From 26f309d2aed640860d8dbc5e813eaa35fa05b1e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Nov 2008 18:46:31 -0600 Subject: [PATCH] Trying to make PEGs compile faster by reducing the number of low level IR nodes: merge functionality of #>r and #r> into #shuffle, and generate 1 node instead of 3 for calls to get-local --- basis/compiler/cfg/builder/builder.factor | 21 +++----- basis/compiler/cfg/stacks/stacks.factor | 20 ++++++-- basis/compiler/tree/checker/checker.factor | 18 ++----- .../tree/dead-code/branches/branches.factor | 2 +- .../tree/dead-code/simple/simple.factor | 26 +++------- basis/compiler/tree/debugger/debugger.factor | 48 ++++++++++++++----- basis/compiler/tree/def-use/def-use.factor | 4 +- .../tree/finalization/finalization.factor | 8 ++-- .../tree/identities/identities.factor | 2 +- .../normalization/renaming/renaming.factor | 6 +-- basis/compiler/tree/tree.factor | 38 +++++---------- .../tree/tuple-unboxing/tuple-unboxing.factor | 14 ++---- basis/locals/locals.factor | 10 ++-- .../known-words/known-words.factor | 38 ++++++++++----- .../stack-checker/visitor/dummy/dummy.factor | 2 +- basis/stack-checker/visitor/visitor.factor | 2 +- 16 files changed, 124 insertions(+), 135 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 17a5942af2..77ed04f4b3 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -221,21 +221,14 @@ M: #push emit-node literal>> ^^load-literal ds-push iterate-next ; ! #shuffle -: emit-shuffle ( effect -- ) - [ out>> ] [ in>> dup length ds-load zip ] bi - '[ _ at ] map ds-store ; - M: #shuffle emit-node - shuffle-effect emit-shuffle iterate-next ; - -M: #>r emit-node - [ in-d>> length ] [ out-r>> empty? ] bi - [ neg ##inc-d ] [ ds-load rs-store ] if - iterate-next ; - -M: #r> emit-node - [ in-r>> length ] [ out-d>> empty? ] bi - [ neg ##inc-r ] [ rs-load ds-store ] if + dup + H{ } clone + [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ] + [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ] + [ nip ] 2tri + [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ] + [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi iterate-next ; ! #return diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index f138f673e0..c8fcae87c0 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -15,16 +15,28 @@ IN: compiler.cfg.stacks 1 ##inc-d D 0 ##replace ; : ds-load ( n -- vregs ) - [ [ ^^peek ] map ] [ neg ##inc-d ] bi ; + dup 0 = + [ drop f ] + [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; : ds-store ( vregs -- ) - [ length ##inc-d ] [ [ ##replace ] each-index ] bi ; + [ + + [ length ##inc-d ] + [ [ ##replace ] each-index ] bi + ] unless-empty ; : rs-load ( n -- vregs ) - [ [ ^^peek ] map ] [ neg ##inc-r ] bi ; + dup 0 = + [ drop f ] + [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; : rs-store ( vregs -- ) - [ length ##inc-r ] [ [ ##replace ] each-index ] bi ; + [ + + [ length ##inc-r ] + [ [ ##replace ] each-index ] bi + ] unless-empty ; : 2inputs ( -- vreg1 vreg2 ) D 1 ^^peek D 0 ^^peek -2 ##inc-d ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index b712a6e354..4f99fa015d 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -22,8 +22,8 @@ ERROR: check-use-error value message ; GENERIC: check-node* ( node -- ) M: #shuffle check-node* - [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ] - [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ] + [ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ] + [ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ] bi ; : check-lengths ( seq -- ) @@ -31,13 +31,6 @@ M: #shuffle check-node* M: #copy check-node* inputs/outputs 2array check-lengths ; -: check->r/r> ( node -- ) - inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ; - -M: #>r check-node* check->r/r> ; - -M: #r> check-node* check->r/r> ; - M: #return-recursive check-node* inputs/outputs 2array check-lengths ; M: #phi check-node* @@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ; M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; -M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; - -M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ; - -M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ; +M: #shuffle check-stack-flow* + { [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ; : assert-datastack-empty ( -- ) datastack get empty? [ "Data stack not empty" throw ] unless ; diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index 719c80f911..eba82384ab 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -39,7 +39,7 @@ M: #branch remove-dead-code* [ drop filter-live ] [ swap nths ] 2bi [ make-values ] keep [ drop ] [ zip ] 2bi - #shuffle ; + #data-shuffle ; : insert-drops ( nodes values indices -- nodes' ) '[ diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index addb13ced3..185c776c4e 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -39,12 +39,6 @@ M: #copy compute-live-values* M: #call compute-live-values* nip look-at-inputs ; -M: #>r compute-live-values* - [ out-r>> ] [ in-d>> ] bi look-at-mapping ; - -M: #r> compute-live-values* - [ out-d>> ] [ in-r>> ] bi look-at-mapping ; - M: #shuffle compute-live-values* mapping>> at look-at-value ; @@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; zip filter-mapping values ; : filter-live ( values -- values' ) - [ live-value? ] filter ; + dup empty? [ [ live-value? ] filter ] unless ; :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle ) inputs @@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; outputs mapping-keys mapping-values - filter-corresponding zip #shuffle ; inline + filter-corresponding zip #data-shuffle ; inline :: drop-dead-values ( outputs -- #shuffle ) [let* | new-outputs [ outputs make-values ] @@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; M: #introduce remove-dead-code* ( #introduce -- nodes ) maybe-drop-dead-outputs ; -M: #>r remove-dead-code* - [ filter-live ] change-out-r - [ filter-live ] change-in-d - dup in-d>> empty? [ drop f ] when ; - -M: #r> remove-dead-code* - [ filter-live ] change-out-d - [ filter-live ] change-in-r - dup in-r>> empty? [ drop f ] when ; - M: #push remove-dead-code* dup out-d>> first live-value? [ drop f ] unless ; @@ -125,12 +109,14 @@ M: #call remove-dead-code* M: #shuffle remove-dead-code* [ filter-live ] change-in-d [ filter-live ] change-out-d + [ filter-live ] change-in-r + [ filter-live ] change-out-r [ filter-mapping ] change-mapping - dup in-d>> empty? [ drop f ] when ; + dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ; M: #copy remove-dead-code* [ in-d>> ] [ out-d>> ] bi - 2dup swap zip #shuffle + 2dup swap zip #data-shuffle remove-dead-code* ; M: #terminate remove-dead-code* diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 59a028a4f4..214be18148 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -3,7 +3,7 @@ USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.sections math words -combinators io sorting hints qualified +combinators combinators.short-circuit io sorting hints qualified compiler.tree compiler.tree.recursive compiler.tree.normalization @@ -57,9 +57,41 @@ TUPLE: shuffle-node { effect effect } ; M: shuffle-node pprint* effect>> effect>string text ; +: (shuffle-effect) ( in out #shuffle -- effect ) + mapping>> '[ _ at ] map ; + +: shuffle-effect ( #shuffle -- effect ) + [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ; + +: #>r? ( #shuffle -- ? ) + { + [ in-d>> length 1 = ] + [ out-r>> length 1 = ] + [ in-r>> empty? ] + [ out-d>> empty? ] + } 1&& ; + +: #r>? ( #shuffle -- ? ) + { + [ in-d>> empty? ] + [ out-r>> empty? ] + [ in-r>> length 1 = ] + [ out-d>> length 1 = ] + } 1&& ; + M: #shuffle node>quot - shuffle-effect dup pretty-shuffle - [ % ] [ shuffle-node boa , ] ?if ; + { + { [ dup #>r? ] [ drop \ >r , ] } + { [ dup #r>? ] [ drop \ r> , ] } + { + [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ] + [ + dup shuffle-effect pretty-shuffle + [ % ] [ shuffle-node boa , ] ?if + ] + } + [ drop "COMPLEX SHUFFLE" , ] + } cond ; M: #push node>quot literal>> , ; @@ -82,16 +114,6 @@ M: #if node>quot M: #dispatch node>quot children>> [ nodes>quot ] map , \ dispatch , ; -M: #>r node>quot - [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi - % ; - -DEFER: rdrop - -M: #r> node>quot - [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi - % ; - M: #alien-invoke node>quot params>> , \ #alien-invoke , ; M: #alien-indirect node>quot params>> , \ #alien-indirect , ; diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 2379f3918d..9be9f13043 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -38,16 +38,16 @@ GENERIC: node-uses-values ( node -- values ) M: #introduce node-uses-values drop f ; M: #push node-uses-values drop f ; -M: #r> node-uses-values in-r>> ; M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ; M: #declare node-uses-values declaration>> keys ; M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ; +M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ; M: #alien-callback node-uses-values drop f ; M: node node-uses-values in-d>> ; GENERIC: node-defs-values ( node -- values ) -M: #>r node-defs-values out-r>> ; +M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ; M: #branch node-defs-values drop f ; M: #declare node-defs-values drop f ; M: #return node-defs-values drop f ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 2d2e429994..16a27e020a 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize classes.builtin +fry assocs compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes ) M: #copy finalize* drop f ; M: #shuffle finalize* - dup shuffle-effect - [ in>> ] [ out>> ] bi sequence= - [ drop f ] when ; + dup + [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] + [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] + bi and [ drop f ] when ; : builtin-predicate? ( #call -- ? ) word>> "predicating" word-prop builtin-class? ; diff --git a/basis/compiler/tree/identities/identities.factor b/basis/compiler/tree/identities/identities.factor index d6ed59cbaa..00632ec6f6 100644 --- a/basis/compiler/tree/identities/identities.factor +++ b/basis/compiler/tree/identities/identities.factor @@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node ) : select-input ( node n -- #shuffle ) [ [ in-d>> ] [ out-d>> ] bi ] dip - pick nth over first associate #shuffle ; + pick nth over first associate #data-shuffle ; M: #call apply-identities* dup word>> "identities" word-prop [ diff --git a/basis/compiler/tree/normalization/renaming/renaming.factor b/basis/compiler/tree/normalization/renaming/renaming.factor index 3050df2611..9d68f4a733 100644 --- a/basis/compiler/tree/normalization/renaming/renaming.factor +++ b/basis/compiler/tree/normalization/renaming/renaming.factor @@ -10,7 +10,7 @@ SYMBOL: rename-map [ rename-map get at ] keep or ; : rename-values ( values -- values' ) - rename-map get '[ [ _ at ] keep or ] map ; + dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ; : add-renamings ( old new -- ) [ rename-values ] dip @@ -22,13 +22,11 @@ M: #introduce rename-node-values* ; M: #shuffle rename-node-values* [ rename-values ] change-in-d + [ rename-values ] change-in-r [ [ rename-value ] assoc-map ] change-mapping ; M: #push rename-node-values* ; -M: #r> rename-node-values* - [ rename-values ] change-in-r ; - M: #terminate rename-node-values* [ rename-values ] change-in-d [ rename-values ] change-in-r ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 05f33902ec..9f9a43df64 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic assocs kernel math namespaces parser -sequences words vectors math.intervals effects classes +sequences words vectors math.intervals classes accessors combinators stack-checker.state stack-checker.visitor stack-checker.inlining ; IN: compiler.tree @@ -42,30 +42,21 @@ TUPLE: #push < node literal out-d ; TUPLE: #renaming < node ; -TUPLE: #shuffle < #renaming mapping in-d out-d ; +TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ; -: #shuffle ( inputs outputs mapping -- node ) +: #shuffle ( in-d out-d in-r out-r mapping -- node ) \ #shuffle new swap >>mapping + swap >>out-r + swap >>in-r swap >>out-d swap >>in-d ; +: #data-shuffle ( in-d out-d mapping -- node ) + [ f f ] dip #shuffle ; inline + : #drop ( inputs -- node ) - { } { } #shuffle ; - -TUPLE: #>r < #renaming in-d out-r ; - -: #>r ( inputs outputs -- node ) - \ #>r new - swap >>out-r - swap >>in-d ; - -TUPLE: #r> < #renaming in-r out-d ; - -: #r> ( inputs outputs -- node ) - \ #r> new - swap >>out-d - swap >>in-r ; + { } { } #data-shuffle ; TUPLE: #terminate < node in-d in-r ; @@ -171,16 +162,9 @@ TUPLE: #alien-callback < #alien-node ; GENERIC: inputs/outputs ( #renaming -- inputs outputs ) M: #shuffle inputs/outputs mapping>> unzip swap ; -M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ; -M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ; M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ; M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; -: shuffle-effect ( #shuffle -- effect ) - [ in-d>> ] [ out-d>> ] [ mapping>> ] tri - '[ _ at ] map - ; - : recursive-phi-in ( #enter-recursive -- seq ) [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; @@ -193,8 +177,8 @@ M: vector #call, #call node, ; M: vector #push, #push node, ; M: vector #shuffle, #shuffle node, ; M: vector #drop, #drop node, ; -M: vector #>r, #>r node, ; -M: vector #r>, #r> node, ; +M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ; +M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ; M: vector #return, #return node, ; M: vector #enter-recursive, #enter-recursive node, ; M: vector #return-recursive, #return-recursive node, ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 8e07c08194..52903fce8d 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -42,7 +42,7 @@ M: #push unbox-tuples* ( #push -- nodes ) [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; : flatten-values ( values -- values' ) - (flatten-values) flatten ; + dup empty? [ (flatten-values) flatten ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] @@ -54,7 +54,7 @@ M: #push unbox-tuples* ( #push -- nodes ) ] tri ; : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle ) - [ drop ] [ zip ] 2bi #shuffle ; + [ drop ] [ zip ] 2bi #data-shuffle ; : unbox-slot-access ( #call -- nodes ) dup out-d>> first unboxed-slot-access? [ @@ -77,17 +77,11 @@ M: #copy unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d ; -M: #>r unbox-tuples* - [ flatten-values ] change-in-d - [ flatten-values ] change-out-r ; - -M: #r> unbox-tuples* - [ flatten-values ] change-in-r - [ flatten-values ] change-out-d ; - M: #shuffle unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d + [ flatten-values ] change-in-r + [ flatten-values ] change-out-r [ unzip [ flatten-values ] bi@ zip ] change-mapping ; M: #terminate unbox-tuples* diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index c588269284..e74ecf3dc9 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,8 +6,7 @@ quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer classes -stack-checker.known-words ; +locals.backend memoize macros.expander lexer classes ; IN: locals ! Inspired by @@ -49,8 +48,7 @@ PREDICATE: local < word "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier f - dup t "local?" set-word-prop - dup { } { object } define-primitive ; + dup t "local?" set-word-prop ; PREDICATE: local-word < word "local-word?" word-prop ; @@ -61,14 +59,12 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) f - dup t "local-reader?" set-word-prop - dup { } { object } define-primitive ; + dup t "local-reader?" set-word-prop ; PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) dup name>> "!" append f { - [ nip { object } { } define-primitive ] [ nip t "local-writer?" set-word-prop ] [ swap "local-reader" set-word-prop ] [ "local-writer" set-word-prop ] diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c40b94fd3c..257181f6ad 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -10,7 +10,8 @@ sequences sequences.private slots.private strings 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.backend words.private quotations.private +combinators locals locals.backend locals.private words.private +quotations.private stack-checker.state stack-checker.backend stack-checker.branches @@ -48,7 +49,7 @@ IN: stack-checker.known-words : infer-shuffle ( shuffle -- ) [ in>> length consume-d ] keep ! inputs shuffle [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies - [ nip ] [ swap zip ] 2bi ! inputs copies mapping + [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping #shuffle, ; : infer-shuffle-word ( word -- ) @@ -123,21 +124,23 @@ M: object infer-call* : infer-load-locals ( -- ) pop-literal nip - [ dup reverse infer-shuffle ] - [ infer->r ] - bi ; + consume-d dup reverse copy-values dup output-r + [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ; : infer-get-local ( -- ) - pop-literal nip - [ infer-r> ] - [ dup 0 prefix infer-shuffle ] - [ infer->r ] - tri ; + [let* | n [ pop-literal nip ] + in-r [ n consume-r ] + out-d [ in-r first copy-value 1array ] + out-r [ in-r copy-values ] | + out-d output-d + out-r output-r + f out-d in-r out-r + out-r in-r zip out-d first in-r first 2array suffix + #shuffle, + ] ; : infer-drop-locals ( -- ) - pop-literal nip - [ infer-r> ] - [ { } infer-shuffle ] bi ; + f f pop-literal nip consume-r f f #shuffle, ; : infer-special ( word -- ) { @@ -164,6 +167,12 @@ M: object infer-call* { \ alien-callback [ infer-alien-callback ] } } case ; +: infer-local-reader ( word -- ) + (( -- value )) apply-word/effect ; + +: infer-local-writer ( word -- ) + (( value -- )) apply-word/effect ; + { >r r> declare call (call) curry compose execute (execute) if dispatch (throw) load-locals get-local drop-locals @@ -183,6 +192,9 @@ do-primitive alien-invoke alien-indirect alien-callback { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } + { [ dup local? ] [ infer-local-reader ] } + { [ dup local-reader? ] [ infer-local-reader ] } + { [ dup local-writer? ] [ infer-local-writer ] } { [ dup recursive-label ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor index a24d8e226d..5f05d97d1a 100644 --- a/basis/stack-checker/visitor/dummy/dummy.factor +++ b/basis/stack-checker/visitor/dummy/dummy.factor @@ -8,7 +8,7 @@ M: f #introduce, drop ; M: f #call, 3drop ; M: f #call-recursive, 3drop ; M: f #push, 2drop ; -M: f #shuffle, 3drop ; +M: f #shuffle, 2drop 2drop drop ; M: f #>r, 2drop ; M: f #r>, 2drop ; M: f #return, drop ; diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor index 7d8ec90453..6093cd008a 100644 --- a/basis/stack-checker/visitor/visitor.factor +++ b/basis/stack-checker/visitor/visitor.factor @@ -13,7 +13,7 @@ HOOK: #introduce, stack-visitor ( values -- ) HOOK: #call, stack-visitor ( inputs outputs word -- ) HOOK: #call-recursive, stack-visitor ( inputs outputs word -- ) HOOK: #push, stack-visitor ( literal value -- ) -HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- ) +HOOK: #shuffle, stack-visitor ( in-d out-d in-r out-r mapping -- ) HOOK: #drop, stack-visitor ( values -- ) HOOK: #>r, stack-visitor ( inputs outputs -- ) HOOK: #r>, stack-visitor ( inputs outputs -- )