Debugging new codegen
parent
7b6d9c4c4f
commit
0e4e05d5cd
|
@ -158,8 +158,6 @@ M: #if emit-node
|
||||||
init-phantoms
|
init-phantoms
|
||||||
##prologue
|
##prologue
|
||||||
[ emit-nodes ] with-node-iterator
|
[ emit-nodes ] with-node-iterator
|
||||||
##epilogue
|
|
||||||
##return
|
|
||||||
] with-cfg-builder
|
] with-cfg-builder
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
|
@ -304,7 +302,8 @@ M: #return-recursive emit-node
|
||||||
[ ##epilogue ##return ] unless stop-iterating ;
|
[ ##epilogue ##return ] unless stop-iterating ;
|
||||||
|
|
||||||
! #terminate
|
! #terminate
|
||||||
M: #terminate emit-node drop stop-iterating ;
|
M: #terminate emit-node
|
||||||
|
drop finalize-phantoms stop-iterating ;
|
||||||
|
|
||||||
! FFI
|
! FFI
|
||||||
: return-size ( ctype -- n )
|
: return-size ( ctype -- n )
|
||||||
|
|
|
@ -305,9 +305,7 @@ M: loc lazy-store
|
||||||
: set-value-classes ( classes -- )
|
: set-value-classes ( classes -- )
|
||||||
phantom-datastack get
|
phantom-datastack get
|
||||||
over length over add-locs
|
over length over add-locs
|
||||||
stack>> [
|
stack>> [ set-value-class ] 2reverse-each ;
|
||||||
[ value-class class-and ] keep set-value-class
|
|
||||||
] 2reverse-each ;
|
|
||||||
|
|
||||||
: finalize-phantoms ( -- )
|
: finalize-phantoms ( -- )
|
||||||
#! Commit all deferred stacking shuffling, and ensure the
|
#! Commit all deferred stacking shuffling, and ensure the
|
||||||
|
|
|
@ -144,7 +144,8 @@ M: _branch-t generate-insn
|
||||||
|
|
||||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||||
|
|
||||||
M: ##dispatch generate-insn drop %dispatch ;
|
M: ##dispatch generate-insn
|
||||||
|
[ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
|
||||||
|
|
||||||
: dst/src ( insn -- dst src )
|
: dst/src ( insn -- dst src )
|
||||||
[ dst>> v>operand ] [ src>> v>operand ] bi ;
|
[ dst>> v>operand ] [ src>> v>operand ] bi ;
|
||||||
|
|
|
@ -461,3 +461,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
|
||||||
] compile-call
|
] compile-call
|
||||||
b>>
|
b>>
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
: mutable-value-bug-1 ( a b -- c )
|
||||||
|
swap [
|
||||||
|
{ tuple } declare 1 slot
|
||||||
|
] [
|
||||||
|
0 slot
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
|
||||||
|
|
||||||
|
: mutable-value-bug-2 ( a b -- c )
|
||||||
|
swap [
|
||||||
|
0 slot
|
||||||
|
] [
|
||||||
|
{ tuple } declare 1 slot
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
|
||||||
|
|
|
@ -1,9 +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 arrays accessors sequences sequences.private words
|
USING: kernel arrays accessors sequences sequences.private words
|
||||||
fry namespaces make math math.order memoize classes.builtin
|
fry namespaces make math math.private math.order memoize
|
||||||
classes.tuple.private slots.private combinators layouts
|
classes.builtin classes.tuple.private classes.algebra
|
||||||
byte-arrays alien.accessors
|
slots.private combinators layouts byte-arrays alien.accessors
|
||||||
compiler.intrinsics
|
compiler.intrinsics
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.combinators
|
compiler.tree.combinators
|
||||||
|
@ -23,6 +23,10 @@ IN: compiler.tree.finalization
|
||||||
|
|
||||||
GENERIC: finalize* ( node -- nodes )
|
GENERIC: finalize* ( node -- nodes )
|
||||||
|
|
||||||
|
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
|
||||||
|
|
||||||
|
: splice-final ( quot -- nodes ) splice-quot finalize ;
|
||||||
|
|
||||||
M: #copy finalize* drop f ;
|
M: #copy finalize* drop f ;
|
||||||
|
|
||||||
M: #shuffle finalize*
|
M: #shuffle finalize*
|
||||||
|
@ -34,30 +38,30 @@ M: #shuffle finalize*
|
||||||
word>> "predicating" word-prop builtin-class? ;
|
word>> "predicating" word-prop builtin-class? ;
|
||||||
|
|
||||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||||
def>> splice-quot ;
|
def>> splice-final ;
|
||||||
|
|
||||||
: expand-builtin-predicate ( #call -- nodes )
|
: expand-builtin-predicate ( #call -- nodes )
|
||||||
word>> builtin-predicate-expansion ;
|
word>> builtin-predicate-expansion ;
|
||||||
|
|
||||||
: first-literal ( #call -- obj ) node-input-infos first literal>> ;
|
|
||||||
|
|
||||||
: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
|
|
||||||
|
|
||||||
: expand-tuple-boa? ( #call -- ? )
|
: expand-tuple-boa? ( #call -- ? )
|
||||||
dup word>> \ <tuple-boa> eq? [
|
dup word>> \ <tuple-boa> eq? [
|
||||||
last-literal tuple-layout?
|
last-literal tuple-layout?
|
||||||
] [ drop f ] if ;
|
] [ drop f ] if ;
|
||||||
|
|
||||||
MEMO: (tuple-boa-expansion) ( n -- quot )
|
MEMO: (tuple-boa-expansion) ( n -- nodes )
|
||||||
[
|
[
|
||||||
[ 2 + ] map <reversed>
|
[ '[ _ (tuple) ] % ]
|
||||||
[ '[ [ _ set-slot ] keep ] % ] each
|
[
|
||||||
] [ ] make ;
|
[ 2 + ] map <reversed>
|
||||||
|
[ '[ [ _ set-slot ] keep ] % ] each
|
||||||
|
] bi
|
||||||
|
] [ ] make '[ _ dip ] splice-final ;
|
||||||
|
|
||||||
: tuple-boa-expansion ( layout -- quot )
|
: tuple-boa-expansion ( layout -- quot )
|
||||||
#! No memoization here since otherwise we'd hang on to
|
#! No memoization here since otherwise we'd hang on to
|
||||||
#! tuple layout objects.
|
#! tuple layout objects.
|
||||||
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
|
size>> (tuple-boa-expansion)
|
||||||
|
[ over 1 set-slot ] splice-final append ;
|
||||||
|
|
||||||
: expand-tuple-boa ( #call -- node )
|
: expand-tuple-boa ( #call -- node )
|
||||||
last-literal tuple-boa-expansion ;
|
last-literal tuple-boa-expansion ;
|
||||||
|
@ -65,14 +69,15 @@ MEMO: (tuple-boa-expansion) ( n -- quot )
|
||||||
MEMO: <array>-expansion ( n -- quot )
|
MEMO: <array>-expansion ( n -- quot )
|
||||||
[
|
[
|
||||||
[ swap (array) ] %
|
[ swap (array) ] %
|
||||||
[ \ 2dup , , [ swap set-array-nth ] % ] each
|
[ '[ _ over 1 set-slot ] % ]
|
||||||
|
[ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
|
||||||
\ nip ,
|
\ nip ,
|
||||||
] [ ] make splice-quot ;
|
] [ ] make splice-final ;
|
||||||
|
|
||||||
: expand-<array>? ( #call -- ? )
|
: expand-<array>? ( #call -- ? )
|
||||||
dup word>> \ <array> eq? [
|
dup word>> \ <array> eq? [
|
||||||
first-literal dup integer?
|
first-literal dup integer?
|
||||||
[ 0 32 between? ] [ drop f ] if
|
[ 0 8 between? ] [ drop f ] if
|
||||||
] [ drop f ] if ;
|
] [ drop f ] if ;
|
||||||
|
|
||||||
: expand-<array> ( #call -- node )
|
: expand-<array> ( #call -- node )
|
||||||
|
@ -83,28 +88,62 @@ MEMO: <array>-expansion ( n -- quot )
|
||||||
MEMO: <byte-array>-expansion ( n -- quot )
|
MEMO: <byte-array>-expansion ( n -- quot )
|
||||||
[
|
[
|
||||||
[ (byte-array) ] %
|
[ (byte-array) ] %
|
||||||
bytes>cells [ cell * ] map
|
[ '[ _ over 1 set-slot ] % ]
|
||||||
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
|
[
|
||||||
] [ ] make splice-quot ;
|
bytes>cells [
|
||||||
|
cell *
|
||||||
|
'[ 0 over _ set-alien-unsigned-cell ] %
|
||||||
|
] each
|
||||||
|
] bi
|
||||||
|
] [ ] make splice-final ;
|
||||||
|
|
||||||
: expand-<byte-array>? ( #call -- ? )
|
: expand-<byte-array>? ( #call -- ? )
|
||||||
dup word>> \ <byte-array> eq? [
|
dup word>> \ <byte-array> eq? [
|
||||||
first-literal dup integer?
|
first-literal dup integer?
|
||||||
[ 0 128 between? ] [ drop f ] if
|
[ 0 32 between? ] [ drop f ] if
|
||||||
] [ drop f ] if ;
|
] [ drop f ] if ;
|
||||||
|
|
||||||
: expand-<byte-array> ( #call -- nodes )
|
: expand-<byte-array> ( #call -- nodes )
|
||||||
first-literal <byte-array>-expansion ;
|
first-literal <byte-array>-expansion ;
|
||||||
|
|
||||||
|
MEMO: <ratio>-expansion ( -- quot )
|
||||||
|
[ (ratio) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
|
||||||
|
|
||||||
|
: expand-<ratio> ( #call -- nodes )
|
||||||
|
drop <ratio>-expansion ;
|
||||||
|
|
||||||
|
MEMO: <complex>-expansion ( -- quot )
|
||||||
|
[ (complex) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
|
||||||
|
|
||||||
|
: expand-<complex> ( #call -- nodes )
|
||||||
|
drop <complex>-expansion ;
|
||||||
|
|
||||||
|
MEMO: <wrapper>-expansion ( -- quot )
|
||||||
|
[ (wrapper) [ 1 set-slot ] keep ] splice-final ;
|
||||||
|
|
||||||
|
: expand-<wrapper> ( #call -- nodes )
|
||||||
|
drop <wrapper>-expansion ;
|
||||||
|
|
||||||
|
: expand-set-slot ( #call -- nodes )
|
||||||
|
dup in-d>> first node-value-info class>> immediate class<=
|
||||||
|
[ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ?
|
||||||
|
splice-final ;
|
||||||
|
|
||||||
M: #call finalize*
|
M: #call finalize*
|
||||||
{
|
{
|
||||||
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
|
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
|
||||||
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
|
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
|
||||||
{ [ dup expand-<array>? ] [ expand-<array> ] }
|
{ [ dup expand-<array>? ] [ expand-<array> ] }
|
||||||
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
|
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
|
||||||
[ ]
|
[
|
||||||
|
dup word>> {
|
||||||
|
{ \ <ratio> [ expand-<ratio> ] }
|
||||||
|
{ \ <complex> [ expand-<complex> ] }
|
||||||
|
{ \ <wrapper> [ expand-<wrapper> ] }
|
||||||
|
{ \ set-slot [ expand-set-slot ] }
|
||||||
|
[ drop ]
|
||||||
|
} case
|
||||||
|
]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: node finalize* ;
|
M: node finalize* ;
|
||||||
|
|
||||||
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
|
|
||||||
|
|
|
@ -63,7 +63,7 @@ HOOK: %jump-f cpu ( label vreg -- )
|
||||||
! Test if vreg is 't' or not
|
! Test if vreg is 't' or not
|
||||||
HOOK: %jump-t cpu ( label vreg -- )
|
HOOK: %jump-t cpu ( label vreg -- )
|
||||||
|
|
||||||
HOOK: %dispatch cpu ( -- )
|
HOOK: %dispatch cpu ( src temp -- )
|
||||||
|
|
||||||
HOOK: %dispatch-label cpu ( word -- )
|
HOOK: %dispatch-label cpu ( word -- )
|
||||||
|
|
||||||
|
|
|
@ -69,9 +69,9 @@ M: x86 stack-frame-size ( n -- i )
|
||||||
|
|
||||||
M: x86 %prologue ( n -- )
|
M: x86 %prologue ( n -- )
|
||||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||||
dup cell + PUSH
|
dup PUSH
|
||||||
temp-reg-1 PUSH
|
temp-reg-1 PUSH
|
||||||
stack-reg swap 2 cells - SUB ;
|
stack-reg swap 3 cells - SUB ;
|
||||||
|
|
||||||
: incr-stack-reg ( n -- )
|
: incr-stack-reg ( n -- )
|
||||||
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
||||||
|
|
|
@ -78,21 +78,23 @@ SYMBOL: quotations
|
||||||
V{ } clone meta-r set
|
V{ } clone meta-r set
|
||||||
d-in [ ] change ;
|
d-in [ ] change ;
|
||||||
|
|
||||||
: infer-branch ( literal -- namespace )
|
: infer-branch ( literal quot -- namespace )
|
||||||
[
|
[
|
||||||
copy-inference
|
copy-inference
|
||||||
nest-visitor
|
nest-visitor
|
||||||
[ value>> quotation set ] [ infer-literal-quot ] bi
|
[ [ value>> quotation set ] [ infer-literal-quot ] bi ] dip
|
||||||
check->r
|
check->r
|
||||||
|
call
|
||||||
] H{ } make-assoc ; inline
|
] H{ } make-assoc ; inline
|
||||||
|
|
||||||
: infer-branches ( branches -- input children data )
|
: infer-branches ( branches quot -- input children data )
|
||||||
[ pop-d ] dip
|
[ pop-d ] 2dip
|
||||||
[ infer-branch ] map
|
[ infer-branch ] curry map
|
||||||
[ stack-visitor branch-variable ] keep ;
|
[ stack-visitor branch-variable ] keep ; inline
|
||||||
|
|
||||||
: (infer-if) ( branches -- )
|
: (infer-if) ( branches -- )
|
||||||
infer-branches [ first2 #if, ] dip compute-phi-function ;
|
[ ] infer-branches
|
||||||
|
[ first2 #if, ] dip compute-phi-function ;
|
||||||
|
|
||||||
: infer-if ( -- )
|
: infer-if ( -- )
|
||||||
2 consume-d
|
2 consume-d
|
||||||
|
@ -106,4 +108,5 @@ SYMBOL: quotations
|
||||||
|
|
||||||
: infer-dispatch ( -- )
|
: infer-dispatch ( -- )
|
||||||
pop-literal nip [ <literal> ] map
|
pop-literal nip [ <literal> ] map
|
||||||
infer-branches [ #dispatch, ] dip compute-phi-function ;
|
[ f #return, ] infer-branches
|
||||||
|
[ #dispatch, ] dip compute-phi-function ;
|
||||||
|
|
Loading…
Reference in New Issue