steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Daniel Ehrenberg 2008-02-13 19:55:49 -06:00
parent c14c19edc4 c3b5b7cc61
commit ffd80ad6df
10 changed files with 175 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/bootstrap/compiler/compiler.factor
View File

@ -74,6 +74,12 @@ nl
malloc free memcpy
} 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

6
core/compiler/tests/stack-trace.factor
View File

@ -1,7 +1,7 @@
IN: temporary
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting ;
words splitting sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
@ -31,9 +31,9 @@ words splitting ;
\ > stack-trace-contains?
] unit-test
: quux [ t [ "hi" throw ] when ] times ;
: quux { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
\ (each-integer) stack-trace-contains?
\ sort stack-trace-contains?
] unit-test

4
core/compiler/tests/templates-early.factor
View File

@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
[
[ ] [ 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

2
core/inference/dataflow/dataflow.factor
View File

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

187
core/optimizer/backend/backend.factor
View File

@ -68,8 +68,6 @@ DEFER: optimize-nodes
] if
] when ;
M: f set-node-successor 2drop ;
: optimize-nodes ( node -- newnode )
[
class-substitutions [ clone ] change
@ -81,16 +79,7 @@ M: f set-node-successor 2drop ;
! Generic nodes
M: node optimize-node* drop t f ;
: cleanup-inlining ( node -- newnode changed? )
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
! Post-inlining cleanup
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;
@ -103,32 +92,31 @@ M: #values optimize-node* cleanup-inlining ;
#! Not very efficient.
dupd union* update ;
: post-inline ( #call/#merge #return/#values -- assoc )
>r node-out-d r> node-in-d 2array unify-lengths flip
: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
node-out-d swap node-in-d 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
: substitute-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 ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor dup [
class-substitutions get pick node-classes update
literal-substitutions get pick node-literals update
tuck compute-value-substitutions value-substitutions get swap update*
node-successor t
] [
2drop t f
] if ;
: substitute-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'.
dup substitute-def-use
last-node
class-substitutions get over node-classes update
literal-substitutions get over node-literals update
2dup post-inline value-substitutions get swap update*
set-node-successor ;
! #return
M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! Some utilities for splicing in dataflow IR subtrees
M: f set-node-successor 2drop ;
: splice-node ( old new -- )
dup splice-def-use last-node set-node-successor ;
GENERIC: remember-method* ( method-spec node -- )
@ -148,12 +136,12 @@ M: node remember-method*
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
[ splice-node ] keep ;
: drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ;
@ -161,7 +149,7 @@ M: node remember-method*
! Constant branch folding
: fold-branch ( node branch# -- node )
over node-children nth
swap node-successor over substitute-node ;
swap node-successor over splice-node ;
! #if
: known-boolean-value? ( node value -- value ? )
@ -176,23 +164,124 @@ M: node remember-method*
} cond
] 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*
dup dup node-in-d first known-boolean-value? [
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep
t
] [ 2drop t f ] if ;
dup fold-if-branch? [ fold-if-branch t ] [
2drop t f
! drop dup lift-throw-tail? dup [
! dupd lift-branch t
! ] [
! 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*
dup dup node-in-d first 2dup node-literal? [
"Optimizing #dispatch" print
node-literal
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
dup fold-dispatch-branch? [
fold-dispatch-branch t
] [
3drop t f
2drop t f
] 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
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure

28
core/optimizer/def-use/def-use.factor
View File

@ -70,20 +70,6 @@ M: #branch node-def-use
#! #values node.
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 )
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
] if ;
!
: sole-consumer ( #call -- node/f )
node-out-d first used-by
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 ;

2
core/optimizer/optimizer.factor
View File

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

2
core/optimizer/specializers/specializers.factor
View File

@ -24,7 +24,7 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( word -- alist )
: specializer-methods ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append

2
extra/benchmark/benchmark.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require
[ [ run ] benchmark ] [ error. f f ] recover 2array
[ [ run ] benchmark ] [ error. drop f f ] recover 2array
dup . ;
: run-benchmarks ( -- assoc )

12
extra/optimizer/debugger/debugger.factor
View File

@ -95,14 +95,18 @@ M: #dispatch node>quot
node-children swap [ dataflow>quot ] curry map ,
\ 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-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 -- )
dup [