From 482998974bf1b0f05f2198f7081b9b82749f7e8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= Date: Mon, 7 Mar 2016 06:40:27 +0100 Subject: [PATCH] compiler.cfg.*: more refactoring to remove basic-block get:s Now almost all words pass around the current basic block on the stack. Left is updating all intrinsics. --- .../cfg/builder/blocks/blocks-docs.factor | 12 ++++++++++-- .../cfg/builder/blocks/blocks-tests.factor | 5 +++-- .../compiler/cfg/builder/blocks/blocks.factor | 18 +++++++----------- basis/compiler/cfg/builder/builder.factor | 6 ++---- .../compiler/cfg/intrinsics/alien/alien.factor | 15 +++++++-------- .../compiler/cfg/intrinsics/allot/allot.factor | 18 +++++++++--------- .../cfg/intrinsics/fixnum/fixnum.factor | 12 +++++++----- basis/compiler/cfg/intrinsics/misc/misc.factor | 12 ++++++------ .../compiler/cfg/intrinsics/slots/slots.factor | 8 ++++---- 9 files changed, 55 insertions(+), 51 deletions(-) diff --git a/basis/compiler/cfg/builder/blocks/blocks-docs.factor b/basis/compiler/cfg/builder/blocks/blocks-docs.factor index 4a1500564c..6e12b3fad7 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-docs.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-docs.factor @@ -59,7 +59,11 @@ HELP: emit-conditional { $description "Emits a sequence of conditional branches to the current " { $link cfg } ". Each branch is a pair where the first item is the entry basic block and the second the branches " { $link height-state } ". 'block' is the block in which the control flow is branched and \"block'\" the block in which it converges again." } ; HELP: emit-trivial-block -{ $values { "quot" quotation } } +{ $values + { "block" basic-block } + { "quot" quotation } + { "block'" basic-block } +} { $description "Combinator that emits a new trivial block, constructed by calling the supplied quotation. The quotation should not end the current block -- only add instructions to it." } { $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ; @@ -76,7 +80,11 @@ HELP: set-basic-block { $description "Sets the given blocks as the current one by storing it in the basic-block dynamic variable. If it has any " { $slot "instructions" } " the current " { $link building } " is set to those." } ; HELP: with-branch -{ $values { "quot" quotation } { "pair/f" { $maybe "pair" } } } +{ $values + { "block" basic-block } + { "quot" quotation } + { "pair/f" { $maybe "pair" } } +} { $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" diff --git a/basis/compiler/cfg/builder/blocks/blocks-tests.factor b/basis/compiler/cfg/builder/blocks/blocks-tests.factor index 6732d855f4..5b3d27ad36 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-tests.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-tests.factor @@ -23,8 +23,9 @@ IN: compiler.cfg.builder.blocks.tests { V{ T{ ##no-tco } T{ ##branch } } } [ - [ [ drop ##no-tco, ] emit-trivial-block ] V{ } make drop - basic-block get successors>> first instructions>> + dup set-basic-block + [ drop ##no-tco, ] emit-trivial-block + predecessors>> first instructions>> ] cfg-unit-test ! end-basic-block diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 09e57a41d9..8b6b35bdbb 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -21,10 +21,10 @@ IN: compiler.cfg.builder.blocks : begin-basic-block ( block -- block' ) dup [ end-local-analysis ] when* (begin-basic-block) ; -: emit-trivial-block ( quot: ( ..a block -- ..b ) -- ) - ##branch, basic-block get begin-basic-block +: emit-trivial-block ( block quot: ( ..a block' -- ..b ) -- block' ) + ##branch, swap begin-basic-block [ swap call ] keep - ##branch, begin-basic-block drop ; inline + ##branch, begin-basic-block ; inline : make-kill-block ( block -- ) t swap kill-block?<< ; @@ -35,8 +35,8 @@ IN: compiler.cfg.builder.blocks : emit-call-block ( word height block -- ) make-kill-block adjust-d ##call, ; -: emit-primitive ( node -- ) - [ word>> ] [ call-height ] bi +: emit-primitive ( block node -- block' ) + [ word>> ] [ call-height ] bi rot [ emit-call-block ] emit-trivial-block ; : begin-branch ( block -- block' ) @@ -49,12 +49,8 @@ IN: compiler.cfg.builder.blocks height-state get clone-height-state 2array ] when* ; -: with-branch ( quot -- pair/f ) - [ - basic-block get begin-branch drop - call - basic-block get end-branch - ] with-scope ; inline +: with-branch ( block quot: ( ..a block -- ..b block' ) -- pair/f ) + [ [ begin-branch ] dip call end-branch ] with-scope ; inline : emit-conditional ( block branches -- block' ) swap end-basic-block diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 8edaf67683..5fef4ff643 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -55,9 +55,7 @@ GENERIC: emit-node ( block node -- block' ) [ swap connect-bbs ] [ end-basic-block ] bi ; : emit-trivial-call ( block word height -- block' ) - ##branch, rot begin-basic-block - [ emit-call-block ] keep - ##branch, begin-basic-block ; + rot [ emit-call-block ] emit-trivial-block ; : emit-call ( block word height -- block' ) over loops get at [ @@ -81,7 +79,7 @@ M: #recursive emit-node ( block node -- block' ) ! #if : emit-branch ( nodes block -- pair/f ) - [ begin-branch swap emit-nodes end-branch ] with-scope ; + [ swap emit-nodes ] with-branch ; : emit-if ( block node -- block' ) children>> over '[ _ emit-branch ] map emit-conditional ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index cbd9f3730e..7372210238 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences alien math classes.algebra fry -locals combinators combinators.short-circuit cpu.architecture -compiler.tree.propagation.info compiler.cfg.hats -compiler.cfg.registers compiler.cfg.stacks -compiler.cfg.instructions compiler.cfg.utilities -compiler.cfg.builder.blocks ; +USING: accessors alien classes.algebra combinators +combinators.short-circuit compiler.cfg compiler.cfg.builder.blocks +compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks +compiler.tree.propagation.info cpu.architecture fry kernel locals math +namespaces sequences ; IN: compiler.cfg.intrinsics.alien : emit-? ( node -- ? ) @@ -20,13 +19,13 @@ IN: compiler.cfg.intrinsics.alien _ node-input-infos second class>> ^^box-displaced-alien ] binary-op - ] [ emit-primitive ] if ; + ] [ basic-block get swap emit-primitive drop ] if ; :: inline-accessor ( node quot test -- ) node node-input-infos :> infos infos test call [ infos quot call ] - [ node emit-primitive ] if ; inline + [ node basic-block get swap emit-primitive drop ] if ; inline : inline-load-memory? ( infos -- ? ) [ first class>> c-ptr class<= ] diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index c41be223f8..9b35de77d3 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays compiler.cfg.builder.blocks -compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.stacks compiler.constants compiler.tree.propagation.info -cpu.architecture fry kernel layouts locals math math.order -sequences ; +USING: accessors arrays byte-arrays compiler.cfg +compiler.cfg.builder.blocks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks +compiler.constants compiler.tree.propagation.info cpu.architecture fry +kernel layouts locals math math.order namespaces sequences ; IN: compiler.cfg.intrinsics.allot : ##set-slots, ( regs obj class -- ) @@ -28,7 +28,7 @@ IN: compiler.cfg.intrinsics.allot ds-drop [ tuple-slot-regs ] [ second ^^allot-tuple ] bi [ tuple ##set-slots, ] [ ds-push drop ] 2bi - ] [ drop emit-primitive ] if ; + ] [ drop basic-block get swap emit-primitive drop ] if ; : store-length ( len reg class -- ) [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ; @@ -51,7 +51,7 @@ IN: compiler.cfg.intrinsics.allot len reg array store-length len reg elt array store-initial-element reg ds-push - ] [ node emit-primitive ] if ; + ] [ node basic-block get swap emit-primitive drop ] if ; : expand-(byte-array)? ( obj -- ? ) dup integer? [ 0 1024 between? ] [ drop f ] if ; @@ -69,7 +69,7 @@ IN: compiler.cfg.intrinsics.allot : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-(byte-array)? - [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; + [ nip emit-allot-byte-array drop ] [ drop basic-block get swap emit-primitive drop ] if ; :: zero-byte-array ( len reg -- ) 0 ^^load-literal :> elt @@ -83,4 +83,4 @@ IN: compiler.cfg.intrinsics.allot :> len len emit-allot-byte-array :> reg len reg zero-byte-array - ] [ drop node emit-primitive ] if ; + ] [ drop node basic-block get swap emit-primitive drop ] if ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 224c66e09e..b5e3fb99d4 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -27,8 +27,8 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-shift-general ( -- ) ds-peek 0 cc> ##compare-integer-imm-branch, - [ emit-fixnum-left-shift ] with-branch - [ emit-fixnum-right-shift ] with-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-fast ( node -- ) @@ -42,11 +42,13 @@ IN: compiler.cfg.intrinsics.fixnum '[ _ ^^compare-integer ] binary-op ; : emit-no-overflow-case ( dst -- final-bb ) - [ D: -2 inc-stack ds-push ] with-branch ; + basic-block get [ + swap D: -2 inc-stack ds-push + ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ - -1 basic-block get emit-call-block + basic-block get [ + swap -1 basic-block get emit-call-block ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index b7fca87308..935fbb0c4f 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 +USING: accessors classes.algebra classes.struct compiler.cfg 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 @@ -19,13 +19,13 @@ IN: compiler.cfg.intrinsics.misc ds-drop vm-special-object-offset ^^vm-field ds-push - ] [ emit-primitive ] ?if ; + ] [ basic-block get swap emit-primitive drop ] ?if ; : emit-set-special-object ( node -- ) dup node-input-infos second literal>> [ ds-drop [ ds-pop ] dip vm-special-object-offset ##set-vm-field, - ] [ emit-primitive ] ?if ; + ] [ basic-block get swap emit-primitive drop ] ?if ; : context-object-offset ( n -- n ) cells "context-objects" context offset-of + ; @@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.misc 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 - ] [ emit-primitive ] ?if ; + ] [ basic-block get swap emit-primitive drop ] ?if ; : emit-identity-hashcode ( -- ) [ @@ -47,8 +47,8 @@ IN: compiler.cfg.intrinsics.misc : emit-local-allot ( node -- ) dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both? [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ] - [ 2drop emit-primitive ] + [ 2drop basic-block get swap emit-primitive drop ] if ; : emit-cleanup-allot ( -- ) - [ drop ##no-tco, ] emit-trivial-block ; + basic-block get [ drop ##no-tco, ] emit-trivial-block drop ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 7b57575058..593f8561cf 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes.algebra classes.builtin -combinators.short-circuit compiler.cfg.builder.blocks +combinators.short-circuit compiler.cfg compiler.cfg.builder.blocks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture -kernel layouts locals math namespaces sequences slots.private ; +kernel layouts locals math namespaces sequences ; IN: compiler.cfg.intrinsics.slots : class-tag ( class -- tag/f ) @@ -37,7 +37,7 @@ IN: compiler.cfg.intrinsics.slots dup second literal>> immediate-slot-offset? [ (emit-slot-imm) ] [ (emit-slot) ] if ds-push - ] [ drop emit-primitive ] if ; + ] [ drop basic-block get swap emit-primitive drop ] if ; :: (emit-set-slot-imm) ( write-barrier? tag slot -- ) ds-drop @@ -71,4 +71,4 @@ IN: compiler.cfg.intrinsics.slots : emit-set-slot ( node -- ) dup node>set-slot-data over [ emit-intrinsic-set-slot drop - ] [ 3drop emit-primitive ] if ; + ] [ 3drop basic-block get swap emit-primitive drop ] if ;