Clean up tail call optimization

db4
Slava Pestov 2008-02-12 17:32:17 -06:00
parent 0900c0e6cd
commit 7c6999872a
2 changed files with 18 additions and 24 deletions

View File

@ -82,25 +82,6 @@ GENERIC: generate-node ( node -- next )
: if-intrinsics ( #call -- quot ) : if-intrinsics ( #call -- quot )
node-param "if-intrinsics" word-prop ; node-param "if-intrinsics" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #values #terminal-values node-successor #terminal? ;
PREDICATE: #call #terminal-call
dup node-successor #if?
over node-successor node-successor #terminal? and
swap if-intrinsics and ;
UNION: #terminal
POSTPONE: f #return #terminal-values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
! node ! node
M: node generate-node drop iterate-next ; M: node generate-node drop iterate-next ;
@ -224,10 +205,11 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- ) : define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ; 2array 1array define-if-intrinsics ;
: do-if-intrinsic ( #call pair -- next ) : do-if-intrinsic ( pair -- next )
<label> [ swap do-template ] keep <label> [
>r node-successor r> generate-if swap do-template
node-successor ; node> node-successor dup >node
] keep generate-if ;
: find-intrinsic ( #call -- pair/f ) : find-intrinsic ( #call -- pair/f )
intrinsics find-template ; intrinsics find-template ;
@ -249,7 +231,7 @@ M: #call generate-node
] [ ] [
node-param generate-call node-param generate-call
] ?if ] ?if
] if* ; ] ?if ;
! #call-label ! #call-label
M: #call-label generate-node node-param generate-call ; M: #call-label generate-node node-param generate-call ;

View File

@ -304,3 +304,15 @@ SYMBOL: node-stack
node-children node-children
[ last-node ] map [ last-node ] map
[ #terminate? not ] subset ; [ #terminate? not ] subset ;
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge ;
: tail-call? ( -- ? )
node-stack get [ node-successor #tail? ] all? ;