diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..6d21504f8b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -74,6 +74,12 @@ nl malloc free memcpy } compile -[ compiled-usages recompile ] recompile-hook set-global +: enable-compiler ( -- ) + [ compiled-usages recompile ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ; + +enable-compiler " done" print flush diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 71c95b1b61..137d86b489 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -1,7 +1,7 @@ IN: temporary USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private -words splitting ; +words splitting sorting ; : symbolic-stack-trace ( -- newseq ) error-continuation get continuation-call callstack>array @@ -31,9 +31,9 @@ words splitting ; \ > stack-trace-contains? ] unit-test -: quux [ t [ "hi" throw ] when ] times ; +: quux { 1 2 3 } [ "hi" throw ] sort ; [ t ] [ [ 10 quux ] ignore-errors - \ (each-integer) stack-trace-contains? + \ sort stack-trace-contains? ] unit-test diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index e518d2de8a..13d834a489 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ; [ [ ] [ init-templates ] unit-test - [ ] [ init-generator ] unit-test + H{ } clone compiled set + + [ ] [ gensym gensym begin-compiling ] unit-test [ t ] [ [ end-basic-block ] { } make empty? ] unit-test diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 58094f584f..9bca648b08 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ; PREDICATE: #values #tail-values node-successor #tail? ; UNION: #tail - POSTPONE: f #return #tail-values #tail-merge ; + POSTPONE: f #return #tail-values #tail-merge #terminate ; : tail-call? ( -- ? ) node-stack get [ node-successor #tail? ] all? ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 1ae3b4388c..a8645787a1 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -68,8 +68,6 @@ DEFER: optimize-nodes ] if ] when ; -M: f set-node-successor 2drop ; - : optimize-nodes ( node -- newnode ) [ class-substitutions [ clone ] change @@ -81,16 +79,7 @@ M: f set-node-successor 2drop ; ! Generic nodes M: node optimize-node* drop t f ; -: cleanup-inlining ( node -- newnode changed? ) - node-successor [ node-successor t ] [ t f ] if* ; - -! #return -M: #return optimize-node* cleanup-inlining ; - -! #values -M: #values optimize-node* cleanup-inlining ; - -! Some utilities for splicing in dataflow IR subtrees +! Post-inlining cleanup : follow ( key assoc -- value ) 2dup at* [ swap follow nip ] [ 2drop ] if ; @@ -103,32 +92,31 @@ M: #values optimize-node* cleanup-inlining ; #! Not very efficient. dupd union* update ; -: post-inline ( #call/#merge #return/#values -- assoc ) - >r node-out-d r> node-in-d 2array unify-lengths flip +: compute-value-substitutions ( #return/#values #call/#merge -- assoc ) + node-out-d swap node-in-d 2array unify-lengths flip [ = not ] assoc-subset >hashtable ; -: substitute-def-use ( node -- ) - #! As a first approximation, we take all the values used - #! by the set of new nodes, and push a 't' on their - #! def-use list here. We could perform a full graph - #! substitution, but we don't need to, because the next - #! optimizer iteration will do that. We just need a minimal - #! degree of accuracy; the new values should be marked as - #! having _some_ usage, so that flushing doesn't erronously - #! flush them away. - [ compute-def-use def-use get keys ] with-scope - def-use get [ [ t swap ?push ] change-at ] curry each ; +: cleanup-inlining ( #return/#values -- newnode changed? ) + dup node-successor dup [ + class-substitutions get pick node-classes update + literal-substitutions get pick node-literals update + tuck compute-value-substitutions value-substitutions get swap update* + node-successor t + ] [ + 2drop t f + ] if ; -: substitute-node ( old new -- ) - #! The last node of 'new' becomes 'old', then values are - #! substituted. A subsequent optimizer phase kills the - #! last node of 'new' and the first node of 'old'. - dup substitute-def-use - last-node - class-substitutions get over node-classes update - literal-substitutions get over node-literals update - 2dup post-inline value-substitutions get swap update* - set-node-successor ; +! #return +M: #return optimize-node* cleanup-inlining ; + +! #values +M: #values optimize-node* cleanup-inlining ; + +! Some utilities for splicing in dataflow IR subtrees +M: f set-node-successor 2drop ; + +: splice-node ( old new -- ) + dup splice-def-use last-node set-node-successor ; GENERIC: remember-method* ( method-spec node -- ) @@ -148,12 +136,12 @@ M: node remember-method* pick node-in-d dataflow-with [ remember-method ] keep [ swap infer-classes/node ] 2keep - [ substitute-node ] keep ; + [ splice-node ] keep ; : splice-quot ( #call quot -- node ) over node-in-d dataflow-with [ swap infer-classes/node ] 2keep - [ substitute-node ] keep ; + [ splice-node ] keep ; : drop-inputs ( node -- #shuffle ) node-in-d clone \ #shuffle in-node ; @@ -161,7 +149,7 @@ M: node remember-method* ! Constant branch folding : fold-branch ( node branch# -- node ) over node-children nth - swap node-successor over substitute-node ; + swap node-successor over splice-node ; ! #if : known-boolean-value? ( node value -- value ? ) @@ -176,23 +164,124 @@ M: node remember-method* } cond ] if ; +: fold-if-branch? dup node-in-d first known-boolean-value? ; + +: fold-if-branch ( node value -- node' ) + over drop-inputs >r + 0 1 ? fold-branch + r> [ set-node-successor ] keep ; + +: only-one ( seq -- elt/f ) + dup length 1 = [ first ] [ drop f ] if ; + +: lift-throw-tail? ( #if -- tail/? ) + dup node-successor node-successor + [ active-children only-one ] [ drop f ] if ; + +: clone-node ( node -- newnode ) + clone dup [ clone ] modify-values ; + +: detach-node-successor ( node -- successor ) + dup node-successor #terminate rot set-node-successor ; + +: lift-branch ( #if node -- ) + >r detach-node-successor r> splice-node ; + M: #if optimize-node* - dup dup node-in-d first known-boolean-value? [ - over drop-inputs >r - 0 1 ? fold-branch - r> [ set-node-successor ] keep - t - ] [ 2drop t f ] if ; + dup fold-if-branch? [ fold-if-branch t ] [ + 2drop t f + ! drop dup lift-throw-tail? dup [ + ! dupd lift-branch t + ! ] [ + ! 2drop t f + ! ] if + ] if ; + +: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; + +: fold-dispatch-branch ( node value -- node' ) + dupd node-literal + over drop-inputs >r fold-branch r> + [ set-node-successor ] keep ; M: #dispatch optimize-node* - dup dup node-in-d first 2dup node-literal? [ - "Optimizing #dispatch" print - node-literal - over drop-inputs >r fold-branch r> [ set-node-successor ] keep t + dup fold-dispatch-branch? [ + fold-dispatch-branch t ] [ - 3drop t f + 2drop t f ] if ; +! #loop + + +! BEFORE: + +! #label -> C -> #return 1 +! | +! -> #if -> #merge -> #return 2 +! | +! -------- +! | | +! A B +! | | +! #values | +! #call-label +! | +! | +! #values + +! AFTER: + +! #label -> #terminate +! | +! -> #if -> #terminate +! | +! -------- +! | | +! A B +! | | +! #values | +! | #call-label +! #merge | +! | | +! C #values +! | +! #return 1 + +: find-final-if ( node -- #if/f ) + dup [ + dup #if? [ + dup node-successor #tail? [ + node-successor find-final-if + ] unless + ] [ + node-successor find-final-if + ] if + ] when ; + +: lift-loop-tail? ( #label -- tail/f ) + dup node-successor node-successor [ + dup node-param swap node-child find-final-if dup [ + node-children [ penultimate-node ] map + [ + dup #call-label? + [ node-param eq? not ] [ 2drop t ] if + ] with subset only-one + ] [ 2drop f ] if + ] [ drop f ] if ; + +! M: #loop optimize-node* +! dup lift-loop-tail? dup [ +! last-node >r +! dup detach-node-successor +! over node-child find-final-if detach-node-successor +! [ set-node-successor ] keep +! r> set-node-successor +! t +! ] [ +! 2drop t f +! ] if ; + ! #call : splice-method ( #call method-spec/t quot/t -- node/t ) #! t indicates failure diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index 9355b2bb70..df5c1e0aa4 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -70,20 +70,6 @@ M: #branch node-def-use #! #values node. dup branch-def-use (node-def-use) ; -! : dead-literals ( -- values ) -! def-use get [ >r value? r> empty? and ] assoc-subset ; -! -! : kill-node* ( node values -- ) -! [ swap remove-all ] curry modify-values ; -! -! : kill-node ( node values -- ) -! dup assoc-empty? -! [ 2drop ] [ [ kill-node* ] curry each-node ] if ; -! -! : kill-values ( node -- ) -! #! Remove literals which are not actually used anywhere. -! dead-literals kill-node ; - : compute-dead-literals ( -- values ) def-use get [ >r value? r> empty? and ] assoc-subset ; @@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; dead-literals [ kill-nodes ] with-variable ] if ; -! - : sole-consumer ( #call -- node/f ) node-out-d first used-by dup length 1 = [ first ] [ drop f ] if ; + +: splice-def-use ( node -- ) + #! As a first approximation, we take all the values used + #! by the set of new nodes, and push a 't' on their + #! def-use list here. We could perform a full graph + #! substitution, but we don't need to, because the next + #! optimizer iteration will do that. We just need a minimal + #! degree of accuracy; the new values should be marked as + #! having _some_ usage, so that flushing doesn't erronously + #! flush them away. + [ compute-def-use def-use get keys ] with-scope + def-use get [ [ t swap ?push ] change-at ] curry each ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 8b05af691d..a699bb0cb3 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -12,7 +12,7 @@ IN: optimizer H{ } clone value-substitutions set dup compute-def-use kill-values - ! dup detect-loops + dup detect-loops dup infer-classes optimizer-changed off optimize-nodes diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index a4f5aaab95..10a9fda3ea 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -24,7 +24,7 @@ IN: optimizer.specializers \ dispatch , ] [ ] make ; -: specializer-methods ( word -- alist ) +: specializer-methods ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep [ declare ] curry pick append diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor old mode 100644 new mode 100755 index 46ff9a1ada..d453ee60ca --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -8,7 +8,7 @@ IN: benchmark : run-benchmark ( vocab -- result ) "=== Benchmark " write dup print flush dup require - [ [ run ] benchmark ] [ error. f f ] recover 2array + [ [ run ] benchmark ] [ error. drop f f ] recover 2array dup . ; : run-benchmarks ( -- assoc ) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 729281e81b..ebf14417c0 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -95,14 +95,18 @@ M: #dispatch node>quot node-children swap [ dataflow>quot ] curry map , \ dispatch , ; -M: #return node>quot - dup node-param unparse "#return " swap append comment, ; - M: #>r node>quot nip node-in-d length \ >r % ; M: #r> node>quot nip node-out-d length \ r> % ; -M: object node>quot dup class word-name comment, ; +M: object node>quot + [ + dup class word-name % + " " % + dup node-param unparse % + " " % + dup effect-str % + ] "" make comment, ; : (dataflow>quot) ( ? node -- ) dup [