tweaking stack shuffle compilation
Slava Pestov
parent
eb73ee864f
commit
7711aff1a5
|
|
@ -124,6 +124,7 @@ sequences io vectors words ;
|
|||
"/library/inference/optimizer.factor"
|
||||
"/library/inference/inline-methods.factor"
|
||||
"/library/inference/known-words.factor"
|
||||
"/library/inference/stack.factor"
|
||||
"/library/inference/call-optimizers.factor"
|
||||
"/library/inference/print-dataflow.factor"
|
||||
|
||||
|
|
@ -132,6 +133,7 @@ sequences io vectors words ;
|
|||
"/library/compiler/xt.factor"
|
||||
"/library/compiler/vops.factor"
|
||||
"/library/compiler/linearizer.factor"
|
||||
"/library/compiler/stack.factor"
|
||||
"/library/compiler/intrinsics.factor"
|
||||
"/library/compiler/simplifier.factor"
|
||||
"/library/compiler/generator.factor"
|
||||
|
|
|
|||
|
|
@ -6,21 +6,14 @@ kernel lists math namespaces prettyprint sequences words ;
|
|||
: supported-cpu? ( -- ? )
|
||||
cpu "unknown" = not ;
|
||||
|
||||
: check-architecture ( -- )
|
||||
supported-cpu? [
|
||||
"Unsupported CPU; compiler disabled" throw
|
||||
] unless ;
|
||||
|
||||
: compiling ( word -- word parameter )
|
||||
check-architecture "Compiling " write dup . dup word-def ;
|
||||
|
||||
GENERIC: (compile) ( word -- )
|
||||
|
||||
M: word (compile) drop ;
|
||||
|
||||
M: compound (compile) ( word -- )
|
||||
#! Should be called inside the with-compiler scope.
|
||||
compiling dataflow optimize linearize simplify generate ;
|
||||
"Compiling " write dup .
|
||||
dup word-def dataflow optimize linearize simplify generate ;
|
||||
|
||||
: precompile ( word -- )
|
||||
#! Print linear IR of word.
|
||||
|
|
@ -40,30 +33,18 @@ M: compound (compile) ( word -- )
|
|||
#! Compile the most recently defined word.
|
||||
"compile" get [ word compile ] when ; parsing
|
||||
|
||||
: cannot-compile ( word error -- )
|
||||
"Cannot compile " write swap . print-error ;
|
||||
|
||||
: try-compile ( word -- )
|
||||
[ compile ] [ [ cannot-compile ] when* ] catch ;
|
||||
[ compile ] [ error. ] catch ;
|
||||
|
||||
: compile-all ( -- ) [ try-compile ] each-word ;
|
||||
|
||||
: recompile ( word -- )
|
||||
dup update-xt compile ;
|
||||
|
||||
: compile-1 ( quot -- word )
|
||||
#! Compute a quotation into an uninterned word, for testing
|
||||
#! purposes.
|
||||
gensym [ swap define-compound ] keep dup compile execute ;
|
||||
|
||||
\ dataflow profile
|
||||
\ optimize profile
|
||||
\ linearize profile
|
||||
\ simplify profile
|
||||
\ generate profile
|
||||
\ kill-node profile
|
||||
\ partial-eval profile
|
||||
\ inline-method profile
|
||||
\ apply-identities profile
|
||||
\ subst-values profile
|
||||
\ split-branch profile
|
||||
: compile-1 ( quot -- )
|
||||
#! Compute and call a quotation.
|
||||
"compile" get [
|
||||
gensym [ swap define-compound ] keep dup compile execute
|
||||
] [
|
||||
call
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -10,50 +10,6 @@ sequences vectors words ;
|
|||
#! Can fixnum operations take immediate operands?
|
||||
cpu "x86" = ;
|
||||
|
||||
\ dup [
|
||||
drop
|
||||
in-1
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ swap [
|
||||
drop
|
||||
in-2
|
||||
0 0 %replace-d ,
|
||||
1 1 %replace-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ over [
|
||||
drop
|
||||
0 1 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ pick [
|
||||
drop
|
||||
0 2 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ >r [
|
||||
drop
|
||||
in-1
|
||||
1 %inc-r ,
|
||||
1 %dec-d ,
|
||||
0 0 %replace-r ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ r> [
|
||||
drop
|
||||
0 0 %peek-r ,
|
||||
1 %inc-d ,
|
||||
1 %dec-r ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: node-peek ( node -- value ) node-in-d peek ;
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
|
|
@ -80,13 +36,13 @@ sequences vectors words ;
|
|||
|
||||
\ slot [
|
||||
dup slot@ [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
0 swap slot@ %fast-slot ,
|
||||
] [
|
||||
drop
|
||||
in-2
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
0 %untag ,
|
||||
1 0 %slot ,
|
||||
] ifte out-1
|
||||
|
|
@ -94,14 +50,14 @@ sequences vectors words ;
|
|||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-2
|
||||
2 %dec-d ,
|
||||
-2 %inc-d,
|
||||
slot@ >r 0 1 r> %fast-set-slot ,
|
||||
] [
|
||||
drop
|
||||
in-3
|
||||
3 %dec-d ,
|
||||
-3 %inc-d,
|
||||
1 %untag ,
|
||||
0 1 2 %set-slot ,
|
||||
] ifte
|
||||
|
|
@ -125,17 +81,17 @@ sequences vectors words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
1 %dec-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 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
node-peek literal-value 0 <vreg> swap %setenv ,
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: value/vreg-list ( in -- list )
|
||||
|
|
@ -149,7 +105,7 @@ sequences vectors words ;
|
|||
|
||||
: load-inputs ( node -- in )
|
||||
dup node-in-d values>vregs
|
||||
[ length swap node-out-d length - %dec-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 ,
|
||||
|
|
@ -159,7 +115,7 @@ sequences vectors words ;
|
|||
dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
|
||||
|
||||
: binary-op-imm ( imm op -- )
|
||||
1 %dec-d , in-1
|
||||
-1 %inc-d, in-1
|
||||
>r 0 <vreg> dup r> execute ,
|
||||
0 0 %replace-d , ; inline
|
||||
|
||||
|
|
@ -192,7 +148,7 @@ sequences vectors words ;
|
|||
] each
|
||||
|
||||
: fast-fixnum* ( n -- )
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
log2 0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
0 0 %replace-d , ;
|
||||
|
|
@ -218,7 +174,7 @@ sequences vectors words ;
|
|||
! be EDX there.
|
||||
drop
|
||||
in-2
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
|
||||
2 0 %replace-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
@ -250,7 +206,7 @@ sequences vectors words ;
|
|||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
: negative-shift ( n -- )
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
dup cell -8 * <= [
|
||||
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
|
||||
|
|
@ -262,7 +218,7 @@ sequences vectors words ;
|
|||
|
||||
: positive-shift ( n -- )
|
||||
dup cell 8 * tag-bits - <= [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
out-1
|
||||
|
|
@ -272,7 +228,7 @@ sequences vectors words ;
|
|||
|
||||
: fast-shift ( n -- )
|
||||
dup 0 = [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
drop
|
||||
] [
|
||||
dup 0 < [
|
||||
|
|
|
|||
|
|
@ -56,14 +56,11 @@ M: literal load-value ( vreg n value -- )
|
|||
: push-1 ( value -- ) 0 swap push-literal ;
|
||||
|
||||
M: #push linearize-node* ( node -- )
|
||||
node-out-d dup length dup %inc-d ,
|
||||
node-out-d dup length dup %inc-d,
|
||||
1 - swap [ push-1 0 over %replace-d , ] each drop ;
|
||||
|
||||
M: #drop linearize-node* ( node -- )
|
||||
node-in-d length %dec-d , ;
|
||||
|
||||
: ifte-head ( label -- )
|
||||
in-1 1 %dec-d , 0 %jump-t , ;
|
||||
in-1 -1 %inc-d, 0 %jump-t , ;
|
||||
|
||||
M: #ifte linearize-node* ( node -- )
|
||||
node-children first2
|
||||
|
|
@ -76,7 +73,7 @@ M: #ifte linearize-node* ( node -- )
|
|||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
in-1
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
0 %untag-fixnum ,
|
||||
0 %dispatch ,
|
||||
[ <label> dup %target-label , cons ] map
|
||||
|
|
|
|||
|
|
@ -27,9 +27,6 @@ M: %inc-d generate-node ( vop -- )
|
|||
M: %inc-r generate-node ( vop -- )
|
||||
15 15 rot vop-in-1 cell * ADDI ;
|
||||
|
||||
M: %dec-r generate-node ( vop -- )
|
||||
15 15 rot vop-in-1 cell * SUBI ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -131,10 +131,11 @@ M: %replace-d basic-block? drop t ;
|
|||
|
||||
TUPLE: %inc-d ;
|
||||
C: %inc-d make-vop ;
|
||||
: %inc-d ( n -- ) src-vop <%inc-d> ;
|
||||
: %dec-d ( n -- ) neg %inc-d ;
|
||||
: %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 ;
|
||||
|
||||
TUPLE: %immediate ;
|
||||
C: %immediate make-vop ;
|
||||
: %immediate ( vreg obj -- )
|
||||
|
|
@ -151,12 +152,10 @@ C: %replace-r make-vop ;
|
|||
|
||||
TUPLE: %inc-r ;
|
||||
C: %inc-r make-vop ;
|
||||
|
||||
: %inc-r ( n -- ) src-vop <%inc-r> ;
|
||||
|
||||
! this exists, unlike %dec-d which does not, due to x86 quirks
|
||||
TUPLE: %dec-r ;
|
||||
C: %dec-r make-vop ;
|
||||
: %dec-r ( n -- ) src-vop <%dec-r> ;
|
||||
: %inc-r, ( n -- ) dup 0 = [ dup %inc-r , ] unless drop ;
|
||||
|
||||
: in-1 0 0 %peek-d , ;
|
||||
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
|
||||
|
|
|
|||
|
|
@ -4,28 +4,27 @@ IN: compiler-backend
|
|||
USING: alien assembler compiler inference kernel lists math
|
||||
memory sequences words ;
|
||||
|
||||
: rel-cs ( -- )
|
||||
#! Add an entry to the relocation table for the 32-bit
|
||||
#! immediate just compiled.
|
||||
"cs" f 0 0 rel-dlsym ;
|
||||
|
||||
: CS ( -- [ address ] ) "cs" f dlsym unit ;
|
||||
: CS> ( register -- ) CS MOV rel-cs ;
|
||||
: >CS ( register -- ) CS swap MOV rel-cs ;
|
||||
|
||||
: reg-stack ( reg n -- op ) cell * neg 2list ;
|
||||
: ds-op ( n -- op ) ESI swap reg-stack ;
|
||||
: cs-op ( n -- op ) ECX swap reg-stack ;
|
||||
: cs-op ( n -- op ) EBX swap reg-stack ;
|
||||
|
||||
M: %peek-d generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
|
||||
: (%peek) dup vop-out-1 v>operand swap vop-in-1 ;
|
||||
|
||||
M: %replace-d generate-node ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
|
||||
M: %peek-d generate-node ( vop -- ) (%peek) ds-op MOV ;
|
||||
|
||||
M: %inc-d generate-node ( vop -- )
|
||||
ESI swap vop-in-1 cell *
|
||||
dup 0 > [ ADD ] [ neg SUB ] ifte ;
|
||||
M: %peek-r generate-node ( vop -- ) (%peek) cs-op MOV ;
|
||||
|
||||
: (%replace) dup vop-in-2 v>operand swap vop-in-1 ;
|
||||
|
||||
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 ;
|
||||
|
||||
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 ;
|
||||
|
|
@ -36,20 +35,3 @@ M: %immediate generate-node ( vop -- )
|
|||
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 ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
ECX CS> dup vop-out-1 v>operand swap vop-in-1 cs-op MOV ;
|
||||
|
||||
M: %dec-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
vop-in-1 ECX swap cell * SUB ECX >CS ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- )
|
||||
#! Can only follow a %inc-r
|
||||
dup vop-in-2 v>operand swap vop-in-1 cs-op swap MOV
|
||||
ECX >CS ;
|
||||
|
||||
M: %inc-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
ECX CS>
|
||||
vop-in-1 ECX swap cell * ADD ;
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ M: node = eq? ;
|
|||
set-delegate
|
||||
] keep ;
|
||||
|
||||
: empty-node f { } { } { } { } ;
|
||||
: param-node ( label) { } { } { } { } ;
|
||||
: in-d-node ( inputs) >r f r> { } { } { } ;
|
||||
: out-d-node ( outputs) >r f { } r> { } { } ;
|
||||
|
|
@ -86,9 +87,9 @@ TUPLE: #push ;
|
|||
C: #push make-node ;
|
||||
: #push ( outputs -- node ) d-tail out-d-node <#push> ;
|
||||
|
||||
TUPLE: #drop ;
|
||||
C: #drop make-node ;
|
||||
: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
|
||||
TUPLE: #shuffle ;
|
||||
C: #shuffle make-node ;
|
||||
: #shuffle ( -- node ) empty-node <#shuffle> ;
|
||||
|
||||
TUPLE: #values ;
|
||||
C: #values make-node ;
|
||||
|
|
@ -163,6 +164,9 @@ SYMBOL: current-node
|
|||
: uses-value? ( value node -- ? )
|
||||
node-values [ value-refers? ] contains-with? ;
|
||||
|
||||
: outputs-value? ( value node -- ? )
|
||||
2dup node-out-d member? >r node-out-r member? r> or ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
dup node-successor [ last-node ] [ ] ?ifte ;
|
||||
|
||||
|
|
@ -174,8 +178,11 @@ SYMBOL: current-node
|
|||
2drop f
|
||||
] ifte ;
|
||||
|
||||
: drop-inputs ( node -- #drop )
|
||||
node-in-d clone in-d-node <#drop> ;
|
||||
: drop-inputs ( node -- #shuffle )
|
||||
node-in-d clone in-d-node <#shuffle> ;
|
||||
|
||||
: #drop ( n -- #shuffle )
|
||||
d-tail in-d-node <#shuffle> ;
|
||||
|
||||
: each-node ( node quot -- | quot: node -- )
|
||||
over [
|
||||
|
|
|
|||
|
|
@ -44,51 +44,8 @@ M: #push can-kill? ( literal node -- ? ) 2drop t ;
|
|||
M: #push kill-node* ( literals node -- )
|
||||
[ node-out-d seq-diff ] keep set-node-out-d ;
|
||||
|
||||
! #drop
|
||||
M: #drop can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
||||
! #call
|
||||
: (kill-shuffle) ( word -- map )
|
||||
{{
|
||||
[[ dup {{ }} ]]
|
||||
[[ drop {{ }} ]]
|
||||
[[ swap {{ }} ]]
|
||||
[[ over
|
||||
{{
|
||||
[[ { f t } dup ]]
|
||||
}}
|
||||
]]
|
||||
[[ pick
|
||||
{{
|
||||
[[ { f f t } over ]]
|
||||
[[ { f t f } over ]]
|
||||
[[ { f t t } dup ]]
|
||||
}}
|
||||
]]
|
||||
[[ >r {{ }} ]]
|
||||
[[ r> {{ }} ]]
|
||||
}} hash ;
|
||||
|
||||
M: #call can-kill? ( literal node -- ? )
|
||||
dup node-param (kill-shuffle) >r delegate can-kill? r> or ;
|
||||
|
||||
: kill-mask ( killing node -- mask )
|
||||
dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
|
||||
[ swap memq? ] map-with ;
|
||||
|
||||
: lookup-mask ( mask word -- word )
|
||||
over [ ] contains? [ (kill-shuffle) hash ] [ nip ] ifte ;
|
||||
|
||||
: kill-shuffle ( literals node -- )
|
||||
#! If certain values passing through a stack op are being
|
||||
#! killed, the stack op can be reduced, in extreme cases
|
||||
#! to a no-op.
|
||||
[ [ kill-mask ] keep node-param lookup-mask ] keep
|
||||
set-node-param ;
|
||||
|
||||
M: #call kill-node* ( literals node -- )
|
||||
dup node-param (kill-shuffle)
|
||||
[ kill-shuffle ] [ 2drop ] ifte ;
|
||||
! #shuffle
|
||||
M: #shuffle can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
||||
! #call-label
|
||||
M: #call-label can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
|
|
|||
|
|
@ -37,42 +37,6 @@ memory parser sequences strings vectors words prettyprint ;
|
|||
#dispatch pop-d drop infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
! Stack manipulation
|
||||
\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ >r [
|
||||
\ >r #call
|
||||
1 0 pick node-inputs
|
||||
pop-d push-r
|
||||
0 1 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ r> [
|
||||
\ r> #call
|
||||
0 1 pick node-inputs
|
||||
pop-r push-d
|
||||
1 0 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
|
||||
\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ dup [ \ dup infer-shuffle ] "infer" set-word-prop
|
||||
\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
|
||||
\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ over [ \ over infer-shuffle ] "infer" set-word-prop
|
||||
\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
|
||||
\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
! Non-standard control flow
|
||||
\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -54,9 +54,9 @@ M: node optimize-node* ( node -- t )
|
|||
M: #push optimize-node* ( node -- node/t )
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
|
||||
! #drop
|
||||
M: #drop optimize-node* ( node -- node/t )
|
||||
[ node-in-d empty? ] prune-if ;
|
||||
! #shuffle
|
||||
M: #shuffle optimize-node* ( node -- node/t )
|
||||
[ dup node-in-d empty? swap node-in-r empty? and ] prune-if ;
|
||||
|
||||
! #ifte
|
||||
: static-branch? ( node -- lit ? )
|
||||
|
|
|
|||
|
|
@ -16,28 +16,24 @@ M: comment pprint* ( ann -- )
|
|||
: comment, ( ? node text -- )
|
||||
rot [ <comment> , ] [ 2drop ] ifte ;
|
||||
|
||||
: value-str ( classes values -- str )
|
||||
[ swap hash [ object ] unless* ] map-with
|
||||
[ word-name ] map
|
||||
: value-str ( prefix values -- str )
|
||||
[ value-uid word-name append ] map-with
|
||||
" " join ;
|
||||
|
||||
: effect-str ( node -- str )
|
||||
[
|
||||
dup node-classes swap
|
||||
2dup node-in-d value-str %
|
||||
"" over node-in-d value-str %
|
||||
"r: " over node-in-r value-str %
|
||||
"--" %
|
||||
node-out-d value-str %
|
||||
"" over node-out-d value-str %
|
||||
"r: " swap node-out-r value-str %
|
||||
] "" make ;
|
||||
|
||||
M: #push node>quot ( ? node -- )
|
||||
node-out-d [ literal-value literalize ] map % drop ;
|
||||
|
||||
M: #drop node>quot ( ? node -- )
|
||||
node-in-d length dup 3 > [
|
||||
\ drop <repeated>
|
||||
] [
|
||||
{ f [ drop ] [ 2drop ] [ 3drop ] } nth
|
||||
] ifte % drop ;
|
||||
M: #shuffle node>quot ( ? node -- )
|
||||
>r drop t r> dup effect-str "#shuffle: " swap append comment, ;
|
||||
|
||||
DEFER: dataflow>quot
|
||||
|
||||
|
|
|
|||
|
|
@ -143,9 +143,3 @@ M: compound apply-object ( word -- )
|
|||
dup "inline" word-prop
|
||||
[ inline-block block, ] [ apply-default ] ifte
|
||||
] ifte* ;
|
||||
|
||||
: infer-shuffle ( word -- )
|
||||
dup #call [
|
||||
over "infer-effect" word-prop
|
||||
[ meta-d [ swap with-datastack ] change ] hairy-node
|
||||
] keep node, ;
|
||||
|
|
|
|||
|
|
@ -37,11 +37,6 @@ USE: prettyprint
|
|||
|
||||
[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
|
||||
|
||||
[ [ t t f ] ] [
|
||||
[ 1 2 3 ] [ <literal> ] map
|
||||
[ [ literal-value 2 <= ] subset ] keep in-d-node <#drop> kill-mask
|
||||
] unit-test
|
||||
|
||||
: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
|
||||
|
||||
[ 4 ] [ literal-kill-test-1 drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,6 +6,24 @@ USE: lists
|
|||
USE: math
|
||||
USE: kernel
|
||||
|
||||
! Test shuffle intrinsics
|
||||
[ ] [ 1 [ drop ] compile-1 ] unit-test
|
||||
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
|
||||
[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test
|
||||
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
|
||||
[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test
|
||||
[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test
|
||||
[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test
|
||||
[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test
|
||||
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
|
||||
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test
|
||||
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
|
||||
[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test
|
||||
[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test
|
||||
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
|
||||
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
|
||||
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
|
||||
|
||||
! Test various kill combinations
|
||||
|
||||
: kill-1
|
||||
|
|
|
|||
|
|
@ -44,6 +44,8 @@ parser prettyprint sequences io strings vectors words ;
|
|||
PREDICATE: cons kernel-error ( obj -- ? )
|
||||
car kernel-error = ;
|
||||
|
||||
M: f error. ( f -- ) ;
|
||||
|
||||
M: kernel-error error. ( error -- )
|
||||
#! Kernel errors are indexed by integers.
|
||||
cdr uncons car swap {
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@
|
|||
#define DLLEXPORT
|
||||
#endif
|
||||
|
||||
/* CELL must be 32 bits and your system must have 32-bit pointers */
|
||||
typedef unsigned long int CELL;
|
||||
#define CELLS ((signed)sizeof(CELL))
|
||||
|
||||
|
|
@ -29,10 +28,12 @@ CELL ds_bot;
|
|||
CELL cs_bot;
|
||||
|
||||
/* raw pointer to callstack top */
|
||||
#if defined(FACTOR_PPC)
|
||||
#if defined(FACTOR_X86)
|
||||
register CELL cs asm("ebx");
|
||||
#elif defined(FACTOR_PPC)
|
||||
register CELL cs asm("r15");
|
||||
#else
|
||||
DLLEXPORT CELL cs;
|
||||
CELL cs;
|
||||
#endif
|
||||
|
||||
/* TAGGED currently executing quotation */
|
||||
|
|
|
|||
Loading…
Reference in New Issue