factor/library/compiler/inference/words.factor

185 lines
5.6 KiB
Factor
Raw Normal View History

2006-05-15 01:49:07 -04:00
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays errors generic hashtables interpreter kernel
2005-12-16 22:24:39 -05:00
math math-internals namespaces parser prettyprint sequences
strings vectors words ;
IN: inference
2005-09-14 00:37:50 -04:00
: consume-values ( n node -- )
over ensure-values
2006-07-19 23:10:02 -04:00
over 0 rot node-inputs
meta-d get [ length swap - ] keep set-length ;
2005-09-14 00:37:50 -04:00
: produce-values ( n node -- )
2006-07-19 23:10:02 -04:00
>r [ drop <computed> ] map dup r> set-node-out-d
meta-d get swap nappend ;
2005-09-09 00:17:19 -04:00
2005-05-17 16:13:08 -04:00
: consume/produce ( word effect -- )
#! Add a node to the dataflow graph that consumes and
#! produces a number of values.
2005-09-14 00:37:50 -04:00
swap #call
over first length over consume-values
swap second length over produce-values
node, ;
2004-11-26 22:23:57 -05:00
: no-effect ( word -- )
"Stack effect inference of the word " swap word-name
" was already attempted, and failed" append3
2005-05-17 16:13:08 -04:00
inference-error ;
2004-11-26 22:23:57 -05:00
2006-01-19 23:28:45 -05:00
TUPLE: rstate label base-case? ;
2005-12-16 22:24:39 -05:00
: nest-node ( -- dataflow current )
dataflow-graph get dataflow-graph off
current-node get current-node off ;
: unnest-node ( new-node dataflow current -- new-node )
>r >r dataflow-graph get 1array over set-node-children
r> dataflow-graph set
r> current-node set ;
: with-recursive-state ( word label base-case quot -- )
2006-05-15 01:49:07 -04:00
>r <rstate> 2array recursive-state [ swap add ] change r>
2005-12-16 22:24:39 -05:00
nest-node 2slip unnest-node ; inline
: inline-block ( word base-case -- node-block variables )
[
copy-inference
>r gensym 2dup r> [
2005-12-16 22:24:39 -05:00
dup #label >r
#entry node,
swap word-def infer-quot
#return node, r>
] with-recursive-state
] make-hash ;
: apply-infer ( hash -- )
{ meta-d meta-r d-in }
[ [ swap hash ] keep set ] each-with ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* ( label node -- ) 2drop ;
M: #call-label collect-recursion* ( label node -- )
tuck node-param = [ node-in-d , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
#! Collect the input stacks of all #call-label nodes that
#! call given label.
dup node-param swap
[ [ collect-recursion* ] each-node-with ] { } make ;
: join-values ( node -- )
#! We have to infer recursive labels twice to determine
#! which literals survive the recursion (eg, quotations)
#! and which don't (loop indices, etc). The latter cannot
#! be folded.
2006-05-22 21:55:46 -04:00
collect-recursion meta-d get add unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
#! Labels which do not call themselves are just spliced into
#! the IR, and no #label node is added.
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
: inline-closure ( word -- )
#! This is not a closure in the lexical scope sense, but a
#! closure under recursive value substitution.
#! If the block does not call itself, there is no point in
#! having the block node in the IR. Just add its contents.
dup f inline-block over recursive-label? [
meta-d get >r
drop join-values f inline-block apply-infer
2006-03-04 02:53:22 -05:00
r> over set-node-in-d node,
] [
apply-infer node-child node-successor splice-node drop
] if ;
2005-09-17 22:25:18 -04:00
: infer-compound ( word base-case -- terminates? effect )
#! Infer a word's stack effect in a separate inferencer
#! instance. Outputs a true boolean if the word terminates
2005-09-17 22:25:18 -04:00
#! control flow by throwing an exception or restoring a
#! continuation.
2004-11-26 22:23:57 -05:00
[
2006-01-19 23:28:45 -05:00
recursive-state get init-inference
over >r inline-block nip
[ terminated? get effect ] bind r>
2005-09-17 22:25:18 -04:00
] with-scope over consume/produce over [ terminate ] when ;
2005-07-31 23:38:33 -04:00
GENERIC: apply-word
2004-12-24 02:52:02 -05:00
2005-07-31 23:38:33 -04:00
M: object apply-word ( word -- )
#! A primitive with an unknown stack effect.
no-effect ;
2006-07-27 19:45:13 -04:00
: save-effect ( word terminates effect prop -- )
rot [ 3drop ] [ set-word-prop ] if ;
2006-01-19 23:28:45 -05:00
2005-07-31 23:38:33 -04:00
M: compound apply-word ( word -- )
#! Infer a compound word's stack effect.
[
2006-07-27 19:45:13 -04:00
dup f infer-compound "infer-effect" save-effect
2005-09-21 01:12:16 -04:00
] [
swap t "no-effect" set-word-prop rethrow
2005-09-21 01:12:16 -04:00
] recover ;
2005-05-15 21:17:56 -04:00
2005-07-31 23:38:33 -04:00
: apply-default ( word -- )
2006-07-25 00:14:18 -04:00
dup "no-effect" word-prop [ no-effect ] when
dup "infer-effect" word-prop [
over "infer" word-prop [
swap first length ensure-values call drop
] [
2006-07-26 15:03:49 -04:00
consume/produce
2005-09-24 15:21:17 -04:00
] if*
2006-07-25 00:14:18 -04:00
] [
apply-word
] if* ;
2005-07-31 23:38:33 -04:00
M: word apply-object ( word -- )
apply-default ;
2005-07-31 23:38:33 -04:00
M: symbol apply-object ( word -- )
apply-literal ;
: inline-base-case ( word label -- )
meta-d get clone >r over t inline-block apply-infer drop
[ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
: base-case ( word label -- )
over "inline" word-prop [
inline-base-case
] [
2006-07-27 19:45:13 -04:00
drop dup t infer-compound "base-case" save-effect
2005-09-24 15:21:17 -04:00
] if ;
: recursive-word ( word rstate -- )
2004-11-26 22:23:57 -05:00
#! Handle a recursive call, by either applying a previously
2004-12-03 22:12:58 -05:00
#! inferred base case, or raising an error. If the recursive
#! call is to a local block, emit a label call node.
2005-05-15 21:17:56 -04:00
over "infer-effect" word-prop [
nip consume/produce
2004-11-26 22:23:57 -05:00
] [
over "base-case" word-prop [
nip consume/produce
2005-05-15 21:17:56 -04:00
] [
dup rstate-base-case? [
2005-09-14 00:37:50 -04:00
notify-base-case
] [
rstate-label base-case
2005-09-24 15:21:17 -04:00
] if
] if*
] if* ;
2004-11-26 22:23:57 -05:00
2005-07-31 23:38:33 -04:00
M: compound apply-object ( word -- )
2004-11-26 22:23:57 -05:00
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get <reversed> assoc [
2005-01-31 14:02:09 -05:00
recursive-word
2004-11-26 22:23:57 -05:00
] [
2005-08-29 21:00:39 -04:00
dup "inline" word-prop
[ inline-closure ] [ apply-default ] if
2005-09-24 15:21:17 -04:00
] if* ;