USE: math
USE: namespaces
+: SELF-CALL ( name -- )
+ #! Call named C function in Factor interpreter executable.
+ dlsym-self CALL JUMP-FIXUP ;
+
: UNBOX ( name -- )
#! Move top of datastack to C stack.
SELF-CALL EAX PUSH-R ;
BIN: 100 BIN: 11 MOD-R/M
compile-byte ;
+: R>>I ( imm reg -- )
+ #! SHIFT <reg> BY <imm>, STORE RESULT IN <reg>
+ HEX: c1 compile-byte
+ BIN: 111 BIN: 11 MOD-R/M
+ compile-byte ;
+
: CMP-I-R ( imm reg -- )
#! There are three forms of CMP we assemble
#! 83 f8 03 cmpl $0x3,%eax
IN: compiler
USE: alien
USE: inference
-USE: errors
USE: kernel
-USE: lists
-USE: math
USE: namespaces
-USE: strings
USE: words
-USE: vectors
: DS ( -- address ) "ds" dlsym-self ;
-: PUSH-DS ( -- )
- #! Push contents of EAX onto datastack.
- DS ECX [I]>R
- 4 ECX R+I
- EAX ECX R>[R]
- ECX DS R>[I] ;
-
: POP-DS ( -- )
#! Pop datastack to EAX.
DS ECX [I]>R
4 ECX R-I
ECX DS R>[I] ;
-: PEEK-DS ( -- )
- #! Peek datastack to EAX.
- DS ECX [I]>R
- ECX EAX [R]>R ;
-
-: PEEK-2-DS ( -- )
- #! Peek second value on datastack to EAX.
- DS ECX [I]>R
- 4 ECX R-I
- ECX EAX [R]>R ;
-
-: SELF-CALL ( name -- )
- #! Call named C function in Factor interpreter executable.
- dlsym-self CALL JUMP-FIXUP ;
-
#push-immediate [
DS ECX [I]>R
4 ECX R+I
#return [ drop RET ] "generator" set-word-property
-[
- [ #drop drop ]
- [ #dup dup ]
- [ #swap swap ]
- [ #over over ]
- [ #pick pick ]
- [ #>r >r ]
- [ #r> r> ]
-] [
- uncons [
- car CALL compiled-offset defer-xt drop
- ] cons "generator" set-word-property
-] each
-
-: begin-jump-table ( -- )
+#dispatch [
#! Compile a piece of code that jumps to an offset in a
- #! jump table indexed by the type of the Factor object in
- #! EAX.
+ #! jump table indexed by the fixnum at the top of the stack.
#! The jump table must immediately follow this macro.
- 2 EAX R<<I ( -- fixup )
+ drop
+ POP-DS
+ 1 EAX R>>I ( -- fixup )
EAX+/PARTIAL
EAX JUMP-[R]
cell compile-aligned
- compiled-offset swap set-compiled-cell ( fixup -- ) ;
+ compiled-offset swap set-compiled-cell ( fixup -- )
+] "generator" set-word-property
-: jump-table-entry ( word -- )
+#target [
#! Jump table entries are absolute addresses.
- ( dup postpone-word )
- compiled-offset 0 compile-cell 0 defer-xt ;
-
-: check-jump-table ( vtable -- )
- length num-types = [
- "Jump table must have " num-types " entries" cat3 throw
- ] unless ;
-
-: compile-jump-table ( vtable -- )
- #! Compile a table of words as a word-array of XTs.
- begin-jump-table
- dup check-jump-table
- [ jump-table-entry ] each ;
-
-: TYPE ( -- )
- #! Peek datastack, store type # in EAX.
- PEEK-DS
- EAX PUSH-R
- "type_of" SELF-CALL
- 4 ESP R+I ;
-
-: compile-generic ( vtable -- )
- #! Compile a faster alternative to
- #! : generic ( obj vtable -- )
- #! >r dup type r> vector-nth execute ;
- TYPE compile-jump-table ;
-
-#generic [ compile-generic ] "generator" set-word-property
-
-: ARITHMETIC-TYPE ( -- )
- #! Peek top two on datastack, store arithmetic type # in EAX.
- PEEK-DS
- EAX PUSH-R
- PEEK-2-DS
- EAX PUSH-R
- "arithmetic_type" SELF-CALL
- 8 ESP R+I ;
-
-: compile-2generic ( vtable -- )
- #! Compile a faster alternative to
- #! : 2generic ( obj vtable -- )
- #! >r 2dup arithmetic-type r> vector-nth execute ;
- ARITHMETIC-TYPE compile-jump-table ;
-
-#2generic [ compile-2generic ] "generator" set-word-property
+ compiled-offset 0 compile-cell 0 defer-xt
+] "generator" set-word-property
USE: math
USE: namespaces
USE: words
+USE: strings
+USE: errors
! The linear IR is close to assembly language. It also resembles
! Forth code in some sense. It exists so that pattern matching
SYMBOL: #jump ( tail-call )
SYMBOL: #return-to ( push addr on C stack )
+! #dispatch is linearized as #dispatch followed by a #target
+! for each dispatch table entry. The linearizer ensures the
+! correct number of #targets is emitted.
+SYMBOL: #target ( part of jump table )
+
: linear, ( node -- )
#! Add a node to the linear IR.
[ node-op get node-param get ] bind cons , ;
[ node-param get ] bind linearize-ifte
] "linearizer" set-word-property
-: generic-head ( param op -- end label/param )
+: dispatch-head ( vtable -- end label/code )
#! Output the jump table insn and return a list of
#! label/branch pairs.
- >r
+ [ #dispatch ] ,
<label> ( end label ) swap
- [ <label> cons ] map
- dup [ cdr ] map r> swons , ;
+ [ <label> dup #target swons , cons ] map ;
-: generic-body ( end label/param -- )
+: dispatch-body ( end label/param -- )
#! Output each branch, with a jump to the end label.
[
uncons label, (linearize) dup #jump-label swons ,
] each drop ;
-: linearize-generic ( param op -- )
+: check-dispatch ( vtable -- )
+ length num-types = [
+ "Dispatch must have " num-types " entries" cat3 throw
+ ] unless ;
+
+: linearize-dispatch ( vtable -- )
#! The parameter is a list of lists, each one is a branch to
#! take in case the top of stack has that type.
- generic-head dupd generic-body label, ;
+ dup check-dispatch dispatch-head dupd dispatch-body label, ;
-#generic [
- [ node-param get node-op get ] bind linearize-generic
-] "linearizer" set-word-property
-
-#2generic [
- [ node-param get node-op get ] bind linearize-generic
+#dispatch [
+ [ node-param get ] bind linearize-dispatch
] "linearizer" set-word-property
#values [ drop ] "linearizer" set-word-property
+
+[
+ [ #drop drop ]
+ [ #dup dup ]
+ [ #swap swap ]
+ [ #over over ]
+ [ #pick pick ]
+ [ #>r >r ]
+ [ #r> r> ]
+] [
+ uncons
+ [ car #call swons , drop ] cons
+ "linearizer" set-word-property
+] each
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-property
-#generic [
- [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-property
-
-#2generic [
+#dispatch [
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-property
#ifte [ can-kill-branches? ] "can-kill" set-word-property
#ifte [ kill-branches ] "kill-node" set-word-property
-#generic [ scan-branches ] "scan-literal" set-word-property
-#generic [ can-kill-branches? ] "can-kill" set-word-property
-#generic [ kill-branches ] "kill-node" set-word-property
-
-#2generic [ scan-branches ] "scan-literal" set-word-property
-#2generic [ can-kill-branches? ] "can-kill" set-word-property
-#2generic [ kill-branches ] "kill-node" set-word-property
+#dispatch [ scan-branches ] "scan-literal" set-word-property
+#dispatch [ can-kill-branches? ] "can-kill" set-word-property
+#dispatch [ kill-branches ] "kill-node" set-word-property
! Don't care about inputs to recursive combinator calls
#call-label [ 2drop t ] "can-kill" set-word-property
[
f infer-branch [
d-in get meta-d get vector-length cons
- ] bind recursive-state get set-base
+ recursive-state get set-base
+ ] bind
] [
[ 2drop ] when
] catch ;
pop-d drop ( condition )
infer-branches ;
+\ ifte [ infer-ifte ] "infer" set-word-property
+
: vtable>list ( [ vtable | rstate ] -- list )
unswons vector>list [ over cons ] map nip ;
-: infer-generic ( -- )
+: infer-dispatch ( -- )
#! Infer effects for all branches, unify.
2 ensure-d
dataflow-drop, pop-d vtable>list
- >r 1 meta-d get vector-tail* #generic r>
- infer-branches ;
-
-: infer-2generic ( -- )
- #! Infer effects for all branches, unify.
- 3 ensure-d
- dataflow-drop, pop-d vtable>list
- >r 2 meta-d get vector-tail* #2generic r>
+ >r 1 meta-d get vector-tail* #dispatch r>
+ pop-d drop ( n )
infer-branches ;
-\ ifte [ infer-ifte ] "infer" set-word-property
-
-\ generic [ infer-generic ] "infer" set-word-property
-\ generic [ 2 | 0 ] "infer-effect" set-word-property
-
-\ 2generic [ infer-2generic ] "infer" set-word-property
-\ 2generic [ 3 | 0 ] "infer-effect" set-word-property
+\ dispatch [ infer-dispatch ] "infer" set-word-property
+\ dispatch [ 2 | 0 ] "infer-effect" set-word-property
SYMBOL: #push ( literal )
SYMBOL: #ifte
-SYMBOL: #generic
-SYMBOL: #2generic
+SYMBOL: #dispatch
! This is purely a marker for values we retain after a
! conditional. It does not generate code, but merely alerts the
! It is quite clumsy, however. A higher-level CLOS-style
! 'generic words' system will be built later.
+: dispatch ( n vtable -- )
+ vector-nth call ;
+
: generic ( obj vtable -- )
- >r dup type r> vector-nth call ;
+ >r dup type r> dispatch ; inline
: 2generic ( n n vtable -- )
- >r 2dup arithmetic-type r> vector-nth call ;
+ >r 2dup arithmetic-type r> dispatch ; inline
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.
[ t ] [
[ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
- #generic swap dataflow-contains-op? car [
+ #dispatch swap dataflow-contains-op? car [
node-param get [
[ [ node-param get \ undefined-method = ] bind ] some?
] some?
projects / factor.git / commitdiff