diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index cc6b4d1e81..b6c2f64efb 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -80,9 +80,9 @@ nl malloc calloc free memcpy } compile-uncompiled -{ - build-tree optimize-tree -} compile-uncompiled +{ build-tree } compile-uncompiled + +{ optimize-tree } compile-uncompiled vocabs [ words compile-uncompiled "." write flush ] each diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index f54ec441b0..4d826c40d2 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ; %jump-label ; : generate-call ( label -- next ) - dup maybe-compile + ! dup maybe-compile end-basic-block dup compiling-loops get at [ %jump-label f @@ -232,7 +232,7 @@ M: #dispatch generate-node ] if ; M: #call generate-node - ! dup node-input-infos [ class>> ] map set-operand-classes + dup node-input-infos [ class>> ] map set-operand-classes dup find-if-intrinsic [ do-if-intrinsic ] [ diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index b36eddfece..d94ae1b247 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -20,47 +20,49 @@ M: #phi compute-live-values* [ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ] 2bi ; +SYMBOL: if-node + M: #branch remove-dead-code* - [ [ (remove-dead-code) ] map ] change-children ; + [ [ [ (remove-dead-code) ] map ] change-children ] + [ if-node set ] + bi ; : remove-phi-inputs ( #phi -- ) dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r drop ; -! SYMBOL: if-node -! -! : dead-value-indices ( values -- indices ) -! [ length ] keep live-values get -! '[ , nth , key? not ] filter ; inline -! -! : drop-d-values ( values indices -- node ) -! [ drop filter-live ] [ nths filter-live ] 2bi -! [ make-values ] keep -! [ drop ] [ zip ] 2bi -! #shuffle ; -! -! : drop-r-values ( values indices -- nodes ) +: live-value-indices ( values -- indices ) + [ length ] keep live-values get + '[ , nth , key? ] filter ; inline + +: drop-d-values ( values indices -- node ) + [ drop filter-live ] [ nths ] 2bi + [ make-values ] keep + [ drop ] [ zip ] 2bi + #shuffle ; + +: drop-r-values ( values indices -- nodes ) 2drop f ; ! [ dup make-values [ #r> ] keep ] dip ! drop-d-values dup out-d>> dup make-values #>r ! 3array ; -! -! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' ) -! '[ -! [ , drop-d-values 1array ] -! [ , drop-r-values ] -! bi* 3append -! ] 3map ; -! -! : hoist-drops ( #phi -- ) -! if-node get swap -! { -! [ phi-in-d>> ] -! [ phi-in-r>> ] -! [ out-d>> dead-value-indices ] -! [ out-r>> dead-value-indices ] -! } cleave -! '[ , , , , insert-drops ] change-children drop ; + +: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' ) + '[ + [ , drop-d-values 1array ] + [ , drop-r-values ] + bi* 3append + ] 3map ; + +: hoist-drops ( #phi -- ) + if-node get swap + { + [ phi-in-d>> ] + [ phi-in-r>> ] + [ out-d>> live-value-indices ] + [ out-r>> live-value-indices ] + } cleave + '[ , , , , insert-drops ] change-children drop ; : remove-phi-outputs ( #phi -- ) [ filter-live ] change-out-d @@ -69,7 +71,7 @@ M: #branch remove-dead-code* M: #phi remove-dead-code* { - ! [ hoist-drops ] + [ hoist-drops ] [ remove-phi-inputs ] [ remove-phi-outputs ] [ ] diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index d587ae70f2..14e66fa648 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -4,7 +4,8 @@ compiler.tree.combinators compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis compiler.tree.tuple-unboxing compiler.tree.debugger compiler.tree.normalization compiler.tree.checker tools.test -kernel math stack-checker.state accessors combinators io ; +kernel math stack-checker.state accessors combinators io +prettyprint ; IN: compiler.tree.dead-code.tests \ remove-dead-code must-infer @@ -96,9 +97,4 @@ IN: compiler.tree.dead-code.tests [ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test -: non-flushable-4 ( a -- b ) drop f ; - -: recursive-test-1 ( a b -- ) - dup 10 < [ - >r drop 5 non-flushable-4 r> 1 + recursive-test-1 - ] [ 2drop ] if ; inline recursive +[ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 532c5a9ac3..7b0f03e13d 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup compiler.tree.combinators compiler.tree sequences math math.private kernel tools.test accessors slots.private quotations.private prettyprint classes.tuple.private classes classes.tuple -compiler.tree.intrinsics ; +compiler.tree.intrinsics namespaces ; \ escape-analysis must-infer @@ -295,3 +295,13 @@ C: ro-box [ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test + +[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test + +: impeach-node ( quot: ( node -- ) -- ) + dup slip impeach-node ; inline recursive + +: bleach-node ( quot: ( node -- ) -- ) + [ bleach-node ] curry [ ] compose impeach-node ; inline recursive + +[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index 0edcd6c46c..f95d17dd1d 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -59,10 +59,10 @@ M: #push escape-analysis* ] [ 2drop f ] if ; : record-slot-call ( #call -- ) - [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri - over [ - [ record-slot-access ] [ copy-slot-value ] 3bi - ] [ 2drop unknown-allocation ] if ; + [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over + [ [ record-slot-access ] [ copy-slot-value ] 3bi ] + [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ] + if ; M: #call escape-analysis* dup word>> { @@ -88,3 +88,5 @@ M: #alien-indirect escape-analysis* [ in-d>> add-escaping-values ] [ out-d>> unknown-allocations ] bi ; + +M: #alien-callback escape-analysis* drop ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 691795efdb..6e191157b0 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -21,10 +21,10 @@ IN: compiler.tree.optimizer detect-loops ! invert-loops ! fuse-branches - ! escape-analysis - ! unbox-tuples - ! compute-def-use - ! remove-dead-code + escape-analysis + unbox-tuples + compute-def-use + remove-dead-code ! strength-reduce compute-def-use USE: kernel dup check-nodes ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 14a9427dd1..6b266c4ea8 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -52,7 +52,6 @@ IN: compiler.tree.propagation.recursive 3bi ; M: #recursive propagate-around ( #recursive -- ) - "blah" USE: io print { 0 } clone [ USE: math dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if constraints [ clone ] change diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 0dd8f3e3de..8135572bb1 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -37,3 +37,12 @@ TUPLE: empty-tuple ; [ [ <=> ] sort ] [ [ <=> ] with search ] } [ [ ] swap [ test-unboxing ] curry unit-test ] each + +! A more complicated example +: impeach-node ( quot: ( node -- ) -- ) + dup slip impeach-node ; inline recursive + +: bleach-node ( quot: ( node -- ) -- ) + [ bleach-node ] curry [ ] compose impeach-node ; inline recursive + +[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index bc5e74b6d7..da89123a4b 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -58,9 +58,11 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox-slot-access ( #call -- nodes ) dup out-d>> first unboxed-slot-access? [ - [ in-d>> second 1array #drop ] - [ prepare-slot-access slot-access-shuffle ] - bi 2array + ! [ in-d>> second 1array #drop ] + ! [ + prepare-slot-access slot-access-shuffle + ! ] + ! bi 2array ] when ; M: #call unbox-tuples* @@ -133,4 +135,6 @@ M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ; M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ; +M: #alien-callback unbox-tuples* ; + : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ; diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor index 90d70f6754..093d231d08 100644 --- a/basis/debugger/threads/threads.factor +++ b/basis/debugger/threads/threads.factor @@ -20,3 +20,6 @@ M: thread error-in-thread ( error thread -- ) error-thread get-global error-in-thread. print-error flush ] bind ] if ; + +[ self error-in-thread stop ] +thread-error-hook set-global diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index c406d0db12..2ff2912d6f 100755 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -223,9 +223,6 @@ GENERIC: error-in-thread ( error thread -- ) dup register-thread set-self ; -[ self error-in-thread stop ] -thread-error-hook set-global - PRIVATE> [ init-threads ] "threads" add-init-hook