"/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"
"/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"
: 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.
#! 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 ;
#! 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 )
\ 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
\ 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
] "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 )
: 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 ,
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
] each
: fast-fixnum* ( n -- )
- 1 %dec-d ,
+ -1 %inc-d,
in-1
log2 0 <vreg> 0 <vreg> %fixnum<< ,
0 0 %replace-d , ;
! 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
: 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 ,
: positive-shift ( n -- )
dup cell 8 * tag-bits - <= [
- 1 %dec-d ,
+ -1 %inc-d,
in-1
0 <vreg> 0 <vreg> %fixnum<< ,
out-1
: fast-shift ( n -- )
dup 0 = [
- 1 %dec-d ,
+ -1 %inc-d,
drop
] [
dup 0 < [
: 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
#! 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
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 ;
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 -- )
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 , ;
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 ;
+
+: (%peek) dup vop-out-1 v>operand swap vop-in-1 ;
+
+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 ;
+
+M: %replace-d generate-node ( vop -- ) (%replace) ds-op swap MOV ;
-M: %peek-d generate-node ( vop -- )
- dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
+M: %replace-r generate-node ( vop -- ) (%replace) cs-op swap MOV ;
-M: %replace-d generate-node ( vop -- )
- dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
+: (%inc) swap vop-in-1 cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
-M: %inc-d generate-node ( vop -- )
- ESI 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 ;
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 ;
set-delegate
] keep ;
+: empty-node f { } { } { } { } ;
: param-node ( label) { } { } { } { } ;
: in-d-node ( inputs) >r f r> { } { } { } ;
: out-d-node ( outputs) >r f { } r> { } { } ;
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 ;
: 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 ;
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 [
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 ;
#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
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 ? )
: 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
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, ;
[ { [ 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
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
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 {
#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))
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 */
projects / factor.git / commitdiff