1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
4 combinators quotations namespaces grouping locals stack-checker.state
5 stack-checker.backend stack-checker.errors stack-checker.visitor
6 stack-checker.values stack-checker.recursive-state ;
7 FROM: sequences.private => dispatch ;
8 IN: stack-checker.branches
10 : balanced? ( pairs -- ? )
11 [ second ] filter [ first2 length - ] map all-equal? ;
13 SYMBOLS: +bottom+ +top+ ;
15 : unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
16 ! Introduced values can be anything, and don't unify with
18 dup [ [ - +top+ <repetition> ] dip append ] [ 3drop f ] if ;
20 : pad-with-bottom ( seq -- newseq )
21 ! Terminated branches are padded with bottom values which
22 ! unify with literals.
24 dup [ length ] [ max ] map-reduce
25 '[ _ +bottom+ pad-head ] map
28 : phi-inputs ( max-input-count pairs -- newseq )
30 swap '[ [ _ ] dip first2 unify-inputs ] map
34 : remove-bottom ( seq -- seq' )
35 +bottom+ swap remove ;
37 : unify-values ( values -- phi-out )
40 [ known ] map dup all-eq?
41 [ first make-known ] [ drop <value> ] if
44 : phi-outputs ( phi-in -- stack )
45 flip [ unify-values ] map ;
47 SYMBOLS: combinator quotations ;
49 : simple-unbalanced-branches-error ( word quots branches -- * )
50 [ length [ ( ..a -- ..b ) ] replicate ]
51 [ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
52 unbalanced-branches-error ;
54 : unify-branches ( ins stacks -- in phi-in phi-out )
56 [ keys supremum ] [ ] [ balanced? ] tri
57 [ dupd phi-inputs dup phi-outputs ] [
58 [ combinator get quotations get ] dip
59 simple-unbalanced-branches-error
63 : branch-variable ( seq symbol -- seq )
64 '[ [ _ ] dip at ] map ;
66 : active-variable ( seq symbol -- seq )
67 [ [ terminated? over at [ drop f ] when ] map ] dip
70 : datastack-phi ( seq -- phi-in phi-out )
71 [ input-count branch-variable ]
72 [ inner-d-index branch-variable infimum inner-d-index set ]
73 [ \ meta-d active-variable ] tri
75 [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
77 : terminated-phi ( seq -- terminated )
78 terminated? branch-variable ;
80 : terminate-branches ( seq -- )
81 [ terminated? swap at ] all? [ terminate ] when ;
83 : compute-phi-function ( seq -- )
84 [ quotation active-variable sift quotations set ]
85 [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
86 [ terminate-branches ]
89 : copy-inference ( -- )
90 \ meta-d [ clone ] change
91 literals [ clone ] change
92 input-count [ ] change
93 inner-d-index [ ] change ;
95 GENERIC: infer-branch ( literal -- namespace )
97 M: literal infer-branch
101 [ value>> quotation set ] [ infer-literal-quot ] bi
104 M: declared-effect infer-branch
105 known>> infer-branch ;
107 M: callable infer-branch
111 [ quotation set ] [ infer-quot-here ] bi
114 : infer-branches ( branches -- input children data )
117 [ stack-visitor branch-variable ] keep ; inline
119 : (infer-if) ( branches -- )
121 [ first2 #if, ] dip compute-phi-function ;
123 GENERIC: curried/composed? ( known -- ? )
124 M: object curried/composed? drop f ;
125 M: curried curried/composed? drop t ;
126 M: composed curried/composed? drop t ;
127 M: declared-effect curried/composed? known>> curried/composed? ;
129 : declare-if-effects ( -- )
130 H{ } clone V{ } clone
131 [ [ \ if ( ..a -- ..b ) ] 2dip 0 declare-effect-d ]
132 [ [ \ if ( ..a -- ..b ) ] 2dip 1 declare-effect-d ] 2bi ;
136 2 literals-available? [
142 dup [ known curried/composed? ] any? [
144 [ rot [ drop call ] [ nip call ] if ]
147 [ #drop, ] [ [ literal ] map (infer-if) ] bi
151 : infer-dispatch ( -- )
152 \ dispatch combinator set
153 pop-literal nip infer-branches
154 [ #dispatch, ] dip compute-phi-function ;