compiler does tail call optimization
Slava Pestov
parent
d9afca04f8
commit
a2717958f0
|
|
@ -129,7 +129,7 @@ SYMBOL: #target ( part of jump table )
|
|||
<label> [
|
||||
#jump-t swons ,
|
||||
(linearize) ( false branch )
|
||||
<label> dup #jump swons ,
|
||||
<label> dup #jump-label swons ,
|
||||
] keep label, ( branch target of BRANCH-T )
|
||||
swap (linearize) ( true branch )
|
||||
label, ( branch target of false branch end ) ;
|
||||
|
|
@ -147,7 +147,9 @@ SYMBOL: #target ( part of jump table )
|
|||
|
||||
: dispatch-body ( end label/param -- )
|
||||
#! Output each branch, with a jump to the end label.
|
||||
[ uncons label, (linearize) dup #jump swons , ] each drop ;
|
||||
[
|
||||
uncons label, (linearize) dup #jump-label swons ,
|
||||
] each drop ;
|
||||
|
||||
: check-dispatch ( vtable -- )
|
||||
length num-types = [
|
||||
|
|
|
|||
|
|
@ -63,8 +63,15 @@ USE: words
|
|||
] each drop
|
||||
] make-list ;
|
||||
|
||||
: singleton ( word op default -- )
|
||||
>r word-property dup [
|
||||
r> drop call
|
||||
] [
|
||||
drop r> call
|
||||
] ifte ;
|
||||
|
||||
: simplify-node ( node rest -- rest ? )
|
||||
over car "simplifier" word-property [
|
||||
over car "simplify" word-property [
|
||||
call
|
||||
] [
|
||||
swap , f
|
||||
|
|
@ -79,7 +86,23 @@ USE: words
|
|||
: simplify ( linear -- linear )
|
||||
purge-labels [ (simplify) ] make-list ;
|
||||
|
||||
: follows? ( op list -- ? ) dup [ car car = ] [ 2drop f ] ifte ;
|
||||
: follow ( linear -- linear )
|
||||
dup car car "follow" word-property dup [
|
||||
call
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
|
||||
#label [
|
||||
cdr follow
|
||||
] "follow" set-word-property
|
||||
|
||||
#jump-label [
|
||||
uncons >r cdr r> find-label follow
|
||||
] "follow" set-word-property
|
||||
|
||||
: follows? ( op linear -- ? )
|
||||
follow dup [ car car = ] [ 2drop f ] ifte ;
|
||||
|
||||
GENERIC: call-simplifier ( node rest -- rest ? )
|
||||
M: cons call-simplifier ( node rest -- ? )
|
||||
|
|
@ -93,5 +116,5 @@ M: return-follows call-simplifier ( node rest -- rest ? )
|
|||
[ #call-label | #jump-label ]
|
||||
] assoc swons , r> t ;
|
||||
|
||||
#call [ call-simplifier ] "simplifier" set-word-property
|
||||
#call-label [ call-simplifier ] "simplifier" set-word-property
|
||||
#call [ call-simplifier ] "simplify" set-word-property
|
||||
#call-label [ call-simplifier ] "simplify" set-word-property
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@ USE: math
|
|||
USE: test
|
||||
|
||||
: empty-loop-1 ( n -- )
|
||||
[ ] times ;
|
||||
[ ] times ; compiled
|
||||
|
||||
: empty-loop-2 ( n -- )
|
||||
[ drop ] times* ;
|
||||
[ drop ] times* ; compiled
|
||||
|
||||
[ ] [ 5000000 empty-loop-1 ] unit-test
|
||||
[ ] [ 5000000 empty-loop-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
IN: scratchpad
|
||||
USE: math
|
||||
USE: test
|
||||
USE: compiler
|
||||
|
||||
[ 1 ] [ 10000 fac 10000 [ succ / ] times* ] unit-test
|
||||
: fac-benchmark
|
||||
10000 fac 10000 [ succ / ] times* ; compiled
|
||||
|
||||
[ 1 ] [ fac-benchmark ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,16 +4,17 @@ USE: math
|
|||
USE: test
|
||||
USE: unparser
|
||||
USE: hashtables
|
||||
USE: compiler
|
||||
|
||||
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
|
||||
|
||||
: store-hash ( hashtable n -- )
|
||||
[ dup >hex swap pick set-hash ] times* drop ;
|
||||
[ dup >hex swap pick set-hash ] times* drop ; compiled
|
||||
|
||||
: lookup-hash ( hashtable n -- )
|
||||
[ unparse over hash drop ] times* drop ;
|
||||
[ unparse over hash drop ] times* drop ; compiled
|
||||
|
||||
: hashtable-benchmark ( n -- )
|
||||
60000 <hashtable> swap 2dup store-hash lookup-hash ;
|
||||
60000 <hashtable> swap 2dup store-hash lookup-hash ; compiled
|
||||
|
||||
[ ] [ 80000 hashtable-benchmark ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ USE: kernel
|
|||
USE: math
|
||||
USE: test
|
||||
USE: lists
|
||||
USE: compiler
|
||||
|
||||
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
|
||||
|
||||
|
|
@ -14,9 +15,9 @@ USE: lists
|
|||
string-step
|
||||
] [
|
||||
2drop
|
||||
] ifte ;
|
||||
] ifte ; compiled
|
||||
|
||||
: string-benchmark ( n -- )
|
||||
"abcdef" 10 [ 2dup string-step ] times 2drop ;
|
||||
"abcdef" 10 [ 2dup string-step ] times 2drop ; compiled
|
||||
|
||||
[ ] [ 1000000 string-benchmark ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,17 +7,17 @@ USE: test
|
|||
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
|
||||
|
||||
: fill-vector ( n -- vector )
|
||||
dup <vector> swap [ dup pick set-vector-nth ] times* ;
|
||||
dup <vector> swap [ dup pick set-vector-nth ] times* ; compiled
|
||||
|
||||
: copy-elt ( vec-y vec-x n -- )
|
||||
#! Copy nth element from vec-x to vec-y.
|
||||
rot >r tuck >r vector-nth r> r> set-vector-nth ;
|
||||
rot >r tuck >r vector-nth r> r> set-vector-nth ; compiled
|
||||
|
||||
: copy-vector ( vec-y vec-x n -- )
|
||||
#! Copy first n-1 elements from vec-x to vec-y.
|
||||
[ >r 2dup r> copy-elt ] times* 2drop ;
|
||||
[ >r 2dup r> copy-elt ] times* 2drop ; compiled
|
||||
|
||||
: vector-benchmark ( n -- )
|
||||
0 <vector> over fill-vector rot copy-vector ; ! compiled
|
||||
0 <vector> over fill-vector rot copy-vector ; compiled
|
||||
|
||||
[ ] [ 4000000 vector-benchmark ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,8 +6,35 @@ USE: lists
|
|||
|
||||
[ [ ] ] [ [ ] simplify ] unit-test
|
||||
[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
|
||||
[ [ [ #jump | car ] ] ] [ [ [ #call | car ] [ #return ] ] simplify ] unit-test
|
||||
[ [ #jump | car ] ] [ [ [ #call | car ] [ #return ] ] simplify car ] unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ]
|
||||
unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[ [ [ #label | 123 ] [ #return ] ] follow ]
|
||||
unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[
|
||||
[
|
||||
[ #jump-label | 123 ]
|
||||
[ #call | car ]
|
||||
[ #label | 123 ]
|
||||
[ #return ]
|
||||
] follow
|
||||
]
|
||||
unit-test
|
||||
|
||||
[
|
||||
[ #jump | car ]
|
||||
]
|
||||
[
|
||||
[
|
||||
[ #call | car ]
|
||||
[ #jump-label | 123 ]
|
||||
[ #label | 123 ]
|
||||
[ #return ]
|
||||
] simplify car
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -54,3 +54,5 @@ USE: lists
|
|||
! See how well callstack overflow is handled
|
||||
: callstack-overflow callstack-overflow f ;
|
||||
[ callstack-overflow ] unit-test-fails
|
||||
|
||||
[ [ cdr cons ] word-plist ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -119,6 +119,7 @@ USE: unparser
|
|||
cpu "x86" = [
|
||||
[
|
||||
"compiler/optimizer"
|
||||
"compiler/simplifier"
|
||||
"compiler/simple"
|
||||
"compiler/stack"
|
||||
"compiler/ifte"
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ INLINE CELL tag_header(CELL cell)
|
|||
return RETAG(cell << TAG_BITS,HEADER_TYPE);
|
||||
}
|
||||
|
||||
#define HEADER_DEBUG
|
||||
/* #define HEADER_DEBUG */
|
||||
|
||||
INLINE CELL untag_header(CELL cell)
|
||||
{
|
||||
|
|
@ -80,7 +80,7 @@ INLINE void type_check(CELL type, CELL tagged)
|
|||
if(type < HEADER_TYPE)
|
||||
{
|
||||
#ifdef HEADER_DEBUG
|
||||
if(type == WORD_TYPE && object_type(tagged) != WORD_TYPE)
|
||||
if(TAG(tagged) == WORD_TYPE && object_type(tagged) != WORD_TYPE)
|
||||
critical_error("word header check",tagged);
|
||||
#endif
|
||||
if(TAG(tagged) == type)
|
||||
|
|
|
|||
Loading…
Reference in New Issue