Debugging optimizer

db4
Slava Pestov 2008-08-18 15:47:49 -05:00
parent 2fa08c75b9
commit 9b6fb70eba
12 changed files with 82 additions and 60 deletions

View File

@ -80,9 +80,9 @@ nl
malloc calloc free memcpy
} compile-uncompiled
{
build-tree optimize-tree
} compile-uncompiled
{ build-tree } compile-uncompiled
{ optimize-tree } compile-uncompiled
vocabs [ words compile-uncompiled "." write flush ] each

View File

@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
%jump-label ;
: generate-call ( label -- next )
dup maybe-compile
! dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
@ -232,7 +232,7 @@ M: #dispatch generate-node
] if ;
M: #call generate-node
! dup node-input-infos [ class>> ] map set-operand-classes
dup node-input-infos [ class>> ] map set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [

View File

@ -20,47 +20,49 @@ M: #phi compute-live-values*
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
2bi ;
SYMBOL: if-node
M: #branch remove-dead-code*
[ [ (remove-dead-code) ] map ] change-children ;
[ [ [ (remove-dead-code) ] map ] change-children ]
[ if-node set ]
bi ;
: remove-phi-inputs ( #phi -- )
dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d
dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r
drop ;
! SYMBOL: if-node
!
! : dead-value-indices ( values -- indices )
! [ length ] keep live-values get
! '[ , nth , key? not ] filter ; inline
!
! : drop-d-values ( values indices -- node )
! [ drop filter-live ] [ nths filter-live ] 2bi
! [ make-values ] keep
! [ drop ] [ zip ] 2bi
! #shuffle ;
!
! : drop-r-values ( values indices -- nodes )
: live-value-indices ( values -- indices )
[ length ] keep live-values get
'[ , nth , key? ] filter ; inline
: drop-d-values ( values indices -- node )
[ drop filter-live ] [ nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
: drop-r-values ( values indices -- nodes ) 2drop f ;
! [ dup make-values [ #r> ] keep ] dip
! drop-d-values dup out-d>> dup make-values #>r
! 3array ;
!
! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
! '[
! [ , drop-d-values 1array ]
! [ , drop-r-values ]
! bi* 3append
! ] 3map ;
!
! : hoist-drops ( #phi -- )
! if-node get swap
! {
! [ phi-in-d>> ]
! [ phi-in-r>> ]
! [ out-d>> dead-value-indices ]
! [ out-r>> dead-value-indices ]
! } cleave
! '[ , , , , insert-drops ] change-children drop ;
: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
'[
[ , drop-d-values 1array ]
[ , drop-r-values ]
bi* 3append
] 3map ;
: hoist-drops ( #phi -- )
if-node get swap
{
[ phi-in-d>> ]
[ phi-in-r>> ]
[ out-d>> live-value-indices ]
[ out-r>> live-value-indices ]
} cleave
'[ , , , , insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d
@ -69,7 +71,7 @@ M: #branch remove-dead-code*
M: #phi remove-dead-code*
{
! [ hoist-drops ]
[ hoist-drops ]
[ remove-phi-inputs ]
[ remove-phi-outputs ]
[ ]

View File

@ -4,7 +4,8 @@ compiler.tree.combinators compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io ;
kernel math stack-checker.state accessors combinators io
prettyprint ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
@ -96,9 +97,4 @@ IN: compiler.tree.dead-code.tests
[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
: non-flushable-4 ( a -- b ) drop f ;
: recursive-test-1 ( a b -- )
dup 10 < [
>r drop 5 non-flushable-4 r> 1 + recursive-test-1
] [ 2drop ] if ; inline recursive
[ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test

View File

@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple
compiler.tree.intrinsics ;
compiler.tree.intrinsics namespaces ;
\ escape-analysis must-infer
@ -295,3 +295,13 @@ C: <ro-box> ro-box
[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
dup slip impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test

View File

@ -59,10 +59,10 @@ M: #push escape-analysis*
] [ 2drop f ] if ;
: record-slot-call ( #call -- )
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
over [
[ record-slot-access ] [ copy-slot-value ] 3bi
] [ 2drop unknown-allocation ] if ;
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
[ [ record-slot-access ] [ copy-slot-value ] 3bi ]
[ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
if ;
M: #call escape-analysis*
dup word>> {
@ -88,3 +88,5 @@ M: #alien-indirect escape-analysis*
[ in-d>> add-escaping-values ]
[ out-d>> unknown-allocations ]
bi ;
M: #alien-callback escape-analysis* drop ;

View File

@ -21,10 +21,10 @@ IN: compiler.tree.optimizer
detect-loops
! invert-loops
! fuse-branches
! escape-analysis
! unbox-tuples
! compute-def-use
! remove-dead-code
escape-analysis
unbox-tuples
compute-def-use
remove-dead-code
! strength-reduce
compute-def-use USE: kernel
dup check-nodes ;

View File

@ -52,7 +52,6 @@ IN: compiler.tree.propagation.recursive
3bi ;
M: #recursive propagate-around ( #recursive -- )
"blah" USE: io print
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change

View File

@ -37,3 +37,12 @@ TUPLE: empty-tuple ;
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
! A more complicated example
: impeach-node ( quot: ( node -- ) -- )
dup slip impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test

View File

@ -58,9 +58,11 @@ M: #push unbox-tuples* ( #push -- nodes )
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
[ in-d>> second 1array #drop ]
[ prepare-slot-access slot-access-shuffle ]
bi 2array
! [ in-d>> second 1array #drop ]
! [
prepare-slot-access slot-access-shuffle
! ]
! bi 2array
] when ;
M: #call unbox-tuples*
@ -133,4 +135,6 @@ M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-callback unbox-tuples* ;
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

View File

@ -20,3 +20,6 @@ M: thread error-in-thread ( error thread -- )
error-thread get-global error-in-thread. print-error flush
] bind
] if ;
[ self error-in-thread stop ]
thread-error-hook set-global

View File

@ -223,9 +223,6 @@ GENERIC: error-in-thread ( error thread -- )
dup register-thread
set-self ;
[ self error-in-thread stop ]
thread-error-hook set-global
PRIVATE>
[ init-threads ] "threads" add-init-hook