From 36061514babed23026e74eff99b4479fc0711c55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Sep 2004 01:02:48 +0000 Subject: [PATCH] better C type support in FFI --- Makefile | 2 +- TODO.FACTOR.txt | 1 + library/compiler/alien-macros.factor | 51 +++++++ library/compiler/alien-types.factor | 149 +++++++++++++++++++++ library/compiler/assembler.factor | 6 +- library/compiler/assembly-x86.factor | 31 ----- library/compiler/compiler-macros.factor | 59 ++++++++ library/cross-compiler.factor | 4 + library/math/math.factor | 3 + library/platform/native/boot-stage2.factor | 3 + library/platform/native/primitives.factor | 2 + library/test/crashes.factor | 23 ++++ library/test/math/bitops.factor | 6 + native/ffi.c | 26 ++++ native/ffi.h | 3 + native/primitives.c | 2 + native/primitives.h | 2 +- native/types.h | 18 ++- 18 files changed, 349 insertions(+), 42 deletions(-) create mode 100644 library/compiler/alien-macros.factor create mode 100644 library/compiler/alien-types.factor create mode 100644 library/compiler/compiler-macros.factor diff --git a/Makefile b/Makefile index 6d9ffb2200..7582c93a58 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ CC = gcc # On FreeBSD, to use SDL and other libc_r libs: -CFLAGS = -Os -g -Wall -pthread -export-dynamic +CFLAGS = -g -Wall -pthread -export-dynamic # On PowerPC G5: # CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3 # On Pentium 4: diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 2e274e549e..d31834f077 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -4,6 +4,7 @@ FFI: [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/) [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/) +- profiler is inaccurate: wrong word on cs - buffer change handler in sidekick is screwed - dec> bin> oct> hex> throw errors - parse-number doesn't diff --git a/library/compiler/alien-macros.factor b/library/compiler/alien-macros.factor new file mode 100644 index 0000000000..34590585a4 --- /dev/null +++ b/library/compiler/alien-macros.factor @@ -0,0 +1,51 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: alien +USE: compiler +USE: lists +USE: namespaces +USE: stack + +: UNBOX ( name -- ) + #! Move top of datastack to C stack. + dlsym-self CALL drop + EAX PUSH-R ; + +: BOX ( name -- ) + #! Move EAX to datastack. + 24 ESP R-I + EAX PUSH-R + dlsym-self CALL drop + 28 ESP R+I ; + +: PARAMETERS ( list -- ) + #! Generate code for boxing a list of C types. + [ c-type [ "unboxer" get ] bind UNBOX ] each ; + +: RETURNS ( type -- ) + c-type [ "boxer" get ] bind BOX ; diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor new file mode 100644 index 0000000000..9dbb76a348 --- /dev/null +++ b/library/compiler/alien-types.factor @@ -0,0 +1,149 @@ +! :folding=indent:collapseFolds=0: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: alien +USE: combinators +USE: compiler +USE: errors +USE: lists +USE: math +USE: namespaces +USE: stack +USE: strings +USE: words + +! Some code for interfacing with C structures. + +: ( -- type ) + [ + [ "No setter" throw ] "setter" set + [ "No getter" throw ] "getter" set + "no boxer" "boxer" set + "no unboxer" "unboxer" set + 0 "width" set + ] extend ; + +: c-types ( -- ns ) + global [ "c-types" get ] bind ; + +: c-type ( name -- type ) + global [ + dup "c-types" get get* dup [ + nip + ] [ + drop "No such C type: " swap cat2 throw + ] ifte + ] bind ; + +: define-c-type ( quot name -- ) + c-types [ >r swap extend r> set ] bind ; + +: define-getter ( offset type name -- ) + #! Define a word with stack effect ( alien -- obj ) in the + #! current 'in' vocabulary. + "in" get create >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 "in" get create >r + [ "setter" get ] bind cons r> swap define-compound ; + +: define-field ( offset spec -- offset ) + unswons >r c-type dup >r [ "width" 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-constructor ( len -- ) + [ ] cons + <% "<" % "struct-name" get % ">" % %> "in" get create swap + define-compound ; + +: define-struct-type ( len -- ) + #! For example, if len is 32, make a C type with getter: + #! [ 32 >r alien-cell r> ] cons + #! The setter just throws an error for now. + [ + [ >r alien-cell r> ] cons "getter" set + "unbox_alien" "unboxer" set + cell "width" set + ] "struct-name" get "*" cat2 define-c-type ; + +: define-struct ( spec name -- ) + #! Define a set of words for working with a C structure + #! alien. + [ + "struct-name" set + 0 swap [ define-field ] each + dup define-constructor + define-struct-type + ] with-scope ; + +global [ "c-types" set ] bind + +[ + [ alien-cell ] "getter" set + [ set-alien-cell ] "setter" set + cell "width" set + "does_not_exist" "boxer" set + "unbox_alien" "unboxer" set +] "void*" define-c-type + +[ + [ alien-4 ] "getter" set + [ set-alien-4 ] "setter" set + 4 "width" set + "box_integer" "boxer" set + "unbox_integer" "unboxer" set +] "int" define-c-type + +[ + [ alien-2 ] "getter" set + [ set-alien-2 ] "setter" set + 2 "width" set + "box_integer" "boxer" set + "unbox_integer" "unboxer" set +] "short" define-c-type + +[ + [ alien-1 ] "getter" set + [ set-alien-1 ] "setter" set + 1 "width" set + "box_integer" "boxer" set + "unbox_integer" "unboxer" set +] "char" define-c-type + +[ + [ alien-4 ] "getter" set + [ set-alien-4 ] "setter" set + cell "width" set + "box_c_string" "boxer" set + "unbox_c_string" "unboxer" set +] "char*" define-c-type diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index 1466530bd3..4b772c2746 100644 --- a/library/compiler/assembler.factor +++ b/library/compiler/assembler.factor @@ -38,11 +38,7 @@ USE: stack compiled-offset literal-table + set-compiled-offset ; : compile-aligned ( n -- ) - dup compiled-offset mod dup 0 = [ - 2drop - ] [ - - compiled-offset + set-compiled-offset - ] ifte ; + compiled-offset swap align set-compiled-offset ; : intern-literal ( obj -- lit# ) address-of diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor index 36eec34103..0b71d35977 100644 --- a/library/compiler/assembly-x86.factor +++ b/library/compiler/assembly-x86.factor @@ -147,37 +147,6 @@ USE: combinators compile-cell ] ifte ; -: LITERAL ( cell -- ) - #! Push literal on data stack. - #! Assume that it is ok to clobber EAX without saving. - DATASTACK EAX [I]>R - EAX I>[R] - 4 DATASTACK I+[I] ; - -: [LITERAL] ( cell -- ) - #! Push complex literal on data stack by following an - #! indirect pointer. - ECX PUSH-R - ( cell -- ) ECX [I]>R - DATASTACK EAX [I]>R - ECX EAX R>[R] - 4 DATASTACK I+[I] - ECX POP-R ; - -: PUSH-DS ( -- ) - #! Push contents of EAX onto datastack. - ECX PUSH-R - DATASTACK ECX [I]>R - EAX ECX R>[R] - 4 DATASTACK I+[I] - ECX POP-R ; - -: POP-DS ( -- ) - #! Pop datastack, store pointer to datastack top in EAX. - DATASTACK EAX [I]>R - 4 EAX R-I - EAX DATASTACK R>[I] ; - : fixup ( addr where -- ) #! Encode a relative offset to addr from where at where. #! Add 4 because addr is relative to *after* insn. diff --git a/library/compiler/compiler-macros.factor b/library/compiler/compiler-macros.factor new file mode 100644 index 0000000000..d2f8440ccb --- /dev/null +++ b/library/compiler/compiler-macros.factor @@ -0,0 +1,59 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: compiler + +: LITERAL ( cell -- ) + #! Push literal on data stack. + #! Assume that it is ok to clobber EAX without saving. + DATASTACK EAX [I]>R + EAX I>[R] + 4 DATASTACK I+[I] ; + +: [LITERAL] ( cell -- ) + #! Push complex literal on data stack by following an + #! indirect pointer. + ECX PUSH-R + ( cell -- ) ECX [I]>R + DATASTACK EAX [I]>R + ECX EAX R>[R] + 4 DATASTACK I+[I] + ECX POP-R ; + +: PUSH-DS ( -- ) + #! Push contents of EAX onto datastack. + ECX PUSH-R + DATASTACK ECX [I]>R + EAX ECX R>[R] + 4 DATASTACK I+[I] + ECX POP-R ; + +: POP-DS ( -- ) + #! Pop datastack, store pointer to datastack top in EAX. + DATASTACK EAX [I]>R + 4 EAX R-I + EAX DATASTACK R>[I] ; diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 76a4689d80..8641246eed 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -50,6 +50,8 @@ DEFER: alien-cell DEFER: set-alien-cell DEFER: alien-4 DEFER: set-alien-4 +DEFER: alien-2 +DEFER: set-alien-2 DEFER: alien-1 DEFER: set-alien-1 @@ -370,6 +372,8 @@ IN: image set-alien-cell alien-4 set-alien-4 + alien-2 + set-alien-2 alien-1 set-alien-1 ] [ diff --git a/library/math/math.factor b/library/math/math.factor index ecc3897a6a..3c12286888 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -78,3 +78,6 @@ USE: stack : polar> ( abs arg -- z ) cis * ; inline + +: align ( offset width -- offset ) + 2dup mod dup 0 = [ 2drop ] [ - + ] ifte ; diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index b0027006d6..d194b45267 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -133,8 +133,11 @@ USE: stdio "/library/compiler/assembler.factor" "/library/compiler/assembly-x86.factor" + "/library/compiler/compiler-macros.factor" "/library/compiler/compiler.factor" "/library/compiler/words.factor" + "/library/compiler/alien-types.factor" + "/library/compiler/alien-macros.factor" "/library/platform/native/primitives.factor" diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index aa8bb6b7c4..f9937d04dc 100644 --- a/library/platform/native/primitives.factor +++ b/library/platform/native/primitives.factor @@ -228,6 +228,8 @@ USE: words [ set-alien-cell | " n alien off -- " ] [ alien-4 | " alien off -- n " ] [ set-alien-4 | " n alien off -- " ] + [ alien-2 | " alien off -- n " ] + [ set-alien-2 | " n alien off -- " ] [ alien-1 | " alien off -- n " ] [ set-alien-1 | " n alien off -- " ] ] [ diff --git a/library/test/crashes.factor b/library/test/crashes.factor index f528f0e45b..e9a1c63a38 100644 --- a/library/test/crashes.factor +++ b/library/test/crashes.factor @@ -8,6 +8,7 @@ USE: stack USE: strings USE: test USE: vectors +USE: lists ! Various things that broke CFactor at various times. ! This should run without issue (and tests nothing useful) @@ -32,3 +33,25 @@ USE: vectors 10 [ [ -1000000 ] [ drop ] catch ] times 10 [ [ -1000000 ] [ drop ] catch ] times + +! Make sure various type checks don't run into header untagging +! problems etc. + +! Lotype -vs- lotype +[ ] [ [ 4 car ] [ drop ] catch ] unit-test + +! Lotype -vs- hitype +[ ] [ [ 4 vector-length ] [ drop ] catch ] unit-test +[ ] [ [ [ 4 3 ] vector-length ] [ drop ] catch ] unit-test + +! Hitype -vs- lotype +[ ] [ [ "hello" car ] [ drop ] catch ] unit-test + +! Hitype -vs- hitype +[ ] [ [ "hello" vector-length ] [ drop ] catch ] unit-test + +! f -vs- lotype +[ ] [ [ f car ] [ drop ] catch ] unit-test + +! f -vs- hitype +[ ] [ [ f vector-length ] [ drop ] catch ] unit-test diff --git a/library/test/math/bitops.factor b/library/test/math/bitops.factor index a31c8a4159..fd39b8c992 100644 --- a/library/test/math/bitops.factor +++ b/library/test/math/bitops.factor @@ -48,3 +48,9 @@ USE: lists -1 over shift swap -1 >bignum swap shift = and ] each ] unit-test + +[ 12 ] [ 11 4 align ] unit-test +[ 12 ] [ 12 4 align ] unit-test +[ 12 ] [ 10 2 align ] unit-test +[ 14 ] [ 13 2 align ] unit-test +[ 11 ] [ 11 1 align ] unit-test diff --git a/native/ffi.c b/native/ffi.c index 8b600b4251..e2d737ff95 100644 --- a/native/ffi.c +++ b/native/ffi.c @@ -81,6 +81,11 @@ void primitive_alien(void) #endif } +ALIEN* unbox_alien(void) +{ + return untag_alien(dpop())->ptr; +} + INLINE CELL alien_pointer(void) { FIXNUM offset = unbox_integer(); @@ -135,6 +140,27 @@ void primitive_set_alien_4(void) #endif } +void primitive_alien_2(void) +{ +#ifdef FFI + CELL ptr = alien_pointer(); + box_integer(*(CHAR*)ptr); +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} + +void primitive_set_alien_2(void) +{ +#ifdef FFI + CELL ptr = alien_pointer(); + CELL value = unbox_integer(); + *(CHAR*)ptr = value; +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} + void primitive_alien_1(void) { #ifdef FFI diff --git a/native/ffi.h b/native/ffi.h index 90309ec00a..f5cf6c2d54 100644 --- a/native/ffi.h +++ b/native/ffi.h @@ -26,9 +26,12 @@ void primitive_dlsym(void); void primitive_dlsym_self(void); void primitive_dlclose(void); void primitive_alien(void); +ALIEN* unbox_alien(void); void primitive_alien_cell(void); void primitive_set_alien_cell(void); void primitive_alien_4(void); void primitive_set_alien_4(void); +void primitive_alien_2(void); +void primitive_set_alien_2(void); void primitive_alien_1(void); void primitive_set_alien_1(void); diff --git a/native/primitives.c b/native/primitives.c index 52012aceb7..bfd229424c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -187,6 +187,8 @@ XT primitives[] = { primitive_set_alien_cell, primitive_alien_4, primitive_set_alien_4, + primitive_alien_2, + primitive_set_alien_2, primitive_alien_1, primitive_set_alien_1 }; diff --git a/native/primitives.h b/native/primitives.h index 7698bf623a..521fd4500b 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 188 +#define PRIMITIVE_COUNT 190 CELL primitive_to_xt(CELL primitive); diff --git a/native/types.h b/native/types.h index b75fcaadc7..c25d03e7e3 100644 --- a/native/types.h +++ b/native/types.h @@ -83,11 +83,21 @@ INLINE void type_check(CELL type, CELL tagged) { if(type < HEADER_TYPE) { - if(TAG(tagged) != type) - type_error(type,tagged); + if(TAG(tagged) == type) + return; } - else if(object_type(tagged) != type) - type_error(type,tagged); + else if(tagged == F) + { + if(type == F_TYPE) + return; + } + else if(TAG(tagged) == OBJECT_TYPE + && object_type(tagged) == type) + { + return; + } + + type_error(type,tagged); } void* allot_object(CELL type, CELL length);