steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

handle the stack effect type as a separate specialization pass, and use coercers when available

db4
Joe Groff 2009-09-01 23:13:08 -05:00
parent 65fa9cf301
commit cb56e95567
1 changed files with 29 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
basis/hints/hints.factor
View File

@ -19,13 +19,8 @@ M: class specializer-declaration ;
M: object specializer-declaration class ;
: specialized? ( types -- ? )
[ object = ] all? not ;
: specializer ( word -- specializer )
[ "specializer" word-prop ]
[ stack-effect effect-in-types ] bi
dup specialized? [ suffix ] [ drop ] if ;
"specializer" word-prop ;
: make-specializer ( specs -- quot )
dup length <reversed>
@ -36,13 +31,6 @@ M: object specializer-declaration class ;
[ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
ERROR: type-mismatch-error word expected-types ;
: fallback-def ( word -- quot )
dup stack-effect effect-in-types dup specialized?
[ [ type-mismatch-error ] 2curry ]
[ drop def>> ] if ;
: specializer-cases ( quot specializer -- alist )
dup [ array? ] all? [ 1array ] unless [
[ nip make-specializer ]
@ -50,7 +38,7 @@ ERROR: type-mismatch-error word expected-types ;
] with { } map>assoc ;
: specialize-quot ( quot word specializer -- quot' )
[ drop nip fallback-def ] [ nip specializer-cases ] 3bi alist>quot ;
[ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
@ -72,7 +60,7 @@ t specialize-method? set-global
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
: (specialized-def) ( word -- quot )
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
@ -80,6 +68,32 @@ t specialize-method? set-global
bi
] if ;
ERROR: type-mismatch-error word expected-types ;
: typed-stack-effect? ( effect -- ? )
[ object = ] all? not ;
: type-mismatch-quot ( word types -- quot )
[ type-mismatch-error ] 2curry ;
: make-coercer ( types -- quot )
[ "coercer" word-prop [ ] or ]
[ swap \ dip [ ] 2sequence prepend ]
map-reduce ;
: typed-inputs ( quot word -- quot' )
dup stack-effect effect-in-types {
[ 2nip make-coercer ]
[ 2nip make-specializer ]
[ nip swap '[ _ declare @ ] ]
[ [ drop ] 2dip type-mismatch-quot ]
} 3cleave '[ @ @ _ _ if ] ;
: specialized-def ( word -- quot )
[ (specialized-def) ] keep
dup stack-effect effect-in-types typed-stack-effect?
[ typed-inputs ] [ drop ] if ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;