2005-01-13 14:41:08 -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-07-26 16:39:14 -04:00
|
|
|
USING: errors generic hashtables interpreter kernel lists math
|
2005-07-27 20:13:11 -04:00
|
|
|
namespaces prettyprint sequences strings vectors words ;
|
2004-12-31 02:17:45 -05:00
|
|
|
|
2005-07-27 20:13:11 -04:00
|
|
|
: unify-lengths ( seq -- seq )
|
2004-12-31 02:17:45 -05:00
|
|
|
#! Pad all vectors to the same length. If one vector is
|
|
|
|
#! shorter, pad it with unknown results at the bottom.
|
2005-07-27 20:13:11 -04:00
|
|
|
dup max-length swap
|
|
|
|
[ [ required-inputs ] keep append ] map-with ;
|
2004-12-31 02:17:45 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: unify-results ( seq -- value )
|
2004-12-31 02:17:45 -05:00
|
|
|
#! If all values in list are equal, return the value.
|
2005-07-27 01:46:06 -04:00
|
|
|
#! Otherwise, unify.
|
2005-07-28 23:33:18 -04:00
|
|
|
dup [ eq? ] every? [ first ] [ <meet> ] ifte ;
|
2004-12-23 16:37:16 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: unify-stacks ( seq -- stack )
|
2004-11-26 22:23:57 -05:00
|
|
|
#! Replace differing literals in stacks with unknown
|
|
|
|
#! results.
|
2005-07-30 02:08:59 -04:00
|
|
|
unify-lengths flip [ unify-results ] map ;
|
2004-12-22 22:16:46 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: balanced? ( in out -- ? )
|
2005-07-28 23:33:18 -04:00
|
|
|
[ swap length swap length - ] 2map [ = ] every? ;
|
2004-12-07 23:21:32 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: unify-effect ( in out -- in out )
|
|
|
|
2dup balanced?
|
|
|
|
[ unify-stacks >r unify-stacks r> ]
|
|
|
|
[ "Unbalanced branches" inference-error ] ifte ;
|
2004-12-07 23:21:32 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: datastack-effect ( seq -- )
|
|
|
|
dup [ d-in swap hash ] map
|
|
|
|
swap [ meta-d swap hash ] map
|
2004-12-26 01:42:09 -05:00
|
|
|
unify-effect
|
|
|
|
meta-d set d-in set ;
|
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: callstack-effect ( seq -- )
|
|
|
|
dup length { } <repeated>
|
|
|
|
swap [ meta-r swap hash ] map
|
2004-12-26 01:42:09 -05:00
|
|
|
unify-effect
|
|
|
|
meta-r set drop ;
|
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: filter-terminators ( seq -- seq )
|
2005-02-08 22:02:44 -05:00
|
|
|
#! Remove branches that unconditionally throw errors.
|
|
|
|
[ [ active? ] bind ] subset ;
|
2004-12-07 23:21:32 -05:00
|
|
|
|
2005-07-26 16:39:14 -04:00
|
|
|
: unify-effects ( seq -- )
|
2005-07-27 20:13:11 -04:00
|
|
|
filter-terminators dup empty?
|
|
|
|
[ drop terminate ]
|
|
|
|
[ dup datastack-effect callstack-effect ] ifte ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
: unify-dataflow ( effects -- nodes )
|
|
|
|
[ [ dataflow-graph get ] bind ] map ;
|
|
|
|
|
2004-12-26 17:04:08 -05:00
|
|
|
: copy-inference ( -- )
|
|
|
|
#! We avoid cloning the same object more than once in order
|
|
|
|
#! to preserve identity structure.
|
2005-07-27 01:46:06 -04:00
|
|
|
meta-r [ clone ] change
|
|
|
|
meta-d [ clone ] change
|
|
|
|
d-in [ clone ] change
|
2005-05-17 16:13:08 -04:00
|
|
|
dataflow-graph off
|
|
|
|
current-node off ;
|
2004-12-23 18:26:04 -05:00
|
|
|
|
2004-12-27 15:27:18 -05:00
|
|
|
: infer-branch ( value -- namespace )
|
2005-02-08 22:02:44 -05:00
|
|
|
#! Return a namespace with inferencer variables:
|
|
|
|
#! meta-d, meta-r, d-in. They are set to f if
|
|
|
|
#! terminate was called.
|
2004-12-07 23:21:32 -05:00
|
|
|
<namespace> [
|
2004-12-26 17:04:08 -05:00
|
|
|
copy-inference
|
2005-05-16 01:15:48 -04:00
|
|
|
dup value-recursion recursive-state set
|
2005-01-31 14:02:09 -05:00
|
|
|
literal-value dup infer-quot
|
2005-07-27 01:46:06 -04:00
|
|
|
active? [ #values node, handle-terminator ] [ drop ] ifte
|
2004-12-07 23:21:32 -05:00
|
|
|
] extend ;
|
|
|
|
|
2004-12-08 18:39:36 -05:00
|
|
|
: (infer-branches) ( branchlist -- list )
|
2005-07-27 01:46:06 -04:00
|
|
|
[ infer-branch ] map dup unify-effects
|
|
|
|
unify-dataflow ;
|
2004-11-29 23:14:12 -05:00
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
: infer-branches ( branches node -- )
|
2004-11-26 22:23:57 -05:00
|
|
|
#! Recursive stack effect inference is done here. If one of
|
|
|
|
#! the branches has an undecidable stack effect, we set the
|
2005-05-14 00:23:00 -04:00
|
|
|
#! base case to this stack effect and try again.
|
2005-07-27 01:46:06 -04:00
|
|
|
[ >r (infer-branches) r> set-node-children ] keep
|
|
|
|
node, meta-d get >list #merge node, ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-05-15 21:17:56 -04:00
|
|
|
\ ifte [
|
2005-07-27 01:46:06 -04:00
|
|
|
2 #drop node, pop-d pop-d swap 2vector
|
2005-05-17 16:13:08 -04:00
|
|
|
#ifte pop-d drop infer-branches
|
2005-05-15 21:17:56 -04:00
|
|
|
] "infer" set-word-prop
|
2004-12-26 02:52:39 -05:00
|
|
|
|
2005-07-27 20:13:11 -04:00
|
|
|
: vtable-value ( rstate vtable -- seq )
|
2005-07-27 01:46:06 -04:00
|
|
|
[ swap <literal> ] map-with ;
|
2004-11-26 22:23:57 -05:00
|
|
|
|
2005-01-14 14:56:19 -05:00
|
|
|
USE: kernel-internals
|
2005-02-24 20:52:17 -05:00
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
\ dispatch [
|
2005-07-27 01:46:06 -04:00
|
|
|
pop-literal vtable-value
|
2005-05-17 16:13:08 -04:00
|
|
|
#dispatch pop-d drop infer-branches
|
|
|
|
] "infer" set-word-prop
|