factor/library/inference/words.factor

178 lines
5.2 KiB
Factor
Raw Normal View History

! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
2004-11-26 22:23:57 -05:00
IN: inference
2005-05-09 02:34:15 -04:00
USING: errors generic interpreter kernel lists math
math-internals namespaces sequences strings vectors words
hashtables parser prettyprint ;
: with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output
#! parameters, add node. The quotation is called with the
#! stack effect.
2004-12-24 17:29:16 -05:00
>r dup car ensure-d
>r dataflow, r> r> rot
[ pick car swap [ length 0 node-inputs ] bind ] keep
pick >r >r nip call r> r> cdr car swap
[ length 0 node-outputs ] bind ; inline
2004-12-23 01:14:07 -05:00
: consume-d ( typelist -- )
[ pop-d 2drop ] each ;
2004-12-23 01:14:07 -05:00
: produce-d ( typelist -- )
[ <computed> push-d ] each ;
2004-12-30 02:40:14 -05:00
: (consume/produce) ( param op effect )
dup >r -rot r>
2004-12-24 17:29:16 -05:00
[ unswons consume-d car produce-d ] with-dataflow ;
2004-12-03 22:12:58 -05:00
: consume/produce ( word [ in-types out-types ] -- )
#! Add a node to the dataflow graph that consumes and
#! produces a number of values.
2004-12-03 22:12:58 -05:00
#call swap (consume/produce) ;
2004-11-26 22:23:57 -05:00
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 inference-error ;
2004-11-26 22:23:57 -05:00
: inline-compound ( word -- effect node )
#! Infer the stack effect of a compound word in the current
#! inferencer instance. If the word in question is recursive
#! we infer its stack effect inside a new block.
gensym over word-def cons [
word-def infer-quot effect
] with-block ;
: infer-compound ( word -- )
#! Infer a word's stack effect in a separate inferencer
#! instance.
2004-11-26 22:23:57 -05:00
[
[
recursive-state get init-inference
dup dup inline-compound drop present-effect
[ "infer-effect" set-word-prop ] keep
] with-scope consume/produce
] [
[
>r inferring-base-case get [
drop
] [
t "no-effect" set-word-prop
] ifte r> rethrow
] when*
] catch ;
2004-11-26 22:23:57 -05:00
2004-12-24 02:52:02 -05:00
GENERIC: (apply-word)
M: object (apply-word) ( word -- )
#! A primitive with an unknown stack effect.
no-effect ;
2004-12-24 02:52:02 -05:00
M: compound (apply-word) ( word -- )
2004-11-26 22:23:57 -05:00
#! Infer a compound word's stack effect.
dup "no-effect" word-prop [
no-effect
2004-11-26 22:23:57 -05:00
] [
infer-compound
2004-11-26 22:23:57 -05:00
] ifte ;
2004-12-24 02:52:02 -05:00
M: symbol (apply-word) ( word -- )
apply-literal ;
GENERIC: apply-word
: apply-default ( word -- )
dup "infer-effect" word-prop [
over "infer" word-prop [
swap car ensure-d call drop
] [
consume/produce
] ifte*
] [
(apply-word)
] ifte* ;
M: word apply-word ( word -- )
apply-default ;
M: compound apply-word ( word -- )
dup "inline" word-prop [
inline-compound 2drop
] [
apply-default
] ifte ;
2005-01-13 17:28:29 -05:00
: with-recursion ( quot -- )
[
inferring-base-case on
2005-01-13 17:28:29 -05:00
call
] [
inferring-base-case off
2005-01-13 17:28:29 -05:00
rethrow
] catch ;
: base-case ( word [ label quot ] -- )
2004-12-30 02:40:14 -05:00
[
car over inline-compound [
drop
[ #call-label ] [ #call ] ?ifte
node-op set
node-param set
] bind
2005-01-13 17:28:29 -05:00
] with-recursion ;
: no-base-case ( word -- )
word-name " does not have a base case." cat2 inference-error ;
: recursive-word ( word [ label quot ] -- )
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.
inferring-base-case get [
drop no-base-case
2004-11-26 22:23:57 -05:00
] [
base-case
2004-12-30 02:40:14 -05:00
] ifte ;
2004-11-26 22:23:57 -05:00
M: word 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 assoc [
2005-01-31 14:02:09 -05:00
recursive-word
2004-11-26 22:23:57 -05:00
] [
apply-word
] ifte* ;
2004-11-26 22:23:57 -05:00
: infer-quot-value ( rstate quot -- )
gensym dup pick cons [
drop
swap recursive-state set
dup infer-quot
] with-block drop handle-terminator ;
\ call [
[ general-list ] ensure-d pop-literal infer-quot-value
] "infer" set-word-prop
2004-11-26 22:23:57 -05:00
\ execute [
[ word ] ensure-d pop-literal unit infer-quot-value
] "infer" set-word-prop
2004-11-26 22:23:57 -05:00
! These hacks will go away soon
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
2005-05-09 02:34:15 -04:00
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
2005-05-09 02:34:15 -04:00
\ <= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ < [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
2005-05-09 02:34:15 -04:00
\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
\ not-a-number t "terminator" set-word-prop
\ throw t "terminator" set-word-prop