Debugging compiler
parent
1997cbe9aa
commit
74dccc7fbf
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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* ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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 ] }
|
||||||
|
|
|
@ -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 >
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
Loading…
Reference in New Issue