compiler cleanups
Slava Pestov
parent
c67c29cf27
commit
db88cc9460
|
|
@ -32,6 +32,10 @@ USE: lists
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -170,6 +170,12 @@ USE: math
|
|||
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
|
||||
|
|
|
|||
|
|
@ -28,24 +28,12 @@
|
|||
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
|
||||
|
|
@ -53,21 +41,6 @@ USE: vectors
|
|||
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
|
||||
|
|
@ -110,75 +83,20 @@ USE: vectors
|
|||
|
||||
#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
|
||||
|
|
|
|||
|
|
@ -32,6 +32,8 @@ USE: lists
|
|||
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
|
||||
|
|
@ -47,6 +49,11 @@ SYMBOL: #jump-label ( unconditional branch )
|
|||
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 , ;
|
||||
|
|
@ -128,31 +135,45 @@ SYMBOL: #return-to ( push addr on C stack )
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -153,11 +153,7 @@ USE: prettyprint
|
|||
[ 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
|
||||
|
||||
|
|
@ -177,13 +173,9 @@ USE: prettyprint
|
|||
#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
|
||||
|
|
|
|||
|
|
@ -106,7 +106,8 @@ USE: hashtables
|
|||
[
|
||||
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 ;
|
||||
|
|
@ -150,27 +151,18 @@ USE: hashtables
|
|||
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>
|
||||
>r 1 meta-d get vector-tail* #dispatch r>
|
||||
pop-d drop ( n )
|
||||
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>
|
||||
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
|
||||
|
|
|
|||
|
|
@ -50,8 +50,7 @@ SYMBOL: #call-label
|
|||
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
|
||||
|
|
|
|||
|
|
@ -50,11 +50,14 @@ USE: vectors
|
|||
! 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.
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ USE: generic
|
|||
|
||||
[ 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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue