Local DCE

basis/compiler/tree/builder/builder.factor

@@ -21,7 +21,7 @@ IN: compiler.tree.builder
 : build-tree-with ( in-stack quot -- nodes out-stack )
     #! Not safe to call from inference transforms.
     [
-        [ >vector meta-d set ]
+        [ >vector \ meta-d set ]
         [ f initial-recursive-state infer-quot ] bi*
     ] with-tree-builder nip
     unclip-last in-d>> ;

basis/stack-checker/backend/backend-tests.factor

@@ -3,20 +3,21 @@ stack-checker.state sequences ;
 IN: stack-checker.backend.tests
 
 [ ] [
-    V{ } clone meta-d set
-    V{ } clone meta-r set
+    V{ } clone \ meta-d set
+    V{ } clone \ meta-r set
+    V{ } clone \ literals set
     0 d-in set
 ] unit-test
 
 [ 0 ] [ 0 ensure-d length ] unit-test
 
 [ 2 ] [ 2 ensure-d length ] unit-test
-[ 2 ] [ meta-d get length ] unit-test
+[ 2 ] [ meta-d length ] unit-test
 
 [ 3 ] [ 3 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
 
 [ 1 ] [ 1 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
 
 [ ] [ 1 consume-d drop ] unit-test

basis/stack-checker/backend/backend.factor

@@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors
 stack-checker.values stack-checker.recursive-state ;
 IN: stack-checker.backend
 
-: push-d ( obj -- ) meta-d get push ;
+: push-d ( obj -- ) meta-d push ;
 
 : pop-d  ( -- obj )
-    meta-d get [
+    meta-d [
         <value> dup 1array #introduce, d-in inc
     ] [ pop ] if-empty ;
 
@@ -22,46 +22,52 @@ IN: stack-checker.backend
     [ <value> ] replicate ;
 
 : ensure-d ( n -- values )
-    meta-d get 2dup length > [
+    meta-d 2dup length > [
         2dup
         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
-        [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
-        meta-d get push-all
+        [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
+        meta-d push-all
     ] when swap tail* ;
 
 : shorten-by ( n seq -- )
     [ length swap - ] keep shorten ; inline
 
 : consume-d ( n -- seq )
-    [ ensure-d ] [ meta-d get shorten-by ] bi ;
+    [ ensure-d ] [ meta-d shorten-by ] bi ;
 
-: output-d ( values -- ) meta-d get push-all ;
+: output-d ( values -- ) meta-d push-all ;
 
 : produce-d ( n -- values )
-    make-values dup meta-d get push-all ;
+    make-values dup meta-d push-all ;
 
-: push-r ( obj -- ) meta-r get push ;
+: push-r ( obj -- ) meta-r push ;
 
 : pop-r ( -- obj )
-    meta-r get dup empty?
+    meta-r dup empty?
     [ too-many-r> inference-error ] [ pop ] if ;
 
 : consume-r ( n -- seq )
-    meta-r get 2dup length >
+    meta-r 2dup length >
     [ too-many-r> inference-error ] when
     [ swap tail* ] [ shorten-by ] 2bi ;
 
-: output-r ( seq -- ) meta-r get push-all ;
-
-: pop-literal ( -- rstate obj )
-    pop-d
-    [ 1array #drop, ]
-    [ literal [ recursion>> ] [ value>> ] bi ] bi ;
-
-GENERIC: apply-object ( obj -- )
+: output-r ( seq -- ) meta-r push-all ;
 
 : push-literal ( obj -- )
-    dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
+    literals get push ;
+
+: pop-literal ( -- rstate obj )
+    literals get [
+        pop-d
+        [ 1array #drop, ]
+        [ literal [ recursion>> ] [ value>> ] bi ] bi
+    ] [ pop recursive-state get swap ] if-empty ;
+
+: literals-available? ( n -- literals ? )
+    literals get 2dup length <=
+    [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
+
+GENERIC: apply-object ( obj -- )
 
 M: wrapper apply-object
     wrapped>>
@@ -72,10 +78,17 @@ M: wrapper apply-object
 M: object apply-object push-literal ;
 
 : terminate ( -- )
-    terminated? on meta-d get clone meta-r get clone #terminate, ;
+    terminated? on meta-d clone meta-r clone #terminate, ;
+
+: check->r ( -- )
+    meta-r empty? [ \ too-many->r inference-error ] unless ;
 
 : infer-quot-here ( quot -- )
-    [ apply-object terminated? get not ] all? drop ;
+    meta-r [
+        V{ } clone \ meta-r set
+        [ apply-object terminated? get not ] all?
+        [ commit-literals check->r ] [ literals get delete-all ] if
+    ] dip \ meta-r set ;
 
 : infer-quot ( quot rstate -- )
     recursive-state get [
@@ -127,13 +140,8 @@ M: object apply-object push-literal ;
 : infer-word-def ( word -- )
     [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 
-: check->r ( -- )
-    meta-r get empty? terminated? get or
-    [ \ too-many->r inference-error ] unless ;
-
 : end-infer ( -- )
-    check->r
-    meta-d get clone #return, ;
+    meta-d clone #return, ;
 
 : effect-required? ( word -- ? )
     {

basis/stack-checker/branches/branches.factor

@@ -57,9 +57,9 @@ SYMBOL: quotations
     branch-variable ;
 
 : datastack-phi ( seq -- phi-in phi-out )
-    [ d-in branch-variable ] [ meta-d active-variable ] bi
+    [ d-in branch-variable ] [ \ meta-d active-variable ] bi
     unify-branches
-    [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
+    [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
 
 : terminated-phi ( seq -- terminated )
     terminated? branch-variable ;
@@ -74,17 +74,25 @@ SYMBOL: quotations
     tri ;
 
 : copy-inference ( -- )
-    meta-d [ clone ] change
-    V{ } clone meta-r set
+    \ meta-d [ clone ] change
+    literals [ clone ] change
     d-in [ ] change ;
 
-: infer-branch ( literal -- namespace )
+GENERIC: infer-branch ( literal -- namespace )
+
+M: literal infer-branch
     [
         copy-inference
         nest-visitor
         [ value>> quotation set ] [ infer-literal-quot ] bi
-        check->r
-    ] H{ } make-assoc ; inline
+    ] H{ } make-assoc ;
+
+M: callable infer-branch
+    [
+        copy-inference
+        nest-visitor
+        [ quotation set ] [ infer-quot-here ] bi
+    ] H{ } make-assoc ;
 
 : infer-branches ( branches -- input children data )
     [ pop-d ] dip
@@ -96,16 +104,19 @@ SYMBOL: quotations
     [ first2 #if, ] dip compute-phi-function ;
 
 : infer-if ( -- )
-    2 consume-d
+    2 literals-available? [
+        (infer-if)
+    ] [
+        drop 2 consume-d
         dup [ known [ curried? ] [ composed? ] bi or ] contains? [
             output-d
             [ rot [ drop call ] [ nip call ] if ]
             infer-quot-here
         ] [
             [ #drop, ] [ [ literal ] map (infer-if) ] bi
+        ] if
     ] if ;
 
 : infer-dispatch ( -- )
-    pop-literal nip [ <literal> ] map
-    infer-branches
+    pop-literal nip infer-branches
     [ #dispatch, ] dip compute-phi-function ;

basis/stack-checker/inlining/inlining.factor

@@ -51,14 +51,14 @@ SYMBOL: enter-out
 : prepare-stack ( word -- )
     required-stack-effect in>>
     [ length ensure-d drop ] [
-        meta-d get clone enter-in set
-        meta-d get swap make-copies enter-out set
+        meta-d clone enter-in set
+        meta-d swap make-copies enter-out set
     ] bi ;
 
 : emit-enter-recursive ( label -- )
     enter-out get >>enter-out
     enter-in get enter-out get #enter-recursive,
-    enter-out get >vector meta-d set ;
+    enter-out get >vector \ meta-d set ;
 
 : entry-stack-height ( label -- stack )
     enter-out>> length ;
@@ -77,7 +77,7 @@ SYMBOL: enter-out
 
 : end-recursive-word ( word label -- )
     [ check-return ]
-    [ meta-d get dup copy-values dup meta-d set #return-recursive, ]
+    [ meta-d dup copy-values dup \ meta-d set #return-recursive, ]
     bi ;
 
 : recursive-word-inputs ( label -- n )
@@ -95,10 +95,8 @@ SYMBOL: enter-out
         [ nip ]
         2tri
 
-        check->r
-
         dup recursive-word-inputs
-        meta-d get
+        meta-d
         stack-visitor get
         terminated? get
     ] with-scope ;
@@ -116,7 +114,7 @@ SYMBOL: enter-out
     swap word>> required-stack-effect in>> length tail* ;
 
 : call-site-stack ( label -- stack )
-    meta-d get trim-stack ;
+    meta-d trim-stack ;
 
 : trimmed-enter-out ( label -- stack )
     dup enter-out>> trim-stack ;
@@ -131,7 +129,7 @@ SYMBOL: enter-out
 
 : adjust-stack-effect ( effect -- effect' )
     [ in>> ] [ out>> ] bi
-    meta-d get length pick length [-]
+    meta-d length pick length [-]
     object <repetition> '[ _ prepend ] bi@
     <effect> ;
 
@@ -142,6 +140,7 @@ SYMBOL: enter-out
     ] [ drop undeclared-recursion-error inference-error ] if ;
 
 : inline-word ( word -- )
+    commit-literals
     [ inlined-dependency depends-on ]
     [
         dup inline-recursive-label [

basis/stack-checker/known-words/known-words.factor

@@ -63,7 +63,9 @@ IN: stack-checker.known-words
 
 GENERIC: infer-call* ( value known -- )
 
-: infer-call ( value -- ) dup known infer-call* ;
+: (infer-call) ( value -- ) dup known infer-call* ;
+
+: infer-call ( -- ) pop-d (infer-call) ;
 
 M: literal infer-call*
     [ 1array #drop, ] [ infer-literal-quot ] bi* ;
@@ -73,7 +75,7 @@ M: curried infer-call*
     [ uncurry ] infer-quot-here
     [ quot>> known pop-d [ set-known ] keep ]
     [ obj>> known pop-d [ set-known ] keep ] bi
-    push-d infer-call ;
+    push-d (infer-call) ;
 
 M: composed infer-call*
     swap push-d
@@ -81,20 +83,41 @@ M: composed infer-call*
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
-    1 infer->r pop-d infer-call
-    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
+    1 infer->r infer-call
+    terminated? get [ 1 infer-r> infer-call ] unless ;
 
 M: object infer-call*
     \ literal-expected inference-warning ;
 
 : infer-slip ( -- )
-    1 infer->r pop-d infer-call 1 infer-r> ;
+    1 infer->r infer-call 1 infer-r> ;
 
 : infer-2slip ( -- )
-    2 infer->r pop-d infer-call 2 infer-r> ;
+    2 infer->r infer-call 2 infer-r> ;
 
 : infer-3slip ( -- )
-    3 infer->r pop-d infer-call 3 infer-r> ;
+    3 infer->r infer-call 3 infer-r> ;
+
+: infer-dip ( -- )
+    commit-literals
+    literals get
+    [ \ dip def>> infer-quot-here ]
+    [ pop 1 infer->r infer-quot-here 1 infer-r>  ]
+    if-empty ;
+
+: infer-2dip ( -- )
+    commit-literals
+    literals get
+    [ \ 2dip def>> infer-quot-here ]
+    [ pop 2 infer->r infer-quot-here 2 infer-r>  ]
+    if-empty ;
+
+: infer-3dip ( -- )
+    commit-literals
+    literals get
+    [ \ 3dip def>> infer-quot-here ]
+    [ pop 3 infer->r infer-quot-here 3 infer-r>  ]
+    if-empty ;
 
 : infer-curry ( -- )
     2 consume-d
@@ -157,11 +180,14 @@ M: object infer-call*
         { \ >r [ 1 infer->r ] }
         { \ r> [ 1 infer-r> ] }
         { \ declare [ infer-declare ] }
-        { \ call [ pop-d infer-call ] }
-        { \ (call) [ pop-d infer-call ] }
+        { \ call [ infer-call ] }
+        { \ (call) [ infer-call ] }
         { \ slip [ infer-slip ] }
         { \ 2slip [ infer-2slip ] }
         { \ 3slip [ infer-3slip ] }
+        { \ dip [ infer-dip ] }
+        { \ 2dip [ infer-2dip ] }
+        { \ 3dip [ infer-3dip ] }
         { \ curry [ infer-curry ] }
         { \ compose [ infer-compose ] }
         { \ execute [ infer-execute ] }
@@ -190,10 +216,10 @@ M: object infer-call*
     "local-word-def" word-prop infer-quot-here ;
 
 {
-    >r r> declare call (call) slip 2slip 3slip curry compose
-    execute (execute) if dispatch <tuple-boa> (throw)
-    load-locals get-local drop-locals do-primitive alien-invoke
-    alien-indirect alien-callback
+    >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
+    curry compose execute (execute) if dispatch <tuple-boa>
+    (throw) load-locals get-local drop-locals do-primitive
+    alien-invoke alien-indirect alien-callback
 } [ t "special" set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }

basis/stack-checker/state/state.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs arrays namespaces sequences kernel definitions
 math effects accessors words fry classes.algebra
-compiler.units ;
+compiler.units stack-checker.values stack-checker.visitor ;
 IN: stack-checker.state
 
 ! Did the current control-flow path throw an error?
@@ -11,23 +11,40 @@ SYMBOL: terminated?
 ! Number of inputs current word expects from the stack
 SYMBOL: d-in
 
+DEFER: commit-literals
+
 ! Compile-time data stack
-SYMBOL: meta-d
+: meta-d ( -- stack ) commit-literals \ meta-d get ;
 
 ! Compile-time retain stack
-SYMBOL: meta-r
+: meta-r ( -- stack ) \ meta-r get ;
 
-: current-stack-height ( -- n ) meta-d get length d-in get - ;
+! Uncommitted literals. This is a form of local dead-code
+! elimination; the goal is to reduce the number of IR nodes
+! which get constructed. Technically it is redundant since
+! we do global DCE later, but it speeds up compile time.
+SYMBOL: literals
+
+: (push-literal) ( obj -- )
+    dup <literal> make-known
+    [ nip \ meta-d get push ] [ #push, ] 2bi ;
+
+: commit-literals ( -- )
+    literals get [
+        [ [ (push-literal) ] each ] [ delete-all ] bi
+    ] unless-empty ;
+
+: current-stack-height ( -- n ) meta-d length d-in get - ;
 
 : current-effect ( -- effect )
     d-in get
-    meta-d get length <effect>
+    meta-d length <effect>
     terminated? get >>terminated? ;
 
 : init-inference ( -- )
     terminated? off
-    V{ } clone meta-d set
-    V{ } clone meta-r set
+    V{ } clone \ meta-d set
+    V{ } clone literals set
     0 d-in set ;
 
 ! Words that the current quotation depends on

basis/stack-checker/transforms/transforms.factor

@@ -19,11 +19,8 @@ IN: stack-checker.transforms
     rot with-datastack first2
     dup [
         [
-            [ drop ] [
-                [ length meta-d get '[ _ pop* ] times ]
-                [ #drop, ]
-                bi
-            ] bi*
+            [ drop ]
+            [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
         ] 2dip
         swap infer-quot
     ] [

core/kernel/kernel.factor

@@ -52,7 +52,9 @@ DEFER: if
 : ?if ( default cond true false -- )
     pick [ roll 2drop call ] [ 2nip call ] if ; inline
 
-! Slippers
+! Slippers and dippers.
+! Not declared inline because the compiler special-cases them
+
 : slip ( quot x -- x )
     #! 'slip' and 'dip' can be defined in terms of each other
     #! because the JIT special-cases a 'dip' preceeded by
@@ -71,11 +73,11 @@ DEFER: if
     #! a literal quotation.
     [ call ] 3dip ;
 
-: dip ( x quot -- x ) swap slip ; inline
+: dip ( x quot -- x ) swap slip ;
 
-: 2dip ( x y quot -- x y ) -rot 2slip ; inline
+: 2dip ( x y quot -- x y ) -rot 2slip ;
 
-: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
+: 3dip ( x y z quot -- x y z ) -roll 3slip ;
 
 ! Keepers
 : keep ( x quot -- x ) over slip ; inline