Merge branch 'master' of git://factorcode.org/git/factor
commit
ffd80ad6df
|
@ -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
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: compiler tools.test namespaces sequences
|
USING: compiler tools.test namespaces sequences
|
||||||
kernel.private kernel math continuations continuations.private
|
kernel.private kernel math continuations continuations.private
|
||||||
words splitting ;
|
words splitting sorting ;
|
||||||
|
|
||||||
: symbolic-stack-trace ( -- newseq )
|
: symbolic-stack-trace ( -- newseq )
|
||||||
error-continuation get continuation-call callstack>array
|
error-continuation get continuation-call callstack>array
|
||||||
|
@ -31,9 +31,9 @@ words splitting ;
|
||||||
\ > stack-trace-contains?
|
\ > stack-trace-contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: quux [ t [ "hi" throw ] when ] times ;
|
: quux { 1 2 3 } [ "hi" throw ] sort ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ 10 quux ] ignore-errors
|
[ 10 quux ] ignore-errors
|
||||||
\ (each-integer) stack-trace-contains?
|
\ sort stack-trace-contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
|
||||||
[
|
[
|
||||||
[ ] [ init-templates ] unit-test
|
[ ] [ init-templates ] unit-test
|
||||||
|
|
||||||
[ ] [ init-generator ] unit-test
|
H{ } clone compiled set
|
||||||
|
|
||||||
|
[ ] [ gensym gensym begin-compiling ] unit-test
|
||||||
|
|
||||||
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
|
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -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? ;
|
||||||
|
|
|
@ -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 ? )
|
||||||
|
@ -176,23 +164,124 @@ M: node remember-method*
|
||||||
} cond
|
} cond
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
||||||
|
|
||||||
|
: fold-if-branch ( node value -- node' )
|
||||||
|
over drop-inputs >r
|
||||||
|
0 1 ? fold-branch
|
||||||
|
r> [ set-node-successor ] keep ;
|
||||||
|
|
||||||
|
: only-one ( seq -- elt/f )
|
||||||
|
dup length 1 = [ first ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: lift-throw-tail? ( #if -- tail/? )
|
||||||
|
dup node-successor node-successor
|
||||||
|
[ active-children only-one ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: clone-node ( node -- newnode )
|
||||||
|
clone dup [ clone ] modify-values ;
|
||||||
|
|
||||||
|
: detach-node-successor ( node -- successor )
|
||||||
|
dup node-successor #terminate rot set-node-successor ;
|
||||||
|
|
||||||
|
: lift-branch ( #if node -- )
|
||||||
|
>r detach-node-successor r> splice-node ;
|
||||||
|
|
||||||
M: #if optimize-node*
|
M: #if optimize-node*
|
||||||
dup dup node-in-d first known-boolean-value? [
|
dup fold-if-branch? [ fold-if-branch t ] [
|
||||||
over drop-inputs >r
|
2drop t f
|
||||||
0 1 ? fold-branch
|
! drop dup lift-throw-tail? dup [
|
||||||
r> [ set-node-successor ] keep
|
! dupd lift-branch t
|
||||||
t
|
! ] [
|
||||||
] [ 2drop t f ] if ;
|
! 2drop t f
|
||||||
|
! ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
|
||||||
|
|
||||||
|
: fold-dispatch-branch ( node value -- node' )
|
||||||
|
dupd node-literal
|
||||||
|
over drop-inputs >r fold-branch r>
|
||||||
|
[ set-node-successor ] keep ;
|
||||||
|
|
||||||
M: #dispatch optimize-node*
|
M: #dispatch optimize-node*
|
||||||
dup dup node-in-d first 2dup node-literal? [
|
dup fold-dispatch-branch? [
|
||||||
"Optimizing #dispatch" print
|
fold-dispatch-branch t
|
||||||
node-literal
|
|
||||||
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
|
|
||||||
] [
|
] [
|
||||||
3drop t f
|
2drop t f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
! #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 )
|
||||||
|
dup node-successor node-successor [
|
||||||
|
dup node-param swap node-child find-final-if dup [
|
||||||
|
node-children [ penultimate-node ] map
|
||||||
|
[
|
||||||
|
dup #call-label?
|
||||||
|
[ node-param eq? not ] [ 2drop t ] if
|
||||||
|
] with subset only-one
|
||||||
|
] [ 2drop f ] if
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
! M: #loop optimize-node*
|
||||||
|
! dup lift-loop-tail? dup [
|
||||||
|
! 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
|
||||||
|
! ] if ;
|
||||||
|
|
||||||
! #call
|
! #call
|
||||||
: splice-method ( #call method-spec/t quot/t -- node/t )
|
: splice-method ( #call method-spec/t quot/t -- node/t )
|
||||||
#! t indicates failure
|
#! t indicates failure
|
||||||
|
|
|
@ -70,20 +70,6 @@ M: #branch node-def-use
|
||||||
#! #values node.
|
#! #values node.
|
||||||
dup branch-def-use (node-def-use) ;
|
dup branch-def-use (node-def-use) ;
|
||||||
|
|
||||||
! : dead-literals ( -- values )
|
|
||||||
! def-use get [ >r value? r> empty? and ] assoc-subset ;
|
|
||||||
!
|
|
||||||
! : kill-node* ( node values -- )
|
|
||||||
! [ swap remove-all ] curry modify-values ;
|
|
||||||
!
|
|
||||||
! : kill-node ( node values -- )
|
|
||||||
! dup assoc-empty?
|
|
||||||
! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
|
|
||||||
!
|
|
||||||
! : kill-values ( node -- )
|
|
||||||
! #! Remove literals which are not actually used anywhere.
|
|
||||||
! dead-literals kill-node ;
|
|
||||||
|
|
||||||
: compute-dead-literals ( -- values )
|
: compute-dead-literals ( -- values )
|
||||||
def-use get [ >r value? r> empty? and ] assoc-subset ;
|
def-use get [ >r value? r> empty? and ] assoc-subset ;
|
||||||
|
|
||||||
|
@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
||||||
dead-literals [ kill-nodes ] with-variable
|
dead-literals [ kill-nodes ] with-variable
|
||||||
] if ;
|
] 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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -24,7 +24,7 @@ IN: optimizer.specializers
|
||||||
\ dispatch ,
|
\ dispatch ,
|
||||||
] [ ] make ;
|
] [ ] make ;
|
||||||
|
|
||||||
: specializer-methods ( word -- alist )
|
: specializer-methods ( quot word -- default alist )
|
||||||
dup [ array? ] all? [ 1array ] unless [
|
dup [ array? ] all? [ 1array ] unless [
|
||||||
[ make-specializer ] keep
|
[ make-specializer ] keep
|
||||||
[ declare ] curry pick append
|
[ declare ] curry pick append
|
||||||
|
|
|
@ -8,7 +8,7 @@ IN: benchmark
|
||||||
: run-benchmark ( vocab -- result )
|
: run-benchmark ( vocab -- result )
|
||||||
"=== Benchmark " write dup print flush
|
"=== Benchmark " write dup print flush
|
||||||
dup require
|
dup require
|
||||||
[ [ run ] benchmark ] [ error. f f ] recover 2array
|
[ [ run ] benchmark ] [ error. drop f f ] recover 2array
|
||||||
dup . ;
|
dup . ;
|
||||||
|
|
||||||
: run-benchmarks ( -- assoc )
|
: run-benchmarks ( -- assoc )
|
||||||
|
|
|
@ -95,14 +95,18 @@ M: #dispatch node>quot
|
||||||
node-children swap [ dataflow>quot ] curry map ,
|
node-children swap [ dataflow>quot ] curry map ,
|
||||||
\ dispatch , ;
|
\ dispatch , ;
|
||||||
|
|
||||||
M: #return node>quot
|
|
||||||
dup node-param unparse "#return " swap append comment, ;
|
|
||||||
|
|
||||||
M: #>r node>quot nip node-in-d length \ >r <array> % ;
|
M: #>r node>quot nip node-in-d length \ >r <array> % ;
|
||||||
|
|
||||||
M: #r> node>quot nip node-out-d length \ r> <array> % ;
|
M: #r> node>quot nip node-out-d length \ r> <array> % ;
|
||||||
|
|
||||||
M: object node>quot dup class word-name comment, ;
|
M: object node>quot
|
||||||
|
[
|
||||||
|
dup class word-name %
|
||||||
|
" " %
|
||||||
|
dup node-param unparse %
|
||||||
|
" " %
|
||||||
|
dup effect-str %
|
||||||
|
] "" make comment, ;
|
||||||
|
|
||||||
: (dataflow>quot) ( ? node -- )
|
: (dataflow>quot) ( ? node -- )
|
||||||
dup [
|
dup [
|
||||||
|
|
Loading…
Reference in New Issue