diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index b6c2f64efb..0b44761f5c 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -5,8 +5,9 @@ sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io -io.encodings.string prettyprint libc compiler.units math.order -compiler.tree.builder compiler.tree.optimizer ; +io.encodings.string prettyprint libc splitting math.parser +compiler.units math.order compiler.tree.builder +compiler.tree.optimizer ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a @@ -71,13 +72,21 @@ nl "." write flush { - . lines + memq? split harvest sift cut cut-slice start index clone + set-at reverse push-all class number>string string>number } compile-uncompiled "." write flush { - malloc calloc free memcpy + lines prefix suffix unclip new-assoc update + word-prop set-word-prop 1array 2array 3array ?nth +} compile-uncompiled + +"." write flush + +{ + . malloc calloc free memcpy } compile-uncompiled { build-tree } compile-uncompiled diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 5cc2b727df..94c5f05887 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings arrays assocs combinators compiler kernel math namespaces parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros -memoize debugger io.encodings.ascii effects ; +memoize debugger io.encodings.ascii effects compiler.generator ; IN: cocoa.messages : make-sender ( method function -- quot ) diff --git a/basis/columns/columns-docs.factor b/basis/columns/columns-docs.factor index e0d4e4a2e0..818ce2f752 100644 --- a/basis/columns/columns-docs.factor +++ b/basis/columns/columns-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "columns" "Column sequences" { $subsection column } { $subsection } "A utility word:" -{ $subsection flipped } ; +{ $subsection } ; HELP: column { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2a274ef457..7480c13339 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -46,7 +46,6 @@ SYMBOL: +failed+ ] tri ; : (compile) ( word -- ) - USE: prettyprint dup . '[ H{ } clone dependencies set diff --git a/basis/compiler/generator/fixup/fixup-docs.factor b/basis/compiler/generator/fixup/fixup-docs.factor index a4ff549e8e..a119d153e6 100644 --- a/basis/compiler/generator/fixup/fixup-docs.factor +++ b/basis/compiler/generator/fixup/fixup-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup math kernel -words strings alien ; +words strings alien compiler.generator ; IN: compiler.generator.fixup HELP: frame-required @@ -14,3 +14,6 @@ HELP: rel-dlsym { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } } { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats." } ; + +HELP: literal-table +{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ; diff --git a/basis/compiler/generator/generator-docs.factor b/basis/compiler/generator/generator-docs.factor index e00b8d5b28..53bc031ad0 100755 --- a/basis/compiler/generator/generator-docs.factor +++ b/basis/compiler/generator/generator-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax words debugger generator.fixup -generator.registers quotations kernel vectors arrays effects -sequences ; +USING: help.markup help.syntax words debugger +compiler.generator.fixup compiler.generator.registers quotations +kernel vectors arrays effects sequences ; IN: compiler.generator ARTICLE: "generator" "Compiled code generator" @@ -31,9 +31,6 @@ HELP: compiled-stack-traces? { $values { "?" "a boolean" } } { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ; -HELP: literal-table -{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ; - HELP: begin-compiling { $values { "word" word } { "label" word } } { $description "Prepares to generate machine code for a word." } ; diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 4d826c40d2..0897424472 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 @@ -255,13 +255,13 @@ M: #shuffle generate-node shuffle-effect phantom-shuffle iterate-next ; M: #>r generate-node - in-d>> length - phantom->r + [ in-d>> length ] [ out-r>> empty? ] bi + [ phantom-drop ] [ phantom->r ] if iterate-next ; M: #r> generate-node - out-d>> length - phantom-r> + [ in-r>> length ] [ out-d>> empty? ] bi + [ phantom-rdrop ] [ phantom-r> ] if iterate-next ; ! #return diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index 064f027531..41753433de 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -658,3 +658,9 @@ UNION: immediate fixnum POSTPONE: f ; : phantom-r> ( n -- ) phantom-retainstack get phantom-input phantom-datastack get phantom-append ; + +: phantom-drop ( n -- ) + phantom-datastack get phantom-input drop ; + +: phantom-rdrop ( n -- ) + phantom-retainstack get phantom-input drop ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 58e31a8cf5..632412a6af 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -31,9 +31,12 @@ M: #shuffle check-node* M: #copy check-node* inputs/outputs 2array check-lengths ; -M: #>r check-node* inputs/outputs 2array check-lengths ; +: check->r/r> ( node -- ) + inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ; -M: #r> check-node* inputs/outputs 2array check-lengths ; +M: #>r check-node* check->r/r> ; + +M: #r> check-node* check->r/r> ; M: #return-recursive check-node* inputs/outputs 2array check-lengths ; @@ -43,9 +46,10 @@ M: #phi check-node* bi ; M: #enter-recursive check-node* + [ [ label>> enter-out>> ] [ out-d>> ] bi assert= ] [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ] [ recursive-phi-in check-lengths ] - bi ; + tri ; M: #push check-node* out-d>> length 1 = [ "Bad #push" throw ] unless ; @@ -72,7 +76,7 @@ SYMBOL: terminated? GENERIC: check-stack-flow* ( node -- ) : (check-stack-flow) ( nodes -- ) - [ check-stack-flow* ] each ; + [ check-stack-flow* terminated? get not ] all? drop ; : init-stack-flow ( -- ) V{ } clone datastack set @@ -164,31 +168,27 @@ M: #branch check-stack-flow* : check-phi-in ( #phi -- ) phi-in-d>> branch-out get [ - over [ +bottom+ eq? ] all? [ - 2drop - ] [ + dup [ over length tail* sequence= [ "Branch outputs don't match phi inputs" throw ] unless + ] [ + 2drop ] if ] 2each ; : set-phi-datastack ( #phi -- ) phi-in-d>> first length - branch-out get [ ] find nip - dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ; + branch-out get [ ] find nip swap head* >vector datastack set ; M: #phi check-stack-flow* - [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ; + branch-out get [ ] contains? [ + [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri + ] [ drop terminated? on ] if ; M: #recursive check-stack-flow* - [ - init-stack-flow - child>> (check-stack-flow) - datastack get - ] with-scope - datastack set ; + [ check-in-d ] [ child>> (check-stack-flow) ] bi ; M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 9a40d3a4f6..e969d098c7 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -443,3 +443,11 @@ cell-bits 32 = [ [ ] [ [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop ] unit-test + +[ ] [ + [ + [ "X" throw ] + [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ] + if + ] cleaned-up-tree drop +] unit-test diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 5e2eb2c38d..670634e752 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -5,7 +5,7 @@ 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 -prettyprint ; +prettyprint words sequences.deep sequences.private ; IN: compiler.tree.dead-code.tests \ remove-dead-code must-infer @@ -106,3 +106,70 @@ IN: compiler.tree.dead-code.tests : boo ( a b -- c ) 2drop f ; [ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test + +: squish ( quot -- quot' ) + [ + { + { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] } + { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] } + [ ] + } cond + ] deep-map ; + +: call-recursive-dce-1 ( a -- b ) + [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive + +[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [ + [ call-recursive-dce-1 ] optimize-quot squish +] unit-test + +: produce-a-value ( -- a ) f ; + +: call-recursive-dce-2 ( a -- b ) + drop + produce-a-value dup . call-recursive-dce-2 ; inline recursive + +[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [ + [ f call-recursive-dce-2 drop ] optimize-quot squish +] unit-test + +[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [ + [ f call-recursive-dce-2 ] optimize-quot squish +] unit-test + +: call-recursive-dce-3 ( a -- ) + call-recursive-dce-3 ; inline recursive + +[ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [ + [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish +] unit-test + +[ [ drop "WRAP" [ "REC" ] label ] ] [ + [ call-recursive-dce-3 ] optimize-quot squish +] unit-test + +: call-recursive-dce-4 ( a -- b ) + call-recursive-dce-4 ; inline recursive + +[ [ "WRAP" [ "REC" ] label ] ] [ + [ call-recursive-dce-4 ] optimize-quot squish +] unit-test + +[ [ drop "WRAP" [ "REC" ] label ] ] [ + [ call-recursive-dce-4 drop ] optimize-quot squish +] unit-test + +[ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test + +: call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive + +[ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test + +[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test + +: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i ) + dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive + +[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test + +[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] 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 28c65969e3..022912ff4e 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -1,12 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences kernel -compiler.tree compiler.tree.dead-code.branches +USING: accessors arrays assocs sequences kernel locals fry +combinators stack-checker.backend +compiler.tree +compiler.tree.dead-code.branches compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ; IN: compiler.tree.dead-code.recursive M: #enter-recursive compute-live-values* + #! If the output of an #enter-recursive is live, then the + #! 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 ) @@ -16,22 +20,60 @@ M: #return-recursive compute-live-values* [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ; M: #call-recursive compute-live-values* - #! If the output of a copy is live, then the corresponding - #! inputs to #return nodes are live also. + #! If the output of a #call-recursive is live, then the + #! corresponding inputs to #return nodes are live also. [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ; -M: #recursive remove-dead-code* - [ filter-live ] change-in-d - [ (remove-dead-code) ] change-child ; +:: drop-dead-inputs ( inputs outputs -- #shuffle ) + [let* | new-inputs [ inputs make-values ] + live-inputs [ outputs inputs filter-corresponding ] + new-live-inputs [ outputs new-inputs filter-corresponding ] + mapping [ new-live-inputs live-inputs zip ] | + inputs filter-live + new-live-inputs + mapping + #shuffle + ] ; -M: #call-recursive remove-dead-code* - [ filter-live ] change-in-d - [ filter-live ] change-out-d ; +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-in-d [ filter-live ] change-out-d ; -M: #return-recursive remove-dead-code* - [ filter-live ] change-in-d - [ filter-live ] change-out-d ; +: drop-call-recursive-inputs ( node -- #shuffle ) + dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs + [ out-d>> >>in-d drop ] + [ nip ] + 2bi ; + +:: drop-call-recursive-outputs ( node -- #shuffle ) + [let* | node-out [ node out-d>> ] + return-in [ node label>> return>> in-d>> ] + node-out-live [ return-in node-out filter-corresponding ] + new-node-out-live [ node-out-live make-values ] + node-out-dropped [ node-out filter-live ] + new-node-out-dropped [ node-out-dropped new-node-out-live filter-corresponding ] + mapping [ node-out-dropped new-node-out-dropped zip ] | + node new-node-out-live >>out-d drop + new-node-out-live node-out-dropped mapping #shuffle + ] ; + +M: #call-recursive remove-dead-code* + [ drop-call-recursive-inputs ] + [ ] + [ 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 ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index a3695dc815..880ae94a1f 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -41,12 +41,17 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; : filter-mapping ( assoc -- assoc' ) live-values get '[ drop , key? ] assoc-filter ; -: filter-corresponding ( new old -- new' ) +: filter-corresponding ( new old -- old' ) + #! Remove elements from 'old' if the element with the same + #! index in 'new' is dead. zip filter-mapping values ; : filter-live ( values -- values' ) [ live-value? ] filter ; +: drop-dead-values ( in out -- #shuffle ) + [ make-values dup ] keep zip #shuffle ; + :: drop-dead-outputs ( node -- nodes ) [let* | old-outputs [ node out-d>> ] new-outputs [ old-outputs make-values ] diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 0c2fbf255c..1b4f728adc 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -1,6 +1,7 @@ IN: compiler.tree.normalization.tests USING: compiler.tree.builder compiler.tree.normalization -compiler.tree sequences accessors tools.test kernel math ; +compiler.tree compiler.tree.checker +sequences accessors tools.test kernel math ; \ count-introductions must-infer \ normalize must-infer @@ -24,20 +25,24 @@ compiler.tree sequences accessors tools.test kernel math ; [ normalize recursive-inputs ] bi ] unit-test -[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test +[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test DEFER: bbb : aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive : bbb ( x -- ) >r drop 0 r> aaa ; inline recursive -[ ] [ [ bbb ] build-tree normalize drop ] unit-test +[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test : ccc ( -- ) ccc drop 1 ; inline recursive -[ ] [ [ ccc ] build-tree normalize drop ] unit-test +[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test DEFER: eee : ddd ( -- ) eee ; inline recursive : eee ( -- ) swap ddd ; inline recursive -[ ] [ [ eee ] build-tree normalize drop ] unit-test +[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test + +: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive + +[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 6e191157b0..d42dff7747 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -26,5 +26,4 @@ IN: compiler.tree.optimizer compute-def-use remove-dead-code ! strength-reduce - compute-def-use USE: kernel - dup check-nodes ; + ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index e0b5c1a676..c3b1b7a5fd 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -567,3 +567,7 @@ M: integer infinite-loop infinite-loop ; [ ] [ [ instance? ] final-classes drop ] unit-test [ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test + +: fold-throw-test ( a -- b ) "A" throw ; foldable + +[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 73da76c525..b39ecef6e4 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -62,10 +62,10 @@ M: #declare propagate-before [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ; : fold-call ( #call word -- infos ) - [ in-d>> [ value-info literal>> ] map ] - [ [ execute ] curry ] - bi* with-datastack - [ ] map ; + [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi* + '[ , , with-datastack [ ] map nip ] + [ drop [ object-info ] replicate ] + recover ; : predicate-output-infos ( info class -- info ) [ class>> ] dip { diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 40a35e66d4..f7d0adbf92 100755 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic assocs kernel math namespaces parser sequences words vectors math.intervals effects classes -accessors combinators stack-checker.state stack-checker.visitor ; +accessors combinators stack-checker.state stack-checker.visitor +stack-checker.inlining ; IN: compiler.tree ! High-level tree SSA form. diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index ac2c2bc229..3f92d99597 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -103,7 +103,9 @@ M: #phi unbox-tuples* [ flatten-values ] change-out-d ; M: #recursive unbox-tuples* - [ flatten-values ] change-in-d ; + [ label>> [ flatten-values ] change-enter-out drop ] + [ [ flatten-values ] change-in-d ] + bi ; M: #enter-recursive unbox-tuples* [ flatten-values ] change-in-d diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 56b4630962..d15c5a30ab 100755 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -163,8 +163,8 @@ PREDICATE: small-slot < integer cells small-enough? ; PREDICATE: small-tagged < integer v>operand small-enough? ; : if-small-struct ( n size true false -- ? ) - >r >r over not over struct-small-enough? and - [ nip r> call r> drop ] [ r> drop r> call ] if ; + [ over not over struct-small-enough? and ] 2dip + [ [ nip ] prepose ] dip if ; inline : %unbox-struct ( n size -- ) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 3aa9b22695..52ad68baf1 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private -math memory namespaces sequences words generator +math memory namespaces sequences words compiler.generator compiler.generator.registers compiler.generator.fixup system layouts combinators compiler.constants math.order ; IN: cpu.x86.architecture diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 9228666491..1539a07d68 100755 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math namespaces parser -prettyprint sequences vocabs.loader namespaces inference ; +prettyprint sequences vocabs.loader namespaces stack-checker ; IN: help.cookbook ARTICLE: "cookbook-syntax" "Basic syntax cookbook" diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5d7d5e0d2c..b9191ac612 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -72,7 +72,6 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" - "generator" "growable" "hashtables" "hashtables.private" diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 94d3a64c45..585bb6ece7 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -164,8 +164,8 @@ ERROR: bad-superclass class ; : update-slot ( old-values n class initial -- value ) pick [ - >r >r swap nth dup r> instance? - [ r> drop ] [ drop r> ] if + >r >r swap nth dup r> instance? r> swap + [ drop ] [ nip ] if ] [ >r 3drop r> ] if ; : apply-slot-permutation ( old-values triples -- new-values ) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 11162be4d3..1d3c061a42 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -19,12 +19,9 @@ SYMBOL: restarts : c> ( -- continuation ) catchstack* pop ; -: dummy ( -- obj ) - #! Optimizing compiler assumes stack won't be messed with - #! in-transit. To ensure that a value is actually reified - #! on the stack, we put it in a non-inline word together - #! with a declaration. - f { object } declare ; +! We have to defeat some optimizations to make continuations work +: dummy-1 ( -- obj ) f ; +: dummy-2 ( obj -- obj ) dup drop ; : init-catchstack ( -- ) V{ } clone 1 setenv ; @@ -68,7 +65,7 @@ C: continuation #! ( value f r:capture r:restore ) #! Execution begins right after the call to 'continuation'. #! The 'restore' branch is taken. - >r >r dummy continuation r> r> ?if ; inline + >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline : callcc0 ( quot -- ) [ drop ] ifcc ; inline diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 397aef8e07..eb6442bbb9 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -23,9 +23,9 @@ TUPLE: lexer text line line-text line-length column ; lexer new-lexer ; : skip ( i seq ? -- n ) - over >r + >r tuck r> [ swap CHAR: \s eq? xor ] curry find-from drop - [ r> drop ] [ r> length ] if* ; + [ ] [ length ] ?if ; : change-lexer-column ( lexer quot -- ) swap