compiler: some cleanup

diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
index e1054273d50ddddf09d13cf4014597fe6c30f39a..3ed216117c82a96ed2112b1da0659ff1f7fcf9ee 100644 (file)
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -52,7 +52,7 @@ UNION: irrelevant ##peek ##replace ##inc ;
 : split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
 
 : short-tail-block? ( bb -- ? )
-    [ successors>> empty? ] [ instructions>> length 2 = ] bi and ;
+    { [ successors>> empty? ] [ instructions>> length 2 = ] } 1&& ;
 
 : short-block? ( bb -- ? )
     ! If block is empty, always split

diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 4d2b71aa5490aadd75530344547d07c51d1086c9..f1613339ab37876ddb14f2d08c536b066901b0a0 100644 (file)
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
 USING: accessors alien byte-arrays classes.algebra combinators
-compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.registers compiler.constants effects kernel layouts
-math namespaces parser sequences splitting words ;
+combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.instructions.syntax compiler.cfg.registers
+compiler.constants effects kernel layouts math namespaces parser
+sequences splitting words ;
 IN: compiler.cfg.hats
 
 <<
@@ -35,7 +36,7 @@ IN: compiler.cfg.hats
 PRIVATE>
 
 insn-classes get [
-    dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
+    dup { [ insn-def-slots length 1 = ] [ name>> "##" head? ] } 1&&
     [ define-hat ] [ drop ] if
 ] each
 

diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index 80aa5abc21c8c4e035a1db52fd0e1a92d126d62b..3c638a890e04540e704e0d3fa43d41d741d38d89 100644 (file)
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators
+USING: accessors assocs combinators combinators.short-circuit
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals
@@ -15,7 +15,7 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     dup first-use n>> swap [ fix-lower-bound ] change-ranges drop ;
 
 : last-use-rep ( live-interval -- rep )
-    last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline
+    last-use { [ def-rep>> ] [ use-rep>> ] } 1|| ; inline
 
 : assign-spill ( live-interval -- )
     dup last-use-rep dup [

diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index 509e77dc09cab4d1503e9311209495170ef67179..9980999917b66c211f8a331eb2e14e77ebff1cc6 100644 (file)
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes.algebra combinators
-compiler.tree compiler.tree.dead-code.liveness
-compiler.tree.propagation.info fry kernel locals math math.private
-namespaces sequences stack-checker.backend stack-checker.dependencies
-words ;
+combinators.short-circuit compiler.tree
+compiler.tree.dead-code.liveness compiler.tree.propagation.info
+fry kernel locals math math.private namespaces sequences
+stack-checker.backend stack-checker.dependencies words ;
 IN: compiler.tree.dead-code.simple
 
 : flushable-call? ( #call -- ? )
@@ -136,7 +136,7 @@ M: #shuffle remove-dead-code*
     [ filter-live ] change-in-r
     [ filter-live ] change-out-r
     [ filter-mapping ] change-mapping
-    dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
+    dup { [ in-d>> empty? ] [ in-r>> empty? ] } 1&& [ drop f ] when ;
 
 M: #copy remove-dead-code*
     [ in-d>> ] [ out-d>> ] bi

diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index e281916487936f5b86ea672f23e9299f54d45d7d..ea585e0ce0cc23021d9e3f30a2dea69b203d2977 100644 (file)
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -82,7 +82,7 @@ M: #shuffle node>quot
         { [ dup #>r? ] [ drop \ >R , ] }
         { [ dup #r>? ] [ drop \ R> , ] }
         {
-            [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
+            [ dup { [ in-r>> empty? ] [ out-r>> empty? ] } 1&& ]
             [
                 shuffle-effect dup pretty-shuffle
                 [ % ] [ shuffle-node boa , ] ?if

diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 1348c4131f4a770c630322eadb5fe21000f334f3..34b5ff1281ff688c0fad7098cf02b834e0a48314 100644 (file)
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -12,17 +12,14 @@ SYMBOL: value-classes
 
 SYMBOL: allocations
 
-: (allocation) ( -- allocations )
-    allocations get ; inline
-
 : allocation ( value -- allocation )
-    (allocation) at ;
+    allocations get at ;
 
 : record-allocation ( allocation value -- )
-    (allocation) set-at ;
+    allocations get set-at ;
 
 : record-allocations ( allocations values -- )
-    (allocation) '[ _ set-at ] 2each ;
+    allocations get '[ _ set-at ] 2each ;
 
 SYMBOL: slot-accesses
 
@@ -65,14 +62,10 @@ SYMBOL: +escaping+
 : equate-values ( value1 value2 -- )
     escaping-values get equate ;
 
+DEFER: add-escaping-values
+
 : add-escaping-value ( value -- )
-    [
-        allocation {
-            { [ dup not ] [ drop ] }
-            { [ dup t eq? ] [ drop ] }
-            [ [ add-escaping-value ] each ]
-        } cond
-    ]
+    [ allocation dup boolean? [ drop ] [ add-escaping-values ] if ]
     [ +escaping+ equate-values ] bi ;
 
 : add-escaping-values ( values -- )
@@ -95,26 +88,23 @@ SYMBOL: +escaping+
 DEFER: copy-value
 
 : copy-allocation ( allocation -- allocation' )
-    {
-        { [ dup not ] [ ] }
-        { [ dup t eq? ] [ ] }
-        [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
-    } cond ;
+    dup boolean? [
+        [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map
+    ] unless ;
+
+:: (copy-value) ( from to allocations -- )
+    from to equate-values
+    from allocations at copy-allocation to allocations set-at ;
 
 : copy-value ( from to -- )
-    [ equate-values ]
-    [ [ allocation copy-allocation ] dip record-allocation ]
-    2bi ;
+    allocations get (copy-value) ;
 
 : copy-values ( from to -- )
-    [ copy-value ] 2each ;
+    allocations get '[ _ (copy-value) ] 2each ;
 
 : copy-slot-value ( out slot# in -- )
-    allocation {
-        { [ dup not ] [ 3drop ] }
-        { [ dup t eq? ] [ 3drop ] }
-        [ nth swap copy-value ]
-    } cond ;
+    allocation dup boolean?
+    [ 3drop ] [ nth swap copy-value ] if ;
 
 SYMBOL: escaping-allocations
 

diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
index d0b2ac33ffe056593d3e24483942a18c6d88a58b..4fb1c282b628f41c83666c361b511d45a0e4ea4f 100644 (file)
--- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -10,8 +10,7 @@ IN: compiler.tree.escape-analysis.recursive
 
 : congruent? ( alloc1 alloc2 -- ? )
     {
-        { [ 2dup [ f eq? ] either? ] [ eq? ] }
-        { [ 2dup [ t eq? ] either? ] [ eq? ] }
+        { [ 2dup [ boolean? ] either? ] [ eq? ] }
         { [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
         [ [ [ allocation ] bi@ congruent? ] 2all? ]
     } cond ;

diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
index b136ab741f3b2d9aee8516ae472344d883e96cb9..165994f3ebe556071b1baf5c7c93ba90de297a4c 100644 (file)
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@@ -132,7 +132,7 @@ SYMBOL: changed?
 GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 
 M: #push optimize-modular-arithmetic*
-    dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
+    dup { [ out-d>> first modular-value? ] [ literal>> real? ] } 1&&
     [ [ >fixnum ] change-literal ] when ;
 
 : redundant->fixnum? ( #call -- ? )

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index a7d978bb5f98026c7747435c0a6fa831706580ec..de8aeefd6c3c0962698ee00f3db23f5c1d0a763f 100644 (file)
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -114,8 +114,10 @@ GENERIC: already-inlined-quot? ( quot -- ? )
 M: curried already-inlined-quot? quot>> already-inlined-quot? ;
 
 M: composed already-inlined-quot?
-    [ first>> already-inlined-quot? ]
-    [ second>> already-inlined-quot? ] bi or ;
+    {
+        [ first>> already-inlined-quot? ]
+        [ second>> already-inlined-quot? ]
+    } 1|| ;
 
 M: quotation already-inlined-quot? already-inlined? ;
 

diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor
index 1dbce7be9d8e1dca190b6713889b3311f4b1e896..8b812a81bc707ab3e9cfbe08c77c5434836f35ff 100644 (file)
--- a/basis/compiler/tree/propagation/copy/copy.factor
+++ b/basis/compiler/tree/propagation/copy/copy.factor
@@ -1,35 +1,33 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.tree compiler.tree.def-use
-compiler.utilities grouping kernel namespaces sequences sets
-stack-checker.branches ;
+USING: accessors assocs combinators.short-circuit compiler.tree
+compiler.tree.def-use compiler.utilities grouping kernel
+namespaces sequences sets stack-checker.branches ;
 IN: compiler.tree.propagation.copy
 
 SYMBOL: copies
 
 : resolve-copy ( copy -- val ) copies get compress-path ;
 
-: resolve-copies ( copies -- vals )
-    copies get [ compress-path ] curry map ;
+: resolve-copies ( copies -- vals ) copies get '[ _ compress-path ] map ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+: are-copies-of ( vals copies -- ) copies get '[ _ set-at ] 2each ;
 
 : introduce-value ( val -- ) copies get conjoin ;
 
-: introduce-values ( vals -- )
-    copies get [ conjoin ] curry each ;
+: introduce-values ( vals -- ) copies get '[ _ conjoin ] each ;
 
 GENERIC: compute-copy-equiv* ( node -- )
 
 M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
 
 : compute-phi-equiv ( inputs outputs -- )
-    [
+    copies get '[
         swap remove-bottom resolve-copies
         dup [ f ] [ all-equal? ] if-empty
-        [ first swap is-copy-of ] [ 2drop ] if
+        [ first swap _ set-at ] [ 2drop ] if
     ] 2each ;
 
 M: #phi compute-copy-equiv*

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 804669bb1dd347f0decf7ee9a436e1e41cdc500a..b1db9cbc5a20db08b49cac7c46f619f831fc7da8 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -83,7 +83,7 @@ UNION: fixed-length array byte-array string ;
 : empty-set? ( info -- ? )
     {
         [ class>> null-class? ]
-        [ [ interval>> empty-interval? ] [ class>> real class<= ] bi and ]
+        [ { [ interval>> empty-interval? ] [ class>> real class<= ] } 1&& ]
     } 1|| ;
 
 ! Hardcoding classes is kind of a hack.
@@ -188,11 +188,7 @@ DEFER: value-info-intersect
 DEFER: (value-info-intersect)
 
 : intersect-slot ( info1 info2 -- info )
-    {
-        { [ dup not ] [ nip ] }
-        { [ over not ] [ drop ] }
-        [ (value-info-intersect) ]
-    } cond ;
+    2dup and [ (value-info-intersect) ] [ 2drop f ] if ;
 
 : intersect-slots ( info1 info2 -- slots )
     [ slots>> ] bi@ {
@@ -231,11 +227,7 @@ DEFER: value-info-union
 DEFER: (value-info-union)
 
 : union-slot ( info1 info2 -- info )
-    {
-        { [ dup not ] [ nip ] }
-        { [ over not ] [ drop ] }
-        [ (value-info-union) ]
-    } cond ;
+    2dup and [ (value-info-union) ] [ 2drop f ] if ;
 
 : union-slots ( info1 info2 -- slots )
     [ slots>> ] bi@
@@ -295,14 +287,26 @@ SYMBOL: value-infos
 : value-info ( value -- info )
     value-info* drop ;
 
+: (set-value-info) ( info value assoc -- )
+    [ resolve-copy ] dip last set-at ;
+
 : set-value-info ( info value -- )
-    resolve-copy value-infos get last set-at ;
+    value-infos get (set-value-info) ;
 
-: refine-value-info ( info value -- )
-    resolve-copy value-infos get
+: set-value-infos ( infos values -- )
+    value-infos get '[ _ (set-value-info) ] 2each ;
+
+: (refine-value-info) ( info value assoc -- )
+    [ resolve-copy ] dip
     [ assoc-stack [ value-info-intersect ] when* ] 2keep
     last set-at ;
 
+: refine-value-info ( info value -- )
+    value-infos get (refine-value-info) ;
+
+: refine-value-infos ( infos values -- )
+    value-infos get '[ _ (refine-value-info) ] 2each ;
+
 : value-literal ( value -- obj ? )
     value-info >literal< ;
 

diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 9c64bcaaa677b08ba00b7214edc33830ca4d9117..e0f17a278e1d3a916a6499bbc8f35a8a77fe5612 100644 (file)
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors classes.algebra combinators compiler.tree
+USING: accessors classes.algebra combinators
+combinators.short-circuit compiler.tree
 compiler.tree.combinators compiler.tree.propagation.constraints
 compiler.tree.propagation.copy compiler.tree.propagation.info
 compiler.tree.propagation.nodes compiler.tree.propagation.simple
@@ -83,7 +84,7 @@ M: #recursive propagate-around ( #recursive -- )
     label>> enter-recursive>> node-output-infos ;
 
 : generalize-return-interval ( info -- info' )
-    dup [ literal?>> ] [ class>> null-class? ] bi or
+    dup { [ literal?>> ] [ class>> null-class? ] } 1||
     [ clone dup class>> class-interval >>interval ] unless ;
 
 : generalize-return ( infos -- infos' )

diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index ca8c29343e03caa3606cf951b599b11aa8a5df99..fd6885610fa6184cd789826329fb63db8b9c59bc 100644 (file)
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -16,12 +16,6 @@ M: #push propagate-before
     [ literal>> <literal-info> ] [ out-d>> first ] bi
     set-value-info ;
 
-: refine-value-infos ( classes/f values -- )
-    [ refine-value-info ] 2each ;
-
-: set-value-infos ( infos values -- )
-    [ set-value-info ] 2each ;
-
 M: #declare propagate-before
     ! We need to force the caller word to recompile when the
     ! classes mentioned in the declaration are redefined, since

diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index 247521a87e3e9c8b226b468a1c9c291c2399c708..3e26ad9b3026b861b4c7e452412c802e891e4797 100644 (file)
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -87,7 +87,7 @@ SYMBOL: changed?
     label>> dup not-a-loop? [ drop ] [
         recursive-nesting get <reversed> [
             2dup label>> eq? [ 2drop f ] [
-                [ label>> not-a-loop? ] [ tail?>> not ] bi or
+                { [ label>> not-a-loop? ] [ tail?>> not ] } 1||
                 [ not-a-loop changed? on ] [ drop ] if t
             ] if
         ] with all? drop

diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index e0137d3ceeaeae6b7033cb82f88cd61264982a89..8922ea8755f886883f76a66146b9dedddfe209d7 100644 (file)
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -161,6 +161,6 @@ M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ;
 M: #alien-callback unbox-tuples* ;
 
 : unbox-tuples ( nodes -- nodes )
-    (allocation) escaping-allocations get
+    allocations get escaping-allocations get
     [ nip key? ] curry assoc-all?
     [ [ unbox-tuples* ] map-nodes ] unless ;