Debugging compiler

db4
Slava Pestov 2008-08-28 22:28:34 -05:00
parent 1997cbe9aa
commit 74dccc7fbf
16 changed files with 84 additions and 44 deletions

View File

@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer ; compiler.tree.builder compiler.tree.optimizer sequences.deep ;
IN: optimizer.tests IN: optimizer.tests
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
@ -353,3 +353,8 @@ TUPLE: some-tuple x ;
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test

View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry USING: kernel accessors sequences sequences.deep combinators fry
classes.algebra namespaces assocs math math.private classes.algebra namespaces assocs words math math.private
math.partial-dispatch classes.tuple classes.tuple.private math.partial-dispatch classes classes.tuple classes.tuple.private
definitions stack-checker.state stack-checker.branches definitions stack-checker.state stack-checker.branches
compiler.tree compiler.tree
compiler.tree.intrinsics compiler.tree.intrinsics

View File

@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
: call-recursive-dce-7 ( obj -- elt ? )
dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test

View File

@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
#! corresponding inputs to the #call-recursive are live also. #! corresponding inputs to the #call-recursive are live also.
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ; [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
: return-recursive-phi-in ( #return-recursive -- phi-in )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
M: #return-recursive compute-live-values* M: #return-recursive compute-live-values*
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ; [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
M: #call-recursive compute-live-values* M: #call-recursive compute-live-values*
#! If the output of a #call-recursive is live, then the #! If the output of a #call-recursive is live, then the
@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
drop-values drop-values
] ; ] ;
M: #recursive remove-dead-code* ( node -- nodes )
dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
{
[ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
[ drop [ (remove-dead-code) ] change-child drop ]
[ drop label>> [ filter-live ] change-enter-out drop ]
[ swap 2array ]
} 2cleave ;
M: #enter-recursive remove-dead-code* M: #enter-recursive remove-dead-code*
[ filter-live ] change-out-d ; [ filter-live ] change-out-d ;
@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
[ drop-call-recursive-outputs ] [ drop-call-recursive-outputs ]
tri 3array ; tri 3array ;
M: #return-recursive remove-dead-code* ( node -- nodes ) :: drop-recursive-inputs ( node -- shuffle )
dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
[ drop [ filter-live ] change-out-d drop ] new-outputs [ shuffle out-d>> ] |
[ out-d>> >>in-d drop ] node new-outputs
[ swap 2array ] [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
2tri ; shuffle
] ;
:: drop-recursive-outputs ( node -- shuffle )
[let* | return [ node label>> return>> ]
new-inputs [ return in-d>> filter-live ]
new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
return
[ new-inputs >>in-d new-outputs >>out-d drop ]
[ drop-dead-outputs ]
bi
] ;
M:: #recursive remove-dead-code* ( node -- nodes )
[let* | drop-inputs [ node drop-recursive-inputs ]
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
drop-inputs node drop-outputs 3array
] ;
M: #return-recursive remove-dead-code* ;

View File

@ -1,7 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces USING: kernel accessors words assocs sequences arrays namespaces
fry locals classes.algebra stack-checker.backend fry locals definitions classes.algebra
stack-checker.state
stack-checker.backend
compiler.tree compiler.tree
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.dead-code.liveness ; compiler.tree.dead-code.liveness ;
@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
] ; ] ;
: drop-dead-outputs ( node -- nodes ) : drop-dead-outputs ( node -- nodes )
dup out-d>> drop-dead-values dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
[ in-d>> >>out-d drop ] [ 2array ] 2bi ;
M: #introduce remove-dead-code* ( #introduce -- nodes ) M: #introduce remove-dead-code* ( #introduce -- nodes )
drop-dead-outputs ; dup drop-dead-outputs 2array ;
M: #>r remove-dead-code* M: #>r remove-dead-code*
[ filter-live ] change-out-r [ filter-live ] change-out-r
@ -105,7 +106,9 @@ M: #push remove-dead-code*
] [ drop f ] if ; ] [ drop f ] if ;
: remove-flushable-call ( #call -- node ) : remove-flushable-call ( #call -- node )
in-d>> #drop remove-dead-code* ; [ word>> +inlined+ depends-on ]
[ in-d>> #drop remove-dead-code* ]
bi ;
: some-outputs-dead? ( #call -- ? ) : some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] contains? ; out-d>> [ live-value? not ] contains? ;
@ -115,7 +118,7 @@ M: #call remove-dead-code*
remove-flushable-call remove-flushable-call
] [ ] [
dup some-outputs-dead? [ dup some-outputs-dead? [
drop-dead-outputs dup drop-dead-outputs 2array
] when ] when
] if ; ] if ;

View File

@ -125,21 +125,20 @@ SYMBOL: history
: remember-inlining ( word -- ) : remember-inlining ( word -- )
history [ swap suffix ] change ; history [ swap suffix ] change ;
: inline-word ( #call word -- ) : inline-word ( #call word -- ? )
dup history get memq? [ dup history get memq? [
2drop 2drop f
] [ ] [
[ [
dup remember-inlining dup remember-inlining
dupd def>> splicing-nodes >>body dupd def>> splicing-nodes >>body
propagate-body propagate-body
] with-scope ] with-scope
t
] if ; ] if ;
: inline-method-body ( #call word -- ? ) : inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word t ] [ 2drop f ] if ; 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
: always-inline-word? ( word -- ? ) : always-inline-word? ( word -- ? )
{ curry compose } memq? ; { curry compose } memq? ;
: always-inline-word ( #call word -- ? ) inline-word t ;

View File

@ -93,7 +93,7 @@ M: #declare propagate-before
: do-inlining ( #call word -- ? ) : do-inlining ( #call word -- ? )
{ {
{ [ dup always-inline-word? ] [ always-inline-word ] } { [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] } { [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] } { [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] } { [ dup math-partial? ] [ inline-math-partial ] }

View File

@ -67,8 +67,10 @@ SYMBOL: enter-out
[ entry-stack-height current-stack-height swap - ] [ entry-stack-height current-stack-height swap - ]
bi* bi*
= [ 2drop ] [ = [ 2drop ] [
terminated? get [ 2drop ] [
word>> current-stack-height word>> current-stack-height
unbalanced-recursion-error inference-error unbalanced-recursion-error inference-error
] if
] if ; ] if ;
: end-recursive-word ( word label -- ) : end-recursive-word ( word label -- )
@ -79,7 +81,7 @@ SYMBOL: enter-out
: recursive-word-inputs ( label -- n ) : recursive-word-inputs ( label -- n )
entry-stack-height d-in get + ; entry-stack-height d-in get + ;
: (inline-recursive-word) ( word -- label in out visitor ) : (inline-recursive-word) ( word -- label in out visitor terminated? )
dup prepare-stack dup prepare-stack
[ [
init-inference init-inference
@ -96,11 +98,13 @@ SYMBOL: enter-out
dup recursive-word-inputs dup recursive-word-inputs
meta-d get meta-d get
stack-visitor get stack-visitor get
terminated? get
] with-scope ; ] with-scope ;
: inline-recursive-word ( word -- ) : inline-recursive-word ( word -- )
(inline-recursive-word) (inline-recursive-word)
[ consume-d ] [ output-d ] [ ] tri* #recursive, ; [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
[ terminate ] when ;
: check-call-height ( label -- ) : check-call-height ( label -- )
dup entry-stack-height current-stack-height > dup entry-stack-height current-stack-height >

View File

@ -575,3 +575,8 @@ DEFER: eee'
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
[ [ eee' ] infer ] [ inference-error? ] must-fail-with [ [ eee' ] infer ] [ inference-error? ] must-fail-with
: bogus-error ( x -- )
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
[ bogus-error ] must-infer

View File

@ -88,8 +88,7 @@ SYMBOL: prolog-data
: next* ( -- ) : next* ( -- )
get-char [ (next) record ] when ; get-char [ (next) record ] when ;
: skip-until ( quot -- ) : skip-until ( quot: ( -- ? ) -- )
#! quot: ( -- ? )
get-char [ get-char [
[ call ] keep swap [ drop ] [ [ call ] keep swap [ drop ] [
next skip-until next skip-until

View File

@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
MIXIN: empty-mixin
[ f ] [ "hi" empty-mixin? ] unit-test

View File

@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
dup mixin-class? [ dup mixin-class? [
drop drop
] [ ] [
{ } redefine-mixin-class [ { } redefine-mixin-class ]
[ update-classes ]
bi
] if ; ] if ;
TUPLE: check-mixin-class mixin ; TUPLE: check-mixin-class mixin ;

View File

@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
tri* define-declared tri* define-declared
] 3tri ; ] 3tri ;
M: tuple-class update-generic
over new-class? [ 2drop ] [ call-next-method ] if ;
M: tuple-class reset-class M: tuple-class reset-class
[ [
dup "slots" word-prop [ dup "slots" word-prop [

View File

@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ; values ;
: update-generic ( class generic -- ) GENERIC# update-generic 1 ( class generic -- )
M: class update-generic
affected-methods [ +called+ changed-definition ] each ; affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- ) : with-methods ( class generic quot -- )

View File

@ -24,7 +24,7 @@ t parser-notes set-global
: note. ( str -- ) : note. ( str -- )
parser-notes? [ parser-notes? [
file get [ path>> write ] when* file get [ path>> write ":" write ] when*
lexer get line>> number>string write ": " write lexer get line>> number>string write ": " write
"Note: " write dup print "Note: " write dup print
] when drop ; ] when drop ;