Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/benchmarks/programs/vliw/vliwOLD.sml
ViewVC logotype

Annotation of /sml/trunk/benchmarks/programs/vliw/vliwOLD.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (view) (download)

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

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0