diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 9f9a6e8e92..fd18dcafce 100755 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors -compiler.tree.builder compiler.tree.optimizer ; +compiler.tree.builder compiler.tree.optimizer sequences.deep ; IN: optimizer.tests GENERIC: xyz ( obj -- obj ) @@ -353,3 +353,8 @@ TUPLE: some-tuple x ; [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test + +: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ; + +[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test +[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2c667eaceb..2f21777801 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 9feb931c03..49832bcac0 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sequences.deep combinators fry -classes.algebra namespaces assocs math math.private -math.partial-dispatch classes.tuple classes.tuple.private +classes.algebra namespaces assocs words math math.private +math.partial-dispatch classes classes.tuple classes.tuple.private definitions stack-checker.state stack-checker.branches compiler.tree compiler.tree.intrinsics diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 4c04ec3917..338f397f66 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests [ [ drop ] ] [ [ { integer } declare f drop ] optimize-quot ] unit-test [ [ f drop ] ] [ [ f drop ] optimize-quot ] unit-test + +: call-recursive-dce-7 ( obj -- elt ? ) + dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive + +[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 4c6b411430..03d4e919ee 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values* #! corresponding inputs to the #call-recursive are live also. [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ; -: return-recursive-phi-in ( #return-recursive -- phi-in ) - [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; - M: #return-recursive compute-live-values* - [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ; + [ out-d>> ] [ in-d>> ] bi look-at-mapping ; M: #call-recursive compute-live-values* #! If the output of a #call-recursive is live, then the @@ -34,15 +31,6 @@ M: #call-recursive compute-live-values* drop-values ] ; -M: #recursive remove-dead-code* ( node -- nodes ) - dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs - { - [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ] - [ drop [ (remove-dead-code) ] change-child drop ] - [ drop label>> [ filter-live ] change-enter-out drop ] - [ swap 2array ] - } 2cleave ; - M: #enter-recursive remove-dead-code* [ filter-live ] change-out-d ; @@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code* [ drop-call-recursive-outputs ] tri 3array ; -M: #return-recursive remove-dead-code* ( node -- nodes ) - dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs - [ drop [ filter-live ] change-out-d drop ] - [ out-d>> >>in-d drop ] - [ swap 2array ] - 2tri ; +:: drop-recursive-inputs ( node -- shuffle ) + [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ] + new-outputs [ shuffle out-d>> ] | + node new-outputs + [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi + shuffle + ] ; + +:: drop-recursive-outputs ( node -- shuffle ) + [let* | return [ node label>> return>> ] + new-inputs [ return in-d>> filter-live ] + new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] | + return + [ new-inputs >>in-d new-outputs >>out-d drop ] + [ drop-dead-outputs ] + bi + ] ; + +M:: #recursive remove-dead-code* ( node -- nodes ) + [let* | drop-inputs [ node drop-recursive-inputs ] + drop-outputs [ node drop-recursive-outputs ] | + node [ (remove-dead-code) ] change-child drop + node label>> [ filter-live ] change-enter-out drop + drop-inputs node drop-outputs 3array + ] ; + +M: #return-recursive remove-dead-code* ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index f1be869295..2bcf91e6ab 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors words assocs sequences arrays namespaces -fry locals classes.algebra stack-checker.backend +fry locals definitions classes.algebra +stack-checker.state +stack-checker.backend compiler.tree compiler.tree.propagation.info compiler.tree.dead-code.liveness ; @@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; ] ; : drop-dead-outputs ( node -- nodes ) - dup out-d>> drop-dead-values - [ in-d>> >>out-d drop ] [ 2array ] 2bi ; + dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ; M: #introduce remove-dead-code* ( #introduce -- nodes ) - drop-dead-outputs ; + dup drop-dead-outputs 2array ; M: #>r remove-dead-code* [ filter-live ] change-out-r @@ -105,7 +106,9 @@ M: #push remove-dead-code* ] [ drop f ] if ; : remove-flushable-call ( #call -- node ) - in-d>> #drop remove-dead-code* ; + [ word>> +inlined+ depends-on ] + [ in-d>> #drop remove-dead-code* ] + bi ; : some-outputs-dead? ( #call -- ? ) out-d>> [ live-value? not ] contains? ; @@ -115,7 +118,7 @@ M: #call remove-dead-code* remove-flushable-call ] [ dup some-outputs-dead? [ - drop-dead-outputs + dup drop-dead-outputs 2array ] when ] if ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b30800b445..e01d12ac23 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -125,21 +125,20 @@ SYMBOL: history : remember-inlining ( word -- ) history [ swap suffix ] change ; -: inline-word ( #call word -- ) +: inline-word ( #call word -- ? ) dup history get memq? [ - 2drop + 2drop f ] [ [ dup remember-inlining dupd def>> splicing-nodes >>body propagate-body ] with-scope + t ] if ; : inline-method-body ( #call word -- ? ) - 2dup should-inline? [ inline-word t ] [ 2drop f ] if ; + 2dup should-inline? [ inline-word ] [ 2drop f ] if ; : always-inline-word? ( word -- ? ) { curry compose } memq? ; - -: always-inline-word ( #call word -- ? ) inline-word t ; diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 528829ff4d..48a4b478e6 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -93,7 +93,7 @@ M: #declare propagate-before : do-inlining ( #call word -- ? ) { - { [ dup always-inline-word? ] [ always-inline-word ] } + { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index e373d36124..6523598cff 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -67,8 +67,10 @@ SYMBOL: enter-out [ entry-stack-height current-stack-height swap - ] bi* = [ 2drop ] [ - word>> current-stack-height - unbalanced-recursion-error inference-error + terminated? get [ 2drop ] [ + word>> current-stack-height + unbalanced-recursion-error inference-error + ] if ] if ; : end-recursive-word ( word label -- ) @@ -79,7 +81,7 @@ SYMBOL: enter-out : recursive-word-inputs ( label -- n ) entry-stack-height d-in get + ; -: (inline-recursive-word) ( word -- label in out visitor ) +: (inline-recursive-word) ( word -- label in out visitor terminated? ) dup prepare-stack [ init-inference @@ -96,11 +98,13 @@ SYMBOL: enter-out dup recursive-word-inputs meta-d get stack-visitor get + terminated? get ] with-scope ; : inline-recursive-word ( word -- ) (inline-recursive-word) - [ consume-d ] [ output-d ] [ ] tri* #recursive, ; + [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip + [ terminate ] when ; : check-call-height ( label -- ) dup entry-stack-height current-stack-height > diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index b78e1b5729..dc049ee1a4 100755 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -575,3 +575,8 @@ DEFER: eee' : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive [ [ eee' ] infer ] [ inference-error? ] must-fail-with + +: bogus-error ( x -- ) + dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive + +[ bogus-error ] must-infer diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index 2550c992b9..ee5a5113bf 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -88,8 +88,7 @@ SYMBOL: prolog-data : next* ( -- ) get-char [ (next) record ] when ; -: skip-until ( quot -- ) - #! quot: ( -- ? ) +: skip-until ( quot: ( -- ? ) -- ) get-char [ [ call ] keep swap [ drop ] [ next skip-until diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index f6ca9184b2..9a372e633e 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 [ ] [ "IN: classes.mixin.tests MIXIN: blah" "mixin-reset-test" parse-stream drop ] unit-test [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test + +MIXIN: empty-mixin + +[ f ] [ "hi" empty-mixin? ] unit-test diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a08d4ed20c..56ab6d37f1 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ; dup mixin-class? [ drop ] [ - { } redefine-mixin-class + [ { } redefine-mixin-class ] + [ update-classes ] + bi ] if ; TUPLE: check-mixin-class mixin ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4ff9d4c674..4482eb8131 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -270,6 +270,9 @@ M: tuple-class define-tuple-class tri* define-declared ] 3tri ; +M: tuple-class update-generic + over new-class? [ 2drop ] [ call-next-method ] if ; + M: tuple-class reset-class [ dup "slots" word-prop [ diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 70d406a39b..ff81b5ded3 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -62,7 +62,9 @@ TUPLE: check-method class generic ; [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter values ; -: update-generic ( class generic -- ) +GENERIC# update-generic 1 ( class generic -- ) + +M: class update-generic affected-methods [ +called+ changed-definition ] each ; : with-methods ( class generic quot -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 502d4c1eba..c3742786b2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -24,7 +24,7 @@ t parser-notes set-global : note. ( str -- ) parser-notes? [ - file get [ path>> write ] when* + file get [ path>> write ":" write ] when* lexer get line>> number>string write ": " write "Note: " write dup print ] when drop ;