diff --git a/Makefile b/Makefile index a9a8ad91a5..4e71008b79 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,8 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \ native/sbuf.o native/stack.o \ native/string.o native/types.o native/vector.o \ native/word.o native/compiler.o \ - native/ffi.o native/boolean.o \ + native/alien.o native/dll.o \ + native/boolean.o \ native/debug.o \ native/hashtable.o \ native/icache.o diff --git a/Makefile.win32 b/Makefile.win32 index 804a9999f0..34383786fc 100644 --- a/Makefile.win32 +++ b/Makefile.win32 @@ -1,5 +1,7 @@ +# :mode=makefile: + CC = gcc -DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS) +DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS) DEFAULT_LIBS = -lm STRIP = strip @@ -8,21 +10,23 @@ WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \ native\win32\misc.o native\win32\read.o native\win32\write.o \ native\win32\run.o -OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \ - native\s48_bignum.o \ - native\complex.o native\cons.o native\error.o \ - native\factor.o native\fixnum.o \ - native\float.o native\gc.o \ - native\image.o native\memory.o \ - native\misc.o native\port.o native\primitives.o \ - native\ratio.o native\relocate.o \ - native\run.o \ - native\sbuf.o native\stack.o \ - native\string.o native\types.o native\vector.o \ - native\word.o native\compiler.o \ - native\ffi.o native\boolean.o \ - native\debug.o \ - native\hashtable.o +OBJS = $(WIN32_OBJS) native/arithmetic.o native/array.o native/bignum.o \ + native/s48_bignum.o \ + native/complex.o native/cons.o native/error.o \ + native/factor.o native/fixnum.o \ + native/float.o native/gc.o \ + native/image.o native/memory.o \ + native/misc.o native/port.o native/primitives.o \ + native/ratio.o native/relocate.o \ + native/run.o \ + native/sbuf.o native/stack.o \ + native/string.o native/types.o native/vector.o \ + native/word.o native/compiler.o \ + native/alien.o native/dll.o \ + native/boolean.o \ + native/debug.o \ + native/hashtable.o \ + native/icache.o default: @echo "Run 'make' with one of the following parameters:" diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor new file mode 100644 index 0000000000..0e6e242c81 --- /dev/null +++ b/library/alien/aliens.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: alien +USING: hashtables kernel lists math namespaces parser +prettyprint stdio unparser ; + +BUILTIN: dll 15 [ 1 "dll-path" f ] ; +BUILTIN: alien 16 ; +BUILTIN: byte-array 19 ; +BUILTIN: displaced-alien 20 ; + +: NULL ( -- null ) + #! C null value. + 0 ; + +: null? ( alien -- ? ) dup [ alien-address 0 = ] when ; + +: null>f ( alien -- alien/f ) + dup alien-address 0 = [ drop f ] when ; + +M: alien hashcode ( obj -- n ) + alien-address >fixnum ; + +M: alien = ( obj obj -- ? ) + over alien? [ + alien-address swap alien-address = + ] [ + 2drop f + ] ifte ; + +: ALIEN: scan swons ; parsing + +M: alien prettyprint* ( alien -- str ) + \ ALIEN: word-bl alien-address unparse write ; + +M: dll unparse ( obj -- str ) + [ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ; + +: DLL" skip-blank parse-string dlopen swons ; parsing + +: library ( name -- object ) + dup [ "libraries" get hash ] when ; + +: load-dll ( name -- dll ) + #! Higher level wrapper around dlopen primitive. + library dup [ + [ + "dll" get dup [ + drop "name" get dlopen dup "dll" set + ] unless + ] bind + ] when ; + +: add-library ( library name abi -- ) + "libraries" get [ + [ + "abi" set + "name" set + ] extend put + ] bind ; + +: library-abi ( library -- abi ) + library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ; diff --git a/library/compiler/alien-types.factor b/library/alien/c-types.factor similarity index 60% rename from library/compiler/alien-types.factor rename to library/alien/c-types.factor index ff791aa9ce..832a99fe9b 100644 --- a/library/compiler/alien-types.factor +++ b/library/alien/c-types.factor @@ -1,29 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: alien -USING: assembler compiler errors hashtables kernel lists math -namespaces parser strings words ; - -! Some code for interfacing with C structures. - -: BEGIN-ENUM: - #! C-style enumerations. Their use is not encouraged unless - #! it is for C library interfaces. Used like this: - #! - #! BEGIN-ENUM 0 - #! ENUM: x - #! ENUM: y - #! ENUM: z - #! END-ENUM - #! - #! This is the same as : x 0 ; : y 1 ; : z 2 ;. - scan str>number ; parsing - -: ENUM: - dup CREATE swap unit define-compound 1 + ; parsing - -: END-ENUM - drop ; parsing +USING: assembler errors hashtables kernel namespaces parser +strings ; : ( -- type ) [ @@ -46,67 +25,7 @@ SYMBOL: c-types : define-c-type ( quot name -- ) c-types get [ >r swap extend r> set ] bind ; inline - -: define-getter ( offset type name -- ) - #! Define a word with stack effect ( alien -- obj ) in the - #! current 'in' vocabulary. - create-in >r - [ "getter" get ] bind cons r> swap define-compound ; - -: define-setter ( offset type name -- ) - #! Define a word with stack effect ( obj alien -- ) in the - #! current 'in' vocabulary. - "set-" swap cat2 create-in >r - [ "setter" get ] bind cons r> swap define-compound ; - -: define-field ( offset type name -- offset ) - >r c-type dup >r [ "align" get ] bind align r> r> - "struct-name" get swap "-" swap cat3 - ( offset type name -- ) - 3dup define-getter 3dup define-setter - drop [ "width" get ] bind + ; - -: define-member ( max type -- max ) - c-type [ "width" get ] bind max ; - -: define-constructor ( width -- ) - #! Make a word where foo is the structure name that - #! allocates a Factor heap-local instance of this structure. - #! Used for C functions that expect you to pass in a struct. - [ ] cons - [ "<" , "struct-name" get , ">" , ] make-string - create-in swap - define-compound ; - -: define-struct-type ( width -- ) - #! Define inline and pointer type for the struct. Pointer - #! type is exactly like void*. - [ "width" set ] "struct-name" get define-c-type - "void*" c-type "struct-name" get "*" cat2 - c-types get set-hash ; - -: BEGIN-STRUCT: ( -- offset ) - scan "struct-name" set 0 ; parsing - -: FIELD: ( offset -- offset ) - scan scan define-field ; parsing - -: END-STRUCT ( length -- ) - dup define-constructor define-struct-type ; parsing - -: BEGIN-UNION: ( -- max ) - scan "struct-name" set 0 ; parsing - -: MEMBER: ( max -- max ) - scan define-member ; parsing - -: END-UNION ( max -- ) - dup define-constructor define-struct-type ; parsing - -: NULL ( -- null ) - #! C null value. - 0 ; - + global [ c-types set ] bind [ diff --git a/library/compiler/alien.factor b/library/alien/compiler.factor similarity index 74% rename from library/compiler/alien.factor rename to library/alien/compiler.factor index 87e7d483e7..73a27326aa 100644 --- a/library/compiler/alien.factor +++ b/library/alien/compiler.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: alien -USING: assembler compiler errors generic hashtables -inference interpreter kernel lists math namespaces parser -prettyprint sequences stdio strings unparser words ; +USING: assembler errors generic inference kernel lists math +namespaces sequences stdio strings words ; ! ! ! WARNING ! ! ! ! Reloading this file into a running Factor instance on Win32 @@ -24,70 +23,11 @@ prettyprint sequences stdio strings unparser words ; ! parameter, or a missing abi parameter indicates the cdecl ABI ! should be used, which is common on Unix. -: null? ( alien -- ? ) dup [ alien-address 0 = ] when ; - -: null>f ( alien -- alien/f ) - dup alien-address 0 = [ drop f ] when ; - -M: alien hashcode ( obj -- n ) - alien-address >fixnum ; - -M: alien = ( obj obj -- ? ) - over alien? [ - over local-alien? over local-alien? or [ - eq? - ] [ - alien-address swap alien-address = - ] ifte - ] [ - 2drop f - ] ifte ; - -: ALIEN: scan swons ; parsing - -: LOCAL-ALIEN: "Local aliens are not readable" throw ; parsing - -M: alien prettyprint* ( alien -- str ) - dup local-alien? [ - \ LOCAL-ALIEN: - ] [ - \ ALIEN: - ] ifte word-bl alien-address unparse write ; - -M: dll unparse ( obj -- str ) - [ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ; - -: DLL" skip-blank parse-string dlopen swons ; parsing - -: library ( name -- object ) - dup [ "libraries" get hash ] when ; - -: load-dll ( name -- dll ) - #! Higher level wrapper around dlopen primitive. - library dup [ - [ - "dll" get dup [ - drop "name" get dlopen dup "dll" set - ] unless - ] bind - ] when ; - -: add-library ( library name abi -- ) - "libraries" get [ - [ - "abi" set - "name" set - ] extend put - ] bind ; - SYMBOL: #cleanup ( unwind stack by parameter ) SYMBOL: #unbox ( move top of datastack to C stack ) SYMBOL: #box ( move EAX to datastack ) -: library-abi ( library -- abi ) - library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ; - SYMBOL: #alien-invoke SYMBOL: #alien-global diff --git a/library/alien/enums.factor b/library/alien/enums.factor new file mode 100644 index 0000000000..dff5314cbe --- /dev/null +++ b/library/alien/enums.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: alien +USING: kernel lists math parser words ; + +: BEGIN-ENUM: + #! C-style enumerations. Their use is not encouraged unless + #! it is for C library interfaces. Used like this: + #! + #! BEGIN-ENUM 0 + #! ENUM: x + #! ENUM: y + #! ENUM: z + #! END-ENUM + #! + #! This is the same as : x 0 ; : y 1 ; : z 2 ;. + scan str>number ; parsing + +: ENUM: + dup CREATE swap unit define-compound 1 + ; parsing + +: END-ENUM + drop ; parsing diff --git a/library/alien/structs.factor b/library/alien/structs.factor new file mode 100644 index 0000000000..fed3393e79 --- /dev/null +++ b/library/alien/structs.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: alien +USING: assembler compiler errors hashtables kernel lists math +namespaces parser strings words ; + +! Some code for interfacing with C structures. + +: define-getter ( offset type name -- ) + #! Define a word with stack effect ( alien -- obj ) in the + #! current 'in' vocabulary. + create-in >r + [ "getter" get ] bind cons r> swap define-compound ; + +: define-setter ( offset type name -- ) + #! Define a word with stack effect ( obj alien -- ) in the + #! current 'in' vocabulary. + "set-" swap cat2 create-in >r + [ "setter" get ] bind cons r> swap define-compound ; + +: define-field ( offset type name -- offset ) + >r c-type dup >r [ "align" get ] bind align r> r> + "struct-name" get swap "-" swap cat3 + ( offset type name -- ) + 3dup define-getter 3dup define-setter + drop [ "width" get ] bind + ; + +: define-member ( max type -- max ) + c-type [ "width" get ] bind max ; + +: define-constructor ( width -- ) + #! Make a word where foo is the structure name that + #! allocates a Factor heap-local instance of this structure. + #! Used for C functions that expect you to pass in a struct. + [ ] cons + [ "<" , "struct-name" get , ">" , ] make-string + create-in swap + define-compound ; + +: define-struct-type ( width -- ) + #! Define inline and pointer type for the struct. Pointer + #! type is exactly like void*. + [ "width" set ] "struct-name" get define-c-type + "void*" c-type "struct-name" get "*" cat2 + c-types get set-hash ; + +: BEGIN-STRUCT: ( -- offset ) + scan "struct-name" set 0 ; parsing + +: FIELD: ( offset -- offset ) + scan scan define-field ; parsing + +: END-STRUCT ( length -- ) + dup define-constructor define-struct-type ; parsing + +: BEGIN-UNION: ( -- max ) + scan "struct-name" set 0 ; parsing + +: MEMBER: ( max -- max ) + scan define-member ; parsing + +: END-UNION ( max -- ) + dup define-constructor define-struct-type ; parsing diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 2dc4a04c18..d983802d80 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -54,6 +54,7 @@ hashtables ; "/library/syntax/prettyprint.factor" "/library/io/files.factor" "/library/cli.factor" + "/library/alien/aliens.factor" ] pull-in "delegate" [ "generic" ] search diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index e8b7a2d347..c06813bccb 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -38,8 +38,9 @@ t [ "/library/compiler/simplifier.factor" "/library/compiler/generator.factor" "/library/compiler/compiler.factor" - "/library/compiler/alien-types.factor" - "/library/compiler/alien.factor" + + "/library/alien/c-types.factor" + "/library/alien/compiler.factor" ] pull-in cpu "x86" = [ diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index 1092a00dca..86f721e137 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -14,6 +14,9 @@ unparser ; ] when t [ + "/library/alien/enums.factor" + "/library/alien/structs.factor" + "/library/math/constants.factor" "/library/math/pow.factor" "/library/math/trig-hyp.factor" diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index dba7086e6d..ec54c9a92f 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -181,7 +181,8 @@ vocabularies get [ [ "dlsym" "alien" [ [ string object ] [ integer ] ] ] [ "dlclose" "alien" [ [ dll ] [ ] ] ] [ "" "alien" [ [ integer ] [ alien ] ] ] - [ "" "alien" [ [ integer ] [ alien ] ] ] + [ "" "alien" [ [ integer ] [ byte-array ] ] ] + [ "" "alien" [ [ integer object ] [ displaced-alien ] ] ] [ "alien-signed-cell" "alien" [ [ alien integer ] [ integer ] ] ] [ "set-alien-signed-cell" "alien" [ [ integer alien integer ] [ ] ] ] [ "alien-unsigned-cell" "alien" [ [ alien integer ] [ integer ] ] ] @@ -206,7 +207,6 @@ vocabularies get [ [ "throw" "errors" [ [ object ] [ ] ] ] [ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ] [ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ] - [ "local-alien?" "alien" [ [ alien ] [ object ] ] ] [ "alien-address" "alien" [ [ alien ] [ integer ] ] ] [ "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] ] [ "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] ] diff --git a/library/kernel.factor b/library/kernel.factor index a60825d36d..973854c219 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -29,7 +29,7 @@ M: object clone ; : num-types ( -- n ) #! One more than the maximum value from type primitive. - 19 ; + 21 ; : ? ( cond t f -- t/f ) #! Push t if cond is true, otherwise push f. @@ -41,10 +41,3 @@ M: object clone ; : not ( a -- ~a ) f t ? ; inline : or ( a b -- a|b ) t swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline - -IN: alien - -! See compiler/alien.factor for the rest; this needs to be here -! since primitive stack effects involve alien inputs/outputs. -BUILTIN: dll 15 [ 1 "dll-path" f ] ; -BUILTIN: alien 16 ; diff --git a/library/sequences-epilogue.factor b/library/sequences-epilogue.factor index 91ddf0c054..4061ba63ca 100644 --- a/library/sequences-epilogue.factor +++ b/library/sequences-epilogue.factor @@ -58,6 +58,15 @@ M: sequence = ( obj seq -- ? ) : >pop> ( stack -- stack ) dup pop drop ; +GENERIC: (tree-each) ( quot obj -- ) inline +M: object (tree-each) swap call ; +M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ; +M: f (tree-each) swap call ; +M: sequence (tree-each) [ swap call ] seq-each-with ; +: tree-each swap (tree-each) ; inline +: tree-each-with ( obj vector quot -- ) + swap [ with ] tree-each 2drop ; inline + IN: kernel : depth ( -- n ) diff --git a/library/test/alien.factor b/library/test/alien.factor index 65f2090396..7e533ab683 100644 --- a/library/test/alien.factor +++ b/library/test/alien.factor @@ -6,10 +6,8 @@ USE: inference [ t ] [ 0 0 = ] unit-test [ f ] [ 0 local-alien? ] unit-test -[ f ] [ 0 1024 = ] unit-test [ f ] [ 0 1024 = ] unit-test [ f ] [ "hello" 1024 = ] unit-test -[ t ] [ 1024 local-alien? ] unit-test ! : alien-inference-1 ! "void" "foobar" "boo" [ "short" "short" ] alien-invoke ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 1e26b591cb..afea41b91f 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -9,7 +9,7 @@ stdio strings ; SYMBOL: clip : intersect* ( gadget rect quot -- t1 t2 ) - call >r >r max r> r> min 2dup > [ drop dup ] when ; + call >r >r max r> r> min 2dup > [ drop dup ] when ; inline : intersect-x ( gadget rect -- x1 x2 ) [ diff --git a/library/win32/winsock.factor b/library/win32/winsock.factor index 3fc03d4faa..547555dab1 100644 --- a/library/win32/winsock.factor +++ b/library/win32/winsock.factor @@ -29,7 +29,7 @@ IN: win32-api USE: alien USE: kernel -: HEX: 190 ; +: HEX: 190 ; : AF_INET 2 ; : SOCK_STREAM 1 ; diff --git a/library/words.factor b/library/words.factor index 777d8f54a0..9ab882cce3 100644 --- a/library/words.factor +++ b/library/words.factor @@ -4,16 +4,6 @@ IN: words USING: generic hashtables kernel kernel-internals lists math namespaces sequences strings vectors ; -! Utility -GENERIC: (tree-each) ( quot obj -- ) inline -M: object (tree-each) swap call ; -M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ; -M: f (tree-each) swap call ; -M: sequence (tree-each) [ swap call ] seq-each-with ; -: tree-each swap (tree-each) ; inline -: tree-each-with ( obj vector quot -- ) - swap [ with ] tree-each 2drop ; inline - ! The basic word type. Words can be named and compared using ! identity. They hold a property map. BUILTIN: word 17 diff --git a/native/alien.c b/native/alien.c new file mode 100644 index 0000000000..6d4ac5d94e --- /dev/null +++ b/native/alien.c @@ -0,0 +1,114 @@ +#include "factor.h" + +INLINE void* alien_offset(CELL object) +{ + ALIEN *alien; + F_ARRAY *array; + DISPLACED_ALIEN *d; + + switch(type_of(object)) + { + case ALIEN_TYPE: + alien = untag_alien_fast(object); + if(alien->expired) + general_error(ERROR_EXPIRED,object); + return alien->ptr; + case BYTE_ARRAY_TYPE: + array = untag_byte_array_fast(object); + return array + sizeof(F_ARRAY); + case DISPLACED_ALIEN_TYPE: + d = untag_displaced_alien_fast(object); + return alien_offset(d->alien) + d->displacement; + default: + type_error(ALIEN_TYPE,object); + return (void*)-1; /* can't happen */ + } +} + +INLINE void* alien_pointer(void) +{ + F_FIXNUM offset = unbox_signed_cell(); + return alien_offset(dpop()) + offset; +} + +void* unbox_alien(void) +{ + return alien_offset(dpop()); +} + +void box_alien(void* ptr) +{ + ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN)); + alien->ptr = ptr; + alien->expired = false; + dpush(tag_object(alien)); +} + +void primitive_alien(void) +{ + void* ptr = (void*)unbox_signed_cell(); + maybe_garbage_collection(); + box_alien(ptr); +} + +void primitive_displaced_alien(void) +{ + CELL alien; + CELL displacement; + DISPLACED_ALIEN* d; + maybe_garbage_collection(); + alien = dpop(); + displacement = unbox_unsigned_cell(); + d = allot_object(DISPLACED_ALIEN_TYPE,sizeof(DISPLACED_ALIEN)); + d->alien = alien; + d->displacement = displacement; + dpush(tag_object(d)); +} + +void primitive_alien_address(void) +{ + box_unsigned_cell((CELL)alien_offset(dpop())); +} + +void fixup_alien(ALIEN* alien) +{ + alien->expired = true; +} + +void fixup_displaced_alien(DISPLACED_ALIEN* d) +{ + data_fixup(&d->alien); +} + +void collect_displaced_alien(DISPLACED_ALIEN* d) +{ + COPY_OBJECT(d->alien); +} + +#define DEF_ALIEN_SLOT(name,type,boxer) \ +void primitive_alien_##name (void) \ +{ \ + box_##boxer (*(type*)alien_pointer()); \ +} \ +void primitive_set_alien_##name (void) \ +{ \ + type* ptr = alien_pointer(); \ + type value = unbox_##boxer (); \ + *ptr = value; \ +} + +DEF_ALIEN_SLOT(signed_cell,int,signed_cell) +DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell) +DEF_ALIEN_SLOT(signed_8,s64,signed_8) +DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8) +DEF_ALIEN_SLOT(signed_4,s32,signed_4) +DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4) +DEF_ALIEN_SLOT(signed_2,s16,signed_2) +DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2) +DEF_ALIEN_SLOT(signed_1,BYTE,signed_1) +DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1) + +void primitive_alien_value_string(void) +{ + box_c_string(alien_pointer()); +} diff --git a/native/ffi.h b/native/alien.h similarity index 65% rename from native/ffi.h rename to native/alien.h index 9a287d6b09..be4a696e69 100644 --- a/native/ffi.h +++ b/native/alien.h @@ -1,43 +1,36 @@ -typedef struct { - CELL header; - /* tagged string */ - CELL path; - /* OS-specific handle */ - void* dll; -} DLL; - -DLL* untag_dll(CELL tagged); - typedef struct { CELL header; void* ptr; - /* local aliens are heap-allocated as strings and must be collected. */ - bool local; + bool expired; } ALIEN; -INLINE ALIEN* untag_alien(CELL tagged) +INLINE ALIEN* untag_alien_fast(CELL tagged) { - type_check(ALIEN_TYPE,tagged); return (ALIEN*)UNTAG(tagged); } -void ffi_dlopen(DLL *dll); -void *ffi_dlsym(DLL *dll, F_STRING *symbol); -void ffi_dlclose(DLL *dll); +typedef struct { + CELL header; + CELL alien; + CELL displacement; +} DISPLACED_ALIEN; + +INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged) +{ + return (DISPLACED_ALIEN*)UNTAG(tagged); +} -void primitive_dlopen(void); -void primitive_dlsym(void); -void primitive_dlclose(void); void primitive_alien(void); -void primitive_local_alien(void); -void fixup_dll(DLL* dll); -void collect_dll(DLL* dll); +void primitive_displaced_alien(void); +void primitive_alien_address(void); + void fixup_alien(ALIEN* alien); -void collect_alien(ALIEN* alien); +void fixup_displaced_alien(DISPLACED_ALIEN* d); +void collect_displaced_alien(DISPLACED_ALIEN* d); + DLLEXPORT void* unbox_alien(void); DLLEXPORT void box_alien(void* ptr); -void primitive_local_alienp(void); -void primitive_alien_address(void); + void primitive_alien_signed_cell(void); void primitive_set_alien_signed_cell(void); void primitive_alien_unsigned_cell(void); diff --git a/native/array.c b/native/array.c index 4d1516d1e8..3dbddc9195 100644 --- a/native/array.c +++ b/native/array.c @@ -32,6 +32,12 @@ void primitive_tuple(void) dpush(tag_object(array(TUPLE_TYPE,to_fixnum(dpop()),F))); } +void primitive_byte_array(void) +{ + maybe_garbage_collection(); + dpush(tag_object(array(BYTE_ARRAY_TYPE,to_fixnum(dpop()),0))); +} + F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) { /* later on, do an optimization: if end of array is here, just grow */ @@ -50,7 +56,7 @@ void primitive_grow_array(void) { F_ARRAY* array; CELL capacity; maybe_garbage_collection(); - array = untag_array(dpop()); + array = untag_array_fast(dpop()); capacity = to_fixnum(dpop()); dpush(tag_object(grow_array(array,capacity,F))); } diff --git a/native/array.h b/native/array.h index 6aa6c07a1a..566737610a 100644 --- a/native/array.h +++ b/native/array.h @@ -4,16 +4,23 @@ typedef struct { CELL capacity; } F_ARRAY; -INLINE F_ARRAY* untag_array(CELL tagged) +INLINE F_ARRAY* untag_array_fast(CELL tagged) +{ + return (F_ARRAY*)UNTAG(tagged); +} + +INLINE F_ARRAY* untag_byte_array_fast(CELL tagged) { - type_check(ARRAY_TYPE,tagged); return (F_ARRAY*)UNTAG(tagged); } F_ARRAY* allot_array(CELL type, CELL capacity); F_ARRAY* array(CELL type, CELL capacity, CELL fill); + void primitive_array(void); void primitive_tuple(void); +void primitive_byte_array(void); + F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); diff --git a/native/debug.c b/native/debug.c index 845f3e9273..d06f183724 100644 --- a/native/debug.c +++ b/native/debug.c @@ -60,7 +60,7 @@ CELL hash(CELL hash, CELL key) return F; } - a = untag_array(array); + a = untag_array_fast(array); for(i = 0; i < array_capacity(a); i++) { diff --git a/native/dll.c b/native/dll.c new file mode 100644 index 0000000000..9e42b1247d --- /dev/null +++ b/native/dll.c @@ -0,0 +1,57 @@ +#include "factor.h" + +void primitive_dlopen(void) +{ + DLL* dll; + F_STRING* path; + + maybe_garbage_collection(); + + path = untag_string(dpop()); + dll = allot_object(DLL_TYPE,sizeof(DLL)); + dll->path = tag_object(path); + ffi_dlopen(dll); + + dpush(tag_object(dll)); +} + +void primitive_dlsym(void) +{ + CELL dll; + F_STRING* sym; + + maybe_garbage_collection(); + + dll = dpop(); + sym = untag_string(dpop()); + + dpush(tag_cell((CELL)ffi_dlsym( + dll == F ? NULL : untag_dll(dll), + sym))); +} + +void primitive_dlclose(void) +{ + maybe_garbage_collection(); + ffi_dlclose(untag_dll(dpop())); +} + +DLL* untag_dll(CELL tagged) +{ + DLL* dll = (DLL*)UNTAG(tagged); + type_check(DLL_TYPE,tagged); + if(dll->dll == NULL) + general_error(ERROR_EXPIRED,tagged); + return (DLL*)UNTAG(tagged); +} + +void fixup_dll(DLL* dll) +{ + data_fixup(&dll->path); + ffi_dlopen(dll); +} + +void collect_dll(DLL* dll) +{ + COPY_OBJECT(dll->path); +} diff --git a/native/dll.h b/native/dll.h new file mode 100644 index 0000000000..4f659af13f --- /dev/null +++ b/native/dll.h @@ -0,0 +1,20 @@ +typedef struct { + CELL header; + /* tagged string */ + CELL path; + /* OS-specific handle */ + void* dll; +} DLL; + +DLL* untag_dll(CELL tagged); + +void ffi_dlopen(DLL *dll); +void *ffi_dlsym(DLL *dll, F_STRING *symbol); +void ffi_dlclose(DLL *dll); + +void primitive_dlopen(void); +void primitive_dlsym(void); +void primitive_dlclose(void); + +void fixup_dll(DLL* dll); +void collect_dll(DLL* dll); diff --git a/native/factor.h b/native/factor.h index 9297e3f311..05f94aead7 100644 --- a/native/factor.h +++ b/native/factor.h @@ -144,7 +144,8 @@ typedef unsigned char BYTE; #include "stack.h" #include "compiler.h" #include "relocate.h" -#include "ffi.h" +#include "alien.h" +#include "dll.h" #include "debug.h" #endif /* __FACTOR_H__ */ diff --git a/native/ffi.c b/native/ffi.c deleted file mode 100644 index 1143cb6a7d..0000000000 --- a/native/ffi.c +++ /dev/null @@ -1,159 +0,0 @@ -#include "factor.h" - -void foo(int fd) { close(fd); } - -void primitive_dlopen(void) -{ - DLL* dll; - F_STRING* path; - - maybe_garbage_collection(); - - path = untag_string(dpop()); - dll = allot_object(DLL_TYPE,sizeof(DLL)); - dll->path = tag_object(path); - ffi_dlopen(dll); - - dpush(tag_object(dll)); -} - -void primitive_dlsym(void) -{ - CELL dll; - F_STRING* sym; - - maybe_garbage_collection(); - - dll = dpop(); - sym = untag_string(dpop()); - - dpush(tag_cell((CELL)ffi_dlsym( - dll == F ? NULL : untag_dll(dll), - sym))); -} - -void primitive_dlclose(void) -{ - maybe_garbage_collection(); - ffi_dlclose(untag_dll(dpop())); -} - -DLL* untag_dll(CELL tagged) -{ - DLL* dll = (DLL*)UNTAG(tagged); - type_check(DLL_TYPE,tagged); - if(dll->dll == NULL) - general_error(ERROR_EXPIRED,tagged); - return (DLL*)UNTAG(tagged); -} - -void* unbox_alien(void) -{ - return untag_alien(dpop())->ptr; -} - -void box_alien(void* ptr) -{ - ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN)); - alien->ptr = ptr; - alien->local = false; - dpush(tag_object(alien)); -} - -INLINE void* alien_pointer(void) -{ - F_FIXNUM offset = unbox_signed_cell(); - ALIEN* alien = untag_alien(dpop()); - void* ptr = alien->ptr; - - if(ptr == NULL) - general_error(ERROR_EXPIRED,tag_object(alien)); - - return ptr + offset; -} - -void primitive_alien(void) -{ - void* ptr = (void*)unbox_signed_cell(); - maybe_garbage_collection(); - box_alien(ptr); -} - -void primitive_local_alien(void) -{ - F_FIXNUM length = unbox_signed_cell(); - ALIEN* alien; - F_STRING* local; - if(length < 0) - general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(length)); - maybe_garbage_collection(); - alien = allot_object(ALIEN_TYPE,sizeof(ALIEN)); - local = string(length / CHARS,'\0'); - alien->ptr = (void*)(local + 1); - alien->local = true; - dpush(tag_object(alien)); -} - -void primitive_local_alienp(void) -{ - box_boolean(untag_alien(dpop())->local); -} - -void primitive_alien_address(void) -{ - box_unsigned_cell((CELL)untag_alien(dpop())->ptr); -} - -void fixup_dll(DLL* dll) -{ - data_fixup(&dll->path); - ffi_dlopen(dll); -} - -void collect_dll(DLL* dll) -{ - COPY_OBJECT(dll->path); -} - -void fixup_alien(ALIEN* alien) -{ - alien->ptr = NULL; -} - -void collect_alien(ALIEN* alien) -{ - if(alien->local && alien->ptr != NULL) - { - F_STRING* ptr = (F_STRING*)(alien->ptr - sizeof(F_STRING)); - ptr = copy_untagged_object(ptr,SSIZE(ptr)); - alien->ptr = (void*)(ptr + 1); - } -} - -#define DEF_ALIEN_SLOT(name,type,boxer) \ -void primitive_alien_##name (void) \ -{ \ - box_##boxer (*(type*)alien_pointer()); \ -} \ -void primitive_set_alien_##name (void) \ -{ \ - type* ptr = alien_pointer(); \ - type value = unbox_##boxer (); \ - *ptr = value; \ -} - -DEF_ALIEN_SLOT(signed_cell,int,signed_cell) -DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell) -DEF_ALIEN_SLOT(signed_8,s64,signed_8) -DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8) -DEF_ALIEN_SLOT(signed_4,s32,signed_4) -DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4) -DEF_ALIEN_SLOT(signed_2,s16,signed_2) -DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2) -DEF_ALIEN_SLOT(signed_1,BYTE,signed_1) -DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1) - -void primitive_alien_value_string(void) -{ - box_c_string(alien_pointer()); -} diff --git a/native/gc.c b/native/gc.c index a9cf5bd20e..5b23fa5310 100644 --- a/native/gc.c +++ b/native/gc.c @@ -79,12 +79,12 @@ INLINE void collect_object(CELL scan) case PORT_TYPE: collect_port((F_PORT*)scan); break; - case ALIEN_TYPE: - collect_alien((ALIEN*)scan); - break; case DLL_TYPE: collect_dll((DLL*)scan); break; + case DISPLACED_ALIEN_TYPE: + collect_displaced_alien((DISPLACED_ALIEN*)scan); + break; } } diff --git a/native/primitives.c b/native/primitives.c index 8c8398fd39..624c6a320d 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -145,7 +145,8 @@ void* primitives[] = { primitive_dlsym, primitive_dlclose, primitive_alien, - primitive_local_alien, + primitive_byte_array, + primitive_displaced_alien, primitive_alien_signed_cell, primitive_set_alien_signed_cell, primitive_alien_unsigned_cell, @@ -170,7 +171,6 @@ void* primitives[] = { primitive_throw, primitive_string_to_memory, primitive_memory_to_string, - primitive_local_alienp, primitive_alien_address, primitive_slot, primitive_set_slot, diff --git a/native/relocate.c b/native/relocate.c index d1ff0c7adc..bf09694dc0 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -32,6 +32,9 @@ void relocate_object(CELL relocating) case ALIEN_TYPE: fixup_alien((ALIEN*)relocating); break; + case DISPLACED_ALIEN_TYPE: + fixup_displaced_alien((DISPLACED_ALIEN*)relocating); + break; } } diff --git a/native/stack.c b/native/stack.c index edb49928e4..b7eaba4927 100644 --- a/native/stack.c +++ b/native/stack.c @@ -75,7 +75,7 @@ F_VECTOR* stack_to_vector(CELL bottom, CELL top) { CELL depth = (top - bottom + CELLS) / CELLS; F_VECTOR* v = vector(depth); - F_ARRAY* a = untag_array(v->array); + F_ARRAY* a = untag_array_fast(v->array); memcpy(a + 1,(void*)bottom,depth * CELLS); v->top = tag_fixnum(depth); return v; @@ -98,7 +98,7 @@ CELL vector_to_stack(F_VECTOR* vector, CELL bottom) { CELL start = bottom; CELL len = untag_fixnum_fast(vector->top) * CELLS; - memcpy((void*)start,untag_array(vector->array) + 1,len); + memcpy((void*)start,untag_array_fast(vector->array) + 1,len); return start + len - CELLS; } diff --git a/native/types.c b/native/types.c index 1ef6cd8a0b..a1dc1447a1 100644 --- a/native/types.c +++ b/native/types.c @@ -52,8 +52,9 @@ CELL untagged_object_size(CELL pointer) size = CELLS * 2; break; case ARRAY_TYPE: - case BIGNUM_TYPE: case TUPLE_TYPE: + case BIGNUM_TYPE: + case BYTE_ARRAY_TYPE: size = align8(sizeof(F_ARRAY) + array_capacity((F_ARRAY*)(pointer)) * CELLS); break; @@ -81,6 +82,9 @@ CELL untagged_object_size(CELL pointer) case ALIEN_TYPE: size = sizeof(ALIEN); break; + case DISPLACED_ALIEN_TYPE: + size = sizeof(DISPLACED_ALIEN); + break; default: critical_error("Cannot determine size",pointer); size = -1;/* can't happen */ diff --git a/native/types.h b/native/types.h index a5c51fb60a..3ae675e96c 100644 --- a/native/types.h +++ b/native/types.h @@ -36,8 +36,10 @@ CELL T; #define ALIEN_TYPE 16 #define WORD_TYPE 17 #define TUPLE_TYPE 18 +#define BYTE_ARRAY_TYPE 19 +#define DISPLACED_ALIEN_TYPE 20 -#define TYPE_COUNT 19 +#define TYPE_COUNT 21 INLINE bool headerp(CELL cell) {