unit tests mostly pass with new compiler
Slava Pestov
parent
69829b906b
commit
0c67037e8c
|
|
@ -0,0 +1,230 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler-backend
|
||||
USING: generic inference kernel lists math namespaces
|
||||
prettyprint strings words ;
|
||||
|
||||
! A peephole optimizer operating on the linear IR.
|
||||
|
||||
! The linear IR being simplified is stored in this variable.
|
||||
SYMBOL: simplifying
|
||||
|
||||
GENERIC: simplify-node ( linear vop -- linear ? )
|
||||
|
||||
! The next node following this node in terms of control flow, or
|
||||
! f if this is a conditional.
|
||||
GENERIC: next-logical ( linear vop -- linear )
|
||||
|
||||
! No delegation.
|
||||
M: tuple simplify-node drop f ;
|
||||
|
||||
: simplify-1 ( list -- list ? )
|
||||
#! Return a new linear IR.
|
||||
dup [
|
||||
dup car simplify-node
|
||||
[ uncons simplify-1 drop cons t ]
|
||||
[ uncons simplify-1 >r cons r> ] ifte
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
: simplify ( linear -- linear )
|
||||
#! Keep simplifying until simplify-1 returns f.
|
||||
[
|
||||
dup simplifying set simplify-1
|
||||
] with-scope [ simplify ] when ;
|
||||
|
||||
: label-called? ( label -- ? )
|
||||
simplifying get [ calls-label? ] some-with? ;
|
||||
|
||||
M: %label simplify-node ( linear vop -- linear ? )
|
||||
vop-label label-called? [ f ] [ cdr t ] ifte ;
|
||||
|
||||
: next-physical? ( linear class -- vop ? )
|
||||
#! If the following op has given class, remove it and
|
||||
#! return it.
|
||||
over cdr dup [
|
||||
car class = [ cdr car t ] [ f ] ifte
|
||||
] [
|
||||
3drop f f
|
||||
] ifte ;
|
||||
|
||||
M: %inc-d simplify-node ( linear vop -- linear ? )
|
||||
#! %inc-d cancels a following %inc-d.
|
||||
>r dup \ %inc-d next-physical? [
|
||||
vop-literal r> vop-literal + dup 0 = [
|
||||
drop cdr cdr f
|
||||
] [
|
||||
%inc-d >r cdr cdr r> swons t
|
||||
] ifte
|
||||
] [
|
||||
r> 2drop f
|
||||
] ifte ;
|
||||
|
||||
: dead-load? ( linear vop -- ? )
|
||||
#! Is the %replace-d followed by a %peek-d of the same
|
||||
#! stack slot and vreg?
|
||||
swap cdr car dup %peek-d? [
|
||||
over vop-source over vop-dest = >r
|
||||
swap vop-literal swap vop-literal = r> and
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
||||
: dead-store? ( linear n -- ? )
|
||||
#! Is the %replace-d followed by a %dec-d, so the stored
|
||||
#! value is lost?
|
||||
swap \ %inc-d next-physical? [
|
||||
vop-literal + 0 <
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
||||
M: %replace-d simplify-node ( linear vop -- linear ? )
|
||||
2dup dead-load? [
|
||||
drop uncons cdr cons t
|
||||
] [
|
||||
2dup vop-literal dead-store? [
|
||||
drop cdr t
|
||||
] [
|
||||
drop f
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
M: %immediate-d simplify-node ( linear vop -- linear ? )
|
||||
over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
|
||||
|
||||
: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
|
||||
|
||||
: can-fast-branch? ( linear -- ? )
|
||||
unswons class fast-branch [
|
||||
unswons pop? [ car %jump-t? ] [ drop f ] ifte
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
||||
: fast-branch-params ( linear -- src dest label linear )
|
||||
uncons >r dup vop-source swap vop-dest r> cdr
|
||||
uncons >r vop-label r> ;
|
||||
|
||||
M: %fixnum<= simplify-node ( linear vop -- linear ? )
|
||||
drop dup can-fast-branch? [
|
||||
fast-branch-params >r
|
||||
%jump-fixnum<= >r -1 %inc-d r>
|
||||
r> cons cons t
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
M: %eq? simplify-node ( linear vop -- linear ? )
|
||||
drop dup can-fast-branch? [
|
||||
fast-branch-params >r
|
||||
%jump-eq? >r -1 %inc-d r>
|
||||
r> cons cons t
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
: find-label ( label -- rest )
|
||||
simplifying get [
|
||||
dup %label? [ vop-label = ] [ 2drop f ] ifte
|
||||
] some-with? ;
|
||||
|
||||
M: %label next-logical ( linear vop -- linear )
|
||||
drop cdr dup car next-logical ;
|
||||
|
||||
M: %jump-label next-logical ( linear vop -- linear )
|
||||
nip vop-label find-label cdr ;
|
||||
|
||||
M: %target-label next-logical ( linear vop -- linear )
|
||||
nip vop-label find-label cdr ;
|
||||
|
||||
M: object next-logical ( linear vop -- linear )
|
||||
drop ;
|
||||
|
||||
: next-logical? ( op linear -- ? )
|
||||
dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
|
||||
|
||||
: reduce ( linear op new -- linear ? )
|
||||
>r over cdr next-logical? [
|
||||
dup car vop-label
|
||||
r> execute swap cdr cons t
|
||||
] [
|
||||
r> drop f
|
||||
] ifte ; inline
|
||||
|
||||
M: %call simplify-node ( linear vop -- ? )
|
||||
#! Tail call optimization.
|
||||
drop \ %return \ %jump reduce ;
|
||||
|
||||
M: %call-label simplify-node ( linear vop -- ? )
|
||||
#! Tail call optimization.
|
||||
drop \ %return \ %jump-label reduce ;
|
||||
|
||||
: double-jump ( linear op2 op1 -- linear ? )
|
||||
#! A jump to a jump is just a jump. If the next logical node
|
||||
#! is a jump of type op1, replace the jump at the car of the
|
||||
#! list with a jump of type op2.
|
||||
pick next-logical? [
|
||||
>r dup dup car next-logical car vop-label
|
||||
r> execute swap cdr cons t
|
||||
] [
|
||||
drop f
|
||||
] ifte ; inline
|
||||
|
||||
: useless-jump ( linear -- linear ? )
|
||||
#! A jump to a label immediately following is not needed.
|
||||
dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
|
||||
|
||||
: (dead-code) ( linear -- linear ? )
|
||||
#! Remove all nodes until the next #label.
|
||||
dup [
|
||||
dup car %label? [
|
||||
f
|
||||
] [
|
||||
cdr (dead-code) t or
|
||||
] ifte
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
: dead-code ( linear -- linear ? )
|
||||
uncons (dead-code) >r cons r> ;
|
||||
|
||||
M: %jump-label simplify-node ( linear vop -- linear ? )
|
||||
drop
|
||||
\ %return dup double-jump [
|
||||
t
|
||||
] [
|
||||
\ %jump-label dup double-jump [
|
||||
t
|
||||
] [
|
||||
\ %jump dup double-jump
|
||||
! [
|
||||
! t
|
||||
! ] [
|
||||
! useless-jump [
|
||||
! t
|
||||
! ] [
|
||||
! dead-code
|
||||
! ] ifte
|
||||
! ] ifte
|
||||
] ifte
|
||||
] ifte ;
|
||||
!
|
||||
! #jump-label [
|
||||
! [ #return #return double-jump ]
|
||||
! [ #jump-label #jump-label double-jump ]
|
||||
! [ #jump #jump double-jump ]
|
||||
! [ useless-jump ]
|
||||
! [ dead-code ]
|
||||
! ] "simplifiers" set-word-prop
|
||||
!
|
||||
! #target-label [
|
||||
! [ #target-label #jump-label double-jump ]
|
||||
! ! [ #target #jump double-jump ]
|
||||
! ] "simplifiers" set-word-prop
|
||||
!
|
||||
! #jump [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
! #return [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
! #end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
|
|
@ -2,6 +2,7 @@ IN: temporary
|
|||
USE: test
|
||||
USE: kernel
|
||||
USE: compiler
|
||||
USE: compiler-frontend
|
||||
USE: inference
|
||||
USE: words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,13 @@
|
|||
IN: temporary
|
||||
USE: test
|
||||
USE: compiler
|
||||
USE: compiler-frontend
|
||||
USE: inference
|
||||
USE: words
|
||||
USE: math
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: sequences
|
||||
|
||||
: foo 1 2 3 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,75 +0,0 @@
|
|||
IN: temporary
|
||||
USE: compiler
|
||||
USE: test
|
||||
USE: inference
|
||||
USE: lists
|
||||
USE: kernel
|
||||
USE: namespaces
|
||||
|
||||
[ t ] [ \ >r [ [ r> ] [ >r ] ] next-physical? ] unit-test
|
||||
[ f t ] [ [ [ r> ] [ >r ] ] \ >r cancel nip ] unit-test
|
||||
[ [ [ >r ] [ r> ] ] f ] [ [ [ >r ] [ r> ] ] \ >r cancel nip ] unit-test
|
||||
|
||||
[ [ [ #jump 123 ] [ #return ] ] t ]
|
||||
[ [ [ #call 123 ] [ #return ] ] #return #jump reduce ] unit-test
|
||||
|
||||
[ [ ] ] [ [ ] simplify ] unit-test
|
||||
[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
|
||||
[ [[ #jump car ]] ] [ [ [[ #call car ]] [ #return ] ] simplify car ] unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[
|
||||
[
|
||||
123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ]
|
||||
simplifying set find-label cdr
|
||||
] with-scope
|
||||
]
|
||||
unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[
|
||||
[
|
||||
[
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #call car ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] dup simplifying set next-logical
|
||||
] with-scope
|
||||
]
|
||||
unit-test
|
||||
|
||||
[
|
||||
[ [[ #return f ]] ]
|
||||
]
|
||||
[
|
||||
[
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] simplify
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[ [[ #jump car ]] ]
|
||||
]
|
||||
[
|
||||
[
|
||||
[[ #call car ]]
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] simplify
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[ [[ swap f ]] ]
|
||||
] [
|
||||
[
|
||||
[[ #jump-label 1 ]]
|
||||
[[ #label 1 ]]
|
||||
[[ #jump-label 2 ]]
|
||||
[[ #label 2 ]]
|
||||
[[ swap f ]]
|
||||
] simplify
|
||||
] unit-test
|
||||
|
|
@ -22,6 +22,8 @@ USING: kernel math test unparser ;
|
|||
|
||||
[ -1 ] [ 1 neg ] unit-test
|
||||
[ -1 ] [ 1 >bignum neg ] unit-test
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test
|
||||
[ 268435456 ] [ -268435456 >fixnum neg ] unit-test
|
||||
|
||||
[ 9 3 ] [ 93 10 /mod ] unit-test
|
||||
[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,8 +5,10 @@ USE: math
|
|||
USE: namespaces
|
||||
USE: random
|
||||
USE: test
|
||||
USE: errors
|
||||
|
||||
: check-random-int ( min max -- )
|
||||
2dup random-int -rot between? assert ;
|
||||
2dup random-int -rot between?
|
||||
[ "Assertion failed" throw ] unless ;
|
||||
|
||||
[ ] [ 100 [ -12 674 check-random-int ] times ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,4 +16,4 @@ USING: kernel math namespaces sequences strings test ;
|
|||
CHAR: H 0 SBUF" hello world" [ set-nth ] keep 0 swap nth
|
||||
] unit-test
|
||||
|
||||
[ SBUF" x" ] [ 1 <sbuf> [ CHAR: x >bignum over push ] keep ] unit-test
|
||||
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ SYMBOL: failures
|
|||
cpu "unknown" = [
|
||||
[
|
||||
"io/buffer" "compiler/optimizer"
|
||||
"compiler/simplifier" "compiler/simple"
|
||||
"compiler/simple"
|
||||
"compiler/stack" "compiler/ifte"
|
||||
"compiler/generic" "compiler/bail-out"
|
||||
"compiler/linearizer" "compiler/intrinsics"
|
||||
|
|
|
|||
|
|
@ -28,7 +28,5 @@ unit-test
|
|||
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
|
||||
|
||||
[ ] [ { 1 2 3 } unparse drop ] unit-test
|
||||
! Unreadable objects
|
||||
[ { 1 2 3 } vector-array unparse parse ] unit-test-fails
|
||||
|
||||
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
|
||||
|
|
|
|||
|
|
@ -75,14 +75,14 @@ unit-test
|
|||
[ "funky" ] [ "funny-stack" get pop ] unit-test
|
||||
|
||||
[ t ] [
|
||||
{ 1 2 3 4 } dup vector-array length
|
||||
>r clone vector-array length r>
|
||||
{ 1 2 3 4 } dup underlying length
|
||||
>r clone underlying length r>
|
||||
=
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ 1 2 3 4 } dup clone
|
||||
swap vector-array swap vector-array eq?
|
||||
swap underlying swap underlying eq?
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
|
|
|
|||
Loading…
Reference in New Issue