1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays effects fry hints kernel locals math
4 math.order namespaces sequences stack-checker.backend
5 stack-checker.dependencies stack-checker.errors
6 stack-checker.known-words stack-checker.recursive-state
7 stack-checker.state stack-checker.values stack-checker.visitor
9 IN: stack-checker.inlining
11 ! Code to handle inline words. Much of the complexity stems from
12 ! having to handle recursive inline words.
14 : infer-inline-word-def ( word label -- )
15 [ drop specialized-def ] [ add-inline-word ] 2bi infer-quot ;
17 TUPLE: inline-recursive < identity-tuple
20 enter-out enter-recursive
26 : inlined-block? ( word -- ? ) "inlined-block" word-prop ;
28 : <inline-recursive> ( word -- label )
30 gensym dup t "inlined-block" set-word-prop >>id
33 : quotation-param? ( obj -- ? )
34 dup pair? [ second effect? ] [ drop f ] if ;
36 : make-copies ( values effect-in -- values' )
38 [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
39 [ length make-values ] dip append ;
44 : prepare-stack ( word -- )
45 required-stack-effect in>>
46 [ length ensure-d drop ] [
47 meta-d clone enter-in set
48 meta-d swap make-copies enter-out set
51 : emit-enter-recursive ( label -- )
52 enter-out get >>enter-out
53 enter-in get enter-out get #enter-recursive,
54 enter-out get >vector (meta-d) set ;
56 : entry-stack-height ( label -- stack )
59 :: check-return ( word label -- )
61 current-stack-height label entry-stack-height -
64 label word>> current-stack-height
65 unbalanced-recursion-error inference-error
69 : end-recursive-word ( word label -- )
71 [ meta-d dup copy-values dup (meta-d) set #return-recursive, ]
74 : recursive-word-inputs ( label -- n )
75 entry-stack-height input-count get + ;
77 : (inline-recursive-word) ( word -- label in out visitor terminated? )
83 dup <inline-recursive>
84 [ dup emit-enter-recursive infer-inline-word-def ]
85 [ end-recursive-word ]
89 dup recursive-word-inputs
95 : inline-recursive-word ( word -- )
96 (inline-recursive-word)
97 [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
100 : check-call-height ( label -- )
101 dup entry-stack-height current-stack-height > [
102 word>> diverging-recursion-error inference-error
105 : trim-stack ( label seq -- stack )
106 swap word>> required-stack-effect in>> length tail* ;
108 : call-site-stack ( label -- stack )
111 : trimmed-enter-out ( label -- stack )
112 dup enter-out>> trim-stack ;
114 GENERIC: (undeclared-known) ( value -- known )
115 M: object (undeclared-known) ;
116 M: declared-effect (undeclared-known) known>> (undeclared-known) ;
118 : undeclared-known ( value -- known ) known (undeclared-known) ;
120 : check-call-site-stack ( label -- )
121 [ ] [ call-site-stack ] [ trimmed-enter-out ] tri
122 [ dup undeclared-known [ [ undeclared-known ] same? ] [ 2drop t ] if ] 2all?
123 [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
125 : check-call ( label -- )
126 [ check-call-height ] [ check-call-site-stack ] bi ;
128 : adjust-stack-effect ( effect -- effect' )
130 meta-d length pick length [-]
131 object <repetition> '[ _ prepend ] bi@
134 : call-recursive-inline-word ( word label -- )
136 [ required-stack-effect adjust-stack-effect ] dip
137 [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
139 drop undeclared-recursion-error inference-error
142 : inline-word ( word -- )
144 [ +definition+ depends-on ]
145 [ declare-input-effects ]
147 dup inline-recursive-label [
148 call-recursive-inline-word
151 [ inline-recursive-word ]
152 [ dup infer-inline-word-def ]
158 dup inline? [ inline-word ] [ non-inline-word ] if ;