steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.cfg.*: big changes which removes the last basic-block uses 

All intrinsic code generating words signatures are changed from ( node
-- ) to ( block node -- block' ) so the current block is now always
passed on the stack.
db4
Björn Lindqvist 2016-03-08 14:38:48 +01:00
parent 482998974b
commit 9df955e199
19 changed files with 153 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/compiler/cfg/builder/alien/alien-docs.factor
View File

@ -35,11 +35,15 @@ HELP: check-dlsym
{ $description "Checks that a symbol with the given name exists in the given library. Throws an error if not." } ; { $description "Checks that a symbol with the given name exists in the given library. Throws an error if not." } ;
HELP: emit-callback-body HELP: emit-callback-body
{ $values { "params" alien-node-params } } { $values
{ "block" basic-block }
{ "nodes" alien-node-params }
{ "block'" basic-block }
}
{ $description "Emits the nodes that forms the body of the alien callback." } ; { $description "Emits the nodes that forms the body of the alien callback." } ;
HELP: emit-callback-return HELP: emit-callback-return
{ $values { "params" alien-node-params } { "block" basic-block } } { $values { "block" basic-block } { "params" alien-node-params } }
{ $description "Emits a " { $link ##callback-outputs } " instruction for the " { $link #alien-callback } " if needed." } ; { $description "Emits a " { $link ##callback-outputs } " instruction for the " { $link #alien-callback } " if needed." } ;
HELP: unbox-parameters HELP: unbox-parameters

14
basis/compiler/cfg/builder/alien/alien-tests.factor
View File

@ -1,9 +1,9 @@
USING: accessors alien alien.c-types compiler.cfg compiler.cfg.builder USING: accessors alien alien.c-types compiler.cfg compiler.cfg.builder
compiler.cfg.builder.alien compiler.cfg.instructions compiler.cfg.builder.alien compiler.cfg.builder.blocks
compiler.cfg.registers compiler.test compiler.tree.builder compiler.cfg.instructions compiler.cfg.registers compiler.test
compiler.tree.optimizer cpu.architecture cpu.x86.assembler compiler.tree.builder compiler.tree.optimizer cpu.architecture
cpu.x86.assembler.operands kernel make namespaces sequences system cpu.x86.assembler cpu.x86.assembler.operands kernel make namespaces
tools.test words ; sequences system tools.test words ;
IN: compiler.cfg.builder.alien.tests IN: compiler.cfg.builder.alien.tests
! unboxing ints is only needed on 32bit archs ! unboxing ints is only needed on 32bit archs
@ -35,7 +35,7 @@ cpu x86.32?
] alien-assembly ; ] alien-assembly ;
{ t } [ { t } [
<basic-block> dup basic-block set dup <basic-block> dup set-basic-block dup
\ dummy-assembly build-tree optimize-tree first \ dummy-assembly build-tree optimize-tree first
[ emit-node ] V{ } make drop eq? [ emit-node ] V{ } make drop eq?
] unit-test ] unit-test
@ -58,7 +58,7 @@ cpu x86.32?
T{ ##branch } T{ ##branch }
} }
} [ } [
basic-block get <basic-block> dup set-basic-block
\ dummy-callback build-tree optimize-tree 3 swap nth child>> \ dummy-callback build-tree optimize-tree 3 swap nth child>>
[ emit-callback-body drop ] V{ } make [ emit-callback-body drop ] V{ } make
] cfg-unit-test ] cfg-unit-test

7
basis/compiler/cfg/builder/blocks/blocks-docs.factor
View File

@ -35,7 +35,7 @@ HELP: begin-basic-block
HELP: begin-branch HELP: begin-branch
{ $values { $values
{ "block" "current " { $link basic-block } } { "block" "current " { $link basic-block } }
{ "block" basic-block } { "block'" basic-block }
} }
{ $description "Used to begin emitting a branch." } ; { $description "Used to begin emitting a branch." } ;
@ -87,9 +87,7 @@ HELP: with-branch
} }
{ $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ; { $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;
ARTICLE: "compiler.cfg.builder.blocks" ARTICLE: "compiler.cfg.builder.blocks" "CFG construction utilities"
"CFG construction utilities"
$nl
"This vocab contains utilities for that helps " { $vocab-link "compiler.cfg.builder" } " to construct CFG:s." "This vocab contains utilities for that helps " { $vocab-link "compiler.cfg.builder" } " to construct CFG:s."
$nl $nl
"Combinators:" "Combinators:"
@ -102,6 +100,7 @@ $nl
begin-branch begin-branch
emit-call-block emit-call-block
emit-conditional emit-conditional
emit-trivial-call
} ; } ;
ABOUT: "compiler.cfg.builder.blocks" ABOUT: "compiler.cfg.builder.blocks"

4
basis/compiler/cfg/builder/blocks/blocks-tests.factor
View File

@ -29,8 +29,8 @@ IN: compiler.cfg.builder.blocks.tests
] cfg-unit-test ] cfg-unit-test
! end-basic-block ! end-basic-block
{ f } [ { } [
f end-basic-block basic-block get <basic-block> dup set-basic-block ##branch, end-basic-block
] unit-test ] unit-test
! make-kill-block ! make-kill-block

8
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -35,9 +35,11 @@ IN: compiler.cfg.builder.blocks
: emit-call-block ( word height block -- ) : emit-call-block ( word height block -- )
make-kill-block adjust-d ##call, ; make-kill-block adjust-d ##call, ;
: emit-primitive ( block node -- block' ) : emit-trivial-call ( block word height -- block' )
[ word>> ] [ call-height ] bi rot rot [ emit-call-block ] emit-trivial-block ;
[ emit-call-block ] emit-trivial-block ;
: emit-primitive ( block #call -- block' )
[ word>> ] [ call-height ] bi emit-trivial-call ;
: begin-branch ( block -- block' ) : begin-branch ( block -- block' )
height-state [ clone-height-state ] change (begin-basic-block) ; height-state [ clone-height-state ] change (begin-basic-block) ;

2
basis/compiler/cfg/builder/builder-docs.factor
View File

@ -128,7 +128,6 @@ HELP: with-cfg-builder
ARTICLE: "compiler.cfg.builder" ARTICLE: "compiler.cfg.builder"
"Final stage of compilation generates machine code from dataflow IR" "Final stage of compilation generates machine code from dataflow IR"
$nl
"The compiler first builds an SSA IR tree of the word to be compiled (see " { $vocab-link "compiler.tree.builder" } ") then this vocab converts it to a CFG IR tree. The result is not in SSA form; this is constructed later by calling compiler.cfg.ssa.construction:construct-ssa." "The compiler first builds an SSA IR tree of the word to be compiled (see " { $vocab-link "compiler.tree.builder" } ") then this vocab converts it to a CFG IR tree. The result is not in SSA form; this is constructed later by calling compiler.cfg.ssa.construction:construct-ssa."
$nl $nl
"Main word:" "Main word:"
@ -148,7 +147,6 @@ $nl
{ $subsections { $subsections
emit-call emit-call
emit-loop-call emit-loop-call
emit-trivial-call
} }
"Emitters for " { $link #dispatch } " and " { $link #if } ":" "Emitters for " { $link #dispatch } " and " { $link #if } ":"
{ $subsections { $subsections

21
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -271,17 +271,10 @@ SYMBOL: foo
] cfg-unit-test ] cfg-unit-test
! emit-loop-call ! emit-loop-call
{ 1 } [ { 1 "good" } [
V{ } 0 insns>block basic-block set init-cfg-test V{ } 0 insns>block dup set-basic-block
V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop V{ } "good" insns>block swap [ emit-loop-call ] keep
basic-block get successors>> length [ successors>> length ] [ successors>> first number>> ] bi
] unit-test
{ "bar" } [
V{ } "foo" insns>block basic-block set
init-cfg-test
[ V{ } "bar" insns>block basic-block get emit-loop-call ] V{ } make drop
basic-block get successors>> first number>>
] unit-test ] unit-test
! emit-node ! emit-node
@ -342,8 +335,8 @@ SYMBOL: foo
{ {
V{ T{ ##call { word set-slot } } T{ ##branch } } V{ T{ ##call { word set-slot } } T{ ##branch } }
} [ } [
[ f call-node-1 emit-node drop ] V{ } make drop [ f call-node-1 emit-node ] V{ } make drop
basic-block get successors>> first instructions>> predecessors>> first instructions>>
] cfg-unit-test ] cfg-unit-test
! ! #push ! ! #push
@ -372,7 +365,7 @@ SYMBOL: foo
! ! #terminate ! ! #terminate
{ f } [ { f } [
basic-block get dup set-basic-block <basic-block> dup set-basic-block
T{ #terminate { in-d { } } { in-r { } } } emit-node T{ #terminate { in-d { } } { in-r { } } } emit-node
] cfg-unit-test ] cfg-unit-test

5
basis/compiler/cfg/builder/builder.factor
View File

@ -54,9 +54,6 @@ GENERIC: emit-node ( block node -- block' )
##safepoint, ##branch, ##safepoint, ##branch,
[ swap connect-bbs ] [ end-basic-block ] bi ; [ swap connect-bbs ] [ end-basic-block ] bi ;
: emit-trivial-call ( block word height -- block' )
rot [ emit-call-block ] emit-trivial-block ;
: emit-call ( block word height -- block' ) : emit-call ( block word height -- block' )
over loops get at [ over loops get at [
2nip swap emit-loop-call f 2nip swap emit-loop-call f
@ -127,7 +124,7 @@ M: #dispatch emit-node ( block node -- block' )
M: #call emit-node ( block node -- block' ) M: #call emit-node ( block node -- block' )
dup word>> dup "intrinsic" word-prop [ dup word>> dup "intrinsic" word-prop [
nip call( node -- ) drop basic-block get nip call( block #call -- block' )
] [ swap call-height emit-call ] if* ; ] [ swap call-height emit-call ] if* ;
M: #call-recursive emit-node ( block node -- block' ) M: #call-recursive emit-node ( block node -- block' )

28
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -13,19 +13,19 @@ IN: compiler.cfg.intrinsics.alien
[ second class>> c-ptr class<= ] [ second class>> c-ptr class<= ]
} 1&& ; } 1&& ;
: emit-<displaced-alien> ( node -- ) : emit-<displaced-alien> ( block node -- block' )
dup emit-<displaced-alien>? [ dup emit-<displaced-alien>? [
'[ '[
_ node-input-infos second class>> _ node-input-infos second class>>
^^box-displaced-alien ^^box-displaced-alien
] binary-op ] binary-op
] [ basic-block get swap emit-primitive drop ] if ; ] [ emit-primitive ] if ;
:: inline-accessor ( node quot test -- ) :: inline-accessor ( block #call quot test -- block' )
node node-input-infos :> infos #call node-input-infos :> infos
infos test call infos test call
[ infos quot call ] [ infos quot call block ]
[ node basic-block get swap emit-primitive drop ] if ; inline [ block #call emit-primitive ] if ; inline
: inline-load-memory? ( infos -- ? ) : inline-load-memory? ( infos -- ? )
[ first class>> c-ptr class<= ] [ first class>> c-ptr class<= ]
@ -38,15 +38,15 @@ IN: compiler.cfg.intrinsics.alien
: prepare-load-memory ( infos -- base offset ) : prepare-load-memory ( infos -- base offset )
[ 2inputs ] dip first prepare-accessor ; [ 2inputs ] dip first prepare-accessor ;
: (emit-load-memory) ( node rep c-type quot -- ) : (emit-load-memory) ( block node rep c-type quot -- block' )
'[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ] '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ]
[ inline-load-memory? ] [ inline-load-memory? ]
inline-accessor ; inline inline-accessor ; inline
: emit-load-memory ( node rep c-type -- ) : emit-load-memory ( block node rep c-type -- block' )
[ ] (emit-load-memory) ; [ ] (emit-load-memory) ;
: emit-alien-cell ( node -- ) : emit-alien-cell ( block node -- block' )
int-rep f [ ^^box-alien ] (emit-load-memory) ; int-rep f [ ^^box-alien ] (emit-load-memory) ;
: inline-store-memory? ( infos class -- ? ) : inline-store-memory? ( infos class -- ? )
@ -58,14 +58,14 @@ IN: compiler.cfg.intrinsics.alien
: prepare-store-memory ( infos -- value base offset ) : prepare-store-memory ( infos -- value base offset )
[ 3inputs ] dip second prepare-accessor ; [ 3inputs ] dip second prepare-accessor ;
:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- ) :: (emit-store-memory) ( block node rep c-type prepare-quot test-quot -- block' )
node block node
[ prepare-quot call rep c-type ##store-memory-imm, ] [ prepare-quot call rep c-type ##store-memory-imm, ]
[ test-quot call inline-store-memory? ] [ test-quot call inline-store-memory? ]
inline-accessor ; inline inline-accessor ; inline
:: emit-store-memory ( node rep c-type -- ) :: emit-store-memory ( block node rep c-type -- block' )
node rep c-type block node rep c-type
[ prepare-store-memory ] [ prepare-store-memory ]
[ [
rep { rep {
@ -76,7 +76,7 @@ IN: compiler.cfg.intrinsics.alien
] ]
(emit-store-memory) ; (emit-store-memory) ;
: emit-set-alien-cell ( node -- ) : emit-set-alien-cell ( block node -- block' )
int-rep f int-rep f
[ [
[ first class>> ] [ prepare-store-memory ] bi [ first class>> ] [ prepare-store-memory ] bi

25
basis/compiler/cfg/intrinsics/allot/allot-docs.factor
View File

@ -1,18 +1,33 @@
USING: byte-arrays compiler.tree help.markup help.syntax ; USING: byte-arrays classes.tuple.private compiler.cfg compiler.tree
help.markup help.syntax ;
IN: compiler.cfg.intrinsics.allot IN: compiler.cfg.intrinsics.allot
HELP: emit-<byte-array> HELP: emit-<byte-array>
{ $values { "node" node } } { $values
{ "block" "current " { $link basic-block } }
{ "#call" node }
{ "block'" basic-block }
}
{ $description "Emits optimized cfg instructions for allocating a " { $link byte-array } "." } ; { $description "Emits optimized cfg instructions for allocating a " { $link byte-array } "." } ;
HELP: emit-<tuple-boa> HELP: emit-<tuple-boa>
{ $values { "node" node } } { $values
{ $description "Emits optimized cfg instructions for building and allocating tuples." } ; { "block" "current " { $link basic-block } }
{ "#call" #call }
{ "block'" basic-block }
}
{ $description "Emits intrinsic cfg instructions for building and allocating tuples. The intrinsic condition is that the tuple layout given to " { $link <tuple-boa> } " must be a literal." }
{ $see-also <tuple-boa> } ;
ARTICLE: "compiler.cfg.intrinsics.allot" "Generating instructions for inline memory allocation" ARTICLE: "compiler.cfg.intrinsics.allot" "Generating instructions for inline memory allocation"
"Generating instructions for inline memory allocation" "Generating instructions for inline memory allocation"
$nl $nl
"Emitters:" "Emitters:"
{ $subsections emit-<byte-array> emit-<tuple-boa> } ; { $subsections
emit-(byte-array)
emit-<array>
emit-<byte-array>
emit-<tuple-boa>
} ;
ABOUT: "compiler.cfg.intrinsics.allot" ABOUT: "compiler.cfg.intrinsics.allot"

25
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -21,14 +21,14 @@ IN: compiler.cfg.intrinsics.allot
: ^^allot-tuple ( n -- dst ) : ^^allot-tuple ( n -- dst )
2 + cells tuple ^^allot ; 2 + cells tuple ^^allot ;
: emit-<tuple-boa> ( node -- ) : emit-<tuple-boa> ( block #call -- block' )
dup node-input-infos last literal>> dup node-input-infos last literal>>
dup array? [ dup array? [
nip nip
ds-drop ds-drop
[ tuple-slot-regs ] [ second ^^allot-tuple ] bi [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots, ] [ ds-push drop ] 2bi [ tuple ##set-slots, ] [ ds-push drop ] 2bi
] [ drop basic-block get swap emit-primitive drop ] if ; ] [ drop emit-primitive ] if ;
: store-length ( len reg class -- ) : store-length ( len reg class -- )
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ; [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ;
@ -42,7 +42,7 @@ IN: compiler.cfg.intrinsics.allot
: ^^allot-array ( n -- dst ) : ^^allot-array ( n -- dst )
2 + cells array ^^allot ; 2 + cells array ^^allot ;
:: emit-<array> ( node -- ) :: emit-<array> ( block node -- block' )
node node-input-infos first literal>> :> len node node-input-infos first literal>> :> len
len expand-<array>? [ len expand-<array>? [
ds-pop :> elt ds-pop :> elt
@ -50,8 +50,8 @@ IN: compiler.cfg.intrinsics.allot
ds-drop ds-drop
len reg array store-length len reg array store-length
len reg elt array store-initial-element len reg elt array store-initial-element
reg ds-push reg ds-push block
] [ node basic-block get swap emit-primitive drop ] if ; ] [ block node emit-primitive ] if ;
: expand-(byte-array)? ( obj -- ? ) : expand-(byte-array)? ( obj -- ? )
dup integer? [ 0 1024 between? ] [ drop f ] if ; dup integer? [ 0 1024 between? ] [ drop f ] if ;
@ -67,9 +67,10 @@ IN: compiler.cfg.intrinsics.allot
: emit-allot-byte-array ( len -- dst ) : emit-allot-byte-array ( len -- dst )
ds-drop ^^allot-byte-array dup ds-push ; ds-drop ^^allot-byte-array dup ds-push ;
: emit-(byte-array) ( node -- ) : emit-(byte-array) ( block node -- block' )
dup node-input-infos first literal>> dup expand-(byte-array)? dup node-input-infos first literal>> dup expand-(byte-array)? [
[ nip emit-allot-byte-array drop ] [ drop basic-block get swap emit-primitive drop ] if ; nip emit-allot-byte-array drop
] [ drop emit-primitive ] if ;
:: zero-byte-array ( len reg -- ) :: zero-byte-array ( len reg -- )
0 ^^load-literal :> elt 0 ^^load-literal :> elt
@ -78,9 +79,9 @@ IN: compiler.cfg.intrinsics.allot
[ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm, [ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm,
] each ; ] each ;
:: emit-<byte-array> ( node -- ) :: emit-<byte-array> ( block #call -- block' )
node node-input-infos first literal>> dup expand-<byte-array>? [ #call node-input-infos first literal>> dup expand-<byte-array>? [
:> len :> len
len emit-allot-byte-array :> reg len emit-allot-byte-array :> reg
len reg zero-byte-array len reg zero-byte-array block
] [ drop node basic-block get swap emit-primitive drop ] if ; ] [ drop block #call emit-primitive ] if ;

52
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators compiler.cfg USING: accessors arrays combinators compiler.cfg.builder.blocks
compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks.local
compiler.cfg.stacks.local compiler.tree.propagation.info compiler.tree.propagation.info cpu.architecture fry kernel layouts
cpu.architecture fry kernel layouts math math.intervals namespaces locals math math.intervals namespaces sequences ;
sequences ;
IN: compiler.cfg.intrinsics.fixnum IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- ) : emit-both-fixnums? ( -- )
@ -25,13 +24,13 @@ IN: compiler.cfg.intrinsics.fixnum
tag-bits get ^^sar-imm tag-bits get ^^sar-imm
] binary-op ; ] binary-op ;
: emit-fixnum-shift-general ( -- ) : emit-fixnum-shift-general ( block -- block' )
ds-peek 0 cc> ##compare-integer-imm-branch, ds-peek 0 cc> ##compare-integer-imm-branch, dup
basic-block get [ emit-fixnum-left-shift ] with-branch [ [ emit-fixnum-left-shift ] with-branch ]
basic-block get [ emit-fixnum-right-shift ] with-branch [ [ emit-fixnum-right-shift ] with-branch ] bi 2array
2array basic-block get swap emit-conditional drop ; emit-conditional ;
: emit-fixnum-shift-fast ( node -- ) : emit-fixnum-shift-fast ( block #call -- block' )
node-input-infos second interval>> { node-input-infos second interval>> {
{ [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] } { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
{ [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] } { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
@ -41,22 +40,17 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum-comparison ( cc -- ) : emit-fixnum-comparison ( cc -- )
'[ _ ^^compare-integer ] binary-op ; '[ _ ^^compare-integer ] binary-op ;
: emit-no-overflow-case ( dst -- final-bb ) : emit-no-overflow-case ( dst block -- final-bb )
basic-block get [ [ swap D: -2 inc-stack ds-push ] with-branch ;
swap D: -2 inc-stack ds-push
] with-branch ;
: emit-overflow-case ( word -- final-bb ) : emit-overflow-case ( word block -- final-bb )
basic-block get [ [ -1 swap [ emit-call-block ] keep ] with-branch ;
swap -1 basic-block get emit-call-block
] with-branch ;
: emit-fixnum-overflow-op ( quot word -- ) :: emit-fixnum-overflow-op ( block quot word -- block' )
! Inputs to the final instruction need to be copied because (2inputs) [ any-rep ^^copy ] bi@ cc/o
! of loc>vreg sync quot call( vreg1 vreg2 cc -- vreg ) block emit-no-overflow-case
[ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip word block emit-overflow-case 2array
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array block swap emit-conditional ; inline
basic-block get swap emit-conditional drop ; inline
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
@ -64,11 +58,11 @@ IN: compiler.cfg.intrinsics.fixnum
: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ; : fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
: emit-fixnum+ ( -- ) : emit-fixnum+ ( block -- block' )
[ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ; [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
: emit-fixnum- ( -- ) : emit-fixnum- ( block -- block' )
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
: emit-fixnum* ( -- ) : emit-fixnum* ( block -- block' )
[ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -65,7 +65,7 @@ ERROR: inline-intrinsics-not-supported word quot ;
{ byte-arrays:(byte-array) [ emit-(byte-array) ] } { byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ kernel:<wrapper> [ emit-simple-allot ] } { kernel:<wrapper> [ emit-simple-allot ] }
{ alien.data.private:(local-allot) [ emit-local-allot ] } { alien.data.private:(local-allot) [ emit-local-allot ] }
{ alien.data.private:(cleanup-allot) [ drop emit-cleanup-allot ] } { alien.data.private:(cleanup-allot) [ emit-cleanup-allot ] }
{ alien:<displaced-alien> [ emit-<displaced-alien> ] } { alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] } { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
{ alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] } { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }

9
basis/compiler/cfg/intrinsics/misc/misc-docs.factor
View File

@ -1,6 +1,11 @@
USING: compiler.tree help.markup help.syntax kernel.private words ; USING: compiler.cfg compiler.tree help.markup help.syntax
kernel.private ;
IN: compiler.cfg.intrinsics.misc IN: compiler.cfg.intrinsics.misc
HELP: emit-context-object HELP: emit-context-object
{ $values { "node" node } } { $values
{ "block" "current " { $link basic-block } }
{ "node" node }
{ "block'" basic-block }
}
{ $description "Emits intrinsic code for a call to the " { $link context-object } " primitive." } ; { $description "Emits intrinsic code for a call to the " { $link context-object } " primitive." } ;

23
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.algebra classes.struct compiler.cfg USING: accessors classes.algebra classes.struct
compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks compiler.constants compiler.cfg.instructions compiler.cfg.stacks compiler.constants
compiler.tree.propagation.info cpu.architecture kernel layouts math compiler.tree.propagation.info cpu.architecture kernel layouts math
@ -14,27 +14,27 @@ IN: compiler.cfg.intrinsics.misc
node-input-infos first2 [ class>> fixnum class<= ] both? node-input-infos first2 [ class>> fixnum class<= ] both?
[ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ; [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
: emit-special-object ( node -- ) : emit-special-object ( block node -- block' )
dup node-input-infos first literal>> [ dup node-input-infos first literal>> [
ds-drop ds-drop
vm-special-object-offset ^^vm-field vm-special-object-offset ^^vm-field
ds-push ds-push
] [ basic-block get swap emit-primitive drop ] ?if ; ] [ emit-primitive ] ?if ;
: emit-set-special-object ( node -- ) : emit-set-special-object ( block node -- block' )
dup node-input-infos second literal>> [ dup node-input-infos second literal>> [
ds-drop ds-drop
[ ds-pop ] dip vm-special-object-offset ##set-vm-field, [ ds-pop ] dip vm-special-object-offset ##set-vm-field,
] [ basic-block get swap emit-primitive drop ] ?if ; ] [ emit-primitive ] ?if ;
: context-object-offset ( n -- n ) : context-object-offset ( n -- n )
cells "context-objects" context offset-of + ; cells "context-objects" context offset-of + ;
: emit-context-object ( node -- ) : emit-context-object ( block node -- block' )
dup node-input-infos first literal>> [ dup node-input-infos first literal>> [
"ctx" vm offset-of ^^vm-field "ctx" vm offset-of ^^vm-field
ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
] [ basic-block get swap emit-primitive drop ] ?if ; ] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- ) : emit-identity-hashcode ( -- )
[ [
@ -44,11 +44,10 @@ IN: compiler.cfg.intrinsics.misc
hashcode-shift ^^shr-imm hashcode-shift ^^shr-imm
] unary-op ; ] unary-op ;
: emit-local-allot ( node -- ) : emit-local-allot ( block node -- block' )
dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both? dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
[ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ] [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
[ 2drop basic-block get swap emit-primitive drop ] [ 2drop emit-primitive ] if ;
if ;
: emit-cleanup-allot ( -- ) : emit-cleanup-allot ( block node -- block' )
basic-block get [ drop ##no-tco, ] emit-trivial-block drop ; drop [ drop ##no-tco, ] emit-trivial-block ;

7
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -633,7 +633,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
{ float-vector-rep [ ^select-vector ] } { float-vector-rep [ ^select-vector ] }
} [ integer? ] emit-vl-vector-op ; } [ integer? ] emit-vl-vector-op ;
: emit-alien-vector ( node -- ) : emit-alien-vector ( block node -- block' )
dup [ dup [
'[ '[
ds-drop prepare-load-memory ds-drop prepare-load-memory
@ -642,14 +642,13 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
[ inline-load-memory? ] inline-accessor [ inline-load-memory? ] inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ; ] with { [ %alien-vector-reps member? ] } if-literals-match ;
: emit-set-alien-vector ( node -- ) : emit-set-alien-vector ( block node -- block' )
dup [ dup [
'[ '[
ds-drop prepare-store-memory ds-drop prepare-store-memory
_ f ##store-memory-imm, _ f ##store-memory-imm,
] ]
[ byte-array inline-store-memory? ] [ byte-array inline-store-memory? ] inline-accessor
inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ; ] with { [ %alien-vector-reps member? ] } if-literals-match ;
: enable-simd ( -- ) : enable-simd ( -- )

24
basis/compiler/cfg/intrinsics/slots/slots-docs.factor
View File

@ -1,6 +1,6 @@
USING: classes classes.builtin compiler.cfg.instructions compiler.tree USING: classes classes.builtin compiler.cfg compiler.cfg.instructions
compiler.tree.propagation.info help.markup help.syntax kernel layouts compiler.tree compiler.tree.propagation.info help.markup help.syntax
math slots.private ; kernel layouts math slots.private ;
IN: compiler.cfg.intrinsics.slots IN: compiler.cfg.intrinsics.slots
HELP: class-tag HELP: class-tag
@ -39,5 +39,21 @@ HELP: value-tag
{ $description "Finds the class number for this value-info-states class (an index in the " { $link builtins } " list), or " { $link f } " if it hasn't one." } ; { $description "Finds the class number for this value-info-states class (an index in the " { $link builtins } " list), or " { $link f } " if it hasn't one." } ;
HELP: emit-set-slot HELP: emit-set-slot
{ $values { "node" node } } { $values
{ "block" basic-block }
{ "#call" #call }
{ "block'" basic-block }
}
{ $description "Emits intrinsic code for a " { $link set-slot } " call." } ; { $description "Emits intrinsic code for a " { $link set-slot } " call." } ;
ARTICLE: "compiler.cfg.intrinsics.slots"
"Generating instructions for slot access"
"This vocab has words for generating intrinsic CFG instructions for slot accessors."
$nl
"Main words, called directly by the compiler through the \"intrinsic\" word property:"
{ $subsections
emit-set-slot
emit-slot
} ;
ABOUT: "compiler.cfg.intrinsics.slots"

11
basis/compiler/cfg/intrinsics/slots/slots-tests.factor
View File

@ -1,7 +1,7 @@
USING: accessors arrays compiler.cfg compiler.cfg.instructions USING: accessors arrays compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.intrinsics.slots compiler.test compiler.tree compiler.cfg.instructions compiler.cfg.intrinsics.slots compiler.test
compiler.tree.propagation.info kernel layouts literals make math compiler.tree compiler.tree.propagation.info kernel layouts literals
math.intervals namespaces sequences slots.private tools.test ; make math math.intervals sequences slots.private tools.test ;
IN: compiler.cfg.intrinsics.slots.tests IN: compiler.cfg.intrinsics.slots.tests
: call-node-1 ( -- node ) : call-node-1 ( -- node )
@ -111,8 +111,9 @@ IN: compiler.cfg.intrinsics.slots.tests
{ {
V{ T{ ##call { word set-slot } } T{ ##branch } } V{ T{ ##call { word set-slot } } T{ ##branch } }
} [ } [
<basic-block> dup set-basic-block
call-node-1 [ emit-set-slot ] V{ } make drop call-node-1 [ emit-set-slot ] V{ } make drop
basic-block get successors>> first instructions>> predecessors>> first instructions>>
] cfg-unit-test ] cfg-unit-test
{ {

8
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -30,14 +30,14 @@ IN: compiler.cfg.intrinsics.slots
: immediate-slot-offset? ( object -- ? ) : immediate-slot-offset? ( object -- ? )
{ [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ; { [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ;
: emit-slot ( node -- ) : emit-slot ( block node -- block' )
dup node-input-infos dup node-input-infos
dup first value-tag [ dup first value-tag [
nip nip
dup second literal>> immediate-slot-offset? dup second literal>> immediate-slot-offset?
[ (emit-slot-imm) ] [ (emit-slot) ] if [ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push ds-push
] [ drop basic-block get swap emit-primitive drop ] if ; ] [ drop emit-primitive ] if ;
:: (emit-set-slot-imm) ( write-barrier? tag slot -- ) :: (emit-set-slot-imm) ( write-barrier? tag slot -- )
ds-drop ds-drop
@ -68,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
(emit-set-slot-imm) (emit-set-slot-imm)
] [ drop (emit-set-slot) ] if ; ] [ drop (emit-set-slot) ] if ;
: emit-set-slot ( node -- ) : emit-set-slot ( block #call -- block' )
dup node>set-slot-data over [ dup node>set-slot-data over [
emit-intrinsic-set-slot drop emit-intrinsic-set-slot drop
] [ 3drop basic-block get swap emit-primitive drop ] if ; ] [ 3drop emit-primitive ] if ;