Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* From the SML/NJ benchmark suite. *) |
2 | ||
3 | fun print _ = () | |
4 | ||
5 | signature BMARK = | |
6 | sig | |
7 | val doit : int -> unit | |
8 | val testit : TextIO.outstream -> unit | |
9 | end; | |
10 | ||
11 | open Array (* List *) | |
12 | infix 9 sub | |
13 | ||
14 | fun fold f x y = List.foldr f y x | |
15 | fun revfold f x y = List.foldl f y x | |
16 | val makestring = Int.toString | |
17 | ||
18 | local | |
19 | open Real | |
20 | in | |
21 | val realEq = == | |
22 | val realNe = != | |
23 | end | |
24 | ||
25 | exception NotAChar | |
26 | fun fromStr x = | |
27 | (case Char.fromString x | |
28 | of SOME c => c | |
29 | | NONE => raise NotAChar) | |
30 | ||
31 | fun ordof(s, i) = Char.ord(String.sub(s, i)) | |
32 | ||
33 | ||
34 | val explode = (fn x => map Char.toString (explode x)) | |
35 | val implode = (fn x => implode (map fromStr x)) | |
36 | fun ord s = Char.ord (fromStr s) | |
37 | ||
38 | val output = TextIO.output | |
39 | val std_out = TextIO.stdOut | |
40 | val open_in = TextIO.openIn | |
41 | val open_out = TextIO.openOut | |
42 | val close_in = TextIO.closeIn | |
43 | val close_out = TextIO.closeOut | |
44 | val input_line = | |
45 | fn ins => | |
46 | case TextIO.inputLine ins of | |
47 | NONE => "" | |
48 | | SOME s => s | |
49 | type instream = TextIO.instream | |
50 | type outstream = TextIO.outstream | |
51 | fun outputc f x = TextIO.output(f, x) | |
52 | ||
53 | exception NotAReal | |
54 | ||
55 | fun strToReal s = | |
56 | (case Real.fromString s | |
57 | of SOME r => r | |
58 | | _ => raise NotAReal) | |
59 | ||
60 | fun intToReal x = | |
61 | (strToReal ((Int.toString x) ^ ".0")) | |
62 | ||
63 | structure Bits = | |
64 | struct | |
65 | ||
66 | fun wrap (f : Word.word * Word.word -> Word.word) | |
67 | = (fn (x : int, y : int) => | |
68 | Word.toInt(f(Word.fromInt x, Word.fromInt y))) | |
69 | ||
70 | val orb = wrap Word.orb | |
71 | val andb = wrap Word.andb | |
72 | val xorb = wrap Word.xorb | |
73 | val lshift = wrap Word.<< | |
74 | val rshift = wrap Word.>> | |
75 | ||
76 | end | |
77 | structure Ref = | |
78 | struct | |
79 | val inc = fn x => (x := !x + 1) | |
80 | val dec = fn x => (x := !x - 1) | |
81 | end | |
82 | ||
83 | (* stringmap.sml *) | |
84 | ||
85 | signature STRINGMAP = | |
86 | sig type 'a stringmap | |
87 | exception Stringmap | |
88 | val new : unit -> 'a stringmap | |
89 | val add : 'a stringmap -> string * 'a -> unit | |
90 | val rm : 'a stringmap -> string -> unit | |
91 | val map : 'a stringmap -> string -> 'a | |
92 | val app : (string * 'a -> unit) -> 'a stringmap -> unit | |
93 | val isin : 'a stringmap -> string -> bool | |
94 | val extract : 'a stringmap -> 'a list | |
95 | end | |
96 | ||
97 | structure Stringmap : STRINGMAP = | |
98 | struct | |
99 | type 'a stringmap = (string * 'a) list array | |
100 | exception Stringmap | |
101 | val hashFactor = 32 | |
102 | and tableSize = 2357 | |
103 | ||
104 | (* a string hashing function | |
105 | returns a number between 0 and tableSize-1 *) | |
106 | fun hash(str: string) : int = | |
107 | let val nchars = String.size str | |
108 | ||
109 | fun loop(i,n,r) = | |
110 | if i < n then | |
111 | loop(i+1,n,(hashFactor * r + ordof(str,i)) mod tableSize) | |
112 | else r | |
113 | ||
114 | in loop(0,nchars,0) | |
115 | (* while !i < nchars do | |
116 | (n := (hashFactor * !n + ordof(str, !i)) mod tableSize; | |
117 | i := !i + 1); | |
118 | !n | |
119 | *) | |
120 | end | |
121 | ||
122 | (* create a new stringmap *) | |
123 | fun new (): 'a stringmap = array(tableSize,nil) | |
124 | ||
125 | (* add a mapping pair s +-> x to the stringmap a *) | |
126 | fun add a (s,x) = | |
127 | let val index = hash s | |
128 | in update(a,index,(s,x)::(a sub index)) | |
129 | end | |
130 | ||
131 | (* apply the stringmap a to the index string s *) | |
132 | fun map a s = | |
133 | let fun find ((s',x)::r) = if s=s' then x else find r | |
134 | | find nil = raise Stringmap | |
135 | in find (a sub (hash s)) | |
136 | end | |
137 | ||
138 | (* return true if the string is in the map, false otherwise *) | |
139 | fun isin a s = | |
140 | ((map a s; true) | |
141 | handle Stringmap => false) | |
142 | ||
143 | (* remove all pairs mapping string s from stringmap a *) | |
144 | fun rm a s = let fun f ((b as (s',j))::r) = | |
145 | if s=s' then f r else b :: f r | |
146 | | f nil = nil | |
147 | val index = hash s | |
148 | in update(a,index, f(a sub index)) | |
149 | end | |
150 | ||
151 | (* apply a function f to all mapping pairs in stringmap a *) | |
152 | fun app (f: string * 'a -> unit) a = | |
153 | let fun zap 0 = () | |
154 | | zap n = let val m = n-1 in List.app f (a sub m); zap m end | |
155 | in zap tableSize | |
156 | end | |
157 | ||
158 | (* extract the stringmap items as a list *) | |
159 | fun extract a = | |
160 | let fun atol n = | |
161 | if n < Array.length a then (a sub n) :: atol (n + 1) | |
162 | else nil | |
163 | val al = atol 0 | |
164 | fun flatten (a, b) = a @ b | |
165 | val fal = fold flatten al nil | |
166 | fun strip (s, v) = v | |
167 | val answer = List.map strip fal | |
168 | in | |
169 | answer | |
170 | end | |
171 | ||
172 | end (* Stringmap *) | |
173 | ||
174 | ||
175 | ||
176 | structure StrPak : | |
177 | sig | |
178 | val stringListString : string list -> string | |
179 | end = | |
180 | ||
181 | struct | |
182 | ||
183 | fun sl nil = "]" | |
184 | | sl (h::nil) = h ^ "]" | |
185 | | sl (h::n::t) = h ^ "," ^ sl (n::t) | |
186 | ||
187 | fun stringListString l = "[" ^ sl l | |
188 | ||
189 | end | |
190 | signature SortObjSig = | |
191 | sig | |
192 | type obj | |
193 | val gt : obj * obj -> bool | |
194 | end | |
195 | ||
196 | functor Sort ( objfun : SortObjSig ) : | |
197 | sig | |
198 | type obj | |
199 | val sort : obj list -> obj list | |
200 | end = | |
201 | ||
202 | struct | |
203 | ||
204 | open objfun | |
205 | ||
206 | type obj = objfun.obj | |
207 | ||
208 | fun sort l = | |
209 | let fun m2 (nil, b) = b | |
210 | | m2 (a, nil) = a | |
211 | | m2 (ha::ta, hb::tb) = | |
212 | if gt(ha, hb) then hb::(m2(ha::ta, tb)) | |
213 | else ha::(m2(ta, hb::tb)) | |
214 | fun ml (nil) = nil | |
215 | | ml (h::nil) = h | |
216 | | ml (h1::h2::nil) = m2(h1, h2) | |
217 | | ml (h1::h2::l) = ml [m2(h1, h2), (ml l)] | |
218 | in | |
219 | ml (map (fn x => [x]) l) | |
220 | end | |
221 | ||
222 | end | |
223 | ||
224 | structure IntImp = | |
225 | struct | |
226 | type obj = int | |
227 | fun gt(a:obj, b:obj) = a > b | |
228 | end | |
229 | ||
230 | ||
231 | structure INTSort = Sort ( IntImp ) | |
232 | ||
233 | structure Set : | |
234 | sig | |
235 | exception SET | |
236 | exception LISTUNION | |
237 | type 'a set | |
238 | val make : ''a set | |
239 | val makeEQ : ('a * 'a -> bool) -> 'a set | |
240 | val listToSet : ''a list -> ''a set | |
241 | val listToSetEQ : ('a * 'a -> bool) * 'a list -> 'a set | |
242 | val add : 'a set * 'a -> 'a set | |
243 | val union : 'a set * 'a set -> 'a set | |
244 | val listUnion : 'a set list -> 'a set | |
245 | val listUnionEQ : ('a * 'a -> bool) * 'a set list -> 'a set | |
246 | val rm : 'a set * 'a -> 'a set | |
247 | val intersect : 'a set * 'a set -> 'a set | |
248 | val diff : 'a set * 'a set -> 'a set | |
249 | val member : 'a set * 'a -> bool | |
250 | val set : 'a set -> 'a list | |
251 | val mag : 'a set -> int | |
252 | val empty : 'a set -> bool | |
253 | end = | |
254 | struct | |
255 | datatype 'a set = S of ('a*'a->bool) * 'a list | |
256 | ||
257 | exception SET | |
258 | exception LISTUNION | |
259 | ||
260 | fun eqf (x, y) = x = y | |
261 | ||
262 | val make = S (eqf, nil) | |
263 | ||
264 | fun makeEQ eqf = S (eqf, nil) | |
265 | ||
266 | fun set (S (eqf, a)) = a | |
267 | ||
268 | fun member (S (eqf, nil), e) = false | |
269 | | member (S (eqf, (s::t)), e) = eqf(e, s) orelse member(S (eqf, t), e) | |
270 | ||
271 | fun add(st as (S (eqf, s)), e) = if member(st, e) then st else S(eqf, e::s) | |
272 | ||
273 | fun listToSetEQ (eqf, l) = | |
274 | let fun f (nil, s) = s | |
275 | | f (h::t, s) = f(t, add(s, h)) | |
276 | in | |
277 | f(l, makeEQ eqf) | |
278 | end | |
279 | ||
280 | fun listToSet l = listToSetEQ (eqf, l) | |
281 | ||
282 | ||
283 | fun union (a, S (eqf, nil)) = a | |
284 | | union (S (eqf, nil), b) = b | |
285 | | union (S (eqf, e::a), b) = union(S (eqf, a), add(b, e)) | |
286 | ||
287 | fun listUnion (h::t) = fold union t h | |
288 | | listUnion _ = raise LISTUNION | |
289 | ||
290 | fun listUnionEQ (eqf, l) = fold union l (makeEQ eqf) | |
291 | ||
292 | ||
293 | fun rm (S (eqf, nil), x) = raise SET | |
294 | | rm (S (eqf, s::t), x) = | |
295 | if eqf(s, x) then S (eqf, t) else S(eqf, s :: set(rm(S (eqf, t), x))) | |
296 | ||
297 | fun intersect1 (a, S (eqf, nil), c) = S (eqf, c) | |
298 | | intersect1 (S (eqf, nil), b, c) = S (eqf, c) | |
299 | | intersect1 (S (eqf, a::t), b, c) = | |
300 | if member(b, a) then intersect1(S (eqf, t), b, a::c) | |
301 | else intersect1(S (eqf, t), b, c) | |
302 | ||
303 | fun intersect (a, b) = intersect1 (a, b, nil) | |
304 | ||
305 | fun diff (S (eqf, nil), b) = S (eqf, nil) | |
306 | | diff (S (eqf, a::t), b) = if member(b, a) then diff(S (eqf, t), b) | |
307 | else S (eqf, a :: set(diff(S (eqf, t), b))) | |
308 | ||
309 | ||
310 | fun mag s = List.length (set s) | |
311 | ||
312 | (* fun empty s = set s = nil *) | |
313 | ||
314 | fun empty (S(eqf, nil)) = true | |
315 | | empty (S(eqf, _)) = false | |
316 | ||
317 | end | |
318 | (* Copyright 1989 by AT&T Bell Laboratories *) | |
319 | (* updated by John Danskin at Princeton *) | |
320 | structure AbsMach = | |
321 | struct | |
322 | type reg = (int*string) | |
323 | type label = (int*string) | |
324 | datatype values = | |
325 | INT of int | |
326 | | REAL of real | |
327 | | LABVAL of int * int | |
328 | ||
329 | datatype arithop = imul | iadd | isub | idiv | |
330 | | orb | andb | xorb | rshift | lshift | |
331 | | fadd | fdiv | fmul | fsub | |
332 | | real | floor | logb | |
333 | ||
334 | datatype comparison = ilt | ieq | igt | ile | ige | ine | |
335 | | flt | feq | fgt | fle | fge | fne | |
336 | | inrange | outofrange | |
337 | datatype opcode = | |
338 | FETCH of {immutable: bool, offset: int, ptr: reg, dst: reg} | |
339 | (* dst := M[ptr+offset] | |
340 | if immutable then unaffected by any STORE | |
341 | other than through the allocptr *) | |
342 | | STORE of {offset: int, src: reg, ptr: reg} | |
343 | (* M[ptr+offset] := src *) | |
344 | | GETLAB of {lab: label, dst: reg} | |
345 | | GETREAL of {value: string, dst: reg} | |
346 | | ARITH of {oper: arithop, src1: reg, src2: reg, dst: reg} | |
347 | | ARITHI of {oper: arithop, src1: reg, src2: int, dst: reg} | |
348 | | MOVE of {src: reg, dst: reg} | |
349 | | BRANCH of {test: comparison, src1: reg, src2: reg, dst: label, | |
350 | live: reg list} | |
351 | | JUMP of {dst: reg, live: reg list} | |
352 | | LABEL of {lab:label, live: reg list} | |
353 | | WORD of {value: int} | |
354 | | LABWORD of {lab: label} | |
355 | | NOP | |
356 | | BOGUS of {reads: reg list, writes: reg list} | |
357 | ||
358 | val opcodeEq : opcode * opcode -> bool = (op =) | |
359 | ||
360 | end | |
361 | ||
362 | structure AbsMachImp : | |
363 | sig | |
364 | type reg | |
365 | type operation | |
366 | val oeq : operation * operation -> bool | |
367 | type comparison | |
368 | val ceq : comparison * comparison -> bool | |
369 | val write_o : operation -> reg Set.set | |
370 | val read_o : operation -> reg Set.set | |
371 | val write_c : comparison -> reg Set.set | |
372 | val read_c : comparison -> reg Set.set | |
373 | val resources_ok : operation list * comparison list -> bool | |
374 | datatype codetypes = | |
375 | ASSIGNMENT of operation | |
376 | | LABELREF of int * operation | |
377 | | COMPARISON of int * operation | |
378 | | FLOW of int * operation | |
379 | | TARGET of int * operation | |
380 | | EXIT of operation | |
381 | | JUNK of operation | |
382 | | NERGLE | |
383 | val classify : operation -> codetypes | |
384 | val maxreg : AbsMach.opcode list -> int | |
385 | end = | |
386 | struct | |
387 | ||
388 | type reg = int (* register strings will gum up set operations etc *) | |
389 | type operation = AbsMach.opcode | |
390 | type comparison = AbsMach.opcode | |
391 | ||
392 | fun oeq (a, b) = AbsMach.opcodeEq(a, b) | |
393 | fun ceq (a, b) = AbsMach.opcodeEq(a, b) | |
394 | ||
395 | fun reg(i, s) = i | |
396 | fun label(i, s) = i | |
397 | ||
398 | ||
399 | fun srl rl = Set.listToSet((map reg) rl) | |
400 | fun sr r = srl [r] | |
401 | ||
402 | val immutableMem = ~1 | |
403 | val mutableMem = ~2 | |
404 | val flowControl = ~3 | |
405 | ||
406 | (* comparisons are limited to one because of difficulty writing larger trees *) | |
407 | fun resources_ok(ops, c) = (List.length ops) <= 4 andalso (List.length c) <= 1 | |
408 | ||
409 | fun allocptr r = reg r = 1 | |
410 | ||
411 | fun write_o i = | |
412 | let open Set | |
413 | open AbsMach | |
414 | val f = | |
415 | fn FETCH{dst, ...} => sr dst | |
416 | | STORE{ptr, ...} => | |
417 | if allocptr ptr then listToSet [immutableMem, mutableMem] | |
418 | else listToSet [mutableMem] | |
419 | | GETLAB {dst, ...} => sr dst | |
420 | | GETREAL {dst, ...} => sr dst | |
421 | | ARITH {dst, ...} => sr dst | |
422 | | ARITHI {dst, ...} => sr dst | |
423 | | MOVE {dst, ...} => sr dst | |
424 | | JUMP _ => listToSet [flowControl] | |
425 | | BOGUS {writes, ...} => srl writes | |
426 | | _ => make | |
427 | in | |
428 | f i | |
429 | end | |
430 | ||
431 | fun write_c c = Set.listToSet [flowControl] | |
432 | ||
433 | val std_reg_list = [(1, ""), (2, ""), (3, ""), (4, ""), (5, "")] | |
434 | ||
435 | fun read i = | |
436 | let open Set | |
437 | open AbsMach | |
438 | val f = | |
439 | fn FETCH {immutable, ptr, ...} => | |
440 | let val mem = if immutable then immutableMem else mutableMem | |
441 | in | |
442 | add(sr ptr, mem) | |
443 | end | |
444 | | STORE {src, ptr, ...} => srl [src, ptr] | |
445 | | ARITH {src1, src2, ...} => srl [src1, src2] | |
446 | | ARITHI {src1, ...} => sr src1 | |
447 | | MOVE {src, ...} => sr src | |
448 | | BRANCH {src1, src2, ...} => srl [src1, src2] | |
449 | | JUMP {dst, ...} => srl (dst :: std_reg_list) | |
450 | | BOGUS {reads, ...} => srl reads | |
451 | | _ => make | |
452 | in | |
453 | f i | |
454 | end | |
455 | ||
456 | fun read_o i = read i | |
457 | fun read_c i = read i | |
458 | ||
459 | datatype codetypes = | |
460 | ASSIGNMENT of operation | |
461 | | LABELREF of int * operation | |
462 | | COMPARISON of int * operation | |
463 | | FLOW of int * operation | |
464 | | TARGET of int * operation | |
465 | | EXIT of operation | |
466 | | JUNK of operation | |
467 | | NERGLE | |
468 | ||
469 | fun maxreg li = | |
470 | let fun f (a, b) = Int.max(a, b) | |
471 | val r = | |
472 | (Set.set (Set.listUnion((map write_o li) @ | |
473 | (map read li)))) | |
474 | in | |
475 | fold f r 0 | |
476 | end | |
477 | ||
478 | ||
479 | fun classify i = | |
480 | let open AbsMach | |
481 | val f = | |
482 | fn FETCH _ => ASSIGNMENT i | |
483 | | STORE _ => ASSIGNMENT i | |
484 | | GETLAB{lab, dst} => LABELREF(label lab, i) | |
485 | | GETREAL _ => ASSIGNMENT i | |
486 | | ARITH _ => ASSIGNMENT i | |
487 | | ARITHI _ => ASSIGNMENT i | |
488 | | MOVE{src, dst} => | |
489 | if reg src = reg dst then NERGLE | |
490 | else ASSIGNMENT i | |
491 | | BRANCH{test,src1,src2,dst,live} => | |
492 | if test = ieq andalso (reg src1) = (reg src2) | |
493 | then FLOW (label dst, i) | |
494 | else COMPARISON (label dst, i) | |
495 | | JUMP _ => EXIT i | |
496 | | LABEL {lab, ...} => TARGET(label lab, i) | |
497 | | WORD _ => JUNK i | |
498 | | LABWORD _ => JUNK i | |
499 | | NOP => JUNK i | |
500 | | BOGUS _ => ASSIGNMENT i | |
501 | in | |
502 | f i | |
503 | end | |
504 | end | |
505 | structure ReadAbs : sig val read: instream -> AbsMach.opcode list end = | |
506 | struct | |
507 | ||
508 | open AbsMach | |
509 | ||
510 | exception ReadError | |
511 | ||
512 | fun readline(i,f) = | |
513 | let | |
514 | ||
515 | fun error s = (print("Error in line "^makestring i^": "^s^"\n"); | |
516 | raise ReadError) | |
517 | ||
518 | fun b(" "::rest) = b rest | b rest = rest | |
519 | ||
520 | val aop = | |
521 | fn "i"::"m"::"u"::"l"::l => (imul,l) | |
522 | | "i"::"a"::"d"::"d"::l => (iadd,l) | |
523 | | "i"::"s"::"u"::"b"::l => (isub,l) | |
524 | | "i"::"d"::"i"::"v"::l => (idiv,l) | |
525 | | "o"::"r"::"b"::" "::l=> (orb,l) | |
526 | | "a"::"n"::"d"::"b"::l => (andb,l) | |
527 | | "x"::"o"::"r"::"b"::l => (xorb,l) | |
528 | | "r"::"s"::"h"::"i"::"f"::"t"::l => (rshift,l) | |
529 | | "l"::"s"::"h"::"i"::"f"::"t"::l => (lshift,l) | |
530 | | "f"::"a"::"d"::"d"::l => (fadd,l) | |
531 | | "f"::"d"::"i"::"v"::l => (fdiv,l) | |
532 | | "f"::"m"::"u"::"l"::l => (fmul,l) | |
533 | | "f"::"s"::"u"::"b"::l => (fsub,l) | |
534 | | "r"::"e"::"a"::"l"::l => (real,l) | |
535 | | "f"::"l"::"o"::"o"::"r"::l => (floor,l) | |
536 | | "l"::"o"::"g"::"b"::l => (logb,l) | |
537 | | _ => error "illegal arithmetic operator" | |
538 | ||
539 | val com = | |
540 | fn "i"::"l"::"t"::l => (ilt,l) | |
541 | | "i"::"e"::"q"::l => (ieq,l) | |
542 | | "i"::"g"::"t"::l => (igt,l) | |
543 | | "i"::"l"::"e"::l => (ile,l) | |
544 | | "i"::"g"::"e"::l => (ige,l) | |
545 | | "i"::"n"::"e"::l => (ine,l) | |
546 | | "f"::"l"::"t"::l => (flt,l) | |
547 | | "f"::"e"::"q"::l => (feq,l) | |
548 | | "f"::"g"::"t"::l => (fgt,l) | |
549 | | "f"::"l"::"e"::l => (fle,l) | |
550 | | "f"::"g"::"e"::l => (fge,l) | |
551 | | "f"::"n"::"e"::l => (fne,l) | |
552 | | "i"::"n"::"r"::"a"::"n"::"g"::"e"::l => (inrange,l) | |
553 | | "o"::"u"::"t"::"o"::"f"::"r"::"a"::"n"::"g"::"e"::l => (outofrange,l) | |
554 | | _ => error "illegal comparison operator" | |
555 | ||
556 | fun immut("i"::l) = (true,l) | immut("m"::l) = (false,l) | |
557 | | immut _ = error "i or m required" | |
558 | ||
559 | fun int l = | |
560 | let val z = ord "0" | |
561 | fun f(n,l0 as d::l) = if d>="0" andalso d<="9" | |
562 | then f(n*10+ord(d)-z, l) | |
563 | else (n,l0) | |
564 | | f _ = error "in readabs.int" | |
565 | in f(0,l) | |
566 | end | |
567 | ||
568 | fun string l = | |
569 | let fun f("/"::l) = (nil,l) | |
570 | | f(a::l) = let val (s,l') = f l | |
571 | in (a::s, l') | |
572 | end | |
573 | | f _ = error "name not terminated by \"/\"" | |
574 | val (s,l') = f l | |
575 | in (implode s, l') | |
576 | end | |
577 | ||
578 | fun realc s = | |
579 | let val (sign,s) = case explode s of "~"::rest => (~1.0,rest) | |
580 | | s => (1.0,s) | |
581 | fun j(exp,d::dl,mant) = j(exp,dl,mant * 0.1 + intToReal(d)) | |
582 | | j(0,nil,mant) = mant*sign | |
583 | | j(exp,nil,mant) = if exp>0 then j(exp-1,nil,mant*10.0) | |
584 | else j(exp+1,nil,mant*0.1) | |
585 | fun h(esign,wholedigits,diglist,exp,nil) = | |
586 | j(esign*exp+wholedigits-1,diglist,0.0) | |
587 | | h(es,fd,dl,exp,d::s) = h(es,fd,dl,exp*10+(ord d - ord "0"),s) | |
588 | fun g(i,r,"E"::"~"::s)=h(~1,i,r,0,s) | |
589 | | g(i,r,"E"::s)=h(1,i,r,0,s) | |
590 | | g(i,r,d::s) = if d>="0" andalso d<="9" then | |
591 | g(i, (ord d - ord "0")::r, s) | |
592 | else h(1,i,r,0,nil) | |
593 | | g(i,r,nil) = h(1,i,r,0,nil) | |
594 | fun f(i,r,"."::s)=g(i,r,s) | |
595 | | f(i,r,s as "E"::_)=g(i,r,s) | |
596 | | f(i,r,d::s) = f(i+1,(ord(d)-ord("0"))::r,s) | |
597 | | f _ = error "bad in readdabs" | |
598 | in f(0,nil,s) | |
599 | end handle Overflow => error ("real constant "^s^" out of range") | |
600 | ||
601 | fun require((a:string)::ar, b::br) = if a=b then require(ar,br) | |
602 | else error(a^" required") | |
603 | | require(nil, br) = br | |
604 | | require(a::_,_) = error(a^" required") | |
605 | ||
606 | fun reg l = let val (s,l) = string l | |
607 | val l = require(["R"],l) | |
608 | val (i,l) = int l | |
609 | in ((i,s),l) | |
610 | end | |
611 | fun lab l = let val (s,l) = string l | |
612 | val l = require(["L"],l) | |
613 | val (i,l) = int l | |
614 | in ((i,s),l) | |
615 | end | |
616 | ||
617 | fun live l = | |
618 | let fun f(")"::_) = nil | |
619 | | f l = let val (r,l) = reg l | |
620 | in r::f(b l) | |
621 | end | |
622 | in f(b(require(["("],l))) | |
623 | end | |
624 | ||
625 | val opcode = | |
626 | fn "F"::"E"::"T"::"C"::"H"::l => | |
627 | let val (imm,l) = immut(b l) | |
628 | val (dst,l) = reg(b l) | |
629 | val (ptr,l) = reg(b(require(["M","["],b(require([":","="],b l))))) | |
630 | val (offset,l) = int(b(require(["+"],b l))) | |
631 | in require(["]"], b l); | |
632 | FETCH{immutable=imm,dst=dst,ptr=ptr,offset=offset} | |
633 | end | |
634 | | "S"::"T"::"O"::"R"::"E"::l => | |
635 | let val (ptr,l) = reg(b(require(["M","["],b l))) | |
636 | val (offset,l) = int(b(require(["+"],b l))) | |
637 | val (src,l) = reg(b(require([":","="],b(require(["]"], b l))))) | |
638 | in STORE{src=src,ptr=ptr,offset=offset} | |
639 | end | |
640 | | "G"::"E"::"T"::"L"::"A"::"B"::l => | |
641 | let val (dst,l) = reg(b l) | |
642 | val (lab,l) = lab(b(require([":","="],b l))) | |
643 | in GETLAB{dst=dst,lab=lab} | |
644 | end | |
645 | | "G"::"E"::"T"::"R"::"E"::"A"::"L"::l => | |
646 | let val (dst,l) = reg(b l) | |
647 | val r = realc(implode(b(require([":","="],b l)))) | |
648 | in GETREAL{dst=dst,value=Real.toString r} | |
649 | end | |
650 | | "A"::"R"::"I"::"T"::"H"::"I"::l => | |
651 | let val (dst,l) = reg(b l) | |
652 | val (s1,l) = reg(b(require([":","="],b l))) | |
653 | val (oper,l) = aop(b l) | |
654 | val (s2,l) = int(b l) | |
655 | in ARITHI{oper=oper,src1=s1,src2=s2,dst=dst} | |
656 | end | |
657 | | "A"::"R"::"I"::"T"::"H"::l => | |
658 | let val (dst,l) = reg(b l) | |
659 | val (s1,l) = reg(b(require([":","="],b l))) | |
660 | val (oper,l) = aop(b l) | |
661 | val (s2,l) = reg(b l) | |
662 | in ARITH{oper=oper,src1=s1,src2=s2,dst=dst} | |
663 | end | |
664 | | "M"::"O"::"V"::"E"::l => | |
665 | let val (dst,l) = reg(b l) | |
666 | val (s1,l) = reg(b(require([":","="],b l))) | |
667 | in MOVE{src=s1,dst=dst} | |
668 | end | |
669 | | "B"::"R"::"A"::"N"::"C"::"H"::l => | |
670 | let val (s1,l) = reg(b(require(["I","F"],b l))) | |
671 | val (test,l) = com(b l) | |
672 | val (s2,l) = reg(b l) | |
673 | val (dst,l) = lab(b(require(["G","O","T","O"],b l))) | |
674 | val liv = live(b l) | |
675 | in BRANCH{test=test,src1=s1,src2=s2,dst=dst,live=liv} | |
676 | end | |
677 | | "J"::"U"::"M"::"P"::l => | |
678 | let val (dst,l) = reg(b l) | |
679 | val live = live(b l) | |
680 | in JUMP{dst=dst,live=live} | |
681 | end | |
682 | | "L"::"A"::"B"::"E"::"L"::l => | |
683 | let val (lab,l) = lab(b l) | |
684 | val live = live(b(require([":"],l))) | |
685 | in LABEL{lab=lab,live=live} | |
686 | end | |
687 | | "W"::"O"::"R"::"D"::l => | |
688 | let val (i,l) = int(b l) | |
689 | in WORD{value=i} | |
690 | end | |
691 | | "L"::"A"::"B"::"W"::"O"::"R"::"D"::l => | |
692 | let val (i,l) = lab(b l) | |
693 | in LABWORD{lab=i} | |
694 | end | |
695 | | "N"::"O"::"P"::_ => NOP | |
696 | | _ => error "illegal opcode name" | |
697 | in | |
698 | case explode(input_line f) | |
699 | of nil => nil | |
700 | | l => opcode(b l)::readline(i+1,f) | |
701 | end | |
702 | ||
703 | fun read f = readline(0,f) | |
704 | ||
705 | end | |
706 | ||
707 | structure PrintAbs : | |
708 | sig | |
709 | val show: outstream -> AbsMach.opcode list -> unit | |
710 | val str: AbsMach.opcode list -> string | |
711 | end = | |
712 | struct | |
713 | ||
714 | open AbsMach | |
715 | ||
716 | fun xstr prog = | |
717 | ||
718 | let | |
719 | ||
720 | val outstr = ref "" | |
721 | fun pr s = outstr := !outstr ^ s | |
722 | ||
723 | val aop = | |
724 | fn imul => "imul" | |
725 | | iadd => "iadd" | |
726 | | isub => "isub" | |
727 | | idiv => "idiv" | |
728 | | orb => "orb" | |
729 | | andb => "andb" | |
730 | | xorb => "xorb" | |
731 | | rshift => "rshift" | |
732 | | lshift => "lshift" | |
733 | | fadd => "fadd" | |
734 | | fdiv => "fdiv" | |
735 | | fmul => "fmul" | |
736 | | fsub => "fsub" | |
737 | | real => "real" | |
738 | | floor => "floor" | |
739 | | logb => "logb" | |
740 | ||
741 | val com = | |
742 | fn ilt => "ilt" | |
743 | | ieq => "ieq" | |
744 | | igt => "igt" | |
745 | | ile => "ile" | |
746 | | ige => "ige" | |
747 | | ine => "ine" | |
748 | | flt => "flt" | |
749 | | feq => "feq" | |
750 | | fgt => "fgt" | |
751 | | fle => "fle" | |
752 | | fge => "fge" | |
753 | | fne => "fne" | |
754 | | inrange => "inrange" | |
755 | | outofrange => "outofrange" | |
756 | ||
757 | fun bo true = "t" | bo false = "f" | |
758 | ||
759 | fun reg(i,s) = (pr(s); pr "/R"; pr(makestring i)) | |
760 | fun label(i,s) = (pr(s); pr "/L"; pr(makestring i)) | |
761 | ||
762 | val p = | |
763 | fn FETCH{immutable,offset,ptr,dst} => | |
764 | (pr "FETCH"; | |
765 | if immutable then pr "i " else pr "m "; | |
766 | reg dst; pr " := M[ "; reg ptr; | |
767 | pr " + "; pr (makestring offset); pr(" ]\n")) | |
768 | | STORE{offset,ptr,src} => | |
769 | (pr "STORE "; | |
770 | pr "M[ "; reg ptr; | |
771 | pr " + "; pr (makestring offset); pr(" ] := "); | |
772 | reg src; | |
773 | pr "\n") | |
774 | | GETLAB{lab, dst} => | |
775 | (pr "GETLAB "; reg dst; | |
776 | pr " := "; label lab; | |
777 | pr "\n") | |
778 | | GETREAL{value,dst} => | |
779 | (pr "GETREAL "; reg dst; | |
780 | pr " := "; | |
781 | pr value; | |
782 | pr "\n") | |
783 | | ARITH{oper,src1,src2,dst} => | |
784 | (pr "ARITH "; reg dst; | |
785 | pr " := "; reg src1; | |
786 | pr " "; pr(aop oper); pr " "; | |
787 | reg src2; | |
788 | pr "\n") | |
789 | | ARITHI{oper,src1,src2,dst} => | |
790 | (pr "ARITHI "; reg dst; | |
791 | pr " := "; reg src1; | |
792 | pr " "; pr(aop oper); pr " "; | |
793 | pr(makestring src2); | |
794 | pr "\n") | |
795 | | MOVE{src,dst} => | |
796 | (pr "MOVE "; reg dst; | |
797 | pr " := "; reg src; | |
798 | pr "\n") | |
799 | | BRANCH{test,src1,src2,dst,live} => | |
800 | (pr "BRANCH "; | |
801 | pr "IF "; reg src1; | |
802 | pr " "; pr(com test); pr " "; | |
803 | reg src2; | |
804 | pr " GOTO "; | |
805 | label dst; | |
806 | pr " ( "; | |
807 | List.app (fn r => (reg r; pr " ")) live; | |
808 | pr ")\n") | |
809 | | JUMP{dst,live} => | |
810 | (pr "JUMP "; reg dst; | |
811 | pr " ( "; | |
812 | List.app (fn r => (reg r; pr " ")) live; | |
813 | pr ")\n") | |
814 | | LABEL{lab, live} => | |
815 | (pr "LABEL "; label lab; | |
816 | pr ": ( "; | |
817 | List.app (fn r => (reg r; pr " ")) live; | |
818 | pr ")\n") | |
819 | | WORD{value} => | |
820 | (pr "WORD "; | |
821 | pr (makestring value); | |
822 | pr "\n") | |
823 | | LABWORD{lab} => | |
824 | (pr "LABWORD "; label lab; | |
825 | pr "\n") | |
826 | | NOP => pr "NOP\n" | |
827 | | BOGUS{reads, writes} => | |
828 | (pr "BOGUS"; | |
829 | pr " ( "; | |
830 | List.app (fn r => (reg r; pr " ")) writes; | |
831 | pr ") := ("; | |
832 | List.app (fn r => (reg r; pr " ")) reads; | |
833 | pr ")\n") | |
834 | ||
835 | ||
836 | in (List.app p prog; !outstr) | |
837 | end | |
838 | ||
839 | fun str prog = | |
840 | let fun cat (a, b) = (xstr [a]) ^ b | |
841 | in | |
842 | fold cat prog "" | |
843 | end | |
844 | ||
845 | fun show out prog = | |
846 | let fun f nil = () | |
847 | | f (h::t) = (outputc out (xstr [h]); | |
848 | f t) | |
849 | in | |
850 | f prog | |
851 | end | |
852 | ||
853 | end | |
854 | ||
855 | ||
856 | structure HM = AbsMachImp | |
857 | structure BreakInst : | |
858 | sig | |
859 | val breaki : AbsMach.opcode list -> AbsMach.opcode list | |
860 | end = | |
861 | struct | |
862 | ||
863 | open AbsMach | |
864 | open HM | |
865 | ||
866 | val maxreg = AbsMachImp.maxreg | |
867 | ||
868 | fun reg(i:int, s:string) = i | |
869 | fun rstr(i:int, s:string) = s | |
870 | ||
871 | val new_reg_val = ref 0 | |
872 | val new_reg_pairs:(AbsMach.reg * AbsMach.reg) list ref = ref nil | |
873 | ||
874 | fun new_reg_init li = (new_reg_val := maxreg li; | |
875 | new_reg_pairs := nil) | |
876 | ||
877 | fun new_reg (r:AbsMach.reg) = | |
878 | let fun f nil = | |
879 | let val nr = (new_reg_val := !new_reg_val + 1; (!new_reg_val, rstr r)) | |
880 | in | |
881 | (new_reg_pairs := (r, nr) :: !new_reg_pairs; | |
882 | nr) | |
883 | end | |
884 | | f ((a, b)::t) = if r = a then b else f t | |
885 | in | |
886 | f (!new_reg_pairs) | |
887 | end | |
888 | ||
889 | fun breaki l = | |
890 | let fun f i = | |
891 | let val g = | |
892 | fn ARITH{oper, src1, src2, dst} => | |
893 | if reg dst = reg src1 orelse reg dst = reg src2 then | |
894 | let val nr = new_reg(dst) | |
895 | in | |
896 | [ARITH{oper=oper, src1=src2, src2=src2, dst=nr}, | |
897 | MOVE{src=nr, dst=dst}] | |
898 | end | |
899 | else [i] | |
900 | | ARITHI{oper, src1, src2, dst} => | |
901 | if reg dst = reg src1 then | |
902 | let val nr = new_reg(dst) | |
903 | in | |
904 | [ARITHI{oper=oper, src1=src1, src2=src2, dst=nr}, | |
905 | MOVE{src=nr, dst=dst}] | |
906 | end | |
907 | else [i] | |
908 | | FETCH{immutable, offset, ptr, dst} => | |
909 | if reg ptr = reg dst then | |
910 | let val nr = new_reg(dst) | |
911 | in | |
912 | [FETCH{immutable=immutable, offset=offset, | |
913 | ptr=ptr, dst=nr}, | |
914 | MOVE{src=nr, dst=dst}] | |
915 | end | |
916 | else [i] | |
917 | | MOVE{src, dst} => | |
918 | if reg src = reg dst then nil | |
919 | else [i] | |
920 | | _ => [i] | |
921 | in | |
922 | g i | |
923 | end | |
924 | fun h (a, b) = f a @ b | |
925 | val foo = new_reg_init l | |
926 | in | |
927 | fold h l nil | |
928 | end | |
929 | ||
930 | end | |
931 | structure OutFilter : | |
932 | sig | |
933 | val remnops : AbsMach.opcode list -> AbsMach.opcode list | |
934 | end = | |
935 | struct | |
936 | ||
937 | open AbsMach | |
938 | ||
939 | fun remnops ol = | |
940 | let fun f (NOP, NOP::b) = NOP::b | |
941 | | f (a, b) = a::b | |
942 | in | |
943 | fold f ol nil | |
944 | end | |
945 | ||
946 | end | |
947 | structure Delay : | |
948 | sig | |
949 | val init: AbsMach.opcode list -> unit | |
950 | val add_delay: AbsMach.opcode list -> AbsMach.opcode list | |
951 | val rm_bogus: AbsMach.opcode list -> AbsMach.opcode list | |
952 | val is_bogus_i : AbsMach.opcode -> bool | |
953 | val is_bogus_reg : AbsMach.reg -> bool | |
954 | val idempotency : int ref | |
955 | end = | |
956 | struct | |
957 | ||
958 | open AbsMach | |
959 | ||
960 | val maxreg = ref 0 | |
961 | val maxdelay = 12 | |
962 | ||
963 | val idempotency = ref 0 | |
964 | ||
965 | fun is_bogus_i (BOGUS _ ) = true | |
966 | | is_bogus_i _ = false | |
967 | ||
968 | fun bogus_reg ((i, s), which) = (!maxreg + maxdelay * i + which, s) | |
969 | ||
970 | fun is_bogus_reg (i, s) = i > !maxreg | |
971 | ||
972 | fun unbogus_reg (i, s) = if is_bogus_reg (i, s) then (i div maxdelay, s) | |
973 | else (i, s) | |
974 | ||
975 | val max_bog_reg = ref 0 | |
976 | val curr_idem_reg = ref 0 | |
977 | ||
978 | fun idem_reg() = | |
979 | (curr_idem_reg := !curr_idem_reg + 1; | |
980 | (!curr_idem_reg, "idem")) | |
981 | ||
982 | fun init il = ( | |
983 | maxreg := AbsMachImp.maxreg il; | |
984 | max_bog_reg := (!maxreg + 1) * maxdelay; | |
985 | curr_idem_reg := !max_bog_reg + 1 | |
986 | ) | |
987 | ||
988 | exception DELAY | |
989 | ||
990 | fun delay i = | |
991 | let fun opdelay oper = | |
992 | let val f = | |
993 | fn imul => 5 | |
994 | | iadd => 2 | |
995 | | isub => 2 | |
996 | | idiv => 12 | |
997 | | orb => 2 | |
998 | | andb => 2 | |
999 | | xorb => 2 | |
1000 | | rshift => 2 | |
1001 | | lshift => 2 | |
1002 | | fadd => 2 | |
1003 | | fdiv => 12 | |
1004 | | fmul => 4 | |
1005 | | fsub => 2 | |
1006 | | real => 2 | |
1007 | | floor => 2 | |
1008 | | logb => 2 | |
1009 | in | |
1010 | f oper | |
1011 | end | |
1012 | val id = | |
1013 | fn FETCH{immutable,offset,ptr,dst} => 2 | |
1014 | | STORE{offset,ptr,src} => 2 | |
1015 | | GETLAB{lab, dst} => 2 | |
1016 | | GETREAL{value,dst} => 2 | |
1017 | | ARITH{oper,src1,src2,dst} => opdelay oper | |
1018 | | ARITHI{oper,src1,src2,dst} => opdelay oper | |
1019 | | MOVE{src,dst} => 1 | |
1020 | | BRANCH{test,src1,src2,dst,live} => 5 | |
1021 | | JUMP{dst,live} => 1 | |
1022 | | LABEL{lab, live} => 0 | |
1023 | | NOP => 1 | |
1024 | | _ => raise DELAY | |
1025 | in | |
1026 | id i | |
1027 | end | |
1028 | ||
1029 | fun b_idemx (0, r, w) = nil | |
1030 | | b_idemx (1, r, w) = BOGUS{reads=r @ w, writes = [idem_reg()]} :: nil | |
1031 | | b_idemx (n, r, w) = | |
1032 | let val ir = idem_reg() | |
1033 | in | |
1034 | BOGUS{reads=r @ w, writes = [ir]} :: b_idemx(n-1, r, [ir]) | |
1035 | end | |
1036 | ||
1037 | fun b_idem (n, r, w) = | |
1038 | let fun fil ((i, s), b) = if i = 0 then b else (i, s) :: b | |
1039 | val nr = fold fil r nil | |
1040 | in | |
1041 | if null nr then nil | |
1042 | else b_idemx(n, nr, w) | |
1043 | end | |
1044 | ||
1045 | fun b_assx (0, r) = nil | |
1046 | | b_assx (1, r) = BOGUS{reads=[bogus_reg(r, 1)], writes=[r]} :: nil | |
1047 | | b_assx (n, r) = | |
1048 | BOGUS{reads=[bogus_reg(r, n)], writes=[bogus_reg(r, n-1)]} :: | |
1049 | b_assx(n-1, r) | |
1050 | ||
1051 | fun b_ass(n, r) = BOGUS{reads=[r], writes=[bogus_reg(r, n-1)]} :: | |
1052 | b_assx(n-1, r) | |
1053 | ||
1054 | fun b_brxx (0, rl) = nil | |
1055 | | b_brxx (1, rl) = | |
1056 | let fun b r = bogus_reg(r, 1) | |
1057 | in | |
1058 | BOGUS{reads=rl, writes=map b rl} :: nil | |
1059 | end | |
1060 | | b_brxx (n, rl) = | |
1061 | let fun br r = bogus_reg(r, n - 1) | |
1062 | fun bw r = bogus_reg(r, n) | |
1063 | in | |
1064 | BOGUS{reads=map br rl, writes=map bw rl} :: b_brxx (n - 1, rl) | |
1065 | end | |
1066 | ||
1067 | fun b_brx (n, rl) = | |
1068 | let fun br r = bogus_reg(r, n-1) | |
1069 | in | |
1070 | BOGUS{reads=map br rl, writes=rl} :: b_brxx(n-1, rl) | |
1071 | end | |
1072 | ||
1073 | fun b_br (b, n, rl) = rev (b :: b_brx(n, rl)) | |
1074 | ||
1075 | fun is_flow i = | |
1076 | let open AbsMachImp | |
1077 | fun f (FLOW _) = true | |
1078 | | f _ = false | |
1079 | in | |
1080 | f (classify i) | |
1081 | end | |
1082 | ||
1083 | fun add_delay il = | |
1084 | let fun idem (r, w) = b_idem (!idempotency, r, w) | |
1085 | fun g i = | |
1086 | let val d = delay i | |
1087 | val f = | |
1088 | fn FETCH{immutable,offset,ptr,dst} => | |
1089 | i :: (idem([ptr], [dst]) @ b_ass(d, dst)) | |
1090 | | STORE{offset,ptr,src} => [i] | |
1091 | | GETLAB{lab, dst} => i :: b_ass(d, dst) | |
1092 | | GETREAL{value,dst} => i :: b_ass(d, dst) | |
1093 | | ARITH{oper,src1,src2,dst} => | |
1094 | i :: (idem([src1, src2], [dst]) @ b_ass(d, dst)) | |
1095 | | ARITHI{oper,src1,src2,dst} => | |
1096 | i :: (idem([src1], [dst]) @ b_ass(d, dst)) | |
1097 | | MOVE{src,dst} => i :: idem([src], [dst]) | |
1098 | | BRANCH{test,src1,src2,dst,live} => | |
1099 | if is_flow i then [i] | |
1100 | else | |
1101 | b_br (BRANCH{test=test, | |
1102 | src1=src1,src2=src2,dst=dst, | |
1103 | live=live}, | |
1104 | d, [src1, src2]) | |
1105 | | _ => [i] | |
1106 | in | |
1107 | f i | |
1108 | end | |
1109 | fun apnd (nil, b) = b | |
1110 | | apnd (a::t, b) = a :: apnd(t, b) | |
1111 | fun fld(a, b) = apnd(g a, b) | |
1112 | in | |
1113 | fold fld il nil | |
1114 | end | |
1115 | ||
1116 | fun rm_bogus il = | |
1117 | let fun g nil = nil | |
1118 | | g (i::t) = | |
1119 | let val f = | |
1120 | fn FETCH{immutable,offset,ptr,dst} => | |
1121 | FETCH{immutable=immutable, offset=offset, ptr=ptr, | |
1122 | dst= unbogus_reg dst} :: | |
1123 | g t | |
1124 | | STORE{offset,ptr,src} => i :: g t | |
1125 | | GETLAB{lab, dst} => | |
1126 | GETLAB{lab=lab, dst= unbogus_reg dst} :: g t | |
1127 | | GETREAL{value,dst} => | |
1128 | GETREAL{value=value, dst=unbogus_reg dst} :: g t | |
1129 | | ARITH{oper,src1,src2,dst} => | |
1130 | ARITH{oper=oper,src1=src1,src2=src2,dst=unbogus_reg dst} :: | |
1131 | g t | |
1132 | | ARITHI{oper,src1,src2,dst} => | |
1133 | ARITHI{oper=oper,src1=src1,src2=src2,dst=unbogus_reg dst} :: | |
1134 | g t | |
1135 | | MOVE{src,dst} => i :: g t | |
1136 | | BRANCH{test,src1,src2,dst,live} => | |
1137 | BRANCH{test=test, | |
1138 | src1=unbogus_reg src1, | |
1139 | src2=unbogus_reg src2, | |
1140 | dst=dst, live=live | |
1141 | } :: g t | |
1142 | | BOGUS _ => g t | |
1143 | | _ => i :: g t | |
1144 | in | |
1145 | f i | |
1146 | end | |
1147 | in | |
1148 | g il | |
1149 | end | |
1150 | end | |
1151 | structure Ntypes : | |
1152 | sig | |
1153 | type name | |
1154 | val init_names : unit -> unit | |
1155 | val new_name : name -> name | |
1156 | val prime_name : name -> name | |
1157 | val name_prefix_eq : (name * name) -> bool | |
1158 | type test | |
1159 | val teq : test * test -> bool | |
1160 | type reg | |
1161 | type assignment | |
1162 | val aeq : assignment * assignment -> bool | |
1163 | ||
1164 | datatype test_or_name = | |
1165 | TEST of test | |
1166 | | NAME of name | |
1167 | | NEITHER | |
1168 | ||
1169 | val toneq : test_or_name * test_or_name -> bool | |
1170 | ||
1171 | datatype test_or_assign = | |
1172 | TST of test | |
1173 | | ASS of assignment | |
1174 | ||
1175 | val toaeq : test_or_assign * test_or_assign -> bool | |
1176 | ||
1177 | end = | |
1178 | ||
1179 | struct | |
1180 | ||
1181 | ||
1182 | type test = HM.comparison | |
1183 | val teq = HM.ceq | |
1184 | ||
1185 | type reg = int*string | |
1186 | ||
1187 | type assignment = HM.operation | |
1188 | val aeq = HM.oeq | |
1189 | ||
1190 | type name = string | |
1191 | ||
1192 | val ct = ref 0 | |
1193 | ||
1194 | fun init_names () = ct := 0 | |
1195 | ||
1196 | fun nn() = (ct := !ct + 1; !ct - 1) | |
1197 | ||
1198 | fun pref nil = nil | |
1199 | | pref ("_" :: t) = nil | |
1200 | | pref (h :: t) = h :: pref t | |
1201 | ||
1202 | val name_prefix = implode o pref o explode | |
1203 | fun name_prefix_eq(a, b) = (name_prefix a) = (name_prefix b) | |
1204 | (* | |
1205 | fun new_name n = n ^ "_" ^ (makestring (nn())) | |
1206 | *) | |
1207 | fun new_name n = name_prefix n ^ "_" ^ (makestring (nn())) | |
1208 | fun prime_name n = (new_name n) ^ "'" | |
1209 | ||
1210 | datatype test_or_name = | |
1211 | TEST of test | |
1212 | | NAME of name | |
1213 | | NEITHER | |
1214 | ||
1215 | fun toneq (TEST a, TEST b) = teq (a, b) | |
1216 | | toneq (NAME a, NAME b) = a = b | |
1217 | | toneq _ = false | |
1218 | ||
1219 | datatype test_or_assign = | |
1220 | TST of test | |
1221 | | ASS of assignment | |
1222 | ||
1223 | fun toaeq (TST a, TST b) = teq (a, b) | |
1224 | | toaeq (ASS a, ASS b) = aeq (a, b) | |
1225 | | toaeq _ = false | |
1226 | ||
1227 | end | |
1228 | structure Dag : | |
1229 | sig | |
1230 | exception DAG | |
1231 | exception DAGnotfound | |
1232 | type dag | |
1233 | val make : dag | |
1234 | val tests_of : dag -> Ntypes.test Set.set | |
1235 | val sel_of : dag -> ((Ntypes.test * bool) -> Ntypes.test_or_name) | |
1236 | val root_of : dag -> Ntypes.test_or_name | |
1237 | val succ_of : dag -> Ntypes.name Set.set | |
1238 | val attach : Ntypes.test * dag * dag -> dag | |
1239 | val reach : dag * Ntypes.test_or_name -> dag | |
1240 | val replace_edge : dag * Ntypes.name list -> dag | |
1241 | val newdag : (Ntypes.test Set.set * | |
1242 | ((Ntypes.test * bool) -> Ntypes.test_or_name) * | |
1243 | Ntypes.test_or_name * | |
1244 | Ntypes.name Set.set) | |
1245 | -> dag | |
1246 | val dagToString : dag -> string | |
1247 | end = | |
1248 | struct | |
1249 | ||
1250 | open Ntypes; | |
1251 | ||
1252 | ||
1253 | exception DAGnotfound | |
1254 | exception DAG | |
1255 | ||
1256 | datatype dag = | |
1257 | D of | |
1258 | test Set.set * | |
1259 | ((test * bool) -> test_or_name) * | |
1260 | test_or_name * | |
1261 | name Set.set | |
1262 | ||
1263 | fun tonToString (TEST t) = "TEST t" | |
1264 | | tonToString (NAME n) = "NAME " ^ n | |
1265 | | tonToString NEITHER = "NEITHER" | |
1266 | ||
1267 | fun sep (a, b) = a ^ ", " ^ b | |
1268 | ||
1269 | fun dagToString (D(t, sel, rt, s)) = | |
1270 | "D([" ^ PrintAbs.str (Set.set t) ^ "]" ^ | |
1271 | "fn, " ^ (tonToString rt) ^ ", " ^ (fold sep (Set.set s) ")") | |
1272 | ||
1273 | val make = D(Set.makeEQ teq, fn x => raise DAGnotfound, NEITHER, Set.make) | |
1274 | ||
1275 | fun newdag x = D x | |
1276 | ||
1277 | fun tests_of(D (b, sel, r, h)) = b | |
1278 | fun sel_of(D (b, sel, r, h)) = sel | |
1279 | fun root_of(D (b, sel, r, h)) = r | |
1280 | fun succ_of(D (b, sel, r, h)) = h | |
1281 | ||
1282 | fun attach (t, D dt, D df) = | |
1283 | let open Set | |
1284 | val (b1, sel1, r1, h1) = dt | |
1285 | val (b2, sel2, r2, h2) = df | |
1286 | in | |
1287 | D(add(union(b1, b2), t), | |
1288 | (fn(x, y) => | |
1289 | if teq(x, t) then if y then r1 else r2 | |
1290 | else sel1(x, y) handle DAGnotfound => sel2(x, y)), | |
1291 | TEST t, | |
1292 | union(h1,h2) | |
1293 | ) | |
1294 | end | |
1295 | ||
1296 | fun reach (D d, tn) = | |
1297 | let open Set | |
1298 | val (b, sel, r, h) = d | |
1299 | fun f (TEST t) = | |
1300 | if not (member(b, t)) then raise DAGnotfound | |
1301 | else attach(t, reach(D d, sel(t, true)), reach(D d, sel(t, false))) | |
1302 | | f (NAME n) = | |
1303 | D(makeEQ teq, fn x => raise DAGnotfound, NAME n, listToSet [n]) | |
1304 | | f (_) = raise DAGnotfound | |
1305 | in | |
1306 | f tn | |
1307 | end | |
1308 | ||
1309 | fun replace_edge (D d, nil) = D d | |
1310 | | replace_edge (D d, old::new::tl) = | |
1311 | let open Set | |
1312 | val (b, sel, r, h) = d | |
1313 | val nh = if member(h, old) then add(rm(h, old), new) else h | |
1314 | val nr = if toneq(r, NAME old) then NAME new else r | |
1315 | val nsel = fn(x, y) => | |
1316 | let val v = sel(x, y) | |
1317 | in | |
1318 | if toneq(v, NAME old) then NAME new else v | |
1319 | end | |
1320 | in | |
1321 | D (b, nsel, nr, nh) | |
1322 | end | |
1323 | | replace_edge _ = raise DAG | |
1324 | ||
1325 | end | |
1326 | ||
1327 | ||
1328 | ||
1329 | ||
1330 | ||
1331 | ||
1332 | ||
1333 | ||
1334 | ||
1335 | ||
1336 | ||
1337 | ||
1338 | ||
1339 | ||
1340 | ||
1341 | ||
1342 | structure Node : | |
1343 | sig | |
1344 | type node | |
1345 | type program | |
1346 | val delete_debug : bool ref | |
1347 | val move_op_debug : bool ref | |
1348 | val move_test_debug : bool ref | |
1349 | val rw_debug : bool ref | |
1350 | val ntn_debug : bool ref | |
1351 | val prog_node_debug : bool ref | |
1352 | val prog_node_debug_verbose : bool ref | |
1353 | val closure_progs_debug : bool ref | |
1354 | val cpsiCheck : bool ref | |
1355 | val makeProg : unit -> program | |
1356 | val make : | |
1357 | Ntypes.name * Ntypes.assignment Set.set * | |
1358 | Dag.dag * Ntypes.name Set.set-> node | |
1359 | val name_of : node -> Ntypes.name | |
1360 | val assignment_of : node -> Ntypes.assignment Set.set | |
1361 | val dag_of : node -> Dag.dag | |
1362 | val succ : program * node -> Ntypes.name Set.set | |
1363 | val prednm : program * Ntypes.name -> Ntypes.name Set.set | |
1364 | val pred : program * node -> Ntypes.name Set.set | |
1365 | val succNodes : program * node -> node Set.set | |
1366 | val predNodes : program * node -> node Set.set | |
1367 | val readNode : node -> int Set.set | |
1368 | val writeNode : node -> int Set.set | |
1369 | val unreachable : program * node -> bool | |
1370 | val num_ops_node : node -> int | |
1371 | val num_tests_node : node -> int | |
1372 | val num_things_node : node -> int | |
1373 | val replace_edge_node : node * string list -> node | |
1374 | exception NAMETONODE | |
1375 | val nameToNode : program * Ntypes.name -> node | |
1376 | val nameSetToNodeSet : program * Ntypes.name Set.set -> node Set.set | |
1377 | val eqn : node * node -> bool | |
1378 | val n00 : node | |
1379 | val fin : node | |
1380 | val delete : program * node -> program | |
1381 | val move_op : | |
1382 | program * Ntypes.assignment * node Set.set * node -> program | |
1383 | val move_test : program * Ntypes.test * node * node -> program | |
1384 | val nodeToString : node -> string | |
1385 | val progToString : program -> string | |
1386 | val entries : program -> node list | |
1387 | val programs : program -> program list | |
1388 | val addPredInfo : program -> program | |
1389 | val closure : program * node -> program | |
1390 | val sortNodes : node list -> node list | |
1391 | val updateNode : program * node -> program | |
1392 | val addNode : program * node -> program | |
1393 | val rmNode : program * node -> program | |
1394 | end = | |
1395 | struct | |
1396 | ||
1397 | open Ntypes | |
1398 | open Dag | |
1399 | open StrPak | |
1400 | datatype node = N of name * assignment Set.set * dag * name Set.set | |
1401 | type program = node Stringmap.stringmap * node * node | |
1402 | ||
1403 | type debug_fun = unit -> string | |
1404 | val delete_debug = ref false | |
1405 | val move_op_debug = ref false | |
1406 | val dead_set_debug = ref false | |
1407 | val move_test_debug = ref false | |
1408 | val rw_debug = ref false | |
1409 | val prog_node_debug = ref false | |
1410 | val prog_node_debug_verbose = ref false | |
1411 | val closure_progs_debug = ref false | |
1412 | ||
1413 | fun name_of(N(n, a, d, prd)) = n | |
1414 | fun assignment_of(N(n, a, d, prd)) = a | |
1415 | fun dag_of(N(n, a, d, prd)) = d | |
1416 | fun pred_of(N(n, a, d, prd)) = prd | |
1417 | ||
1418 | fun eqn(n1, n2) = name_of n1 = name_of n2 | |
1419 | ||
1420 | val start:name = "START" | |
1421 | val finish:name = "FINISH" | |
1422 | ||
1423 | fun printstringlist sl = stringListString sl | |
1424 | val psl = printstringlist | |
1425 | ||
1426 | fun nodeToString (N(n, a, d, prd)) = | |
1427 | "\nN(" ^ n ^ ", [" ^ PrintAbs.str (Set.set a) ^ "], " ^ | |
1428 | Dag.dagToString d ^ | |
1429 | "pred(" ^ psl (Set.set prd) ^ "))" | |
1430 | ||
1431 | fun progToString (ns, n0, F) = | |
1432 | "P (" ^ (psl o (map nodeToString) o Stringmap.extract) ns ^ ",\n" ^ | |
1433 | nodeToString n0 ^ ",\n" ^ | |
1434 | nodeToString F ^ ")\n" | |
1435 | ||
1436 | fun make (n, a, t, prd) = N(n, a, t, prd) | |
1437 | ||
1438 | val n00 = make(start, Set.makeEQ aeq, Dag.make, Set.make) | |
1439 | val fin = make(finish, Set.makeEQ aeq, Dag.make, Set.make) | |
1440 | ||
1441 | fun makeProg() = (Stringmap.new():node Stringmap.stringmap, n00, fin) | |
1442 | ||
1443 | fun addPredNode (N(n, a, t, prd), p) = (N(n, a, t, Set.add(prd, p))) | |
1444 | fun unionPredNode (N(n, a, t, prd), ps) = (N(n, a, t, Set.union(prd, ps))) | |
1445 | fun setPredNode (N(n, a, t, prd), p) = (N(n, a, t, p)) | |
1446 | fun rmPredNode (N(n, a, t, prd), p) = (N(n, a, t, Set.rm(prd, p))) | |
1447 | ||
1448 | fun p_n_debug (f:debug_fun) = | |
1449 | if !prog_node_debug then print ("p_n:" ^ f() ^ "\n") | |
1450 | else () | |
1451 | ||
1452 | ||
1453 | fun updateNode(P as (ns, n0, F), new_node) = | |
1454 | let val answer = | |
1455 | (Stringmap.rm (ns:node Stringmap.stringmap) | |
1456 | ((name_of new_node):string); | |
1457 | Stringmap.add ns ((name_of new_node), new_node); | |
1458 | if name_of new_node = name_of n0 then (ns, new_node, F) | |
1459 | else if name_of new_node = name_of F then (ns, n0, new_node) | |
1460 | else P) | |
1461 | val foo = p_n_debug | |
1462 | (fn () => | |
1463 | ("updateNode n=" ^ nodeToString new_node ^ | |
1464 | "=>" ^ | |
1465 | (if !prog_node_debug_verbose then progToString answer | |
1466 | else "(program)"))) | |
1467 | in | |
1468 | answer | |
1469 | end | |
1470 | ||
1471 | fun addNode(P as (ns, n0, F), new_node) = | |
1472 | let val answer = | |
1473 | if Stringmap.isin ns (name_of new_node) then updateNode(P, new_node) | |
1474 | else (Stringmap.add ns ((name_of new_node), new_node); | |
1475 | P) | |
1476 | val foo = p_n_debug | |
1477 | (fn () => | |
1478 | ("addNode n=" ^ nodeToString new_node ^ | |
1479 | "=>" ^ | |
1480 | (if !prog_node_debug_verbose then progToString answer | |
1481 | else "(program)"))) | |
1482 | in | |
1483 | answer | |
1484 | end | |
1485 | ||
1486 | ||
1487 | fun rmNode(P as (ns, n0, F), node) = | |
1488 | let val answer = (Stringmap.rm ns (name_of node); | |
1489 | P) | |
1490 | val foo = p_n_debug | |
1491 | (fn () => | |
1492 | ("rmNode n=" ^ nodeToString node ^ | |
1493 | "=>" ^ | |
1494 | (if !prog_node_debug_verbose then progToString answer | |
1495 | else "(program)"))) | |
1496 | in | |
1497 | answer | |
1498 | end | |
1499 | ||
1500 | ||
1501 | fun succ(p, n) = (succ_of o dag_of) n | |
1502 | fun pred(p, n) = pred_of n | |
1503 | ||
1504 | val ntn_debug = ref true | |
1505 | fun ntnPrint (f:debug_fun) = if !ntn_debug then print ("ntn:" ^ f() ^ "\n") else () | |
1506 | ||
1507 | exception NAMETONODE | |
1508 | fun nameToNode(P as (ns, n0, F), nm) = | |
1509 | Stringmap.map ns nm | |
1510 | handle Stringmap => | |
1511 | (ntnPrint (fn () => ("nameToNode " ^ nm ^ "not found")); | |
1512 | raise NAMETONODE) | |
1513 | ||
1514 | exception NAMESETTONODESET | |
1515 | fun nameSetToNodeSet(P, ns) = | |
1516 | Set.listToSetEQ(eqn, map (fn x => nameToNode(P, x)) (Set.set ns)) | |
1517 | handle NAMETONODE => raise NAMESETTONODESET | |
1518 | ||
1519 | fun prednm(p, nm) = pred(p, nameToNode(p, nm)) | |
1520 | ||
1521 | fun succNodes (p, n) = nameSetToNodeSet(p, succ(p, n)) | |
1522 | fun predNodes (p, n) = nameSetToNodeSet(p, pred(p, n)) | |
1523 | ||
1524 | ||
1525 | (* a correctness assertion *) | |
1526 | exception CPSI | |
1527 | val cpsiCheck = ref false | |
1528 | fun checkPredSuccInfo(from, P as (ns, n0, F)) = | |
1529 | let val nl = Stringmap.extract ns | |
1530 | val badnode = ref n0 | |
1531 | fun fail s = (print ("CPSI:" ^ s ^ " failed\nfrom " ^ from ^ | |
1532 | "\nbadnode=" ^ nodeToString (!badnode) ^ | |
1533 | "\nprogram=" ^ progToString P ^ "\n"); | |
1534 | raise CPSI) | |
1535 | fun chk (xpred, xsuccN, n) = | |
1536 | let val foo = badnode := n | |
1537 | val s = Set.set(xsuccN(P, n)) | |
1538 | handle NAMESETTONODESET => | |
1539 | fail "NAMESETTONODESET" | |
1540 | fun cs x = Set.member(xpred x, name_of n) | |
1541 | fun fs (x, b) = b andalso cs x | |
1542 | in | |
1543 | fold fs s true | |
1544 | end | |
1545 | fun cp (x, b) = b andalso chk(pred_of, succNodes, x) | |
1546 | fun cs (x, b) = b andalso chk((succ_of o dag_of), predNodes, x) | |
1547 | in | |
1548 | if not (fold cp nl true) then fail "cp" | |
1549 | else if not (fold cs nl true) then fail "cs" | |
1550 | else () | |
1551 | end | |
1552 | fun cpsi x = if !cpsiCheck then checkPredSuccInfo x else () | |
1553 | ||
1554 | ||
1555 | fun empty n = | |
1556 | let open Set in | |
1557 | empty (assignment_of n) andalso empty ((tests_of o dag_of) n) | |
1558 | end | |
1559 | ||
1560 | fun unreachable(P as (ns, n0, F), n) = | |
1561 | not (eqn (n0, n)) andalso Set.empty (pred(P, n)) | |
1562 | ||
1563 | fun read (TST(t)) = HM.read_c t | |
1564 | | read (ASS(a)) = HM.read_o a | |
1565 | ||
1566 | fun write (TST(t)) = HM.write_c t | |
1567 | | write (ASS(a)) = HM.write_o a | |
1568 | ||
1569 | fun read_write_debug (f:debug_fun) = | |
1570 | if !rw_debug then print (f() ^ "\n") | |
1571 | else () | |
1572 | ||
1573 | fun readNode n = | |
1574 | let open Set | |
1575 | val answer = | |
1576 | union | |
1577 | (listUnion (make::(map (read o ASS) ((set o assignment_of) n))), | |
1578 | listUnion (make::(map | |
1579 | (read o TST) ((set o tests_of o dag_of) n)))) | |
1580 | val foo = read_write_debug | |
1581 | (fn () => | |
1582 | ("readNode " ^ nodeToString n ^ "=>" ^ | |
1583 | stringListString (map makestring (set answer)))) | |
1584 | in | |
1585 | answer | |
1586 | end | |
1587 | ||
1588 | fun writeNode n = | |
1589 | let open Set | |
1590 | val answer = | |
1591 | union | |
1592 | (listUnion (make::(map (write o ASS) ((set o assignment_of) n))), | |
1593 | listUnion (make::(map | |
1594 | (write o TST) ((set o tests_of o dag_of) n)))) | |
1595 | val foo = read_write_debug | |
1596 | (fn () => | |
1597 | ("writeNode " ^ nodeToString n ^ "=>" ^ | |
1598 | stringListString (map makestring (set answer)))) | |
1599 | in | |
1600 | answer | |
1601 | end | |
1602 | ||
1603 | fun no_write_conflict (ta, n) = | |
1604 | let open Set in | |
1605 | empty (intersect(writeNode n, (union(read ta, write ta)))) | |
1606 | end | |
1607 | ||
1608 | fun no_read_conflict (ta, n) = | |
1609 | let open Set in | |
1610 | empty (intersect (write ta, readNode n)) | |
1611 | end | |
1612 | ||
1613 | fun empty n = | |
1614 | let open Set in | |
1615 | (empty o assignment_of) n andalso (empty o tests_of o dag_of) n | |
1616 | end | |
1617 | ||
1618 | fun replace_edge_node(N (n, a, d, p), nl) = N(n, a, replace_edge(d, nl), p) | |
1619 | ||
1620 | fun except_bogus nil = nil | |
1621 | | except_bogus (h::t) = | |
1622 | if Delay.is_bogus_i h then except_bogus t else h :: except_bogus t | |
1623 | ||
1624 | val num_ops_node = List.length o except_bogus o Set.set o assignment_of | |
1625 | val num_tests_node = List.length o Set.set o tests_of o dag_of | |
1626 | fun num_things_node n = (num_ops_node n) + (num_tests_node n) | |
1627 | ||
1628 | fun dead_debug (f:debug_fun) = | |
1629 | if !dead_set_debug then print ("dead" ^ f() ^ "\n") else () | |
1630 | ||
1631 | exception DEAD | |
1632 | fun dead(P:program, r:HM.reg, n:node, done: name Set.set) = | |
1633 | let val foo = | |
1634 | dead_debug (fn () => "(P, " ^ makestring r ^ ", " ^ nodeToString n ^ ")") | |
1635 | val new_done = Set.add(done, name_of n) | |
1636 | fun nfil(a, b) = if Set.member(new_done, a) then b | |
1637 | else a::b | |
1638 | fun drl nil = true | |
1639 | | drl (h::t) = dead(P, r, h, new_done) andalso drl t | |
1640 | fun ntn n = nameToNode (P, n) handle NAMETONODE => raise DEAD | |
1641 | val next = fold nfil (Set.set (succ(P, n))) nil | |
1642 | val answer = ( | |
1643 | not (Set.member(readNode n, r)) andalso | |
1644 | (Set.member(writeNode n, r) orelse | |
1645 | drl (map ntn next)) | |
1646 | ) | |
1647 | val foo = dead_debug(fn () => "=>" ^ Bool.toString answer) | |
1648 | in | |
1649 | answer | |
1650 | end | |
1651 | ||
1652 | fun deadset(P, rs, n) = | |
1653 | let val foo = dead_debug (fn () => "deadset(" ^ | |
1654 | stringListString | |
1655 | (map makestring (Set.set rs)) ^ ",\n" ^ | |
1656 | nodeToString n ^ ")") | |
1657 | fun f nil = true | |
1658 | | f (r::t) = dead(P, r, n, Set.make) andalso f t | |
1659 | val answer = f (Set.set rs) | |
1660 | val foo = dead_debug(fn () => "deadset=>" ^ Bool.toString answer ^ "\n") | |
1661 | in | |
1662 | answer | |
1663 | end | |
1664 | ||
1665 | fun del_debug (f:debug_fun) = | |
1666 | if !delete_debug then print ("delete:" ^ f() ^ "\n") | |
1667 | else () | |
1668 | ||
1669 | exception DELETE | |
1670 | exception DELETE_HD | |
1671 | exception DELETE_WIERDSUCC | |
1672 | fun delete (P as (ns, n0, F), n) = | |
1673 | let val foo = cpsi("delete enter", P) | |
1674 | val em = empty n | |
1675 | val un = unreachable(P, n) | |
1676 | fun ntn n = nameToNode(P, n) handle NAMETONODE => raise DELETE | |
1677 | val p = Set.listToSetEQ(eqn, (map ntn (Set.set (pred(P, n))))) | |
1678 | open Set | |
1679 | ||
1680 | val foo = del_debug | |
1681 | (fn () => | |
1682 | "delete( n=" ^ (name_of n) ^ "\n" ^ | |
1683 | "em=" ^ (Bool.toString em) ^ "\n" ^ | |
1684 | "un=" ^ (Bool.toString un) ^ "\n" ^ | |
1685 | "p =" ^ (psl (map name_of (Set.set p))) ^ "\n" ^ | |
1686 | ")") | |
1687 | in | |
1688 | if (em orelse un) andalso not (eqn(n, F)) then | |
1689 | if not un then | |
1690 | let | |
1691 | val foo = del_debug (fn () => "complex deletion") | |
1692 | val s0 = Set.set (succ(P, n)) | |
1693 | val nprime = if List.length s0 = 1 then hd s0 | |
1694 | else (print (Int.toString (List.length s0)); | |
1695 | raise DELETE_WIERDSUCC) | |
1696 | val new_nprime = | |
1697 | rmPredNode(unionPredNode(ntn nprime, pred_of n), | |
1698 | name_of n) | |
1699 | fun ren x = | |
1700 | replace_edge_node(x, [name_of n, name_of new_nprime]) | |
1701 | val pprime = map ren (set p) | |
1702 | fun updt(n, p) = updateNode(p, n) | |
1703 | val Nprime = fold updt (new_nprime :: pprime) P | |
1704 | ||
1705 | val foo = del_debug (fn () => "nprime=" ^ nprime) | |
1706 | val foo = del_debug | |
1707 | (fn () => | |
1708 | "pprime=" ^ (psl (map nodeToString pprime))) | |
1709 | val answer = rmNode(Nprime, n) | |
1710 | val foo = cpsi("delete leave cd", answer) | |
1711 | in | |
1712 | answer | |
1713 | end | |
1714 | else (del_debug (fn () => "simple_deletion"); | |
1715 | let val s = Set.set(nameSetToNodeSet(P, (succ(P, n)))) | |
1716 | fun updt(s, p) = updateNode(p, rmPredNode(s, name_of n)) | |
1717 | val np = rmNode(fold updt s P, n) | |
1718 | val foo = cpsi("delete leave sd", np) | |
1719 | in | |
1720 | np | |
1721 | end) | |
1722 | else (del_debug (fn () => "No deletion"); | |
1723 | P) | |
1724 | end handle Hd => raise DELETE_HD | |
1725 | ||
1726 | fun mop_debug (f:debug_fun) = | |
1727 | if !move_op_debug then | |
1728 | (dead_set_debug := true; | |
1729 | print ("mop:" ^ f() ^ "\n")) | |
1730 | else dead_set_debug := false | |
1731 | ||
1732 | ||
1733 | fun can_move_op1(P as (ns, n0, F), x, move_set, m) = | |
1734 | let open Set | |
1735 | val foo = mop_debug (fn () => "can_move_op") | |
1736 | val rok = HM.resources_ok(set (add(assignment_of m, x)), | |
1737 | set ((tests_of o dag_of) m)) | |
1738 | val foo = mop_debug(fn () => "1") | |
1739 | val p = diff(nameSetToNodeSet(P, succ(P, m)), move_set) | |
1740 | val foo = mop_debug(fn () => "2") | |
1741 | val l = (write o ASS) x | |
1742 | val foo = mop_debug(fn () => "3") | |
1743 | fun dlpf nil = true | |
1744 | | dlpf (pj::t) = deadset(P, l, pj) andalso dlpf t | |
1745 | fun cond nil = true | |
1746 | | cond (nj::t) = | |
1747 | (not o eqn)(nj, F) andalso | |
1748 | (* no_read_conflict(ASS x, nj) andalso *) | |
1749 | (* change ex model so it can run on a sequential machine *) | |
1750 | no_read_conflict(ASS x, m) andalso | |
1751 | no_write_conflict(ASS x, m) andalso | |
1752 | cond t | |
1753 | val foo = mop_debug(fn () => "4") | |
1754 | val answer = rok andalso cond (set move_set) andalso dlpf (set p) | |
1755 | val foo = mop_debug (fn () => "can_move_op=>" ^ Bool.toString answer) | |
1756 | in | |
1757 | answer | |
1758 | end | |
1759 | ||
1760 | fun can_move_op(P, x, move_set, m) = | |
1761 | let open Set | |
1762 | val ms = set move_set | |
1763 | fun pf n = pred(P, n) | |
1764 | val ps = set(listUnion (map pf ms)) | |
1765 | fun all (x, b) = b andalso can_move_op1(P, x, move_set, m) | |
1766 | in | |
1767 | if List.length ps > 1 then | |
1768 | if List.length ms > 1 then false | |
1769 | else fold all ((set o assignment_of o hd) ms) true | |
1770 | else can_move_op1(P, x, move_set, m) | |
1771 | end | |
1772 | ||
1773 | fun move_op (P as (ns, n0, F), x, move_set, m) = | |
1774 | let val foo = cpsi("move_op enter", P) | |
1775 | val foo = | |
1776 | mop_debug (fn () => | |
1777 | "move_op(x=" ^ | |
1778 | PrintAbs.str [x] ^ | |
1779 | "move_set\n" ^ | |
1780 | (stringListString (map nodeToString | |
1781 | (Set.set move_set))) ^ | |
1782 | "\nm=" ^ nodeToString m ^"\n)\n") | |
1783 | in | |
1784 | if not (can_move_op(P, x, move_set, m)) then P | |
1785 | else | |
1786 | let open Set | |
1787 | exception NOTFOUND | |
1788 | val primed_pairs = ref nil | |
1789 | fun pnf nm = | |
1790 | let fun f nil = | |
1791 | let val nn = prime_name nm | |
1792 | in | |
1793 | (primed_pairs := (nm, nn) :: !primed_pairs; | |
1794 | nn) | |
1795 | end | |
1796 | | f ((a, b)::t) = if nm = a then b else f t | |
1797 | val answer = f (!primed_pairs) | |
1798 | val foo = mop_debug (fn () => "pnf " ^ nm ^ "=>" ^ answer) | |
1799 | in | |
1800 | answer | |
1801 | end | |
1802 | val foo = mop_debug(fn () => "1") | |
1803 | fun njp nil = nil | |
1804 | | njp ((N(n, a, d, prd))::t) = | |
1805 | N(pnf n, rm(a, x), d, listToSet [name_of m]) :: njp t | |
1806 | fun ojp l = map (fn x => rmPredNode(x, name_of m)) l | |
1807 | fun replist nil = nil | |
1808 | | replist (h::t) = h :: pnf h :: replist t | |
1809 | val rlist = replist (map name_of (set move_set)) | |
1810 | val foo = mop_debug(fn () => "2") | |
1811 | val mprime = | |
1812 | let val aprime = add(assignment_of m, x) | |
1813 | val dprime = replace_edge(dag_of m, rlist) | |
1814 | in | |
1815 | N(name_of m, aprime, dprime, pred_of m) | |
1816 | end | |
1817 | val foo = mop_debug(fn () => "3") | |
1818 | val nj = njp(set move_set) | |
1819 | val foo = mop_debug(fn () => | |
1820 | "nj=" ^ | |
1821 | stringListString (map name_of nj)) | |
1822 | fun uptd(n, p) = updateNode(p, n) | |
1823 | val np = fold uptd (mprime :: (ojp (set move_set))) P | |
1824 | fun addnpi(n, p) = | |
1825 | let val s = set (succNodes(p, n)) | |
1826 | fun ap x = addPredNode(x, name_of n) | |
1827 | fun updt(x, p) = updateNode(p, ap x) | |
1828 | in | |
1829 | fold updt s p | |
1830 | end | |
1831 | fun addn(n, p) = addnpi(n, addNode(p, n)) | |
1832 | val nnp = fold addn nj np | |
1833 | val foo = mop_debug(fn () => "4") | |
1834 | val answer = nnp | |
1835 | val foo = mop_debug(fn () => "5") | |
1836 | val foo = cpsi("move_op leave", answer) | |
1837 | in | |
1838 | mop_debug(fn () => "6"); | |
1839 | answer | |
1840 | end | |
1841 | end | |
1842 | ||
1843 | fun updt_sel (d, nsel) = | |
1844 | let val tst = tests_of d | |
1845 | val rt = root_of d | |
1846 | val s = succ_of d | |
1847 | in | |
1848 | newdag(tst, nsel, rt, s) | |
1849 | end | |
1850 | ||
1851 | fun mt_debug (f:debug_fun) = | |
1852 | if !move_test_debug then print ("move_test" ^ f() ^ "\n") | |
1853 | else () | |
1854 | ||
1855 | fun can_move_test(P as (ns, n0, F):program, x:test, n:node, m:node) = | |
1856 | let val foo = cpsi("move_test enter", P) | |
1857 | val foo = mt_debug (fn () => "can_move_test") | |
1858 | val answer = | |
1859 | no_write_conflict(TST x, m) andalso | |
1860 | ||
1861 | (* hack because sel can't distinguish xj *) | |
1862 | not (Set.member(tests_of(dag_of m), x)) andalso | |
1863 | ||
1864 | HM.resources_ok(Set.set (assignment_of m), | |
1865 | Set.set (Set.add((tests_of o dag_of) m, x))) | |
1866 | val foo = mt_debug (fn () => "can_move_test=>" ^ Bool.toString answer) | |
1867 | in | |
1868 | answer | |
1869 | end | |
1870 | ||
1871 | fun move_test (P as (ns, n0, F):program, x:test, n:node, m:node) = | |
1872 | if not (can_move_test(P, x, n, m)) then P | |
1873 | else | |
1874 | let val foo = | |
1875 | mt_debug (fn () => "move_test" ^ name_of n ^ " " ^ name_of m) | |
1876 | open Set | |
1877 | val d_n = dag_of n | |
1878 | val sel_n = sel_of d_n | |
1879 | val rt_n = root_of d_n | |
1880 | val nt = | |
1881 | let val newname = (new_name o name_of) n ^ "tt" | |
1882 | fun nsel (z, b) = | |
1883 | let val v = sel_n(z, b) in | |
1884 | if toneq(v, TEST x) then sel_n(x, true) | |
1885 | else v | |
1886 | end | |
1887 | val nC = | |
1888 | if TEST x = rt_n then | |
1889 | reach(updt_sel(d_n, nsel), sel_n(x, true)) | |
1890 | else | |
1891 | reach(updt_sel(d_n, nsel), rt_n) | |
1892 | in | |
1893 | N(newname, assignment_of n, nC, listToSet [name_of m]) | |
1894 | end | |
1895 | val foo = mt_debug (fn () => "got nt") | |
1896 | val nf = | |
1897 | let val newname = ((new_name o name_of) n) ^ "ff" | |
1898 | fun nsel (z, b) = | |
1899 | let val v = sel_n(z, b) in | |
1900 | if toneq(v, TEST x) then sel_n(x, false) | |
1901 | else v | |
1902 | end | |
1903 | val nC = | |
1904 | if TEST x = rt_n then | |
1905 | reach(updt_sel(d_n, nsel), sel_n(x, false)) | |
1906 | else | |
1907 | reach(updt_sel(d_n, nsel), rt_n) | |
1908 | in | |
1909 | N(newname, assignment_of n, nC, listToSet [name_of m]) | |
1910 | end | |
1911 | val foo = mt_debug (fn () => "got nf") | |
1912 | val d_m = dag_of m | |
1913 | val sel_m = sel_of d_m | |
1914 | fun nton n = NAME( name_of n) | |
1915 | fun nsel (z, b) = | |
1916 | if teq(z, x) then if b then nton nt else nton nf | |
1917 | else | |
1918 | let val v = sel_m(z, b) in | |
1919 | if toneq(v, NAME(name_of n)) then TEST x else v | |
1920 | end | |
1921 | val nb = add(tests_of d_m, x) | |
1922 | val nh = | |
1923 | add(add(rm(succ_of d_m, name_of n), name_of nt), name_of nf) | |
1924 | fun new_rt (NAME rt) = TEST x | |
1925 | | new_rt t = t | |
1926 | val nc = newdag(nb, nsel, (new_rt o root_of) d_m, nh) | |
1927 | val new_m = N(name_of m, assignment_of m, nc, pred_of m) | |
1928 | fun updt_t s = addPredNode(s, name_of nt) | |
1929 | fun updt_f s = addPredNode(s, name_of nf) | |
1930 | val upt = map updt_t (set (nameSetToNodeSet(P, succ(P, nt)))) | |
1931 | val upf = map updt_f (set (nameSetToNodeSet(P, succ(P, nf)))) | |
1932 | fun updtl(n, p) = updateNode(p, n) | |
1933 | val np = | |
1934 | fold updtl ([rmPredNode(n, name_of m), new_m] @ upt @ upf) P | |
1935 | val answer = np | |
1936 | val foo = mt_debug (fn () => "mtst done") | |
1937 | val foo = cpsi("move_test leave", answer) | |
1938 | in | |
1939 | answer | |
1940 | end | |
1941 | ||
1942 | ||
1943 | fun entries (P as (ns, n0, F)) = | |
1944 | let val nl = Stringmap.extract ns | |
1945 | fun f (a, b) = if unreachable(P, a) then a::b else b | |
1946 | in | |
1947 | n0 :: (fold f nl nil) | |
1948 | end | |
1949 | ||
1950 | fun addPredInfo(P as (ns, n0, F)) = | |
1951 | let fun rmpi n = setPredNode (n, Set.make) | |
1952 | val nl = map rmpi (Stringmap.extract ns) | |
1953 | fun updt(n, p) = updateNode(p, n) | |
1954 | val np = fold updt nl P | |
1955 | fun addpi (n, p) = | |
1956 | let val s = Set.set (succNodes(p, n)) | |
1957 | fun api(s, p) = updateNode(p, addPredNode(s, name_of n)) | |
1958 | in | |
1959 | fold api s p | |
1960 | end | |
1961 | in | |
1962 | fold addpi nl np | |
1963 | end | |
1964 | ||
1965 | fun cp_debug (f:debug_fun) = | |
1966 | if !closure_progs_debug then print ("cp:" ^ f() ^ "\n") | |
1967 | else () | |
1968 | ||
1969 | fun closure (P as (ns, n0, F), entry) = | |
1970 | let open Set | |
1971 | val foo = cp_debug | |
1972 | (fn () => | |
1973 | "closure:entry=" ^ name_of entry ^ "\nprogram=" ^ progToString P) | |
1974 | val isin = Stringmap.isin | |
1975 | fun dfs(p, parent, nil) = p | |
1976 | | dfs(p as (ns, n0, F), parent, cur::todo) = | |
1977 | if not (isin ns (name_of cur)) then | |
1978 | let val np = dfs(addNode(p, cur), cur, set(succNodes(P, cur))) | |
1979 | in | |
1980 | dfs(np, parent, todo) | |
1981 | end | |
1982 | else dfs(p, parent, todo) | |
1983 | val prog:program = (Stringmap.new(), entry, F) | |
1984 | val answer = dfs(addNode(prog, entry), | |
1985 | entry, | |
1986 | set(succNodes(P, entry))) | |
1987 | val foo = cp_debug | |
1988 | (fn () => | |
1989 | "\nclosure=>" ^ progToString answer) | |
1990 | in | |
1991 | answer | |
1992 | end | |
1993 | ||
1994 | fun programs(P as (ns, n0, F):program) = | |
1995 | let val foo = cp_debug (fn () => "programs") | |
1996 | val l = entries (addPredInfo P) | |
1997 | (* make sure preds are in closure*) | |
1998 | fun cf e = addPredInfo(closure(P, e)) | |
1999 | val answer = map cf l | |
2000 | val foo = cp_debug (fn () => "programs done") | |
2001 | in | |
2002 | answer | |
2003 | end | |
2004 | ||
2005 | structure ns = | |
2006 | struct | |
2007 | type obj = node | |
2008 | ||
2009 | fun int l = | |
2010 | let val z = ord "0" | |
2011 | fun f(n, nil) = n | |
2012 | | f (n, d::l) = | |
2013 | if d>="0" andalso d<="9" then f(n*10+ord(d)-z, l) | |
2014 | else n | |
2015 | in | |
2016 | f(0,l) | |
2017 | end | |
2018 | ||
2019 | fun gt (a, b) = | |
2020 | let val a = explode(name_of a) | |
2021 | val b = explode(name_of b) | |
2022 | in | |
2023 | (int a) > (int b) | |
2024 | end | |
2025 | end | |
2026 | ||
2027 | structure sortN = Sort(ns) | |
2028 | ||
2029 | val sortNodes = sortN.sort | |
2030 | ||
2031 | end | |
2032 | ||
2033 | structure Compress : | |
2034 | sig | |
2035 | val compress_debug : bool ref | |
2036 | val compress : (int * Node.program) -> Node.program | |
2037 | val move_things_node : | |
2038 | Node.program * Ntypes.name * Ntypes.name Set.set -> Node.program | |
2039 | val do_move_tests : bool ref | |
2040 | val do_move_ops : bool ref | |
2041 | ||
2042 | val dbg_p : Node.program ref | |
2043 | ||
2044 | end = | |
2045 | ||
2046 | struct | |
2047 | ||
2048 | open Ntypes | |
2049 | open Dag | |
2050 | open Node | |
2051 | ||
2052 | val do_move_tests = ref false | |
2053 | val do_move_ops = ref true | |
2054 | ||
2055 | exception COMPRESS | |
2056 | ||
2057 | fun error (s:string) = | |
2058 | (print (s ^ "\n"); | |
2059 | raise COMPRESS) | |
2060 | ||
2061 | val compress_debug = ref false | |
2062 | ||
2063 | val dbg_p = ref (makeProg()) | |
2064 | ||
2065 | type debug_fun = unit -> string | |
2066 | fun debug (f:debug_fun) = | |
2067 | if !compress_debug then print (f() ^ "\n") | |
2068 | else () | |
2069 | ||
2070 | exception FILTERSUCC | |
2071 | ||
2072 | fun filterSucc(P, nm, fence_set) = | |
2073 | let open Set | |
2074 | val s = set(succ(P, nameToNode(P, nm))) | |
2075 | handle NAMETONODE => raise FILTERSUCC | |
2076 | fun f (nm, l) = if member(fence_set, nm) then l else nm::l | |
2077 | in | |
2078 | fold f s nil | |
2079 | end | |
2080 | ||
2081 | (* | |
2082 | val inP = ref false | |
2083 | val finP = ref makeProg | |
2084 | val foutP = ref makeProg | |
2085 | ||
2086 | fun chinP (p, from) = | |
2087 | let val nm = "11_100'_110tt_119'" | |
2088 | val prd = prednm(p, nm) | |
2089 | val pe = Set.empty(prd) | |
2090 | in | |
2091 | if !inP then | |
2092 | if pe then (foutP := p; error ("chinP gone -" ^ from)) else () | |
2093 | else if pe then () | |
2094 | else (inP := true; | |
2095 | print ("chinP found it -" ^ from ^ "\n"); | |
2096 | finP := p; | |
2097 | nameToNode(p, nm); | |
2098 | ()) | |
2099 | end | |
2100 | *) | |
2101 | ||
2102 | exception MOVETHINGSNODE | |
2103 | fun move_things_node(P, nm, fence_set) = | |
2104 | let open Set | |
2105 | (* | |
2106 | val foo = debug | |
2107 | (fn () => | |
2108 | "move_things_node(\n" ^ | |
2109 | progToString P ^ ",\n" ^ | |
2110 | nm ^ ", [" ^ | |
2111 | fold (fn (a, b) => a ^ ", " ^ b) (set fence_set) "]" ^ | |
2112 | ")") | |
2113 | *) | |
2114 | fun ntn (p, nm) = ((* chinP (p, "ntn");*) nameToNode (p, nm)) | |
2115 | handle NAMETONODE => (dbg_p := P; raise MOVETHINGSNODE) | |
2116 | fun s_nm_list p = filterSucc(p, nm, fence_set) | |
2117 | fun nd nm = ntn(P, nm) handle MOVETHINGSNODE => error "nd nm" | |
2118 | val au = listUnionEQ(aeq, map (assignment_of o nd) (s_nm_list P)) | |
2119 | val tu = listUnionEQ(teq, map (tests_of o dag_of o nd) (s_nm_list P)) | |
2120 | fun ms (p, a) = | |
2121 | let fun f(nm, l) = | |
2122 | ((*chinP (p, "ms"); *) | |
2123 | if member(assignment_of(ntn(p, nm)), a) then nm::l | |
2124 | else l | |
2125 | ) | |
2126 | handle MOVETHINGSNODE => (dbg_p := p; error "ms") | |
2127 | in | |
2128 | fold f (s_nm_list p) nil | |
2129 | end | |
2130 | fun move_a1(a, p) = | |
2131 | let val msl = ms (p, a) | |
2132 | val ms_set = nameSetToNodeSet(p, listToSet msl) | |
2133 | fun dms(a, p) = delete(p, ntn(p, a)) | |
2134 | fun mop() = | |
2135 | let val foo = debug (fn () => "mop start " ^ nm) | |
2136 | val new_p = move_op(p, a, ms_set, ntn(p, nm)) | |
2137 | handle MOVETHINGSNODE => error "move_a move_op" | |
2138 | val foo = debug (fn () => "mop end") | |
2139 | in | |
2140 | new_p | |
2141 | end | |
2142 | val mpa = mop() | |
2143 | (* | |
2144 | val foo = chinP(mpa, | |
2145 | "a_move_a amop " ^ nm ^ | |
2146 | StrPak.stringListString | |
2147 | (map name_of (set ms_set))) | |
2148 | *) | |
2149 | val answer = fold dms msl mpa | |
2150 | (* | |
2151 | val foo = chinP(answer, "a_move_a adel") | |
2152 | *) | |
2153 | in | |
2154 | answer | |
2155 | end | |
2156 | fun move_a(a, p) = if !do_move_ops then move_a1(a, p) else p | |
2157 | fun tset (p, t) = | |
2158 | let fun f(nm, l) = | |
2159 | ((*chinP (p, "tset");*) | |
2160 | if member(tests_of(dag_of(ntn(p, nm))), t) then nm::l | |
2161 | else l | |
2162 | ) | |
2163 | handle MOVETHINGSNODE => error "tset" | |
2164 | in | |
2165 | fold f (s_nm_list p) nil | |
2166 | end | |
2167 | fun move_t1(t, p) = | |
2168 | let val ts = tset (p, t) | |
2169 | val answer = | |
2170 | if List.length ts > 0 then | |
2171 | move_test(p, t, | |
2172 | (ntn(p, hd ts) | |
2173 | handle MOVETHINGSNODE => error "move_t 1"), | |
2174 | (ntn(p, nm) | |
2175 | handle MOVETHINGSNODE => error "move_t 2")) | |
2176 | ||
2177 | else p | |
2178 | (*val foo = chinP(answer, "a_move_t")*) | |
2179 | in | |
2180 | answer | |
2181 | end | |
2182 | fun move_t(t, p) = if !do_move_tests then move_t1(t, p) else p | |
2183 | in | |
2184 | debug (fn () => "movethingsnode " ^ nm ^ "\n"); | |
2185 | fold move_t (set tu) (fold move_a (set au) P) | |
2186 | end | |
2187 | ||
2188 | exception MOVETHINGSWINDOW | |
2189 | fun move_things_window(P, w, nm, fence_set) = | |
2190 | let open Set | |
2191 | (* | |
2192 | val foo = debug (fn () => | |
2193 | "move_things_window(\n" ^ | |
2194 | progToString P ^ ",\n" ^ | |
2195 | (makestring w) ^ ", " ^ | |
2196 | nm ^ ", [" ^ | |
2197 | fold (fn (a, b) => a ^ ", " ^ b) (set fence_set) "]" ^ | |
2198 | ")\n") | |
2199 | *) | |
2200 | fun ntn (P, nm) = (nameToNode (P, nm)) | |
2201 | handle NAMETONODE => raise MOVETHINGSWINDOW | |
2202 | val node = ntn(P, nm) | |
2203 | val things = num_things_node node | |
2204 | val s_nm_list = filterSucc(P, nm, fence_set) | |
2205 | fun nxt(nm, p) = | |
2206 | move_things_window(p, w - things, nm, fence_set) | |
2207 | val child_p = if w > things then fold nxt s_nm_list P else P | |
2208 | in | |
2209 | debug (fn () => "movethingswindow " ^ nm ^ "\n"); | |
2210 | move_things_node(child_p, nm, fence_set) | |
2211 | end | |
2212 | ||
2213 | ||
2214 | exception CPRESS | |
2215 | exception CPRESS1 | |
2216 | exception CPRESS2 | |
2217 | exception CPRESS3 | |
2218 | exception CPRESS4 | |
2219 | exception CPRESS5 | |
2220 | fun cpress(window, P, fence_set, everin_fence_set) = | |
2221 | let open Set | |
2222 | fun nxt(nm, p:program) = | |
2223 | ((* dbg_p := p; *) | |
2224 | move_things_window(p, window, nm, fence_set)) | |
2225 | handle MOVETHINGSWINDOW => raise CPRESS1 | |
2226 | val filled = fold nxt (set fence_set) P | |
2227 | handle CPRESS1 => raise CPRESS2 | |
2228 | fun succf nm = succ(filled, nameToNode(filled, nm)) | |
2229 | handle NAMETONODE => raise CPRESS | |
2230 | val nfence_set = listUnion(make::(map succf (set fence_set))) | |
2231 | fun filt(a, l) = if member(everin_fence_set, a) then l else a::l | |
2232 | val f_fence_set = listToSet(fold filt (set nfence_set) nil) | |
2233 | val n_everin_fc = | |
2234 | fold (fn (a, s) => add(s, a)) (set f_fence_set) everin_fence_set | |
2235 | in | |
2236 | debug (fn () => "cpress: fence_set=" ^ | |
2237 | StrPak.stringListString (set fence_set) ^ | |
2238 | "\n f_fence_set =" ^ StrPak.stringListString (set f_fence_set)); | |
2239 | if not (empty f_fence_set) | |
2240 | then cpress(window, filled, f_fence_set, n_everin_fc) | |
2241 | handle CPRESS => raise CPRESS3 | |
2242 | handle CPRESS1 => raise CPRESS4 | |
2243 | handle CPRESS2 => raise CPRESS5 | |
2244 | else filled | |
2245 | end | |
2246 | ||
2247 | fun clean_up (P as (ns, n0, F):program) = | |
2248 | let val foo = debug (fn () => "cleanup") | |
2249 | val clos = closure(P, n0) | |
2250 | val (ns, n0, F) = clos | |
2251 | val l = (map name_of (Stringmap.extract ns)) | |
2252 | fun f (n, p) = | |
2253 | (debug (fn () => "cleanup deleting " ^ n); | |
2254 | delete(p, nameToNode(p, n))) | |
2255 | val answer = fold f l clos | |
2256 | val foo = debug (fn () => "exiting cleanup") | |
2257 | in | |
2258 | answer | |
2259 | end | |
2260 | ||
2261 | fun compress(window, P as (ns, n0, F)) = | |
2262 | let open Set | |
2263 | val fence = n0 | |
2264 | val fence_set = add(make, name_of n0) | |
2265 | val everin_fence_set = add(makeEQ(name_prefix_eq), name_of n0) | |
2266 | val uc = cpress(window, P, fence_set, everin_fence_set) | |
2267 | val cu = clean_up uc | |
2268 | in | |
2269 | debug (fn () => "compress"); | |
2270 | cu | |
2271 | end | |
2272 | ||
2273 | ||
2274 | ||
2275 | end | |
2276 | structure ReadI : | |
2277 | sig | |
2278 | val readI : | |
2279 | HM.operation list -> (HM.operation list * Node.program list) | |
2280 | ||
2281 | val writeI : | |
2282 | (HM.operation list * Node.program list) -> HM.operation list | |
2283 | ||
2284 | val progMap : Node.program -> string | |
2285 | ||
2286 | val read_debug : bool ref | |
2287 | val write_debug : bool ref | |
2288 | val live_debug : bool ref | |
2289 | end = | |
2290 | ||
2291 | struct | |
2292 | ||
2293 | val read_debug = ref false | |
2294 | val write_debug = ref false | |
2295 | val live_debug = ref false | |
2296 | ||
2297 | fun read_dbg f = | |
2298 | if !read_debug then print ("readI.read:" ^ f() ^ "\n") | |
2299 | else () | |
2300 | ||
2301 | fun write_dbg f = | |
2302 | if !write_debug then print ("writeI.read:" ^ f() ^ "\n") | |
2303 | else () | |
2304 | ||
2305 | fun write_dbg_s s = write_dbg (fn () => s) | |
2306 | ||
2307 | exception BTARGET | |
2308 | ||
2309 | fun btarget (nil, n) = (fn x => raise BTARGET) | |
2310 | | btarget (h::t, n) = | |
2311 | let open HM | |
2312 | val rf = btarget(t, n + 1) | |
2313 | fun g lbl x = if lbl = x then n else rf x | |
2314 | fun f (TARGET(lbl, inst)) = (g lbl) | |
2315 | | f _ = rf | |
2316 | in | |
2317 | f h | |
2318 | end | |
2319 | ||
2320 | ||
2321 | val programs = Node.programs | |
2322 | ||
2323 | exception BNODES | |
2324 | ||
2325 | fun buildNodes l = | |
2326 | let open HM | |
2327 | open Ntypes | |
2328 | val t = btarget(l, 0) | |
2329 | fun f (nil, n) = nil | |
2330 | | f (ci::rest, n) = | |
2331 | let open Dag | |
2332 | open AbsMach | |
2333 | val nm = makestring n | |
2334 | val nxtnm = makestring (n + 1) | |
2335 | fun asn i = Set.listToSetEQ(aeq, i) | |
2336 | val edag = reach(Dag.make, NAME nxtnm) | |
2337 | fun tgtnm tgt = makestring (t tgt) | |
2338 | fun edagt tgt = reach(Dag.make, NAME (tgtnm tgt)) | |
2339 | val finDag = reach(Dag.make, NAME (Node.name_of Node.fin)) | |
2340 | fun cdag (tgt,tst) = attach(tst, edagt tgt, edag) | |
2341 | val g = | |
2342 | fn ASSIGNMENT i => Node.make(nm, asn [i], edag, Set.make) | |
2343 | | NERGLE => Node.make(nm, asn [], edag, Set.make) | |
2344 | | LABELREF (tgt, i as GETLAB{lab, dst}) => | |
2345 | Node.make(nm, | |
2346 | asn [GETLAB{lab=(t tgt, tgtnm tgt), | |
2347 | dst=dst}], | |
2348 | edag, Set.make) | |
2349 | | COMPARISON (tgt, tst) => | |
2350 | Node.make(nm, asn nil, cdag(tgt, tst), Set.make) | |
2351 | | FLOW (tgt, i) => | |
2352 | Node.make(nm, asn nil, edagt tgt, Set.make) | |
2353 | | EXIT i => Node.make(nm, asn [i], finDag, Set.make) | |
2354 | | TARGET (lbl, i) => | |
2355 | Node.make(nm, asn nil, edag, Set.make) | |
2356 | | _ => raise BNODES | |
2357 | in | |
2358 | (g ci)::Node.fin::(f (rest, n + 1)) | |
2359 | end | |
2360 | fun addn(n, p) = Node.addNode(p, n) | |
2361 | val prog = fold addn (Node.fin :: f(l, 0)) (Node.makeProg()) | |
2362 | in | |
2363 | prog | |
2364 | end | |
2365 | ||
2366 | exception READI | |
2367 | exception READI_NTN | |
2368 | fun readI ol = | |
2369 | let open HM | |
2370 | fun junkfil (JUNK a, (junk, other)) = (JUNK a :: junk, other) | |
2371 | | junkfil (x, (junk, other)) = (junk, x::other) | |
2372 | val cl = map HM.classify ol | |
2373 | val (junk, other) = fold junkfil cl (nil, nil) | |
2374 | fun ntn x = (Node.nameToNode x ) | |
2375 | handle NAMETONODE => raise READI_NTN | |
2376 | val (ns, foo, fin) = buildNodes other | |
2377 | val nn = (ns, ntn((ns, foo, fin), "0"), fin) | |
2378 | fun unjunk (JUNK i) = i | |
2379 | | unjunk _ = raise READI | |
2380 | val progs = programs nn | |
2381 | val foo = read_dbg | |
2382 | (fn () => ("progs =>" ^ | |
2383 | (StrPak.stringListString | |
2384 | (map Node.progToString progs)))) | |
2385 | in | |
2386 | (map unjunk junk, progs) | |
2387 | end | |
2388 | ||
2389 | structure ps = | |
2390 | struct | |
2391 | open Ntypes | |
2392 | type obj = Node.program | |
2393 | ||
2394 | fun int l = | |
2395 | let val z = ord "0" | |
2396 | fun f(n, nil) = n | |
2397 | | f (n, d::l) = | |
2398 | if d>="0" andalso d<="9" then f(n*10+ord(d)-z, l) | |
2399 | else n | |
2400 | in | |
2401 | f(0,l) | |
2402 | end | |
2403 | ||
2404 | fun gt((nsa, n0a, Fa), (nsb, n0b, Fb)) = | |
2405 | let val a = explode (Node.name_of n0a) | |
2406 | val b = explode (Node.name_of n0b) | |
2407 | in | |
2408 | (int a) > (int b) | |
2409 | end | |
2410 | end | |
2411 | ||
2412 | structure sortP = Sort (ps) | |
2413 | ||
2414 | fun live_dbg f = if !live_debug then print ("live:" ^ f() ^ "\n") | |
2415 | else () | |
2416 | ||
2417 | fun build_live_tab(P as (ns, n0, F): Node.program) = | |
2418 | let open Ntypes | |
2419 | open Node | |
2420 | open Set | |
2421 | fun fil (a, b) = if a < 0 orelse Delay.is_bogus_reg (a, "") then b | |
2422 | else add(b, a) | |
2423 | fun fil_lset s = fold fil (set s) make | |
2424 | val lt:(int set) Stringmap.stringmap = Stringmap.new() | |
2425 | val finset = listToSet [0, 1, 2, 3, 4, 5] | |
2426 | fun flive f n = | |
2427 | if Stringmap.isin lt (name_of n) then Stringmap.map lt (name_of n) | |
2428 | else f n | |
2429 | fun dfs cur = | |
2430 | let fun fl n = flive dfs n | |
2431 | val nm = name_of cur | |
2432 | val gen = (fil_lset o readNode) cur | |
2433 | val kill = writeNode cur | |
2434 | val foo = Stringmap.add lt (nm, gen) | |
2435 | val children = succNodes(P, cur) | |
2436 | val ch_live = if empty children then finset | |
2437 | else listUnion (map fl (set children)) | |
2438 | val live = union(diff(ch_live, kill), gen) | |
2439 | val foo = Stringmap.rm lt nm | |
2440 | val foo = Stringmap.add lt (nm, live) | |
2441 | in | |
2442 | live | |
2443 | end | |
2444 | in | |
2445 | dfs n0; | |
2446 | (fn nm => | |
2447 | let val ans = Stringmap.map lt nm | |
2448 | val foo = live_dbg (fn () => nm ^ "=>" ^ | |
2449 | StrPak.stringListString | |
2450 | (map makestring (set ans))) | |
2451 | in | |
2452 | ans | |
2453 | end) | |
2454 | end | |
2455 | ||
2456 | (* live is the union of live in successors *) | |
2457 | fun branch_live (P, tab, nm) = | |
2458 | let open Node | |
2459 | val s = Set.set (succ(P, nameToNode(P, nm))) | |
2460 | val l:int Set.set = Set.listUnion (map tab s) | |
2461 | val foo = live_dbg | |
2462 | (fn()=>("branch_live " ^ nm ^ " s=" ^ | |
2463 | StrPak.stringListString s ^ " -> " ^ | |
2464 | StrPak.stringListString (map makestring (Set.set l)))) | |
2465 | in | |
2466 | l | |
2467 | end | |
2468 | ||
2469 | exception WRITEP | |
2470 | exception WRITEP1 | |
2471 | exception WRITEP_NTN | |
2472 | ||
2473 | fun writeP (entry_map, lbl_fun, P as (ns, n0, F):Node.program) = | |
2474 | let open Ntypes | |
2475 | open Node | |
2476 | open Set | |
2477 | open HM | |
2478 | open AbsMach | |
2479 | val foo = write_dbg(fn () => "program:" ^ progToString P) | |
2480 | fun blblmap nil = (fn x => (print ("blblmap_" ^ x); raise WRITEP)) | |
2481 | | blblmap (nm::t) = | |
2482 | let val mp = blblmap t | |
2483 | val mylab = lbl_fun() | |
2484 | in | |
2485 | (fn x => if x = nm then mylab else mp x) | |
2486 | end | |
2487 | val lblmap = blblmap(map name_of (Stringmap.extract ns)) | |
2488 | val live_tab = build_live_tab P | |
2489 | fun label_list nm = map (fn r => (r, "")) (set (live_tab nm)) | |
2490 | fun br_list nm = | |
2491 | map (fn r => (r, "")) (set (branch_live(P, live_tab, nm))) | |
2492 | fun getlab (GETLAB{lab=(i,s), dst}) = | |
2493 | GETLAB{lab=(entry_map s, "node" ^ s), dst=dst} | |
2494 | | getlab _ = raise WRITEP1 | |
2495 | fun dogetlabs (i as GETLAB _, l) = (getlab i) :: l | |
2496 | | dogetlabs (i, l) = i :: l | |
2497 | fun ubranch (frm, nm) = | |
2498 | BRANCH{test=ieq, src1=(0, "zero"), src2=(0, "zero"), | |
2499 | dst=(lblmap nm, "node" ^ nm), live=br_list frm} | |
2500 | fun cbranch (BRANCH{test, src1, src2, dst, live}, frm, nm) = | |
2501 | BRANCH{test=test, src1=src1, src2=src2, | |
2502 | dst=(lblmap nm, "node" ^ nm), live=br_list frm} | |
2503 | | cbranch _ = (print "cbranch"; raise Match) | |
2504 | fun label nm = LABEL{lab=(lblmap nm, "node" ^ nm), live=label_list nm} | |
2505 | fun entry_label nm = | |
2506 | LABEL{lab=(entry_map nm, "entry"), live=label_list nm} | |
2507 | ||
2508 | fun f (done, lastnm, nm) = | |
2509 | let val foo = write_dbg | |
2510 | (fn () => | |
2511 | "f (" ^ | |
2512 | StrPak.stringListString (set done) ^ "," ^ | |
2513 | nm ^ ")") | |
2514 | in | |
2515 | if nm = name_of F then (write_dbg_s "fin"; (done, [NOP])) | |
2516 | else if member(done, nm) then (write_dbg_s "already"; | |
2517 | (done, [NOP, ubranch(lastnm, nm)])) | |
2518 | else | |
2519 | let open Dag | |
2520 | val foo = write_dbg_s "doing" | |
2521 | val node = nameToNode(P, nm) | |
2522 | handle NAMETONODE => raise WRITEP_NTN | |
2523 | val needlabel = | |
2524 | let val pd = set (pred (P, node)) | |
2525 | val foo = write_dbg | |
2526 | (fn () => ("needlabel pd=" ^ | |
2527 | StrPak.stringListString pd)) | |
2528 | fun f nil = false | |
2529 | | f ((p::nil):Ntypes.name list) = | |
2530 | let val pn = nameToNode(P, p:Ntypes.name) | |
2531 | val foo = write_dbg | |
2532 | (fn () => ("ndlbl: pn=" ^ | |
2533 | nodeToString pn)) | |
2534 | val d = dag_of pn | |
2535 | val sel = sel_of d | |
2536 | val rt = root_of d | |
2537 | fun istst (TEST t) = | |
2538 | (write_dbg_s "ist true\n"; | |
2539 | true) | |
2540 | | istst (NAME n) = | |
2541 | (write_dbg_s "ist false\n"; | |
2542 | false) | |
2543 | | istst NEITHER = | |
2544 | (write_dbg_s "ist false\n"; | |
2545 | false) | |
2546 | fun untst (TEST t) = t | |
2547 | | untst _ = (print "needlabel1"; | |
2548 | raise Match) | |
2549 | fun unnm (NAME nm) = nm | |
2550 | | unnm _ = (print "needlabel2"; | |
2551 | raise Match) | |
2552 | val foo = | |
2553 | if istst rt then | |
2554 | write_dbg | |
2555 | (fn () => | |
2556 | ("sel=" ^ | |
2557 | unnm(sel(untst rt, true)) ^ | |
2558 | "\n")) | |
2559 | else () | |
2560 | in | |
2561 | istst rt andalso | |
2562 | (sel(untst rt, true) = NAME nm) | |
2563 | end | |
2564 | | f (a::b::c) = true | |
2565 | val answer = f pd | |
2566 | val foo = write_dbg | |
2567 | (fn () => ("needlabel=>" ^ | |
2568 | Bool.toString answer)) | |
2569 | in | |
2570 | answer | |
2571 | end | |
2572 | val nodelabel = if needlabel then [label nm] else nil | |
2573 | val nodeNOP = [NOP] | |
2574 | val a = fold dogetlabs (set (assignment_of node)) nil | |
2575 | val d = dag_of node | |
2576 | val sel = sel_of d | |
2577 | val rt = root_of d | |
2578 | (* only works for <= 1 test *) | |
2579 | fun dag_code NEITHER = (nil, nil) | |
2580 | | dag_code (NAME n) = ([n], nil) | |
2581 | | dag_code (TEST t) = | |
2582 | let fun unnm (NAME x) = x | |
2583 | | unnm _ = (print "dag_code"; raise Match) | |
2584 | val t_n = unnm(sel(t, true)) | |
2585 | val f_n = unnm(sel(t, false)) | |
2586 | in | |
2587 | ([f_n, t_n], [cbranch(t, nm, t_n)]) | |
2588 | end | |
2589 | val (nl, cd) = dag_code rt | |
2590 | exception DFS_SURPRISE | |
2591 | fun dfs (done, nil) = (write_dbg_s "dfs nil"; | |
2592 | (done, nil)) | |
2593 | | dfs (done, h::nil) = (write_dbg_s "dfs 1"; | |
2594 | f(done, nm, h)) | |
2595 | | dfs (done, h::nxt::nil) = | |
2596 | let val foo = write_dbg_s "dfs 2" | |
2597 | val (dn1, cd1) = f(done, nm, h) | |
2598 | val (dn2, cd2) = | |
2599 | if member(dn1, nxt) then (dn1, nil) | |
2600 | else dfs(dn1, nxt::nil) | |
2601 | val lbl = | |
2602 | if nxt = name_of F orelse | |
2603 | member(dn2, nxt) then [NOP] | |
2604 | else [NOP, label nxt] | |
2605 | in | |
2606 | (dn2, cd1 @ lbl @ cd2) | |
2607 | end | |
2608 | | dfs _ = raise DFS_SURPRISE | |
2609 | val (dn, dcd) = dfs(add(done, nm), nl) | |
2610 | in | |
2611 | (dn, NOP :: nodelabel @ a @ cd @ dcd) | |
2612 | end | |
2613 | end | |
2614 | val (done, code) = f (Set.make, "badname", name_of n0) | |
2615 | in | |
2616 | (entry_label (name_of n0)) :: (label (name_of n0)) :: code | |
2617 | end | |
2618 | ||
2619 | exception WRITEI | |
2620 | ||
2621 | fun progMap(p as (ns, n0, F)) = | |
2622 | let val l = Node.sortNodes (Stringmap.extract ns) | |
2623 | val outstr = ref "" | |
2624 | fun pr s = outstr := !outstr ^ s | |
2625 | fun ntn n = Node.nameToNode(p, n) | |
2626 | val n0nm = Node.name_of n0 | |
2627 | val nFnm = Node.name_of F | |
2628 | fun f n = | |
2629 | let val s = Set.set (Node.succ(p, n)) | |
2630 | val nm = Node.name_of n | |
2631 | val pre = if nm = n0nm then "->\t" | |
2632 | else "\t" | |
2633 | val post = if nm = nFnm then "\t->\n" | |
2634 | else "\n" | |
2635 | in | |
2636 | pr (pre ^ | |
2637 | Node.name_of n ^ "\t->\t" ^ StrPak.stringListString s ^ | |
2638 | post) | |
2639 | end | |
2640 | in | |
2641 | List.app f l; | |
2642 | !outstr | |
2643 | end | |
2644 | ||
2645 | fun writeI(j:AbsMach.opcode list, p:Node.program list) = | |
2646 | let val labelid = ref 0 | |
2647 | fun newlabel () = (labelid := !labelid + 1; !labelid - 1) | |
2648 | fun bentrymap nil = (fn x => (print ("bentrymap_" ^ x); raise WRITEI)) | |
2649 | | bentrymap ((ns, n0, F)::t) = | |
2650 | let val mp = bentrymap t | |
2651 | val mylab = newlabel() | |
2652 | in | |
2653 | (fn x => if x = Node.name_of n0 then mylab else mp x) | |
2654 | end | |
2655 | val entry_map = bentrymap p | |
2656 | val sp = sortP.sort p | |
2657 | fun wp p = writeP (entry_map, newlabel, p) | |
2658 | fun f(a, b) = (wp a) @ b | |
2659 | val i = fold f sp nil | |
2660 | in | |
2661 | i @ j | |
2662 | end | |
2663 | ||
2664 | ||
2665 | end | |
2666 | ||
2667 | ||
2668 | ||
2669 | signature SIMLABS = | |
2670 | sig | |
2671 | exception Data_dependency_checked | |
2672 | exception End_of_Program | |
2673 | exception Simulator_error_1 | |
2674 | exception Simulator_error_2 | |
2675 | exception illegal_branch_within_branchdelay | |
2676 | exception illegal_jump_within_branchdelay | |
2677 | exception illegal_operator_or_operand | |
2678 | exception negative_label_offset | |
2679 | exception no_address_in_register | |
2680 | exception no_label_in_register | |
2681 | exception no_memory_address_in_register | |
2682 | exception runtime_error_in_labwords | |
2683 | exception runtime_error_in_words_or_labwords | |
2684 | exception type_mismatch_in_comparison | |
2685 | exception wrong_label | |
2686 | val breakptr : int -> unit | |
2687 | val clock : int ref | |
2688 | val d_m : int * int -> unit | |
2689 | val d_ms : int list -> unit | |
2690 | val d_pc : unit -> unit | |
2691 | val d_r : unit -> unit | |
2692 | val d_regs : int list -> unit | |
2693 | val init : AbsMach.opcode list -> unit | |
2694 | val mcell : int -> AbsMach.values | |
2695 | val pc : unit -> AbsMach.opcode list | |
2696 | val pinit : int * (AbsMach.arithop -> int) * int * AbsMach.opcode list | |
2697 | -> unit | |
2698 | val pptr : unit -> int | |
2699 | val prun : unit -> unit | |
2700 | val pstep : unit -> unit | |
2701 | val regc : int -> AbsMach.values | |
2702 | val run : unit -> unit | |
2703 | val runcount : int ref | |
2704 | val step : unit -> unit | |
2705 | val vinit : int * AbsMach.opcode list -> unit | |
2706 | val vpc : unit -> unit | |
2707 | val vrun1 : unit -> unit | |
2708 | val vrun2 : unit -> unit | |
2709 | val vrun3 : unit -> unit | |
2710 | val vstep1 : unit -> unit | |
2711 | val vstep2 : unit -> unit | |
2712 | val vstep3 : unit -> unit | |
2713 | ||
2714 | val Memory : (AbsMach.values array) ref | |
2715 | end; | |
2716 | ||
2717 | ||
2718 | structure SetEnv : SIMLABS= | |
2719 | struct | |
2720 | ||
2721 | open AbsMach; | |
2722 | ||
2723 | val codes : (opcode list ref)=ref nil; | |
2724 | ||
2725 | val RegN=ref 0 and LabN=ref 0 and memorysize=ref 10000; | |
2726 | (*RegN = (pointer to) number of registers needed; | |
2727 | LabN = (pointer to) number of labels; | |
2728 | memorysize=(pointer to) memory space size. | |
2729 | *) | |
2730 | val IP: (opcode list) ref =ref nil; | |
2731 | val inivalue=(INT 0); | |
2732 | (*IP = Program Pointer; | |
2733 | inivalue = zero- initial value of memory and registers. | |
2734 | *) | |
2735 | val Reg=ref (array(0,inivalue)) and Memory=ref (array(0,inivalue)) | |
2736 | and Lab_Array=ref (array(0, (0,IP) )); | |
2737 | (*Reg = register array; | |
2738 | Memory = memory cell array; | |
2739 | Lab_Array = label-opcode list array. | |
2740 | *) | |
2741 | ||
2742 | fun max(n1:int,n2:int)=if (n1>n2) then n1 else n2; | |
2743 | ||
2744 | (* hvnop tests whether the instruction is not a real machine instruction, | |
2745 | but only useful in simulation. | |
2746 | *) | |
2747 | fun hvnop(LABEL{...})=true | | |
2748 | hvnop(LABWORD{...})=true | | |
2749 | hvnop(WORD{...})=true | | |
2750 | hvnop(_)=false; | |
2751 | ||
2752 | (*count_number is used to take into account register references and label | |
2753 | declarations, and change RegN or LabN. | |
2754 | *) | |
2755 | fun count_number(FETCH {ptr=(n1,_),dst=(n2,_),...})= | |
2756 | (RegN:=max((!RegN),max(n1,n2)) ) | | |
2757 | count_number(STORE {src=(n1,_),ptr=(n2,_),...})= | |
2758 | (RegN:=max((!RegN),max(n1,n2)) ) | | |
2759 | count_number(ARITHI {src1=(n1,_),dst=(n2,_),...})= | |
2760 | (RegN:=max((!RegN),max(n1,n2)) ) | | |
2761 | count_number(MOVE {src=(n1,_),dst=(n2,_)})= | |
2762 | (RegN:=max((!RegN),max(n1,n2)) ) | | |
2763 | count_number(BRANCH {src1=(n1,_),src2=(n2,_),...})= | |
2764 | (RegN:=max((!RegN),max(n1,n2)) ) | | |
2765 | count_number(GETLAB {dst=(n,_),...})= | |
2766 | (RegN:=max((!RegN),n) ) | | |
2767 | count_number(GETREAL {dst=(n,_),...})= | |
2768 | (RegN:=max((!RegN),n) ) | | |
2769 | count_number(ARITH{src1=(n1,_),src2=(n2,_),dst=(n3,_),...})= | |
2770 | (RegN:=max((!RegN),max(n1,max(n2,n3)) ) ) | | |
2771 | count_number(LABEL{...})= | |
2772 | ( Ref.inc(LabN) ) | | |
2773 | count_number(_)=(); | |
2774 | ||
2775 | (* scan is used to scan the opcode list for the first time, to determine | |
2776 | the size of Reg and Lab_Array, i.e. number of registers and labels. | |
2777 | *) | |
2778 | fun scan(nil)=() | | |
2779 | scan(h::t)=(count_number(h);scan(t)); | |
2780 | ||
2781 | (* setlabels is used to set the label array, of which each item is a | |
2782 | pair (label, codep), codep points to the codes containing the LABEL | |
2783 | statement and afterwards codes. | |
2784 | *) | |
2785 | fun setlabels(nil,_)= () | | |
2786 | setlabels(codel as ((LABEL {lab=(l,_),...})::t),k)= | |
2787 | (update((!Lab_Array),k,(l,ref codel)); setlabels(t,k+1) ) | | |
2788 | setlabels(h::t,k)=setlabels(t,k) ; | |
2789 | ||
2790 | (* initializing the enviroment of the simulation. | |
2791 | *) | |
2792 | fun init(l)=(RegN:=0; LabN:=0; IP:=l; codes:=l; | |
2793 | scan(!IP); Ref.inc(RegN); | |
2794 | Reg:=array( (!RegN), inivalue ) ; | |
2795 | Memory:=array( (!memorysize), inivalue ) ; | |
2796 | Lab_Array:=array( (!LabN), (0,IP)); | |
2797 | setlabels(!IP,0) | |
2798 | ); | |
2799 | ||
2800 | ||
2801 | ||
2802 | exception wrong_label; | |
2803 | exception runtime_error_in_labwords; | |
2804 | exception runtime_error_in_words_or_labwords; | |
2805 | exception negative_label_offset; | |
2806 | exception no_label_in_register; | |
2807 | exception illegal_operator_or_operand; | |
2808 | exception type_mismatch_in_comparison ; | |
2809 | exception no_address_in_register; | |
2810 | exception no_memory_address_in_register; | |
2811 | ||
2812 | (* getresult gives the results of arithmtic operations | |
2813 | *) | |
2814 | fun getresult(iadd,INT (n1:int),INT (n2:int))=INT (n1+n2) | | |
2815 | getresult(isub,INT (n1:int),INT (n2:int))=INT (n1-n2) | | |
2816 | getresult(imul,INT (n1:int),INT (n2:int))=INT (n1*n2) | | |
2817 | getresult(idiv,INT (n1:int),INT (n2:int))=INT (n1 div n2) | | |
2818 | getresult(fadd,REAL (r1:real),REAL (r2:real))=REAL (r1+r2) | | |
2819 | getresult(fsub,REAL (r1:real),REAL (r2:real))=REAL (r1-r2) | | |
2820 | getresult(fmul,REAL (r1:real),REAL (r2:real))=REAL (r1*r2) | | |
2821 | getresult(fdiv,REAL (r1:real),REAL (r2:real))=REAL (r1/r2) | | |
2822 | getresult(iadd,INT (n1:int),LABVAL (l,k))=LABVAL (l,k+n1) | | |
2823 | getresult(iadd,LABVAL (l,k),INT (n1:int))=LABVAL (l,k+n1) | | |
2824 | getresult(isub,LABVAL (l,k),INT (n1:int))=LABVAL (l,k-n1) | | |
2825 | getresult(orb,INT n1,INT n2)=INT (Bits.orb(n1,n2)) | | |
2826 | getresult(andb,INT n1,INT n2)=INT (Bits.andb(n1,n2)) | | |
2827 | getresult(xorb,INT n1,INT n2)=INT (Bits.xorb(n1,n2)) | | |
2828 | getresult(rshift,INT n1,INT n2)=INT (Bits.rshift(n1,n2)) | | |
2829 | getresult(lshift,INT n1,INT n2)=INT (Bits.lshift(n1,n2)) | | |
2830 | getresult(real,INT n,_)=REAL (intToReal(n)) | | |
2831 | getresult(floor,REAL r,_)=INT (Real.floor(r)) | | |
2832 | (* getresult(logb,REAL r,_)=INT (System.Unsafe.Assembly.A.logb(r))| *) | |
2833 | getresult(_)=raise illegal_operator_or_operand; | |
2834 | ||
2835 | (* compare gives the results of comparisons in BRANCH statement. | |
2836 | *) | |
2837 | fun compare(ilt,INT n1,INT n2)= (n1<n2) | | |
2838 | compare(ieq,INT n1,INT n2)= (n1=n2) | | |
2839 | compare(igt,INT n1,INT n2)= (n1>n2) | | |
2840 | compare(ile,INT n1,INT n2)= (n1<=n2) | | |
2841 | compare(ige,INT n1,INT n2)= (n1>=n2) | | |
2842 | compare(ine,INT n1,INT n2)= (n1<>n2) | | |
2843 | compare(flt,REAL r1,REAL r2)= (r1<r2) | | |
2844 | compare(feq,REAL r1,REAL r2)= (realEq(r1,r2)) | | |
2845 | compare(fgt,REAL r1,REAL r2)= (r1>r2) | | |
2846 | compare(fle,REAL r1,REAL r2)= (r1<=r2) | | |
2847 | compare(fge,REAL r1,REAL r2)= (r1>=r2) | | |
2848 | compare(fne,REAL r1,REAL r2)= (realNe(r1,r2)) | | |
2849 | compare(inrange,INT a,INT b)= (a>=0) andalso (a<b) | | |
2850 | compare(outofrange,INT a,INT b)=(a<0) orelse (a>b) | | |
2851 | compare(inrange,REAL a,REAL b)= (a>=0.0) andalso (a<b) | | |
2852 | compare(outofrange,REAL a,REAL b)=(a<0.0) orelse (a>b) | | |
2853 | compare(_)=raise type_mismatch_in_comparison ; | |
2854 | ||
2855 | (* findjmp_place returns the pointer to the codes corresponding to the | |
2856 | given label (the codes containing the LABEL statement itself). | |
2857 | *) | |
2858 | fun findjmp_place lab = | |
2859 | let val ipp=ref (ref nil) and i=ref 0 and flag=ref true; | |
2860 | val none=(while ( (!i < !LabN) andalso (!flag) ) do | |
2861 | ( let val (l,p)=((!Lab_Array) sub (!i)) in | |
2862 | if (l=lab) then (ipp:=p;flag:=false) | |
2863 | else Ref.inc(i) | |
2864 | end | |
2865 | ) | |
2866 | ) | |
2867 | in if (!flag) then raise wrong_label | |
2868 | else (!ipp) | |
2869 | end; | |
2870 | ||
2871 | (* findjmp_word returns the content of the k th labword in a code stream. | |
2872 | *) | |
2873 | fun findjmp_word(k,ip)=if (k<0) then raise negative_label_offset | |
2874 | else let fun f2(1,LABWORD{lab=(herepos,_)}::t) | |
2875 | =herepos | | |
2876 | f2(k,LABWORD{...}::t)=f2(k-1,t) | | |
2877 | f2(_)=raise runtime_error_in_labwords ; | |
2878 | in f2(k, (!ip) ) | |
2879 | end; | |
2880 | ||
2881 | (* inst_word returns the content of the k'th word or labword in a code | |
2882 | stream. | |
2883 | *) | |
2884 | fun inst_word(k,ip)=if (k<0) then raise negative_label_offset | |
2885 | else let fun f(1,LABWORD{lab=(herepos,_)}::t) | |
2886 | =LABVAL (herepos,0) | | |
2887 | f(1,WORD{value=n}::t)=INT n | | |
2888 | f(k,LABWORD{...}::t)=f(k-1,t) | | |
2889 | f(k,WORD{...}::t)=f(k-1,t) | | |
2890 | f(_)=raise | |
2891 | runtime_error_in_words_or_labwords | |
2892 | in f(k,(!ip)) | |
2893 | end; | |
2894 | ||
2895 | ||
2896 | (* execjmp changes IP, makes it point to the codes of the given label. | |
2897 | *) | |
2898 | fun execjmp(LABVAL (l,0))= (IP:= !(findjmp_place l) ) | | |
2899 | execjmp(LABVAL (l,k))= (IP:= | |
2900 | ! (findjmp_place | |
2901 | (findjmp_word(k,findjmp_place(l) ) ) ) | |
2902 | ) | | |
2903 | execjmp(_) = raise no_label_in_register; | |
2904 | ||
2905 | (* addrplus returns the result of address+offset. | |
2906 | *) | |
2907 | fun addrplus(INT n,ofst)= n+ofst | | |
2908 | addrplus(_,_)=raise no_memory_address_in_register; | |
2909 | ||
2910 | (* content gives the content of the fetched word. | |
2911 | *) | |
2912 | fun content(INT n,ofst)= (!Memory) sub (n+ofst) | | |
2913 | content(LABVAL (l,k),ofst)=inst_word(k+ofst,findjmp_place(l)) | | |
2914 | content(_,_)=raise no_address_in_register; | |
2915 | ||
2916 | (* exec executes the given instruction. | |
2917 | *) | |
2918 | fun exec(FETCH{immutable=_,offset=ofst,ptr=(p,_),dst=(d,_)})= | |
2919 | update((!Reg),d,content((!Reg) sub p,ofst) ) | | |
2920 | exec(STORE{offset=ofst,src=(s,_),ptr=(p,_)})= | |
2921 | update((!Memory),addrplus((!Reg) sub p,ofst),(!Reg) sub s) | | |
2922 | exec(GETLAB {lab=(l,_),dst=(d,_)})= | |
2923 | update((!Reg),d,(LABVAL (l,0)) ) | | |
2924 | exec(GETREAL {value=v,dst=(d,_)})= | |
2925 | update((!Reg),d,(REAL (strToReal v))) | | |
2926 | exec(MOVE{src=(s,_),dst=(d,_)})= | |
2927 | update((!Reg),d, (!Reg) sub s ) | | |
2928 | exec(LABEL {...})= | |
2929 | () | | |
2930 | exec(LABWORD {...}) = | |
2931 | () | | |
2932 | exec(WORD{...})= | |
2933 | () | | |
2934 | exec(JUMP {dst=(d,_),...})= | |
2935 | execjmp((!Reg) sub d) | | |
2936 | exec(ARITH {oper=opn,src1=(s1,_),src2=(s2,_),dst=(d,_)})= | |
2937 | update((!Reg),d,getresult(opn,(!Reg) sub s1,(!Reg) sub s2) ) | | |
2938 | exec(ARITHI {oper=opn,src1=(s1,_),src2=n1,dst=(d,_)})= | |
2939 | update((!Reg),d,getresult(opn,(!Reg) sub s1,(INT n1) ) ) | | |
2940 | exec(BRANCH{test=comp,src1=(s1,_),src2=(s2,_),dst=(labnum,_),...})= | |
2941 | if compare(comp,(!Reg) sub s1,(!Reg) sub s2) | |
2942 | then (IP:= !(findjmp_place(labnum) ) ) | |
2943 | else () | | |
2944 | exec(NOP)= () | | |
2945 | exec(BOGUS _)= raise Match | |
2946 | ||
2947 | ; | |
2948 | ||
2949 | ||
2950 | ||
2951 | exception End_of_Program; | |
2952 | ||
2953 | fun step () =let | |
2954 | val Instruction=(hd(!IP) handle Hd=> raise End_of_Program) | |
2955 | in | |
2956 | (IP:=tl(!IP) handle Tl=>raise End_of_Program; | |
2957 | exec(Instruction) ) | |
2958 | end; | |
2959 | fun run () =(step();run() ) | |
2960 | handle End_of_Program =>output(std_out,"End of program\n"); | |
2961 | ||
2962 | (* bms, ims, rms are simply abbreviations. | |
2963 | *) | |
2964 | val bms : bool -> string = Bool.toString | |
2965 | and ims : int -> string = Int.toString | |
2966 | and rms : real -> string = Real.toString | |
2967 | ||
2968 | (* dispv shows the content of a register, dispm shows the content of a | |
2969 | memory word. | |
2970 | *) | |
2971 | fun dispv(n,INT k)=output(std_out,"Register "^ims(n)^": "^ | |
2972 | "INT "^ims(k)^"\n") | | |
2973 | dispv(n,REAL r)=output(std_out,"Register "^ims(n)^": "^ | |
2974 | "REAL "^rms(r)^"\n") | | |
2975 | dispv(n,LABVAL (l,0))=output(std_out, | |
2976 | "Register "^ims(n)^": "^ | |
2977 | "LABEL "^ims(l)^"\n") | | |
2978 | dispv(n,LABVAL (l,k))=output(std_out, | |
2979 | "Register "^ims(n)^": "^ | |
2980 | "LABWORD "^ims(k)^" after"^ | |
2981 | "LABEL "^ims(l)^"\n") ; | |
2982 | ||
2983 | fun dispm(n,INT k)=output(std_out,"Memory "^ims(n)^": "^ | |
2984 | "INT "^ims(k)^"\n") | | |
2985 | dispm(n,REAL r)=output(std_out,"Memory "^ims(n)^": "^ | |
2986 | "REAL "^rms(r)^"\n") | | |
2987 | dispm(n,LABVAL (l,0))=output(std_out, | |
2988 | "Memory "^ims(n)^": "^ | |
2989 | "LABEL "^ims(l)^"\n") | | |
2990 | dispm(n,LABVAL (l,k))=output(std_out, | |
2991 | "Memory "^ims(n)^": "^ | |
2992 | "LABWORD "^ims(k)^" after"^ | |
2993 | "LABEL "^ims(l)^"\n") ; | |
2994 | ||
2995 | (* oms and cms give the strings of the functions and comparisions. | |
2996 | *) | |
2997 | fun oms(iadd)="iadd" | oms(isub)="isub" | | |
2998 | oms(imul)="imul" | oms(idiv)="idiv" | | |
2999 | oms(fadd)="fadd" | oms(fsub)="fsub" | | |
3000 | oms(fmul)="fmul" | oms(fdiv)="fdiv" | | |
3001 | oms(real)="real" | oms(floor)="floor" | oms(logb)="logb" | | |
3002 | oms(orb)="orb" | oms(andb)="andb" | oms(xorb)="xorb" | | |
3003 | oms(rshift)="rshift" | oms(lshift)="lshift" ; | |
3004 | ||
3005 | fun cms(ilt)="ilt" | cms(igt)="igt" | cms(ieq)="ieq" | | |
3006 | cms(ile)="ile" | cms(ige)="ige" | cms(ine)="ine" | | |
3007 | cms(flt)="flt" | cms(fgt)="fgt" | cms(feq)="feq" | | |
3008 | cms(fle)="fle" | cms(fge)="fge" | cms(fne)="fne" | | |
3009 | cms(outofrange)="outofrange" | cms(inrange)="inrange" ; | |
3010 | ||
3011 | (* lms gives the string of the live register list. | |
3012 | *) | |
3013 | fun lms(nil)="" | | |
3014 | lms((h,s)::nil)="("^ims(h)^","^s^")" | | |
3015 | lms((h,s)::t)="("^ims(h)^","^s^"),"^lms(t); | |
3016 | ||
3017 | (* disp gives the string for the instruction. | |
3018 | *) | |
3019 | fun disp(FETCH{immutable=b,offset=ofst,ptr=(p,s1),dst=(d,s2)}) = | |
3020 | "FETCH{immutable="^bms(b)^",offset="^ims(ofst) ^",ptr=("^ims(p)^","^s1 | |
3021 | ^"),dst=("^ims(d)^","^s2^")}\n" | | |
3022 | ||
3023 | disp(STORE{offset=ofst,src=(s,s1),ptr=(p,s2)}) = | |
3024 | "STORE{offset="^ims(ofst)^",src=("^ims(s)^","^s1^"),ptr=(" | |
3025 | ^ims(p)^","^s2^")}\n" | | |
3026 | ||
3027 | disp(GETLAB{lab=(l,ls),dst=(d,ds)}) = | |
3028 | "GETLAB{lab=("^ims(l)^","^ls^"),dst=("^ims(d)^","^ds^")}\n" | | |
3029 | ||
3030 | disp(GETREAL{value=r,dst=(d,ds)}) = | |
3031 | "GETREAL{value="^r^",dst=("^ims(d)^","^ds^")}\n" | | |
3032 | ||
3033 | disp(ARITH{oper=opn,src1=(s1,ss1),src2=(s2,ss2),dst=(d,ds)})= | |
3034 | "ARITH{oper="^oms(opn)^",src1=("^ims(s1)^","^ss1^"),src2=("^ims(s2) | |
3035 | ^","^ss2^"),dst=("^ims(d)^","^ds^")}\n" | | |
3036 | ||
3037 | disp(ARITHI{oper=opn,src1=(s1,ss1),src2=n,dst=(d,ds)})= | |
3038 | "ARITH{oper="^oms(opn)^",src1=("^ims(s1)^","^ss1^"),src2="^ims(n)^ | |
3039 | ",dst=("^ims(d)^","^ds^")}\n" | | |
3040 | ||
3041 | disp(MOVE{src=(s,ss),dst=(d,ds)})= | |
3042 | "MOVE{src=("^ims(s)^","^ss^"),dst=("^ims(d)^","^ds^")}\n" | | |
3043 | ||
3044 | disp(BRANCH{test=comp,src1=(s1,ss1),src2=(s2,ss2),dst=(labnum,ss3), | |
3045 | live=lt})= | |
3046 | "BRANCH{test="^cms(comp)^",src1=("^ims(s1)^","^ss1^"),src2=("^ims(s2) | |
3047 | ^","^ss2^"),dst=("^ims(labnum)^","^ss3^"),live=["^lms(lt)^"]}\n" | | |
3048 | ||
3049 | disp(JUMP{dst=(d,ds),live=lt}) = | |
3050 | "JUMP{dst=("^ims(d)^","^ds^"),live=["^lms(lt)^"]}\n" | | |
3051 | ||
3052 | disp(LABWORD{lab=(l,s)})="LABWORD{lab=("^ims(l)^","^s^")}\n" | | |
3053 | ||
3054 | disp(LABEL{lab=(l,s),live=lt})= | |
3055 | "LABEL{lab=("^ims(l)^","^s^"),live=["^lms(lt)^"]}\n" | | |
3056 | ||
3057 | disp(WORD{value=n})="WORD{value="^ims(n)^"}\n" | | |
3058 | ||
3059 | disp(NOP)="NOP" | | |
3060 | disp(BOGUS _) = raise Match | |
3061 | ||
3062 | ; | |
3063 | ||
3064 | fun d_pc () =output(std_out,disp(hd(!IP)) handle Hd=>"No More Instruction\n"); | |
3065 | fun pc () = (!IP); | |
3066 | fun pptr () =(List.length(!codes)-List.length(!IP))+1; | |
3067 | fun breakptr k=let fun goon (LABEL {lab=(l,_),...})=(l<>k) | | |
3068 | goon (_)=true | |
3069 | in while goon(hd(!IP)) do step() | |
3070 | end; | |
3071 | fun regc n=((!Reg) sub n); | |
3072 | fun d_r () =let val i=ref 0 in | |
3073 | (while ( !i < !RegN) do | |
3074 | (dispv((!i),(!Reg) sub (!i)); Ref.inc(i) ) | |
3075 | ) | |
3076 | end; | |
3077 | fun d_regs (nil)=() | | |
3078 | d_regs (h::t)=(dispv(h,(!Reg) sub h);d_regs(t)); | |
3079 | ||
3080 | fun mcell n=((!Memory) sub n); | |
3081 | fun d_m (n,m)=let val i=ref n in | |
3082 | while ( !i <=m) do (dispm(!i,(!Memory) sub !i); Ref.inc(i) ) | |
3083 | end; | |
3084 | fun d_ms nil =() | | |
3085 | d_ms (h::t)=(dispm(h,(!Memory) sub h); d_ms(t) ); | |
3086 | ||
3087 | ||
3088 | (* This part for the VLIW mode execution. *) | |
3089 | ||
3090 | ||
3091 | val runcount=ref 0 and sizen=ref 0 and flag=ref true; | |
3092 | exception Simulator_error_1; | |
3093 | exception Simulator_error_2; | |
3094 | exception Data_dependency_checked; | |
3095 | ||
3096 | (* member tests whether element a is in a list. | |
3097 | *) | |
3098 | fun member(a,nil)=false | | |
3099 | member(a,h::t)=if (a=h) then true else member(a,t); | |
3100 | (* hvcom tests whether the intersection of two list isnot nil. | |
3101 | *) | |
3102 | fun hvcom(nil,l)=false | | |
3103 | hvcom(h::t,l)=member(h,l) orelse hvcom(t,l); | |
3104 | ||
3105 | (* gset returns the list of registers refered in a instruction. | |
3106 | gwset returns the list of the register being written in a instruction. | |
3107 | *) | |
3108 | fun gset(FETCH{ptr=(p,_),dst=(d,_),...})=[p,d] | | |
3109 | gset(STORE{src=(s,_),ptr=(p,_),...})=[s,p] | | |
3110 | gset(GETLAB{dst=(d,_),...})=[d] | | |
3111 | gset(GETREAL{dst=(d,_),...})=[d] | | |
3112 | gset(ARITH{src1=(s1,_),src2=(s2,_),dst=(d,_),...})=[s1,s2,d] | | |
3113 | gset(ARITHI{src1=(s1,_),dst=(d,_),...})=[s1,d] | | |
3114 | gset(MOVE{src=(s,_),dst=(d,_)})=[s,d] | | |
3115 | gset(BRANCH{src1=(s1,_),src2=(s2,_),...})=[s1,s2] | | |
3116 | gset(JUMP{dst=(d,_),...})=[d] | | |
3117 | gset(_)=nil ; | |
3118 | fun gwset(FETCH{dst=(d,_),...})=[d] | | |
3119 | gwset(GETLAB{dst=(d,_),...})=[d] | | |
3120 | gwset(GETREAL{dst=(d,_),...})=[d] | | |
3121 | gwset(ARITH{dst=(d,_),...})=[d] | | |
3122 | gwset(ARITHI{dst=(d,_),...})=[d] | | |
3123 | gwset(MOVE{dst=(d,_),...})=[d] | | |
3124 | gwset(_)=nil ; | |
3125 | ||
3126 | (* fetchcode returns the instruction word which contains the next k | |
3127 | instruction. fetchcode3 is used in version 3 of VLIW mode, in which case | |
3128 | labels within instruction words are OK. | |
3129 | *) | |
3130 | fun fetchcode(0)=nil | | |
3131 | fetchcode(k)=let val h=hd(!IP) in | |
3132 | (IP:=tl(!IP); | |
3133 | if hvnop(h) | |
3134 | then (output(std_out, | |
3135 | "Warning: labels within the instruction word\n"); | |
3136 | fetchcode(k) | |
3137 | ) | |
3138 | else h::fetchcode(k-1) ) | |
3139 | end handle Hd=>nil; | |
3140 | fun fetchcode3(0)=nil | | |
3141 | fetchcode3(k)=let val h=hd(!IP) in | |
3142 | (IP:=tl(!IP); | |
3143 | if hvnop(h) then fetchcode3(k) | |
3144 | else h::fetchcode3(k-1) ) | |
3145 | end handle Hd=>nil; | |
3146 | ||
3147 | (* allnop tests if all instructions left mean no operation. | |
3148 | *) | |
3149 | fun allnop(nil)=true | | |
3150 | allnop(NOP::t)=allnop(t) | | |
3151 | allnop(_)=false; | |
3152 | ||
3153 | (* nopcut cut the instruction stream in a way that the first half are all | |
3154 | NOP instruction. | |
3155 | *) | |
3156 | fun nopcut(nil)=(nil,nil) | | |
3157 | nopcut(NOP::t)=let val (l1,l2)=nopcut(t) in (NOP::l1,l2) end | | |
3158 | nopcut(l)=(nil,l); | |
3159 | ||
3160 | (* cmdd tests the data dependency on memory cells and IP. | |
3161 | *) | |
3162 | fun cmdd(_,nil)=false | | |
3163 | cmdd(wset,STORE{ptr=(p,_),offset=ofst,...}::t)= | |
3164 | cmdd(addrplus((!Reg) sub p,ofst)::wset,t) | | |
3165 | cmdd(wset,FETCH{ptr=(p,_),offset=ofst,...}::t)= | |
3166 | member(addrplus((!Reg) sub p,ofst),wset) orelse cmdd(wset,t) | | |
3167 | cmdd(wset,BRANCH{...}::t)=if allnop(t) then false else true | | |
3168 | cmdd(wset,JUMP{...}::t)=if allnop(t) then false else true | | |
3169 | cmdd(wset,h::t)=cmdd(wset,t); | |
3170 | ||
3171 | (* crdd test the data dependency on registers. | |
3172 | *) | |
3173 | fun crdd(_,nil)=false | | |
3174 | crdd(wset,h::t)=if hvcom(gset(h),wset) then true | |
3175 | else crdd(gwset(h)@wset,t) ; | |
3176 | ||
3177 | (* check_dd checks whether there is data dependency in instruction stream l. | |
3178 | *) | |
3179 | fun check_dd(l)= crdd(nil,l) orelse cmdd(nil,l); | |
3180 | ||
3181 | (* rddcut seperate the longest part of the instruction stream that have no | |
3182 | data dependency on registers , from the left. | |
3183 | *) | |
3184 | fun rddcut(_,nil)= (nil,nil) | | |
3185 | rddcut(wset,l as (h::t))= | |
3186 | if hvcom(gset(h),wset) then (nil,l) | |
3187 | else let val (l1,l2)=rddcut(gwset(h)@wset,t) | |
3188 | in (h::l1,l2) end | |
3189 | ; | |
3190 | (* mddcut seperate the longest part of the instruction stream that have no data | |
3191 | dependency on memory cells and IP, from the left. | |
3192 | *) | |
3193 | fun mddcut(_,nil)= (nil,nil) | | |
3194 | mddcut(wset,(h as STORE{ptr=(p,_),offset=ofst,...})::t)= | |
3195 | let val (l1,l2)=mddcut(addrplus((!Reg) sub p,ofst)::wset,t) | |
3196 | in (h::l1,l2) end | | |
3197 | mddcut(wset,(h as FETCH{ptr=(p,_),offset=ofst,...})::t)= | |
3198 | if member(addrplus((!Reg) sub p,ofst),wset) | |
3199 | then (nil,h::t) | |
3200 | else let val (l1,l2)=mddcut(wset,t) in (h::l1,l2) end | | |
3201 | mddcut(wset,(h as BRANCH{...})::t)= | |
3202 | let val (l1,l2)=nopcut(t) in (h::l1,l2) end | | |
3203 | mddcut(wset,(h as JUMP{...})::t)= | |
3204 | let val (l1,l2)=nopcut(t) in (h::l1,l2) end | | |
3205 | mddcut(wset,h::t)= | |
3206 | let val (l1,l2)=mddcut(wset,t) in (h::l1,l2) end | |
3207 | ; | |
3208 | ||
3209 | (* calcult returns the necessary value list corresponding to a instruction | |
3210 | stream. And change the IP when necessary. | |
3211 | *) | |
3212 | fun calcult(nil)=nil | | |
3213 | calcult(FETCH{ptr=(p,_),offset=ofst,...}::t)= | |
3214 | content((!Reg) sub p,ofst)::calcult(t) | | |
3215 | calcult(STORE{src=(s,_),...}::t)=((!Reg) sub s )::calcult(t) | | |
3216 | calcult(MOVE{src=(s,_),...}::t)=((!Reg) sub s)::calcult(t) | | |
3217 | calcult(ARITH{oper=opn,src1=(s1,_),src2=(s2,_),...}::t)= | |
3218 | getresult(opn,(!Reg) sub s1,(!Reg) sub s2)::calcult(t) | | |
3219 | calcult(ARITHI{oper=opn,src1=(s1,_),src2=n1,...}::t)= | |
3220 | getresult(opn,(!Reg) sub s1,(INT n1))::calcult(t) | | |
3221 | calcult(JUMP{dst=(d,_),...}::t)=((!Reg) sub d)::calcult(t) | | |
3222 | calcult(h::t)=calcult(t); | |
3223 | ||
3224 | (* dowr does the actual writing operations. | |
3225 | *) | |
3226 | fun dowr(nil,nil)=() | | |
3227 | dowr(nil,h::t)=raise Simulator_error_1 | | |
3228 | dowr(FETCH{...}::t,nil)=raise Simulator_error_2 | | |
3229 | dowr(STORE{...}::t,nil)=raise Simulator_error_2 | | |
3230 | dowr(MOVE{...}::t,nil)=raise Simulator_error_2 | | |
3231 | dowr(ARITH{...}::t,nil)=raise Simulator_error_2 | | |
3232 | dowr(ARITHI{...}::t,nil)=raise Simulator_error_2 | | |
3233 | dowr(JUMP{...}::t,nil)=raise Simulator_error_2 | | |
3234 | dowr(FETCH{dst=(d,_),...}::t,vh::vt)=(update((!Reg),d,vh); | |
3235 | dowr(t,vt) ) | | |
3236 | dowr(STORE{ptr=(p,_),offset=ofst,...}::t,vh::vt)= | |
3237 | (update((!Memory),addrplus((!Reg) sub p,ofst),vh); dowr(t,vt) ) | | |
3238 | dowr(GETLAB{lab=(l,_),dst=(d,_)}::t,vt)= | |
3239 | (update((!Reg),d,(LABVAL (l,0)) ); dowr(t,vt) ) | | |
3240 | dowr(GETREAL{value=v,dst=(d,_)}::t,vt)= | |
3241 | (update((!Reg),d,(REAL (strToReal v)) ); dowr(t,vt) ) | | |
3242 | dowr(MOVE{dst=(d,_),...}::t,vh::vt)= | |
3243 | (update((!Reg),d,vh); dowr(t,vt) ) | | |
3244 | dowr(ARITH{dst=(d,_),...}::t,vh::vt)= | |
3245 | (update((!Reg),d,vh); dowr(t,vt) ) | | |
3246 | dowr(ARITHI{dst=(d,_),...}::t,vh::vt)= | |
3247 | (update((!Reg),d,vh); dowr(t,vt) ) | | |
3248 | dowr(JUMP{...}::t,vh::vt)= | |
3249 | (execjmp(vh); flag:=false; dowr(t,vt) ) | | |
3250 | dowr(BRANCH{test=comp,src1=(s1,_),src2=(s2,_), | |
3251 | dst=(labnum,_),...}::t,vt)= | |
3252 | if compare(comp,(!Reg) sub s1,(!Reg) sub s2) | |
3253 | then (IP:= !(findjmp_place(labnum)); flag:=false; dowr(t,vt) ) | |
3254 | else dowr(t,vt) | | |
3255 | dowr(h::t,vt)=dowr(t,vt) | |
3256 | ; | |
3257 | ||
3258 | (* vv3 executes an instruction word in version 3 mode. | |
3259 | *) | |
3260 | fun vv3(nil)= () | | |
3261 | vv3(l)=let val (l1,l2)=rddcut(nil,l); | |
3262 | val (l3,l4)=mddcut(nil,l1) | |
3263 | in (flag:=true; dowr(l3,calcult(l3)); Ref.inc(runcount); | |
3264 | if (!flag) then vv3(l4@l2) else () ) | |
3265 | end; | |
3266 | ||
3267 | fun vinit(k,l)=(init(l); sizen:=k; runcount:=0 ) ; | |
3268 | ||
3269 | fun vstep1()=let val f=(while hvnop(hd(!IP)) do IP:=tl(!IP)) | |
3270 | handle Hd=>raise End_of_Program; | |
3271 | val codel=fetchcode(!sizen) | |
3272 | in | |
3273 | (dowr(codel,calcult(codel)); Ref.inc(runcount) ) | |
3274 | end; | |
3275 | ||
3276 | fun vstep2()=let val f=(while hvnop(hd(!IP)) do IP:=tl(!IP)) | |
3277 | handle Hd=>raise End_of_Program; | |
3278 | val codel=fetchcode(!sizen) | |
3279 | in | |
3280 | if check_dd(codel) | |
3281 | then (output(std_out,"Data dependency checked in:\n"); | |
3282 | let fun f(nil)=() | | |
3283 | f(h::t)=(output(std_out,":"^disp(h)); f(t)) | |
3284 | in f(codel) end; | |
3285 | raise Data_dependency_checked | |
3286 | ) | |
3287 | else (dowr(codel,calcult(codel)); Ref.inc(runcount) ) | |
3288 | end; | |
3289 | ||
3290 | fun vstep3()=let val f=if (!IP)=nil then raise End_of_Program else (); | |
3291 | val codel=fetchcode3(!sizen) | |
3292 | in vv3(codel) end; | |
3293 | ||
3294 | fun vrun1()=(vstep1();vrun1()) | |
3295 | handle End_of_Program => | |
3296 | output(std_out,"End of program.\nTotal runtime: " | |
3297 | ^ims(!runcount)^" steps.\n"); | |
3298 | fun vrun2()=(vstep2(); vrun2()) | |
3299 | handle End_of_Program => | |
3300 | output(std_out,"End of program.\nTotal runtime: " | |
3301 | ^ims(!runcount)^" steps.\n")| | |
3302 | Data_dependency_checked=> | |
3303 | output(std_out,"Program halted.\n") ; | |
3304 | fun vrun3()=(vstep3(); vrun3()) | |
3305 | handle End_of_Program => | |
3306 | output(std_out,"End of program.\nTotal runtime: " | |
3307 | ^ims(!runcount)^" substeps.\n"); | |
3308 | ||
3309 | fun vpc()=let val codel=(!IP) ; | |
3310 | fun f (_,nil)=() | | |
3311 | f (0,_)= () | | |
3312 | f (k,h::l)=if k<=0 then () | |
3313 | else (output(std_out,disp(h) ); | |
3314 | if hvnop(h) then f(k,l) | |
3315 | else f(k-1,l) ) | |
3316 | in f((!sizen),codel) end; | |
3317 | ||
3318 | ||
3319 | (* This part for Pipeline mode *) | |
3320 | ||
3321 | ||
3322 | exception illegal_jump_within_branchdelay; | |
3323 | exception illegal_branch_within_branchdelay; | |
3324 | exception illegal_label_within_branchdelay; | |
3325 | exception illegal_labword_within_branchdelay; | |
3326 | exception illegal_word_within_branchdelay; | |
3327 | (* Rdelay points to the timing array of registers. | |
3328 | *) | |
3329 | val Rdelay=ref ( array(0,0) ); | |
3330 | (* clock records run time. withindelay is a flag used in BRANCH and JUMP delays. | |
3331 | *) | |
3332 | val clock=ref 0 and withindelay=ref false; | |
3333 | val fdelay=ref 1 and ardelay: ((arithop->int) ref)=ref (fn k=>1) | |
3334 | and jdelay=ref 1; | |
3335 | ||
3336 | (* pexec executes one instruction, increasing the clock when necessary, which | |
3337 | corresponding to the holding down of instruction streams. | |
3338 | *) | |
3339 | fun pexec(FETCH{immutable=_,offset=ofst,ptr=(p,_),dst=(d,_)})= | |
3340 | (let val t=(!Rdelay) sub p in | |
3341 | if (!clock)<t then clock:=t else () | |
3342 | end; | |
3343 | update((!Reg),d,content((!Reg) sub p,ofst) ); | |
3344 | update((!Rdelay),d,(!clock)+(!fdelay)); | |
3345 | Ref.inc(clock) | |
3346 | ) | | |
3347 | pexec(STORE{offset=ofst,src=(s,_),ptr=(p,_)})= | |
3348 | (let val t1=((!Rdelay) sub p) and t2=((!Rdelay) sub s) ; | |
3349 | val t=Int.max(t1,t2) in | |
3350 | if (!clock)<t then clock:=t else () | |
3351 | end; | |
3352 | update((!Memory),addrplus((!Reg) sub p,ofst),(!Reg) sub s); | |
3353 | Ref.inc(clock) | |
3354 | ) | | |
3355 | pexec(GETLAB{lab=(l,_),dst=(d,_)})= | |
3356 | (update((!Reg),d,(LABVAL (l,0)) ); | |
3357 | Ref.inc(clock) | |
3358 | ) | | |
3359 | pexec(GETREAL{value=v,dst=(d,_)})= | |
3360 | (update((!Reg),d,(REAL (strToReal v)) ); | |
3361 | Ref.inc(clock) | |
3362 | ) | | |
3363 | pexec(MOVE{src=(s,_),dst=(d,_)})= | |
3364 | (let val t=(!Rdelay) sub s in | |
3365 | if (!clock)<t then clock:=t else () | |
3366 | end; | |
3367 | update((!Reg),d,(!Reg) sub s); | |
3368 | Ref.inc(clock) | |
3369 | ) | | |
3370 | pexec(ARITH{oper=opn,src1=(s1,_),src2=(s2,_),dst=(d,_)})= | |
3371 | (let val t1=((!Rdelay) sub s1) and t2=((!Rdelay) sub s2); | |
3372 | val t=Int.max(t1,t2) in | |
3373 | if (!clock)<t then clock:=t else () | |
3374 | end; | |
3375 | update((!Reg),d,getresult(opn,(!Reg) sub s1,(!Reg) sub s2) ); | |
3376 | update((!Rdelay),d,((!ardelay) opn)+(!clock) ); | |
3377 | Ref.inc(clock) | |
3378 | ) | | |
3379 | pexec(ARITHI{oper=opn,src1=(s1,_),src2=n1,dst=(d,_)})= | |
3380 | (let val t=((!Rdelay) sub s1) in | |
3381 | if (!clock)<t then clock:=t else () | |
3382 | end; | |
3383 | update((!Reg),d,getresult(opn,(!Reg) sub s1,(INT n1) ) ); | |
3384 | update((!Rdelay),d,((!ardelay) opn)+(!clock) ); | |
3385 | Ref.inc(clock) | |
3386 | ) | | |
3387 | pexec(JUMP {dst=(d,_),...})= | |
3388 | if (!withindelay) then raise illegal_jump_within_branchdelay | |
3389 | else | |
3390 | (let val t=((!Rdelay) sub d) in | |
3391 | if (!clock)<t then clock:=t else () | |
3392 | end; | |
3393 | Ref.inc(clock); withindelay:=true; | |
3394 | let val i=ref 0 in | |
3395 | while ((!i)<(!jdelay)) do | |
3396 | (let val h=hd(!IP) in | |
3397 | ( pexec(h); Ref.inc(i) ) | |
3398 | end handle Hd=> (i:=(!jdelay) ) ; | |
3399 | (IP:=tl(!IP)) handle Tl=>() | |
3400 | ) | |
3401 | end; | |
3402 | execjmp((!Reg) sub d) | |
3403 | ) | | |
3404 | pexec(BRANCH{test=comp,src1=(s1,_),src2=(s2,_),dst=(labnum,_),...})= | |
3405 | if (!withindelay) then raise illegal_branch_within_branchdelay | |
3406 | else | |
3407 | (let val t1=((!Rdelay) sub s1) and t2=((!Rdelay) sub s2); | |
3408 | val t=Int.max(t1,t2) in | |
3409 | if (!clock)<t then clock:=t else () | |
3410 | end; | |
3411 | Ref.inc(clock); withindelay:=true; | |
3412 | let val i=ref 0 in | |
3413 | while ((!i)<(!jdelay)) do | |
3414 | (let val h=hd(!IP) in | |
3415 | ( pexec(h); Ref.inc(i) ) | |
3416 | end handle Hd=> (i:=(!jdelay) ) ; | |
3417 | (IP:=tl(!IP)) handle Tl=>() | |
3418 | ) | |
3419 | end; | |
3420 | if compare(comp,(!Reg) sub s1,(!Reg) sub s2) | |
3421 | then (IP:= !(findjmp_place(labnum) ) ) | |
3422 | else () | |
3423 | ) | | |
3424 | pexec(NOP)=Ref.inc(clock) | | |
3425 | pexec(LABEL{...})=if (!withindelay) | |
3426 | then raise illegal_label_within_branchdelay | |
3427 | else () | | |
3428 | pexec(LABWORD{...})=if (!withindelay) | |
3429 | then raise illegal_labword_within_branchdelay | |
3430 | else () | | |
3431 | pexec(WORD{...})=if (!withindelay) | |
3432 | then raise illegal_word_within_branchdelay | |
3433 | else () | |
3434 | ; | |
3435 | ||
3436 | fun pinit(fetchdelay,arithdelay,jumpdelay,l)= | |
3437 | (init(l); | |
3438 | Rdelay:=array((!RegN),0); | |
3439 | clock:=0; fdelay:=fetchdelay; | |
3440 | ardelay:=arithdelay; jdelay:=jumpdelay ); | |
3441 | ||
3442 | fun pstep()= | |
3443 | let | |
3444 | val Instruction=(hd(!IP) handle Hd=>raise End_of_Program) | |
3445 | in (IP:=tl(!IP) handle Tl=>raise End_of_Program; | |
3446 | withindelay:=false; pexec(Instruction) ) | |
3447 | end; | |
3448 | ||
3449 | fun prun()=(pstep(); prun() ) handle End_of_Program=> | |
3450 | (output(std_out,"End of program.\n"); | |
3451 | output(std_out,"Total time used: "^ims(!clock)^" cycles.\n") ); | |
3452 | ||
3453 | end; | |
3454 | structure SimStuff = | |
3455 | struct | |
3456 | ||
3457 | fun read file = | |
3458 | let val if1 = (open_in "simprelude.s") | |
3459 | val if2 = (open_in file) | |
3460 | val if3 = (open_in "simpostlude.s") | |
3461 | val prelude = ReadAbs.read if1 | |
3462 | val prog = ReadAbs.read if2 | |
3463 | val postlude = ReadAbs.read if3 | |
3464 | in | |
3465 | close_in if1; | |
3466 | close_in if2; | |
3467 | close_in if3; | |
3468 | prelude @ prog @ postlude | |
3469 | end | |
3470 | ||
3471 | fun init file = SetEnv.init (read file) | |
3472 | ||
3473 | val runcount = ref 0 | |
3474 | ||
3475 | fun run ()= | |
3476 | let open AbsMach | |
3477 | val foo = runcount := 0 | |
3478 | fun updc NOP = runcount := !runcount + 1 | |
3479 | | updc _ = () | |
3480 | open SetEnv | |
3481 | fun f () = (step(); (updc o hd o pc)(); f()) | |
3482 | in | |
3483 | f() | |
3484 | end | |
3485 | ||
3486 | fun srun () = let open SetEnv in d_pc(); step(); srun() end; | |
3487 | ||
3488 | fun memsave () = !SetEnv.Memory | |
3489 | ||
3490 | ||
3491 | fun memcmp(a:AbsMach.values array, b:AbsMach.values array) = | |
3492 | let open AbsMach | |
3493 | fun cmp (INT a, INT b) = a = b | |
3494 | | cmp (REAL a, REAL b) = realEq(a, b) | |
3495 | | cmp (LABVAL _, LABVAL _) = true | |
3496 | | cmp _ = false | |
3497 | fun f 0 = ~1 | |
3498 | | f n = if cmp((a sub n), (b sub n)) then f (n - 1) else n | |
3499 | val al = Array.length a | |
3500 | val bl = Array.length b | |
3501 | in | |
3502 | if al = bl then f (al - 1) else (print "size\n"; 0) | |
3503 | end | |
3504 | ||
3505 | ||
3506 | fun copyarray a = | |
3507 | let val la = Array.length a | |
3508 | val na = array(la, a sub 0) | |
3509 | fun f n = if n > 0 then (update(na, n, a sub n) ; f (n - 1)) else () | |
3510 | val foo = f (la - 1) | |
3511 | in | |
3512 | na | |
3513 | end | |
3514 | ||
3515 | ||
3516 | exception PROG_NO_END | |
3517 | ||
3518 | local open AbsMach | |
3519 | in | |
3520 | fun vstring (INT i) = "INT " ^ makestring i | |
3521 | | vstring (REAL i) = "REAL " ^ Real.toString i | |
3522 | | vstring (LABVAL(i, j)) = | |
3523 | "LABVAL(" ^ makestring i ^ ", " ^ makestring j ^ ")" | |
3524 | end | |
3525 | ||
3526 | fun runf f = | |
3527 | ((init f; | |
3528 | run (); | |
3529 | raise PROG_NO_END)) | |
3530 | handle End_of_Program => (print "eop\n"; | |
3531 | SetEnv.regc 4) | |
3532 | ||
3533 | ||
3534 | fun cmprog(f1, f2) = | |
3535 | let open AbsMach | |
3536 | fun intof (INT i) = i | |
3537 | fun ptsat p = SetEnv.mcell (intof p) | |
3538 | val p1 = runf f1 | |
3539 | (* val foo = print ("cmprog1:" ^ vstring p1 ^ "\n") *) | |
3540 | val v1 = ptsat p1 | |
3541 | val r1 = !runcount | |
3542 | val p2 = runf f2 | |
3543 | (* val foo = print ("cmprog2:" ^ vstring p2 ^ "\n") *) | |
3544 | val v2 = ptsat p2 | |
3545 | val r2 = !runcount | |
3546 | ||
3547 | in | |
3548 | (f1 ^ " ct " ^ makestring r1 ^ " ptr " ^ vstring p1 ^ | |
3549 | " val " ^ vstring v1 ^ | |
3550 | f2 ^ " ct " ^ makestring r2 ^ " ptr " ^ vstring p2 ^ | |
3551 | " val " ^ vstring v2 ^ "\n") | |
3552 | end | |
3553 | ||
3554 | end | |
3555 | ||
3556 | fun time str f = | |
3557 | let (* open System.Timer | |
3558 | val s = start_timer() *) | |
3559 | val v = f() | |
3560 | (* | |
3561 | val e = check_timer s | |
3562 | val foo = print (str ^ " took " ^ makestring e ^ "sec.usec\n") | |
3563 | *) | |
3564 | in | |
3565 | v | |
3566 | end | |
3567 | ||
3568 | ||
3569 | fun writeprog(file, j, p) = | |
3570 | let val ot = (open_out file) | |
3571 | val prog = ReadI.writeI(j, p) | |
3572 | val filp = (Delay.rm_bogus o OutFilter.remnops) prog | |
3573 | val xxx = PrintAbs.show ot filp | |
3574 | in | |
3575 | close_out ot | |
3576 | end; | |
3577 | ||
3578 | fun wp(file, prog) = | |
3579 | let val ot = (open_out file) | |
3580 | val filp = Delay.rm_bogus prog | |
3581 | val xxx = PrintAbs.show ot filp | |
3582 | in | |
3583 | close_out ot | |
3584 | end; | |
3585 | ||
3586 | fun dodelay i = (Delay.init i; Delay.add_delay i); | |
3587 | ||
3588 | val _ = ( | |
3589 | Node.move_test_debug := false; | |
3590 | Node.move_op_debug := false; | |
3591 | Node.rw_debug := false; | |
3592 | Node.delete_debug := false; | |
3593 | Node.ntn_debug := true; | |
3594 | Node.prog_node_debug := false; | |
3595 | Node.prog_node_debug_verbose := false; | |
3596 | Node.closure_progs_debug := false; | |
3597 | Node.cpsiCheck := false; | |
3598 | Compress.compress_debug := false; | |
3599 | ReadI.read_debug := false; | |
3600 | ReadI.write_debug := false; | |
3601 | ReadI.live_debug := false | |
3602 | ) | |
3603 | ||
3604 | fun pm pl = print (StrPak.stringListString (map ReadI.progMap pl)); | |
3605 | fun pp pl = print (StrPak.stringListString (map PrintAbs.str pl)); | |
3606 | ||
3607 | fun ndnm nil = raise Node.NAMETONODE | |
3608 | | ndnm(h::t) = (fn (nm) => Node.nameToNode(h, nm) | |
3609 | handle Node.NAMETONODE => ndnm t nm); | |
3610 | ||
3611 | exception ERROR; | |
3612 | ||
3613 | fun err (s:string) = (print s; raise ERROR); | |
3614 | ||
3615 | fun pmem nil = (err "oh well") | |
3616 | | pmem ((ns, n0, f)::t) = | |
3617 | fn n => if Set.member(ns, n) then (ns, n0, f) | |
3618 | else pmem t n; | |
3619 | ||
3620 | structure Main = struct | |
3621 | ||
3622 | fun doitx (ifile:string, ofile:string, c_ofile:string, ws:int) = | |
3623 | let val foo = Ntypes.init_names() | |
3624 | val ins = open_in ifile | |
3625 | val i = (dodelay o BreakInst.breaki o ReadAbs.read) ins | |
3626 | val _ = close_in ins | |
3627 | val (j, p) = time "Building Nodes" (fn () => ReadI.readI i) | |
3628 | val x = time "writing unopt" (fn () => writeprog(ofile, j, p)) | |
3629 | fun cwin p = Compress.compress(ws, p) | |
3630 | val cp = time "compressing program" (fn () => map cwin p) | |
3631 | val xx = time "writing opt program" (fn () => writeprog(c_ofile, j, cp)) | |
3632 | val answer = "" (* SimStuff.cmprog(ofile, c_ofile) *) | |
3633 | val code_motions = Ntypes.new_name "0" | |
3634 | in | |
3635 | print (answer ^ "code_motions " ^ code_motions ^ " \n") | |
3636 | end | |
3637 | ||
3638 | fun main(s:string list, env:string list) = | |
3639 | let val idemp = ref 0 | |
3640 | val ws = ref 0 | |
3641 | val ifile = ref "/dev/null" | |
3642 | val ofile = ref "/dev/null" | |
3643 | val c_ofile = ref "/dev/null" | |
3644 | val gotifile = ref false | |
3645 | val gotofile = ref false | |
3646 | fun digit d = | |
3647 | if ord d >= ord "0" andalso ord d <= ord "9" then ord d - ord "0" | |
3648 | else err ("expected digit. got " ^ d) | |
3649 | val parse = | |
3650 | fn ("-" :: "i" :: "d" :: "e" :: "m" :: d :: nil) => | |
3651 | idemp := digit d | |
3652 | | ("-" :: "w" :: "s" :: d :: nil) => | |
3653 | ws := digit d | |
3654 | | ("-" :: t) => | |
3655 | (print ("usage: comp [-ws#] [-idem#]" ^ | |
3656 | "input_file temp_file compressed_file\n"); | |
3657 | print ("ws is the window size\nidem is the idempotency\n"); | |
3658 | err "exiting") | |
3659 | | s => if !gotofile then c_ofile := implode s | |
3660 | else if !gotifile then (gotofile := true; | |
3661 | ofile := implode s) | |
3662 | else (gotifile := true; | |
3663 | ifile := implode s) | |
3664 | val foo = List.app (parse o explode) (tl s) | |
3665 | val foo = print ("compressing " ^ !ifile ^ " into (uncompressed)" ^ | |
3666 | !ofile ^ | |
3667 | " and (compressed)" ^ !c_ofile ^ | |
3668 | " with idempotency " ^ makestring (!idemp) ^ | |
3669 | " and window size " ^ makestring (!ws) ^ "\n") | |
3670 | in | |
3671 | Delay.idempotency := !idemp; | |
3672 | doitx(!ifile, !ofile, !c_ofile, !ws) | |
3673 | end | |
3674 | ||
3675 | val s = OS.FileSys.getDir() | |
3676 | ||
3677 | fun doit() = main(["foobar", "-ws9", | |
3678 | s^"/DATA/ndotprod.s", | |
3679 | s^"/DATA/tmp.s", | |
3680 | s^"/DATA/cmp.s"], | |
3681 | nil) | |
3682 | fun testit _ = () | |
3683 | end | |
3684 | ||
3685 | structure Main : BMARK = | |
3686 | struct | |
3687 | open Main | |
3688 | ||
3689 | val doit = | |
3690 | fn n => | |
3691 | let | |
3692 | fun loop n = | |
3693 | if n = 0 | |
3694 | then () | |
3695 | else (doit(); | |
3696 | loop(n-1)) | |
3697 | in loop n | |
3698 | end | |
3699 | end |