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.

diff --git a/basis/compiler/cfg/builder/alien/alien-docs.factor b/basis/compiler/cfg/builder/alien/alien-docs.factor
index 3642b95121cc1c1141832a6e6482cc4026b41096..bdf3ca1bb7d8ab83a69dd49ae4596aaf720fa9eb 100644 (file)
--- 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 9d618bfb367e97daa413b9cb646de2df0d2f2373..22b878f4d6c42de4928548f896c6ff535abda8cb 100644 (file)
--- 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 } [
-    <basic-block> dup basic-block set dup
+    <basic-block> 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
+    <basic-block> 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 6e12b3fad7a825e42dda3252a57fb99d75db64a0..1f266d7835ffaffd1404b31d55416801c62f2c14 100644 (file)
--- 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 5b3d27ad366a12fd8b960fca0a59aa778296d450..70e158df71a249ec80d711f2f3601efec04c0d2b 100644 (file)
--- 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
+{ } [
+    <basic-block> 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 8b6b35bdbbc5694caa61c433136850f4eaf2a115..75b574e3a3dd3c360082d967703867c279f8b5dc 100644 (file)
--- 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 8cc47a3c096af6653d48b529d0fb7d36821cb00f..1fa34fb88a797590860c0bca0ba60f16caaab189 100644 (file)
--- 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 b601138eb81891d87d2f67304a4344f73255a9f3..0aaff60083632d4f5ede05acc22992dbf193fb6f 100644 (file)
--- 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
+    <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 5fef4ff6434e8774175fc5313779ccc759a85614..ec163d144ffe899aae3a9d4182174deeb4b69f99 100644 (file)
--- 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 7372210238257a5f6d1871ec724098d9f5d40277..ccb4eef3674a6cd5f1ef6d28551b8b3105cd8b2f 100644 (file)
--- 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-<displaced-alien> ( node -- )
+: emit-<displaced-alien> ( block node -- block' )
     dup emit-<displaced-alien>? [
         '[
             _ 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 6e9e909acad1768489dc3b72959ecb5dc09c9453..c1114f6dddc5c028d27a8821737d968f19df09e0 100644 (file)
--- 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-<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 } "." } ;
 
 HELP: emit-<tuple-boa>
-{ $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 <tuple-boa> } " must be a literal." }
+{ $see-also <tuple-boa> } ;
 
 ARTICLE: "compiler.cfg.intrinsics.allot" "Generating instructions for inline memory allocation"
 "Generating instructions for inline memory allocation"
 $nl
 "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"

diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index 9b35de77d3d69c05bc4ceaf3c605de13331637b3..ff6e1b9b5c4ddaa57ffc7b11daf076d5f231fc80 100644 (file)
--- 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-<tuple-boa> ( node -- )
+: emit-<tuple-boa> ( 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-<array> ( node -- )
+:: emit-<array> ( block node -- block' )
     node node-input-infos first literal>> :> len
     len expand-<array>? [
         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-<byte-array> ( node -- )
-    node node-input-infos first literal>> dup expand-<byte-array>? [
+:: emit-<byte-array> ( block #call -- block' )
+    #call node-input-infos first literal>> dup expand-<byte-array>? [
         :> 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 b5e3fb99d4367cee62a9cf48edb361ab864bd5e6..08c4543a243bc93333c90b14d4819fa853146f37 100644 (file)
--- 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 2b815bfd6c432e8294a229a68dc816cbe2a5e578..2f5a6ce5a18ba435d7db9ba4cf8f204c19d8190d 100644 (file)
--- 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:<wrapper> [ 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:<displaced-alien> [ emit-<displaced-alien> ] }
     { 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 f9a1ccf211895c238af92dc1a901d5ed98b2409a..0e2fecd5589d2bd9305f8a65b5667491a9480397 100644 (file)
--- 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 935fbb0c4fe12321ccc07628ab5534af0e580189..42a176eea30795e34af2217b903e7e99a4b6ee52 100644 (file)
--- 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 93db54f7cc3eb06c364f58697e9aa1bbb8e86bc1..1b846da492184b73a733fcbd720612c27d490cbb 100644 (file)
--- 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 bbacb0ea45b6f1fa6d8d5edfda4b20ba04df56b5..c20365d8c3404ec593e4f3414b7fe06a27dfefe7 100644 (file)
--- 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 acd2f98cdfdc8948d1c1734c59a4eb8b0be4d96c..cb80376df1de44330f22c0a768263ccd0c4c1fef 100644 (file)
--- 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 } }
 } [
+    <basic-block> 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 593f8561cfd8ece2ad8883cf7cc9007fa282a545..35f76e7656d58d54e435246a235dc9c2abd6ab53 100644 (file)
--- 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 ;