Add the tiger source code bundle from the book site

Signed-off-by: jmug <u.g.a.mariano@gmail.com>

tiger/chap9/assem.sml

@@ -0,0 +1,39 @@
+structure Assem = struct
+
+  type reg = string
+  type temp = Temp.temp
+  type label = Temp.label
+
+  datatype instr = OPER of {assem: string,
+			    dst: temp list,
+			    src: temp list,
+			    jump: label list option}
+                 | LABEL of {assem: string, lab: Temp.label}
+                 | MOVE of {assem: string, 
+			    dst: temp,
+			    src: temp}
+
+  fun format saytemp =
+    let 
+	fun speak(assem,dst,src,jump) =
+	    let val saylab = Symbol.name    
+		fun f(#"`":: #"s":: i::rest) = 
+		    (explode(saytemp(List.nth(src,ord i - ord #"0"))) @ f rest)
+		  | f( #"`":: #"d":: i:: rest) = 
+		    (explode(saytemp(List.nth(dst,ord i - ord #"0"))) @ f rest)
+		  | f( #"`":: #"j":: i:: rest) = 
+		    (explode(saylab(List.nth(jump,ord i - ord #"0"))) @ f rest)
+		  | f( #"`":: #"`":: rest) = #"`" :: f rest
+		  | f( #"`":: _ :: rest) = ErrorMsg.impossible "bad Assem format"
+		  | f(c :: rest) = (c :: f rest)
+		  | f nil = nil
+	    in implode(f(explode assem))
+	    end
+      in fn OPER{assem,dst,src,jump=NONE} => speak(assem,dst,src,nil)
+          | OPER{assem,dst,src,jump=SOME j} => speak(assem,dst,src,j)
+	  | LABEL{assem,...} => assem
+	  | MOVE{assem,dst,src} => speak(assem,[dst],[src],nil)
+     end
+
+end
+

tiger/chap9/canon.sml

@@ -0,0 +1,183 @@
+signature CANON = 
+sig
+    val linearize : Tree.stm -> Tree.stm list
+        (* From an arbitrary Tree statement, produce a list of cleaned trees
+	   satisfying the following properties:
+	      1.  No SEQ's or ESEQ's
+	      2.  The parent of every CALL is an EXP(..) or a MOVE(TEMP t,..)
+        *)
+
+    val basicBlocks : Tree.stm list -> (Tree.stm list list * Tree.label)
+        (* From a list of cleaned trees, produce a list of
+	 basic blocks satisfying the following properties:
+	      1. and 2. as above;
+	      3.  Every block begins with a LABEL;
+              4.  A LABEL appears only at the beginning of a block;
+              5.  Any JUMP or CJUMP is the last stm in a block;
+              6.  Every block ends with a JUMP or CJUMP;
+           Also produce the "label" to which control will be passed
+           upon exit.
+        *)
+
+    val traceSchedule : Tree.stm list list * Tree.label -> Tree.stm list
+         (* From a list of basic blocks satisfying properties 1-6,
+            along with an "exit" label,
+	    produce a list of stms such that:
+	      1. and 2. as above;
+              7. Every CJUMP(_,t,f) is immediately followed by LABEL f.
+            The blocks are reordered to satisfy property 7; also
+	    in this reordering as many JUMP(T.NAME(lab)) statements
+            as possible are eliminated by falling through into T.LABEL(lab).
+         *)
+end
+
+structure Canon : CANON = 
+struct
+
+  structure T = Tree
+
+ fun linearize(stm0: T.stm) : T.stm list =
+ let
+  infix %
+  fun (T.EXP(T.CONST _)) % x = x
+    | x % (T.EXP(T.CONST _)) = x
+    | x % y = T.SEQ(x,y)
+
+  fun commute(T.EXP(T.CONST _), _) = true
+    | commute(_, T.NAME _) = true
+    | commute(_, T.CONST _) = true
+    | commute _ = false
+
+  val nop = T.EXP(T.CONST 0)
+
+  fun reorder ((e as T.CALL _ )::rest) =
+	let val t = Temp.newtemp()
+	 in reorder(T.ESEQ(T.MOVE(T.TEMP t, e), T.TEMP t) :: rest)
+	end
+    | reorder (a::rest) =
+	 let val (stms,e) = do_exp a
+	     val (stms',el) = reorder rest
+	  in if commute(stms',e)
+	     then (stms % stms',e::el)
+	     else let val t = Temp.newtemp()
+		   in (stms % T.MOVE(T.TEMP t, e) % stms', T.TEMP t :: el)
+		  end
+	 end
+    | reorder nil = (nop,nil)
+
+  and reorder_exp(el,build) = let val (stms,el') = reorder el
+                        in (stms, build el')
+                       end
+
+  and reorder_stm(el,build) = let val (stms,el') = reorder (el)
+		 	 in stms % build(el')
+			end
+
+  and do_stm(T.SEQ(a,b)) = 
+               do_stm a % do_stm b
+    | do_stm(T.JUMP(e,labs)) = 
+	       reorder_stm([e],fn [e] => T.JUMP(e,labs))
+    | do_stm(T.CJUMP(p,a,b,t,f)) = 
+               reorder_stm([a,b], fn[a,b]=> T.CJUMP(p,a,b,t,f))
+    | do_stm(T.MOVE(T.TEMP t,T.CALL(e,el))) = 
+               reorder_stm(e::el,fn e::el => T.MOVE(T.TEMP t,T.CALL(e,el)))
+    | do_stm(T.MOVE(T.TEMP t,b)) = 
+	       reorder_stm([b],fn[b]=>T.MOVE(T.TEMP t,b))
+    | do_stm(T.MOVE(T.MEM e,b)) = 
+	       reorder_stm([e,b],fn[e,b]=>T.MOVE(T.MEM e,b))
+    | do_stm(T.MOVE(T.ESEQ(s,e),b)) = 
+	       do_stm(T.SEQ(s,T.MOVE(e,b)))
+    | do_stm(T.EXP(T.CALL(e,el))) = 
+	       reorder_stm(e::el,fn e::el => T.EXP(T.CALL(e,el)))
+    | do_stm(T.EXP e) = 
+	       reorder_stm([e],fn[e]=>T.EXP e)
+    | do_stm s = reorder_stm([],fn[]=>s)
+
+  and do_exp(T.BINOP(p,a,b)) = 
+                 reorder_exp([a,b], fn[a,b]=>T.BINOP(p,a,b))
+    | do_exp(T.MEM(a)) = 
+		 reorder_exp([a], fn[a]=>T.MEM(a))
+    | do_exp(T.ESEQ(s,e)) = 
+		 let val stms = do_stm s
+		     val (stms',e) = do_exp e
+		  in (stms%stms',e)
+		 end
+    | do_exp(T.CALL(e,el)) = 
+		 reorder_exp(e::el, fn e::el => T.CALL(e,el))
+    | do_exp e = reorder_exp([],fn[]=>e)
+
+  (* linear gets rid of the top-level SEQ's, producing a list *)
+  fun linear(T.SEQ(a,b),l) = linear(a,linear(b,l))
+    | linear(s,l) = s::l
+
+ in (* body of linearize *)
+    linear(do_stm stm0, nil)
+ end
+
+  type block = T.stm list
+
+  (* Take list of statements and make basic blocks satisfying conditions
+       3 and 4 above, in addition to the extra condition that 
+      every block ends with a JUMP or CJUMP *)
+
+  fun basicBlocks stms = 
+     let val done = Temp.newlabel()
+         fun blocks((head as T.LABEL _) :: tail, blist) =
+	     let fun next((s as (T.JUMP _))::rest, thisblock) =
+		                endblock(rest, s::thisblock)
+		   | next((s as (T.CJUMP _))::rest, thisblock) =
+                                endblock(rest,s::thisblock)
+		   | next(stms as (T.LABEL lab :: _), thisblock) =
+                                next(T.JUMP(T.NAME lab,[lab]) :: stms, thisblock)
+		   | next(s::rest, thisblock) = next(rest, s::thisblock)
+		   | next(nil, thisblock) = 
+			     next([T.JUMP(T.NAME done, [done])], thisblock)
+		 
+		 and endblock(stms, thisblock) = 
+		            blocks(stms, rev thisblock :: blist)
+		     
+	     in next(tail, [head])
+	     end
+	   | blocks(nil, blist) = rev blist
+	   | blocks(stms, blist) = blocks(T.LABEL(Temp.newlabel())::stms, blist)
+      in (blocks(stms,nil), done)
+     end
+
+  fun enterblock(b as (T.LABEL s :: _), table) = Symbol.enter(table,s,b)
+    | enterblock(_, table) = table
+
+  fun splitlast([x]) = (nil,x)
+    | splitlast(h::t) = let val (t',last) = splitlast t in (h::t', last) end
+
+  fun trace(table,b as (T.LABEL lab :: _),rest) = 
+   let val table = Symbol.enter(table, lab, nil)
+    in case splitlast b
+     of (most,T.JUMP(T.NAME lab, _)) =>
+	  (case Symbol.look(table, lab)
+            of SOME(b' as _::_) => most @ trace(table, b', rest)
+	     | _ => b @ getnext(table,rest))
+      | (most,T.CJUMP(opr,x,y,t,f)) =>
+          (case (Symbol.look(table,t), Symbol.look(table,f))
+            of (_, SOME(b' as _::_)) => b @ trace(table, b', rest)
+             | (SOME(b' as _::_), _) => 
+		           most @ [T.CJUMP(T.notRel opr,x,y,f,t)]
+		                @ trace(table, b', rest)
+             | _ => let val f' = Temp.newlabel()
+		     in most @ [T.CJUMP(opr,x,y,t,f'), 
+				T.LABEL f', T.JUMP(T.NAME f,[f])]
+			     @ getnext(table,rest)
+                        end)
+      | (most, T.JUMP _) => b @ getnext(table,rest)
+     end
+
+  and getnext(table,(b as (T.LABEL lab::_))::rest) = 
+           (case Symbol.look(table, lab)
+             of SOME(_::_) => trace(table,b,rest)
+              | _ => getnext(table,rest))
+    | getnext(table,nil) = nil
+
+  fun traceSchedule(blocks,done) = 
+       getnext(foldr enterblock Symbol.empty blocks, blocks)
+         @ [T.LABEL done]
+
+end

tiger/chap9/flowgraph.sml

@@ -0,0 +1,23 @@
+structure Flow =
+struct
+    datatype flowgraph = FGRAPH of {control: Graph.graph,
+				    def: Temp.temp list Graph.Table.table,
+				    use: Temp.temp list Graph.Table.table,
+				    ismove: bool Graph.Table.table}
+
+  (* Note:  any "use" within the block is assumed to be BEFORE a "def" 
+        of the same variable.  If there is a def(x) followed by use(x)
+       in the same block, do not mention the use in this data structure,
+       mention only the def.
+
+     More generally:
+       If there are any nonzero number of defs, mention def(x).
+       If there are any nonzero number of uses BEFORE THE FIRST DEF,
+           mention use(x).
+
+     For any node in the graph,  
+           Graph.Table.look(def,node) = SOME(def-list)
+           Graph.Table.look(use,node) = SOME(use-list)
+   *)
+
+end

tiger/chap9/graph.sig

@@ -0,0 +1,23 @@
+signature GRAPH =
+sig
+    type graph
+    type node
+    
+    val nodes: graph -> node list
+    val succ: node -> node list
+    val pred: node -> node list
+    val adj: node -> node list   (* succ+pred *)
+    val eq: node*node -> bool
+
+    val newGraph: unit -> graph
+    val newNode : graph -> node
+    exception GraphEdge
+    val mk_edge: {from: node, to: node} -> unit
+    val rm_edge: {from: node, to: node} -> unit
+
+    structure Table : TABLE 
+    sharing type Table.key = node
+
+    val nodename: node->string  (* for debugging only *)
+
+end

tiger/chap9/graph.sml

@@ -0,0 +1,80 @@
+structure Graph :> GRAPH =
+struct
+  type node' = int
+  type temp = Temp.temp
+
+  datatype noderep = NODE of {succ: node' list, pred: node' list}
+
+  val emptyNode = NODE{succ=[],pred=[]}
+
+  val bogusNode = NODE{succ=[~1],pred=[]}
+
+  fun isBogus(NODE{succ= ~1::_,...}) = true
+    | isBogus _ = false
+
+  structure A = DynamicArrayFn(struct open Array
+				    type elem = noderep
+				    type vector = noderep vector
+				    type array = noderep array
+                             end)
+
+  type graph = A.array
+
+  type node = graph * node'
+  fun eq((_,a),(_,b)) = a=b
+
+  fun augment (g: graph) (n: node') : node = (g,n)
+
+  fun newGraph() = A.array(0,bogusNode)
+
+  fun nodes g = let val b = A.bound g
+                    fun f i = if isBogus( A.sub(g,i)) then nil
+			           else (g,i)::f(i+1)
+		 in f 0			     
+                end
+
+  fun succ(g,i) = let val NODE{succ=s,...} = A.sub(g,i) 
+		   in map (augment g) s 
+		  end
+  fun pred(g,i) = let val NODE{pred=p,...} = A.sub(g,i)
+                     in map (augment g) p 
+		  end
+  fun adj gi = pred gi @ succ gi
+
+  fun newNode g = (* binary search for unused node *)
+    let fun look(lo,hi) =
+               (* i < lo indicates i in use
+                  i >= hi indicates i not in use *)
+            if lo=hi then (A.update(g,lo,emptyNode); (g,lo))
+            else let val m = (lo+hi) div 2
+                  in if isBogus(A.sub(g,m)) then look(lo,m) else look(m+1,hi)
+                 end
+     in look(0, 1 + A.bound g)
+    end
+
+  exception GraphEdge
+  fun check(g,g') = (* if g=g' then () else raise GraphEdge *) ()
+
+  fun delete(i,j::rest) = if i=j then rest else j::delete(i,rest)
+    | delete(_,nil) = raise GraphEdge
+
+  fun diddle_edge change {from=(g:graph, i),to=(g':graph, j)} = 
+      let val _ = check(g,g')
+          val NODE{succ=si,pred=pi} = A.sub(g,i)
+          val _ = A.update(g,i,NODE{succ=change(j,si),pred=pi})
+          val NODE{succ=sj,pred=pj} = A.sub(g,j)
+          val _ = A.update(g,j,NODE{succ=sj,pred=change(i,pj)})
+       in ()
+      end
+
+  val mk_edge = diddle_edge (op ::)
+  val rm_edge = diddle_edge delete
+
+  structure Table = IntMapTable(type key = node
+				fun getInt(g,n) = n)
+
+
+  fun nodename(g,i:int) = "n" ^ Int.toString(i)
+
+end
+

tiger/chap9/main.sml

@@ -0,0 +1,39 @@
+structure Main = struct
+
+   structure Tr = Translate
+   structure F = Frame
+   structure R = RegAlloc
+
+ fun getsome (SOME x) = x
+
+   fun emitproc out (F.PROC{body,frame}) =
+     let val _ = print ("emit " ^ Frame.name frame ^ "\n")
+(*         val _ = Printtree.printtree(out,body); *)
+	 val stms = Canon.linearize body
+(*         val _ = app (fn s => Printtree.printtree(out,s)) stms; *)
+         val stms' = Canon.traceSchedule(Canon.basicBlocks stms)
+	 val instrs =   List.concat(map (Mips.codegen frame) stms') 
+         val format0 = Assem.format(Temp.makestring)
+      in  app (fn i => TextIO.output(out,format0 i)) instrs;
+     end
+     end
+    | emitproc out (F.STRING(lab,s)) = TextIO.output(out,F.string(lab,s))
+
+   fun withOpenFile fname f = 
+       let val out = TextIO.openOut fname
+        in (f out before TextIO.closeOut out) 
+	    handle e => (TextIO.closeOut out; raise e)
+       end 
+
+   fun compile filename = 
+       let val absyn = Parse.parse filename
+           val frags = (FindEscape.prog absyn; Semant.transProg absyn)
+        in 
+            withOpenFile (filename ^ ".s") 
+	     (fn out => (app (emitproc out) frags))
+       end
+
+end
+
+
+

tiger/chap9/runtime.c

@@ -0,0 +1,109 @@
+#undef __STDC__
+#include <stdio.h>
+
+
+int *initArray(int size, int init)
+{int i;
+ int *a = (int *)malloc(size*sizeof(int));
+ for(i=0;i<size;i++) a[i]=init;
+ return a;
+}
+
+int *allocRecord(int size)
+{int i;
+ int *p, *a;
+ p = a = (int *)malloc(size);
+ for(i=0;i<size;i+=sizeof(int)) *p++ = 0;
+ return a;
+}
+
+struct string {int length; unsigned char chars[1];};
+
+int stringEqual(struct string *s, struct string *t)
+{int i;
+ if (s==t) return 1;
+ if (s->length!=t->length) return 0;
+ for(i=0;i<s->length;i++) if (s->chars[i]!=t->chars[i]) return 0;
+ return 1;
+}
+
+void print(struct string *s)
+{int i; unsigned char *p=s->chars;
+ for(i=0;i<s->length;i++,p++) putchar(*p);
+}
+
+void flush()
+{
+ fflush(stdout);
+}
+
+struct string consts[256];
+struct string empty={0,""};
+
+int main()
+{int i;
+ for(i=0;i<256;i++)
+   {consts[i].length=1;
+    consts[i].chars[0]=i;
+   }
+ return tigermain(0 /* static link!? */);
+}
+
+int ord(struct string *s)
+{
+ if (s->length==0) return -1;
+ else return s->chars[0];
+}
+
+struct string *chr(int i)
+{
+ if (i<0 || i>=256) 
+   {printf("chr(%d) out of range\n",i); exit(1);}
+ return consts+i;
+}
+
+int size(struct string *s)
+{ 
+ return s->length;
+}
+
+struct string *substring(struct string *s, int first, int n)
+{
+ if (first<0 || first+n>s->length)
+   {printf("substring([%d],%d,%d) out of range\n",s->length,first,n);
+    exit(1);}
+ if (n==1) return consts+s->chars[first];
+ {struct string *t = (struct string *)malloc(sizeof(int)+n);
+  int i;
+  t->length=n;
+  for(i=0;i<n;i++) t->chars[i]=s->chars[first+i];
+  return t;
+ }
+}
+
+struct string *concat(struct string *a, struct string *b)
+{
+ if (a->length==0) return b;
+ else if (b->length==0) return a;
+ else {int i, n=a->length+b->length;
+       struct string *t = (struct string *)malloc(sizeof(int)+n);
+       t->length=n;
+       for (i=0;i<a->length;i++)
+	 t->chars[i]=a->chars[i];
+       for(i=0;i<b->length;i++)
+	 t->chars[i+a->length]=b->chars[i];
+       return t;
+     }
+}
+
+int not(int i)
+{ return !i;
+}
+
+#undef getchar
+
+struct string *getchar()
+{int i=getc(stdin);
+ if (i==EOF) return &empty;
+ else return consts+i;
+}