new simplifier
parent
b5801f45dd
commit
3617093ba5
|
@ -1,6 +1,5 @@
|
|||
+ compiler:
|
||||
|
||||
- recursive? and tree-contains? should handle vectors
|
||||
- type inference fails with some assembler words;
|
||||
displaced, register and other predicates need to inherit from list
|
||||
not cons, and need stronger branch partial eval
|
||||
|
|
|
@ -72,9 +72,11 @@ USE: hashtables
|
|||
|
||||
"traits" [ "generic" ] search
|
||||
"delegate" [ "generic" ] search
|
||||
"object" [ "generic" ] search
|
||||
|
||||
vocabularies get [ "generic" off ] bind
|
||||
|
||||
reveal
|
||||
reveal
|
||||
reveal
|
||||
|
||||
|
|
|
@ -49,10 +49,6 @@ SYMBOL: relocation-table
|
|||
#! If flag is true; relative.
|
||||
0 1 ? rel, relocating word-primitive rel, ;
|
||||
|
||||
: rel-word ( word rel/abs -- )
|
||||
#! If flag is true; relative.
|
||||
over primitive? [ rel-primitive ] [ 2drop ] ifte ;
|
||||
|
||||
: rel-dlsym ( name dll rel/abs -- )
|
||||
#! If flag is true; relative.
|
||||
2 3 ? rel, relocating cons intern-literal rel, ;
|
||||
|
@ -61,6 +57,14 @@ SYMBOL: relocation-table
|
|||
#! Relocate address just compiled.
|
||||
4 rel, relocating 0 rel, ;
|
||||
|
||||
: rel-word ( word rel/abs -- )
|
||||
#! If flag is true; relative.
|
||||
over primitive? [
|
||||
rel-primitive
|
||||
] [
|
||||
nip [ rel-address ] unless
|
||||
] ifte ;
|
||||
|
||||
: generate-node ( [[ op params ]] -- )
|
||||
#! Generate machine code for a node.
|
||||
unswons dup "generator" word-property [
|
||||
|
@ -107,6 +111,8 @@ SYMBOL: previous-offset
|
|||
|
||||
#label [ save-xt ] "generator" set-word-property
|
||||
|
||||
#end-dispatch [ drop ] "generator" set-word-property
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
#! Given a type number, return the tag number.
|
||||
dup 6 > [ drop 3 ] when ;
|
||||
|
|
|
@ -53,10 +53,13 @@ SYMBOL: #jump ( tail-call )
|
|||
SYMBOL: #jump-label ( tail-call )
|
||||
SYMBOL: #return-to ( push addr on C stack )
|
||||
|
||||
! dispatch is linearized as dispatch followed by a #target
|
||||
! for each dispatch table entry. The linearizer ensures the
|
||||
! correct number of #targets is emitted.
|
||||
! dispatch is linearized as dispatch followed by a #target or
|
||||
! #target-label for each dispatch table entry. The dispatch
|
||||
! table terminates with #end-dispatch. The linearizer ensures
|
||||
! the correct number of #targets is emitted.
|
||||
SYMBOL: #target ( part of jump table )
|
||||
SYMBOL: #target-label
|
||||
SYMBOL: #end-dispatch
|
||||
|
||||
: linear, ( node -- )
|
||||
#! Add a node to the linear IR.
|
||||
|
@ -146,7 +149,8 @@ SYMBOL: #target ( part of jump table )
|
|||
#! label/branch pairs.
|
||||
[ dispatch ] ,
|
||||
<label> ( end label ) swap
|
||||
[ <label> dup #target swons , cons ] map ;
|
||||
[ <label> dup #target-label swons , cons ] map
|
||||
[ #end-dispatch ] , ;
|
||||
|
||||
: dispatch-body ( end label/param -- )
|
||||
#! Output each branch, with a jump to the end label.
|
||||
|
|
|
@ -33,6 +33,7 @@ USE: inference
|
|||
USE: words
|
||||
USE: prettyprint
|
||||
USE: kernel-internals
|
||||
USE: vectors
|
||||
|
||||
! The optimizer transforms dataflow IR to dataflow IR. Currently
|
||||
! it removes literals that are eventually dropped, and never
|
||||
|
@ -89,12 +90,24 @@ USE: kernel-internals
|
|||
#! Push a list of literals that may be killed in the IR.
|
||||
dup scan-literals [ over can-kill? ] subset nip ;
|
||||
|
||||
SYMBOL: branch-returns
|
||||
|
||||
: can-kill-branches? ( literal node -- ? )
|
||||
#! Check if the literal appears in either branch.
|
||||
#! Check if the literal appears in either branch. This
|
||||
#! assumes that the last element of each branch is a #values
|
||||
#! node.
|
||||
2dup consumes-literal? [
|
||||
2drop f
|
||||
] [
|
||||
[ node-param get ] bind [ dupd can-kill? ] all? nip
|
||||
[ node-param get ] bind
|
||||
[
|
||||
dup [
|
||||
last [ node-consume-d get list>vector ] bind
|
||||
] map
|
||||
unify-stacks vector>list
|
||||
branch-returns set
|
||||
[ dupd can-kill? ] all? nip
|
||||
] with-scope
|
||||
] ifte ;
|
||||
|
||||
: kill-node ( literals node -- )
|
||||
|
@ -170,6 +183,14 @@ USE: kernel-internals
|
|||
] extend ,
|
||||
] "kill-node" set-word-property
|
||||
|
||||
#values [
|
||||
dupd consumes-literal? [
|
||||
branch-returns get mentions-literal?
|
||||
] [
|
||||
drop t
|
||||
] ifte
|
||||
] "can-kill" set-word-property
|
||||
|
||||
\ ifte [ scan-branches ] "scan-literal" set-word-property
|
||||
\ ifte [ can-kill-branches? ] "can-kill" set-word-property
|
||||
\ ifte [ kill-branches ] "kill-node" set-word-property
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
! $Id$
|
||||
!
|
||||
! Copyright (C) 2004 Slava Pestov.
|
||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
|
@ -26,101 +26,176 @@
|
|||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: compiler
|
||||
USE: inference
|
||||
USE: errors
|
||||
USE: generic
|
||||
USE: hashtables
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: namespaces
|
||||
USE: parser
|
||||
USE: prettyprint
|
||||
USE: stdio
|
||||
USE: strings
|
||||
USE: unparser
|
||||
USE: vectors
|
||||
USE: words
|
||||
USE: inference
|
||||
USE: strings
|
||||
USE: strings
|
||||
USE: prettyprint
|
||||
|
||||
: labels ( linear -- list )
|
||||
#! Make a list of all labels defined in the linear IR.
|
||||
[ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ;
|
||||
! The linear IR being simplified is stored in this variable.
|
||||
SYMBOL: simplifying
|
||||
|
||||
: simplifiers ( linear -- list )
|
||||
#! A list of quotations with stack effect
|
||||
#! ( linear -- linear ? ) that can simplify the first node
|
||||
#! in the linear IR.
|
||||
car car "simplifiers" word-property ;
|
||||
|
||||
: simplify-node ( linear list -- linear ? )
|
||||
dup [
|
||||
uncons >r call [
|
||||
r> drop t
|
||||
] [
|
||||
r> simplify-node
|
||||
] ifte
|
||||
] when ;
|
||||
|
||||
: simplify-1 ( linear -- linear ? )
|
||||
#! Return a new linear IR.
|
||||
dup [
|
||||
dup simplifiers simplify-node
|
||||
[ uncons simplify-1 >r cons r> ] unless*
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
: simplify ( linear -- linear )
|
||||
#! Keep simplifying until simplify-1 returns f.
|
||||
[
|
||||
dup simplifying set simplify-1 [ simplify ] when
|
||||
] with-scope ;
|
||||
|
||||
: label-called? ( label linear -- ? )
|
||||
[ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
|
||||
|
||||
: purge-label ( label linear -- )
|
||||
>r dup cdr r> label-called? [ , ] [ drop ] ifte ;
|
||||
: next-physical? ( op linear -- ? )
|
||||
cdr dup [ car car = ] [ 2drop f ] ifte ;
|
||||
|
||||
: purge-labels ( linear -- linear )
|
||||
#! Remove all unused labels.
|
||||
[
|
||||
dup [
|
||||
dup car #label = [ over purge-label ] [ , ] ifte
|
||||
] 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 "simplify" [ swap , f ] singleton ;
|
||||
|
||||
: find-label ( label linear -- rest )
|
||||
[ cdr over = ] some? cdr nip ;
|
||||
|
||||
: (simplify) ( list -- ? )
|
||||
dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ;
|
||||
|
||||
: simplify ( linear -- linear )
|
||||
( purge-labels ) [ (simplify) ] make-list ;
|
||||
|
||||
: follow ( linear -- linear )
|
||||
dup car car "follow" [ ] singleton ;
|
||||
: cancel ( linear op -- linear param ? )
|
||||
#! If the following op is as given, remove it, and return
|
||||
#! its param.
|
||||
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
|
||||
|
||||
#label [
|
||||
cdr follow
|
||||
] "follow" set-word-property
|
||||
[
|
||||
dup car cdr simplifying get
|
||||
label-called? [ f ] [ cdr t ] ifte
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
||||
\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-property
|
||||
\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-property
|
||||
\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-property
|
||||
\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-property
|
||||
|
||||
: next-logical ( linear -- linear )
|
||||
dup car car "next-logical" word-property call ;
|
||||
|
||||
#label [
|
||||
cdr next-logical
|
||||
] "next-logical" set-word-property
|
||||
|
||||
: find-label ( label -- rest )
|
||||
simplifying get [
|
||||
uncons pick = swap #label = and
|
||||
] some? nip ;
|
||||
|
||||
#jump-label [
|
||||
uncons >r cdr r> find-label follow
|
||||
] "follow" set-word-property
|
||||
car cdr find-label cdr
|
||||
] "next-logical" set-word-property
|
||||
|
||||
: follows? ( op linear -- ? )
|
||||
follow dup [ car car = ] [ 2drop f ] ifte ;
|
||||
#target-label [
|
||||
car cdr find-label cdr
|
||||
] "next-logical" set-word-property
|
||||
|
||||
GENERIC: simplify-call ( node rest -- rest ? )
|
||||
M: cons simplify-call ( node rest -- rest ? )
|
||||
swap , f ;
|
||||
: next-logical? ( op linear -- ? )
|
||||
next-logical dup [ car car = ] [ 2drop f ] ifte ;
|
||||
|
||||
PREDICATE: cons return-follows #return swap follows? ;
|
||||
M: return-follows simplify-call ( node rest -- rest ? )
|
||||
>r
|
||||
unswons [
|
||||
[[ #call #jump ]]
|
||||
[[ #call-label #jump-label ]]
|
||||
] assoc swons , r> t ;
|
||||
: reduce ( linear op new -- linear ? )
|
||||
>r over cdr next-logical? [
|
||||
unswons cdr r> swons swons t
|
||||
] [
|
||||
r> drop f
|
||||
] ifte ;
|
||||
|
||||
#call [ simplify-call ] "simplify" set-word-property
|
||||
#call-label [ simplify-call ] "simplify" set-word-property
|
||||
#call [
|
||||
[
|
||||
#return #jump reduce
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
||||
GENERIC: simplify-drop ( node rest -- rest ? )
|
||||
M: cons simplify-drop ( node rest -- rest ? )
|
||||
swap , f ;
|
||||
#call-label [
|
||||
[
|
||||
#return #jump-label reduce
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
||||
PREDICATE: cons push-next ( list -- ? )
|
||||
: double-jump ( linear op1 op2 -- 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 just of type op2.
|
||||
swap pick next-logical? [
|
||||
over next-logical car cdr cons swap cdr cons t
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
||||
: 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 [
|
||||
car car [ #push-immediate #push-indirect ] contains?
|
||||
] when ;
|
||||
dup car car #label = [
|
||||
f
|
||||
] [
|
||||
cdr (dead-code) t or
|
||||
] ifte
|
||||
] [
|
||||
f
|
||||
] ifte ;
|
||||
|
||||
M: push-next simplify-drop ( node rest -- rest ? )
|
||||
nip uncons >r unswons [
|
||||
[[ #push-immediate #replace-immediate ]]
|
||||
[[ #push-indirect #replace-indirect ]]
|
||||
] assoc swons , r> t ;
|
||||
: dead-code ( linear -- linear ? )
|
||||
uncons (dead-code) >r cons r> ;
|
||||
|
||||
\ drop [ simplify-drop ] "simplify" set-word-property
|
||||
#jump-label [
|
||||
[
|
||||
#return #return double-jump
|
||||
] [
|
||||
#jump-label #jump-label double-jump
|
||||
] [
|
||||
#jump #jump double-jump
|
||||
] [
|
||||
useless-jump
|
||||
] [
|
||||
dead-code
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
||||
#target-label [
|
||||
[
|
||||
#jump-label #target-label double-jump
|
||||
] [
|
||||
#jump #target double-jump
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
||||
#jump [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
#return [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
|
||||
\ drop [
|
||||
[
|
||||
#push-immediate cancel [
|
||||
#replace-immediate swons swons t
|
||||
] when
|
||||
] [
|
||||
#push-indirect cancel [
|
||||
#replace-indirect swons swons t
|
||||
] when
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
|
|
|
@ -52,6 +52,9 @@ USE: words
|
|||
: compile-call ( word -- )
|
||||
dup dup postpone-word compile-call-label t rel-word ;
|
||||
|
||||
: compile-target ( word -- )
|
||||
compiled-offset 0 compile-cell 0 defer-xt ;
|
||||
|
||||
#call [
|
||||
compile-call
|
||||
] "generator" set-word-property
|
||||
|
@ -97,9 +100,14 @@ USE: words
|
|||
compiled-offset swap set-compiled-cell ( fixup -- )
|
||||
] "generator" set-word-property
|
||||
|
||||
#target-label [
|
||||
#! Jump table entries are absolute addresses.
|
||||
compile-target rel-address
|
||||
] "generator" set-word-property
|
||||
|
||||
#target [
|
||||
#! Jump table entries are absolute addresses.
|
||||
compiled-offset 0 compile-cell 0 defer-xt rel-address
|
||||
dup dup postpone-word compile-target f rel-word
|
||||
] "generator" set-word-property
|
||||
|
||||
#c-call [
|
||||
|
|
|
@ -18,3 +18,5 @@ USE: lists
|
|||
[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
|
||||
|
||||
[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f <literal> ] map kill-mask ] unit-test
|
||||
|
||||
[ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test
|
||||
|
|
|
@ -4,32 +4,54 @@ 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 ] ] find-label ]
|
||||
unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[ [ [[ #label 123 ]] [ #return ] ] follow ]
|
||||
[
|
||||
[
|
||||
123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ]
|
||||
simplifying set find-label cdr
|
||||
] with-scope
|
||||
]
|
||||
unit-test
|
||||
|
||||
[ [ [ #return ] ] ]
|
||||
[
|
||||
[
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #call car ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] follow
|
||||
[
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #call car ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] dup simplifying set next-logical
|
||||
] with-scope
|
||||
]
|
||||
unit-test
|
||||
|
||||
[
|
||||
[[ #jump car ]]
|
||||
[ [[ #return f ]] ]
|
||||
]
|
||||
[
|
||||
[
|
||||
[[ #jump-label 123 ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] simplify
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[ [[ #jump car ]] ]
|
||||
]
|
||||
[
|
||||
[
|
||||
|
@ -37,22 +59,17 @@ unit-test
|
|||
[[ #jump-label 123 ]]
|
||||
[[ #label 123 ]]
|
||||
[ #return ]
|
||||
] simplify car
|
||||
] simplify
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
[ [[ swap f ]] ]
|
||||
] [
|
||||
[
|
||||
[[ #push-immediate 1 ]]
|
||||
] push-next? >boolean
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
[[ #replace-immediate 1 ]]
|
||||
[ #return ]
|
||||
]
|
||||
] [
|
||||
[ drop 1 ] dataflow linearize simplify
|
||||
[[ #jump-label 1 ]]
|
||||
[[ #label 1 ]]
|
||||
[[ #jump-label 2 ]]
|
||||
[[ #label 2 ]]
|
||||
[[ swap f ]]
|
||||
] simplify
|
||||
] unit-test
|
||||
|
|
|
@ -36,13 +36,18 @@ USE: stdio
|
|||
USE: strings
|
||||
USE: unparser
|
||||
USE: math
|
||||
USE: hashtables
|
||||
|
||||
: word-uses? ( of in -- ? )
|
||||
GENERIC: word-uses? ( of in -- ? )
|
||||
M: word word-uses? 2drop f ;
|
||||
M: compound word-uses? ( of in -- ? )
|
||||
2dup = [
|
||||
2drop f ! Don't say that a word uses itself
|
||||
] [
|
||||
word-parameter tree-contains?
|
||||
] ifte ;
|
||||
M: generic word-uses? ( of in -- ? )
|
||||
"methods" word-property hash>alist tree-contains? ;
|
||||
|
||||
: usages-in-vocab ( of vocab -- usages )
|
||||
#! Push a list of all usages of a word in a vocabulary.
|
||||
|
|
|
@ -167,11 +167,6 @@ M: vector hashcode ( vec -- n )
|
|||
over vector-nth hashcode rot bitxor swap
|
||||
] times* drop ;
|
||||
|
||||
: vector-head ( n vector -- list )
|
||||
#! Return a new list with all elements up to the nth
|
||||
#! element.
|
||||
swap [ over vector-nth ] vector-project nip ;
|
||||
|
||||
: vector-tail ( n vector -- list )
|
||||
#! Return a new list with all elements from the nth
|
||||
#! index upwards.
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
F_FIXNUM to_integer(CELL x)
|
||||
{
|
||||
switch(type_of(x))
|
||||
switch(TAG(x))
|
||||
{
|
||||
case FIXNUM_TYPE:
|
||||
return untag_fixnum_fast(x);
|
||||
|
|
|
@ -7,7 +7,7 @@ F_FIXNUM to_fixnum(CELL tagged)
|
|||
F_ARRAY* y;
|
||||
F_FLOAT* f;
|
||||
|
||||
switch(type_of(tagged))
|
||||
switch(TAG(tagged))
|
||||
{
|
||||
case FIXNUM_TYPE:
|
||||
return untag_fixnum_fast(tagged);
|
||||
|
|
|
@ -6,7 +6,7 @@ double to_float(CELL tagged)
|
|||
double x;
|
||||
double y;
|
||||
|
||||
switch(type_of(tagged))
|
||||
switch(TAG(tagged))
|
||||
{
|
||||
case FIXNUM_TYPE:
|
||||
return (double)untag_fixnum_fast(tagged);
|
||||
|
|
Loading…
Reference in New Issue