From 4a1bcacfd4ebb74af668e4c32eb51115f13e065a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 Nov 2008 19:08:40 -0600 Subject: [PATCH 01/13] Refactoring recursive-state alist; now its a mapping from words to local state triples, reduces searching by a bit --- basis/compiler/tree/builder/builder.factor | 11 ++-- basis/stack-checker/backend/backend.factor | 10 ++-- basis/stack-checker/errors/errors.factor | 6 +- basis/stack-checker/inlining/inlining.factor | 29 +++++----- .../known-words/known-words.factor | 2 +- basis/stack-checker/state/state.factor | 58 +++++++++++++------ .../transforms/transforms.factor | 2 +- 7 files changed, 71 insertions(+), 47 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 19d80ec14f..65e9ccdff6 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -12,12 +12,13 @@ IN: compiler.tree.builder : build-tree ( quot -- nodes ) #! Not safe to call from inference transforms. - [ f infer-quot ] with-tree-builder nip ; + [ f initial-recursive-state infer-quot ] with-tree-builder nip ; : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] [ f infer-quot ] bi* + [ >vector meta-d set ] + [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; @@ -32,10 +33,10 @@ IN: compiler.tree.builder dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and [ - 1quotation f infer-quot + 1quotation f initial-recursive-state infer-quot ] [ - [ specialized-def ] - [ dup 2array 1array ] bi infer-quot + [ specialized-def ] [ initial-recursive-state ] bi + infer-quot ] if ; : check-cannot-infer ( word -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index aadd1adbd4..250ee2cb7a 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -82,9 +82,6 @@ M: object apply-object push-literal ; infer-quot-here ] dip recursive-state set ; -: infer-quot-recursive ( quot word label -- ) - 2array recursive-state get swap prefix infer-quot ; - : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; @@ -97,7 +94,7 @@ M: object apply-object push-literal ; ] [ dup value>> callable? [ [ value>> ] - [ [ recursion>> ] keep f 2array prefix ] + [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ drop bad-call @@ -126,6 +123,9 @@ M: object apply-object push-literal ; terminated?>> [ terminate ] when ] 2bi ; inline +: infer-word-def ( word -- ) + [ def>> ] [ add-recursive-state ] bi infer-quot ; + : check->r ( -- ) meta-r get empty? terminated? get or [ \ too-many->r inference-error ] unless ; @@ -174,7 +174,7 @@ M: object apply-object push-literal ; stack-visitor off dependencies off generic-dependencies off - [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] + [ infer-word-def end-infer ] [ finish-word current-effect ] bi ] with-scope diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index bab6c17c85..b728d1a7e9 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,11 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences prettyprint io words arrays summary effects debugger assocs accessors namespaces -compiler.errors ; +compiler.errors stack-checker.state ; IN: stack-checker.errors -SYMBOL: recursive-state - TUPLE: inference-error error type rstate ; M: inference-error compiler-error-type type>> ; @@ -35,6 +33,8 @@ TUPLE: literal-expected ; M: literal-expected summary drop "Literal value expected" ; +M: object (literal) \ literal-expected inference-warning ; + TUPLE: unbalanced-branches-error branches quots ; : unbalanced-branches-error ( branches quots -- * ) diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 7847fdfdcf..695eb4f0d3 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -14,8 +14,8 @@ IN: stack-checker.inlining ! Code to handle inline words. Much of the complexity stems from ! having to handle recursive inline words. -: (inline-word) ( word label -- ) - [ [ def>> ] keep ] dip infer-quot-recursive ; +: infer-inline-word-def ( word label -- ) + [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ; TUPLE: inline-recursive < identity-tuple id @@ -88,7 +88,7 @@ SYMBOL: enter-out nest-visitor dup - [ dup emit-enter-recursive (inline-word) ] + [ dup emit-enter-recursive infer-inline-word-def ] [ end-recursive-word ] [ nip ] 2tri @@ -133,20 +133,23 @@ SYMBOL: enter-out object '[ _ prepend ] bi@ ; -: call-recursive-inline-word ( word -- ) - dup "recursive" word-prop [ - [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri - [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi - ] [ undeclared-recursion-error inference-error ] if ; +: call-recursive-inline-word ( word label -- ) + over "recursive" word-prop [ + [ required-stack-effect adjust-stack-effect ] dip + [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi + ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) [ inlined-dependency depends-on ] [ - { - { [ dup inline-recursive-label ] [ call-recursive-inline-word ] } - { [ dup "recursive" word-prop ] [ inline-recursive-word ] } - [ dup (inline-word) ] - } cond + dup inline-recursive-label [ + call-recursive-inline-word + ] [ + dup "recursive" word-prop + [ inline-recursive-word ] + [ dup infer-inline-word-def ] + if + ] if* ] bi ; M: word apply-object diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 257181f6ad..ecc9f95f54 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -195,7 +195,7 @@ do-primitive alien-invoke alien-indirect alien-callback { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } - { [ dup recursive-label ] [ call-recursive-word ] } + { [ dup recursive-word? ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 11dc6f9ef8..177731f985 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,10 +1,38 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel definitions math -effects accessors words fry classes.algebra stack-checker.errors +USING: assocs arrays namespaces sequences kernel definitions +math effects accessors words fry classes.algebra compiler.units ; IN: stack-checker.state +! Recursive state +SYMBOL: recursive-state + +: initial-recursive-state ( word -- state ) + { } { } 3array 1array ; inline + +f initial-recursive-state recursive-state set-global + +: add-recursive-state ( word -- rstate ) + [ recursive-state get ] dip { } { } 3array prefix ; + +: add-local-quotation ( recursive-state quot -- rstate ) + [ unclip first3 swap ] dip prefix swap 3array prefix ; + +: add-local-recursive-state ( word label -- rstate ) + [ recursive-state get ] 2dip + [ unclip first3 ] 2dip 2array prefix 3array prefix ; + +: recursive-word? ( word -- ? ) + recursive-state get key? ; + +: inline-recursive-label ( word -- label/f ) + recursive-state get first third at ; + +: recursive-quotation? ( quot -- ? ) + recursive-state get first second [ eq? ] with contains? ; + +! Values : ( -- value ) \ counter ; SYMBOL: known-values @@ -29,9 +57,12 @@ TUPLE: literal < identity-tuple value recursion ; : ( obj -- value ) recursive-state get \ literal boa ; +GENERIC: (literal) ( value -- literal ) + +M: literal (literal) ; + : literal ( value -- literal ) - known dup literal? - [ \ literal-expected inference-warning ] unless ; + known (literal) ; ! Result of curry TUPLE: curried obj quot ; @@ -71,20 +102,6 @@ SYMBOL: meta-r : init-known-values ( -- ) H{ } clone known-values set ; -: recursive-label ( word -- label/f ) - recursive-state get at ; - -: local-recursive-state ( -- assoc ) - recursive-state get dup - [ first dup word? [ inline? ] when not ] find drop - [ head-slice ] when* ; - -: inline-recursive-label ( word -- label/f ) - local-recursive-state at ; - -: recursive-quotation? ( quot -- ? ) - local-recursive-state [ first eq? ] with contains? ; - ! Words that the current quotation depends on SYMBOL: dependencies @@ -98,9 +115,12 @@ SYMBOL: dependencies ! Generic words that the current quotation depends on SYMBOL: generic-dependencies +: ?class-or ( class/f class -- class' ) + swap [ class-or ] when* ; + : depends-on-generic ( generic class -- ) generic-dependencies get dup - [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ; + [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; ! Words we've inferred the stack effect of, for rollback SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index abc3ae1950..c71337b021 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -9,7 +9,7 @@ stack-checker.errors ; IN: stack-checker.transforms : give-up-transform ( word -- ) - dup recursive-label + dup recursive-word? [ call-recursive-word ] [ dup infer-word apply-word/effect ] if ; From 5bae69426db5b2019fd2bdec55526f596d1d18a0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 00:07:45 -0600 Subject: [PATCH 02/13] Stack checker cleanup and optimization - stack-checker.state vocabulary split up into stack-checker.{state,values,recursive-state} - code that modifies and searches recursive state factored out into stack-checker.recursive-state - recursive state is now a set of three binary hash trees instead of an alist, and no longer contains unnecessary data - binary hash trees are in stack-checker.recursive-state.tree: unbalanced, persistent - ~8 second speedup on bootstrap, ~20 second speedup in "peg.javascript" require --- basis/compiler/tree/builder/builder.factor | 10 ++- .../allocations/allocations.factor | 2 +- basis/stack-checker/backend/backend.factor | 3 +- basis/stack-checker/branches/branches.factor | 2 +- basis/stack-checker/errors/errors.factor | 12 ++-- basis/stack-checker/inlining/inlining.factor | 8 ++- .../known-words/known-words.factor | 9 +-- .../recursive-state/recursive-state.factor | 43 +++++++++++ .../recursive-state/tree/tree.factor | 31 ++++++++ basis/stack-checker/state/state.factor | 72 ------------------- .../transforms/transforms.factor | 3 +- basis/stack-checker/values/values.factor | 52 ++++++++++++++ 12 files changed, 154 insertions(+), 93 deletions(-) create mode 100644 basis/stack-checker/recursive-state/recursive-state.factor create mode 100644 basis/stack-checker/recursive-state/tree/tree.factor create mode 100644 basis/stack-checker/values/values.factor diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 65e9ccdff6..c2ec6552cd 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,9 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors quotations kernel sequences namespaces -assocs words arrays vectors hints combinators stack-checker -stack-checker.state stack-checker.visitor stack-checker.errors -stack-checker.backend compiler.tree ; +assocs words arrays vectors hints combinators compiler.tree +stack-checker +stack-checker.state +stack-checker.errors +stack-checker.visitor +stack-checker.backend +stack-checker.recursive-state ; IN: compiler.tree.builder : with-tree-builder ( quot -- nodes ) diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor index 4c197d7fc0..5d34eaad15 100644 --- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces sequences kernel math -combinators sets disjoint-sets fry stack-checker.state ; +combinators sets disjoint-sets fry stack-checker.values ; IN: compiler.tree.escape-analysis.allocations ! A map from values to one of the following: diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 250ee2cb7a..94e59950f7 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,8 @@ namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations debugger assocs combinators compiler.errors accessors math.order definitions sets generic.standard.engines.tuple stack-checker.state -stack-checker.visitor stack-checker.errors ; +stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend : push-d ( obj -- ) meta-d get push ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index d1417d035c..7b461d0028 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -3,7 +3,7 @@ USING: fry vectors sequences assocs math accessors kernel combinators quotations namespaces stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor -; +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.branches : balanced? ( pairs -- ? ) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index b728d1a7e9..efdc7e23b2 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences prettyprint io words arrays summary effects debugger assocs accessors namespaces -compiler.errors stack-checker.state ; +compiler.errors stack-checker.values +stack-checker.recursive-state ; IN: stack-checker.errors -TUPLE: inference-error error type rstate ; +TUPLE: inference-error error type word ; M: inference-error compiler-error-type type>> ; @@ -13,7 +14,7 @@ M: inference-error error-help error>> error-help ; : (inference-error) ( ... class type -- * ) >r boa r> - recursive-state get + recursive-state get word>> \ inference-error boa throw ; inline : inference-error ( ... class -- * ) @@ -23,10 +24,7 @@ M: inference-error error-help error>> error-help ; +warning+ (inference-error) ; inline M: inference-error error. - [ - rstate>> - [ "Nesting:" print stack. ] unless-empty - ] [ error>> error. ] bi ; + [ "In word: " write word>> . ] [ error>> error. ] bi ; TUPLE: literal-expected ; diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 695eb4f0d3..b6a988652b 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -4,18 +4,20 @@ USING: fry namespaces assocs kernel sequences words accessors definitions math math.order effects classes arrays combinators vectors arrays stack-checker.state +stack-checker.errors +stack-checker.values stack-checker.visitor stack-checker.backend stack-checker.branches -stack-checker.errors -stack-checker.known-words ; +stack-checker.known-words +stack-checker.recursive-state ; IN: stack-checker.inlining ! Code to handle inline words. Much of the complexity stems from ! having to handle recursive inline words. : infer-inline-word-def ( word label -- ) - [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ; + [ drop def>> ] [ add-inline-word ] 2bi infer-quot ; TUPLE: inline-recursive < identity-tuple id diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ecc9f95f54..4aea0f2d28 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -11,14 +11,15 @@ strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.private words.private -quotations.private +quotations.private stack-checker.values +stack-checker.alien stack-checker.state +stack-checker.errors +stack-checker.visitor stack-checker.backend stack-checker.branches -stack-checker.errors stack-checker.transforms -stack-checker.visitor -stack-checker.alien ; +stack-checker.recursive-state ; IN: stack-checker.known-words : infer-primitive ( word -- ) diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor new file mode 100644 index 0000000000..41d7331230 --- /dev/null +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sequences kernel sequences assocs +namespaces stack-checker.recursive-state.tree ; +IN: stack-checker.recursive-state + +TUPLE: recursive-state words word quotations inline-words ; + +C: recursive-state + +: prepare-recursive-state ( word rstate -- rstate ) + swap >>word + f >>quotations + f >>inline-words ; inline + +: initial-recursive-state ( word -- state ) + recursive-state new + f >>words + prepare-recursive-state ; inline + +f initial-recursive-state recursive-state set-global + +: add-recursive-state ( word -- rstate ) + recursive-state get clone + [ word>> dup ] keep [ store ] change-words + prepare-recursive-state ; + +: add-local-quotation ( recursive-state quot -- rstate ) + swap clone [ dupd store ] change-quotations ; + +: add-inline-word ( word label -- rstate ) + swap recursive-state get clone + [ store ] change-inline-words ; + +: recursive-word? ( word -- ? ) + recursive-state get 2dup word>> eq? + [ 2drop t ] [ words>> lookup ] if ; + +: inline-recursive-label ( word -- label/f ) + recursive-state get inline-words>> lookup ; + +: recursive-quotation? ( quot -- ? ) + recursive-state get quotations>> lookup ; diff --git a/basis/stack-checker/recursive-state/tree/tree.factor b/basis/stack-checker/recursive-state/tree/tree.factor new file mode 100644 index 0000000000..dd392af7c9 --- /dev/null +++ b/basis/stack-checker/recursive-state/tree/tree.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences math math.order ; +IN: stack-checker.recursive-state.tree + +! Persistent unbalanced hash tree using eq? comparison. +! We use this to speed up stack-checker.recursive-state. +! Perhaps this should go somewhere else + +TUPLE: node value key hashcode left right ; + +GENERIC: lookup ( key node -- value/f ) + +M: f lookup nip ; + +: decide ( key node -- key node ? ) + over hashcode over hashcode>> <= ; inline + +M: node lookup + 2dup key>> eq? + [ nip value>> ] + [ decide [ left>> ] [ right>> ] if lookup ] if ; + +GENERIC: store ( value key node -- node' ) + +M: f store drop dup hashcode f f node boa ; + +M: node store + clone decide + [ [ store ] change-left ] + [ [ store ] change-right ] if ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 177731f985..2706ec60ef 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -5,75 +5,6 @@ math effects accessors words fry classes.algebra compiler.units ; IN: stack-checker.state -! Recursive state -SYMBOL: recursive-state - -: initial-recursive-state ( word -- state ) - { } { } 3array 1array ; inline - -f initial-recursive-state recursive-state set-global - -: add-recursive-state ( word -- rstate ) - [ recursive-state get ] dip { } { } 3array prefix ; - -: add-local-quotation ( recursive-state quot -- rstate ) - [ unclip first3 swap ] dip prefix swap 3array prefix ; - -: add-local-recursive-state ( word label -- rstate ) - [ recursive-state get ] 2dip - [ unclip first3 ] 2dip 2array prefix 3array prefix ; - -: recursive-word? ( word -- ? ) - recursive-state get key? ; - -: inline-recursive-label ( word -- label/f ) - recursive-state get first third at ; - -: recursive-quotation? ( quot -- ? ) - recursive-state get first second [ eq? ] with contains? ; - -! Values -: ( -- value ) \ counter ; - -SYMBOL: known-values - -: known ( value -- known ) known-values get at ; - -: set-known ( known value -- ) - over [ known-values get set-at ] [ 2drop ] if ; - -: make-known ( known -- value ) - [ set-known ] keep ; - -: copy-value ( value -- value' ) - known make-known ; - -: copy-values ( values -- values' ) - [ copy-value ] map ; - -! Literal value -TUPLE: literal < identity-tuple value recursion ; - -: ( obj -- value ) - recursive-state get \ literal boa ; - -GENERIC: (literal) ( value -- literal ) - -M: literal (literal) ; - -: literal ( value -- literal ) - known (literal) ; - -! Result of curry -TUPLE: curried obj quot ; - -C: curried - -! Result of compose -TUPLE: composed quot1 quot2 ; - -C: composed - ! Did the current control-flow path throw an error? SYMBOL: terminated? @@ -99,9 +30,6 @@ SYMBOL: meta-r V{ } clone meta-r set 0 d-in set ; -: init-known-values ( -- ) - H{ } clone known-values set ; - ! Words that the current quotation depends on SYMBOL: dependencies diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c71337b021..e4f8c50eeb 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -5,7 +5,8 @@ namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations stack-checker.backend stack-checker.state stack-checker.visitor -stack-checker.errors ; +stack-checker.errors stack-checker.values +stack-checker.recursive-state ; IN: stack-checker.transforms : give-up-transform ( word -- ) diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor new file mode 100644 index 0000000000..97aa774e55 --- /dev/null +++ b/basis/stack-checker/values/values.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces kernel assocs sequences +stack-checker.recursive-state ; +IN: stack-checker.values + +! Values +: ( -- value ) \ counter ; + +SYMBOL: known-values + +: init-known-values ( -- ) + H{ } clone known-values set ; + +: known ( value -- known ) known-values get at ; + +: set-known ( known value -- ) + over [ known-values get set-at ] [ 2drop ] if ; + +: make-known ( known -- value ) + [ set-known ] keep ; + +: copy-value ( value -- value' ) + known make-known ; + +: copy-values ( values -- values' ) + [ copy-value ] map ; + +! Literal value +TUPLE: literal < identity-tuple value recursion hashcode ; + +M: literal hashcode* nip hashcode>> ; + +: ( obj -- value ) + recursive-state get over hashcode \ literal boa ; + +GENERIC: (literal) ( value -- literal ) + +M: literal (literal) ; + +: literal ( value -- literal ) + known (literal) ; + +! Result of curry +TUPLE: curried obj quot ; + +C: curried + +! Result of compose +TUPLE: composed quot1 quot2 ; + +C: composed From 3bb778eab4771d549e0fa7b06d2c3fd8443b850e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 00:09:47 -0600 Subject: [PATCH 03/13] Remove unnecessary stack-checker.transforms dependency from macros --- basis/macros/expander/expander.factor | 2 +- basis/macros/macros.factor | 15 ++++++--------- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index c2fceffae6..3666fa2423 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private namespaces make quotations accessors words continuations vectors effects math -generalizations stack-checker.transforms fry ; +generalizations fry ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 0a6621f044..794d523d00 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,21 +1,18 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel sequences words effects -stack-checker.transforms combinators assocs definitions -quotations namespaces memoize accessors ; +USING: parser kernel sequences words effects combinators assocs +definitions quotations namespaces memoize accessors ; IN: macros : real-macro-effect ( word -- effect' ) "declared-effect" word-prop in>> 1 ; : define-macro ( word definition -- ) - over "declared-effect" word-prop in>> length >r - 2dup "macro" set-word-prop - 2dup over real-macro-effect memoize-quot [ call ] append define - r> define-transform ; + [ "macro" set-word-prop ] + [ over real-macro-effect memoize-quot [ call ] append define ] + 2bi ; -: MACRO: - (:) define-macro ; parsing +: MACRO: (:) define-macro ; parsing PREDICATE: macro < word "macro" word-prop >boolean ; From a81e737e025e9c9e2e3f45ebe108782612149789 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 00:10:37 -0600 Subject: [PATCH 04/13] Add passociate word: like associate but for persistent hashtables --- basis/persistent/hashtables/hashtables.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index a867dbb2e3..e50fd52c10 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -53,3 +53,6 @@ M: persistent-hash clone ; M: persistent-hash pprint-delims drop \ PH{ \ } ; M: persistent-hash >pprint-sequence >alist ; M: persistent-hash pprint* pprint-object ; + +: passociate ( value key -- phash ) + T{ persistent-hash } new-at ; inline From 3f4eb5a09a4841fd4542b68b6393529d4d99cb8f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 00:10:55 -0600 Subject: [PATCH 05/13] Add changed-nth combinator: like change-nth but for persistent sequences --- basis/persistent/sequences/sequences.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/persistent/sequences/sequences.factor b/basis/persistent/sequences/sequences.factor index 961e8bfce7..5503e369b4 100644 --- a/basis/persistent/sequences/sequences.factor +++ b/basis/persistent/sequences/sequences.factor @@ -14,3 +14,6 @@ M: sequence ppop 1 head* ; GENERIC: new-nth ( val i seq -- seq' ) M: sequence new-nth clone [ set-nth ] keep ; + +: changed-nth ( i seq quot -- seq' ) + [ [ nth ] dip call ] [ drop new-nth ] 3bi ; inline From 3723b2e64046c704c73193d66a3ed078bd9808cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 00:12:14 -0600 Subject: [PATCH 06/13] vlists: immutable sequences with mostly-O(1) push and pop, O(n) behavior when sharing: optimized for the unshared case. also contains valists, which are assocs built on vlists with O(n) search starting from the end, and mostly-O(1) insertion that shadows prior entries. Behaves similar to Lisp/Scheme alists --- basis/vlists/vlists-tests.factor | 41 ++++++++++++++ basis/vlists/vlists.factor | 93 ++++++++++++++++++++++++++++++++ 2 files changed, 134 insertions(+) create mode 100644 basis/vlists/vlists-tests.factor create mode 100644 basis/vlists/vlists.factor diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor new file mode 100644 index 0000000000..3546051364 --- /dev/null +++ b/basis/vlists/vlists-tests.factor @@ -0,0 +1,41 @@ +USING: vlists kernel persistent.sequences arrays tools.test +namespaces accessors sequences assocs ; +IN: vlists.tests + +[ { "hi" "there" } ] +[ VL{ } "hi" swap ppush "there" swap ppush >array ] unit-test + +[ VL{ "hi" "there" "foo" } VL{ "hi" "there" "bar" } t ] +[ + VL{ } "hi" swap ppush "there" swap ppush "v" set + "foo" "v" get ppush + "bar" "v" get ppush + dup "baz" over ppush [ vector>> ] bi@ eq? +] unit-test + +[ "foo" VL{ "hi" "there" } t ] +[ + VL{ "hi" "there" "foo" } dup "v" set + [ peek ] [ ppop ] bi + dup "v" get [ vector>> ] bi@ eq? +] unit-test + +[ VL{ } 3 over push ] must-fail + +[ 4 VL{ "hi" } set-first ] must-fail + +[ 5 t ] [ + "rice" VA{ { "rice" 5 } { "beans" 10 } } at* +] unit-test + +[ 6 t ] [ + "rice" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at* +] unit-test + +[ 3 ] [ + VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } assoc-size +] unit-test + +[ f f ] [ + "meat" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at* +] unit-test diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor new file mode 100644 index 0000000000..e0f7e55554 --- /dev/null +++ b/basis/vlists/vlists.factor @@ -0,0 +1,93 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays accessors sequences sequences.private +persistent.sequences assocs persistent.assocs kernel math +vectors parser prettyprint.backend ; +IN: vlists + +TUPLE: vlist +{ length array-capacity read-only } +{ vector vector read-only } ; + +: ( -- vlist ) 0 V{ } clone vlist boa ; inline + +M: vlist length length>> ; + +M: vlist nth-unsafe vector>> nth-unsafe ; + +vlist< [ length>> ] [ vector>> ] bi ; inline + +: unshare ( len vec -- len vec' ) + clone [ set-length ] 2keep ; inline + +PRIVATE> + +M: vlist ppush + >vlist< + 2dup length = [ unshare ] unless + [ [ 1+ swap ] dip push ] keep vlist boa ; + +ERROR: empty-vlist-error ; + +M: vlist ppop + [ empty-vlist-error ] + [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ; + +M: vlist clone + [ length>> ] [ vector>> >vector ] bi vlist boa ; + +M: vlist equal? + over vlist? [ sequence= ] [ 2drop f ] if ; + +: >vlist ( seq -- vlist ) + [ length ] [ >vector ] bi vlist boa ; inline + +M: vlist like + drop dup vlist? [ >vlist ] unless ; + +INSTANCE: vlist immutable-sequence + +: VL{ \ } [ >vlist ] parse-literal ; parsing + +M: vlist pprint-delims drop \ VL{ \ } ; +M: vlist >pprint-sequence ; +M: vlist pprint* pprint-object ; + +TUPLE: valist { vlist vlist read-only } ; + +: ( -- valist ) valist boa ; inline + +M: valist assoc-size vlist>> length 2/ ; + +: valist-at ( key i array -- value ? ) + over 0 >= [ + 3dup nth-unsafe = [ + [ 1+ ] dip nth-unsafe nip t + ] [ + [ 2 - ] dip valist-at + ] if + ] [ 3drop f f ] if ; inline recursive + +M: valist at* + vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ; + +M: valist new-at + vlist>> ppush ppush valist boa ; + +M: valist >alist vlist>> ; + +: >valist ( assoc -- valist ) + >alist concat >vlist valist boa ; inline + +M: valist assoc-like + drop dup valist? [ >valist ] unless ; + +INSTANCE: valist assoc + +: VA{ \ } [ >valist ] parse-literal ; parsing + +M: valist pprint-delims drop \ VA{ \ } ; +M: valist >pprint-sequence >alist ; +M: valist pprint* pprint-object ; From cfa82cb4746078f042c1d190867937d3ce1a0eb7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 03:20:34 -0600 Subject: [PATCH 07/13] New calling convention for VM primitives: instead of the Factor side passing the stack pointer as the first parameter, and having the VM save it to stack_chain->top, we instead have the Factor side save it. Eliminates a lot of crud in the VM --- basis/bootstrap/image/image.factor | 3 + basis/cpu/ppc/bootstrap.factor | 7 +- basis/cpu/x86/32/bootstrap.factor | 11 +++- basis/cpu/x86/64/bootstrap.factor | 13 +++- basis/cpu/x86/bootstrap.factor | 6 -- vm/alien.c | 16 ++--- vm/alien.h | 64 +++++++++--------- vm/callstack.c | 17 ++--- vm/callstack.h | 17 +++-- vm/code_gc.c | 2 +- vm/code_gc.h | 2 +- vm/code_heap.c | 6 +- vm/code_heap.h | 8 ++- vm/data_gc.c | 18 +++--- vm/data_gc.h | 18 +++--- vm/debug.c | 2 +- vm/debug.h | 2 +- vm/errors.c | 6 +- vm/errors.h | 8 +-- vm/image.c | 4 +- vm/image.h | 4 +- vm/io.c | 14 ++-- vm/io.h | 20 +++--- vm/math.c | 98 ++++++++++++++-------------- vm/math.h | 100 ++++++++++++++--------------- vm/os-unix.c | 2 +- vm/os-windows-ce.c | 2 +- vm/os-windows.c | 2 +- vm/primitives.h | 41 ------------ vm/profiler.c | 2 +- vm/profiler.h | 2 +- vm/quotations.c | 6 +- vm/quotations.h | 4 +- vm/run.c | 20 +++--- vm/run.h | 28 ++++---- vm/types.c | 30 ++++----- vm/types.h | 30 ++++----- 37 files changed, 308 insertions(+), 327 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 8b0051148f..c0fafdc0f5 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -134,6 +134,7 @@ SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling SYMBOL: jit-declare-word +SYMBOL: jit-save-stack ! Default definition for undefined words SYMBOL: undefined-quot @@ -158,6 +159,7 @@ SYMBOL: undefined-quot { jit-profiling 35 } { jit-push-immediate 36 } { jit-declare-word 42 } + { jit-save-stack 43 } { undefined-quot 60 } } at header-size + ; @@ -459,6 +461,7 @@ M: quotation ' jit-return jit-profiling jit-declare-word + jit-save-stack undefined-quot } [ emit-userenv ] each ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 9bf88185c5..8809311f21 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -57,7 +57,12 @@ big-endian on [ 0 6 LOAD32 - 4 1 MR + 7 6 0 LWZ + 1 7 0 STW +] rc-absolute-ppc-2/2 rt-primitive 1 jit-save-stack jit-define + +[ + 0 6 LOAD32 6 MTCTR BCTR ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 44f840e66a..ba963ab477 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs parser ; +cpu.x86.assembler layouts vocabs parser compiler.constants ; IN: bootstrap.x86 4 \ cell set @@ -19,5 +19,14 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) arg0 1 SAR ; : rex-length ( -- n ) 0 ; +[ + arg0 0 [] MOV ! load stack_chain + arg0 [] stack-reg MOV ! save stack pointer +] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define + +[ + (JMP) drop +] rc-relative rt-primitive 1 jit-primitive jit-define + << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index acac8b55bc..83a72d6dd3 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs parser ; +cpu.x86.assembler layouts vocabs parser compiler.constants math ; IN: bootstrap.x86 8 \ cell set @@ -16,5 +16,16 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) ; : rex-length ( -- n ) 1 ; +[ + arg0 0 MOV ! load stack_chain + arg0 arg0 [] MOV + arg0 [] stack-reg MOV ! save stack pointer +] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define + +[ + arg1 0 MOV ! load XT + arg1 JMP ! go +] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define + << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 6dadbc096c..1ee74a434b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -44,12 +44,6 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define -[ - arg0 0 MOV ! load XT - arg1 stack-reg MOV ! pass callstack pointer as arg 2 - arg0 JMP ! go -] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define - [ (JMP) drop ] rc-relative rt-xt 1 jit-word-jump jit-define diff --git a/vm/alien.c b/vm/alien.c index 5b4ff3b832..8b7df45e9a 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -82,7 +82,7 @@ void box_alien(void *ptr) } /* make an alien pointing at an offset of another alien */ -DEFINE_PRIMITIVE(displaced_alien) +void primitive_displaced_alien(void) { CELL alien = dpop(); CELL displacement = to_cell(dpop()); @@ -107,7 +107,7 @@ DEFINE_PRIMITIVE(displaced_alien) /* address of an object representing a C pointer. Explicitly throw an error if the object is a byte array, as a sanity check. */ -DEFINE_PRIMITIVE(alien_address) +void primitive_alien_address(void) { box_unsigned_cell((CELL)pinned_alien_offset(dpop())); } @@ -121,11 +121,11 @@ INLINE void *alien_pointer(void) /* define words to read/write values at an alien address */ #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ - DEFINE_PRIMITIVE(alien_##name) \ + void primitive_alien_##name(void) \ { \ boxer(*(type*)alien_pointer()); \ } \ - DEFINE_PRIMITIVE(set_alien_##name) \ + void primitive_set_alien_##name(void) \ { \ type* ptr = alien_pointer(); \ type value = to(dpop()); \ @@ -170,7 +170,7 @@ void box_small_struct(CELL x, CELL y, CELL size) } /* open a native library and push a handle */ -DEFINE_PRIMITIVE(dlopen) +void primitive_dlopen(void) { CELL path = tag_object(string_to_native_alien( untag_string(dpop()))); @@ -183,7 +183,7 @@ DEFINE_PRIMITIVE(dlopen) } /* look up a symbol in a native library */ -DEFINE_PRIMITIVE(dlsym) +void primitive_dlsym(void) { CELL dll = dpop(); REGISTER_ROOT(dll); @@ -205,12 +205,12 @@ DEFINE_PRIMITIVE(dlsym) } /* close a native library handle */ -DEFINE_PRIMITIVE(dlclose) +void primitive_dlclose(void) { ffi_dlclose(untag_dll(dpop())); } -DEFINE_PRIMITIVE(dll_validp) +void primitive_dll_validp(void) { CELL dll = dpop(); if(dll == F) diff --git a/vm/alien.h b/vm/alien.h index babfbc358d..ec1eb08acf 100755 --- a/vm/alien.h +++ b/vm/alien.h @@ -1,7 +1,7 @@ CELL allot_alien(CELL delegate, CELL displacement); -DECLARE_PRIMITIVE(displaced_alien); -DECLARE_PRIMITIVE(alien_address); +void primitive_displaced_alien(void); +void primitive_alien_address(void); DLLEXPORT void *alien_offset(CELL object); @@ -10,32 +10,32 @@ void fixup_alien(F_ALIEN* d); DLLEXPORT void *unbox_alien(void); DLLEXPORT void box_alien(void *ptr); -DECLARE_PRIMITIVE(alien_signed_cell); -DECLARE_PRIMITIVE(set_alien_signed_cell); -DECLARE_PRIMITIVE(alien_unsigned_cell); -DECLARE_PRIMITIVE(set_alien_unsigned_cell); -DECLARE_PRIMITIVE(alien_signed_8); -DECLARE_PRIMITIVE(set_alien_signed_8); -DECLARE_PRIMITIVE(alien_unsigned_8); -DECLARE_PRIMITIVE(set_alien_unsigned_8); -DECLARE_PRIMITIVE(alien_signed_4); -DECLARE_PRIMITIVE(set_alien_signed_4); -DECLARE_PRIMITIVE(alien_unsigned_4); -DECLARE_PRIMITIVE(set_alien_unsigned_4); -DECLARE_PRIMITIVE(alien_signed_2); -DECLARE_PRIMITIVE(set_alien_signed_2); -DECLARE_PRIMITIVE(alien_unsigned_2); -DECLARE_PRIMITIVE(set_alien_unsigned_2); -DECLARE_PRIMITIVE(alien_signed_1); -DECLARE_PRIMITIVE(set_alien_signed_1); -DECLARE_PRIMITIVE(alien_unsigned_1); -DECLARE_PRIMITIVE(set_alien_unsigned_1); -DECLARE_PRIMITIVE(alien_float); -DECLARE_PRIMITIVE(set_alien_float); -DECLARE_PRIMITIVE(alien_double); -DECLARE_PRIMITIVE(set_alien_double); -DECLARE_PRIMITIVE(alien_cell); -DECLARE_PRIMITIVE(set_alien_cell); +void primitive_alien_signed_cell(void); +void primitive_set_alien_signed_cell(void); +void primitive_alien_unsigned_cell(void); +void primitive_set_alien_unsigned_cell(void); +void primitive_alien_signed_8(void); +void primitive_set_alien_signed_8(void); +void primitive_alien_unsigned_8(void); +void primitive_set_alien_unsigned_8(void); +void primitive_alien_signed_4(void); +void primitive_set_alien_signed_4(void); +void primitive_alien_unsigned_4(void); +void primitive_set_alien_unsigned_4(void); +void primitive_alien_signed_2(void); +void primitive_set_alien_signed_2(void); +void primitive_alien_unsigned_2(void); +void primitive_set_alien_unsigned_2(void); +void primitive_alien_signed_1(void); +void primitive_set_alien_signed_1(void); +void primitive_alien_unsigned_1(void); +void primitive_set_alien_unsigned_1(void); +void primitive_alien_float(void); +void primitive_set_alien_float(void); +void primitive_alien_double(void); +void primitive_set_alien_double(void); +void primitive_alien_cell(void); +void primitive_set_alien_cell(void); DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); DLLEXPORT void box_value_struct(void *src, CELL size); @@ -43,7 +43,7 @@ DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) -DECLARE_PRIMITIVE(dlopen); -DECLARE_PRIMITIVE(dlsym); -DECLARE_PRIMITIVE(dlclose); -DECLARE_PRIMITIVE(dll_validp); +void primitive_dlopen(void); +void primitive_dlsym(void); +void primitive_dlclose(void); +void primitive_dll_validp(void); diff --git a/vm/callstack.c b/vm/callstack.c index b7e99b418c..dfa7dd5f4a 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -6,11 +6,6 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) stack_chain->callstack_bottom = callstack_bottom; } -F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top) -{ - stack_chain->callstack_top = callstack_top; -} - void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) { F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; @@ -68,7 +63,7 @@ F_STACK_FRAME *capture_start(void) return frame + 1; } -DEFINE_PRIMITIVE(callstack) +void primitive_callstack(void) { F_STACK_FRAME *top = capture_start(); F_STACK_FRAME *bottom = stack_chain->callstack_bottom; @@ -82,7 +77,7 @@ DEFINE_PRIMITIVE(callstack) dpush(tag_object(callstack)); } -DEFINE_PRIMITIVE(set_callstack) +void primitive_set_callstack(void) { F_CALLSTACK *stack = untag_callstack(dpop()); @@ -158,7 +153,7 @@ void stack_frame_to_array(F_STACK_FRAME *frame) set_array_nth(array,frame_index++,frame_scan(frame)); } -DEFINE_PRIMITIVE(callstack_to_array) +void primitive_callstack_to_array(void) { F_CALLSTACK *stack = untag_callstack(dpop()); @@ -190,7 +185,7 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) /* Some primitives implementing a limited form of callstack mutation. Used by the single stepper. */ -DEFINE_PRIMITIVE(innermost_stack_frame_quot) +void primitive_innermost_stack_frame_quot(void) { F_STACK_FRAME *inner = innermost_stack_frame( untag_callstack(dpop())); @@ -199,7 +194,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_quot) dpush(frame_executing(inner)); } -DEFINE_PRIMITIVE(innermost_stack_frame_scan) +void primitive_innermost_stack_frame_scan(void) { F_STACK_FRAME *inner = innermost_stack_frame( untag_callstack(dpop())); @@ -208,7 +203,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_scan) dpush(frame_scan(inner)); } -DEFINE_PRIMITIVE(set_innermost_stack_frame_quot) +void primitive_set_innermost_stack_frame_quot(void) { F_CALLSTACK *callstack = untag_callstack(dpop()); F_QUOTATION *quot = untag_quotation(dpop()); diff --git a/vm/callstack.h b/vm/callstack.h index 6c38cd0117..da0748b071 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -1,5 +1,4 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); -F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) @@ -14,11 +13,11 @@ CELL frame_executing(F_STACK_FRAME *frame); CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); -DECLARE_PRIMITIVE(callstack); -DECLARE_PRIMITIVE(set_datastack); -DECLARE_PRIMITIVE(set_retainstack); -DECLARE_PRIMITIVE(set_callstack); -DECLARE_PRIMITIVE(callstack_to_array); -DECLARE_PRIMITIVE(innermost_stack_frame_quot); -DECLARE_PRIMITIVE(innermost_stack_frame_scan); -DECLARE_PRIMITIVE(set_innermost_stack_frame_quot); +void primitive_callstack(void); +void primitive_set_datastack(void); +void primitive_set_retainstack(void); +void primitive_set_callstack(void); +void primitive_callstack_to_array(void); +void primitive_innermost_stack_frame_quot(void); +void primitive_innermost_stack_frame_scan(void); +void primitive_set_innermost_stack_frame_quot(void); diff --git a/vm/code_gc.c b/vm/code_gc.c index 03661999c5..bd6384408b 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -295,7 +295,7 @@ void recursive_mark(F_BLOCK *block) } /* Push the free space and total size of the code heap */ -DEFINE_PRIMITIVE(code_room) +void primitive_code_room(void) { CELL used, total_free, max_free; heap_usage(&code_heap,&used,&total_free,&max_free); diff --git a/vm/code_gc.h b/vm/code_gc.h index f93cba9c7a..72ad8d451c 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -82,4 +82,4 @@ void recursive_mark(F_BLOCK *block); void dump_heap(F_HEAP *heap); void compact_code_heap(void); -DECLARE_PRIMITIVE(code_room); +void primitive_code_room(void); diff --git a/vm/code_heap.c b/vm/code_heap.c index 1435caa9d2..2268df27e3 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -68,9 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_XT: return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; case RT_HERE: - return rel->offset + code_start; + return rel->offset + code_start + (short)REL_ARGUMENT(rel); case RT_LABEL: return code_start + REL_ARGUMENT(rel); + case RT_STACK_CHAIN: + return (CELL)&stack_chain; default: critical_error("Bad rel type",rel->type); return -1; /* Can't happen */ @@ -322,7 +324,7 @@ void default_word_code(F_WORD *word, bool relocate) word->compiledp = F; } -DEFINE_PRIMITIVE(modify_code_heap) +void primitive_modify_code_heap(void) { bool rescan_code_heap = to_boolean(dpop()); F_ARRAY *alist = untag_array(dpop()); diff --git a/vm/code_heap.h b/vm/code_heap.h index c3b476c4b5..7b1545ddf5 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -13,8 +13,10 @@ typedef enum { RT_HERE, /* a local label */ RT_LABEL, - /* immeditae literal */ - RT_IMMEDIATE + /* immediate literal */ + RT_IMMEDIATE, + /* address of stack_chain var */ + RT_STACK_CHAIN } F_RELTYPE; typedef enum { @@ -71,4 +73,4 @@ F_COMPILED *add_compiled_block( CELL compiled_code_format(void); bool stack_traces_p(void); -DECLARE_PRIMITIVE(modify_code_heap); +void primitive_modify_code_heap(void); diff --git a/vm/data_gc.c b/vm/data_gc.c index 5342ff04d9..cf1632811c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -250,13 +250,13 @@ CELL unaligned_object_size(CELL pointer) } } -DEFINE_PRIMITIVE(size) +void primitive_size(void) { box_unsigned_cell(object_size(dpop())); } /* Push memory usage statistics in data heap */ -DEFINE_PRIMITIVE(data_room) +void primitive_data_room(void) { F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F); int gen; @@ -281,7 +281,7 @@ void begin_scan(void) gc_off = true; } -DEFINE_PRIMITIVE(begin_scan) +void primitive_begin_scan(void) { gc(); begin_scan(); @@ -306,13 +306,13 @@ CELL next_object(void) } /* Push object at heap scan cursor and advance; pushes f when done */ -DEFINE_PRIMITIVE(next_object) +void primitive_next_object(void) { dpush(next_object()); } /* Re-enables GC */ -DEFINE_PRIMITIVE(end_scan) +void primitive_end_scan(void) { gc_off = false; } @@ -911,12 +911,12 @@ void minor_gc(void) garbage_collection(NURSERY,false,0); } -DEFINE_PRIMITIVE(gc) +void primitive_gc(void) { gc(); } -DEFINE_PRIMITIVE(gc_stats) +void primitive_gc_stats(void) { GROWABLE_ARRAY(stats); @@ -945,12 +945,12 @@ DEFINE_PRIMITIVE(gc_stats) dpush(stats); } -DEFINE_PRIMITIVE(gc_reset) +void primitive_gc_reset(void) { gc_reset(); } -DEFINE_PRIMITIVE(become) +void primitive_become(void) { F_ARRAY *new_objects = untag_array(dpop()); F_ARRAY *old_objects = untag_array(dpop()); diff --git a/vm/data_gc.h b/vm/data_gc.h index 3c21695c2c..0d63cc6bfe 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -13,11 +13,11 @@ CELL binary_payload_start(CELL pointer); void begin_scan(void); CELL next_object(void); -DECLARE_PRIMITIVE(data_room); -DECLARE_PRIMITIVE(size); -DECLARE_PRIMITIVE(begin_scan); -DECLARE_PRIMITIVE(next_object); -DECLARE_PRIMITIVE(end_scan); +void primitive_data_room(void); +void primitive_size(void); +void primitive_begin_scan(void); +void primitive_next_object(void); +void primitive_end_scan(void); void gc(void); DLLEXPORT void minor_gc(void); @@ -388,9 +388,9 @@ INLINE void* allot_object(CELL type, CELL a) CELL collect_next(CELL scan); -DECLARE_PRIMITIVE(gc); -DECLARE_PRIMITIVE(gc_stats); -DECLARE_PRIMITIVE(gc_reset); -DECLARE_PRIMITIVE(become); +void primitive_gc(void); +void primitive_gc_stats(void); +void primitive_gc_reset(void); +void primitive_become(void); CELL find_all_words(void); diff --git a/vm/debug.c b/vm/debug.c index 2550931c72..41205d4aff 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -474,7 +474,7 @@ void factorbug(void) } } -DEFINE_PRIMITIVE(die) +void primitive_die(void) { fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n"); fprintf(stderr,"you have triggered a bug in Factor. Please report.\n"); diff --git a/vm/debug.h b/vm/debug.h index 547fdba436..594d8ec919 100755 --- a/vm/debug.h +++ b/vm/debug.h @@ -6,4 +6,4 @@ void dump_zone(F_ZONE *z); bool fep_disabled; -DECLARE_PRIMITIVE(die); +void primitive_die(void); diff --git a/vm/errors.c b/vm/errors.c index 36072920fe..fe6e79be6d 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -142,19 +142,19 @@ void misc_signal_handler_impl(void) signal_error(signal_number,signal_callstack_top); } -DEFINE_PRIMITIVE(throw) +void primitive_throw(void) { dpop(); throw_impl(dpop(),stack_chain->callstack_top); } -DEFINE_PRIMITIVE(call_clear) +void primitive_call_clear(void) { throw_impl(dpop(),stack_chain->callstack_bottom); } /* For testing purposes */ -DEFINE_PRIMITIVE(unimplemented) +void primitive_unimplemented(void) { not_implemented_error(); } diff --git a/vm/errors.h b/vm/errors.h index 22cd6533c3..c7f8bc8712 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -22,7 +22,7 @@ typedef enum void out_of_memory(void); void fatal_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged); -DECLARE_PRIMITIVE(die); +void primitive_die(void); void throw_error(CELL error, F_STACK_FRAME *native_stack); void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); @@ -32,8 +32,8 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -DECLARE_PRIMITIVE(throw); -DECLARE_PRIMITIVE(call_clear); +void primitive_throw(void); +void primitive_call_clear(void); INLINE void type_check(CELL type, CELL tagged) { @@ -57,4 +57,4 @@ void memory_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); -DECLARE_PRIMITIVE(unimplemented); +void primitive_unimplemented(void); diff --git a/vm/image.c b/vm/image.c index 62f9e1c906..289c1e94c8 100755 --- a/vm/image.c +++ b/vm/image.c @@ -161,7 +161,7 @@ bool save_image(const F_CHAR *filename) return true; } -DEFINE_PRIMITIVE(save_image) +void primitive_save_image(void) { /* do a full GC to push everything into tenured space */ gc(); @@ -184,7 +184,7 @@ void strip_compiled_quotations(void) gc_off = false; } -DEFINE_PRIMITIVE(save_image_and_exit) +void primitive_save_image_and_exit(void) { /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since diff --git a/vm/image.h b/vm/image.h index 9e582fc6c6..6e1b03af0d 100755 --- a/vm/image.h +++ b/vm/image.h @@ -40,8 +40,8 @@ void load_image(F_PARAMETERS *p); void init_objects(F_HEADER *h); bool save_image(const F_CHAR *file); -DECLARE_PRIMITIVE(save_image); -DECLARE_PRIMITIVE(save_image_and_exit); +void primitive_save_image(void); +void primitive_save_image_and_exit(void); /* relocation base of currently loaded image's data heap */ CELL data_relocation_base; diff --git a/vm/io.c b/vm/io.c index bc561f5e5b..bad4854775 100755 --- a/vm/io.c +++ b/vm/io.c @@ -29,7 +29,7 @@ void io_error(void) general_error(ERROR_IO,error,F,NULL); } -DEFINE_PRIMITIVE(fopen) +void primitive_fopen(void) { char *mode = unbox_char_string(); REGISTER_C_STRING(mode); @@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fopen) } } -DEFINE_PRIMITIVE(fgetc) +void primitive_fgetc(void) { FILE* file = unbox_alien(); @@ -74,7 +74,7 @@ DEFINE_PRIMITIVE(fgetc) } } -DEFINE_PRIMITIVE(fread) +void primitive_fread(void) { FILE* file = unbox_alien(); CELL size = unbox_array_size(); @@ -116,7 +116,7 @@ DEFINE_PRIMITIVE(fread) } } -DEFINE_PRIMITIVE(fputc) +void primitive_fputc(void) { FILE *file = unbox_alien(); F_FIXNUM ch = to_fixnum(dpop()); @@ -134,7 +134,7 @@ DEFINE_PRIMITIVE(fputc) } } -DEFINE_PRIMITIVE(fwrite) +void primitive_fwrite(void) { FILE *file = unbox_alien(); F_BYTE_ARRAY *text = untag_byte_array(dpop()); @@ -163,7 +163,7 @@ DEFINE_PRIMITIVE(fwrite) } } -DEFINE_PRIMITIVE(fflush) +void primitive_fflush(void) { FILE *file = unbox_alien(); for(;;) @@ -175,7 +175,7 @@ DEFINE_PRIMITIVE(fflush) } } -DEFINE_PRIMITIVE(fclose) +void primitive_fclose(void) { FILE *file = unbox_alien(); for(;;) diff --git a/vm/io.h b/vm/io.h index f4af9b8bec..08c9dd7807 100755 --- a/vm/io.h +++ b/vm/io.h @@ -3,15 +3,15 @@ void io_error(void); int err_no(void); void clear_err_no(void); -DECLARE_PRIMITIVE(fopen); -DECLARE_PRIMITIVE(fgetc); -DECLARE_PRIMITIVE(fread); -DECLARE_PRIMITIVE(fputc); -DECLARE_PRIMITIVE(fwrite); -DECLARE_PRIMITIVE(fflush); -DECLARE_PRIMITIVE(fclose); +void primitive_fopen(void); +void primitive_fgetc(void); +void primitive_fread(void); +void primitive_fputc(void); +void primitive_fwrite(void); +void primitive_fflush(void); +void primitive_fclose(void); /* Platform specific primitives */ -DECLARE_PRIMITIVE(open_file); -DECLARE_PRIMITIVE(existsp); -DECLARE_PRIMITIVE(read_dir); +void primitive_open_file(void); +void primitive_existsp(void); +void primitive_read_dir(void); diff --git a/vm/math.c b/vm/math.c index 7d3b64ed39..388a472f2e 100644 --- a/vm/math.c +++ b/vm/math.c @@ -21,12 +21,12 @@ CELL to_cell(CELL tagged) return (CELL)to_fixnum(tagged); } -DEFINE_PRIMITIVE(bignum_to_fixnum) +void primitive_bignum_to_fixnum(void) { drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek())))); } -DEFINE_PRIMITIVE(float_to_fixnum) +void primitive_float_to_fixnum(void) { drepl(tag_fixnum(float_to_fixnum(dpeek()))); } @@ -35,13 +35,13 @@ DEFINE_PRIMITIVE(float_to_fixnum) F_FIXNUM y = untag_fixnum_fast(dpop()); \ F_FIXNUM x = untag_fixnum_fast(dpop()); -DEFINE_PRIMITIVE(fixnum_add) +void primitive_fixnum_add(void) { POP_FIXNUMS(x,y) box_signed_cell(x + y); } -DEFINE_PRIMITIVE(fixnum_subtract) +void primitive_fixnum_subtract(void) { POP_FIXNUMS(x,y) box_signed_cell(x - y); @@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fixnum_subtract) /* Multiply two integers, and trap overflow. Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */ -DEFINE_PRIMITIVE(fixnum_multiply) +void primitive_fixnum_multiply(void) { POP_FIXNUMS(x,y) @@ -72,13 +72,13 @@ DEFINE_PRIMITIVE(fixnum_multiply) } } -DEFINE_PRIMITIVE(fixnum_divint) +void primitive_fixnum_divint(void) { POP_FIXNUMS(x,y) box_signed_cell(x / y); } -DEFINE_PRIMITIVE(fixnum_divmod) +void primitive_fixnum_divmod(void) { POP_FIXNUMS(x,y) box_signed_cell(x / y); @@ -90,7 +90,7 @@ DEFINE_PRIMITIVE(fixnum_divmod) * If we're shifting right by n bits, we won't overflow as long as none of the * high WORD_SIZE-TAG_BITS-n bits are set. */ -DEFINE_PRIMITIVE(fixnum_shift) +void primitive_fixnum_shift(void) { POP_FIXNUMS(x,y) @@ -122,12 +122,12 @@ DEFINE_PRIMITIVE(fixnum_shift) } /* Bignums */ -DEFINE_PRIMITIVE(fixnum_to_bignum) +void primitive_fixnum_to_bignum(void) { drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek())))); } -DEFINE_PRIMITIVE(float_to_bignum) +void primitive_float_to_bignum(void) { drepl(tag_bignum(float_to_bignum(dpeek()))); } @@ -136,37 +136,37 @@ DEFINE_PRIMITIVE(float_to_bignum) F_ARRAY *y = untag_object(dpop()); \ F_ARRAY *x = untag_object(dpop()); -DEFINE_PRIMITIVE(bignum_eq) +void primitive_bignum_eq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_equal_p(x,y)); } -DEFINE_PRIMITIVE(bignum_add) +void primitive_bignum_add(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_add(x,y))); } -DEFINE_PRIMITIVE(bignum_subtract) +void primitive_bignum_subtract(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_subtract(x,y))); } -DEFINE_PRIMITIVE(bignum_multiply) +void primitive_bignum_multiply(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_multiply(x,y))); } -DEFINE_PRIMITIVE(bignum_divint) +void primitive_bignum_divint(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_quotient(x,y))); } -DEFINE_PRIMITIVE(bignum_divmod) +void primitive_bignum_divmod(void) { F_ARRAY *q, *r; POP_BIGNUMS(x,y); @@ -175,74 +175,74 @@ DEFINE_PRIMITIVE(bignum_divmod) dpush(tag_bignum(r)); } -DEFINE_PRIMITIVE(bignum_mod) +void primitive_bignum_mod(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_remainder(x,y))); } -DEFINE_PRIMITIVE(bignum_and) +void primitive_bignum_and(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_and(x,y))); } -DEFINE_PRIMITIVE(bignum_or) +void primitive_bignum_or(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_ior(x,y))); } -DEFINE_PRIMITIVE(bignum_xor) +void primitive_bignum_xor(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_xor(x,y))); } -DEFINE_PRIMITIVE(bignum_shift) +void primitive_bignum_shift(void) { F_FIXNUM y = to_fixnum(dpop()); F_ARRAY* x = untag_object(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); } -DEFINE_PRIMITIVE(bignum_less) +void primitive_bignum_less(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_less); } -DEFINE_PRIMITIVE(bignum_lesseq) +void primitive_bignum_lesseq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_greater); } -DEFINE_PRIMITIVE(bignum_greater) +void primitive_bignum_greater(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_greater); } -DEFINE_PRIMITIVE(bignum_greatereq) +void primitive_bignum_greatereq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_less); } -DEFINE_PRIMITIVE(bignum_not) +void primitive_bignum_not(void) { drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek())))); } -DEFINE_PRIMITIVE(bignum_bitp) +void primitive_bignum_bitp(void) { F_FIXNUM bit = to_fixnum(dpop()); F_ARRAY *x = untag_object(dpop()); box_boolean(bignum_logbitp(bit,x)); } -DEFINE_PRIMITIVE(bignum_log2) +void primitive_bignum_log2(void) { drepl(tag_bignum(bignum_integer_length(untag_object(dpeek())))); } @@ -253,7 +253,7 @@ unsigned int bignum_producer(unsigned int digit) return *(ptr + digit); } -DEFINE_PRIMITIVE(byte_array_to_bignum) +void primitive_byte_array_to_bignum(void) { type_check(BYTE_ARRAY_TYPE,dpeek()); CELL n_digits = array_capacity(untag_object(dpeek())); @@ -383,7 +383,7 @@ CELL unbox_array_size(void) /* Does not reduce to lowest terms, so should only be used by math library implementation, to avoid breaking invariants. */ -DEFINE_PRIMITIVE(from_fraction) +void primitive_from_fraction(void) { F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO)); ratio->denominator = dpop(); @@ -392,17 +392,17 @@ DEFINE_PRIMITIVE(from_fraction) } /* Floats */ -DEFINE_PRIMITIVE(fixnum_to_float) +void primitive_fixnum_to_float(void) { drepl(allot_float(fixnum_to_float(dpeek()))); } -DEFINE_PRIMITIVE(bignum_to_float) +void primitive_bignum_to_float(void) { drepl(allot_float(bignum_to_float(dpeek()))); } -DEFINE_PRIMITIVE(str_to_float) +void primitive_str_to_float(void) { char *c_str, *end; double f; @@ -418,7 +418,7 @@ DEFINE_PRIMITIVE(str_to_float) drepl(allot_float(f)); } -DEFINE_PRIMITIVE(float_to_str) +void primitive_float_to_str(void) { char tmp[33]; snprintf(tmp,32,"%.16g",untag_float(dpop())); @@ -430,82 +430,82 @@ DEFINE_PRIMITIVE(float_to_str) double y = untag_float_fast(dpop()); \ double x = untag_float_fast(dpop()); -DEFINE_PRIMITIVE(float_eq) +void primitive_float_eq(void) { POP_FLOATS(x,y); box_boolean(x == y); } -DEFINE_PRIMITIVE(float_add) +void primitive_float_add(void) { POP_FLOATS(x,y); box_double(x + y); } -DEFINE_PRIMITIVE(float_subtract) +void primitive_float_subtract(void) { POP_FLOATS(x,y); box_double(x - y); } -DEFINE_PRIMITIVE(float_multiply) +void primitive_float_multiply(void) { POP_FLOATS(x,y); box_double(x * y); } -DEFINE_PRIMITIVE(float_divfloat) +void primitive_float_divfloat(void) { POP_FLOATS(x,y); box_double(x / y); } -DEFINE_PRIMITIVE(float_mod) +void primitive_float_mod(void) { POP_FLOATS(x,y); box_double(fmod(x,y)); } -DEFINE_PRIMITIVE(float_less) +void primitive_float_less(void) { POP_FLOATS(x,y); box_boolean(x < y); } -DEFINE_PRIMITIVE(float_lesseq) +void primitive_float_lesseq(void) { POP_FLOATS(x,y); box_boolean(x <= y); } -DEFINE_PRIMITIVE(float_greater) +void primitive_float_greater(void) { POP_FLOATS(x,y); box_boolean(x > y); } -DEFINE_PRIMITIVE(float_greatereq) +void primitive_float_greatereq(void) { POP_FLOATS(x,y); box_boolean(x >= y); } -DEFINE_PRIMITIVE(float_bits) +void primitive_float_bits(void) { box_unsigned_4(float_bits(untag_float(dpop()))); } -DEFINE_PRIMITIVE(bits_float) +void primitive_bits_float(void) { box_float(bits_float(to_cell(dpop()))); } -DEFINE_PRIMITIVE(double_bits) +void primitive_double_bits(void) { box_unsigned_8(double_bits(untag_float(dpop()))); } -DEFINE_PRIMITIVE(bits_double) +void primitive_bits_double(void) { box_double(bits_double(to_unsigned_8(dpop()))); } @@ -532,7 +532,7 @@ void box_double(double flo) /* Complex numbers */ -DEFINE_PRIMITIVE(from_rect) +void primitive_from_rect(void) { F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); complex->imaginary = dpop(); diff --git a/vm/math.h b/vm/math.h index 07d7fa9199..4fa3c8d35f 100644 --- a/vm/math.h +++ b/vm/math.h @@ -6,15 +6,15 @@ DLLEXPORT F_FIXNUM to_fixnum(CELL tagged); DLLEXPORT CELL to_cell(CELL tagged); -DECLARE_PRIMITIVE(bignum_to_fixnum); -DECLARE_PRIMITIVE(float_to_fixnum); +void primitive_bignum_to_fixnum(void); +void primitive_float_to_fixnum(void); -DECLARE_PRIMITIVE(fixnum_add); -DECLARE_PRIMITIVE(fixnum_subtract); -DECLARE_PRIMITIVE(fixnum_multiply); -DECLARE_PRIMITIVE(fixnum_divint); -DECLARE_PRIMITIVE(fixnum_divmod); -DECLARE_PRIMITIVE(fixnum_shift); +void primitive_fixnum_add(void); +void primitive_fixnum_subtract(void); +void primitive_fixnum_multiply(void); +void primitive_fixnum_divint(void); +void primitive_fixnum_divmod(void); +void primitive_fixnum_shift(void); CELL bignum_zero; CELL bignum_pos_one; @@ -25,27 +25,27 @@ INLINE CELL tag_bignum(F_ARRAY* bignum) return RETAG(bignum,BIGNUM_TYPE); } -DECLARE_PRIMITIVE(fixnum_to_bignum); -DECLARE_PRIMITIVE(float_to_bignum); -DECLARE_PRIMITIVE(bignum_eq); -DECLARE_PRIMITIVE(bignum_add); -DECLARE_PRIMITIVE(bignum_subtract); -DECLARE_PRIMITIVE(bignum_multiply); -DECLARE_PRIMITIVE(bignum_divint); -DECLARE_PRIMITIVE(bignum_divmod); -DECLARE_PRIMITIVE(bignum_mod); -DECLARE_PRIMITIVE(bignum_and); -DECLARE_PRIMITIVE(bignum_or); -DECLARE_PRIMITIVE(bignum_xor); -DECLARE_PRIMITIVE(bignum_shift); -DECLARE_PRIMITIVE(bignum_less); -DECLARE_PRIMITIVE(bignum_lesseq); -DECLARE_PRIMITIVE(bignum_greater); -DECLARE_PRIMITIVE(bignum_greatereq); -DECLARE_PRIMITIVE(bignum_not); -DECLARE_PRIMITIVE(bignum_bitp); -DECLARE_PRIMITIVE(bignum_log2); -DECLARE_PRIMITIVE(byte_array_to_bignum); +void primitive_fixnum_to_bignum(void); +void primitive_float_to_bignum(void); +void primitive_bignum_eq(void); +void primitive_bignum_add(void); +void primitive_bignum_subtract(void); +void primitive_bignum_multiply(void); +void primitive_bignum_divint(void); +void primitive_bignum_divmod(void); +void primitive_bignum_mod(void); +void primitive_bignum_and(void); +void primitive_bignum_or(void); +void primitive_bignum_xor(void); +void primitive_bignum_shift(void); +void primitive_bignum_less(void); +void primitive_bignum_lesseq(void); +void primitive_bignum_greater(void); +void primitive_bignum_greatereq(void); +void primitive_bignum_not(void); +void primitive_bignum_bitp(void); +void primitive_bignum_log2(void); +void primitive_byte_array_to_bignum(void); INLINE CELL allot_integer(F_FIXNUM x) { @@ -80,7 +80,7 @@ DLLEXPORT u64 to_unsigned_8(CELL obj); CELL unbox_array_size(void); -DECLARE_PRIMITIVE(from_fraction); +void primitive_from_fraction(void); INLINE double untag_float_fast(CELL tagged) { @@ -125,26 +125,26 @@ DLLEXPORT float to_float(CELL value); DLLEXPORT void box_double(double flo); DLLEXPORT double to_double(CELL value); -DECLARE_PRIMITIVE(fixnum_to_float); -DECLARE_PRIMITIVE(bignum_to_float); -DECLARE_PRIMITIVE(str_to_float); -DECLARE_PRIMITIVE(float_to_str); -DECLARE_PRIMITIVE(float_to_bits); +void primitive_fixnum_to_float(void); +void primitive_bignum_to_float(void); +void primitive_str_to_float(void); +void primitive_float_to_str(void); +void primitive_float_to_bits(void); -DECLARE_PRIMITIVE(float_eq); -DECLARE_PRIMITIVE(float_add); -DECLARE_PRIMITIVE(float_subtract); -DECLARE_PRIMITIVE(float_multiply); -DECLARE_PRIMITIVE(float_divfloat); -DECLARE_PRIMITIVE(float_mod); -DECLARE_PRIMITIVE(float_less); -DECLARE_PRIMITIVE(float_lesseq); -DECLARE_PRIMITIVE(float_greater); -DECLARE_PRIMITIVE(float_greatereq); +void primitive_float_eq(void); +void primitive_float_add(void); +void primitive_float_subtract(void); +void primitive_float_multiply(void); +void primitive_float_divfloat(void); +void primitive_float_mod(void); +void primitive_float_less(void); +void primitive_float_lesseq(void); +void primitive_float_greater(void); +void primitive_float_greatereq(void); -DECLARE_PRIMITIVE(float_bits); -DECLARE_PRIMITIVE(bits_float); -DECLARE_PRIMITIVE(double_bits); -DECLARE_PRIMITIVE(bits_double); +void primitive_float_bits(void); +void primitive_bits_float(void); +void primitive_double_bits(void); +void primitive_bits_double(void); -DECLARE_PRIMITIVE(from_rect); +void primitive_from_rect(void); diff --git a/vm/os-unix.c b/vm/os-unix.c index 4ca62e6623..c11962f6e1 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -55,7 +55,7 @@ void ffi_dlclose(F_DLL *dll) dll->dll = NULL; } -DEFINE_PRIMITIVE(existsp) +void primitive_existsp(void) { struct stat sb; box_boolean(stat(unbox_char_string(),&sb) >= 0); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index 9b73692aa0..02b51b82ed 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -27,7 +27,7 @@ char *getenv(char *name) return 0; /* unreachable */ } -DEFINE_PRIMITIVE(os_envs) +void primitive_os_envs(void) { not_implemented_error(); } diff --git a/vm/os-windows.c b/vm/os-windows.c index c19aa5c4b5..fc289c288e 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,7 +87,7 @@ const F_CHAR *vm_executable_path(void) return safe_strdup(full_path); } -DEFINE_PRIMITIVE(existsp) +void primitive_existsp(void) { BY_HANDLE_FILE_INFORMATION bhfi; diff --git a/vm/primitives.h b/vm/primitives.h index 811b473acd..30e0a4af96 100644 --- a/vm/primitives.h +++ b/vm/primitives.h @@ -1,42 +1 @@ extern void *primitives[]; - -/* Primitives are called with two parameters, the word itself and the current -callstack pointer. The DEFINE_PRIMITIVE() macro takes care of boilerplate to -save the current callstack pointer so that GC and other facilities can proceed -to inspect Factor stack frames below the primitive's C stack frame. - -Usage: - -DEFINE_PRIMITIVE(name) -{ - ... CODE ... -} - -Becomes - -F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) -{ - save_callstack_top(callstack_top); - ... CODE ... -} - -On x86, F_FASTCALL expands into a GCC declaration which forces the two -parameters to be passed in registers. This simplifies the quotation compiler -and support code in cpu-x86.S. - -We do the assignment of stack_chain->callstack_top in a ``noinline'' function -to inhibit assignment re-ordering. */ -#define DEFINE_PRIMITIVE(name) \ - INLINE void primitive_##name##_impl(void); \ - \ - F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ - { \ - save_callstack_top(callstack_top); \ - primitive_##name##_impl(); \ - } \ - \ - INLINE void primitive_##name##_impl(void) \ - -/* Prototype for header files */ -#define DECLARE_PRIMITIVE(name) \ - F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) diff --git a/vm/profiler.c b/vm/profiler.c index 250e5a996a..e3db67964f 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -79,7 +79,7 @@ void set_profiling(bool profiling) iterate_code_heap(relocate_code_block); } -DEFINE_PRIMITIVE(profiling) +void primitive_profiling(void) { set_profiling(to_boolean(dpop())); } diff --git a/vm/profiler.h b/vm/profiler.h index d14ceb283b..26a3a78d4b 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,4 +1,4 @@ bool profiling_p; -DECLARE_PRIMITIVE(profiling); +void primitive_profiling(void); F_COMPILED *compile_profiling_stub(F_WORD *word); void update_word_xt(F_WORD *word); diff --git a/vm/quotations.c b/vm/quotations.c index b75d3f79e0..bf917aeec0 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -209,6 +209,7 @@ void jit_compile(CELL quot, bool relocate) case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { + EMIT(userenv[JIT_SAVE_STACK],0); EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj)); i++; @@ -344,6 +345,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { + COUNT(userenv[JIT_SAVE_STACK],i); COUNT(userenv[JIT_PRIMITIVE],i); i++; @@ -412,7 +414,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) } /* push a new quotation on the stack */ -DEFINE_PRIMITIVE(array_to_quotation) +void primitive_array_to_quotation(void) { F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); quot->array = dpeek(); @@ -421,7 +423,7 @@ DEFINE_PRIMITIVE(array_to_quotation) drepl(tag_object(quot)); } -DEFINE_PRIMITIVE(quotation_xt) +void primitive_quotation_xt(void) { F_QUOTATION *quot = untag_quotation(dpeek()); drepl(allot_cell((CELL)quot->xt)); diff --git a/vm/quotations.h b/vm/quotations.h index 0845957c0b..45bf78d14f 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -2,5 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); -DECLARE_PRIMITIVE(array_to_quotation); -DECLARE_PRIMITIVE(quotation_xt); +void primitive_array_to_quotation(void); +void primitive_quotation_xt(void); diff --git a/vm/run.c b/vm/run.c index c4a3e115c1..c7d93d29c8 100755 --- a/vm/run.c +++ b/vm/run.c @@ -105,13 +105,13 @@ bool stack_to_array(CELL bottom, CELL top) } } -DEFINE_PRIMITIVE(datastack) +void primitive_datastack(void) { if(!stack_to_array(ds_bot,ds)) general_error(ERROR_DS_UNDERFLOW,F,F,NULL); } -DEFINE_PRIMITIVE(retainstack) +void primitive_retainstack(void) { if(!stack_to_array(rs_bot,rs)) general_error(ERROR_RS_UNDERFLOW,F,F,NULL); @@ -125,45 +125,45 @@ CELL array_to_stack(F_ARRAY *array, CELL bottom) return bottom + depth - CELLS; } -DEFINE_PRIMITIVE(set_datastack) +void primitive_set_datastack(void) { ds = array_to_stack(untag_array(dpop()),ds_bot); } -DEFINE_PRIMITIVE(set_retainstack) +void primitive_set_retainstack(void) { rs = array_to_stack(untag_array(dpop()),rs_bot); } -DEFINE_PRIMITIVE(getenv) +void primitive_getenv(void) { F_FIXNUM e = untag_fixnum_fast(dpeek()); drepl(userenv[e]); } -DEFINE_PRIMITIVE(setenv) +void primitive_setenv(void) { F_FIXNUM e = untag_fixnum_fast(dpop()); CELL value = dpop(); userenv[e] = value; } -DEFINE_PRIMITIVE(exit) +void primitive_exit(void) { exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(millis) +void primitive_millis(void) { box_unsigned_8(current_millis()); } -DEFINE_PRIMITIVE(sleep) +void primitive_sleep(void) { sleep_millis(to_cell(dpop())); } -DEFINE_PRIMITIVE(set_slot) +void primitive_set_slot(void) { F_FIXNUM slot = untag_fixnum_fast(dpop()); CELL obj = dpop(); diff --git a/vm/run.h b/vm/run.h index 96e606e38c..2dbbcc8c06 100755 --- a/vm/run.h +++ b/vm/run.h @@ -48,8 +48,8 @@ typedef enum { JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DECLARE_WORD = 42, + JIT_SAVE_STACK, STACK_TRACES_ENV = 59, @@ -226,18 +226,18 @@ DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); void init_stacks(CELL ds_size, CELL rs_size); -DECLARE_PRIMITIVE(datastack); -DECLARE_PRIMITIVE(retainstack); -DECLARE_PRIMITIVE(getenv); -DECLARE_PRIMITIVE(setenv); -DECLARE_PRIMITIVE(exit); -DECLARE_PRIMITIVE(os_env); -DECLARE_PRIMITIVE(os_envs); -DECLARE_PRIMITIVE(set_os_env); -DECLARE_PRIMITIVE(unset_os_env); -DECLARE_PRIMITIVE(set_os_envs); -DECLARE_PRIMITIVE(millis); -DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(set_slot); +void primitive_datastack(void); +void primitive_retainstack(void); +void primitive_getenv(void); +void primitive_setenv(void); +void primitive_exit(void); +void primitive_os_env(void); +void primitive_os_envs(void); +void primitive_set_os_env(void); +void primitive_unset_os_env(void); +void primitive_set_os_envs(void); +void primitive_millis(void); +void primitive_sleep(void); +void primitive_set_slot(void); bool stage2; diff --git a/vm/types.c b/vm/types.c index 38fe3460e7..f1588465a4 100755 --- a/vm/types.c +++ b/vm/types.c @@ -29,7 +29,7 @@ CELL clone_object(CELL object) } } -DEFINE_PRIMITIVE(clone) +void primitive_clone(void) { drepl(clone_object(dpeek())); } @@ -68,7 +68,7 @@ F_WORD *allot_word(CELL vocab, CELL name) } /* ( name vocabulary -- word ) */ -DEFINE_PRIMITIVE(word) +void primitive_word(void) { CELL vocab = dpop(); CELL name = dpop(); @@ -76,7 +76,7 @@ DEFINE_PRIMITIVE(word) } /* word-xt ( word -- start end ) */ -DEFINE_PRIMITIVE(word_xt) +void primitive_word_xt(void) { F_WORD *word = untag_word(dpop()); F_COMPILED *code = (profiling_p ? word->profiling : word->code); @@ -84,7 +84,7 @@ DEFINE_PRIMITIVE(word_xt) dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length)); } -DEFINE_PRIMITIVE(wrapper) +void primitive_wrapper(void) { F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); wrapper->object = dpeek(); @@ -123,7 +123,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) } /* push a new array on the stack */ -DEFINE_PRIMITIVE(array) +void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); @@ -194,7 +194,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) return new_array; } -DEFINE_PRIMITIVE(resize_array) +void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); @@ -259,7 +259,7 @@ F_BYTE_ARRAY *allot_byte_array(CELL size) } /* push a new byte array on the stack */ -DEFINE_PRIMITIVE(byte_array) +void primitive_byte_array(void) { CELL size = unbox_array_size(); dpush(tag_object(allot_byte_array(size))); @@ -280,7 +280,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) return new_array; } -DEFINE_PRIMITIVE(resize_byte_array) +void primitive_resize_byte_array(void) { F_BYTE_ARRAY* array = untag_byte_array(dpop()); CELL capacity = unbox_array_size(); @@ -313,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) return tuple; } -DEFINE_PRIMITIVE(tuple) +void primitive_tuple(void) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); F_FIXNUM size = untag_fixnum_fast(layout->size); @@ -327,7 +327,7 @@ DEFINE_PRIMITIVE(tuple) } /* push a new tuple on the stack, filling its slots from the stack */ -DEFINE_PRIMITIVE(tuple_boa) +void primitive_tuple_boa(void) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); F_FIXNUM size = untag_fixnum_fast(layout->size); @@ -434,7 +434,7 @@ F_STRING *allot_string(CELL capacity, CELL fill) return string; } -DEFINE_PRIMITIVE(string) +void primitive_string(void) { CELL initial = to_cell(dpop()); CELL length = unbox_array_size(); @@ -477,7 +477,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) return new_string; } -DEFINE_PRIMITIVE(resize_string) +void primitive_resize_string(void) { F_STRING* string = untag_string(dpop()); CELL capacity = unbox_array_size(); @@ -544,7 +544,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) for(i = 0; i < capacity; i++) \ string[i] = string_nth(s,i); \ } \ - DEFINE_PRIMITIVE(type##_string_to_memory) \ + void primitive_##type##_string_to_memory(void) \ { \ type *address = unbox_alien(); \ F_STRING *str = untag_string(dpop()); \ @@ -576,14 +576,14 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) STRING_TO_MEMORY(char); STRING_TO_MEMORY(u16); -DEFINE_PRIMITIVE(string_nth) +void primitive_string_nth(void) { F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -DEFINE_PRIMITIVE(set_string_nth) +void primitive_set_string_nth(void) { F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); diff --git a/vm/types.h b/vm/types.h index 6efae35f5e..ebbb8a2642 100755 --- a/vm/types.h +++ b/vm/types.h @@ -112,23 +112,23 @@ CELL allot_array_1(CELL obj); CELL allot_array_2(CELL v1, CELL v2); CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); -DECLARE_PRIMITIVE(array); -DECLARE_PRIMITIVE(tuple); -DECLARE_PRIMITIVE(tuple_boa); -DECLARE_PRIMITIVE(tuple_layout); -DECLARE_PRIMITIVE(byte_array); -DECLARE_PRIMITIVE(clone); +void primitive_array(void); +void primitive_tuple(void); +void primitive_tuple_boa(void); +void primitive_tuple_layout(void); +void primitive_byte_array(void); +void primitive_clone(void); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); -DECLARE_PRIMITIVE(resize_array); -DECLARE_PRIMITIVE(resize_byte_array); +void primitive_resize_array(void); +void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); -DECLARE_PRIMITIVE(string); +void primitive_string(void); F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); -DECLARE_PRIMITIVE(resize_string); +void primitive_resize_string(void); F_STRING *memory_to_char_string(const char *string, CELL length); F_STRING *from_char_string(const char *c_string); @@ -152,14 +152,14 @@ DLLEXPORT u16 *unbox_u16_string(void); CELL string_nth(F_STRING* string, CELL index); void set_string_nth(F_STRING* string, CELL index, CELL value); -DECLARE_PRIMITIVE(string_nth); -DECLARE_PRIMITIVE(set_string_nth); +void primitive_string_nth(void); +void primitive_set_string_nth(void); F_WORD *allot_word(CELL vocab, CELL name); -DECLARE_PRIMITIVE(word); -DECLARE_PRIMITIVE(word_xt); +void primitive_word(void); +void primitive_word_xt(void); -DECLARE_PRIMITIVE(wrapper); +void primitive_wrapper(void); /* Macros to simulate a vector in C */ #define GROWABLE_ARRAY(result) \ From ef6206d4bb167804d1b10727c0b87ccafcc422ef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 03:51:04 -0600 Subject: [PATCH 08/13] Try to optimize generic dispatch to speed up + on fixnums, nth on arrays for example --- core/generic/math/math.factor | 19 +++++++++++-------- core/generic/standard/engines/tag/tag.factor | 10 ++++++---- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 077795c4b7..ebe1c08cb3 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -3,7 +3,7 @@ USING: arrays generic hashtables kernel kernel.private math namespaces make sequences words quotations layouts combinators sequences.private classes classes.builtin classes.algebra -definitions math.order ; +definitions math.order math.private ; IN: generic.math PREDICATE: math-class < class @@ -62,13 +62,17 @@ ERROR: no-math-method left right generic ; 2drop object-method ] if ; +SYMBOL: picker + : math-vtable ( picker quot -- quot ) [ - >r - , \ tag , - num-tags get [ bootstrap-type>class ] - r> compose map , - \ dispatch , + swap picker set + picker get , [ tag 0 eq? ] % + num-tags get swap [ bootstrap-type>class ] prepose map + unclip , + [ + picker get , [ tag 1 fixnum-fast ] % , \ dispatch , + ] [ ] make , \ if , ] [ ] make ; inline TUPLE: math-combination ; @@ -85,8 +89,7 @@ M: math-combination perform-combination ] [ over object-method ] if nip - ] math-vtable nip - define ; + ] math-vtable nip define ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 87e2f1c9b1..d1bc6d7417 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -22,13 +22,14 @@ C: lo-tag-dispatch-engine "type" word-prop ] if ; +: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; + M: lo-tag-dispatch-engine engine>quot methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map [ picker % [ tag ] % [ - >alist sort-keys reverse - linear-dispatch-quot + sort-tags linear-dispatch-quot ] [ num-tags get direct-dispatch-quot ] if-small? % @@ -51,10 +52,11 @@ C: hi-tag-dispatch-engine \ hi-tag def>> ; M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map + methods>> engines>quots* + [ >r hi-tag-number r> ] assoc-map [ picker % hi-tag-quot % [ - linear-dispatch-quot + sort-tags linear-dispatch-quot ] [ num-tags get , \ fixnum-fast , [ >r num-tags get - r> ] assoc-map From b1aa3697cb0382729dd78ac6e7ae73ff72833a60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 03:52:01 -0600 Subject: [PATCH 09/13] Emit branches in the same order they're written in code --- basis/compiler/cfg/linearization/linearization.factor | 4 ++-- basis/compiler/cfg/rpo/rpo.factor | 5 ++++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index d397c9d448..7433df9617 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -43,8 +43,8 @@ M: ##branch linearize-insn : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) [ (binary-conditional) ] - [ drop dup successors>> first useless-branch? ] 2bi - [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ; + [ drop dup successors>> second useless-branch? ] 2bi + [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; M: ##compare-branch linearize-insn binary-conditional _compare-branch emit-branch ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 7f4b09e68f..158903b4bf 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -9,7 +9,10 @@ SYMBOL: visited : post-order-traversal ( bb -- ) dup id>> visited get key? [ drop ] [ dup id>> visited get conjoin - [ successors>> [ post-order-traversal ] each ] [ , ] bi + [ + successors>> + [ post-order-traversal ] each + ] [ , ] bi ] if ; : post-order ( bb -- blocks ) From 6590c894bc94186e6b507ff02b693804bff3d92d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 04:10:21 -0600 Subject: [PATCH 10/13] Forgot a constant --- basis/compiler/constants/constants.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index cd68602768..86c1f65049 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -37,14 +37,15 @@ IN: compiler.constants : rc-indirect-arm-pc 8 ; inline ! Relocation types -: rt-primitive 0 ; inline -: rt-dlsym 1 ; inline -: rt-literal 2 ; inline -: rt-dispatch 3 ; inline -: rt-xt 4 ; inline -: rt-here 5 ; inline -: rt-label 6 ; inline -: rt-immediate 7 ; inline +: rt-primitive 0 ; inline +: rt-dlsym 1 ; inline +: rt-literal 2 ; inline +: rt-dispatch 3 ; inline +: rt-xt 4 ; inline +: rt-here 5 ; inline +: rt-label 6 ; inline +: rt-immediate 7 ; inline +: rt-stack-chain 8 ; inline : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] From 029ee6752570a23edaa7a2844aa5951fdea193b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 04:12:09 -0600 Subject: [PATCH 11/13] Fix ppc make-image --- basis/cpu/ppc/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 8809311f21..aee0f3f4f3 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -59,7 +59,7 @@ big-endian on 0 6 LOAD32 7 6 0 LWZ 1 7 0 STW -] rc-absolute-ppc-2/2 rt-primitive 1 jit-save-stack jit-define +] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define [ 0 6 LOAD32 From eb05dd3a12e04fabdd40da654cd06590b7172cec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 04:16:08 -0600 Subject: [PATCH 12/13] Optimize a ##dispatch that is applied to the result of a ##sub-imm or ##add-imm; this eliminates an instruction from the common 1 fixnum-fast { ... } dispatch and 8 fixnum-fast { ... } dispatch code sequences appearing in generic word expansions --- basis/compiler/cfg/builder/builder.factor | 2 +- .../cfg/instructions/instructions.factor | 2 +- .../cfg/value-numbering/rewrite/rewrite.factor | 16 +++++++++++++++- .../value-numbering/value-numbering-tests.factor | 2 +- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/codegen/fixup/fixup.factor | 4 ++-- basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/ppc/ppc.factor | 4 ++-- basis/cpu/x86/32/32.factor | 14 +++++++++++++- basis/cpu/x86/64/64.factor | 15 ++++++++++++++- basis/cpu/x86/x86.factor | 13 ------------- 11 files changed, 51 insertions(+), 25 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 77ed04f4b3..7bad44f7a6 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -190,7 +190,7 @@ M: #if emit-node : emit-dispatch ( node -- ) ##epilogue - ds-pop ^^offset>slot i ##dispatch + ds-pop ^^offset>slot i 0 ##dispatch dispatch-branches ; : ( -- word ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index c39f517671..b2c752e612 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -62,7 +62,7 @@ INSN: ##jump word ; INSN: ##return ; ! Jump tables -INSN: ##dispatch src temp ; +INSN: ##dispatch src temp offset ; INSN: ##dispatch-label label ; ! Slot access diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 94c3f0d6f9..5f67f8097e 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences layouts accessors combinators namespaces -math +math fry compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify @@ -113,4 +113,18 @@ M: ##compare-imm rewrite ] when ] when ; +: dispatch-offset ( expr -- n ) + [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi + \ ##sub-imm eq? [ neg ] when ; + +: add-dispatch-offset? ( insn -- expr ? ) + src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline + +M: ##dispatch rewrite + dup add-dispatch-offset? [ + [ clone ] dip + [ in1>> vn>vreg >>src ] + [ dispatch-offset '[ _ + ] change-offset ] bi + ] [ drop ] if ; + M: insn rewrite ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index d3be68c3c9..b73736ed14 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; [ t ] [ { T{ ##peek f V int-regs 1 D 0 } - T{ ##dispatch f V int-regs 1 V int-regs 2 } + T{ ##dispatch f V int-regs 1 V int-regs 2 0 } } dup value-numbering = ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 35d4d59253..0d45b28126 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ; M: ##dispatch-label generate-insn label>> %dispatch-label ; M: ##dispatch generate-insn - [ src>> register ] [ temp>> register ] bi %dispatch ; + [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ; : >slot< { diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index fe270f4410..b25f1fa8fe 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -72,8 +72,8 @@ SYMBOL: literal-table : rel-this ( class -- ) 0 swap rt-label rel-fixup ; -: rel-here ( class -- ) - 0 swap rt-here rel-fixup ; +: rel-here ( offset class -- ) + rt-here rel-fixup ; : init-fixup ( -- ) BV{ } clone relocation-table set diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b0b5b048d9..96dd577c10 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) -HOOK: %dispatch cpu ( src temp -- ) +HOOK: %dispatch cpu ( src temp offset -- ) HOOK: %dispatch-label cpu ( word -- ) HOOK: %slot cpu ( dst obj slot tag temp -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 49caae4bb8..1bc8d6975d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ; M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; -M:: ppc %dispatch ( src temp -- ) +M:: ppc %dispatch ( src temp offset -- ) 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here temp temp src ADD - temp temp 5 cells LWZ + temp temp 5 offset + cells LWZ temp MTCTR BCTR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index f26d76551a..f892271fd5 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler cpu.x86 cpu.architecture compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.intrinsics ; +compiler.cfg.builder compiler.cfg.intrinsics make ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ; M: x86.32 temp-reg-1 EAX ; M: x86.32 temp-reg-2 ECX ; +M:: x86.32 %dispatch ( src temp offset -- ) + ! Load jump table base. + src HEX: ffffffff ADD + offset cells rc-absolute-cell rel-here + ! Go + src HEX: 7f [+] JMP + ! Fix up the displacement above + cell code-alignment + [ 7 + building get dup pop* push ] + [ align-code ] + bi ; + M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0d20660021..75c808b50a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs -slots splitting assocs combinators cpu.x86.assembler +slots splitting assocs combinators make locals cpu.x86.assembler cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder @@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ; M: x86.64 temp-reg-1 RAX ; M: x86.64 temp-reg-2 RCX ; +M:: x86.64 %dispatch ( src temp offset -- ) + ! Load jump table base. + temp HEX: ffffffff MOV + offset cells rc-absolute-cell rel-here + ! Add jump table base + src temp ADD + src HEX: 7f [+] JMP + ! Fix up the displacement above + cell code-alignment + [ 15 + building get dup pop* push ] + [ align-code ] + bi ; + : param-reg-1 int-regs param-regs first ; inline : param-reg-2 int-regs param-regs second ; inline : param-reg-3 int-regs param-regs third ; inline diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 4f72fe45e1..dfe3d3e55e 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -M:: x86 %dispatch ( src temp -- ) - ! Load jump table base. We use a temporary register - ! since on AMD64 we have to load a 64-bit immediate. On - ! x86, this is redundant. - ! Add jump table base - temp HEX: ffffffff MOV rc-absolute-cell rel-here - src temp ADD - src HEX: 7f [+] JMP - ! Fix up the displacement above - cell code-alignment dup bootstrap-cell 8 = 15 9 ? + - building get dup pop* push - align-code ; - M: x86 %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; From 5b4e8e9d097d5d36feefdf8428961202deeda27b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Nov 2008 04:16:58 -0600 Subject: [PATCH 13/13] Rename tests/templates.factor to tests/codegen.factor since that's really what its testing --- .../tests/{templates.factor => codegen.factor} | 11 +++++++++++ 1 file changed, 11 insertions(+) rename basis/compiler/tests/{templates.factor => codegen.factor} (95%) diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/codegen.factor similarity index 95% rename from basis/compiler/tests/templates.factor rename to basis/compiler/tests/codegen.factor index 0a109a15eb..a56ee55c82 100644 --- a/basis/compiler/tests/templates.factor +++ b/basis/compiler/tests/codegen.factor @@ -230,3 +230,14 @@ TUPLE: id obj ; 10000000 [ "hi" 0 (gc-check-bug) drop ] times ; [ ] [ gc-check-bug ] unit-test + +! New optimization +: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ; + +[ "a" ] [ 8 test-1 ] unit-test +[ "b" ] [ 9 test-1 ] unit-test + +: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ; + +[ "a" ] [ 1 test-2 ] unit-test +[ "b" ] [ 2 test-2 ] unit-test