2005-01-10 23:08:27 -05:00
|
|
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
2005-01-30 15:57:25 -05:00
|
|
|
! 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 ;
|
2004-11-28 19:07:24 -05:00
|
|
|
|
2005-01-16 17:58:28 -05:00
|
|
|
: with-dataflow ( param op [[ in# out# ]] quot -- )
|
2004-11-28 19:07:24 -05:00
|
|
|
#! 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
|
2004-12-23 16:37:16 -05:00
|
|
|
>r dataflow, r> r> rot
|
2005-01-16 17:58:28 -05:00
|
|
|
[ 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-11-28 19:07:24 -05:00
|
|
|
|
2004-12-23 01:14:07 -05:00
|
|
|
: consume-d ( typelist -- )
|
|
|
|
[ pop-d 2drop ] each ;
|
2004-12-22 22:16:46 -05:00
|
|
|
|
2004-12-23 01:14:07 -05:00
|
|
|
: produce-d ( typelist -- )
|
|
|
|
[ <computed> push-d ] each ;
|
2004-12-22 22:16:46 -05:00
|
|
|
|
2004-12-30 02:40:14 -05:00
|
|
|
: (consume/produce) ( param op effect )
|
2005-01-16 17:58:28 -05:00
|
|
|
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
|
|
|
|
2004-12-23 16:37:16 -05:00
|
|
|
: consume/produce ( word [ in-types out-types ] -- )
|
2004-11-28 19:07:24 -05:00
|
|
|
#! 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 -- )
|
2005-02-22 23:07:47 -05:00
|
|
|
"Unknown stack effect: " swap word-name cat2 inference-error ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-01-16 17:58:28 -05:00
|
|
|
: inline-compound ( word -- effect node )
|
2004-11-28 19:07:24 -05:00
|
|
|
#! Infer the stack effect of a compound word in the current
|
2005-01-10 23:08:27 -05:00
|
|
|
#! inferencer instance. If the word in question is recursive
|
|
|
|
#! we infer its stack effect inside a new block.
|
2005-03-05 14:45:23 -05:00
|
|
|
gensym over word-def cons [
|
|
|
|
word-def infer-quot effect
|
2005-02-22 23:07:47 -05:00
|
|
|
] with-block ;
|
2004-11-28 19:07:24 -05:00
|
|
|
|
2005-02-08 22:02:44 -05:00
|
|
|
: infer-compound ( word -- )
|
2004-11-28 19:07:24 -05:00
|
|
|
#! Infer a word's stack effect in a separate inferencer
|
|
|
|
#! instance.
|
2004-11-26 22:23:57 -05:00
|
|
|
[
|
2005-02-08 22:02:44 -05:00
|
|
|
[
|
|
|
|
recursive-state get init-inference
|
|
|
|
dup dup inline-compound drop present-effect
|
2005-03-05 14:45:23 -05:00
|
|
|
[ "infer-effect" set-word-prop ] keep
|
2005-02-08 22:02:44 -05:00
|
|
|
] with-scope consume/produce
|
|
|
|
] [
|
|
|
|
[
|
2005-05-14 00:23:00 -04:00
|
|
|
>r inferring-base-case get [
|
2005-02-08 22:02:44 -05:00
|
|
|
drop
|
|
|
|
] [
|
2005-03-05 14:45:23 -05:00
|
|
|
t "no-effect" set-word-prop
|
2005-02-08 22:02:44 -05:00
|
|
|
] ifte r> rethrow
|
|
|
|
] when*
|
|
|
|
] catch ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2004-12-24 02:52:02 -05:00
|
|
|
GENERIC: (apply-word)
|
|
|
|
|
2005-02-22 23:07:47 -05:00
|
|
|
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.
|
2005-03-05 14:45:23 -05:00
|
|
|
dup "no-effect" word-prop [
|
2005-02-08 22:02:44 -05:00
|
|
|
no-effect
|
2004-11-26 22:23:57 -05:00
|
|
|
] [
|
2005-02-24 20:52:17 -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 ;
|
|
|
|
|
2005-02-24 20:52:17 -05:00
|
|
|
GENERIC: apply-word
|
|
|
|
|
|
|
|
: apply-default ( word -- )
|
2005-03-05 14:45:23 -05:00
|
|
|
dup "infer-effect" word-prop [
|
|
|
|
over "infer" word-prop [
|
2005-02-24 20:52:17 -05:00
|
|
|
swap car ensure-d call drop
|
|
|
|
] [
|
|
|
|
consume/produce
|
|
|
|
] ifte*
|
|
|
|
] [
|
|
|
|
(apply-word)
|
|
|
|
] ifte* ;
|
|
|
|
|
|
|
|
M: word apply-word ( word -- )
|
|
|
|
apply-default ;
|
|
|
|
|
|
|
|
M: compound apply-word ( word -- )
|
2005-03-05 14:45:23 -05:00
|
|
|
dup "inline" word-prop [
|
2005-02-24 20:52:17 -05:00
|
|
|
inline-compound 2drop
|
|
|
|
] [
|
|
|
|
apply-default
|
|
|
|
] ifte ;
|
|
|
|
|
2005-01-13 17:28:29 -05:00
|
|
|
: with-recursion ( quot -- )
|
|
|
|
[
|
2005-05-14 00:23:00 -04:00
|
|
|
inferring-base-case on
|
2005-01-13 17:28:29 -05:00
|
|
|
call
|
|
|
|
] [
|
2005-05-14 00:23:00 -04:00
|
|
|
inferring-base-case off
|
2005-01-13 17:28:29 -05:00
|
|
|
rethrow
|
|
|
|
] catch ;
|
|
|
|
|
2005-02-22 23:07:47 -05:00
|
|
|
: base-case ( word [ label quot ] -- )
|
2004-12-30 02:40:14 -05:00
|
|
|
[
|
2005-02-22 23:07:47 -05:00
|
|
|
car over inline-compound [
|
2005-01-16 17:58:28 -05:00
|
|
|
drop
|
|
|
|
[ #call-label ] [ #call ] ?ifte
|
|
|
|
node-op set
|
|
|
|
node-param set
|
|
|
|
] bind
|
2005-01-13 17:28:29 -05:00
|
|
|
] with-recursion ;
|
2005-01-10 23:08:27 -05:00
|
|
|
|
|
|
|
: no-base-case ( word -- )
|
2005-02-22 23:07:47 -05:00
|
|
|
word-name " does not have a base case." cat2 inference-error ;
|
2005-01-10 23:08:27 -05:00
|
|
|
|
2005-02-22 23:07:47 -05:00
|
|
|
: 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.
|
2005-05-14 00:23:00 -04:00
|
|
|
inferring-base-case get [
|
2005-01-10 23:08:27 -05:00
|
|
|
drop no-base-case
|
2004-11-26 22:23:57 -05:00
|
|
|
] [
|
2005-05-14 00:23:00 -04:00
|
|
|
base-case
|
2004-12-30 02:40:14 -05:00
|
|
|
] ifte ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-02-24 20:52:17 -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.
|
2004-12-29 03:35:46 -05:00
|
|
|
dup recursive-state get assoc [
|
2005-01-31 14:02:09 -05:00
|
|
|
recursive-word
|
2004-11-26 22:23:57 -05:00
|
|
|
] [
|
2005-02-24 20:52:17 -05:00
|
|
|
apply-word
|
2004-12-29 03:35:46 -05:00
|
|
|
] ifte* ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-05-14 00:23:00 -04: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
|
|
|
|
2005-05-14 00:23:00 -04:00
|
|
|
\ execute [
|
|
|
|
[ word ] ensure-d pop-literal unit infer-quot-value
|
|
|
|
] "infer" set-word-prop
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-01-10 23:08:27 -05:00
|
|
|
! These hacks will go away soon
|
2005-03-05 14:45:23 -05:00
|
|
|
\ * [ [ 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
|
2005-03-28 23:45:13 -05:00
|
|
|
\ = [ [ 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
|
2005-03-28 23:45:13 -05:00
|
|
|
\ <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
|
2005-03-05 14:45:23 -05:00
|
|
|
|
2005-03-08 22:54:59 -05:00
|
|
|
\ no-method t "terminator" set-word-prop
|
|
|
|
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
|
2005-03-05 14:45:23 -05:00
|
|
|
\ not-a-number t "terminator" set-word-prop
|
|
|
|
\ throw t "terminator" set-word-prop
|