FFI:\r
- is signed -vs- unsigned pointers an issue?\r
\r
+- symbols are not primitives\r
+\r
[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/)\r
[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/)\r
\r
--- /dev/null
+SOME NOTES ON FACTOR'S FFI
+
+The FFI is quite a neat design and I think it is better than JNI and
+similar approaches. Also, it offers better performance than libffi et
+al. Of course, both of those technologies are great and Factor FFI has
+its drawbacks -- namely, its not portable.
+
+All FFI words are in the "alien" vocabulary.
+
+The basic principle is generating machine stubs from C function
+prototypes. The main entry point is the 'alien-call' word, which is
+defined as simply throwing an error. However, it is given special
+compilation behavior. This means it can only be used in compiled words.
+
+Here is an example from sdl-video.factor:
+
+: SDL_LockSurface ( surface -- )
+ "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; compiled
+
+The parameters are:
+
+"int" - return type. later it will be surface*
+"sdl" - library
+"SDL_LockSurface" - function
+[ "surface*" ] - parameters
+
+Note the word ends with 'compiled'. This is a hack and won't be needed
+later.
+
+Parameters and return values are C type names. C types include the
+following:
+
+- char - 1 byte signed
+- short - 2 bytes signed
+- int - 4 bytes signed
+- void* - word-size width field, can only be used as a parameter
+
+Structs can be defined in this fashion:
+
+BEGIN-STRUCT: point
+ FIELD: int x
+ FIELD: int y
+END-STRUCT
+
+And then referred to in parameter type specifiers as "point*". Struct
+return values are not yet supported.
+
+Enumerations can be defined; they simply become words that push
+integers:
+
+BEGIN-ENUM: 0
+ ENUM: int xuzzy
+ ENUM: int bax
+END-ENUM
+
+The parameter to BEGIN-ENUM specifies the starting index.
: UNBOX ( name -- )
#! Move top of datastack to C stack.
- dlsym-self CALL drop
+ dlsym-self CALL JUMP-FIXUP
EAX PUSH-R ;
: BOX ( name -- )
#! Move EAX to datastack.
24 ESP R-I
EAX PUSH-R
- dlsym-self CALL drop
+ dlsym-self CALL JUMP-FIXUP
28 ESP R+I ;
: PARAMETERS ( params -- count )
USE: words
: BEGIN-ENUM:
- #! C-style enumartions. Their use is not encouraged unless
+ #! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
: compile-alien-call
pop-literal reverse PARAMETERS >r
- pop-literal pop-literal alien-function CALL drop
+ pop-literal pop-literal alien-function CALL JUMP-FIXUP
r> CLEANUP
pop-literal RETURNS ;
global [ <namespace> "libraries" set ] bind
[ alien-call compile-alien-call ]
-unswons "compiling" swap set-word-property
+unswons "compiling" set-word-property
compile-cell
] ifte ;
-: fixup ( addr where -- )
+: JUMP-FIXUP ( addr where -- )
#! Encode a relative offset to addr from where at where.
#! Add 4 because addr is relative to *after* insn.
dup >r 4 + - r> set-compiled-cell ;
: (JUMP) ( xt -- fixup )
#! addr is relative to *after* insn
- compiled-offset dup >r 4 + - compile-cell r> ;
+ compiled-offset 0 compile-cell ;
-: JUMP ( xt -- fixup )
+: JUMP ( -- fixup )
#! Push address of branch for fixup
HEX: e9 compile-byte (JUMP) ;
-: CALL ( xt -- fixup )
+: CALL ( -- fixup )
HEX: e8 compile-byte (JUMP) ;
-: JE ( xt -- fixup )
- HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
+: JE ( -- fixup )
+ HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
: RET ( -- )
HEX: c3 compile-byte ;
IN: compiler
USE: combinators
USE: errors
+USE: hashtables
USE: kernel
USE: lists
USE: logic
USE: vectors
USE: words
+! We use a hashtable "compiled-xts" that maps words to
+! xt's that are currently being compiled. The commit-xt's word
+! sets the xt of each word in the hashtable to the value in the
+! hastable.
+!
+! This has the advantage that we can compile a word before the
+! words it depends on and perform a fixup later; among other
+! things this enables mutually recursive words.
+
+SYMBOL: compiled-xts
+
+: save-xt ( word -- )
+ cell compile-aligned
+ compiled-offset swap compiled-xts acons@ ;
+
+: commit-xts ( -- )
+ compiled-xts get [ unswons set-word-xt ] each
+ compiled-xts off ;
+
+: compiled-xt ( word -- xt )
+ dup compiled-xts get assoc dup [
+ nip
+ ] [
+ drop word-xt
+ ] ifte ;
+
+! "fixup-xts" is a list of [ where | word ] pairs; the xt of
+! word when its done compiling will be written to the offset.
+
+SYMBOL: deferred-xts
+
+: defer-xt ( word where -- )
+ #! After word is compiled, put a call to it at offset.
+ deferred-xts acons@ ;
+
+: fixup-deferred-xt ( where word -- )
+ compiled-xt swap JUMP-FIXUP ;
+
+: fixup-deferred-xts ( -- )
+ deferred-xts get [ uncons fixup-deferred-xt ] each
+ deferred-xts off ;
+
+! Words being compiled are consed onto this list. When a word
+! is encountered that has not been previously compiled, it is
+! consed onto this list. Compilation stops when the list is
+! empty.
+
+SYMBOL: compile-words
+
+: postpone-word ( word -- )
+ t over "compiled" set-word-property
+ compile-words cons@ ;
+
+! During compilation, these two variables store pending
+! literals. Literals are either consumed at compile-time by
+! words with special compilation behavior, or otherwise they are
+! compiled into code that pushes them.
+
+SYMBOL: compile-datastack
+SYMBOL: compile-callstack
+
: pop-literal ( -- obj )
- "compile-datastack" get vector-pop ;
+ compile-datastack get vector-pop ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
] ifte ;
: commit-literals ( -- )
- "compile-datastack" get
+ compile-datastack get
dup vector-empty? [
drop
] [
0 swap set-vector-length
] ifte ;
-: postpone ( obj -- )
+: postpone-literal ( obj -- )
#! Literals are not compiled immediately, so that words like
#! ifte with special compilation behavior can work.
- "compile-datastack" get vector-push ;
+ compile-datastack get vector-push ;
: tail? ( -- ? )
- "compile-callstack" get vector-empty? ;
+ compile-callstack get vector-empty? ;
-: compiled-xt ( word -- xt )
- "compiled-xt" over word-property dup [
- nip
- ] [
- drop word-xt
- ] ifte ;
+: compiled? ( word -- ? )
+ #! This is a hack.
+ dup "compiled" word-property swap primitive? or ;
: compile-simple-word ( word -- )
#! Compile a JMP at the end (tail call optimization)
- commit-literals compiled-xt
- tail? [ JUMP ] [ CALL ] ifte drop ;
+ dup compiled? [ dup postpone-word ] unless
+ commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ;
: compile-word ( word -- )
#! If a word has a compiling property, then it has special
#! compilation behavior.
- "compiling" over word-property dup [
+ dup "compiling" word-property dup [
nip call
] [
drop compile-simple-word
] ifte ;
: begin-compiling-quot ( quot -- )
- "compile-callstack" get vector-push ;
+ compile-callstack get vector-push ;
: end-compiling-quot ( -- )
- "compile-callstack" get vector-pop drop ;
+ compile-callstack get vector-pop drop ;
: compiling ( quot -- )
#! Called on each iteration of compile-loop, with the
#! remaining quotation.
[
- "compile-callstack" get
+ compile-callstack get
dup vector-length pred
swap set-vector-nth
] [
] ifte* ;
: compile-atom ( obj -- )
- dup word? [ compile-word ] [ postpone ] ifte ;
+ dup word? [ compile-word ] [ postpone-literal ] ifte ;
: compile-loop ( quot -- )
[
: with-compiler ( quot -- )
[
- 10 <vector> "compile-datastack" set
- 10 <vector> "compile-callstack" set
+ 10 <vector> compile-datastack set
+ 10 <vector> compile-callstack set
call
+ fixup-deferred-xts
+ commit-xts
] with-scope ;
-: begin-compiling ( word -- )
- cell compile-aligned
- compiled-offset "compiled-xt" rot set-word-property ;
+: (compile) ( word -- )
+ #! Should be called inside the with-compiler scope.
+ intern dup save-xt word-parameter compile-quot RET ;
-: end-compiling ( word -- xt )
- "compiled-xt" over word-property over set-word-xt
- f "compiled-xt" rot set-word-property ;
+: compile-postponed ( -- )
+ compile-words get [
+ uncons compile-words set (compile) compile-postponed
+ ] when* ;
: compile ( word -- )
- intern dup
- begin-compiling
- dup word-parameter [ compile-quot RET ] with-compiler
- end-compiling ;
+ [ postpone-word compile-postponed ] with-compiler ;
: compiled word compile ; parsing
POP-DS
! ptr to condition is now in EAX
f address EAX CMP-I-[R]
- compiled-offset JE ;
+ ! jump w/ address added later
+ JE ;
: branch-target ( fixup -- )
- cell compile-aligned compiled-offset swap fixup ;
+ cell compile-aligned compiled-offset swap JUMP-FIXUP ;
: compile-else ( fixup -- fixup )
#! Push addr where we write the branch target address,
#! and fixup branch target address from compile-f-test.
#! Push f for the fixup if we're tail position.
- tail? [ RET f ] [ 0 JUMP ] ifte swap branch-target ;
+ tail? [ RET f ] [ JUMP ] ifte swap branch-target ;
: compile-end-if ( fixup -- )
tail? [ drop RET ] [ branch-target ] ifte ;
[
[ ifte compile-ifte ]
] [
- unswons "compiling" swap set-word-property
+ unswons "compiling" set-word-property
] each
IN: image
: primitives, ( -- )
- 1 [
+ 2 [
execute
call
ifte
: word-line/file ( word -- line dir file )
#! Note that line numbers here start from 1
- "line" over word-property swap
- "file" swap word-property word-file ;
+ dup "line" word-property swap "file" word-property
+ word-file ;
: jedit ( word -- )
intern dup [
#! Prepend x to the list stored in var.
tuck get cons put ;
+: acons@ ( value key var -- )
+ #! Prepend [ key | value ] to the alist stored in var.
+ [ get acons ] keep set ;
+
+: uncons@ ( var -- car )
+ #! Push the car of the list in var, and set the var to the
+ #! cdr.
+ dup get uncons rot set ;
+
: remove@ ( obj var -- )
#! Remove all occurrences of the object from the list
#! stored in the variable.
: cdr= swap cdr swap cdr = ;
: cons= ( obj cons -- ? )
- over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ;
+ 2dup eq? [
+ 2drop t
+ ] [
+ over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte
+ ] ifte ;
: cons-hashcode ( cons count -- hash )
dup 0 = [
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
+USE: combinators
+USE: errors
USE: kernel
USE: lists
USE: parser
USE: stack
+USE: strings
USE: stdio
"Cold boot in progress..." print
-
[
"/library/platform/native/kernel.factor"
"/library/platform/native/stack.factor"
! Colon defs
: CREATE ( -- word )
scan "in" get create dup set-word
- f "documentation" pick set-word-property
- f "stack-effect" pick set-word-property ;
+ f over "documentation" set-word-property
+ f over "stack-effect" set-word-property ;
: remember-where ( word -- )
- "line-number" get "line" pick set-word-property
- "col" get "col" pick set-word-property
- "file" get "file" pick set-word-property
+ "line-number" get over "line" set-word-property
+ "col" get over "col" set-word-property
+ "file" get over "file" set-word-property
drop ;
: :
nreverse
;-hook ; parsing
+! Symbols
+: SYMBOL: CREATE define-symbol ; parsing
+
! Vocabularies
: DEFER: CREATE drop ; parsing
: USE: scan "use" cons@ ; parsing
: parsed-stack-effect ( parsed str -- parsed )
over doc-comment-here? [
- "stack-effect" word set-word-property
+ word "stack-effect" set-word-property
] [
drop
] ifte ;
: documentation+ ( str word -- )
[
- "documentation" swap word-property [
+ "documentation" word-property [
swap "\n" swap cat3
] when*
] keep
- "documentation" swap set-word-property ;
+ "documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [
: parsing? ( word -- ? )
dup word? [
- "parsing" swap word-property
+ "parsing" word-property
] [
drop f
] ifte ;
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
- t "parsing" word set-word-property ;
+ t word "parsing" set-word-property ;
: end? ( -- ? )
"col" get "line" get str-length >= ;
! Once this file has loaded, we can use 'parsing' normally.
! This hack is needed because in Java Factor, 'parsing' is
! not parsing, but in CFactor, it is.
-t "parsing" "parsing" [ "parser" ] search set-word-property
+t "parsing" [ "parser" ] search "parsing" set-word-property
[ set-alien-1 | " n alien off -- " ]
[ heap-stats | " -- instances bytes " ]
] [
- unswons "stack-effect" swap set-word-property
+ unswons "stack-effect" set-word-property
] each
#! Check if two vectors are equal. Two vectors are
#! considered equal if they have the same length and contain
#! equal elements.
- over vector? [
- 2dup vector-length= [
- 0 -rot (vector=)
+ 2dup eq? [
+ 2drop t
+ ] [
+ over vector? [
+ 2dup vector-length= [
+ 0 -rot (vector=)
+ ] [
+ 2drop f
+ ] ifte
] [
2drop f
] ifte
- ] [
- 2drop f
] ifte ;
: ?vector-nth ( n vec -- obj/f )
USE: namespaces
USE: stack
-: word-property ( pname word -- pvalue )
- word-plist assoc ;
+: word-property ( word pname -- pvalue )
+ swap word-plist assoc ;
-: set-word-property ( pvalue pname word -- )
- dup >r word-plist set-assoc r> set-word-plist ;
+: set-word-property ( pvalue word pname -- )
+ swap [ word-plist set-assoc ] keep set-word-plist ;
: defined? ( obj -- ? )
dup word? [ word-primitive 0 = not ] [ drop f ] ifte ;
: primitive? ( obj -- ? )
dup word? [ word-primitive 1 = not ] [ drop f ] ifte ;
+: symbol? ( obj -- ? )
+ dup word? [ word-primitive 2 = ] [ drop f ] ifte ;
+
! Various features not supported by native Factor.
: comment? drop f ;
over set-word-parameter
1 swap set-word-primitive ;
+: define-symbol ( word -- )
+ dup dup set-word-parameter
+ 2 swap set-word-primitive ;
+
: stack-effect ( word -- str )
- "stack-effect" swap word-property ;
+ "stack-effect" word-property ;
: documentation ( word -- str )
- "documentation" swap word-property ;
+ "documentation" word-property ;
tab-size - ;
: prettyprint-plist ( word -- )
- "parsing" over word-property [ " parsing" write ] when
- "inline" over word-property [ " inline" write ] when
- drop ;
+ dup "parsing" word-property [ " parsing" write ] when
+ "inline" word-property [ " inline" write ] when ;
: . ( obj -- )
[
[ t ] [ ] [ word-parameter-test ] test-word
-: words-test ( -- ? )
- t vocabs [ words [ word? and ] each ] each ;
-
-[ t ] [ ] [ words-test ] test-word
-
! At one time we had a bug in FactorShuffleDefinition.toList()
~<< test-shuffle-1 A r:B -- A r:B >>~
[ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word
-: test-last ( -- )
- nop ;
-word >str "last-word-test" set
-
-[ "test-last" ] [ ] [ "last-word-test" get ] test-word
-[ f ] [ 5 ] [ compound? ] test-word
-[ f ] [ 5 ] [ compiled? ] test-word
-[ f ] [ 5 ] [ shuffle? ] test-word
-
! Make sure callstack only clones callframes, and not
! everything on the callstack.
[ ] [ ] [ f unit dup dup set-cdr >r callstack r> 2drop ] test-word
[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word
+
+[ [ [ 2 | 3 ] [ 1 | 2 ] ] ] [
+ "x" off 2 1 "x" acons@ 3 2 "x" acons@ "x" get
+] unit-test
+
+[ [ 2 | 3 ] ] [ "x" uncons@ ] unit-test
+[ [ 1 | 2 ] ] [ "x" uncons@ ] unit-test
USE: math
USE: test
USE: words
+USE: namespaces
+USE: logic
+USE: lists
[ 4 ] [
"poo" "scratchpad" create [ 2 2 + ] define-compound
"poo" [ "scratchpad" ] search execute
] unit-test
+
+: words-test ( -- ? )
+ t vocabs [ words [ word? and ] each ] each ;
+
+[ t ] [ ] [ words-test ] test-word
+
+
+: test-last ( -- ) ;
+word word-name "last-word-test" set
+
+[ "test-last" ] [ ] [ "last-word-test" get ] test-word
+[ f ] [ 5 ] [ compound? ] test-word
USE: combinators
USE: words
+"Hi." USE: stdio print
+
: no-op ; compiled
[ ] [ no-op ] unit-test
: literals 3 5 ; compiled
+: tail-call fixnum+ ; compiled
+
+[ 4 ] [ 1 3 tail-call ] unit-test
+
[ 3 5 ] [ literals ] unit-test
-: literals&tail-call 3 5 + ; compiled
+: literals&tail-call 3 5 fixnum+ ; compiled
[ 8 ] [ literals&tail-call ] unit-test
-: two-calls dup * ; compiled
+: two-calls dup fixnum* ; compiled
[ 25 ] [ 5 two-calls ] unit-test
-: mix-test 3 5 + 6 * ; compiled
+: mix-test 3 5 fixnum+ 6 fixnum* ; compiled
[ 48 ] [ mix-test ] unit-test
[ 2 ] [ dummy-ifte-4 ] unit-test
-: dummy-ifte-5 0 dup 1 <= [ drop 1 ] [ ] ifte ; compiled
+: dummy-ifte-5 0 dup 1 fixnum<= [ drop 1 ] [ ] ifte ; compiled
[ 1 ] [ dummy-ifte-5 ] unit-test
dup 1 <= [
drop 1
] [
- 1 - dup swap 1 - +
+ 1 fixnum- dup swap 1 fixnum- fixnum+
] ifte ;
[ 17 ] [ 10 dummy-ifte-6 ] unit-test
t [ ] [ ] ifte 5 ; compiled
[ 5 ] [ after-ifte-test ] unit-test
+
+DEFER: countdown-b
+
+: countdown-a ( n -- ) dup 0 eq? [ drop ] [ pred countdown-b ] ifte ;
+: countdown-b ( n -- ) dup 0 eq? [ drop ] [ pred countdown-a ] ifte ; compiled
+
+[ ] [ 10 countdown-b ] unit-test
USE: stack
: word-name ( word -- name )
- "name" swap word-property ;
+ "name" word-property ;
: set-word-name ( word name -- )
- "name" swap set-word-property ;
+ "name" set-word-property ;
: word-vocabulary ( word -- vocab )
- "vocabulary" swap word-property ;
+ "vocabulary" word-property ;
: set-word-vocabulary ( word vocab -- )
- "vocabulary" swap set-word-property ;
+ "vocabulary" set-word-property ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
XT primitives[] = {
undefined,
docol,
+ dosym,
primitive_execute,
primitive_call,
primitive_ifte,
extern XT primitives[];
-#define PRIMITIVE_COUNT 193
+#define PRIMITIVE_COUNT 194
CELL primitive_to_xt(CELL primitive);
call(executing->parameter);
}
+/* pushes word parameter */
+void dosym(void)
+{
+ dpush(executing->parameter);
+}
+
void primitive_execute(void)
{
executing = untag_word(dpop());
void run(void);
void undefined(void);
void docol(void);
+void dosym(void);
void primitive_execute(void);
void primitive_call(void);
void primitive_ifte(void);
projects / factor.git / commitdiff