reworking simplifier and basic blocks
Slava Pestov
parent
b3003e4759
commit
55e2a9e232
|
|
@ -1,3 +1,5 @@
|
|||
- remove t object and type
|
||||
|
||||
+ ui:
|
||||
|
||||
- fix up the min thumb size hack
|
||||
|
|
@ -48,10 +50,8 @@
|
|||
|
||||
+ compiler:
|
||||
|
||||
- declare slot types for built-ins
|
||||
- remove dead code after a 'throw'
|
||||
- when doing comparison with one arg being a float, inline method
|
||||
- investigate overzealous math inlining
|
||||
- shuffles: eliminate dead loads
|
||||
- floating point intrinsics
|
||||
- flushing optimization
|
||||
- fix fixnum/mod overflow on PowerPC
|
||||
|
|
@ -78,7 +78,6 @@
|
|||
- specialized arrays
|
||||
- there is a problem with hashcodes of words and bootstrapping
|
||||
- delegating generic words with a non-standard picker
|
||||
- powerpc has weird callstack residue
|
||||
- instances: do not use make-list
|
||||
- vectors: ensure its ok with bignum indices
|
||||
- code gc
|
||||
|
|
@ -91,8 +90,6 @@
|
|||
- investigate if rehashing on startup is really necessary
|
||||
- vectorize >n, n>, (get)
|
||||
- mutable strings simplifying string operarations
|
||||
- 2each, find*, subset are ugly
|
||||
- map and 2map duplicate logic
|
||||
|
||||
+ i/o:
|
||||
|
||||
|
|
|
|||
|
|
@ -116,19 +116,19 @@ C: alien-node make-node ;
|
|||
dup stack-space %parameters ,
|
||||
dup unbox-parameters load-parameters ;
|
||||
|
||||
: linearize-return ( return -- )
|
||||
: linearize-return ( node -- )
|
||||
alien-node-return dup "void" = [
|
||||
drop
|
||||
] [
|
||||
c-type [ "boxer" get "reg-class" get ] bind %box ,
|
||||
] ifte ;
|
||||
|
||||
M: alien-node linearize-node* ( node -- )
|
||||
M: alien-node linearize* ( node -- )
|
||||
dup parameters linearize-parameters
|
||||
dup node-param dup uncons %alien-invoke ,
|
||||
cdr library-abi "stdcall" =
|
||||
[ dup parameters stack-space %cleanup , ] unless
|
||||
linearize-return ;
|
||||
dup linearize-return linearize-next ;
|
||||
|
||||
: unpair ( seq -- odds evens )
|
||||
2 swap group flip dup empty?
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ sequences io vectors words ;
|
|||
"/library/compiler/linearizer.factor"
|
||||
"/library/compiler/stack.factor"
|
||||
"/library/compiler/intrinsics.factor"
|
||||
"/library/compiler/simplifier.factor"
|
||||
"/library/compiler/basic-blocks.factor"
|
||||
"/library/compiler/generator.factor"
|
||||
"/library/compiler/compiler.factor"
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ M: cons length cdr length 1 + ;
|
|||
M: f empty? drop t ;
|
||||
M: cons empty? drop f ;
|
||||
|
||||
M: f peek ( f -- f ) ;
|
||||
|
||||
M: cons peek ( list -- last )
|
||||
#! Last element of a list.
|
||||
last car ;
|
||||
|
|
|
|||
|
|
@ -102,6 +102,8 @@ SYMBOL: building
|
|||
#! Add to the sequence being built with make-seq.
|
||||
building get push ;
|
||||
|
||||
: ?, ( obj ? -- ) [ , ] [ drop ] ifte ;
|
||||
|
||||
: % ( seq -- )
|
||||
#! Append to the sequence being built with make-seq.
|
||||
building get swap nappend ;
|
||||
|
|
|
|||
|
|
@ -92,4 +92,6 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
|
|||
|
||||
: split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable
|
||||
|
||||
: cut ( n seq -- ) [ head ] 2keep tail ; flushable
|
||||
: (cut) ( n seq -- ) [ head ] 2keep tail-slice ; flushable
|
||||
|
||||
: cut ( n seq -- ) [ (cut) ] keep like ; flushable
|
||||
|
|
|
|||
|
|
@ -0,0 +1,129 @@
|
|||
IN: compiler-backend
|
||||
USING: kernel math namespaces sequences vectors ;
|
||||
|
||||
: (split-blocks) ( n linear -- )
|
||||
2dup length = [
|
||||
dup like , drop
|
||||
] [
|
||||
2dup nth basic-block? [
|
||||
>r 1 + r> (split-blocks)
|
||||
] [
|
||||
(cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
: split-blocks ( linear -- blocks )
|
||||
[ 0 swap (split-blocks) ] { } make ;
|
||||
|
||||
SYMBOL: d-height
|
||||
SYMBOL: r-height
|
||||
|
||||
! combining %inc-d/%inc-r
|
||||
GENERIC: simplify-stack* ( vop -- )
|
||||
|
||||
M: tuple simplify-stack* ( vop -- ) drop ;
|
||||
|
||||
: accum-height ( vop var -- )
|
||||
>r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ;
|
||||
|
||||
M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
|
||||
|
||||
M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
|
||||
|
||||
: update-ds ( vop -- )
|
||||
dup ds-loc-n d-height get - swap set-ds-loc-n ;
|
||||
|
||||
: update-cs ( vop -- )
|
||||
dup cs-loc-n r-height get - swap set-cs-loc-n ;
|
||||
|
||||
M: %peek-d simplify-stack* ( vop -- ) 0 vop-in update-ds ;
|
||||
|
||||
M: %peek-r simplify-stack* ( vop -- ) 0 vop-in update-cs ;
|
||||
|
||||
M: %replace-d simplify-stack* ( vop -- ) 0 vop-out update-ds ;
|
||||
|
||||
M: %replace-r simplify-stack* ( vop -- ) 0 vop-out update-cs ;
|
||||
|
||||
: simplify-stack ( block -- )
|
||||
#! Combine all %inc-d/%inc-r into two final ones.
|
||||
#! Destructively modifies the VOPs in the block.
|
||||
[ simplify-stack* ] each ;
|
||||
|
||||
: each-tail ( seq quot -- | quot: tail -- )
|
||||
>r dup length [ swap tail-slice ] map-with r> each ; inline
|
||||
|
||||
! removing dead loads/stores
|
||||
: preserves-location? ( exitcc location vop -- ? )
|
||||
#! If the VOP writes the register, call the loop exit
|
||||
#! continuation with 'f'.
|
||||
{
|
||||
{ [ 2dup vop-inputs member? ] [ 3drop t ] }
|
||||
{ [ 2dup vop-outputs member? ] [ 2drop f swap call ] }
|
||||
{ [ t ] [ 3drop f ] }
|
||||
} cond ;
|
||||
|
||||
GENERIC: live@end? ( location -- ? )
|
||||
|
||||
M: tuple live@end? drop t ;
|
||||
|
||||
M: ds-loc live@end? ds-loc-n d-height get + 0 >= ;
|
||||
|
||||
M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
|
||||
|
||||
: location-live? ( location tail -- ? )
|
||||
#! A location is not live if and only if it is overwritten
|
||||
#! before the end of the basic block.
|
||||
[
|
||||
-rot [ >r 2dup r> preserves-location? ] contains?
|
||||
[ dup live@end? ] unless*
|
||||
] callcc1 2nip ;
|
||||
|
||||
! Set if trim-dead* removed some VOPs.
|
||||
GENERIC: trim-dead* ( tail vop -- )
|
||||
|
||||
M: tuple trim-dead* ( tail vop -- ) , drop ;
|
||||
|
||||
: simplify-inc ( vop -- ) dup 0 vop-in 0 = not ?, ;
|
||||
|
||||
M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
|
||||
|
||||
M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ;
|
||||
|
||||
: ?dead-load ( tail vop -- )
|
||||
#! If the VOP's output location is overwritten before being
|
||||
#! read again, kill the VOP.
|
||||
dup 0 vop-out rot location-live? ?, ;
|
||||
|
||||
M: %peek-d trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
M: %peek-r trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
M: %replace-d trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
M: %replace-r trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
M: %immediate trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
M: %indirect trim-dead* ( tail vop -- ) ?dead-load ;
|
||||
|
||||
: trim-dead ( block -- )
|
||||
#! Remove dead loads and stores.
|
||||
[ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ;
|
||||
|
||||
: simplify-block ( block -- block )
|
||||
#! Destructively modifies the VOPs in the block.
|
||||
[
|
||||
0 d-height set
|
||||
0 r-height set
|
||||
dup simplify-stack
|
||||
d-height get %inc-d r-height get %inc-r 2vector append
|
||||
trim-dead
|
||||
] { } make ;
|
||||
|
||||
: keep-simplifying ( block -- block )
|
||||
dup length >r simplify-block dup length r>
|
||||
= [ keep-simplifying ] unless ;
|
||||
|
||||
: simplify ( blocks -- blocks )
|
||||
#! Simplify basic block IR.
|
||||
[ keep-simplifying ] map ;
|
||||
|
|
@ -6,20 +6,12 @@ kernel lists math namespaces prettyprint sequences words ;
|
|||
: supported-cpu? ( -- ? )
|
||||
cpu "unknown" = not ;
|
||||
|
||||
GENERIC: (compile) ( word -- )
|
||||
: precompile ( quotation -- basic-blocks )
|
||||
dataflow optimize linearize split-blocks simplify ;
|
||||
|
||||
M: word (compile) drop ;
|
||||
|
||||
M: compound (compile) ( word -- )
|
||||
: (compile) ( word -- )
|
||||
#! Should be called inside the with-compiler scope.
|
||||
"Compiling " write dup .
|
||||
dup word-def dataflow optimize linearize simplify generate ;
|
||||
|
||||
: precompile ( word -- )
|
||||
#! Print linear IR of word.
|
||||
[
|
||||
word-def dataflow optimize linearize simplify [ . ] each
|
||||
] with-scope ;
|
||||
"Compiling " write dup . dup word-def precompile generate ;
|
||||
|
||||
: compile-postponed ( -- )
|
||||
compile-words get [
|
||||
|
|
@ -38,8 +30,7 @@ M: compound (compile) ( word -- )
|
|||
|
||||
: compile-all ( -- ) [ try-compile ] each-word ;
|
||||
|
||||
: recompile ( word -- )
|
||||
dup update-xt compile ;
|
||||
: recompile ( word -- ) dup update-xt compile ;
|
||||
|
||||
: compile-1 ( quot -- )
|
||||
#! Compute and call a quotation.
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ M: integer v>operand tag-bits shift ;
|
|||
M: f v>operand address ;
|
||||
|
||||
: dest/src ( vop -- dest src )
|
||||
dup vop-out-1 v>operand swap vop-in-1 v>operand ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in v>operand ;
|
||||
|
||||
! These constants must match native/card.h
|
||||
: card-bits 7 ;
|
||||
|
|
|
|||
|
|
@ -31,13 +31,13 @@ sequences vectors words ;
|
|||
|
||||
\ slot [
|
||||
dup slot@ [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
0 swap slot@ %fast-slot ,
|
||||
] [
|
||||
drop
|
||||
in-2
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
0 %untag ,
|
||||
1 0 %slot ,
|
||||
] ifte out-1
|
||||
|
|
@ -45,14 +45,14 @@ sequences vectors words ;
|
|||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-2
|
||||
-2 %inc-d,
|
||||
-2 %inc-d ,
|
||||
slot@ >r 0 1 r> %fast-set-slot ,
|
||||
] [
|
||||
drop
|
||||
in-3
|
||||
-3 %inc-d,
|
||||
-3 %inc-d ,
|
||||
1 %untag ,
|
||||
0 1 2 %set-slot ,
|
||||
] ifte
|
||||
|
|
@ -76,17 +76,17 @@ sequences vectors words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
node-peek literal-value 0 <vreg> swap %getenv ,
|
||||
1 %inc-d,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
node-peek literal-value 0 <vreg> swap %setenv ,
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: value/vreg-list ( in -- list )
|
||||
|
|
@ -100,7 +100,7 @@ sequences vectors words ;
|
|||
|
||||
: load-inputs ( node -- in )
|
||||
dup node-in-d values>vregs
|
||||
[ >r node-out-d length r> length - %inc-d, ] keep ;
|
||||
[ >r node-out-d length r> length - %inc-d , ] keep ;
|
||||
|
||||
: binary-op-reg ( node op -- )
|
||||
>r load-inputs first2 swap dup r> execute ,
|
||||
|
|
@ -110,7 +110,7 @@ sequences vectors words ;
|
|||
dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
|
||||
|
||||
: binary-op-imm ( imm op -- )
|
||||
-1 %inc-d, in-1
|
||||
-1 %inc-d , in-1
|
||||
>r 0 <vreg> dup r> execute ,
|
||||
0 0 %replace-d , ; inline
|
||||
|
||||
|
|
@ -143,7 +143,7 @@ sequences vectors words ;
|
|||
] each
|
||||
|
||||
: fast-fixnum* ( n -- )
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
log2 0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
0 0 %replace-d , ;
|
||||
|
|
@ -169,7 +169,7 @@ sequences vectors words ;
|
|||
! be EDX there.
|
||||
drop
|
||||
in-2
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
|
||||
2 0 %replace-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
@ -201,7 +201,7 @@ sequences vectors words ;
|
|||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
: negative-shift ( n -- )
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
dup cell -8 * <= [
|
||||
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
|
||||
|
|
@ -213,7 +213,7 @@ sequences vectors words ;
|
|||
|
||||
: positive-shift ( n -- )
|
||||
dup cell 8 * tag-bits - <= [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
out-1
|
||||
|
|
@ -223,7 +223,7 @@ sequences vectors words ;
|
|||
|
||||
: fast-shift ( n -- )
|
||||
dup 0 = [
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
drop
|
||||
] [
|
||||
dup 0 < [
|
||||
|
|
|
|||
|
|
@ -5,82 +5,72 @@ USING: compiler-backend errors generic lists inference kernel
|
|||
math namespaces prettyprint sequences
|
||||
strings words ;
|
||||
|
||||
GENERIC: linearize-node* ( node -- )
|
||||
|
||||
M: f linearize-node* ( f -- ) drop ;
|
||||
|
||||
M: node linearize-node* ( node -- ) drop ;
|
||||
|
||||
: linearize-node ( node -- )
|
||||
[
|
||||
dup linearize-node* node-successor linearize-node
|
||||
] when* ;
|
||||
GENERIC: linearize* ( node -- )
|
||||
|
||||
: linearize ( dataflow -- linear )
|
||||
#! Transform dataflow IR into linear IR. This strips out
|
||||
#! stack flow information, and flattens conditionals into
|
||||
#! jumps and labels.
|
||||
[ %prologue , linearize-node ] [ ] make ;
|
||||
[ %prologue , linearize* ] { } make ;
|
||||
|
||||
M: #label linearize-node* ( node -- )
|
||||
: linearize-next node-successor linearize* ;
|
||||
|
||||
M: f linearize* ( f -- ) drop ;
|
||||
|
||||
M: node linearize* ( node -- ) linearize-next ;
|
||||
|
||||
M: #label linearize* ( node -- )
|
||||
<label> dup %return-to , >r
|
||||
dup node-param %label ,
|
||||
node-child linearize-node
|
||||
r> %label , ;
|
||||
dup node-child linearize*
|
||||
r> %label ,
|
||||
linearize-next ;
|
||||
|
||||
M: #call linearize-node* ( node -- )
|
||||
dup node-param
|
||||
dup "intrinsic" word-prop [ call ] [ %call , drop ] ?ifte ;
|
||||
: ?tail-call ( node caller jumper -- next )
|
||||
>r >r dup node-successor #return? [
|
||||
node-param r> drop r> execute ,
|
||||
] [
|
||||
dup node-param r> execute , r> drop linearize-next
|
||||
] ifte ; inline
|
||||
|
||||
M: #call-label linearize-node* ( node -- )
|
||||
node-param %call-label , ;
|
||||
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
|
||||
|
||||
: immediate? ( obj -- ? )
|
||||
#! fixnums and f have a pointerless representation, and
|
||||
#! are compiled immediately. Everything else can be moved
|
||||
#! by GC, and is indexed through a table.
|
||||
dup fixnum? swap f eq? or ;
|
||||
M: #call linearize* ( node -- )
|
||||
dup intrinsic [
|
||||
dupd call linearize-next
|
||||
] [
|
||||
\ %call \ %jump ?tail-call
|
||||
] ifte* ;
|
||||
|
||||
GENERIC: load-value ( vreg n value -- )
|
||||
M: #call-label linearize* ( node -- )
|
||||
\ %call-label \ %jump-label ?tail-call ;
|
||||
|
||||
M: object load-value ( vreg n value -- )
|
||||
drop %peek-d , ;
|
||||
: ifte-head ( label -- ) in-1 -1 %inc-d , 0 %jump-t , ;
|
||||
|
||||
: push-literal ( vreg value -- )
|
||||
literal-value dup
|
||||
immediate? [ %immediate ] [ %indirect ] ifte , ;
|
||||
|
||||
M: literal load-value ( vreg n value -- )
|
||||
nip push-literal ;
|
||||
|
||||
: ifte-head ( label -- )
|
||||
in-1 -1 %inc-d, 0 %jump-t , ;
|
||||
|
||||
M: #ifte linearize-node* ( node -- )
|
||||
M: #ifte linearize* ( node -- )
|
||||
node-children first2
|
||||
<label> dup ifte-head
|
||||
swap linearize-node ( false branch )
|
||||
swap linearize* ( false branch )
|
||||
%label , ( branch target of BRANCH-T )
|
||||
linearize-node ( true branch ) ;
|
||||
linearize* ( true branch ) ;
|
||||
|
||||
: dispatch-head ( vtable -- label/code )
|
||||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
in-1
|
||||
-1 %inc-d,
|
||||
-1 %inc-d ,
|
||||
0 %untag-fixnum ,
|
||||
0 %dispatch ,
|
||||
[ <label> dup %target-label , cons ] map
|
||||
%end-dispatch , ;
|
||||
|
||||
: dispatch-body ( label/param -- )
|
||||
#! Output each branch, with a jump to the end label.
|
||||
[ uncons %label , linearize-node ] each ;
|
||||
[ uncons %label , linearize* ] each ;
|
||||
|
||||
M: #dispatch linearize-node* ( vtable -- )
|
||||
#! The parameter is a list of lists, each one is a branch to
|
||||
M: #dispatch linearize* ( vtable -- )
|
||||
#! The parameter is a list of nodes, each one is a branch to
|
||||
#! take in case the top of stack has that type.
|
||||
node-children dispatch-head dispatch-body ;
|
||||
|
||||
M: #return linearize-node* ( node -- )
|
||||
drop f %return , ;
|
||||
M: #return linearize* ( node -- )
|
||||
drop f %return , ;
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ IN: compiler-backend
|
|||
USING: alien assembler kernel math ;
|
||||
|
||||
M: %alien-invoke generate-node ( vop -- )
|
||||
dup vop-in-1 swap vop-in-2 load-library compile-c-call ;
|
||||
dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
|
||||
|
||||
: stack-reserve 8 + 16 align ;
|
||||
: stack@ 12 + ;
|
||||
|
||||
M: %parameters generate-node ( vop -- )
|
||||
vop-in-1 dup 0 =
|
||||
0 vop-in dup 0 =
|
||||
[ drop ] [ stack-reserve 1 1 rot SUBI ] ifte ;
|
||||
|
||||
GENERIC: store-insn
|
||||
|
|
@ -28,19 +28,19 @@ M: float-regs load-insn
|
|||
>r 1 + 1 rot r> float-regs-size 4 = [ LFS ] [ LFD ] ifte ;
|
||||
|
||||
M: %unbox generate-node ( vop -- )
|
||||
[ vop-in-2 f compile-c-call ] keep
|
||||
[ vop-in-3 return-reg 1 ] keep
|
||||
[ vop-in-1 stack@ ] keep
|
||||
vop-in-3 store-insn ;
|
||||
[ 1 vop-in f compile-c-call ] keep
|
||||
[ 2 vop-in return-reg 1 ] keep
|
||||
[ 0 vop-in stack@ ] keep
|
||||
2 vop-in store-insn ;
|
||||
|
||||
M: %parameter generate-node ( vop -- )
|
||||
dup vop-in-1 stack@
|
||||
over vop-in-2
|
||||
rot vop-in-3 load-insn ;
|
||||
dup 0 vop-in stack@
|
||||
over 1 vop-in
|
||||
rot 2 vop-in load-insn ;
|
||||
|
||||
M: %box generate-node ( vop -- )
|
||||
vop-in-1 f compile-c-call ;
|
||||
0 vop-in f compile-c-call ;
|
||||
|
||||
M: %cleanup generate-node ( vop -- )
|
||||
vop-in-1 dup 0 =
|
||||
0 vop-in dup 0 =
|
||||
[ drop ] [ stack-reserve 1 1 rot ADDI ] ifte ;
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ USING: assembler compiler kernel math math-internals memory
|
|||
namespaces words ;
|
||||
|
||||
: >3-imm< ( vop -- out1 in2 in1 )
|
||||
[ vop-out-1 v>operand ] keep
|
||||
[ vop-in-2 v>operand ] keep
|
||||
vop-in-1 ;
|
||||
[ 0 vop-out v>operand ] keep
|
||||
[ 1 vop-in v>operand ] keep
|
||||
0 vop-in ;
|
||||
|
||||
: >3-vop< ( vop -- out1 in1 in2 )
|
||||
>3-imm< v>operand swap ;
|
||||
|
|
@ -24,7 +24,7 @@ namespaces words ;
|
|||
drop
|
||||
"s48_long_to_bignum" f compile-c-call
|
||||
! An untagged pointer to the bignum is now in r3; tag it
|
||||
3 swap vop-out-1 v>operand bignum-tag ORI
|
||||
3 swap 0 vop-out v>operand bignum-tag ORI
|
||||
"end" get save-xt ; inline
|
||||
|
||||
M: %fixnum+ generate-node ( vop -- )
|
||||
|
|
@ -114,7 +114,7 @@ M: %fixnum<< generate-node ( vop -- )
|
|||
! This has specific register requirements.
|
||||
<label> "no-overflow" set
|
||||
<label> "end" set
|
||||
vop-in-1
|
||||
0 vop-in
|
||||
! check for potential overflow
|
||||
dup shift-add dup 5 LOAD
|
||||
4 3 5 ADD
|
||||
|
|
@ -142,7 +142,7 @@ M: %fixnum-sgn generate-node ( vop -- )
|
|||
dest/src dupd 31 SRAWI dup untag ;
|
||||
|
||||
: compare ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 dup integer? [
|
||||
dup 1 vop-in v>operand swap 0 vop-in dup integer? [
|
||||
0 -rot address CMPI
|
||||
] [
|
||||
0 swap v>operand CMP
|
||||
|
|
@ -161,7 +161,7 @@ M: %fixnum-sgn generate-node ( vop -- )
|
|||
"end" get save-xt ; inline
|
||||
|
||||
: fixnum-pred ( vop word -- dest )
|
||||
>r [ compare ] keep vop-out-1 v>operand r> load-boolean ;
|
||||
>r [ compare ] keep 0 vop-out v>operand r> load-boolean ;
|
||||
inline
|
||||
|
||||
M: %fixnum< generate-node ( vop -- ) \ BLT fixnum-pred ;
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ M: %jump-label generate-node ( vop -- )
|
|||
vop-label B ;
|
||||
|
||||
: conditional ( vop -- label )
|
||||
dup vop-in-1 v>operand 0 swap f address CMPI vop-label ;
|
||||
dup 0 vop-in v>operand 0 swap f address CMPI vop-label ;
|
||||
|
||||
M: %jump-f generate-node ( vop -- )
|
||||
conditional BEQ ;
|
||||
|
|
@ -119,4 +119,4 @@ M: %type generate-node ( vop -- )
|
|||
3 4 MR ;
|
||||
|
||||
M: %tag generate-node ( vop -- )
|
||||
dup vop-in-1 v>operand swap vop-out-1 v>operand tag-mask ANDI ;
|
||||
dup 0 vop-in v>operand swap 0 vop-out v>operand tag-mask ANDI ;
|
||||
|
|
|
|||
|
|
@ -8,32 +8,32 @@ M: %slot generate-node ( vop -- )
|
|||
dest/src
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
dup dup 1 SRAWI
|
||||
! compute slot address in vop-out-1
|
||||
! compute slot address in 0 vop-out
|
||||
>r dup dup r> ADD
|
||||
! load slot value in vop-out-1
|
||||
! load slot value in 0 vop-out
|
||||
dup 0 LWZ ;
|
||||
|
||||
M: %fast-slot generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand dup rot vop-in-1 LWZ ;
|
||||
dup 0 vop-out v>operand dup rot 0 vop-in LWZ ;
|
||||
|
||||
M: %set-slot generate-node ( vop -- )
|
||||
dup vop-in-3 v>operand over vop-in-2 v>operand
|
||||
dup 2 vop-in v>operand over 1 vop-in v>operand
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
over dup 1 SRAWI
|
||||
! compute slot address in vop-in-2
|
||||
! compute slot address in 1 vop-in
|
||||
over dup rot ADD
|
||||
! store new slot value
|
||||
>r vop-in-1 v>operand r> 0 STW ;
|
||||
>r 0 vop-in v>operand r> 0 STW ;
|
||||
|
||||
M: %fast-set-slot generate-node ( vop -- )
|
||||
[ vop-in-1 v>operand ] keep
|
||||
[ vop-in-2 v>operand ] keep
|
||||
vop-in-3 STW ;
|
||||
[ 0 vop-in v>operand ] keep
|
||||
[ 1 vop-in v>operand ] keep
|
||||
2 vop-in STW ;
|
||||
|
||||
M: %write-barrier generate-node ( vop -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
#! Uses r6 for storage.
|
||||
vop-in-1 v>operand
|
||||
0 vop-in v>operand
|
||||
dup dup card-bits SRAWI
|
||||
dup dup 16 ADD
|
||||
6 over 0 LBZ
|
||||
|
|
@ -45,10 +45,10 @@ M: %write-barrier generate-node ( vop -- )
|
|||
"userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
|
||||
|
||||
M: %getenv generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand dup userenv
|
||||
dup rot vop-in-1 cell * LWZ ;
|
||||
dup 0 vop-out v>operand dup userenv
|
||||
dup rot 0 vop-in cell * LWZ ;
|
||||
|
||||
M: %setenv generate-node ( vop -- )
|
||||
! bad! need to formalize scratch register usage
|
||||
4 <vreg> v>operand dup userenv >r
|
||||
dup vop-in-1 v>operand r> rot vop-in-2 cell * STW ;
|
||||
dup 0 vop-in v>operand r> rot 1 vop-in cell * STW ;
|
||||
|
|
|
|||
|
|
@ -7,28 +7,28 @@ USING: assembler compiler errors kernel math memory words ;
|
|||
: cs-op cell * neg 15 swap ;
|
||||
|
||||
M: %immediate generate-node ( vop -- )
|
||||
dup vop-in-1 address swap vop-out-1 v>operand LOAD ;
|
||||
dup 0 vop-in address swap 0 vop-out v>operand LOAD ;
|
||||
|
||||
: load-indirect ( dest literal -- )
|
||||
intern-literal over LOAD dup 0 LWZ ;
|
||||
|
||||
M: %indirect generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in load-indirect ;
|
||||
|
||||
M: %peek-d generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 ds-op LWZ ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in ds-op LWZ ;
|
||||
|
||||
M: %replace-d generate-node ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 ds-op STW ;
|
||||
dup 1 vop-in v>operand swap 0 vop-in ds-op STW ;
|
||||
|
||||
M: %inc-d generate-node ( vop -- )
|
||||
14 14 rot vop-in-1 cell * ADDI ;
|
||||
14 14 rot 0 vop-in cell * ADDI ;
|
||||
|
||||
M: %inc-r generate-node ( vop -- )
|
||||
15 15 rot vop-in-1 cell * ADDI ;
|
||||
15 15 rot 0 vop-in cell * ADDI ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in cs-op LWZ ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 cs-op STW ;
|
||||
dup 1 vop-in v>operand swap 0 vop-in cs-op STW ;
|
||||
|
|
|
|||
|
|
@ -1,261 +0,0 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler-backend
|
||||
USING: generic kernel lists math namespaces
|
||||
prettyprint sequences strings words ;
|
||||
|
||||
! A peephole optimizer operating on the linear IR.
|
||||
|
||||
! The linear IR being simplified is stored in this variable.
|
||||
SYMBOL: simplifying
|
||||
|
||||
GENERIC: simplify-node ( linear vop -- linear ? )
|
||||
|
||||
! The next node following this node in terms of control flow, or
|
||||
! f if this is a conditional.
|
||||
GENERIC: next-logical ( linear vop -- linear )
|
||||
|
||||
! No delegation.
|
||||
M: tuple simplify-node drop f ;
|
||||
|
||||
: simplify-1 ( list -- list ? )
|
||||
#! Return a new linear IR.
|
||||
dup [
|
||||
dup car simplify-node
|
||||
[ uncons simplify-1 drop cons t ]
|
||||
[ uncons simplify-1 >r cons r> ] ifte
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
: simplify ( linear -- linear )
|
||||
#! Keep simplifying until simplify-1 returns f.
|
||||
[
|
||||
dup simplifying set simplify-1
|
||||
] with-scope [ simplify ] when ;
|
||||
|
||||
: label-called? ( label -- ? )
|
||||
simplifying get [ calls-label? ] contains-with? ;
|
||||
|
||||
M: %label simplify-node ( linear vop -- linear ? )
|
||||
vop-label label-called? [ f ] [ cdr t ] ifte ;
|
||||
|
||||
: next-physical? ( linear class -- vop ? )
|
||||
#! If the following op has given class, remove it and
|
||||
#! return it.
|
||||
over cdr dup [
|
||||
car class = [ second t ] [ f ] ifte
|
||||
] [
|
||||
3drop f f
|
||||
] ifte ;
|
||||
|
||||
M: %inc-d simplify-node ( linear vop -- linear ? )
|
||||
#! %inc-d cancels a following %inc-d.
|
||||
dup vop-in-1 0 = [
|
||||
drop cdr t
|
||||
] [
|
||||
>r dup \ %inc-d next-physical? [
|
||||
vop-in-1 r> vop-in-1 +
|
||||
%inc-d >r cdr cdr r> swons t
|
||||
] [
|
||||
r> 2drop f
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
: operands= ( vop vop -- ? )
|
||||
over vop-inputs over vop-inputs =
|
||||
>r swap vop-outputs swap vop-outputs = r> and ;
|
||||
|
||||
: cancel ( linear class -- linear ? )
|
||||
dupd next-physical?
|
||||
[ over first operands= [ cdr cdr t ] [ f ] ifte ]
|
||||
[ drop f ] ifte ;
|
||||
|
||||
M: %retag-fixnum simplify-node ( linear vop -- linear ? )
|
||||
drop \ %untag-fixnum cancel ;
|
||||
|
||||
: basic-block ( linear quot -- | quot: vop -- ? )
|
||||
#! Keep applying the quotation to each VOP until either a
|
||||
#! VOP answering f to basic-block?, or the quotation answers
|
||||
#! f.
|
||||
over car basic-block? [
|
||||
>r uncons r> tuck >r >r call [
|
||||
r> r> basic-block
|
||||
] [
|
||||
r> r> 2drop
|
||||
] ifte
|
||||
] [
|
||||
2drop
|
||||
] ifte ; inline
|
||||
|
||||
: reads-vreg? ( vreg linear -- ? )
|
||||
#! Tests if the vreg is read before being written in the
|
||||
#! current basic block. Outputs a true value if the vreg
|
||||
#! is not read or written before the end of the basic block.
|
||||
[
|
||||
2dup vop-inputs member? [
|
||||
! we are reading the vreg
|
||||
2drop t f
|
||||
] [
|
||||
2dup vop-outputs member? [
|
||||
! we are writing the vreg
|
||||
2drop f f
|
||||
] [
|
||||
! keep checking
|
||||
drop t
|
||||
] ifte
|
||||
] ifte
|
||||
] basic-block ;
|
||||
|
||||
: dead-load ( vreg linear -- linear ? )
|
||||
#! If the vreg is not read before being written, drop
|
||||
#! the current VOP.
|
||||
tuck cdr reads-vreg? [ f ] [ cdr t ] ifte ;
|
||||
|
||||
M: %peek-d simplify-node ( linear vop -- linear ? )
|
||||
vop-out-1 swap dead-load ;
|
||||
|
||||
M: %immediate simplify-node ( linear vop -- linear ? )
|
||||
vop-out-1 swap dead-load ;
|
||||
|
||||
M: %indirect simplify-node ( linear vop -- linear ? )
|
||||
vop-out-1 swap dead-load ;
|
||||
|
||||
: dead-peek? ( linear vop -- ? )
|
||||
#! Is the %replace-d followed by a %peek-d of the same
|
||||
#! stack slot and vreg?
|
||||
swap second dup %peek-d? [
|
||||
over vop-in-2 over vop-out-1 = >r
|
||||
swap vop-in-1 swap vop-in-1 = r> and
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
||||
: dead-replace? ( linear n -- ? )
|
||||
#! Is the %replace-d followed by a %dec-d, so the stored
|
||||
#! value is lost?
|
||||
swap \ %inc-d next-physical? [
|
||||
vop-in-1 + 0 <
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
||||
M: %replace-d simplify-node ( linear vop -- linear ? )
|
||||
2dup dead-peek? [
|
||||
drop uncons cdr cons t
|
||||
] [
|
||||
dupd vop-in-1 dead-replace? [ cdr t ] [ f ] ifte
|
||||
] ifte ;
|
||||
|
||||
: pop? ( vop -- ? ) dup %inc-d? swap vop-in-1 -1 = and ;
|
||||
|
||||
: can-fast-branch? ( linear -- ? )
|
||||
unswons class fast-branch [
|
||||
unswons pop? [ car %jump-t? ] [ drop f ] ifte
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
||||
: fast-branch-params ( linear -- src dest label linear )
|
||||
uncons >r dup vop-in-1 swap vop-out-1 r> cdr
|
||||
uncons >r vop-label r> ;
|
||||
|
||||
: make-fast-branch ( linear op -- linear ? )
|
||||
>r dup can-fast-branch? [
|
||||
fast-branch-params r> swap >r
|
||||
execute >r -1 %inc-d r>
|
||||
r> cons cons t
|
||||
] [
|
||||
r> drop f
|
||||
] ifte ;
|
||||
|
||||
M: fast-branch simplify-node ( linear vop -- linear ? )
|
||||
class fast-branch make-fast-branch ;
|
||||
|
||||
: ?label ( symbol linear -- ? )
|
||||
car dup %label? [ vop-label = ] [ 2drop f ] ifte ;
|
||||
|
||||
: (find-label) ( label linear -- linear )
|
||||
dup
|
||||
[ 2dup ?label [ nip ] [ cdr (find-label) ] ifte ]
|
||||
[ 2drop f ] ifte ;
|
||||
|
||||
: find-label ( label -- rest )
|
||||
simplifying get (find-label) ;
|
||||
|
||||
M: %label next-logical ( linear vop -- linear )
|
||||
drop cdr dup car next-logical ;
|
||||
|
||||
M: %jump-label next-logical ( linear vop -- linear )
|
||||
nip vop-label find-label cdr ;
|
||||
|
||||
M: %target-label next-logical ( linear vop -- linear )
|
||||
nip vop-label find-label cdr ;
|
||||
|
||||
M: object next-logical ( linear vop -- linear )
|
||||
drop ;
|
||||
|
||||
: next-logical? ( op linear -- ? )
|
||||
dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
|
||||
|
||||
: collapse ( linear op new -- linear ? )
|
||||
>r over cdr next-logical? [
|
||||
dup car vop-label
|
||||
r> execute swap cdr cons t
|
||||
] [
|
||||
r> drop f
|
||||
] ifte ; inline
|
||||
|
||||
M: %call simplify-node ( linear vop -- ? )
|
||||
#! Tail call optimization.
|
||||
drop \ %return \ %jump collapse ;
|
||||
|
||||
M: %call-label simplify-node ( linear vop -- ? )
|
||||
#! Tail call optimization.
|
||||
drop \ %return \ %jump-label collapse ;
|
||||
|
||||
: double-jump ( linear op2 op1 -- linear ? )
|
||||
#! A jump to a jump is just a jump. If the next logical node
|
||||
#! is a jump of type op1, replace the jump at the car of the
|
||||
#! list with a jump of type op2.
|
||||
pick next-logical? [
|
||||
>r dup dup car next-logical car vop-label
|
||||
r> execute swap cdr cons t
|
||||
] [ drop f ] ifte ; inline
|
||||
|
||||
: useless-jump ( linear -- linear ? )
|
||||
#! A jump to a label immediately following is not needed.
|
||||
dup car vop-label find-label find-label
|
||||
over cdr eq? [ cdr t ] [ f ] ifte ;
|
||||
|
||||
: (dead-code) ( linear -- linear ? )
|
||||
#! Remove all nodes until the next #label.
|
||||
dup [
|
||||
dup car %label?
|
||||
[ f ] [ cdr (dead-code) t or ] ifte
|
||||
] [ f ] ifte ;
|
||||
|
||||
: dead-code ( linear -- linear ? )
|
||||
uncons (dead-code) >r cons r> ;
|
||||
|
||||
M: %jump-label simplify-node ( linear vop -- linear ? )
|
||||
drop {
|
||||
{ [ \ %return dup double-jump ] [ t ] }
|
||||
{ [ \ %jump-label dup double-jump ] [ t ] }
|
||||
{ [ \ %jump dup double-jump ] [ t ] }
|
||||
{ [ useless-jump ] [ t ] }
|
||||
{ [ t ] [ dead-code ] }
|
||||
} cond ;
|
||||
|
||||
M: %target-label simplify-node ( linear vop -- linear ? )
|
||||
drop
|
||||
\ %target-label \ %jump-label double-jump ;
|
||||
|
||||
M: %jump simplify-node ( linear vop -- linear ? )
|
||||
drop dead-code ;
|
||||
|
||||
M: %return simplify-node ( linear vop -- linear ? )
|
||||
drop dead-code ;
|
||||
|
||||
M: %end-dispatch simplify-node ( linear vop -- linear ? )
|
||||
drop dead-code ;
|
||||
|
|
@ -18,6 +18,9 @@ parser sequences vectors words ;
|
|||
: label? ( obj -- ? )
|
||||
dup word? [ "label" word-prop ] [ drop f ] ifte ;
|
||||
|
||||
! A location is a virtual register or a stack slot. We can
|
||||
! ask a VOP if it reads or writes a location.
|
||||
|
||||
! A virtual register
|
||||
TUPLE: vreg n ;
|
||||
|
||||
|
|
@ -25,22 +28,24 @@ TUPLE: vreg n ;
|
|||
TUPLE: int-regs ;
|
||||
TUPLE: float-regs size ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
|
||||
! A call stack location.
|
||||
TUPLE: cs-loc n ;
|
||||
|
||||
! A virtual operation
|
||||
TUPLE: vop inputs outputs label ;
|
||||
: vop-in-1 ( vop -- input ) vop-inputs first ;
|
||||
: vop-in-2 ( vop -- input ) vop-inputs second ;
|
||||
: vop-in-3 ( vop -- input ) vop-inputs third ;
|
||||
: vop-out-1 ( vop -- output ) vop-outputs first ;
|
||||
: vop-out-2 ( vop -- output ) vop-outputs second ;
|
||||
: vop-in ( vop n -- input ) swap vop-inputs nth ;
|
||||
: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
|
||||
: vop-out ( vop n -- input ) swap vop-outputs nth ;
|
||||
: set-vop-out ( input vop n -- ) swap vop-outputs set-nth ;
|
||||
|
||||
GENERIC: basic-block? ( vop -- ? )
|
||||
M: vop basic-block? drop f ;
|
||||
! simplifies some code
|
||||
M: f basic-block? drop f ;
|
||||
|
||||
GENERIC: calls-label? ( label vop -- ? )
|
||||
M: vop calls-label? vop-label = ;
|
||||
|
||||
: make-vop ( inputs outputs label vop -- vop )
|
||||
[ >r <vop> r> set-delegate ] keep ;
|
||||
|
||||
|
|
@ -64,7 +69,6 @@ C: %prologue make-vop ;
|
|||
TUPLE: %label ;
|
||||
C: %label make-vop ;
|
||||
: %label label-vop <%label> ;
|
||||
M: %label calls-label? 2drop f ;
|
||||
|
||||
! Return vops take a label that is ignored, to have the
|
||||
! same stack effect as jumps. This is needed for the
|
||||
|
|
@ -121,41 +125,57 @@ C: %end-dispatch make-vop ;
|
|||
! stack operations
|
||||
TUPLE: %peek-d ;
|
||||
C: %peek-d make-vop ;
|
||||
: %peek-d ( vreg n -- vop ) swap <vreg> src/dest-vop <%peek-d> ;
|
||||
|
||||
: %peek-d ( vreg n -- vop )
|
||||
<ds-loc> swap <vreg> src/dest-vop <%peek-d> ;
|
||||
|
||||
M: %peek-d basic-block? drop t ;
|
||||
|
||||
TUPLE: %replace-d ;
|
||||
C: %replace-d make-vop ;
|
||||
: %replace-d ( vreg n -- vop ) swap <vreg> 2-in-vop <%replace-d> ;
|
||||
|
||||
: %replace-d ( vreg n -- vop )
|
||||
<ds-loc> swap <vreg> swap src/dest-vop <%replace-d> ;
|
||||
|
||||
M: %replace-d basic-block? drop t ;
|
||||
|
||||
TUPLE: %inc-d ;
|
||||
C: %inc-d make-vop ;
|
||||
: %inc-d ( n -- node ) src-vop <%inc-d> ;
|
||||
M: %inc-d basic-block? drop t ;
|
||||
|
||||
: %inc-d, ( n -- ) dup 0 = [ dup %inc-d , ] unless drop ;
|
||||
M: %inc-d basic-block? drop t ;
|
||||
|
||||
TUPLE: %immediate ;
|
||||
C: %immediate make-vop ;
|
||||
|
||||
: %immediate ( vreg obj -- vop )
|
||||
swap <vreg> src/dest-vop <%immediate> ;
|
||||
|
||||
M: %immediate basic-block? drop t ;
|
||||
|
||||
TUPLE: %peek-r ;
|
||||
C: %peek-r make-vop ;
|
||||
: %peek-r ( vreg n -- vop ) swap <vreg> src/dest-vop <%peek-r> ;
|
||||
|
||||
: %peek-r ( vreg n -- vop )
|
||||
<cs-loc> swap <vreg> src/dest-vop <%peek-r> ;
|
||||
|
||||
M: %peek-r basic-block? drop t ;
|
||||
|
||||
TUPLE: %replace-r ;
|
||||
C: %replace-r make-vop ;
|
||||
: %replace-r ( vreg n -- vop ) swap <vreg> 2-in-vop <%replace-r> ;
|
||||
|
||||
: %replace-r ( vreg n -- vop )
|
||||
<cs-loc> swap <vreg> swap src/dest-vop <%replace-r> ;
|
||||
|
||||
M: %replace-r basic-block? drop t ;
|
||||
|
||||
TUPLE: %inc-r ;
|
||||
|
||||
C: %inc-r make-vop ;
|
||||
|
||||
: %inc-r ( n -- ) src-vop <%inc-r> ;
|
||||
|
||||
: %inc-r, ( n -- ) dup 0 = [ dup %inc-r , ] unless drop ;
|
||||
M: %inc-r basic-block? drop t ;
|
||||
|
||||
: in-1 0 0 %peek-d , ;
|
||||
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
|
||||
|
|
@ -222,14 +242,22 @@ TUPLE: %fixnum/i ;
|
|||
C: %fixnum/i make-vop ; : %fixnum/i 3-vop <%fixnum/i> ;
|
||||
TUPLE: %fixnum/mod ;
|
||||
C: %fixnum/mod make-vop ; : %fixnum/mod f <%fixnum/mod> ;
|
||||
|
||||
TUPLE: %fixnum-bitand ;
|
||||
C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
|
||||
M: %fixnum-bitand basic-block? drop t ;
|
||||
|
||||
TUPLE: %fixnum-bitor ;
|
||||
C: %fixnum-bitor make-vop ; : %fixnum-bitor 3-vop <%fixnum-bitor> ;
|
||||
M: %fixnum-bitor basic-block? drop t ;
|
||||
|
||||
TUPLE: %fixnum-bitxor ;
|
||||
C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
|
||||
M: %fixnum-bitxor basic-block? drop t ;
|
||||
|
||||
TUPLE: %fixnum-bitnot ;
|
||||
C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
|
||||
M: %fixnum-bitnot basic-block? drop t ;
|
||||
|
||||
TUPLE: %fixnum<= ;
|
||||
C: %fixnum<= make-vop ; : %fixnum<= 3-vop <%fixnum<=> ;
|
||||
|
|
@ -252,12 +280,17 @@ C: %eq? make-vop ; : %eq? 3-vop <%eq?> ;
|
|||
! - shifts with a large negative count: %fixnum-sgn
|
||||
TUPLE: %fixnum<< ;
|
||||
C: %fixnum<< make-vop ; : %fixnum<< 3-vop <%fixnum<<> ;
|
||||
|
||||
TUPLE: %fixnum>> ;
|
||||
C: %fixnum>> make-vop ; : %fixnum>> 3-vop <%fixnum>>> ;
|
||||
M: %fixnum>> basic-block? drop t ;
|
||||
|
||||
! due to x86 limitations the destination of this VOP must be
|
||||
! vreg 2 (EDX), and the source must be vreg 0 (EAX).
|
||||
TUPLE: %fixnum-sgn ;
|
||||
C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
|
||||
M: %fixnum-sgn basic-block? drop t ;
|
||||
|
||||
|
||||
! Integer comparison followed by a conditional branch is
|
||||
! optimized
|
||||
|
|
@ -317,10 +350,10 @@ C: %untag-fixnum make-vop ;
|
|||
M: %untag-fixnum basic-block? drop t ;
|
||||
|
||||
: check-dest ( vop reg -- )
|
||||
swap vop-out-1 = [ "bad VOP destination" throw ] unless ;
|
||||
swap 0 vop-out = [ "bad VOP destination" throw ] unless ;
|
||||
|
||||
: check-src ( vop reg -- )
|
||||
swap vop-in-1 = [ "bad VOP source" throw ] unless ;
|
||||
swap 0 vop-in = [ "bad VOP source" throw ] unless ;
|
||||
|
||||
TUPLE: %getenv ;
|
||||
C: %getenv make-vop ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ kernel-internals lists math memory namespaces words ;
|
|||
|
||||
M: %alien-invoke generate-node
|
||||
#! call a C function.
|
||||
dup vop-in-1 swap vop-in-2 load-library compile-c-call ;
|
||||
dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
|
||||
|
||||
M: %parameters generate-node
|
||||
#! x86 does not pass parameters in registers
|
||||
|
|
@ -28,12 +28,12 @@ M: float-regs push-reg
|
|||
4 = [ FSTPS ] [ FSTPL ] ifte ;
|
||||
|
||||
M: %unbox generate-node
|
||||
dup vop-in-2 f compile-c-call vop-in-3 push-reg ;
|
||||
dup 1 vop-in f compile-c-call 2 vop-in push-reg ;
|
||||
|
||||
M: %box generate-node
|
||||
dup vop-in-2 push-reg
|
||||
dup vop-in-1 f compile-c-call
|
||||
vop-in-2 ESP swap reg-size ADD ;
|
||||
dup 1 vop-in push-reg
|
||||
dup 0 vop-in f compile-c-call
|
||||
1 vop-in ESP swap reg-size ADD ;
|
||||
|
||||
M: %cleanup generate-node
|
||||
vop-in-1 dup 0 = [ drop ] [ ESP swap ADD ] ifte ;
|
||||
0 vop-in dup 0 = [ drop ] [ ESP swap ADD ] ifte ;
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ M: %fixnum-bitxor generate-node ( vop -- ) dest/src XOR ;
|
|||
|
||||
M: %fixnum-bitnot generate-node ( vop -- )
|
||||
! Negate the bits of the operand
|
||||
vop-out-1 v>operand dup NOT
|
||||
0 vop-out v>operand dup NOT
|
||||
! Mask off the low 3 bits to give a fixnum tag
|
||||
tag-mask XOR ;
|
||||
|
||||
|
|
@ -122,7 +122,7 @@ M: %fixnum<< generate-node
|
|||
<label> "end" set
|
||||
! make a copy
|
||||
ECX EAX MOV
|
||||
vop-in-1
|
||||
0 vop-in
|
||||
! check for potential overflow
|
||||
dup shift-add ECX over ADD
|
||||
2 * 1 - ECX swap CMP
|
||||
|
|
@ -147,7 +147,7 @@ M: %fixnum<< generate-node
|
|||
|
||||
M: %fixnum>> generate-node
|
||||
! shift register
|
||||
dup vop-out-1 v>operand dup rot vop-in-1 SAR
|
||||
dup 0 vop-out v>operand dup rot 0 vop-in SAR
|
||||
! give it a fixnum tag
|
||||
tag-mask bitnot AND ;
|
||||
|
||||
|
|
@ -155,7 +155,7 @@ M: %fixnum-sgn generate-node
|
|||
! store 0 in EDX if EAX is >=0, otherwise store -1.
|
||||
CDQ
|
||||
! give it a fixnum tag.
|
||||
vop-out-1 v>operand tag-bits SHL ;
|
||||
0 vop-out v>operand tag-bits SHL ;
|
||||
|
||||
: load-boolean ( dest cond -- )
|
||||
#! Compile this after a conditional jump to store f or t
|
||||
|
|
@ -170,7 +170,7 @@ M: %fixnum-sgn generate-node
|
|||
"end" get save-xt ; inline
|
||||
|
||||
: fixnum-compare ( vop -- dest )
|
||||
dup vop-out-1 v>operand dup rot vop-in-1 v>operand CMP ;
|
||||
dup 0 vop-out v>operand dup rot 0 vop-in v>operand CMP ;
|
||||
|
||||
M: %fixnum< generate-node ( vop -- )
|
||||
fixnum-compare \ JL load-boolean ;
|
||||
|
|
@ -188,7 +188,7 @@ M: %eq? generate-node ( vop -- )
|
|||
fixnum-compare \ JE load-boolean ;
|
||||
|
||||
: fixnum-jump ( vop -- label )
|
||||
dup vop-in-2 v>operand over vop-in-1 v>operand CMP
|
||||
dup 1 vop-in v>operand over 0 vop-in v>operand CMP
|
||||
vop-label ;
|
||||
|
||||
M: %jump-fixnum< generate-node ( vop -- ) fixnum-jump JL ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ M: %jump-label generate-node ( vop -- )
|
|||
vop-label JMP ;
|
||||
|
||||
: conditional ( vop -- label )
|
||||
dup vop-in-1 v>operand f address CMP vop-label ;
|
||||
dup 0 vop-in v>operand f address CMP vop-label ;
|
||||
|
||||
M: %jump-f generate-node ( vop -- )
|
||||
conditional JE ;
|
||||
|
|
@ -38,19 +38,19 @@ M: %return generate-node ( vop -- )
|
|||
drop RET ;
|
||||
|
||||
M: %untag generate-node ( vop -- )
|
||||
vop-out-1 v>operand BIN: 111 bitnot AND ;
|
||||
0 vop-out v>operand BIN: 111 bitnot AND ;
|
||||
|
||||
M: %retag-fixnum generate-node ( vop -- )
|
||||
vop-out-1 v>operand 3 SHL ;
|
||||
0 vop-out v>operand 3 SHL ;
|
||||
|
||||
M: %untag-fixnum generate-node ( vop -- )
|
||||
vop-out-1 v>operand 3 SHR ;
|
||||
0 vop-out v>operand 3 SHR ;
|
||||
|
||||
M: %dispatch generate-node ( vop -- )
|
||||
#! Compile a piece of code that jumps to an offset in a
|
||||
#! jump table indexed by the fixnum at the top of the stack.
|
||||
#! The jump table must immediately follow this macro.
|
||||
vop-in-1 v>operand
|
||||
0 vop-in v>operand
|
||||
! Multiply by 4 to get a jump table offset
|
||||
dup 2 SHL
|
||||
! Add to jump table base
|
||||
|
|
@ -64,10 +64,10 @@ M: %dispatch generate-node ( vop -- )
|
|||
|
||||
M: %type generate-node ( vop -- )
|
||||
#! Intrinstic version of type primitive. It outputs an
|
||||
#! UNBOXED value in vop-out-1.
|
||||
#! UNBOXED value in 0 vop-out.
|
||||
<label> "f" set
|
||||
<label> "end" set
|
||||
vop-out-1 v>operand
|
||||
0 vop-out v>operand
|
||||
! Make a copy
|
||||
ECX over MOV
|
||||
! Get the tag
|
||||
|
|
@ -91,5 +91,5 @@ M: %type generate-node ( vop -- )
|
|||
"end" get save-xt ;
|
||||
|
||||
M: %tag generate-node ( vop -- )
|
||||
dup dup vop-in-1 check-dest
|
||||
vop-in-1 v>operand tag-mask AND ;
|
||||
dup dup 0 vop-in check-dest
|
||||
0 vop-in v>operand tag-mask AND ;
|
||||
|
|
|
|||
|
|
@ -8,45 +8,45 @@ M: %slot generate-node ( vop -- )
|
|||
dest/src
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
dup 1 SHR
|
||||
! compute slot address in vop-out-1
|
||||
! compute slot address in 0 vop-out
|
||||
dupd ADD
|
||||
! load slot value in vop-out-1
|
||||
! load slot value in 0 vop-out
|
||||
dup unit MOV ;
|
||||
|
||||
M: %fast-slot generate-node ( vop -- )
|
||||
dup vop-in-1 swap vop-out-1 v>operand tuck >r 2list r>
|
||||
dup 0 vop-in swap 0 vop-out v>operand tuck >r 2list r>
|
||||
swap MOV ;
|
||||
|
||||
: card-offset 1 getenv ;
|
||||
|
||||
M: %write-barrier generate-node ( vop -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
vop-in-1 v>operand
|
||||
0 vop-in v>operand
|
||||
dup card-bits SHR
|
||||
card-offset 2list card-mark OR
|
||||
0 rel-cards ;
|
||||
|
||||
M: %set-slot generate-node ( vop -- )
|
||||
dup vop-in-3 v>operand over vop-in-2 v>operand
|
||||
dup 2 vop-in v>operand over 1 vop-in v>operand
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
over 1 SHR
|
||||
! compute slot address in vop-in-2
|
||||
! compute slot address in 1 vop-in
|
||||
dupd ADD
|
||||
! store new slot value
|
||||
>r vop-in-1 v>operand r> unit swap MOV ;
|
||||
>r 0 vop-in v>operand r> unit swap MOV ;
|
||||
|
||||
M: %fast-set-slot generate-node ( vop -- )
|
||||
dup vop-in-3 over vop-in-2 v>operand
|
||||
swap 2list swap vop-in-1 v>operand MOV ;
|
||||
dup 2 vop-in over 1 vop-in v>operand
|
||||
swap 2list swap 0 vop-in v>operand MOV ;
|
||||
|
||||
: userenv@ ( n -- addr )
|
||||
cell * "userenv" f dlsym + ;
|
||||
|
||||
M: %getenv generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1
|
||||
dup 0 vop-out v>operand swap 0 vop-in
|
||||
[ userenv@ unit MOV ] keep 0 rel-userenv ;
|
||||
|
||||
M: %setenv generate-node ( vop -- )
|
||||
dup vop-in-2
|
||||
[ userenv@ unit swap vop-in-1 v>operand MOV ] keep
|
||||
dup 1 vop-in
|
||||
[ userenv@ unit swap 0 vop-in v>operand MOV ] keep
|
||||
0 rel-userenv ;
|
||||
|
|
|
|||
|
|
@ -8,30 +8,30 @@ memory sequences words ;
|
|||
: ds-op ( n -- op ) ESI swap reg-stack ;
|
||||
: cs-op ( n -- op ) EBX swap reg-stack ;
|
||||
|
||||
: (%peek) dup vop-out-1 v>operand swap vop-in-1 ;
|
||||
: (%peek) dup 0 vop-out v>operand swap 0 vop-in ;
|
||||
|
||||
M: %peek-d generate-node ( vop -- ) (%peek) ds-op MOV ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- ) (%peek) cs-op MOV ;
|
||||
|
||||
: (%replace) dup vop-in-2 v>operand swap vop-in-1 ;
|
||||
: (%replace) dup 1 vop-in v>operand swap 0 vop-in ;
|
||||
|
||||
M: %replace-d generate-node ( vop -- ) (%replace) ds-op swap MOV ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- ) (%replace) cs-op swap MOV ;
|
||||
|
||||
: (%inc) swap vop-in-1 cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
|
||||
: (%inc) swap 0 vop-in cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
|
||||
|
||||
M: %inc-d generate-node ( vop -- ) ESI (%inc) ;
|
||||
|
||||
M: %inc-r generate-node ( vop -- ) EBX (%inc) ;
|
||||
|
||||
M: %immediate generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 address MOV ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in address MOV ;
|
||||
|
||||
: load-indirect ( dest literal -- )
|
||||
intern-literal unit MOV 0 0 rel-address ;
|
||||
|
||||
M: %indirect generate-node ( vop -- )
|
||||
#! indirect load of a literal through a table
|
||||
dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
|
||||
dup 0 vop-out v>operand swap 0 vop-in load-indirect ;
|
||||
|
|
|
|||
|
|
@ -144,7 +144,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
|
|||
] with-scope ;
|
||||
|
||||
: postpone-word ( word -- )
|
||||
dup compiling? [
|
||||
dup compiling? over compound? not or [
|
||||
drop
|
||||
] [
|
||||
compile-words [ unique ] change
|
||||
|
|
|
|||
|
|
@ -447,10 +447,10 @@ memory parser sequences strings vectors words prettyprint ;
|
|||
|
||||
\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ char-slot [ [ object fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
|
||||
\ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
|
||||
\ char-slot t "flushable" set-word-prop
|
||||
|
||||
\ set-char-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
|
||||
\ set-char-slot [ [ integer fixnum object ] [ ] ] "infer-effect" set-word-prop
|
||||
\ resize-array [ [ integer array ] [ array ] ] "infer-effect" set-word-prop
|
||||
\ resize-string [ [ integer string ] [ string ] ] "infer-effect" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: integer ^ ( z w -- z^w )
|
|||
"0^0 is not defined" throw
|
||||
] [
|
||||
dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
|
||||
] ifte ; foldable
|
||||
] ifte ;
|
||||
|
||||
: (^mod) ( n z w -- z^w )
|
||||
1 swap [
|
||||
|
|
|
|||
|
|
@ -34,7 +34,8 @@ test vectors words ;
|
|||
[ [ 1 2 3 ] [ 4 5 6 ] [ 1 2 3 ] ] [ kill-6 ] unit-test
|
||||
|
||||
: kill-set*
|
||||
dataflow kill-set [ literal-value ] map ;
|
||||
dataflow dup solve-recursion dup split-node
|
||||
kill-set [ literal-value ] map ;
|
||||
|
||||
: foo 1 2 3 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -31,3 +31,5 @@ USE: test
|
|||
|
||||
[ 1 3 ] [ [[ 1 2 ]] [[ 3 4 ]] 2car ] unit-test
|
||||
[ 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2cdr ] unit-test
|
||||
|
||||
[ f ] [ f peek ] unit-test
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ parser prettyprint sequences io strings vectors words ;
|
|||
PREDICATE: cons kernel-error ( obj -- ? )
|
||||
car kernel-error = ;
|
||||
|
||||
M: f error. ( f -- ) ;
|
||||
M: f error. ( f -- ) drop ;
|
||||
|
||||
M: kernel-error error. ( error -- )
|
||||
#! Kernel errors are indexed by integers.
|
||||
|
|
|
|||
|
|
@ -53,11 +53,7 @@ unparser vectors words ;
|
|||
: instances ( quot -- list )
|
||||
#! Return a list of all object that return true when the
|
||||
#! quotation is applied to them.
|
||||
[
|
||||
[
|
||||
[ swap call ] 2keep rot [ , ] [ drop ] ifte
|
||||
] each-object drop
|
||||
] [ ] make ;
|
||||
[ [ [ swap call ] 2keep rot ?, ] each-object drop ] [ ] make ;
|
||||
|
||||
G: each-slot ( obj quot -- )
|
||||
[ over ] standard-combination ; inline
|
||||
|
|
|
|||
|
|
@ -63,8 +63,6 @@ SYMBOL: commands
|
|||
[ compound? ] "Annotate with breakpoint" [ break ] define-command
|
||||
[ compound? ] "Annotate with profiling" [ profile ] define-command
|
||||
[ word? ] "Compile" [ recompile ] define-command
|
||||
[ word? ] "Show stack effect" [ unit infer . ] define-command
|
||||
[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
|
||||
[ word? ] "Show linear IR" [ precompile ] define-command
|
||||
[ word? ] "Infer stack effect" [ unit infer . ] define-command
|
||||
|
||||
[ [ gadget? ] is? ] "Display gadget" [ gadget. ] define-command
|
||||
|
|
|
|||
|
|
@ -1,5 +1,12 @@
|
|||
#include "factor.h"
|
||||
|
||||
F_FLOAT* make_float(double n)
|
||||
{
|
||||
F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
|
||||
flo->n = n;
|
||||
return flo;
|
||||
}
|
||||
|
||||
double to_float(CELL tagged)
|
||||
{
|
||||
F_RATIO* r;
|
||||
|
|
|
|||
|
|
@ -3,12 +3,7 @@ typedef struct {
|
|||
double n;
|
||||
} F_FLOAT;
|
||||
|
||||
INLINE F_FLOAT* make_float(double n)
|
||||
{
|
||||
F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
|
||||
flo->n = n;
|
||||
return flo;
|
||||
}
|
||||
F_FLOAT* make_float(double n);
|
||||
|
||||
INLINE double untag_float_fast(CELL tagged)
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue