Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2016-2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor Rssa (S: RSSA_STRUCTS): RSSA = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | local | |
16 | open Prim | |
17 | in | |
18 | structure ApplyArg = ApplyArg | |
19 | structure ApplyResult = ApplyResult | |
20 | end | |
21 | local | |
22 | open Runtime | |
23 | in | |
24 | structure CFunction = CFunction | |
25 | structure GCField = GCField | |
26 | end | |
27 | ||
28 | fun constrain (ty: Type.t): Layout.t = | |
29 | let | |
30 | open Layout | |
31 | in | |
32 | if !Control.showTypes | |
33 | then seq [str ": ", Type.layout ty] | |
34 | else empty | |
35 | end | |
36 | ||
37 | structure Operand = | |
38 | struct | |
39 | datatype t = | |
40 | ArrayOffset of {base: t, | |
41 | index: t, | |
42 | offset: Bytes.t, | |
43 | scale: Scale.t, | |
44 | ty: Type.t} | |
45 | | Cast of t * Type.t | |
46 | | Const of Const.t | |
47 | | EnsuresBytesFree | |
48 | | GCState | |
49 | | Offset of {base: t, | |
50 | offset: Bytes.t, | |
51 | ty: Type.t} | |
52 | | ObjptrTycon of ObjptrTycon.t | |
53 | | Runtime of GCField.t | |
54 | | Var of {var: Var.t, | |
55 | ty: Type.t} | |
56 | ||
57 | val null = Const Const.null | |
58 | ||
59 | val word = Const o Const.word | |
60 | ||
61 | fun zero s = word (WordX.fromIntInf (0, s)) | |
62 | ||
63 | fun bool b = | |
64 | word (WordX.fromIntInf (if b then 1 else 0, WordSize.bool)) | |
65 | ||
66 | val ty = | |
67 | fn ArrayOffset {ty, ...} => ty | |
68 | | Cast (_, ty) => ty | |
69 | | Const c => | |
70 | let | |
71 | datatype z = datatype Const.t | |
72 | in | |
73 | case c of | |
74 | IntInf _ => Type.intInf () | |
75 | | Null => Type.cpointer () | |
76 | | Real r => Type.real (RealX.size r) | |
77 | | Word w => Type.ofWordX w | |
78 | | WordVector v => Type.ofWordXVector v | |
79 | end | |
80 | | EnsuresBytesFree => Type.csize () | |
81 | | GCState => Type.gcState () | |
82 | | Offset {ty, ...} => ty | |
83 | | ObjptrTycon _ => Type.objptrHeader () | |
84 | | Runtime z => Type.ofGCField z | |
85 | | Var {ty, ...} => ty | |
86 | ||
87 | fun layout (z: t): Layout.t = | |
88 | let | |
89 | open Layout | |
90 | in | |
91 | case z of | |
92 | ArrayOffset {base, index, offset, scale, ty} => | |
93 | seq [str (concat ["X", Type.name ty, " "]), | |
94 | tuple [layout base, layout index, Scale.layout scale, | |
95 | Bytes.layout offset]] | |
96 | | Cast (z, ty) => | |
97 | seq [str "Cast ", tuple [layout z, Type.layout ty]] | |
98 | | Const c => seq [Const.layout c, constrain (ty z)] | |
99 | | EnsuresBytesFree => str "<EnsuresBytesFree>" | |
100 | | GCState => str "<GCState>" | |
101 | | Offset {base, offset, ty} => | |
102 | seq [str (concat ["O", Type.name ty, " "]), | |
103 | tuple [layout base, Bytes.layout offset], | |
104 | constrain ty] | |
105 | | ObjptrTycon opt => ObjptrTycon.layout opt | |
106 | | Runtime r => GCField.layout r | |
107 | | Var {var, ...} => Var.layout var | |
108 | end | |
109 | ||
110 | fun cast (z: t, t: Type.t): t = | |
111 | if Type.equals (t, ty z) | |
112 | then z | |
113 | else Cast (z, t) | |
114 | ||
115 | val cast = Trace.trace2 ("Rssa.Operand.cast", layout, Type.layout, layout) cast | |
116 | ||
117 | val rec isLocation = | |
118 | fn ArrayOffset _ => true | |
119 | | Cast (z, _) => isLocation z | |
120 | | Offset _ => true | |
121 | | Runtime _ => true | |
122 | | Var _ => true | |
123 | | _ => false | |
124 | ||
125 | fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a = | |
126 | case z of | |
127 | ArrayOffset {base, index, ...} => | |
128 | foldVars (index, foldVars (base, a, f), f) | |
129 | | Cast (z, _) => foldVars (z, a, f) | |
130 | | Offset {base, ...} => foldVars (base, a, f) | |
131 | | Var {var, ...} => f (var, a) | |
132 | | _ => a | |
133 | ||
134 | fun replaceVar (z: t, f: Var.t -> t): t = | |
135 | let | |
136 | fun loop (z: t): t = | |
137 | case z of | |
138 | ArrayOffset {base, index, offset, scale, ty} => | |
139 | ArrayOffset {base = loop base, | |
140 | index = loop index, | |
141 | offset = offset, | |
142 | scale = scale, | |
143 | ty = ty} | |
144 | | Cast (t, ty) => Cast (loop t, ty) | |
145 | | Offset {base, offset, ty} => | |
146 | Offset {base = loop base, | |
147 | offset = offset, | |
148 | ty = ty} | |
149 | | Var {var, ...} => f var | |
150 | | _ => z | |
151 | in | |
152 | loop z | |
153 | end | |
154 | ||
155 | end | |
156 | ||
157 | structure Switch = | |
158 | struct | |
159 | local | |
160 | structure S = Switch (open S | |
161 | structure Type = Type | |
162 | structure Use = Operand) | |
163 | in | |
164 | open S | |
165 | end | |
166 | ||
167 | fun replaceVar (T {cases, default, size, test}, f) = | |
168 | T {cases = cases, | |
169 | default = default, | |
170 | size = size, | |
171 | test = Operand.replaceVar (test, f)} | |
172 | end | |
173 | ||
174 | structure Statement = | |
175 | struct | |
176 | datatype t = | |
177 | Bind of {dst: Var.t * Type.t, | |
178 | isMutable: bool, | |
179 | src: Operand.t} | |
180 | | Move of {dst: Operand.t, | |
181 | src: Operand.t} | |
182 | | Object of {dst: Var.t * Type.t, | |
183 | header: word, | |
184 | size: Bytes.t} | |
185 | | PrimApp of {args: Operand.t vector, | |
186 | dst: (Var.t * Type.t) option, | |
187 | prim: Type.t Prim.t} | |
188 | | Profile of ProfileExp.t | |
189 | | ProfileLabel of ProfileLabel.t | |
190 | | SetExnStackLocal | |
191 | | SetExnStackSlot | |
192 | | SetHandler of Label.t | |
193 | | SetSlotExnStack | |
194 | ||
195 | fun 'a foldDefUse (s, a: 'a, {def: Var.t * Type.t * 'a -> 'a, | |
196 | use: Var.t * 'a -> 'a}): 'a = | |
197 | let | |
198 | fun useOperand (z: Operand.t, a) = Operand.foldVars (z, a, use) | |
199 | in | |
200 | case s of | |
201 | Bind {dst = (x, t), src, ...} => def (x, t, useOperand (src, a)) | |
202 | | Move {dst, src} => useOperand (src, useOperand (dst, a)) | |
203 | | Object {dst = (dst, ty), ...} => def (dst, ty, a) | |
204 | | PrimApp {dst, args, ...} => | |
205 | Vector.fold (args, | |
206 | Option.fold (dst, a, fn ((x, t), a) => | |
207 | def (x, t, a)), | |
208 | useOperand) | |
209 | | Profile _ => a | |
210 | | ProfileLabel _ => a | |
211 | | SetExnStackLocal => a | |
212 | | SetExnStackSlot => a | |
213 | | SetHandler _ => a | |
214 | | SetSlotExnStack => a | |
215 | end | |
216 | ||
217 | fun foreachDefUse (s: t, {def, use}) = | |
218 | foldDefUse (s, (), {def = fn (x, t, ()) => def (x, t), | |
219 | use = use o #1}) | |
220 | ||
221 | fun 'a foldDef (s: t, a: 'a, f: Var.t * Type.t * 'a -> 'a): 'a = | |
222 | foldDefUse (s, a, {def = f, use = #2}) | |
223 | ||
224 | fun foreachDef (s:t , f: Var.t * Type.t -> unit) = | |
225 | foldDef (s, (), fn (x, t, ()) => f (x, t)) | |
226 | ||
227 | fun 'a foldUse (s: t, a: 'a, f: Var.t * 'a -> 'a) = | |
228 | foldDefUse (s, a, {def = #3, use = f}) | |
229 | ||
230 | fun foreachUse (s, f) = foldUse (s, (), f o #1) | |
231 | ||
232 | fun replaceUses (s: t, f: Var.t -> Operand.t): t = | |
233 | let | |
234 | fun oper (z: Operand.t): Operand.t = | |
235 | Operand.replaceVar (z, f) | |
236 | in | |
237 | case s of | |
238 | Bind {dst, isMutable, src} => | |
239 | Bind {dst = dst, | |
240 | isMutable = isMutable, | |
241 | src = oper src} | |
242 | | Move {dst, src} => Move {dst = oper dst, src = oper src} | |
243 | | Object _ => s | |
244 | | PrimApp {args, dst, prim} => | |
245 | PrimApp {args = Vector.map (args, oper), | |
246 | dst = dst, | |
247 | prim = prim} | |
248 | | Profile _ => s | |
249 | | ProfileLabel _ => s | |
250 | | SetExnStackLocal => s | |
251 | | SetExnStackSlot => s | |
252 | | SetHandler _ => s | |
253 | | SetSlotExnStack => s | |
254 | end | |
255 | ||
256 | val layout = | |
257 | let | |
258 | open Layout | |
259 | in | |
260 | fn Bind {dst = (x, t), src, ...} => | |
261 | mayAlign | |
262 | [seq [Var.layout x, constrain t], | |
263 | indent (seq [str "= ", Operand.layout src], 2)] | |
264 | | Move {dst, src} => | |
265 | mayAlign | |
266 | [Operand.layout dst, | |
267 | indent (seq [str ":= ", Operand.layout src], 2)] | |
268 | | Object {dst = (dst, ty), header, size} => | |
269 | mayAlign | |
270 | [seq [Var.layout dst, constrain ty], | |
271 | indent (seq [str "= Object ", | |
272 | record [("header", seq [str "0x", Word.layout header]), | |
273 | ("size", Bytes.layout size)]], | |
274 | 2)] | |
275 | | PrimApp {dst, prim, args, ...} => | |
276 | mayAlign | |
277 | [case dst of | |
278 | NONE => seq [str "_", constrain (Type.unit)] | |
279 | | SOME (x, t) => seq [Var.layout x, constrain t], | |
280 | indent (seq [str "= ", Prim.layout prim, str " ", | |
281 | Vector.layout Operand.layout args], | |
282 | 2)] | |
283 | | Profile e => ProfileExp.layout e | |
284 | | ProfileLabel p => | |
285 | seq [str "ProfileLabel ", ProfileLabel.layout p] | |
286 | | SetExnStackLocal => str "SetExnStackLocal" | |
287 | | SetExnStackSlot => str "SetExnStackSlot " | |
288 | | SetHandler l => seq [str "SetHandler ", Label.layout l] | |
289 | | SetSlotExnStack => str "SetSlotExnStack " | |
290 | end | |
291 | ||
292 | val toString = Layout.toString o layout | |
293 | ||
294 | fun clear (s: t) = | |
295 | foreachDef (s, Var.clear o #1) | |
296 | ||
297 | fun resize (src: Operand.t, dstTy: Type.t): Operand.t * t list = | |
298 | let | |
299 | val srcTy = Operand.ty src | |
300 | ||
301 | val (src, srcTy, ssSrc, dstTy, finishDst) = | |
302 | case (Type.deReal srcTy, Type.deReal dstTy) of | |
303 | (NONE, NONE) => | |
304 | (src, srcTy, [], dstTy, fn dst => (dst, [])) | |
305 | | (SOME rs, NONE) => | |
306 | let | |
307 | val ws = WordSize.fromBits (RealSize.bits rs) | |
308 | val tmp = Var.newNoname () | |
309 | val tmpTy = Type.word ws | |
310 | in | |
311 | (Operand.Var {ty = tmpTy, var = tmp}, | |
312 | tmpTy, | |
313 | [PrimApp {args = Vector.new1 src, | |
314 | dst = SOME (tmp, tmpTy), | |
315 | prim = Prim.realCastToWord (rs, ws)}], | |
316 | dstTy, fn dst => (dst, [])) | |
317 | end | |
318 | | (NONE, SOME rs) => | |
319 | let | |
320 | val ws = WordSize.fromBits (RealSize.bits rs) | |
321 | val tmp = Var.newNoname () | |
322 | val tmpTy = Type.real rs | |
323 | in | |
324 | (src, srcTy, [], | |
325 | Type.word ws, | |
326 | fn dst => | |
327 | (Operand.Var {ty = tmpTy, var = tmp}, | |
328 | [PrimApp {args = Vector.new1 dst, | |
329 | dst = SOME (tmp, tmpTy), | |
330 | prim = Prim.wordCastToReal (ws, rs)}])) | |
331 | end | |
332 | | (SOME _, SOME _) => | |
333 | (src, srcTy, [], dstTy, fn dst => (dst, [])) | |
334 | ||
335 | val srcW = Type.width srcTy | |
336 | val dstW = Type.width dstTy | |
337 | ||
338 | val (dst, ssConv) = | |
339 | if Bits.equals (srcW, dstW) | |
340 | then (Operand.cast (src, dstTy), []) | |
341 | else let | |
342 | val tmp = Var.newNoname () | |
343 | val tmpTy = dstTy | |
344 | in | |
345 | (Operand.Var {ty = tmpTy, var = tmp}, | |
346 | [PrimApp {args = Vector.new1 src, | |
347 | dst = SOME (tmp, tmpTy), | |
348 | prim = (Prim.wordExtdToWord | |
349 | (WordSize.fromBits srcW, | |
350 | WordSize.fromBits dstW, | |
351 | {signed = false}))}]) | |
352 | end | |
353 | ||
354 | val (dst, ssDst) = finishDst dst | |
355 | in | |
356 | (dst, ssSrc @ ssConv @ ssDst) | |
357 | end | |
358 | end | |
359 | ||
360 | datatype z = datatype Statement.t | |
361 | ||
362 | structure Transfer = | |
363 | struct | |
364 | datatype t = | |
365 | Arith of {args: Operand.t vector, | |
366 | dst: Var.t, | |
367 | overflow: Label.t, | |
368 | prim: Type.t Prim.t, | |
369 | success: Label.t, | |
370 | ty: Type.t} | |
371 | | CCall of {args: Operand.t vector, | |
372 | func: Type.t CFunction.t, | |
373 | return: Label.t option} | |
374 | | Call of {args: Operand.t vector, | |
375 | func: Func.t, | |
376 | return: Return.t} | |
377 | | Goto of {args: Operand.t vector, | |
378 | dst: Label.t} | |
379 | | Raise of Operand.t vector | |
380 | | Return of Operand.t vector | |
381 | | Switch of Switch.t | |
382 | ||
383 | fun layout t = | |
384 | let | |
385 | open Layout | |
386 | in | |
387 | case t of | |
388 | Arith {args, dst, overflow, prim, success, ty} => | |
389 | seq [str "Arith ", | |
390 | record [("args", Vector.layout Operand.layout args), | |
391 | ("dst", Var.layout dst), | |
392 | ("overflow", Label.layout overflow), | |
393 | ("prim", Prim.layout prim), | |
394 | ("success", Label.layout success), | |
395 | ("ty", Type.layout ty)]] | |
396 | | CCall {args, func, return} => | |
397 | seq [str "CCall ", | |
398 | record [("args", Vector.layout Operand.layout args), | |
399 | ("func", CFunction.layout (func, Type.layout)), | |
400 | ("return", Option.layout Label.layout return)]] | |
401 | | Call {args, func, return} => | |
402 | seq [Func.layout func, str " ", | |
403 | Vector.layout Operand.layout args, | |
404 | str " ", Return.layout return] | |
405 | | Goto {dst, args} => | |
406 | seq [Label.layout dst, str " ", | |
407 | Vector.layout Operand.layout args] | |
408 | | Raise xs => seq [str "raise ", Vector.layout Operand.layout xs] | |
409 | | Return xs => seq [str "return ", Vector.layout Operand.layout xs] | |
410 | | Switch s => Switch.layout s | |
411 | end | |
412 | ||
413 | fun bug () = | |
414 | CCall {args = (Vector.new1 | |
415 | (Operand.Const | |
416 | (Const.string "control shouldn't reach here"))), | |
417 | func = Type.BuiltInCFunction.bug (), | |
418 | return = NONE} | |
419 | ||
420 | fun foreachFunc (t, f : Func.t -> unit) : unit = | |
421 | case t of | |
422 | Call {func, ...} => f func | |
423 | | _ => () | |
424 | ||
425 | fun 'a foldDefLabelUse (t, a: 'a, | |
426 | {def: Var.t * Type.t * 'a -> 'a, | |
427 | label: Label.t * 'a -> 'a, | |
428 | use: Var.t * 'a -> 'a}): 'a = | |
429 | let | |
430 | fun useOperand (z, a) = Operand.foldVars (z, a, use) | |
431 | fun useOperands (zs: Operand.t vector, a) = | |
432 | Vector.fold (zs, a, useOperand) | |
433 | in | |
434 | case t of | |
435 | Arith {args, dst, overflow, success, ty, ...} => | |
436 | let | |
437 | val a = label (overflow, a) | |
438 | val a = label (success, a) | |
439 | val a = def (dst, ty, a) | |
440 | val a = useOperands (args, a) | |
441 | in | |
442 | a | |
443 | end | |
444 | | CCall {args, return, ...} => | |
445 | useOperands (args, | |
446 | case return of | |
447 | NONE => a | |
448 | | SOME l => label (l, a)) | |
449 | | Call {args, return, ...} => | |
450 | useOperands (args, Return.foldLabel (return, a, label)) | |
451 | | Goto {args, dst, ...} => label (dst, useOperands (args, a)) | |
452 | | Raise zs => useOperands (zs, a) | |
453 | | Return zs => useOperands (zs, a) | |
454 | | Switch s => Switch.foldLabelUse (s, a, {label = label, | |
455 | use = useOperand}) | |
456 | end | |
457 | ||
458 | fun foreachDefLabelUse (t, {def, label, use}) = | |
459 | foldDefLabelUse (t, (), {def = fn (x, t, ()) => def (x, t), | |
460 | label = label o #1, | |
461 | use = use o #1}) | |
462 | ||
463 | fun foldLabel (t, a, f) = foldDefLabelUse (t, a, {def = #3, | |
464 | label = f, | |
465 | use = #2}) | |
466 | ||
467 | fun foreachLabel (t, f) = foldLabel (t, (), f o #1) | |
468 | ||
469 | fun foldDef (t, a, f) = foldDefLabelUse (t, a, {def = f, | |
470 | label = #2, | |
471 | use = #2}) | |
472 | ||
473 | fun foreachDef (t, f) = | |
474 | foldDef (t, (), fn (x, t, ()) => f (x, t)) | |
475 | ||
476 | fun foldUse (t, a, f) = foldDefLabelUse (t, a, {def = #3, | |
477 | label = #2, | |
478 | use = f}) | |
479 | ||
480 | fun foreachUse (t, f) = foldUse (t, (), f o #1) | |
481 | ||
482 | fun clear (t: t): unit = | |
483 | foreachDef (t, Var.clear o #1) | |
484 | ||
485 | local | |
486 | fun make i = WordX.fromIntInf (i, WordSize.bool) | |
487 | in | |
488 | fun ifBool (test, {falsee, truee}) = | |
489 | Switch (Switch.T | |
490 | {cases = Vector.new2 ((make 0, falsee), (make 1, truee)), | |
491 | default = NONE, | |
492 | size = WordSize.bool, | |
493 | test = test}) | |
494 | fun ifZero (test, {falsee, truee}) = | |
495 | Switch (Switch.T | |
496 | {cases = Vector.new1 (make 0, truee), | |
497 | default = SOME falsee, | |
498 | size = WordSize.bool, | |
499 | test = test}) | |
500 | end | |
501 | ||
502 | fun replaceUses (t: t, f: Var.t -> Operand.t): t = | |
503 | let | |
504 | fun oper z = Operand.replaceVar (z, f) | |
505 | fun opers zs = Vector.map (zs, oper) | |
506 | in | |
507 | case t of | |
508 | Arith {args, dst, overflow, prim, success, ty} => | |
509 | Arith {args = opers args, | |
510 | dst = dst, | |
511 | overflow = overflow, | |
512 | prim = prim, | |
513 | success = success, | |
514 | ty = ty} | |
515 | | CCall {args, func, return} => | |
516 | CCall {args = opers args, | |
517 | func = func, | |
518 | return = return} | |
519 | | Call {args, func, return} => | |
520 | Call {args = opers args, | |
521 | func = func, | |
522 | return = return} | |
523 | | Goto {args, dst} => | |
524 | Goto {args = opers args, | |
525 | dst = dst} | |
526 | | Raise zs => Raise (opers zs) | |
527 | | Return zs => Return (opers zs) | |
528 | | Switch s => Switch (Switch.replaceVar (s, f)) | |
529 | end | |
530 | end | |
531 | ||
532 | structure Kind = | |
533 | struct | |
534 | datatype t = | |
535 | Cont of {handler: Handler.t} | |
536 | | CReturn of {func: Type.t CFunction.t} | |
537 | | Handler | |
538 | | Jump | |
539 | ||
540 | fun layout k = | |
541 | let | |
542 | open Layout | |
543 | in | |
544 | case k of | |
545 | Cont {handler} => | |
546 | seq [str "Cont ", | |
547 | record [("handler", Handler.layout handler)]] | |
548 | | CReturn {func} => | |
549 | seq [str "CReturn ", | |
550 | record [("func", CFunction.layout (func, Type.layout))]] | |
551 | | Handler => str "Handler" | |
552 | | Jump => str "Jump" | |
553 | end | |
554 | ||
555 | datatype frameStyle = None | OffsetsAndSize | SizeOnly | |
556 | fun frameStyle (k: t): frameStyle = | |
557 | case k of | |
558 | Cont _ => OffsetsAndSize | |
559 | | CReturn {func, ...} => | |
560 | if CFunction.mayGC func | |
561 | then OffsetsAndSize | |
562 | else if !Control.profile = Control.ProfileNone | |
563 | then None | |
564 | else SizeOnly | |
565 | | Handler => SizeOnly | |
566 | | Jump => None | |
567 | end | |
568 | ||
569 | local | |
570 | open Layout | |
571 | in | |
572 | fun layoutFormals (xts: (Var.t * Type.t) vector) = | |
573 | Vector.layout (fn (x, t) => | |
574 | seq [Var.layout x, | |
575 | if !Control.showTypes | |
576 | then seq [str ": ", Type.layout t] | |
577 | else empty]) | |
578 | xts | |
579 | end | |
580 | ||
581 | structure Block = | |
582 | struct | |
583 | datatype t = | |
584 | T of {args: (Var.t * Type.t) vector, | |
585 | kind: Kind.t, | |
586 | label: Label.t, | |
587 | statements: Statement.t vector, | |
588 | transfer: Transfer.t} | |
589 | ||
590 | local | |
591 | fun make f (T r) = f r | |
592 | in | |
593 | val kind = make #kind | |
594 | val label = make #label | |
595 | end | |
596 | ||
597 | fun clear (T {args, label, statements, transfer, ...}) = | |
598 | (Vector.foreach (args, Var.clear o #1) | |
599 | ; Label.clear label | |
600 | ; Vector.foreach (statements, Statement.clear) | |
601 | ; Transfer.clear transfer) | |
602 | ||
603 | fun layout (T {args, kind, label, statements, transfer, ...}) = | |
604 | let | |
605 | open Layout | |
606 | in | |
607 | align [seq [Label.layout label, str " ", | |
608 | Vector.layout (fn (x, t) => | |
609 | if !Control.showTypes | |
610 | then seq [Var.layout x, str ": ", | |
611 | Type.layout t] | |
612 | else Var.layout x) args, | |
613 | str " ", Kind.layout kind, str " = "], | |
614 | indent (align | |
615 | [align | |
616 | (Vector.toListMap (statements, Statement.layout)), | |
617 | Transfer.layout transfer], | |
618 | 2)] | |
619 | end | |
620 | ||
621 | fun foreachDef (T {args, statements, transfer, ...}, f) = | |
622 | (Vector.foreach (args, f) | |
623 | ; Vector.foreach (statements, fn s => Statement.foreachDef (s, f)) | |
624 | ; Transfer.foreachDef (transfer, f)) | |
625 | ||
626 | fun foreachUse (T {statements, transfer, ...}, f) = | |
627 | (Vector.foreach (statements, fn s => Statement.foreachUse (s, f)) | |
628 | ; Transfer.foreachUse (transfer, f)) | |
629 | end | |
630 | ||
631 | structure Function = | |
632 | struct | |
633 | datatype t = T of {args: (Var.t * Type.t) vector, | |
634 | blocks: Block.t vector, | |
635 | name: Func.t, | |
636 | raises: Type.t vector option, | |
637 | returns: Type.t vector option, | |
638 | start: Label.t} | |
639 | ||
640 | local | |
641 | fun make f (T r) = f r | |
642 | in | |
643 | val blocks = make #blocks | |
644 | val name = make #name | |
645 | end | |
646 | ||
647 | fun dest (T r) = r | |
648 | val new = T | |
649 | ||
650 | fun clear (T {name, args, blocks, ...}) = | |
651 | (Func.clear name | |
652 | ; Vector.foreach (args, Var.clear o #1) | |
653 | ; Vector.foreach (blocks, Block.clear)) | |
654 | ||
655 | fun layoutHeader (T {args, name, raises, returns, start, ...}): Layout.t = | |
656 | let | |
657 | open Layout | |
658 | in | |
659 | seq [str "fun ", Func.layout name, | |
660 | str " ", layoutFormals args, | |
661 | if !Control.showTypes | |
662 | then seq [str ": ", | |
663 | record [("raises", | |
664 | Option.layout | |
665 | (Vector.layout Type.layout) raises), | |
666 | ("returns", | |
667 | Option.layout | |
668 | (Vector.layout Type.layout) returns)]] | |
669 | else empty, | |
670 | str " = ", Label.layout start, str " ()"] | |
671 | end | |
672 | ||
673 | fun layouts (f as T {blocks, ...}, output) = | |
674 | (output (layoutHeader f) | |
675 | ; Vector.foreach (blocks, fn b => | |
676 | output (Layout.indent (Block.layout b, 2)))) | |
677 | ||
678 | fun layout (f as T {blocks, ...}) = | |
679 | let | |
680 | open Layout | |
681 | in | |
682 | align [layoutHeader f, | |
683 | indent (align (Vector.toListMap (blocks, Block.layout)), 2)] | |
684 | end | |
685 | ||
686 | fun foreachDef (T {args, blocks, ...}, f) = | |
687 | (Vector.foreach (args, f) | |
688 | ; (Vector.foreach (blocks, fn b => Block.foreachDef (b, f)))) | |
689 | ||
690 | fun foreachUse (T {blocks, ...}, f) = | |
691 | Vector.foreach (blocks, fn b => Block.foreachUse (b, f)) | |
692 | ||
693 | fun dfs (T {blocks, start, ...}, v) = | |
694 | let | |
695 | val numBlocks = Vector.length blocks | |
696 | val {get = labelIndex, set = setLabelIndex, rem, ...} = | |
697 | Property.getSetOnce (Label.plist, | |
698 | Property.initRaise ("index", Label.layout)) | |
699 | val _ = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) => | |
700 | setLabelIndex (label, i)) | |
701 | val visited = Array.array (numBlocks, false) | |
702 | fun visit (l: Label.t): unit = | |
703 | let | |
704 | val i = labelIndex l | |
705 | in | |
706 | if Array.sub (visited, i) | |
707 | then () | |
708 | else | |
709 | let | |
710 | val _ = Array.update (visited, i, true) | |
711 | val b as Block.T {transfer, ...} = | |
712 | Vector.sub (blocks, i) | |
713 | val v' = v b | |
714 | val _ = Transfer.foreachLabel (transfer, visit) | |
715 | val _ = v' () | |
716 | in | |
717 | () | |
718 | end | |
719 | end | |
720 | val _ = visit start | |
721 | val _ = Vector.foreach (blocks, rem o Block.label) | |
722 | in | |
723 | () | |
724 | end | |
725 | ||
726 | structure Graph = DirectedGraph | |
727 | structure Node = Graph.Node | |
728 | ||
729 | fun dominatorTree (T {blocks, start, ...}): Block.t Tree.t = | |
730 | let | |
731 | open Dot | |
732 | val g = Graph.new () | |
733 | fun newNode () = Graph.newNode g | |
734 | val {get = labelNode, ...} = | |
735 | Property.get | |
736 | (Label.plist, Property.initFun (fn _ => newNode ())) | |
737 | val {get = nodeInfo: unit Node.t -> {block: Block.t}, | |
738 | set = setNodeInfo, ...} = | |
739 | Property.getSetOnce | |
740 | (Node.plist, Property.initRaise ("info", Node.layout)) | |
741 | val () = | |
742 | Vector.foreach | |
743 | (blocks, fn b as Block.T {label, ...}=> | |
744 | setNodeInfo (labelNode label, {block = b})) | |
745 | val () = | |
746 | Vector.foreach | |
747 | (blocks, fn Block.T {label, transfer, ...} => | |
748 | let | |
749 | val from = labelNode label | |
750 | val _ = | |
751 | Transfer.foreachLabel | |
752 | (transfer, fn to => | |
753 | (ignore o Graph.addEdge) | |
754 | (g, {from = from, to = labelNode to})) | |
755 | in | |
756 | () | |
757 | end) | |
758 | in | |
759 | Graph.dominatorTree (g, {root = labelNode start, | |
760 | nodeValue = #block o nodeInfo}) | |
761 | end | |
762 | ||
763 | fun dropProfile (f: t): t = | |
764 | let | |
765 | val {args, blocks, name, raises, returns, start} = dest f | |
766 | val blocks = | |
767 | Vector.map | |
768 | (blocks, fn Block.T {args, kind, label, statements, transfer} => | |
769 | Block.T {args = args, | |
770 | kind = kind, | |
771 | label = label, | |
772 | statements = Vector.keepAll | |
773 | (statements, | |
774 | fn Statement.Profile _ => false | |
775 | | Statement.ProfileLabel _ => false | |
776 | | _ => true), | |
777 | transfer = transfer}) | |
778 | in | |
779 | new {args = args, | |
780 | blocks = blocks, | |
781 | name = name, | |
782 | raises = raises, | |
783 | returns = returns, | |
784 | start = start} | |
785 | end | |
786 | ||
787 | fun shrink (f: t): t = | |
788 | let | |
789 | val {args, blocks, name, raises, returns, start} = dest f | |
790 | val {get = labelInfo, rem, set = setLabelInfo, ...} = | |
791 | Property.getSetOnce | |
792 | (Label.plist, Property.initRaise ("info", Label.layout)) | |
793 | val () = | |
794 | Vector.foreach | |
795 | (blocks, fn block as Block.T {label, ...} => | |
796 | setLabelInfo (label, {block = block, | |
797 | inline = ref false, | |
798 | occurrences = ref 0})) | |
799 | fun visitLabel l = Int.inc (#occurrences (labelInfo l)) | |
800 | val () = visitLabel start | |
801 | val () = | |
802 | Vector.foreach (blocks, fn Block.T {transfer, ...} => | |
803 | Transfer.foreachLabel (transfer, visitLabel)) | |
804 | datatype z = datatype Statement.t | |
805 | datatype z = datatype Transfer.t | |
806 | val () = | |
807 | Vector.foreach | |
808 | (blocks, fn Block.T {transfer, ...} => | |
809 | case transfer of | |
810 | Goto {dst, ...} => | |
811 | let | |
812 | val {inline, occurrences, ...} = labelInfo dst | |
813 | in | |
814 | if 1 = !occurrences | |
815 | then inline := true | |
816 | else () | |
817 | end | |
818 | | _ => ()) | |
819 | fun expand (ss: Statement.t vector list, t: Transfer.t) | |
820 | : Statement.t vector * Transfer.t = | |
821 | let | |
822 | fun done () = (Vector.concat (rev ss), t) | |
823 | in | |
824 | case t of | |
825 | Goto {args, dst} => | |
826 | let | |
827 | val {block, inline, ...} = labelInfo dst | |
828 | in | |
829 | if not (!inline) | |
830 | then done () | |
831 | else | |
832 | let | |
833 | val Block.T {args = formals, statements, | |
834 | transfer, ...} = | |
835 | block | |
836 | val binds = | |
837 | Vector.map2 | |
838 | (formals, args, fn (dst, src) => | |
839 | Bind {dst = dst, | |
840 | isMutable = false, | |
841 | src = src}) | |
842 | in | |
843 | expand (statements :: binds :: ss, transfer) | |
844 | end | |
845 | end | |
846 | | _ => done () | |
847 | end | |
848 | val blocks = | |
849 | Vector.fromList | |
850 | (Vector.fold | |
851 | (blocks, [], | |
852 | fn (Block.T {args, kind, label, statements, transfer}, ac) => | |
853 | let | |
854 | val {inline, ...} = labelInfo label | |
855 | in | |
856 | if !inline | |
857 | then ac | |
858 | else | |
859 | let | |
860 | val (statements, transfer) = | |
861 | expand ([statements], transfer) | |
862 | in | |
863 | Block.T {args = args, | |
864 | kind = kind, | |
865 | label = label, | |
866 | statements = statements, | |
867 | transfer = transfer} :: ac | |
868 | end | |
869 | end)) | |
870 | val () = Vector.foreach (blocks, rem o Block.label) | |
871 | in | |
872 | new {args = args, | |
873 | blocks = blocks, | |
874 | name = name, | |
875 | raises = raises, | |
876 | returns = returns, | |
877 | start = start} | |
878 | end | |
879 | end | |
880 | ||
881 | structure Program = | |
882 | struct | |
883 | datatype t = | |
884 | T of {functions: Function.t list, | |
885 | handlesSignals: bool, | |
886 | main: Function.t, | |
887 | objectTypes: ObjectType.t vector} | |
888 | ||
889 | fun clear (T {functions, main, ...}) = | |
890 | (List.foreach (functions, Function.clear) | |
891 | ; Function.clear main) | |
892 | ||
893 | fun layouts (T {functions, main, objectTypes, ...}, | |
894 | output': Layout.t -> unit): unit = | |
895 | let | |
896 | open Layout | |
897 | val output = output' | |
898 | in | |
899 | output (str "\nObjectTypes:") | |
900 | ; Vector.foreachi (objectTypes, fn (i, ty) => | |
901 | output (seq [str "opt_", Int.layout i, | |
902 | str " = ", ObjectType.layout ty])) | |
903 | ; output (str "\nMain:") | |
904 | ; Function.layouts (main, output) | |
905 | ; output (str "\nFunctions:") | |
906 | ; List.foreach (functions, fn f => Function.layouts (f, output)) | |
907 | end | |
908 | ||
909 | fun layoutStats (T {functions, main, objectTypes, ...}) = | |
910 | let | |
911 | val numStatements = ref 0 | |
912 | val numBlocks = ref 0 | |
913 | val _ = | |
914 | List.foreach | |
915 | (main::functions, fn f => | |
916 | let | |
917 | val {blocks, ...} = Function.dest f | |
918 | in | |
919 | Vector.foreach | |
920 | (blocks, fn Block.T {statements, ...} => | |
921 | (Int.inc numBlocks | |
922 | ; numStatements := !numStatements + Vector.length statements)) | |
923 | end) | |
924 | val numFunctions = 1 + List.length functions | |
925 | val numObjectTypes = Vector.length objectTypes | |
926 | open Layout | |
927 | in | |
928 | align | |
929 | [seq [str "num functions in program = ", Int.layout numFunctions], | |
930 | seq [str "num blocks in program = ", Int.layout (!numBlocks)], | |
931 | seq [str "num statements in program = ", Int.layout (!numStatements)], | |
932 | seq [str "num object types in program = ", Int.layout (numObjectTypes)]] | |
933 | end | |
934 | ||
935 | fun dropProfile (T {functions, handlesSignals, main, objectTypes}) = | |
936 | (Control.profile := Control.ProfileNone | |
937 | ; T {functions = List.map (functions, Function.dropProfile), | |
938 | handlesSignals = handlesSignals, | |
939 | main = Function.dropProfile main, | |
940 | objectTypes = objectTypes}) | |
941 | (* quell unused warning *) | |
942 | val _ = dropProfile | |
943 | ||
944 | fun dfs (p, v) = | |
945 | let | |
946 | val T {functions, main, ...} = p | |
947 | val functions = Vector.fromList (main::functions) | |
948 | val numFunctions = Vector.length functions | |
949 | val {get = funcIndex, set = setFuncIndex, rem, ...} = | |
950 | Property.getSetOnce (Func.plist, | |
951 | Property.initRaise ("index", Func.layout)) | |
952 | val _ = Vector.foreachi (functions, fn (i, f) => | |
953 | setFuncIndex (#name (Function.dest f), i)) | |
954 | val visited = Array.array (numFunctions, false) | |
955 | fun visit (f: Func.t): unit = | |
956 | let | |
957 | val i = funcIndex f | |
958 | in | |
959 | if Array.sub (visited, i) | |
960 | then () | |
961 | else | |
962 | let | |
963 | val _ = Array.update (visited, i, true) | |
964 | val f = Vector.sub (functions, i) | |
965 | val v' = v f | |
966 | val _ = Function.dfs | |
967 | (f, fn Block.T {transfer, ...} => | |
968 | (Transfer.foreachFunc (transfer, visit) | |
969 | ; fn () => ())) | |
970 | val _ = v' () | |
971 | in | |
972 | () | |
973 | end | |
974 | end | |
975 | val _ = visit (Function.name main) | |
976 | val _ = Vector.foreach (functions, rem o Function.name) | |
977 | in | |
978 | () | |
979 | end | |
980 | ||
981 | fun orderFunctions (p as T {handlesSignals, objectTypes, ...}) = | |
982 | let | |
983 | val functions = ref [] | |
984 | val () = | |
985 | dfs | |
986 | (p, fn f => | |
987 | let | |
988 | val {args, name, raises, returns, start, ...} = | |
989 | Function.dest f | |
990 | val blocks = ref [] | |
991 | val () = | |
992 | Function.dfs | |
993 | (f, fn b => | |
994 | (List.push (blocks, b) | |
995 | ; fn () => ())) | |
996 | val f = Function.new {args = args, | |
997 | blocks = Vector.fromListRev (!blocks), | |
998 | name = name, | |
999 | raises = raises, | |
1000 | returns = returns, | |
1001 | start = start} | |
1002 | in | |
1003 | List.push (functions, f) | |
1004 | ; fn () => () | |
1005 | end) | |
1006 | val (main, functions) = | |
1007 | case List.rev (!functions) of | |
1008 | main::functions => (main, functions) | |
1009 | | _ => Error.bug "Rssa.orderFunctions: main/functions" | |
1010 | in | |
1011 | T {functions = functions, | |
1012 | handlesSignals = handlesSignals, | |
1013 | main = main, | |
1014 | objectTypes = objectTypes} | |
1015 | end | |
1016 | ||
1017 | fun copyProp (T {functions, handlesSignals, main, objectTypes, ...}): t = | |
1018 | let | |
1019 | val tracePrimApply = | |
1020 | Trace.trace3 | |
1021 | ("Rssa.copyProp.primApply", | |
1022 | Prim.layout, | |
1023 | List.layout (ApplyArg.layout (Var.layout o #var)), | |
1024 | Layout.ignore, | |
1025 | ApplyResult.layout (Var.layout o #var)) | |
1026 | val {get = replaceVar: Var.t -> Operand.t, | |
1027 | set = setReplaceVar, ...} = | |
1028 | Property.getSetOnce | |
1029 | (Var.plist, Property.initRaise ("replacement", Var.layout)) | |
1030 | fun dontReplace (x: Var.t, t: Type.t): unit = | |
1031 | setReplaceVar (x, Operand.Var {var = x, ty = t}) | |
1032 | val setReplaceVar = fn (x: Var.t, t: Type.t, z: Operand.t) => | |
1033 | let | |
1034 | val z = | |
1035 | if Type.equals (Operand.ty z, t) | |
1036 | then z | |
1037 | else Operand.Cast (z, t) | |
1038 | in | |
1039 | setReplaceVar (x, z) | |
1040 | end | |
1041 | fun loopStatement (s: Statement.t): Statement.t option = | |
1042 | let | |
1043 | val s = Statement.replaceUses (s, replaceVar) | |
1044 | fun keep () = | |
1045 | (Statement.foreachDef (s, dontReplace) | |
1046 | ; SOME s) | |
1047 | in | |
1048 | case s of | |
1049 | Bind {dst = (dst, dstTy), isMutable, src} => | |
1050 | if isMutable | |
1051 | then keep () | |
1052 | else | |
1053 | let | |
1054 | datatype z = datatype Operand.t | |
1055 | fun getSrc src = | |
1056 | case src of | |
1057 | Cast (src, _) => getSrc src | |
1058 | | Const _ => SOME src | |
1059 | | Var _ => SOME src | |
1060 | | _ => NONE | |
1061 | in | |
1062 | case getSrc src of | |
1063 | NONE => keep () | |
1064 | | SOME src => | |
1065 | (setReplaceVar (dst, dstTy, src) | |
1066 | ; NONE) | |
1067 | end | |
1068 | | PrimApp {args, dst, prim} => | |
1069 | let | |
1070 | fun replace (z: Operand.t): Statement.t option = | |
1071 | (Option.app (dst, fn (x, t) => | |
1072 | setReplaceVar (x, t, z)) | |
1073 | ; NONE) | |
1074 | datatype z = datatype Operand.t | |
1075 | fun getArg arg = | |
1076 | case arg of | |
1077 | Cast (arg, _) => getArg arg | |
1078 | | Const c => SOME (ApplyArg.Const c) | |
1079 | | Var x => SOME (ApplyArg.Var x) | |
1080 | | _ => NONE | |
1081 | val applyArgs = Vector.keepAllMap (args, getArg) | |
1082 | datatype z = datatype ApplyResult.t | |
1083 | in | |
1084 | if Vector.length args <> Vector.length applyArgs | |
1085 | then keep () | |
1086 | else | |
1087 | case (tracePrimApply | |
1088 | Prim.apply | |
1089 | (prim, Vector.toList applyArgs, | |
1090 | fn ({var = x, ...}, {var = y, ...}) => | |
1091 | Var.equals (x, y))) of | |
1092 | Apply (prim, args) => | |
1093 | let | |
1094 | val args = | |
1095 | Vector.fromListMap (args, Operand.Var) | |
1096 | val () = Option.app (dst, dontReplace) | |
1097 | in | |
1098 | SOME (PrimApp {args = args, | |
1099 | dst = dst, | |
1100 | prim = prim}) | |
1101 | end | |
1102 | | Bool b => replace (Operand.bool b) | |
1103 | | Const c => replace (Operand.Const c) | |
1104 | | Overflow => keep () | |
1105 | | Unknown => keep () | |
1106 | | Var x => replace (Operand.Var x) | |
1107 | end | |
1108 | | _ => keep () | |
1109 | end | |
1110 | fun loopTransfer t = | |
1111 | (Transfer.foreachDef (t, dontReplace) | |
1112 | ; Transfer.replaceUses (t, replaceVar)) | |
1113 | fun loopFormals args = Vector.foreach (args, dontReplace) | |
1114 | fun loopFunction (f: Function.t): Function.t = | |
1115 | let | |
1116 | val {args, name, raises, returns, start, ...} = | |
1117 | Function.dest f | |
1118 | val () = loopFormals args | |
1119 | val blocks = ref [] | |
1120 | val () = | |
1121 | Function.dfs | |
1122 | (f, fn Block.T {args, kind, label, statements, transfer} => | |
1123 | let | |
1124 | val () = loopFormals args | |
1125 | val statements = | |
1126 | Vector.keepAllMap (statements, loopStatement) | |
1127 | val transfer = loopTransfer transfer | |
1128 | val () = | |
1129 | List.push | |
1130 | (blocks, Block.T {args = args, | |
1131 | kind = kind, | |
1132 | label = label, | |
1133 | statements = statements, | |
1134 | transfer = transfer}) | |
1135 | in | |
1136 | fn () => () | |
1137 | end) | |
1138 | val blocks = Vector.fromList (!blocks) | |
1139 | in | |
1140 | Function.new {args = args, | |
1141 | blocks = blocks, | |
1142 | name = name, | |
1143 | raises = raises, | |
1144 | returns = returns, | |
1145 | start = start} | |
1146 | end | |
1147 | (* Must process main first, because it defines globals that are | |
1148 | * used in other functions. | |
1149 | *) | |
1150 | val main = loopFunction main | |
1151 | val functions = List.revMap (functions, loopFunction) | |
1152 | in | |
1153 | T {functions = functions, | |
1154 | handlesSignals = handlesSignals, | |
1155 | main = main, | |
1156 | objectTypes = objectTypes} | |
1157 | end | |
1158 | ||
1159 | fun shrink (T {functions, handlesSignals, main, objectTypes}) = | |
1160 | let | |
1161 | val p = | |
1162 | T {functions = List.revMap (functions, Function.shrink), | |
1163 | handlesSignals = handlesSignals, | |
1164 | main = Function.shrink main, | |
1165 | objectTypes = objectTypes} | |
1166 | val p = copyProp p | |
1167 | val () = clear p | |
1168 | in | |
1169 | p | |
1170 | end | |
1171 | ||
1172 | structure ExnStack = | |
1173 | struct | |
1174 | structure ZPoint = | |
1175 | struct | |
1176 | datatype t = Caller | Me | |
1177 | ||
1178 | val equals: t * t -> bool = op = | |
1179 | ||
1180 | val toString = | |
1181 | fn Caller => "Caller" | |
1182 | | Me => "Me" | |
1183 | ||
1184 | val layout = Layout.str o toString | |
1185 | end | |
1186 | ||
1187 | structure L = FlatLattice (structure Point = ZPoint) | |
1188 | open L | |
1189 | structure Point = ZPoint | |
1190 | ||
1191 | val me = point Point.Me | |
1192 | end | |
1193 | ||
1194 | structure HandlerLat = FlatLattice (structure Point = Label) | |
1195 | ||
1196 | structure HandlerInfo = | |
1197 | struct | |
1198 | datatype t = T of {block: Block.t, | |
1199 | global: ExnStack.t, | |
1200 | handler: HandlerLat.t, | |
1201 | slot: ExnStack.t, | |
1202 | visited: bool ref} | |
1203 | ||
1204 | fun new (b: Block.t): t = | |
1205 | T {block = b, | |
1206 | global = ExnStack.new (), | |
1207 | handler = HandlerLat.new (), | |
1208 | slot = ExnStack.new (), | |
1209 | visited = ref false} | |
1210 | ||
1211 | fun layout (T {global, handler, slot, ...}) = | |
1212 | Layout.record [("global", ExnStack.layout global), | |
1213 | ("slot", ExnStack.layout slot), | |
1214 | ("handler", HandlerLat.layout handler)] | |
1215 | end | |
1216 | ||
1217 | val traceGoto = | |
1218 | Trace.trace ("Rssa.checkHandlers.goto", Label.layout, Unit.layout) | |
1219 | ||
1220 | fun checkHandlers (T {functions, ...}) = | |
1221 | let | |
1222 | val debug = false | |
1223 | fun checkFunction (f: Function.t): unit = | |
1224 | let | |
1225 | val {name, start, blocks, ...} = Function.dest f | |
1226 | val {get = labelInfo: Label.t -> HandlerInfo.t, | |
1227 | rem = remLabelInfo, | |
1228 | set = setLabelInfo} = | |
1229 | Property.getSetOnce | |
1230 | (Label.plist, Property.initRaise ("info", Label.layout)) | |
1231 | val _ = | |
1232 | Vector.foreach | |
1233 | (blocks, fn b => | |
1234 | setLabelInfo (Block.label b, HandlerInfo.new b)) | |
1235 | (* Do a DFS of the control-flow graph. *) | |
1236 | fun visitLabel l = visitInfo (labelInfo l) | |
1237 | and visitInfo | |
1238 | (hi as HandlerInfo.T {block, global, handler, slot, | |
1239 | visited, ...}): unit = | |
1240 | if !visited | |
1241 | then () | |
1242 | else | |
1243 | let | |
1244 | val _ = visited := true | |
1245 | val Block.T {label, statements, transfer, ...} = block | |
1246 | val _ = | |
1247 | if debug | |
1248 | then | |
1249 | let | |
1250 | open Layout | |
1251 | in | |
1252 | outputl | |
1253 | (seq [str "visiting ", | |
1254 | Label.layout label], | |
1255 | Out.error) | |
1256 | end | |
1257 | else () | |
1258 | datatype z = datatype Statement.t | |
1259 | val {global, handler, slot} = | |
1260 | Vector.fold | |
1261 | (statements, | |
1262 | {global = global, handler = handler, slot = slot}, | |
1263 | fn (s, {global, handler, slot}) => | |
1264 | case s of | |
1265 | SetExnStackLocal => {global = ExnStack.me, | |
1266 | handler = handler, | |
1267 | slot = slot} | |
1268 | | SetExnStackSlot => {global = slot, | |
1269 | handler = handler, | |
1270 | slot = slot} | |
1271 | | SetSlotExnStack => {global = global, | |
1272 | handler = handler, | |
1273 | slot = global} | |
1274 | | SetHandler l => {global = global, | |
1275 | handler = HandlerLat.point l, | |
1276 | slot = slot} | |
1277 | | _ => {global = global, | |
1278 | handler = handler, | |
1279 | slot = slot}) | |
1280 | fun fail msg = | |
1281 | (Control.message | |
1282 | (Control.Silent, fn () => | |
1283 | let open Layout | |
1284 | in align | |
1285 | [str "before: ", HandlerInfo.layout hi, | |
1286 | str "block: ", Block.layout block, | |
1287 | seq [str "after: ", | |
1288 | Layout.record | |
1289 | [("global", ExnStack.layout global), | |
1290 | ("slot", ExnStack.layout slot), | |
1291 | ("handler", | |
1292 | HandlerLat.layout handler)]], | |
1293 | Vector.layout | |
1294 | (fn Block.T {label, ...} => | |
1295 | seq [Label.layout label, | |
1296 | str " ", | |
1297 | HandlerInfo.layout (labelInfo label)]) | |
1298 | blocks] | |
1299 | end) | |
1300 | ; Error.bug (concat ["Rssa.checkHandlers: handler mismatch at ", msg])) | |
1301 | fun assert (msg, f) = | |
1302 | if f | |
1303 | then () | |
1304 | else fail msg | |
1305 | fun goto (l: Label.t): unit = | |
1306 | let | |
1307 | val HandlerInfo.T {global = g, handler = h, | |
1308 | slot = s, ...} = | |
1309 | labelInfo l | |
1310 | val _ = | |
1311 | assert ("goto", | |
1312 | ExnStack.<= (global, g) | |
1313 | andalso ExnStack.<= (slot, s) | |
1314 | andalso HandlerLat.<= (handler, h)) | |
1315 | in | |
1316 | visitLabel l | |
1317 | end | |
1318 | val goto = traceGoto goto | |
1319 | fun tail name = | |
1320 | assert (name, | |
1321 | ExnStack.forcePoint | |
1322 | (global, ExnStack.Point.Caller)) | |
1323 | datatype z = datatype Transfer.t | |
1324 | in | |
1325 | case transfer of | |
1326 | Arith {overflow, success, ...} => | |
1327 | (goto overflow; goto success) | |
1328 | | CCall {return, ...} => Option.app (return, goto) | |
1329 | | Call {return, ...} => | |
1330 | assert | |
1331 | ("return", | |
1332 | let | |
1333 | datatype z = datatype Return.t | |
1334 | in | |
1335 | case return of | |
1336 | Dead => true | |
1337 | | NonTail {handler = h, ...} => | |
1338 | (case h of | |
1339 | Handler.Caller => | |
1340 | ExnStack.forcePoint | |
1341 | (global, ExnStack.Point.Caller) | |
1342 | | Handler.Dead => true | |
1343 | | Handler.Handle l => | |
1344 | let | |
1345 | val res = | |
1346 | ExnStack.forcePoint | |
1347 | (global, | |
1348 | ExnStack.Point.Me) | |
1349 | andalso | |
1350 | HandlerLat.forcePoint | |
1351 | (handler, l) | |
1352 | val _ = goto l | |
1353 | in | |
1354 | res | |
1355 | end) | |
1356 | | Tail => true | |
1357 | end) | |
1358 | | Goto {dst, ...} => goto dst | |
1359 | | Raise _ => tail "raise" | |
1360 | | Return _ => tail "return" | |
1361 | | Switch s => Switch.foreachLabel (s, goto) | |
1362 | end | |
1363 | val info as HandlerInfo.T {global, ...} = labelInfo start | |
1364 | val _ = ExnStack.forcePoint (global, ExnStack.Point.Caller) | |
1365 | val _ = visitInfo info | |
1366 | val _ = | |
1367 | Control.diagnostics | |
1368 | (fn display => | |
1369 | let | |
1370 | open Layout | |
1371 | val _ = | |
1372 | display (seq [str "checkHandlers ", | |
1373 | Func.layout name]) | |
1374 | val _ = | |
1375 | Vector.foreach | |
1376 | (blocks, fn Block.T {label, ...} => | |
1377 | display (seq | |
1378 | [Label.layout label, | |
1379 | str " ", | |
1380 | HandlerInfo.layout (labelInfo label)])) | |
1381 | in | |
1382 | () | |
1383 | end) | |
1384 | val _ = Vector.foreach (blocks, fn b => | |
1385 | remLabelInfo (Block.label b)) | |
1386 | in | |
1387 | () | |
1388 | end | |
1389 | val _ = List.foreach (functions, checkFunction) | |
1390 | in | |
1391 | () | |
1392 | end | |
1393 | ||
1394 | fun checkScopes (program as T {functions, main, ...}): unit = | |
1395 | let | |
1396 | datatype status = | |
1397 | Defined | |
1398 | | Global | |
1399 | | InScope | |
1400 | | Undefined | |
1401 | fun make (layout, plist) = | |
1402 | let | |
1403 | val {get, set, ...} = | |
1404 | Property.getSet (plist, Property.initConst Undefined) | |
1405 | fun bind (x, isGlobal) = | |
1406 | case get x of | |
1407 | Global => () | |
1408 | | Undefined => | |
1409 | set (x, if isGlobal then Global else InScope) | |
1410 | | _ => Error.bug ("Rssa.checkScopes: duplicate definition of " | |
1411 | ^ (Layout.toString (layout x))) | |
1412 | fun reference x = | |
1413 | case get x of | |
1414 | Global => () | |
1415 | | InScope => () | |
1416 | | _ => Error.bug (concat | |
1417 | ["Rssa.checkScopes: reference to ", | |
1418 | Layout.toString (layout x), | |
1419 | " not in scope"]) | |
1420 | fun unbind x = | |
1421 | case get x of | |
1422 | Global => () | |
1423 | | _ => set (x, Defined) | |
1424 | in (bind, reference, unbind) | |
1425 | end | |
1426 | val (bindVar, getVar, unbindVar) = make (Var.layout, Var.plist) | |
1427 | val bindVar = | |
1428 | Trace.trace2 | |
1429 | ("Rssa.bindVar", Var.layout, Bool.layout, Unit.layout) | |
1430 | bindVar | |
1431 | val getVar = | |
1432 | Trace.trace ("Rssa.getVar", Var.layout, Unit.layout) getVar | |
1433 | val unbindVar = | |
1434 | Trace.trace ("Rssa.unbindVar", Var.layout, Unit.layout) unbindVar | |
1435 | val (bindFunc, _, _) = make (Func.layout, Func.plist) | |
1436 | val bindFunc = fn f => bindFunc (f, false) | |
1437 | val (bindLabel, getLabel, unbindLabel) = | |
1438 | make (Label.layout, Label.plist) | |
1439 | val bindLabel = fn l => bindLabel (l, false) | |
1440 | fun loopFunc (f: Function.t, isMain: bool): unit = | |
1441 | let | |
1442 | val bindVar = fn x => bindVar (x, isMain) | |
1443 | val {args, blocks, ...} = Function.dest f | |
1444 | val _ = Vector.foreach (args, bindVar o #1) | |
1445 | val _ = Vector.foreach (blocks, bindLabel o Block.label) | |
1446 | val _ = | |
1447 | Vector.foreach | |
1448 | (blocks, fn Block.T {transfer, ...} => | |
1449 | Transfer.foreachLabel (transfer, getLabel)) | |
1450 | (* Descend the dominator tree, verifying that variable | |
1451 | * definitions dominate variable uses. | |
1452 | *) | |
1453 | val _ = | |
1454 | Tree.traverse | |
1455 | (Function.dominatorTree f, | |
1456 | fn Block.T {args, statements, transfer, ...} => | |
1457 | let | |
1458 | val _ = Vector.foreach (args, bindVar o #1) | |
1459 | val _ = | |
1460 | Vector.foreach | |
1461 | (statements, fn s => | |
1462 | (Statement.foreachUse (s, getVar) | |
1463 | ; Statement.foreachDef (s, bindVar o #1))) | |
1464 | val _ = Transfer.foreachUse (transfer, getVar) | |
1465 | val _ = Transfer.foreachDef (transfer, bindVar o #1) | |
1466 | in | |
1467 | fn () => | |
1468 | if isMain | |
1469 | then () | |
1470 | else | |
1471 | let | |
1472 | val _ = | |
1473 | Vector.foreach | |
1474 | (statements, fn s => | |
1475 | Statement.foreachDef (s, unbindVar o #1)) | |
1476 | val _ = | |
1477 | Transfer.foreachDef (transfer, unbindVar o #1) | |
1478 | val _ = Vector.foreach (args, unbindVar o #1) | |
1479 | in | |
1480 | () | |
1481 | end | |
1482 | end) | |
1483 | val _ = Vector.foreach (blocks, unbindLabel o Block.label) | |
1484 | val _ = Vector.foreach (args, unbindVar o #1) | |
1485 | in | |
1486 | () | |
1487 | end | |
1488 | val _ = List.foreach (functions, bindFunc o Function.name) | |
1489 | val _ = loopFunc (main, true) | |
1490 | val _ = List.foreach (functions, fn f => loopFunc (f, false)) | |
1491 | val _ = clear program | |
1492 | in () | |
1493 | end | |
1494 | ||
1495 | fun typeCheck (p as T {functions, main, objectTypes, ...}) = | |
1496 | let | |
1497 | val _ = | |
1498 | Vector.foreach | |
1499 | (objectTypes, fn ty => | |
1500 | Err.check ("objectType", | |
1501 | fn () => ObjectType.isOk ty, | |
1502 | fn () => ObjectType.layout ty)) | |
1503 | fun tyconTy (opt: ObjptrTycon.t): ObjectType.t = | |
1504 | Vector.sub (objectTypes, ObjptrTycon.index opt) | |
1505 | val () = checkScopes p | |
1506 | val {get = labelBlock: Label.t -> Block.t, | |
1507 | set = setLabelBlock, ...} = | |
1508 | Property.getSetOnce (Label.plist, | |
1509 | Property.initRaise ("block", Label.layout)) | |
1510 | val {get = funcInfo, set = setFuncInfo, ...} = | |
1511 | Property.getSetOnce (Func.plist, | |
1512 | Property.initRaise ("info", Func.layout)) | |
1513 | val {get = varType: Var.t -> Type.t, set = setVarType, ...} = | |
1514 | Property.getSetOnce (Var.plist, | |
1515 | Property.initRaise ("type", Var.layout)) | |
1516 | val setVarType = | |
1517 | Trace.trace2 ("Rssa.setVarType", Var.layout, Type.layout, | |
1518 | Unit.layout) | |
1519 | setVarType | |
1520 | fun checkOperand (x: Operand.t): unit = | |
1521 | let | |
1522 | datatype z = datatype Operand.t | |
1523 | fun ok () = | |
1524 | case x of | |
1525 | ArrayOffset {base, index, offset, scale, ty} => | |
1526 | (checkOperand base | |
1527 | ; checkOperand index | |
1528 | ; Type.arrayOffsetIsOk {base = Operand.ty base, | |
1529 | index = Operand.ty index, | |
1530 | offset = offset, | |
1531 | tyconTy = tyconTy, | |
1532 | result = ty, | |
1533 | scale = scale}) | |
1534 | | Cast (z, ty) => | |
1535 | (checkOperand z | |
1536 | ; Type.castIsOk {from = Operand.ty z, | |
1537 | to = ty, | |
1538 | tyconTy = tyconTy}) | |
1539 | | Const _ => true | |
1540 | | EnsuresBytesFree => true | |
1541 | | GCState => true | |
1542 | | Offset {base, offset, ty} => | |
1543 | Type.offsetIsOk {base = Operand.ty base, | |
1544 | offset = offset, | |
1545 | tyconTy = tyconTy, | |
1546 | result = ty} | |
1547 | | ObjptrTycon _ => true | |
1548 | | Runtime _ => true | |
1549 | | Var {ty, var} => Type.isSubtype (varType var, ty) | |
1550 | in | |
1551 | Err.check ("operand", ok, fn () => Operand.layout x) | |
1552 | end | |
1553 | val checkOperand = | |
1554 | Trace.trace ("Rssa.checkOperand", Operand.layout, Unit.layout) | |
1555 | checkOperand | |
1556 | fun checkOperands v = Vector.foreach (v, checkOperand) | |
1557 | fun check' (x, name, isOk, layout) = | |
1558 | Err.check (name, fn () => isOk x, fn () => layout x) | |
1559 | val labelKind = Block.kind o labelBlock | |
1560 | fun statementOk (s: Statement.t): bool = | |
1561 | let | |
1562 | datatype z = datatype Statement.t | |
1563 | in | |
1564 | case s of | |
1565 | Bind {src, dst = (_, dstTy), ...} => | |
1566 | (checkOperand src | |
1567 | ; Type.isSubtype (Operand.ty src, dstTy)) | |
1568 | | Move {dst, src} => | |
1569 | (checkOperand dst | |
1570 | ; checkOperand src | |
1571 | ; (Type.isSubtype (Operand.ty src, Operand.ty dst) | |
1572 | andalso Operand.isLocation dst)) | |
1573 | | Object {dst = (_, ty), header, size} => | |
1574 | let | |
1575 | val tycon = | |
1576 | ObjptrTycon.fromIndex | |
1577 | (Runtime.headerToTypeIndex header) | |
1578 | in | |
1579 | Type.isSubtype (Type.objptr tycon, ty) | |
1580 | andalso | |
1581 | Bytes.equals | |
1582 | (size, | |
1583 | Bytes.align | |
1584 | (size, | |
1585 | {alignment = (case !Control.align of | |
1586 | Control.Align4 => Bytes.inWord32 | |
1587 | | Control.Align8 => Bytes.inWord64)})) | |
1588 | andalso | |
1589 | (case tyconTy tycon of | |
1590 | ObjectType.Normal {ty, ...} => | |
1591 | Bytes.equals | |
1592 | (size, Bytes.+ (Runtime.normalMetaDataSize (), | |
1593 | Type.bytes ty)) | |
1594 | | _ => false) | |
1595 | end | |
1596 | | PrimApp {args, dst, prim} => | |
1597 | (Vector.foreach (args, checkOperand) | |
1598 | ; (Type.checkPrimApp | |
1599 | {args = Vector.map (args, Operand.ty), | |
1600 | prim = prim, | |
1601 | result = Option.map (dst, #2)})) | |
1602 | | Profile _ => true | |
1603 | | ProfileLabel _ => true | |
1604 | | SetExnStackLocal => true | |
1605 | | SetExnStackSlot => true | |
1606 | | SetHandler l => | |
1607 | (case labelKind l of | |
1608 | Kind.Handler => true | |
1609 | | _ => false) | |
1610 | | SetSlotExnStack => true | |
1611 | end | |
1612 | val statementOk = | |
1613 | Trace.trace ("Rssa.statementOk", | |
1614 | Statement.layout, | |
1615 | Bool.layout) | |
1616 | statementOk | |
1617 | fun gotoOk {args: Type.t vector, | |
1618 | dst: Label.t}: bool = | |
1619 | let | |
1620 | val Block.T {args = formals, kind, ...} = labelBlock dst | |
1621 | in | |
1622 | Vector.equals (args, formals, fn (t, (_, t')) => | |
1623 | Type.isSubtype (t, t')) | |
1624 | andalso (case kind of | |
1625 | Kind.Jump => true | |
1626 | | _ => false) | |
1627 | end | |
1628 | fun labelIsNullaryJump l = gotoOk {dst = l, args = Vector.new0 ()} | |
1629 | fun tailIsOk (caller: Type.t vector option, | |
1630 | callee: Type.t vector option): bool = | |
1631 | case (caller, callee) of | |
1632 | (_, NONE) => true | |
1633 | | (SOME caller, SOME callee) => | |
1634 | Vector.equals (callee, caller, Type.isSubtype) | |
1635 | | _ => false | |
1636 | fun nonTailIsOk (formals: (Var.t * Type.t) vector, | |
1637 | returns: Type.t vector option): bool = | |
1638 | case returns of | |
1639 | NONE => true | |
1640 | | SOME ts => | |
1641 | Vector.equals (formals, ts, fn ((_, t), t') => | |
1642 | Type.isSubtype (t', t)) | |
1643 | fun callIsOk {args, func, raises, return, returns} = | |
1644 | let | |
1645 | val Function.T {args = formals, | |
1646 | raises = raises', | |
1647 | returns = returns', ...} = | |
1648 | funcInfo func | |
1649 | ||
1650 | in | |
1651 | Vector.equals (args, formals, fn (z, (_, t)) => | |
1652 | Type.isSubtype (Operand.ty z, t)) | |
1653 | andalso | |
1654 | (case return of | |
1655 | Return.Dead => | |
1656 | Option.isNone raises' | |
1657 | andalso Option.isNone returns' | |
1658 | | Return.NonTail {cont, handler} => | |
1659 | let | |
1660 | val Block.T {args = cArgs, kind = cKind, ...} = | |
1661 | labelBlock cont | |
1662 | in | |
1663 | nonTailIsOk (cArgs, returns') | |
1664 | andalso | |
1665 | (case cKind of | |
1666 | Kind.Cont {handler = h} => | |
1667 | Handler.equals (handler, h) | |
1668 | andalso | |
1669 | (case h of | |
1670 | Handler.Caller => | |
1671 | tailIsOk (raises, raises') | |
1672 | | Handler.Dead => true | |
1673 | | Handler.Handle l => | |
1674 | let | |
1675 | val Block.T {args = hArgs, | |
1676 | kind = hKind, ...} = | |
1677 | labelBlock l | |
1678 | in | |
1679 | nonTailIsOk (hArgs, raises') | |
1680 | andalso | |
1681 | (case hKind of | |
1682 | Kind.Handler => true | |
1683 | | _ => false) | |
1684 | end) | |
1685 | | _ => false) | |
1686 | end | |
1687 | | Return.Tail => | |
1688 | tailIsOk (raises, raises') | |
1689 | andalso tailIsOk (returns, returns')) | |
1690 | end | |
1691 | ||
1692 | fun checkFunction (Function.T {args, blocks, raises, returns, start, | |
1693 | ...}) = | |
1694 | let | |
1695 | val _ = Vector.foreach (args, setVarType) | |
1696 | val _ = | |
1697 | Vector.foreach | |
1698 | (blocks, fn b as Block.T {args, label, statements, | |
1699 | transfer, ...} => | |
1700 | (setLabelBlock (label, b) | |
1701 | ; Vector.foreach (args, setVarType) | |
1702 | ; Vector.foreach (statements, fn s => | |
1703 | Statement.foreachDef | |
1704 | (s, setVarType)) | |
1705 | ; Transfer.foreachDef (transfer, setVarType))) | |
1706 | val _ = labelIsNullaryJump start | |
1707 | fun transferOk (t: Transfer.t): bool = | |
1708 | let | |
1709 | datatype z = datatype Transfer.t | |
1710 | in | |
1711 | case t of | |
1712 | Arith {args, overflow, prim, success, ty, ...} => | |
1713 | let | |
1714 | val _ = checkOperands args | |
1715 | in | |
1716 | Prim.mayOverflow prim | |
1717 | andalso labelIsNullaryJump overflow | |
1718 | andalso labelIsNullaryJump success | |
1719 | andalso | |
1720 | Type.checkPrimApp | |
1721 | {args = Vector.map (args, Operand.ty), | |
1722 | prim = prim, | |
1723 | result = SOME ty} | |
1724 | end | |
1725 | | CCall {args, func, return} => | |
1726 | let | |
1727 | val _ = checkOperands args | |
1728 | in | |
1729 | CFunction.isOk (func, {isUnit = Type.isUnit}) | |
1730 | andalso | |
1731 | Vector.equals (args, CFunction.args func, | |
1732 | fn (z, t) => | |
1733 | Type.isSubtype | |
1734 | (Operand.ty z, t)) | |
1735 | andalso | |
1736 | case return of | |
1737 | NONE => true | |
1738 | | SOME l => | |
1739 | case labelKind l of | |
1740 | Kind.CReturn {func = f} => | |
1741 | CFunction.equals (func, f) | |
1742 | | _ => false | |
1743 | end | |
1744 | | Call {args, func, return} => | |
1745 | let | |
1746 | val _ = checkOperands args | |
1747 | in | |
1748 | callIsOk {args = args, | |
1749 | func = func, | |
1750 | raises = raises, | |
1751 | return = return, | |
1752 | returns = returns} | |
1753 | end | |
1754 | | Goto {args, dst} => | |
1755 | (checkOperands args | |
1756 | ; gotoOk {args = Vector.map (args, Operand.ty), | |
1757 | dst = dst}) | |
1758 | | Raise zs => | |
1759 | (checkOperands zs | |
1760 | ; (case raises of | |
1761 | NONE => false | |
1762 | | SOME ts => | |
1763 | Vector.equals | |
1764 | (zs, ts, fn (z, t) => | |
1765 | Type.isSubtype (Operand.ty z, t)))) | |
1766 | | Return zs => | |
1767 | (checkOperands zs | |
1768 | ; (case returns of | |
1769 | NONE => false | |
1770 | | SOME ts => | |
1771 | Vector.equals | |
1772 | (zs, ts, fn (z, t) => | |
1773 | Type.isSubtype (Operand.ty z, t)))) | |
1774 | | Switch s => | |
1775 | Switch.isOk (s, {checkUse = checkOperand, | |
1776 | labelIsOk = labelIsNullaryJump}) | |
1777 | end | |
1778 | val transferOk = | |
1779 | Trace.trace ("Rssa.transferOk", | |
1780 | Transfer.layout, | |
1781 | Bool.layout) | |
1782 | transferOk | |
1783 | fun blockOk (Block.T {args, kind, statements, transfer, ...}) | |
1784 | : bool = | |
1785 | let | |
1786 | fun kindOk (k: Kind.t): bool = | |
1787 | let | |
1788 | datatype z = datatype Kind.t | |
1789 | in | |
1790 | case k of | |
1791 | Cont _ => true | |
1792 | | CReturn {func} => | |
1793 | let | |
1794 | val return = CFunction.return func | |
1795 | in | |
1796 | 0 = Vector.length args | |
1797 | orelse | |
1798 | (1 = Vector.length args | |
1799 | andalso | |
1800 | let | |
1801 | val expects = | |
1802 | #2 (Vector.first args) | |
1803 | in | |
1804 | Type.isSubtype (return, expects) | |
1805 | andalso | |
1806 | CType.equals (Type.toCType return, | |
1807 | Type.toCType expects) | |
1808 | end) | |
1809 | end | |
1810 | | Handler => true | |
1811 | | Jump => true | |
1812 | end | |
1813 | val _ = check' (kind, "kind", kindOk, Kind.layout) | |
1814 | val _ = | |
1815 | Vector.foreach | |
1816 | (statements, fn s => | |
1817 | check' (s, "statement", statementOk, | |
1818 | Statement.layout)) | |
1819 | val _ = check' (transfer, "transfer", transferOk, | |
1820 | Transfer.layout) | |
1821 | in | |
1822 | true | |
1823 | end | |
1824 | val blockOk = | |
1825 | Trace.trace ("Rssa.blockOk", | |
1826 | Block.layout, | |
1827 | Bool.layout) | |
1828 | blockOk | |
1829 | ||
1830 | val _ = | |
1831 | Vector.foreach | |
1832 | (blocks, fn b => | |
1833 | check' (b, "block", blockOk, Block.layout)) | |
1834 | in | |
1835 | () | |
1836 | end | |
1837 | val _ = | |
1838 | List.foreach | |
1839 | (functions, fn f as Function.T {name, ...} => | |
1840 | setFuncInfo (name, f)) | |
1841 | val _ = checkFunction main | |
1842 | val _ = List.foreach (functions, checkFunction) | |
1843 | val _ = | |
1844 | check' | |
1845 | (main, "main function", | |
1846 | fn f => | |
1847 | let | |
1848 | val {args, ...} = Function.dest f | |
1849 | in | |
1850 | Vector.isEmpty args | |
1851 | end, | |
1852 | Function.layout) | |
1853 | val _ = clear p | |
1854 | in | |
1855 | () | |
1856 | end handle Err.E e => (Layout.outputl (Err.layout e, Out.error) | |
1857 | ; Error.bug "Rssa.typeCheck") | |
1858 | end | |
1859 | ||
1860 | end |