1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs effects fry grouping kernel math
4 namespaces quotations sequences stack-checker.backend
5 stack-checker.errors stack-checker.recursive-state
6 stack-checker.state stack-checker.values stack-checker.visitor
8 FROM: sequences.private => dispatch ;
9 IN: stack-checker.branches
11 : balanced? ( pairs -- ? )
12 [ second ] filter [ first2 length - ] map all-equal? ;
14 SYMBOLS: +bottom+ +top+ ;
16 : unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
17 ! Introduced values can be anything, and don't unify with
19 [ [ - +top+ <repetition> ] dip append ] [ 2drop f ] if* ;
21 : pad-with-bottom ( seq -- newseq )
22 ! Terminated branches are padded with bottom values which
23 ! unify with literals.
26 '[ _ +bottom+ pad-head ] map
29 : phi-inputs ( max-input-count pairs -- newseq )
31 swap '[ [ _ ] dip first2 unify-inputs ] map
35 : remove-bottom ( seq -- seq' )
36 +bottom+ swap remove ;
38 : unify-values ( values -- phi-out )
41 [ known ] map dup all-eq?
42 [ first make-known ] [ drop <value> ] if
45 : phi-outputs ( phi-in -- stack )
46 flip [ unify-values ] map ;
48 SYMBOLS: combinator quotations ;
50 : simple-unbalanced-branches-error ( word quots branches -- * )
51 [ length [ ( ..a -- ..b ) ] replicate ]
52 [ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
53 unbalanced-branches-error ;
55 : unify-branches ( ins stacks -- in phi-in phi-out )
57 [ keys maximum ] [ ] [ balanced? ] tri
58 [ dupd phi-inputs dup phi-outputs ] [
59 [ combinator get quotations get ] dip
60 simple-unbalanced-branches-error
64 : branch-variable ( seq symbol -- seq )
67 : active-variable ( seq symbol -- seq )
68 [ [ terminated? over at [ drop f ] when ] map ] dip
71 : datastack-phi ( seq -- phi-in phi-out )
72 [ input-count branch-variable ]
73 [ inner-d-index branch-variable minimum inner-d-index set ]
74 [ (meta-d) active-variable ] tri
76 [ input-count set ] [ ] [ dup >vector (meta-d) set ] tri* ;
78 : terminated-phi ( seq -- terminated )
79 terminated? branch-variable ;
81 : terminate-branches ( seq -- )
82 [ terminated? of ] all? [ terminate ] when ;
84 : compute-phi-function ( seq -- )
85 [ quotation active-variable sift quotations set ]
86 [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
87 [ terminate-branches ]
90 : copy-inference ( -- )
91 (meta-d) [ clone ] change
92 literals [ clone ] change
93 input-count [ ] change
94 inner-d-index [ ] change ;
96 : collect-variables ( -- hash )
108 } [ dup get ] H{ } map>assoc ;
110 GENERIC: infer-branch ( literal -- namespace )
112 M: literal-tuple infer-branch
116 [ value>> quotation set ] [ infer-literal-quot ] bi
120 M: declared-effect infer-branch
121 known>> infer-branch ;
123 M: callable infer-branch
127 [ quotation set ] [ infer-quot-here ] bi
131 : infer-branches ( branches -- input children data )
134 [ stack-visitor branch-variable ] keep ; inline
136 : (infer-if) ( branches -- )
138 [ first2 #if, ] dip compute-phi-function ;
140 GENERIC: curried/composed? ( known -- ? )
141 M: object curried/composed? drop f ;
142 M: curried-effect curried/composed? drop t ;
143 M: composed-effect curried/composed? drop t ;
144 M: declared-effect curried/composed? known>> curried/composed? ;
146 : declare-if-effects ( -- )
147 H{ } clone V{ } clone
148 [ [ \ if ( ..a -- ..b ) ] 2dip 0 declare-effect-d ]
149 [ [ \ if ( ..a -- ..b ) ] 2dip 1 declare-effect-d ] 2bi ;
153 2 literals-available? [
159 dup [ known curried/composed? ] any? [
161 [ rot [ drop call ] [ nip call ] if ]
164 [ #drop, ] [ [ literal ] map (infer-if) ] bi
168 : infer-dispatch ( -- )
169 \ dispatch combinator set
170 pop-literal infer-branches
171 [ #dispatch, ] dip compute-phi-function ;