Optimizer cleanup

release
slava 2006-05-10 07:40:03 +00:00
parent fd8a3062e3
commit 72fe1b6134
3 changed files with 12 additions and 36 deletions

View File

@ -57,7 +57,7 @@ C: #call-label make-node ;
TUPLE: #push ;
C: #push make-node ;
: #push ( -- node ) peek-d out-node <#push> ;
: #push ( -- node ) peek-d 1array out-node <#push> ;
: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
TUPLE: #shuffle ;
@ -77,11 +77,11 @@ C: #return make-node ;
TUPLE: #if ;
C: #if make-node ;
: #if ( in -- node ) peek-d in-node <#if> ;
: #if ( in -- node ) peek-d 1array in-node <#if> ;
TUPLE: #dispatch ;
C: #dispatch make-node ;
: #dispatch ( in -- node ) peek-d in-node <#dispatch> ;
: #dispatch ( in -- node ) peek-d 1array in-node <#dispatch> ;
TUPLE: #merge ;
C: #merge make-node ;
@ -124,11 +124,6 @@ SYMBOL: current-node
dup node-in-r % node-out-r %
] { } make ;
: uses-value? ( value node -- ? ) node-values memq? ;
: outputs-value? ( value node -- ? )
2dup node-out-d member? >r node-out-r member? r> or ;
: last-node ( node -- last )
dup node-successor [ last-node ] [ ] ?if ;

View File

@ -14,11 +14,6 @@ GENERIC: literals* ( node -- seq )
: literals ( node -- hash )
[ literals* ] node-union ;
! GENERIC: flushable-values* ( node -- seq )
!
! : flushable-values ( node -- hash )
! [ flushable-values* ] node-union ;
GENERIC: live-values* ( node -- seq )
: live-values ( node -- hash )
@ -35,32 +30,17 @@ GENERIC: live-values* ( node -- seq )
over hash-empty?
[ 2drop ] [ [ kill-node* ] each-node-with ] if ;
: kill-unused-literals ( node -- )
\ live-values get over literals hash-diff swap kill-node ;
: kill-values ( node -- )
dup live-values over literals hash-diff swap kill-node ;
! Generic nodes
M: node literals* ( node -- ) drop { } ;
! M: node flushable-values* ( node -- ) drop { } ;
M: node live-values* ( node -- ) node-values ;
! #shuffle
M: #shuffle literals* ( node -- seq )
dup node-out-d swap node-out-r
[ [ value? ] subset ] 2apply append ;
M: node live-values* ( node -- seq )
node-in-d [ value? ] subset ;
! #push
M: #push literals* ( node -- seq )
node-values ;
! #call
! M: #call flushable-values* ( node -- )
! dup node-param "flushable" word-prop
! [ node-out-d ] [ drop { } ] if ;
M: #push literals* ( node -- seq ) node-out-d ;
! #return
M: #return live-values* ( node -- seq )

View File

@ -5,14 +5,11 @@ USING: arrays errors hashtables kernel kernel-internals lists
math namespaces parser sequences sequences-internals strings
vectors words ;
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
IN: kernel-internals
: class-tuple ( object -- class )
dup tuple? [ 2 slot ] [ drop f ] if ; inline
IN: kernel-internals
: tuple= ( tuple tuple -- ? )
2dup [ array-capacity ] 2apply number= [
dup array-capacity
@ -22,10 +19,14 @@ IN: kernel-internals
] if ; inline
: tuple-hashcode ( n tuple -- n )
dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
dup class-tuple hashcode >r >r 1-
r> 4 slot hashcode* r> bitxor ;
IN: generic
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
: tuple-predicate ( word -- )
dup predicate-word
[ \ class-tuple , over literalize , \ eq? , ] [ ] make