92 lines
2.7 KiB
Factor
92 lines
2.7 KiB
Factor
|
! Copyright (C) 2009 Slava Pestov.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: accessors combinators combinators.private effects fry
|
||
|
|
kernel kernel.private make sequences continuations
|
||
|
|
stack-checker stack-checker.transforms ;
|
||
|
|
IN: stack-checker.call-effect
|
||
|
|
|
||
|
|
! call( and execute( have complex expansions.
|
||
|
|
|
||
|
|
! call( uses the following strategy:
|
||
|
|
! - Inline caching. If the quotation is the same as last time, just call it unsafely
|
||
|
|
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
|
||
|
|
! and compare it with declaration. If matches, call it unsafely.
|
||
|
|
! - Fallback. If the above doesn't work, call it and compare the datastack before
|
||
|
|
! and after to make sure it didn't mess anything up.
|
||
|
|
|
||
|
|
! execute( uses a similar strategy.
|
||
|
|
|
||
|
|
TUPLE: inline-cache value ;
|
||
|
|
|
||
|
|
: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
|
||
|
|
|
||
|
|
SYMBOL: +failed+
|
||
|
|
|
||
|
|
: cached-effect ( quot -- effect )
|
||
|
|
dup cached-effect>>
|
||
|
|
[ ] [
|
||
|
|
[ [ infer ] [ 2drop +failed+ ] recover dup ] keep
|
||
|
|
(>>cached-effect)
|
||
|
|
] ?if ;
|
||
|
|
|
||
|
|
: call-effect-unsafe? ( quot effect -- ? )
|
||
|
|
[ cached-effect ] dip
|
||
|
|
over +failed+ eq?
|
||
|
|
[ 2drop f ] [ effect<= ] if ; inline
|
||
|
|
|
||
|
|
: (call-effect-slow>quot) ( in out effect -- quot )
|
||
|
|
[
|
||
|
|
[ [ datastack ] dip dip ] %
|
||
|
|
[ [ , ] bi@ \ check-datastack , ] dip
|
||
|
|
'[ _ wrong-values ] , \ unless ,
|
||
|
|
] [ ] make ;
|
||
|
|
|
||
|
|
: call-effect-slow>quot ( effect -- quot )
|
||
|
|
[ in>> length ] [ out>> length ] [ ] tri
|
||
|
|
[ (call-effect-slow>quot) ] keep add-effect-input
|
||
|
|
[ call-effect-unsafe ] 2curry ;
|
||
|
|
|
||
|
|
: call-effect-slow ( quot effect -- ) drop call ;
|
||
|
|
|
||
|
|
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
|
||
|
|
|
||
|
|
: call-effect-fast ( quot effect inline-cache -- )
|
||
|
|
2over call-effect-unsafe?
|
||
|
|
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
|
||
|
|
[ drop call-effect-slow ]
|
||
|
|
if ; inline
|
||
|
|
|
||
|
|
\ call-effect [
|
||
|
|
inline-cache new '[
|
||
|
|
_
|
||
|
|
3dup nip cache-hit? [
|
||
|
|
drop call-effect-unsafe
|
||
|
|
] [
|
||
|
|
call-effect-fast
|
||
|
|
] if
|
||
|
|
]
|
||
|
|
] 0 define-transform
|
||
|
|
|
||
|
|
: execute-effect-slow ( word effect -- )
|
||
|
|
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||
|
|
|
||
|
|
: execute-effect-unsafe? ( word effect -- ? )
|
||
|
|
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
|
||
|
|
|
||
|
|
: execute-effect-fast ( word effect inline-cache -- )
|
||
|
|
2over execute-effect-unsafe?
|
||
|
|
[ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
|
||
|
|
[ drop execute-effect-slow ]
|
||
|
|
if ; inline
|
||
|
|
|
||
|
|
: execute-effect-ic ( word effect inline-cache -- )
|
||
|
|
3dup nip cache-hit?
|
||
|
|
[ drop execute-effect-unsafe ]
|
||
|
|
[ execute-effect-fast ]
|
||
|
|
if ; inline
|
||
|
|
|
||
|
|
: execute-effect>quot ( effect -- quot )
|
||
|
|
inline-cache new '[ _ _ execute-effect-ic ] ;
|
||
|
|
|
||
|
|
\ execute-effect [ execute-effect>quot ] 1 define-transform
|