From 7afea4c0eafe65ff914d5337486e462cc356ff9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Nov 2009 17:24:11 -0600 Subject: [PATCH 01/11] compiler.tree.propagation: implementing missing case in branch constraints --- .../tree/propagation/branches/branches.factor | 16 ++++++++++++++++ .../tree/propagation/propagation-tests.factor | 9 +++++++++ 2 files changed, 25 insertions(+) diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 0d837d82ae..662059ec1b 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- ) swap t--> ] } + { + { { t f } { t } } + [ + first =t + condition-value get =t /\ + swap f--> + ] + } + { + { { t } { t f } } + [ + second =t + condition-value get =f /\ + swap f--> + ] + } { { { t f } { } } [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 3627757acd..e3f509914b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -224,6 +224,14 @@ IN: compiler.tree.propagation.tests [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test +[ V{ fixnum } ] [ + [ + [ { fixnum } declare ] [ drop f ] if + dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if + [ "Oops" throw ] when + ] final-classes +] unit-test + [ V{ fixnum } ] [ [ >fixnum @@ -925,3 +933,4 @@ M: tuple-with-read-only-slot clone ! Could be bignum not integer but who cares [ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test + From ff25aaef5469cf25e03fb63c479f60c5894b6c37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Nov 2009 17:24:32 -0600 Subject: [PATCH 02/11] compiler.tree.propagation.transforms: inline push if types are known. Speeds up reverse-complement, sort, sum-file benchmarks --- .../tree/propagation/transforms/transforms.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 294b883403..5aa490bfd3 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -6,7 +6,7 @@ stack-checker.dependencies quotations classes.tuple.private math math.partial-dispatch math.private math.intervals sets.private math.floats.private math.integers.private layouts math.order vectors hashtables combinators effects generalizations assocs -sets combinators.short-circuit sequences.private locals +sets combinators.short-circuit sequences.private locals growable stack-checker namespaces compiler.tree.propagation.info ; IN: compiler.tree.propagation.transforms @@ -300,3 +300,10 @@ CONSTANT: lookup-table-at-max 256 tester '[ _ filter ] ; \ intersect [ intersect-quot ] 1 define-partial-eval + +! Speeds up sum-file, sort and reverse-complement benchmarks by +! compiling decoder-readln better +\ push [ + in-d>> second value-info class>> growable class<= + [ \ push def>> ] [ f ] if +] "custom-inlining" set-word-prop From 14a4535ad9f61f2d1d6c87b534417ec70fe1c7c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 03:01:22 -0600 Subject: [PATCH 03/11] classes.algebra: output cleaner anonymous unions and intersections --- core/classes/algebra/algebra-tests.factor | 5 +++++ core/classes/algebra/algebra.factor | 12 +++++++++--- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index c56ceb7bce..e2f4d4305f 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ; INTERSECTION: generic-class generic class ; +UNION: union-with-one-member a ; + ! class<= [ t ] [ \ fixnum \ integer class<= ] unit-test [ t ] [ \ fixnum \ fixnum class<= ] unit-test @@ -122,6 +124,9 @@ INTERSECTION: generic-class generic class ; [ t ] [ generic-class generic class<= ] unit-test [ t ] [ generic-class \ class class<= ] unit-test +[ t ] [ a union-with-one-member class<= ] unit-test +[ f ] [ union-with-one-member class-not integer class<= ] unit-test + ! class-and : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5ae4f03598..c08239849f 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -9,11 +9,14 @@ IN: classes.algebra TUPLE: anonymous-union { members read-only } ; -C: anonymous-union +: ( members -- class ) + [ null eq? not ] filter prune + dup length 1 = [ first ] [ anonymous-union boa ] if ; TUPLE: anonymous-intersection { participants read-only } ; -C: anonymous-intersection +: ( participants -- class ) + prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ; TUPLE: anonymous-complement { class read-only } ; @@ -114,6 +117,7 @@ M: word valid-class? drop f ; [ class-not normalize-class ] map ] } + [ ] } cond ; : left-anonymous-complement<= ( first second -- ? ) @@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; : (class<=) ( first second -- ? ) 2dup eq? [ 2drop t ] [ + [ normalize-class ] bi@ 2dup superclass<= [ 2drop t ] [ - [ normalize-class ] bi@ { + { + { [ 2dup eq? ] [ 2drop t ] } { [ dup empty-intersection? ] [ 2drop t ] } { [ over empty-union? ] [ 2drop t ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } From 8dd8d705003cf2d0280b5367add11c669d04998f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 03:01:28 -0600 Subject: [PATCH 04/11] sequences: inline a couple of words --- core/sequences/sequences.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index fde5b5736d..5017e52ce5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -659,9 +659,9 @@ PRIVATE> [ 0 swap copy ] keep ] new-like ; -: suffix! ( seq elt -- seq ) over push ; +: suffix! ( seq elt -- seq ) over push ; inline -: append! ( seq1 seq2 -- seq1 ) over push-all ; +: append! ( seq1 seq2 -- seq1 ) over push-all ; inline : last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; From 720c4124314a86153074155fce70dca33f24c141 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 03:22:57 -0600 Subject: [PATCH 05/11] compiler.tree.propagation: fix bug in constraints that caused retain stack overflow --- basis/compiler/tree/propagation/branches/branches.factor | 2 +- .../tree/propagation/constraints/constraints.factor | 8 ++++---- basis/compiler/tree/propagation/info/info.factor | 5 ++++- basis/compiler/tree/propagation/propagation-tests.factor | 8 ++++++++ 4 files changed, 17 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 662059ec1b..8d349128be 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- ) constraints get last update-constraints ; : branch-phi-constraints ( output values booleans -- ) - { + { { { { t } { f } } [ diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 59c9912e47..617352d699 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -39,8 +39,8 @@ M: true-constraint assume* bi ; M: true-constraint satisfied? - value>> value-info class>> - { [ true-class? ] [ null-class? not ] } 1&& ; + value>> value-info* + [ class>> true-class? ] [ drop f ] if ; TUPLE: false-constraint value ; @@ -52,8 +52,8 @@ M: false-constraint assume* bi ; M: false-constraint satisfied? - value>> value-info class>> - { [ false-class? ] [ null-class? not ] } 1&& ; + value>> value-info* + [ class>> false-class? ] [ drop f ] if ; ! Class constraints TUPLE: class-constraint value class ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 9030914e34..6dcf6f7317 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -294,8 +294,11 @@ DEFER: (value-info-union) ! Assoc stack of current value --> info mapping SYMBOL: value-infos +: value-info* ( value -- info ? ) + resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline + : value-info ( value -- info ) - resolve-copy value-infos get assoc-stack null-info or ; + value-info* drop ; : set-value-info ( info value -- ) resolve-copy value-infos get last set-at ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index e3f509914b..c7e02aef4c 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -239,6 +239,14 @@ IN: compiler.tree.propagation.tests ] final-classes ] unit-test +[ ] [ + [ + dup dup dup [ 100 < ] [ drop f ] if dup + [ 2drop f ] [ 2drop f ] if + [ ] [ dup [ ] [ ] if ] if + ] final-info drop +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare (clone) ] final-classes ] unit-test From 86da8ebed9e6d2bce102b69886f5554e9d86dba6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 03:52:14 -0600 Subject: [PATCH 06/11] Instead of bumping the definition counter every time in the VM, bump it only if stack effects changed or macros were redefined --- .../call-effect/call-effect.factor | 15 +++---- basis/macros/macros.factor | 5 ++- core/compiler/units/units.factor | 40 ++++++++++++++++--- vm/code_heap.cpp | 13 ------ vm/vm.hpp | 1 - 5 files changed, 47 insertions(+), 27 deletions(-) diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index 98e46e1457..545d02cf9a 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -4,7 +4,7 @@ USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations words math stack-checker combinators.short-circuit stack-checker.transforms compiler.tree.propagation.info -compiler.tree.propagation.inlining ; +compiler.tree.propagation.inlining compiler.units ; IN: compiler.tree.propagation.call-effect ! call( and execute( have complex expansions. @@ -15,22 +15,23 @@ IN: compiler.tree.propagation.call-effect ! and compare it with declaration. If matches, call it unsafely. ! - Fallback. If the above doesn't work, call it and compare the datastack before ! and after to make sure it didn't mess anything up. +! - Inline caches and cached effects are invalidated whenever a macro is redefined, or +! a word's effect changes, by comparing a global counter against the counter value +! last observed. The counter is incremented by compiler.units. ! execute( uses a similar strategy. -: definition-counter ( -- n ) 46 getenv ; inline - TUPLE: inline-cache value counter ; : inline-cache-hit? ( word/quot ic -- ? ) { [ nip value>> ] [ value>> eq? ] - [ nip counter>> definition-counter eq? ] + [ nip counter>> effect-counter eq? ] } 2&& ; inline : update-inline-cache ( word/quot ic -- ) - [ definition-counter ] dip + [ effect-counter ] dip [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline SINGLETON: +unknown+ @@ -64,10 +65,10 @@ M: compose cached-effect [ infer ] [ 2drop +unknown+ ] recover ; : cached-effect-valid? ( quot -- ? ) - cache-counter>> definition-counter eq? ; inline + cache-counter>> effect-counter eq? ; inline : save-effect ( effect quot -- ) - [ definition-counter ] dip + [ effect-counter ] dip [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ; M: quotation cached-effect diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 0e5ef30f51..0186f6181f 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects combinators assocs -definitions quotations namespaces memoize accessors ; +definitions quotations namespaces memoize accessors +compiler.units ; IN: macros + : remember-definition ( definition loc -- ) new-definitions get first (remember-definition) ; @@ -44,6 +49,8 @@ HOOK: to-recompile compiler-impl ( -- words ) HOOK: process-forgotten-words compiler-impl ( words -- ) +: compile ( words -- ) recompile modify-code-heap ; + ! Non-optimizing compiler M: f recompile [ dup def>> ] { } map>assoc ; @@ -90,6 +97,17 @@ GENERIC: definitions-changed ( assoc obj -- ) definition-observers get [ definitions-changed ] with each ; +! Incremented each time stack effects potentially changed, used +! by compiler.tree.propagation.call-effect for call( and execute( +! inline caching +: effect-counter ( -- n ) 46 getenv ; inline + +GENERIC: bump-effect-counter* ( defspec -- ? ) + +M: object bump-effect-counter* drop f ; + +> dup [ vocab ] when dup ] assoc-map ; @@ -102,22 +120,34 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-definitions get update dup dup changed-vocabs update ; -: compile ( words -- ) recompile modify-code-heap ; - : process-forgotten-definitions ( -- ) forgotten-definitions get keys [ [ word? ] filter process-forgotten-words ] [ [ delete-definition-errors ] each ] bi ; +: bump-effect-counter? ( -- ? ) + changed-effects get old-definitions get first assoc-intersect assoc-empty? not + new-definitions get first [ drop bump-effect-counter* ] assoc-any? + or ; + +: bump-effect-counter ( -- ) + bump-effect-counter? [ 46 getenv 1 + 46 setenv ] when ; + +: notify-observers ( -- ) + updated-definitions dup assoc-empty? + [ drop ] [ notify-definition-observers notify-error-observers ] if ; + : finish-compilation-unit ( -- ) remake-generics to-recompile recompile update-tuples process-forgotten-definitions modify-code-heap - updated-definitions dup assoc-empty? - [ drop ] [ notify-definition-observers notify-error-observers ] if ; + bump-effect-counter + notify-observers ; + +PRIVATE> : with-nested-compilation-unit ( quot -- ) [ diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index f263b070b0..98da158b16 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -135,18 +135,6 @@ struct code_heap_relocator { } }; -void factor_vm::increment_definition_counter() -{ - /* Increment redefinition counter for call( */ - cell counter_ = special_objects[REDEFINITION_COUNTER]; - cell counter; - if(counter_ == false_object) - counter = 0; - else - counter = untag_fixnum(counter_) + 1; - special_objects[REDEFINITION_COUNTER] = tag_fixnum(counter); -} - void factor_vm::primitive_modify_code_heap() { data_root alist(dpop(),this); @@ -197,7 +185,6 @@ void factor_vm::primitive_modify_code_heap() } update_code_heap_words(); - increment_definition_counter(); } code_heap_room factor_vm::code_room() diff --git a/vm/vm.hpp b/vm/vm.hpp index 900ce54b55..0e4762d6c5 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -534,7 +534,6 @@ struct factor_vm void jit_compile_word(cell word_, cell def_, bool relocate); void update_code_heap_words(); void update_code_heap_words_and_literals(); - void increment_definition_counter(); void primitive_modify_code_heap(); code_heap_room code_room(); void primitive_code_room(); From c4cd6e078755667368a72a4f19f5828bb06205ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 03:52:20 -0600 Subject: [PATCH 07/11] benchmark.fannkuch: use iota --- extra/benchmark/fannkuch/fannkuch.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor index 40dd54ca99..f3a41ca4a9 100644 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -24,7 +24,7 @@ IN: benchmark.fannkuch : fannkuch ( n -- ) [ - [ 0 0 ] dip [ 1 + ] B{ } map-as + [ 0 0 ] dip iota [ 1 + ] B{ } map-as [ fannkuch-step ] each-permutation nip ] keep "Pfannkuchen(" write pprint ") = " write . ; From afecb9c758f73efe81838752f91477d3206346b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 04:32:33 -0600 Subject: [PATCH 08/11] Fixing call( inline caching --- .../tree/propagation/call-effect/call-effect.factor | 6 +----- core/compiler/units/units.factor | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index 545d02cf9a..ff4886d1c7 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -24,11 +24,7 @@ IN: compiler.tree.propagation.call-effect TUPLE: inline-cache value counter ; : inline-cache-hit? ( word/quot ic -- ? ) - { - [ nip value>> ] - [ value>> eq? ] - [ nip counter>> effect-counter eq? ] - } 2&& ; inline + { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline : update-inline-cache ( word/quot ic -- ) [ effect-counter ] dip diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 93ed6c4aa1..a46e846b0d 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -132,7 +132,7 @@ M: object bump-effect-counter* drop f ; or ; : bump-effect-counter ( -- ) - bump-effect-counter? [ 46 getenv 1 + 46 setenv ] when ; + bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ; : notify-observers ( -- ) updated-definitions dup assoc-empty? From 7377c96a21974559a565f33c6b13c7934c2c9273 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 07:11:26 -0600 Subject: [PATCH 09/11] compiler.tree.propagation.branches: fix recent constraints change --- basis/compiler/tree/propagation/branches/branches.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 8d349128be..28f34cb425 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -133,7 +133,7 @@ M: #phi propagate-before ( #phi -- ) { { { t f } { t } } [ - first =t + first =f condition-value get =t /\ swap f--> ] @@ -141,7 +141,7 @@ M: #phi propagate-before ( #phi -- ) { { { t } { t f } } [ - second =t + second =f condition-value get =f /\ swap f--> ] From 5470330c451361a546193b0deca1eee3e601bda5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 07:17:00 -0600 Subject: [PATCH 10/11] Fix another problem with call( inline caching --- core/compiler/units/units.factor | 6 ++++-- core/definitions/definitions.factor | 8 ++++++++ core/words/words.factor | 2 +- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a46e846b0d..9ffb98a383 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -127,8 +127,8 @@ M: object bump-effect-counter* drop f ; bi ; : bump-effect-counter? ( -- ? ) - changed-effects get old-definitions get first assoc-intersect assoc-empty? not - new-definitions get first [ drop bump-effect-counter* ] assoc-any? + changed-effects get new-words get assoc-diff assoc-empty? not + changed-definitions get [ drop bump-effect-counter* ] assoc-any? or ; : bump-effect-counter ( -- ) @@ -156,6 +156,7 @@ PRIVATE> H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set + H{ } clone new-words set H{ } clone new-classes set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline @@ -168,6 +169,7 @@ PRIVATE> H{ } clone outdated-generics set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set + H{ } clone new-words set H{ } clone new-classes set new-definitions set old-definitions set diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index d815b9609d..597b195c36 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -21,8 +21,16 @@ SYMBOL: changed-generics SYMBOL: outdated-generics +SYMBOL: new-words + SYMBOL: new-classes +: new-word ( word -- ) + dup new-words get set-in-unit ; + +: new-word? ( word -- ? ) + new-words get key? ; + : new-class ( word -- ) dup new-classes get set-in-unit ; diff --git a/core/words/words.factor b/core/words/words.factor index 24a95853da..712e3ba558 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -135,7 +135,7 @@ M: word reset-word ] tri ; : ( name vocab -- word ) - 2dup [ hashcode ] bi@ bitxor >fixnum (word) ; + 2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ; : gensym ( -- word ) "( gensym )" f \ gensym counter >fixnum (word) ; From ea36783fb3ea1e3829dbcb454409154819b7ff0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Nov 2009 07:55:47 -0600 Subject: [PATCH 11/11] Fix bootstrap --- basis/stack-checker/alien/alien.factor | 2 +- core/bootstrap/syntax.factor | 171 +++++++++++++------------ core/compiler/units/units-tests.factor | 2 +- core/words/words.factor | 5 +- 4 files changed, 93 insertions(+), 87 deletions(-) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 2a20ba74cd..f9ab1ae96c 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -69,6 +69,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; pop-literal nip >>abi pop-literal nip >>parameters pop-literal nip >>return - "( callback )" f >>xt + "( callback )" >>xt dup callback-bottom #alien-callback, ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 57be2fb90f..bb159f04df 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -1,90 +1,93 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words words.symbol sequences vocabs kernel ; +USING: words words.symbol sequences vocabs kernel +compiler.units ; IN: bootstrap.syntax -"syntax" create-vocab drop +[ + "syntax" create-vocab drop -{ - "!" - "\"" - "#!" - "(" - "((" - ":" - ";" - "" - "SBUF\"" - "SINGLETON:" - "SINGLETONS:" - "SYMBOL:" - "SYMBOLS:" - "CONSTANT:" - "TUPLE:" - "SLOT:" - "T{" - "UNION:" - "INTERSECTION:" - "USE:" - "UNUSE:" - "USING:" - "QUALIFIED:" - "QUALIFIED-WITH:" - "FROM:" - "EXCLUDE:" - "RENAME:" - "ALIAS:" - "SYNTAX:" - "V{" - "W{" - "[" - "\\" - "M\\" - "]" - "delimiter" - "deprecated" - "f" - "flushable" - "foldable" - "inline" - "recursive" - "t" - "{" - "}" - "CS{" - "<<" - ">>" - "call-next-method" - "initial:" - "read-only" - "call(" - "execute(" -} [ "syntax" create drop ] each + { + "!" + "\"" + "#!" + "(" + "((" + ":" + ";" + "" + "SBUF\"" + "SINGLETON:" + "SINGLETONS:" + "SYMBOL:" + "SYMBOLS:" + "CONSTANT:" + "TUPLE:" + "SLOT:" + "T{" + "UNION:" + "INTERSECTION:" + "USE:" + "UNUSE:" + "USING:" + "QUALIFIED:" + "QUALIFIED-WITH:" + "FROM:" + "EXCLUDE:" + "RENAME:" + "ALIAS:" + "SYNTAX:" + "V{" + "W{" + "[" + "\\" + "M\\" + "]" + "delimiter" + "deprecated" + "f" + "flushable" + "foldable" + "inline" + "recursive" + "t" + "{" + "}" + "CS{" + "<<" + ">>" + "call-next-method" + "initial:" + "read-only" + "call(" + "execute(" + } [ "syntax" create drop ] each -"t" "syntax" lookup define-symbol + "t" "syntax" lookup define-symbol +] with-compilation-unit diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index c827d370d5..eccc292f26 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -7,7 +7,7 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep + "A" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 712e3ba558..3dbfb3c864 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -137,8 +137,11 @@ M: word reset-word : ( name vocab -- word ) 2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ; +: ( name -- word ) + f \ counter >fixnum (word) ; + : gensym ( -- word ) - "( gensym )" f \ gensym counter >fixnum (word) ; + "( gensym )" ; : define-temp ( quot effect -- word ) [ gensym dup ] 2dip define-declared ;