273 lines
8.2 KiB
Factor
273 lines
8.2 KiB
Factor
! Copyright (C) 2004, 2011 Slava Pestov, Daniel Ehrenberg.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: fry accessors alien alien.accessors alien.private arrays
|
|
byte-arrays classes continuations.private effects generic
|
|
hashtables hashtables.private io io.backend io.files
|
|
io.files.private io.streams.c kernel kernel.private math
|
|
math.private math.parser.private memory memory.private
|
|
namespaces namespaces.private parser quotations
|
|
quotations.private sbufs sbufs.private sequences
|
|
sequences.private slots.private strings strings.private system
|
|
threads.private classes.tuple classes.tuple.private vectors
|
|
vectors.private words words.private definitions assocs summary
|
|
compiler.units system.private combinators tools.memory.private
|
|
combinators.short-circuit locals locals.backend locals.types
|
|
combinators.private stack-checker.values generic.single
|
|
generic.single.private alien.libraries tools.dispatch.private
|
|
macros tools.profiler.sampling.private classes.algebra
|
|
stack-checker.alien
|
|
stack-checker.state
|
|
stack-checker.errors
|
|
stack-checker.visitor
|
|
stack-checker.backend
|
|
stack-checker.branches
|
|
stack-checker.transforms
|
|
stack-checker.dependencies
|
|
stack-checker.recursive-state
|
|
stack-checker.row-polymorphism ;
|
|
QUALIFIED-WITH: generic.single.private gsp
|
|
IN: stack-checker.known-words
|
|
|
|
: infer-special ( word -- )
|
|
[ current-word set ] [ "special" word-prop call( -- ) ] bi ;
|
|
|
|
: infer-shuffle ( shuffle -- )
|
|
[ in>> length consume-d ] keep ! inputs shuffle
|
|
[ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
|
|
[ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
|
|
#shuffle, ;
|
|
|
|
: infer-shuffle-word ( word -- )
|
|
"shuffle" word-prop infer-shuffle ;
|
|
|
|
: infer-local-reader ( word -- )
|
|
( -- value ) apply-word/effect ;
|
|
|
|
: infer-local-writer ( word -- )
|
|
( value -- ) apply-word/effect ;
|
|
|
|
: non-inline-word ( word -- )
|
|
dup add-depends-on-effect
|
|
{
|
|
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
|
|
{ [ dup "special" word-prop ] [ infer-special ] }
|
|
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
|
|
{ [ dup macro? ] [ apply-macro ] }
|
|
{ [ dup local? ] [ infer-local-reader ] }
|
|
{ [ dup local-reader? ] [ infer-local-reader ] }
|
|
{ [ dup local-writer? ] [ infer-local-writer ] }
|
|
{ [ dup "no-compile" word-prop ] [ do-not-compile ] }
|
|
[ dup required-stack-effect apply-word/effect ]
|
|
} cond ;
|
|
|
|
{
|
|
{ drop ( x -- ) }
|
|
{ 2drop ( x y -- ) }
|
|
{ 3drop ( x y z -- ) }
|
|
{ 4drop ( w x y z -- ) }
|
|
{ dup ( x -- x x ) }
|
|
{ 2dup ( x y -- x y x y ) }
|
|
{ 3dup ( x y z -- x y z x y z ) }
|
|
{ 4dup ( w x y z -- w x y z w x y z ) }
|
|
{ rot ( x y z -- y z x ) }
|
|
{ -rot ( x y z -- z x y ) }
|
|
{ dupd ( x y -- x x y ) }
|
|
{ swapd ( x y z -- y x z ) }
|
|
{ nip ( x y -- y ) }
|
|
{ 2nip ( x y z -- z ) }
|
|
{ over ( x y -- x y x ) }
|
|
{ pick ( x y z -- x y z x ) }
|
|
{ swap ( x y -- y x ) }
|
|
} [ "shuffle" set-word-prop ] assoc-each
|
|
|
|
: check-declaration ( declaration -- declaration )
|
|
dup { [ array? ] [ [ classoid? ] all? ] } 1&&
|
|
[ bad-declaration-error ] unless ;
|
|
|
|
: infer-declare ( -- )
|
|
pop-literal nip check-declaration
|
|
[ length ensure-d ] keep zip
|
|
#declare, ;
|
|
|
|
\ declare [ infer-declare ] "special" set-word-prop
|
|
|
|
! Call
|
|
GENERIC: infer-call* ( value known -- )
|
|
|
|
: (infer-call) ( value -- ) dup known infer-call* ;
|
|
|
|
: infer-call ( -- ) pop-d (infer-call) ;
|
|
|
|
\ call [ infer-call ] "special" set-word-prop
|
|
|
|
\ (call) [ infer-call ] "special" set-word-prop
|
|
|
|
M: literal-tuple infer-call*
|
|
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
|
|
|
|
M: curried infer-call*
|
|
swap push-d
|
|
[ uncurry ] infer-quot-here
|
|
[ quot>> known pop-d [ set-known ] keep ]
|
|
[ obj>> known pop-d [ set-known ] keep ] bi
|
|
push-d (infer-call) ;
|
|
|
|
M: composed infer-call*
|
|
swap push-d
|
|
[ uncompose ] infer-quot-here
|
|
[ quot2>> known pop-d [ set-known ] keep ]
|
|
[ quot1>> known pop-d [ set-known ] keep ] bi
|
|
push-d push-d
|
|
1 infer->r infer-call
|
|
terminated? get [ 1 infer-r> infer-call ] unless ;
|
|
|
|
M: declared-effect infer-call*
|
|
[ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
|
|
|
|
M: input-parameter infer-call* \ call unknown-macro-input ;
|
|
|
|
M: object infer-call* \ call bad-macro-input ;
|
|
|
|
:: infer-ndip ( word n -- )
|
|
literals get [
|
|
word def>> infer-quot-here
|
|
] [
|
|
pop n [ infer->r infer-quot-here ] [ infer-r> ] bi
|
|
] if-empty ;
|
|
|
|
: infer-dip ( -- ) \ dip 1 infer-ndip ;
|
|
|
|
\ dip [ infer-dip ] "special" set-word-prop
|
|
|
|
: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
|
|
|
|
\ 2dip [ infer-2dip ] "special" set-word-prop
|
|
|
|
: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
|
|
|
|
\ 3dip [ infer-3dip ] "special" set-word-prop
|
|
|
|
:: infer-builder ( quot word -- )
|
|
2 consume-d dup first2 quot call make-known
|
|
[ push-d ] [ 1array ] bi word #call, ; inline
|
|
|
|
: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
|
|
|
|
\ curry [ infer-curry ] "special" set-word-prop
|
|
|
|
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
|
|
|
|
\ compose [ infer-compose ] "special" set-word-prop
|
|
|
|
: infer-execute ( -- )
|
|
pop-literal nip
|
|
dup word? [
|
|
apply-object
|
|
] [
|
|
\ execute time-bomb
|
|
] if ;
|
|
|
|
\ execute [ infer-execute ] "special" set-word-prop
|
|
|
|
\ (execute) [ infer-execute ] "special" set-word-prop
|
|
|
|
: infer-<tuple-boa> ( -- )
|
|
\ <tuple-boa>
|
|
peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
|
|
apply-word/effect ;
|
|
|
|
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
|
|
|
|
: infer-effect-unsafe ( word -- )
|
|
pop-literal nip
|
|
add-effect-input
|
|
apply-word/effect ;
|
|
|
|
: infer-execute-effect-unsafe ( -- )
|
|
\ (execute) infer-effect-unsafe ;
|
|
|
|
\ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
|
|
|
|
: infer-call-effect-unsafe ( -- )
|
|
\ call infer-effect-unsafe ;
|
|
|
|
\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
|
|
|
|
: infer-load-locals ( -- )
|
|
pop-literal nip
|
|
consume-d dup copy-values dup output-r
|
|
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
|
|
|
|
\ load-locals [ infer-load-locals ] "special" set-word-prop
|
|
|
|
: infer-load-local ( -- )
|
|
1 infer->r ;
|
|
|
|
\ load-local [ infer-load-local ] "special" set-word-prop
|
|
|
|
:: infer-get-local ( -- )
|
|
pop-literal nip 1 swap - :> n
|
|
n consume-r :> in-r
|
|
in-r first copy-value 1array :> out-d
|
|
in-r copy-values :> out-r
|
|
|
|
out-d output-d
|
|
out-r output-r
|
|
f out-d in-r out-r
|
|
out-r in-r zip out-d first in-r first 2array suffix
|
|
#shuffle, ;
|
|
|
|
\ get-local [ infer-get-local ] "special" set-word-prop
|
|
|
|
: infer-drop-locals ( -- )
|
|
f f pop-literal nip consume-r f f #shuffle, ;
|
|
|
|
\ drop-locals [ infer-drop-locals ] "special" set-word-prop
|
|
|
|
: infer-call-effect ( word -- )
|
|
1 ensure-d first literal value>>
|
|
add-effect-input add-effect-input
|
|
apply-word/effect ;
|
|
|
|
{ call-effect execute-effect } [
|
|
dup t "no-compile" set-word-prop
|
|
dup '[ _ infer-call-effect ] "special" set-word-prop
|
|
] each
|
|
|
|
\ if [ infer-if ] "special" set-word-prop
|
|
\ dispatch [ infer-dispatch ] "special" set-word-prop
|
|
|
|
\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
|
|
\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
|
|
\ alien-assembly [ infer-alien-assembly ] "special" set-word-prop
|
|
\ alien-callback [ infer-alien-callback ] "special" set-word-prop
|
|
|
|
{
|
|
c-to-factor
|
|
do-primitive
|
|
mega-cache-lookup
|
|
mega-cache-miss
|
|
inline-cache-miss
|
|
inline-cache-miss-tail
|
|
lazy-jit-compile
|
|
set-callstack
|
|
set-datastack
|
|
set-retainstack
|
|
unwind-native-frames
|
|
} [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
|
|
|
|
{
|
|
declare call (call) dip 2dip 3dip curry compose
|
|
execute (execute) call-effect-unsafe execute-effect-unsafe
|
|
if dispatch <tuple-boa> do-primitive
|
|
load-local load-locals get-local drop-locals
|
|
alien-invoke alien-indirect alien-callback alien-assembly
|
|
} [ t "no-compile" set-word-prop ] each
|
|
|
|
! Exceptions to the above
|
|
\ curry f "no-compile" set-word-prop
|
|
\ compose f "no-compile" set-word-prop
|
|
|
|
! More words not to compile
|
|
\ clear t "no-compile" set-word-prop
|