factor/library/inference/branches.factor

101 lines
3.0 KiB
Factor
Raw Normal View History

2005-01-13 14:41:08 -05:00
! 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-07-26 16:39:14 -04:00
USING: errors generic hashtables interpreter kernel lists math
namespaces prettyprint sequences strings unparser vectors words ;
2004-12-31 02:17:45 -05: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.
dup max-length swap
[ [ required-inputs ] keep append ] map-with ;
2004-12-31 02:17:45 -05:00
: unify-values ( 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 ;
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.
unify-lengths flip [ unify-values ] map ;
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:" } -rot [
swap length unparse " " rot length unparse append3
] 2map append "\n" join 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
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
unify-effect
meta-r set drop ;
2005-07-26 16:39:14 -04:00
: filter-terminators ( seq -- seq )
#! 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 -- )
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 )
#! 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 ;
: (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
#! 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, #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
USE: kernel-internals
2005-05-17 16:13:08 -04:00
\ dispatch [
2005-08-05 00:05:04 -04:00
pop-literal nip [ <literal> ] map
2005-05-17 16:13:08 -04:00
#dispatch pop-d drop infer-branches
] "infer" set-word-prop