new simplifier

cvs
Slava Pestov 2005-01-17 20:33:12 +00:00
parent b5801f45dd
commit 3617093ba5
14 changed files with 255 additions and 121 deletions

View File

@ -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

View File

@ -72,9 +72,11 @@ USE: hashtables
"traits" [ "generic" ] search
"delegate" [ "generic" ] search
"object" [ "generic" ] search
vocabularies get [ "generic" off ] bind
reveal
reveal
reveal

View File

@ -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 ;

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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 [

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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.

View File

@ -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);

View File

@ -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);

View File

@ -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);