diff --git a/basis/compiler/cfg/builder/alien/alien-docs.factor b/basis/compiler/cfg/builder/alien/alien-docs.factor index 3642b95121..bdf3ca1bb7 100644 --- a/basis/compiler/cfg/builder/alien/alien-docs.factor +++ b/basis/compiler/cfg/builder/alien/alien-docs.factor @@ -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." } ; 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." } ; 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." } ; HELP: unbox-parameters diff --git a/basis/compiler/cfg/builder/alien/alien-tests.factor b/basis/compiler/cfg/builder/alien/alien-tests.factor index 9d618bfb36..22b878f4d6 100644 --- a/basis/compiler/cfg/builder/alien/alien-tests.factor +++ b/basis/compiler/cfg/builder/alien/alien-tests.factor @@ -1,9 +1,9 @@ USING: accessors alien alien.c-types compiler.cfg compiler.cfg.builder -compiler.cfg.builder.alien compiler.cfg.instructions -compiler.cfg.registers compiler.test compiler.tree.builder -compiler.tree.optimizer cpu.architecture cpu.x86.assembler -cpu.x86.assembler.operands kernel make namespaces sequences system -tools.test words ; +compiler.cfg.builder.alien compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.registers compiler.test +compiler.tree.builder compiler.tree.optimizer cpu.architecture +cpu.x86.assembler cpu.x86.assembler.operands kernel make namespaces +sequences system tools.test words ; IN: compiler.cfg.builder.alien.tests ! unboxing ints is only needed on 32bit archs @@ -35,7 +35,7 @@ cpu x86.32? ] alien-assembly ; { t } [ - dup basic-block set dup + dup set-basic-block dup \ dummy-assembly build-tree optimize-tree first [ emit-node ] V{ } make drop eq? ] unit-test @@ -58,7 +58,7 @@ cpu x86.32? T{ ##branch } } } [ - basic-block get + dup set-basic-block \ dummy-callback build-tree optimize-tree 3 swap nth child>> [ emit-callback-body drop ] V{ } make ] cfg-unit-test diff --git a/basis/compiler/cfg/builder/blocks/blocks-docs.factor b/basis/compiler/cfg/builder/blocks/blocks-docs.factor index 6e12b3fad7..1f266d7835 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-docs.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-docs.factor @@ -35,7 +35,7 @@ HELP: begin-basic-block HELP: begin-branch { $values { "block" "current " { $link basic-block } } - { "block" basic-block } + { "block'" basic-block } } { $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." } ; -ARTICLE: "compiler.cfg.builder.blocks" -"CFG construction utilities" -$nl +ARTICLE: "compiler.cfg.builder.blocks" "CFG construction utilities" "This vocab contains utilities for that helps " { $vocab-link "compiler.cfg.builder" } " to construct CFG:s." $nl "Combinators:" @@ -102,6 +100,7 @@ $nl begin-branch emit-call-block emit-conditional + emit-trivial-call } ; ABOUT: "compiler.cfg.builder.blocks" diff --git a/basis/compiler/cfg/builder/blocks/blocks-tests.factor b/basis/compiler/cfg/builder/blocks/blocks-tests.factor index 5b3d27ad36..70e158df71 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-tests.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-tests.factor @@ -29,8 +29,8 @@ IN: compiler.cfg.builder.blocks.tests ] cfg-unit-test ! end-basic-block -{ f } [ - f end-basic-block basic-block get +{ } [ + dup set-basic-block ##branch, end-basic-block ] unit-test ! make-kill-block diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 8b6b35bdbb..75b574e3a3 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -35,9 +35,11 @@ IN: compiler.cfg.builder.blocks : emit-call-block ( word height block -- ) make-kill-block adjust-d ##call, ; -: emit-primitive ( block node -- block' ) - [ word>> ] [ call-height ] bi rot - [ emit-call-block ] emit-trivial-block ; +: emit-trivial-call ( block word height -- block' ) + rot [ emit-call-block ] emit-trivial-block ; + +: emit-primitive ( block #call -- block' ) + [ word>> ] [ call-height ] bi emit-trivial-call ; : begin-branch ( block -- block' ) height-state [ clone-height-state ] change (begin-basic-block) ; diff --git a/basis/compiler/cfg/builder/builder-docs.factor b/basis/compiler/cfg/builder/builder-docs.factor index 8cc47a3c09..1fa34fb88a 100644 --- a/basis/compiler/cfg/builder/builder-docs.factor +++ b/basis/compiler/cfg/builder/builder-docs.factor @@ -128,7 +128,6 @@ HELP: with-cfg-builder ARTICLE: "compiler.cfg.builder" "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." $nl "Main word:" @@ -148,7 +147,6 @@ $nl { $subsections emit-call emit-loop-call - emit-trivial-call } "Emitters for " { $link #dispatch } " and " { $link #if } ":" { $subsections diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index b601138eb8..0aaff60083 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -271,17 +271,10 @@ SYMBOL: foo ] cfg-unit-test ! emit-loop-call -{ 1 } [ - V{ } 0 insns>block basic-block set init-cfg-test - V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop - basic-block get successors>> length -] 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>> +{ 1 "good" } [ + V{ } 0 insns>block dup set-basic-block + V{ } "good" insns>block swap [ emit-loop-call ] keep + [ successors>> length ] [ successors>> first number>> ] bi ] unit-test ! emit-node @@ -342,8 +335,8 @@ SYMBOL: foo { V{ T{ ##call { word set-slot } } T{ ##branch } } } [ - [ f call-node-1 emit-node drop ] V{ } make drop - basic-block get successors>> first instructions>> + [ f call-node-1 emit-node ] V{ } make drop + predecessors>> first instructions>> ] cfg-unit-test ! ! #push @@ -372,7 +365,7 @@ SYMBOL: foo ! ! #terminate { f } [ - basic-block get dup set-basic-block + dup set-basic-block T{ #terminate { in-d { } } { in-r { } } } emit-node ] cfg-unit-test diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 5fef4ff643..ec163d144f 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -54,9 +54,6 @@ GENERIC: emit-node ( block node -- block' ) ##safepoint, ##branch, [ 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' ) over loops get at [ 2nip swap emit-loop-call f @@ -127,7 +124,7 @@ M: #dispatch emit-node ( block node -- block' ) M: #call emit-node ( block node -- block' ) dup word>> dup "intrinsic" word-prop [ - nip call( node -- ) drop basic-block get + nip call( block #call -- block' ) ] [ swap call-height emit-call ] if* ; M: #call-recursive emit-node ( block node -- block' ) diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 7372210238..ccb4eef367 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -13,19 +13,19 @@ IN: compiler.cfg.intrinsics.alien [ second class>> c-ptr class<= ] } 1&& ; -: emit- ( node -- ) +: emit- ( block node -- block' ) dup emit-? [ '[ _ node-input-infos second class>> ^^box-displaced-alien ] binary-op - ] [ basic-block get swap emit-primitive drop ] if ; + ] [ emit-primitive ] if ; -:: inline-accessor ( node quot test -- ) - node node-input-infos :> infos +:: inline-accessor ( block #call quot test -- block' ) + #call node-input-infos :> infos infos test call - [ infos quot call ] - [ node basic-block get swap emit-primitive drop ] if ; inline + [ infos quot call block ] + [ block #call emit-primitive ] if ; inline : inline-load-memory? ( infos -- ? ) [ first class>> c-ptr class<= ] @@ -38,15 +38,15 @@ IN: compiler.cfg.intrinsics.alien : prepare-load-memory ( infos -- base offset ) [ 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 ] [ inline-load-memory? ] inline-accessor ; inline -: emit-load-memory ( node rep c-type -- ) +: emit-load-memory ( block node rep c-type -- block' ) [ ] (emit-load-memory) ; -: emit-alien-cell ( node -- ) +: emit-alien-cell ( block node -- block' ) int-rep f [ ^^box-alien ] (emit-load-memory) ; : inline-store-memory? ( infos class -- ? ) @@ -58,14 +58,14 @@ IN: compiler.cfg.intrinsics.alien : prepare-store-memory ( infos -- value base offset ) [ 3inputs ] dip second prepare-accessor ; -:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- ) - node +:: (emit-store-memory) ( block node rep c-type prepare-quot test-quot -- block' ) + block node [ prepare-quot call rep c-type ##store-memory-imm, ] [ test-quot call inline-store-memory? ] inline-accessor ; inline -:: emit-store-memory ( node rep c-type -- ) - node rep c-type +:: emit-store-memory ( block node rep c-type -- block' ) + block node rep c-type [ prepare-store-memory ] [ rep { @@ -76,7 +76,7 @@ IN: compiler.cfg.intrinsics.alien ] (emit-store-memory) ; -: emit-set-alien-cell ( node -- ) +: emit-set-alien-cell ( block node -- block' ) int-rep f [ [ first class>> ] [ prepare-store-memory ] bi diff --git a/basis/compiler/cfg/intrinsics/allot/allot-docs.factor b/basis/compiler/cfg/intrinsics/allot/allot-docs.factor index 6e9e909aca..c1114f6ddd 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot-docs.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot-docs.factor @@ -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 HELP: emit- -{ $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 } "." } ; HELP: emit- -{ $values { "node" node } } -{ $description "Emits optimized cfg instructions for building and allocating tuples." } ; +{ $values + { "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 } " must be a literal." } +{ $see-also } ; ARTICLE: "compiler.cfg.intrinsics.allot" "Generating instructions for inline memory allocation" "Generating instructions for inline memory allocation" $nl "Emitters:" -{ $subsections emit- emit- } ; +{ $subsections + emit-(byte-array) + emit- + emit- + emit- +} ; ABOUT: "compiler.cfg.intrinsics.allot" diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 9b35de77d3..ff6e1b9b5c 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -21,14 +21,14 @@ IN: compiler.cfg.intrinsics.allot : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; -: emit- ( node -- ) +: emit- ( block #call -- block' ) dup node-input-infos last literal>> dup array? [ nip ds-drop [ tuple-slot-regs ] [ second ^^allot-tuple ] bi [ 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 -- ) [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ; @@ -42,7 +42,7 @@ IN: compiler.cfg.intrinsics.allot : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; -:: emit- ( node -- ) +:: emit- ( block node -- block' ) node node-input-infos first literal>> :> len len expand-? [ ds-pop :> elt @@ -50,8 +50,8 @@ IN: compiler.cfg.intrinsics.allot ds-drop len reg array store-length len reg elt array store-initial-element - reg ds-push - ] [ node basic-block get swap emit-primitive drop ] if ; + reg ds-push block + ] [ block node emit-primitive ] if ; : expand-(byte-array)? ( obj -- ? ) dup integer? [ 0 1024 between? ] [ drop f ] if ; @@ -67,9 +67,10 @@ IN: compiler.cfg.intrinsics.allot : emit-allot-byte-array ( len -- dst ) ds-drop ^^allot-byte-array dup ds-push ; -: emit-(byte-array) ( node -- ) - 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 ; +: emit-(byte-array) ( block node -- block' ) + dup node-input-infos first literal>> dup expand-(byte-array)? [ + nip emit-allot-byte-array drop + ] [ drop emit-primitive ] if ; :: zero-byte-array ( len reg -- ) 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, ] each ; -:: emit- ( node -- ) - node node-input-infos first literal>> dup expand-? [ +:: emit- ( block #call -- block' ) + #call node-input-infos first literal>> dup expand-? [ :> len len emit-allot-byte-array :> reg - len reg zero-byte-array - ] [ drop node basic-block get swap emit-primitive drop ] if ; + len reg zero-byte-array block + ] [ drop block #call emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index b5e3fb99d4..08c4543a24 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators compiler.cfg -compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks -compiler.cfg.stacks.local compiler.tree.propagation.info -cpu.architecture fry kernel layouts math math.intervals namespaces -sequences ; +USING: accessors arrays combinators compiler.cfg.builder.blocks +compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks.local +compiler.tree.propagation.info cpu.architecture fry kernel layouts +locals math math.intervals namespaces sequences ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) @@ -25,13 +24,13 @@ IN: compiler.cfg.intrinsics.fixnum tag-bits get ^^sar-imm ] binary-op ; -: emit-fixnum-shift-general ( -- ) - ds-peek 0 cc> ##compare-integer-imm-branch, - basic-block get [ emit-fixnum-left-shift ] with-branch - basic-block get [ emit-fixnum-right-shift ] with-branch - 2array basic-block get swap emit-conditional drop ; +: emit-fixnum-shift-general ( block -- block' ) + ds-peek 0 cc> ##compare-integer-imm-branch, dup + [ [ emit-fixnum-left-shift ] with-branch ] + [ [ emit-fixnum-right-shift ] with-branch ] bi 2array + emit-conditional ; -: emit-fixnum-shift-fast ( node -- ) +: emit-fixnum-shift-fast ( block #call -- block' ) node-input-infos second interval>> { { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-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 -- ) '[ _ ^^compare-integer ] binary-op ; -: emit-no-overflow-case ( dst -- final-bb ) - basic-block get [ - swap D: -2 inc-stack ds-push - ] with-branch ; +: emit-no-overflow-case ( dst block -- final-bb ) + [ swap D: -2 inc-stack ds-push ] with-branch ; -: emit-overflow-case ( word -- final-bb ) - basic-block get [ - swap -1 basic-block get emit-call-block - ] with-branch ; +: emit-overflow-case ( word block -- final-bb ) + [ -1 swap [ emit-call-block ] keep ] with-branch ; -: emit-fixnum-overflow-op ( quot word -- ) - ! Inputs to the final instruction need to be copied because - ! of loc>vreg sync - [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip - [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array - basic-block get swap emit-conditional drop ; inline +:: emit-fixnum-overflow-op ( block quot word -- block' ) + (2inputs) [ any-rep ^^copy ] bi@ cc/o + quot call( vreg1 vreg2 cc -- vreg ) block emit-no-overflow-case + word block emit-overflow-case 2array + block swap emit-conditional ; inline : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; @@ -64,11 +58,11 @@ IN: compiler.cfg.intrinsics.fixnum : fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ; -: emit-fixnum+ ( -- ) +: emit-fixnum+ ( block -- block' ) [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ; -: emit-fixnum- ( -- ) +: emit-fixnum- ( block -- block' ) [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; -: emit-fixnum* ( -- ) +: emit-fixnum* ( block -- block' ) [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2b815bfd6c..2f5a6ce5a1 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -65,7 +65,7 @@ ERROR: inline-intrinsics-not-supported word quot ; { byte-arrays:(byte-array) [ emit-(byte-array) ] } { kernel: [ emit-simple-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: [ emit- ] } { 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 ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc-docs.factor b/basis/compiler/cfg/intrinsics/misc/misc-docs.factor index f9a1ccf211..0e2fecd558 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc-docs.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc-docs.factor @@ -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 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." } ; diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index 935fbb0c4f..42a176eea3 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! 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.instructions compiler.cfg.stacks compiler.constants 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? [ [ 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>> [ ds-drop vm-special-object-offset ^^vm-field 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>> [ ds-drop [ 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 ) cells "context-objects" context offset-of + ; -: emit-context-object ( node -- ) +: emit-context-object ( block node -- block' ) dup node-input-infos first literal>> [ "ctx" vm offset-of ^^vm-field 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 ( -- ) [ @@ -44,11 +44,10 @@ IN: compiler.cfg.intrinsics.misc hashcode-shift ^^shr-imm ] unary-op ; -: emit-local-allot ( node -- ) +: emit-local-allot ( block node -- block' ) dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both? [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ] - [ 2drop basic-block get swap emit-primitive drop ] - if ; + [ 2drop emit-primitive ] if ; -: emit-cleanup-allot ( -- ) - basic-block get [ drop ##no-tco, ] emit-trivial-block drop ; +: emit-cleanup-allot ( block node -- block' ) + drop [ drop ##no-tco, ] emit-trivial-block ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 93db54f7cc..1b846da492 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -633,7 +633,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep { float-vector-rep [ ^select-vector ] } } [ integer? ] emit-vl-vector-op ; -: emit-alien-vector ( node -- ) +: emit-alien-vector ( block node -- block' ) dup [ '[ ds-drop prepare-load-memory @@ -642,14 +642,13 @@ PREDICATE: fixnum-vector-rep < int-vector-rep [ inline-load-memory? ] inline-accessor ] with { [ %alien-vector-reps member? ] } if-literals-match ; -: emit-set-alien-vector ( node -- ) +: emit-set-alien-vector ( block node -- block' ) dup [ '[ ds-drop prepare-store-memory _ f ##store-memory-imm, ] - [ byte-array inline-store-memory? ] - inline-accessor + [ byte-array inline-store-memory? ] inline-accessor ] with { [ %alien-vector-reps member? ] } if-literals-match ; : enable-simd ( -- ) diff --git a/basis/compiler/cfg/intrinsics/slots/slots-docs.factor b/basis/compiler/cfg/intrinsics/slots/slots-docs.factor index bbacb0ea45..c20365d8c3 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots-docs.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots-docs.factor @@ -1,6 +1,6 @@ -USING: classes classes.builtin compiler.cfg.instructions compiler.tree -compiler.tree.propagation.info help.markup help.syntax kernel layouts -math slots.private ; +USING: classes classes.builtin compiler.cfg compiler.cfg.instructions +compiler.tree compiler.tree.propagation.info help.markup help.syntax +kernel layouts math slots.private ; IN: compiler.cfg.intrinsics.slots 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." } ; 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." } ; + +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" diff --git a/basis/compiler/cfg/intrinsics/slots/slots-tests.factor b/basis/compiler/cfg/intrinsics/slots/slots-tests.factor index acd2f98cdf..cb80376df1 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots-tests.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots-tests.factor @@ -1,7 +1,7 @@ -USING: accessors arrays compiler.cfg compiler.cfg.instructions -compiler.cfg.intrinsics.slots compiler.test compiler.tree -compiler.tree.propagation.info kernel layouts literals make math -math.intervals namespaces sequences slots.private tools.test ; +USING: accessors arrays compiler.cfg compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.intrinsics.slots compiler.test +compiler.tree compiler.tree.propagation.info kernel layouts literals +make math math.intervals sequences slots.private tools.test ; IN: compiler.cfg.intrinsics.slots.tests : call-node-1 ( -- node ) @@ -111,8 +111,9 @@ IN: compiler.cfg.intrinsics.slots.tests { V{ T{ ##call { word set-slot } } T{ ##branch } } } [ + dup set-basic-block call-node-1 [ emit-set-slot ] V{ } make drop - basic-block get successors>> first instructions>> + predecessors>> first instructions>> ] cfg-unit-test { diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 593f8561cf..35f76e7656 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -30,14 +30,14 @@ IN: compiler.cfg.intrinsics.slots : immediate-slot-offset? ( object -- ? ) { [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ; -: emit-slot ( node -- ) +: emit-slot ( block node -- block' ) dup node-input-infos dup first value-tag [ nip dup second literal>> immediate-slot-offset? [ (emit-slot-imm) ] [ (emit-slot) ] if ds-push - ] [ drop basic-block get swap emit-primitive drop ] if ; + ] [ drop emit-primitive ] if ; :: (emit-set-slot-imm) ( write-barrier? tag slot -- ) ds-drop @@ -68,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots (emit-set-slot-imm) ] [ drop (emit-set-slot) ] if ; -: emit-set-slot ( node -- ) +: emit-set-slot ( block #call -- block' ) dup node>set-slot-data over [ emit-intrinsic-set-slot drop - ] [ 3drop basic-block get swap emit-primitive drop ] if ; + ] [ 3drop emit-primitive ] if ;