Optimizer cleanup
parent
fd8a3062e3
commit
72fe1b6134
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue