enable-compiler and disable-compiler words

db4
Slava Pestov 2008-02-13 18:42:55 -06:00
parent 6cfc427289
commit fc80279b3a
5 changed files with 119 additions and 60 deletions

View File

@ -74,6 +74,12 @@ nl
malloc free memcpy malloc free memcpy
} compile } compile
[ compiled-usages recompile ] recompile-hook set-global : enable-compiler ( -- )
[ compiled-usages recompile ] recompile-hook set-global ;
: disable-compiler ( -- )
[ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
enable-compiler
" done" print flush " done" print flush

View File

@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ; PREDICATE: #values #tail-values node-successor #tail? ;
UNION: #tail UNION: #tail
POSTPONE: f #return #tail-values #tail-merge ; POSTPONE: f #return #tail-values #tail-merge #terminate ;
: tail-call? ( -- ? ) : tail-call? ( -- ? )
node-stack get [ node-successor #tail? ] all? ; node-stack get [ node-successor #tail? ] all? ;

View File

@ -68,8 +68,6 @@ DEFER: optimize-nodes
] if ] if
] when ; ] when ;
M: f set-node-successor 2drop ;
: optimize-nodes ( node -- newnode ) : optimize-nodes ( node -- newnode )
[ [
class-substitutions [ clone ] change class-substitutions [ clone ] change
@ -81,16 +79,7 @@ M: f set-node-successor 2drop ;
! Generic nodes ! Generic nodes
M: node optimize-node* drop t f ; M: node optimize-node* drop t f ;
: cleanup-inlining ( node -- newnode changed? ) ! Post-inlining cleanup
node-successor [ node-successor t ] [ t f ] if* ;
! #return
M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! Some utilities for splicing in dataflow IR subtrees
: follow ( key assoc -- value ) : follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ; 2dup at* [ swap follow nip ] [ 2drop ] if ;
@ -103,32 +92,31 @@ M: #values optimize-node* cleanup-inlining ;
#! Not very efficient. #! Not very efficient.
dupd union* update ; dupd union* update ;
: post-inline ( #call/#merge #return/#values -- assoc ) : compute-value-substitutions ( #return/#values #call/#merge -- assoc )
>r node-out-d r> node-in-d 2array unify-lengths flip node-out-d swap node-in-d 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ; [ = not ] assoc-subset >hashtable ;
: substitute-def-use ( node -- ) : cleanup-inlining ( #return/#values -- newnode changed? )
#! As a first approximation, we take all the values used dup node-successor dup [
#! by the set of new nodes, and push a 't' on their class-substitutions get pick node-classes update
#! def-use list here. We could perform a full graph literal-substitutions get pick node-literals update
#! substitution, but we don't need to, because the next tuck compute-value-substitutions value-substitutions get swap update*
#! optimizer iteration will do that. We just need a minimal node-successor t
#! degree of accuracy; the new values should be marked as ] [
#! having _some_ usage, so that flushing doesn't erronously 2drop t f
#! flush them away. ] if ;
[ compute-def-use def-use get keys ] with-scope
def-use get [ [ t swap ?push ] change-at ] curry each ;
: substitute-node ( old new -- ) ! #return
#! The last node of 'new' becomes 'old', then values are M: #return optimize-node* cleanup-inlining ;
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'. ! #values
dup substitute-def-use M: #values optimize-node* cleanup-inlining ;
last-node
class-substitutions get over node-classes update ! Some utilities for splicing in dataflow IR subtrees
literal-substitutions get over node-literals update M: f set-node-successor 2drop ;
2dup post-inline value-substitutions get swap update*
set-node-successor ; : splice-node ( old new -- )
dup splice-def-use last-node set-node-successor ;
GENERIC: remember-method* ( method-spec node -- ) GENERIC: remember-method* ( method-spec node -- )
@ -148,12 +136,12 @@ M: node remember-method*
pick node-in-d dataflow-with pick node-in-d dataflow-with
[ remember-method ] keep [ remember-method ] keep
[ swap infer-classes/node ] 2keep [ swap infer-classes/node ] 2keep
[ substitute-node ] keep ; [ splice-node ] keep ;
: splice-quot ( #call quot -- node ) : splice-quot ( #call quot -- node )
over node-in-d dataflow-with over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep [ swap infer-classes/node ] 2keep
[ substitute-node ] keep ; [ splice-node ] keep ;
: drop-inputs ( node -- #shuffle ) : drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ; node-in-d clone \ #shuffle in-node ;
@ -161,7 +149,7 @@ M: node remember-method*
! Constant branch folding ! Constant branch folding
: fold-branch ( node branch# -- node ) : fold-branch ( node branch# -- node )
over node-children nth over node-children nth
swap node-successor over substitute-node ; swap node-successor over splice-node ;
! #if ! #if
: known-boolean-value? ( node value -- value ? ) : known-boolean-value? ( node value -- value ? )
@ -193,18 +181,20 @@ M: node remember-method*
: clone-node ( node -- newnode ) : clone-node ( node -- newnode )
clone dup [ clone ] modify-values ; clone dup [ clone ] modify-values ;
: detach-node-successor ( node -- successor )
dup node-successor #terminate rot set-node-successor ;
: lift-branch ( #if node -- ) : lift-branch ( #if node -- )
over last-node clone-node -rot >r detach-node-successor r> splice-node ;
>r dup node-successor r> substitute-node
set-node-successor ;
M: #if optimize-node* M: #if optimize-node*
dup fold-if-branch? [ fold-if-branch t ] [ dup fold-if-branch? [ fold-if-branch t ] [
drop dup lift-throw-tail? dup [ 2drop t f
dupd lift-branch t ! drop dup lift-throw-tail? dup [
] [ ! dupd lift-branch t
2drop t f ! ] [
] if ! 2drop t f
! ] if
] if ; ] if ;
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; : fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
@ -222,21 +212,72 @@ M: #dispatch optimize-node*
] if ; ] if ;
! #loop ! #loop
! BEFORE:
! #label -> C -> #return 1
! |
! -> #if -> #merge -> #return 2
! |
! --------
! | |
! A B
! | |
! #values |
! #call-label
! |
! |
! #values
! AFTER:
! #label -> #terminate
! |
! -> #if -> #terminate
! |
! --------
! | |
! A B
! | |
! #values |
! | #call-label
! #merge |
! | |
! C #values
! |
! #return 1
: find-final-if ( node -- #if/f )
dup [
dup #if? [
dup node-successor #tail? [
node-successor find-final-if
] unless
] [
node-successor find-final-if
] if
] when ;
: lift-loop-tail? ( #label -- tail/f ) : lift-loop-tail? ( #label -- tail/f )
dup node-child dup #if? [ dup node-successor node-successor [
node-children dup node-param swap node-child find-final-if dup [
[ penultimate-node ] map node-children [ penultimate-node ] map
[ [
dup #call-label? dup #call-label?
[ node-param eq? not ] [ 2drop t ] if [ node-param eq? not ] [ 2drop t ] if
] with subset only-one ] with subset only-one
] [ ] [ 2drop f ] if
2drop f ] [ drop f ] if ;
] if ;
! M: #loop optimize-node* ! M: #loop optimize-node*
! dup lift-loop-tail? dup [ ! dup lift-loop-tail? dup [
! over node-child swap lift-branch t ! last-node >r
! dup detach-node-successor
! over node-child find-final-if detach-node-successor
! [ set-node-successor ] keep
! r> set-node-successor
! t
! ] [ ! ] [
! 2drop t f ! 2drop t f
! ] if ; ! ] if ;

View File

@ -118,3 +118,15 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
: sole-consumer ( #call -- node/f ) : sole-consumer ( #call -- node/f )
node-out-d first used-by node-out-d first used-by
dup length 1 = [ first ] [ drop f ] if ; dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- )
#! As a first approximation, we take all the values used
#! by the set of new nodes, and push a 't' on their
#! def-use list here. We could perform a full graph
#! substitution, but we don't need to, because the next
#! optimizer iteration will do that. We just need a minimal
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
[ compute-def-use def-use get keys ] with-scope
def-use get [ [ t swap ?push ] change-at ] curry each ;

View File

@ -12,7 +12,7 @@ IN: optimizer
H{ } clone value-substitutions set H{ } clone value-substitutions set
dup compute-def-use dup compute-def-use
kill-values kill-values
! dup detect-loops dup detect-loops
dup infer-classes dup infer-classes
optimizer-changed off optimizer-changed off
optimize-nodes optimize-nodes