Skip to content

Commit ef013b4

Browse files
jsiekjsiek
committed
strides towards reducing use of has-type
1 parent a800961 commit ef013b4

File tree

8 files changed

+343
-152
lines changed

8 files changed

+343
-152
lines changed

‎conditionals.rkt

Lines changed: 53 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,9 @@
6060
(error "argument type does not match parameter type"
6161
(list ts pts)))
6262
ret))
63-
63+
64+
;; The introduction of has-type should have been done in vectors.rkt
65+
;; and not here because it's not needed yet. -Jeremy
6466
(define/public (type-check env)
6567
(lambda (e)
6668
(vomit "conditionals/type-check" e env)
@@ -120,59 +122,56 @@
120122
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121123
;; flatten : S1 -> C1-expr x (C1-stmt list)
122124

123-
(define/override (collect-locals)
124-
(lambda (ast)
125-
(match ast
126-
[`(if ,cnd ,thn ,els)
127-
(append (append* (map (collect-locals) thn))
128-
(append* (map (collect-locals) els)))]
129-
[else ((super collect-locals) ast)])))
130-
131-
(define optimize-if #f)
125+
(field [optimize-if #f])
132126

133-
(define/public (flatten-if new-thn thn-ss new-els els-ss)
127+
(define/public (flatten-if new-thn thn-ss new-els els-ss xs)
134128
(lambda (cnd)
135129
(vomit "flatten-if" cnd)
136130
(match cnd
137131
[`(has-type ,cnd ,t)
138132
(match cnd
139133
[#t #:when optimize-if
140-
(values new-thn thn-ss)]
134+
(values new-thn thn-ss xs)]
141135
[#f #:when optimize-if
142-
(values new-els els-ss)]
136+
(values new-els els-ss xs)]
143137
[`(let ([,x ,e]) ,body) #:when optimize-if
144-
(define-values (new-e e-ss) ((flatten #f) e))
145-
(define-values (new-body body-ss)
146-
((flatten-if new-thn thn-ss new-els els-ss) body))
138+
(define-values (new-e e-ss xs1) ((flatten #f) e))
139+
(define-values (new-body body-ss xs2)
140+
((flatten-if new-thn thn-ss new-els els-ss xs) body))
147141
(values new-body
148142
(append e-ss
149143
`((assign ,x ,new-e))
150-
body-ss))]
144+
body-ss)
145+
(append xs1 xs2))]
151146
[`(not ,cnd) #:when optimize-if
152-
((flatten-if new-els els-ss new-thn thn-ss) cnd)]
147+
((flatten-if new-els els-ss new-thn thn-ss xs) cnd)]
153148
[`(,cmp ,e1 ,e2)
154149
#:when (and optimize-if (set-member? (comparison-ops) cmp))
155-
(define-values (new-e1 e1-ss) ((flatten #t) e1))
156-
(define-values (new-e2 e2-ss) ((flatten #t) e2))
150+
(define-values (new-e1 e1-ss xs1) ((flatten #t) e1))
151+
(define-values (new-e2 e2-ss xs2) ((flatten #t) e2))
157152
(define tmp (gensym 'if))
158153
(define thn-ret `(assign ,tmp ,new-thn))
159154
(define els-ret `(assign ,tmp ,new-els))
160155
(values `(has-type ,tmp ,t)
161156
(append e1-ss e2-ss
162157
`((if (,cmp ,new-e1 ,new-e2)
163158
,(append thn-ss (list thn-ret))
164-
,(append els-ss (list els-ret))))))]
159+
,(append els-ss (list els-ret)))))
160+
(cons tmp (append xs1 xs2 xs))
161+
)]
165162
[else
166-
(define-values (new-cnd cnd-ss) ((flatten #t)
167-
`(has-type ,cnd ,t)))
163+
(define-values (new-cnd cnd-ss xs1)
164+
((flatten #t) `(has-type ,cnd ,t)))
168165
(define tmp (gensym 'if))
169166
(define thn-ret `(assign ,tmp ,new-thn))
170167
(define els-ret `(assign ,tmp ,new-els))
171168
(values `(has-type ,tmp ,t)
172169
(append cnd-ss
173170
`((if (eq? (has-type #t Boolean) ,new-cnd)
174171
,(append thn-ss (list thn-ret))
175-
,(append els-ss (list els-ret))))))])]
172+
,(append els-ss (list els-ret)))))
173+
(cons tmp (append xs1 xs))
174+
)])]
176175
[other (error 'flatten-if "unmatched ~a" other)])))
177176

178177
(define/override (flatten need-atomic)
@@ -181,56 +180,58 @@
181180
(match e
182181
;; For atomic stuff, we keep the has-type annotation. -Jeremy
183182
[`(has-type (void) ,t)
184-
(values `(has-type (void) ,t) '())]
185-
[`(has-type ,e ,t) #:when (or (symbol? e) (integer? e) (boolean? e))
186-
(values `(has-type ,e ,t) '())]
183+
(values `(has-type (void) ,t) '() '())]
184+
[`(has-type ,e1 ,t)
185+
#:when (or (symbol? e1) (integer? e1) (boolean? e1))
186+
(values `(has-type ,e1 ,t) '() '())]
187187

188188
;; We override 'and' to place has-type's around the #t and #f
189189
;; in the generated code. -Jeremy
190190
[`(has-type (and ,e1 ,e2) ,t)
191-
(define-values (new-e1 e1-ss) ((flatten #t) e1))
192-
(define-values (new-e2 e2-ss) ((flatten #f) e2))
191+
(define-values (new-e1 e1-ss xs1) ((flatten #t) e1))
192+
(define-values (new-e2 e2-ss xs2) ((flatten #f) e2))
193193
(define tmp (gensym 'and))
194194
(values `(has-type ,tmp ,t)
195195
(append e1-ss
196196
`((if (eq? (has-type #t Boolean) ,new-e1)
197197
,(append e2-ss `((assign ,tmp ,new-e2)))
198-
((assign ,tmp (has-type #f Boolean)))))))]
198+
((assign ,tmp (has-type #f Boolean))))))
199+
(cons tmp (append xs1 xs2))
200+
)]
199201

200202
;; We override flattening for op's because we
201203
;; need to put a has-type on the LHS of the assign. -Jeremy
202-
[`(has-type (,op ,es ...) ,t)
203-
#:when (set-member? (primitives) op)
204-
(define-values (new-es sss) (map2 (flatten #t) es))
204+
[`(has-type (,op ,es ...) ,t) #:when (set-member? (primitives) op)
205+
(define-values (new-es sss xss) (map3 (flatten #t) es))
205206
(define ss (append* sss))
207+
(define xs (append* xss))
206208
(define prim-apply `(,op ,@new-es))
207209
(cond
208210
[need-atomic
209211
(define tmp (gensym 'tmp))
210212
(values `(has-type ,tmp ,t)
211-
(append ss `((assign ,tmp (has-type ,prim-apply ,t)))))]
212-
[else (values `(has-type ,prim-apply ,t) ss)])]
213+
(append ss `((assign ,tmp (has-type ,prim-apply ,t))))
214+
(cons tmp xs) )]
215+
[else (values `(has-type ,prim-apply ,t) ss xs)])]
213216

214217
;; For 'let' we just need to strip the enclosing has-type. -Jeremy
215-
[`(has-type (let ([,x ,e]) ,body) ,t)
216-
((flatten need-atomic) `(let ([,x ,e]) ,body))]
218+
[`(has-type (let ([,x ,rhs]) ,body) ,t)
219+
((flatten need-atomic) `(let ([,x ,rhs]) ,body))]
217220

218221
[`(has-type (if ,cnd ,thn ,els) ,t)
219-
(define-values (new-thn thn-ss) ((flatten #t) thn))
220-
(define-values (new-els els-ss) ((flatten #t) els))
221-
((flatten-if new-thn thn-ss new-els els-ss) cnd)]
222-
223-
[`(program ,e)
224-
(define-values (new-e ss) ((flatten #t) e))
225-
(define xs (append* (map (collect-locals) ss)))
226-
`(program ,(remove-duplicates xs)
227-
,@(append ss `((return ,new-e))))]
228-
[`(program (type ,ty) ,e)
229-
(define-values (new-e ss) ((flatten #t) e))
230-
(define xs (append* (map (collect-locals) ss)))
231-
`(program ,(remove-duplicates xs) (type ,ty)
232-
,@(append ss `((return ,new-e))))]
233-
[else ((super flatten need-atomic) e)])))
222+
(define-values (new-thn thn-ss xs1) ((flatten #t) thn))
223+
(define-values (new-els els-ss xs2) ((flatten #t) els))
224+
((flatten-if new-thn thn-ss new-els els-ss (append xs1 xs2)) cnd)]
225+
226+
[`(program ,body)
227+
(define-values (new-body ss xs) ((flatten #t) body))
228+
`(program ,xs ,@(append ss `((return ,new-body))))]
229+
[`(program (type ,ty) ,body)
230+
(define-values (new-body ss xs) ((flatten #t) body))
231+
`(program ,xs (type ,ty)
232+
,@(append ss `((return ,new-body))))]
233+
[else
234+
((super flatten need-atomic) e)])))
234235

235236
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
236237
;; select-instructions : env -> S1 -> S1
@@ -261,7 +262,6 @@
261262
[else (error 'compare->cc "unmatched ~a" cmp)]
262263
))
263264

264-
265265
(define/override (select-instructions)
266266
(lambda (e)
267267
(match e

‎dynamic-typing.rkt

Lines changed: 17 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -124,21 +124,28 @@
124124
(verbose "flatten" e)
125125
(match e
126126
[`(has-type (inject ,e ,ty) ,ty2)
127-
(define-values (new-e e-ss) ((send this flatten #t) e))
127+
(define-values (new-e e-ss xs) ((send this flatten #t) e))
128128
(cond [need-atomic
129129
(define tmp (gensym 'tmp))
130130
(values `(has-type ,tmp ,ty2)
131-
(append e-ss `((assign ,tmp (has-type (inject ,new-e ,ty) ,ty2)))))]
131+
(append e-ss `((assign ,tmp
132+
(has-type (inject ,new-e ,ty)
133+
,ty2))))
134+
(cons (cons tmp ty2) xs)
135+
)]
132136
[else
133-
(values `(has-type (inject ,new-e ,ty) ,ty2) e-ss)])]
137+
(values `(has-type (inject ,new-e ,ty) ,ty2) e-ss xs)])]
134138
[`(has-type (project ,e ,ty) ,ty2)
135-
(define-values (new-e e-ss) ((send this flatten #t) e))
139+
(define-values (new-e e-ss xs) ((send this flatten #t) e))
136140
(cond [need-atomic
137141
(define tmp (gensym 'tmp))
138142
(values `(has-type ,tmp ,ty2)
139-
(append e-ss `((assign ,tmp (has-type (project ,new-e ,ty) ,ty2)))))]
143+
(append e-ss `((assign ,tmp
144+
(has-type (project ,new-e ,ty)
145+
,ty2))))
146+
(cons (cons tmp ty2) xs))]
140147
[else
141-
(values `(has-type (project ,new-e ,ty) ,ty2) e-ss)])]
148+
(values `(has-type (project ,new-e ,ty) ,ty2) e-ss xs)])]
142149
[else
143150
((super flatten need-atomic) e)]
144151
)))
@@ -152,12 +159,12 @@
152159
[`(Vectorof ,T) #t]
153160
[else (super root-type? t)]))
154161

155-
(define/override (uncover-call-live-roots-exp e)
162+
(define/override ((uncover-call-live-roots-exp xs) e)
156163
(vomit "any/uncover-call-live-roots-exp" e)
157164
(match e
158-
[`(inject ,e ,ty) (uncover-call-live-roots-exp e)]
159-
[`(project ,e ,ty) (uncover-call-live-roots-exp e)]
160-
[else (super uncover-call-live-roots-exp e)]))
165+
[`(inject ,e ,ty) ((uncover-call-live-roots-exp xs) e)]
166+
[`(project ,e ,ty) ((uncover-call-live-roots-exp xs) e)]
167+
[else ((super uncover-call-live-roots-exp xs) e)]))
161168

162169
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
163170
;; select-instructions

0 commit comments

Comments
 (0)