From e304d3c9f8a31f0808ef6c7ef503f55329166dc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 06:02:49 -0600 Subject: [PATCH] Local DCE --- basis/compiler/tree/builder/builder.factor | 2 +- .../backend/backend-tests.factor | 11 ++-- basis/stack-checker/backend/backend.factor | 66 +++++++++++-------- basis/stack-checker/branches/branches.factor | 41 +++++++----- basis/stack-checker/inlining/inlining.factor | 17 +++-- .../known-words/known-words.factor | 52 +++++++++++---- basis/stack-checker/state/state.factor | 31 +++++++-- .../transforms/transforms.factor | 7 +- core/kernel/kernel.factor | 10 +-- 9 files changed, 149 insertions(+), 88 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4e79c4cd2d..b715223445 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -21,7 +21,7 @@ IN: compiler.tree.builder : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] + [ >vector \ meta-d set ] [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index 3bbba0fcb8..48cd10a7ee 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -3,20 +3,21 @@ stack-checker.state sequences ; IN: stack-checker.backend.tests [ ] [ - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone \ meta-r set + V{ } clone \ literals set 0 d-in set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test [ 2 ] [ 2 ensure-d length ] unit-test -[ 2 ] [ meta-d get length ] unit-test +[ 2 ] [ meta-d length ] unit-test [ 3 ] [ 3 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ 1 ] [ 1 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ ] [ 1 consume-d drop ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 8bb19b82f7..56777cc8a7 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend -: push-d ( obj -- ) meta-d get push ; +: push-d ( obj -- ) meta-d push ; : pop-d ( -- obj ) - meta-d get [ + meta-d [ dup 1array #introduce, d-in inc ] [ pop ] if-empty ; @@ -22,46 +22,52 @@ IN: stack-checker.backend [ ] replicate ; : ensure-d ( n -- values ) - meta-d get 2dup length > [ + meta-d 2dup length > [ 2dup [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri - [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri - meta-d get push-all + [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri + meta-d push-all ] when swap tail* ; : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline : consume-d ( n -- seq ) - [ ensure-d ] [ meta-d get shorten-by ] bi ; + [ ensure-d ] [ meta-d shorten-by ] bi ; -: output-d ( values -- ) meta-d get push-all ; +: output-d ( values -- ) meta-d push-all ; : produce-d ( n -- values ) - make-values dup meta-d get push-all ; + make-values dup meta-d push-all ; -: push-r ( obj -- ) meta-r get push ; +: push-r ( obj -- ) meta-r push ; -: pop-r ( -- obj ) - meta-r get dup empty? +: pop-r ( -- obj ) + meta-r dup empty? [ too-many-r> inference-error ] [ pop ] if ; : consume-r ( n -- seq ) - meta-r get 2dup length > + meta-r 2dup length > [ too-many-r> inference-error ] when [ swap tail* ] [ shorten-by ] 2bi ; -: output-r ( seq -- ) meta-r get push-all ; - -: pop-literal ( -- rstate obj ) - pop-d - [ 1array #drop, ] - [ literal [ recursion>> ] [ value>> ] bi ] bi ; - -GENERIC: apply-object ( obj -- ) +: output-r ( seq -- ) meta-r push-all ; : push-literal ( obj -- ) - dup make-known [ nip push-d ] [ #push, ] 2bi ; + literals get push ; + +: pop-literal ( -- rstate obj ) + literals get [ + pop-d + [ 1array #drop, ] + [ literal [ recursion>> ] [ value>> ] bi ] bi + ] [ pop recursive-state get swap ] if-empty ; + +: literals-available? ( n -- literals ? ) + literals get 2dup length <= + [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ; + +GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> @@ -72,10 +78,17 @@ M: wrapper apply-object M: object apply-object push-literal ; : terminate ( -- ) - terminated? on meta-d get clone meta-r get clone #terminate, ; + terminated? on meta-d clone meta-r clone #terminate, ; + +: check->r ( -- ) + meta-r empty? [ \ too-many->r inference-error ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? drop ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -127,13 +140,8 @@ M: object apply-object push-literal ; : infer-word-def ( word -- ) [ specialized-def ] [ add-recursive-state ] bi infer-quot ; -: check->r ( -- ) - meta-r get empty? terminated? get or - [ \ too-many->r inference-error ] unless ; - : end-infer ( -- ) - check->r - meta-d get clone #return, ; + meta-d clone #return, ; : effect-required? ( word -- ? ) { diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 7b461d0028..e4c11960de 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -57,9 +57,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ d-in branch-variable ] [ meta-d active-variable ] bi + [ d-in branch-variable ] [ \ meta-d active-variable ] bi unify-branches - [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ; + [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ; : terminated-phi ( seq -- terminated ) terminated? branch-variable ; @@ -74,17 +74,25 @@ SYMBOL: quotations tri ; : copy-inference ( -- ) - meta-d [ clone ] change - V{ } clone meta-r set + \ meta-d [ clone ] change + literals [ clone ] change d-in [ ] change ; -: infer-branch ( literal -- namespace ) +GENERIC: infer-branch ( literal -- namespace ) + +M: literal infer-branch [ copy-inference nest-visitor [ value>> quotation set ] [ infer-literal-quot ] bi - check->r - ] H{ } make-assoc ; inline + ] H{ } make-assoc ; + +M: callable infer-branch + [ + copy-inference + nest-visitor + [ quotation set ] [ infer-quot-here ] bi + ] H{ } make-assoc ; : infer-branches ( branches -- input children data ) [ pop-d ] dip @@ -96,16 +104,19 @@ SYMBOL: quotations [ first2 #if, ] dip compute-phi-function ; : infer-if ( -- ) - 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] contains? [ - output-d - [ rot [ drop call ] [ nip call ] if ] - infer-quot-here + 2 literals-available? [ + (infer-if) ] [ - [ #drop, ] [ [ literal ] map (infer-if) ] bi + drop 2 consume-d + dup [ known [ curried? ] [ composed? ] bi or ] contains? [ + output-d + [ rot [ drop call ] [ nip call ] if ] + infer-quot-here + ] [ + [ #drop, ] [ [ literal ] map (infer-if) ] bi + ] if ] if ; : infer-dispatch ( -- ) - pop-literal nip [ ] map - infer-branches + pop-literal nip infer-branches [ #dispatch, ] dip compute-phi-function ; diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index df0145b73e..23283fb6e3 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -51,14 +51,14 @@ SYMBOL: enter-out : prepare-stack ( word -- ) required-stack-effect in>> [ length ensure-d drop ] [ - meta-d get clone enter-in set - meta-d get swap make-copies enter-out set + meta-d clone enter-in set + meta-d swap make-copies enter-out set ] bi ; : emit-enter-recursive ( label -- ) enter-out get >>enter-out enter-in get enter-out get #enter-recursive, - enter-out get >vector meta-d set ; + enter-out get >vector \ meta-d set ; : entry-stack-height ( label -- stack ) enter-out>> length ; @@ -77,7 +77,7 @@ SYMBOL: enter-out : end-recursive-word ( word label -- ) [ check-return ] - [ meta-d get dup copy-values dup meta-d set #return-recursive, ] + [ meta-d dup copy-values dup \ meta-d set #return-recursive, ] bi ; : recursive-word-inputs ( label -- n ) @@ -95,10 +95,8 @@ SYMBOL: enter-out [ nip ] 2tri - check->r - dup recursive-word-inputs - meta-d get + meta-d stack-visitor get terminated? get ] with-scope ; @@ -116,7 +114,7 @@ SYMBOL: enter-out swap word>> required-stack-effect in>> length tail* ; : call-site-stack ( label -- stack ) - meta-d get trim-stack ; + meta-d trim-stack ; : trimmed-enter-out ( label -- stack ) dup enter-out>> trim-stack ; @@ -131,7 +129,7 @@ SYMBOL: enter-out : adjust-stack-effect ( effect -- effect' ) [ in>> ] [ out>> ] bi - meta-d get length pick length [-] + meta-d length pick length [-] object '[ _ prepend ] bi@ ; @@ -142,6 +140,7 @@ SYMBOL: enter-out ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) + commit-literals [ inlined-dependency depends-on ] [ dup inline-recursive-label [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 12eb637964..26e1b81c93 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -63,7 +63,9 @@ IN: stack-checker.known-words GENERIC: infer-call* ( value known -- ) -: infer-call ( value -- ) dup known infer-call* ; +: (infer-call) ( value -- ) dup known infer-call* ; + +: infer-call ( -- ) pop-d (infer-call) ; M: literal infer-call* [ 1array #drop, ] [ infer-literal-quot ] bi* ; @@ -73,7 +75,7 @@ M: curried infer-call* [ uncurry ] infer-quot-here [ quot>> known pop-d [ set-known ] keep ] [ obj>> known pop-d [ set-known ] keep ] bi - push-d infer-call ; + push-d (infer-call) ; M: composed infer-call* swap push-d @@ -81,20 +83,41 @@ M: composed infer-call* [ quot2>> known pop-d [ set-known ] keep ] [ quot1>> known pop-d [ set-known ] keep ] bi push-d push-d - 1 infer->r pop-d infer-call - terminated? get [ 1 infer-r> pop-d infer-call ] unless ; + 1 infer->r infer-call + terminated? get [ 1 infer-r> infer-call ] unless ; M: object infer-call* \ literal-expected inference-warning ; : infer-slip ( -- ) - 1 infer->r pop-d infer-call 1 infer-r> ; + 1 infer->r infer-call 1 infer-r> ; : infer-2slip ( -- ) - 2 infer->r pop-d infer-call 2 infer-r> ; + 2 infer->r infer-call 2 infer-r> ; : infer-3slip ( -- ) - 3 infer->r pop-d infer-call 3 infer-r> ; + 3 infer->r infer-call 3 infer-r> ; + +: infer-dip ( -- ) + commit-literals + literals get + [ \ dip def>> infer-quot-here ] + [ pop 1 infer->r infer-quot-here 1 infer-r> ] + if-empty ; + +: infer-2dip ( -- ) + commit-literals + literals get + [ \ 2dip def>> infer-quot-here ] + [ pop 2 infer->r infer-quot-here 2 infer-r> ] + if-empty ; + +: infer-3dip ( -- ) + commit-literals + literals get + [ \ 3dip def>> infer-quot-here ] + [ pop 3 infer->r infer-quot-here 3 infer-r> ] + if-empty ; : infer-curry ( -- ) 2 consume-d @@ -157,11 +180,14 @@ M: object infer-call* { \ >r [ 1 infer->r ] } { \ r> [ 1 infer-r> ] } { \ declare [ infer-declare ] } - { \ call [ pop-d infer-call ] } - { \ (call) [ pop-d infer-call ] } + { \ call [ infer-call ] } + { \ (call) [ infer-call ] } { \ slip [ infer-slip ] } { \ 2slip [ infer-2slip ] } { \ 3slip [ infer-3slip ] } + { \ dip [ infer-dip ] } + { \ 2dip [ infer-2dip ] } + { \ 3dip [ infer-3dip ] } { \ curry [ infer-curry ] } { \ compose [ infer-compose ] } { \ execute [ infer-execute ] } @@ -190,10 +216,10 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - >r r> declare call (call) slip 2slip 3slip curry compose - execute (execute) if dispatch (throw) - load-locals get-local drop-locals do-primitive alien-invoke - alien-indirect alien-callback + >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip + curry compose execute (execute) if dispatch + (throw) load-locals get-local drop-locals do-primitive + alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 2706ec60ef..130147f798 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra -compiler.units ; +compiler.units stack-checker.values stack-checker.visitor ; IN: stack-checker.state ! Did the current control-flow path throw an error? @@ -11,23 +11,40 @@ SYMBOL: terminated? ! Number of inputs current word expects from the stack SYMBOL: d-in +DEFER: commit-literals + ! Compile-time data stack -SYMBOL: meta-d +: meta-d ( -- stack ) commit-literals \ meta-d get ; ! Compile-time retain stack -SYMBOL: meta-r +: meta-r ( -- stack ) \ meta-r get ; -: current-stack-height ( -- n ) meta-d get length d-in get - ; +! Uncommitted literals. This is a form of local dead-code +! elimination; the goal is to reduce the number of IR nodes +! which get constructed. Technically it is redundant since +! we do global DCE later, but it speeds up compile time. +SYMBOL: literals + +: (push-literal) ( obj -- ) + dup make-known + [ nip \ meta-d get push ] [ #push, ] 2bi ; + +: commit-literals ( -- ) + literals get [ + [ [ (push-literal) ] each ] [ delete-all ] bi + ] unless-empty ; + +: current-stack-height ( -- n ) meta-d length d-in get - ; : current-effect ( -- effect ) d-in get - meta-d get length + meta-d length terminated? get >>terminated? ; : init-inference ( -- ) terminated? off - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone literals set 0 d-in set ; ! Words that the current quotation depends on diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 7eec29f94b..299dc1b551 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,11 +19,8 @@ IN: stack-checker.transforms rot with-datastack first2 dup [ [ - [ drop ] [ - [ length meta-d get '[ _ pop* ] times ] - [ #drop, ] - bi - ] bi* + [ drop ] + [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* ] 2dip swap infer-quot ] [ diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index bbe2d348d8..98dc0e50fa 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -52,7 +52,9 @@ DEFER: if : ?if ( default cond true false -- ) pick [ roll 2drop call ] [ 2nip call ] if ; inline -! Slippers +! Slippers and dippers. +! Not declared inline because the compiler special-cases them + : slip ( quot x -- x ) #! 'slip' and 'dip' can be defined in terms of each other #! because the JIT special-cases a 'dip' preceeded by @@ -71,11 +73,11 @@ DEFER: if #! a literal quotation. [ call ] 3dip ; -: dip ( x quot -- x ) swap slip ; inline +: dip ( x quot -- x ) swap slip ; -: 2dip ( x y quot -- x y ) -rot 2slip ; inline +: 2dip ( x y quot -- x y ) -rot 2slip ; -: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline +: 3dip ( x y z quot -- x y z ) -roll 3slip ; ! Keepers : keep ( x quot -- x ) over slip ; inline