diff lab4/optree.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab4/optree.ml	Thu Oct 05 08:04:15 2017 +0100
@@ -0,0 +1,199 @@
+(* lab4/optree.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Print
+
+(* |symbol| -- global symbols *)
+type symbol = string
+
+type codelab = int
+
+let nolab = -1
+
+(* |lab| -- last used code label *)
+let lab = ref 0
+
+(* |label| -- allocate a code label *)
+let label () = incr lab; !lab
+
+(* |fLab| -- format a code label for printf *)
+let fLab n = fMeta "L$" [fNum n]
+
+let nosym = "*nosym*"
+
+let gensym () = sprintf "g$" [fNum (label ())]
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not | Lsl
+  | Lsr | Asr | BitAnd | BitOr | BitNot
+
+(* |inst| -- type of intermediate instructions *)
+type inst =
+    CONST of int                (* Constant (value) *)
+  | GLOBAL of symbol            (* Constant (symbol, offset) *)
+  | LOCAL of int                (* Local address (offset) *)
+  | REGVAR of int               (* Register (index) *)
+  | LOADC                       (* Load char *)
+  | LOADW                       (* Load word *)
+  | STOREC                      (* Store char *)
+  | STOREW                      (* Store word *)
+  | ARG of int                  (* Pass argument (index) *)
+  | SLINK                       (* Pass static link *)
+  | PCALL of int                (* Call procedure (nparams) *)
+  | RESULTW                     (* Procedure result *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | BOUND                       (* Array bound check *)
+  | NCHECK                      (* Null pointer check *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (cond, dest) *)
+  | JCASE of codelab list * codelab (* Jump table *)
+
+  (* Extra instructions *)
+  | LINE of int                 (* Line number *)
+  | NOP
+  | SEQ
+  | AFTER                       (* Expression with side effect *)
+  | DEFTMP of int
+  | TEMP of int                 (* Temporary *)
+
+let op_name =
+  function
+      Plus -> "PLUS" | Minus -> "MINUS" | Times -> "TIMES"
+    | Div -> "DIV" | Mod -> "MOD" | Eq -> "EQ"
+    | Uminus -> "UMINUS" | Lt -> "LT" | Gt -> "GT" 
+    | Leq -> "LEQ" | Geq -> "GEQ" | Neq -> "NEQ" 
+    | And -> "AND" | Or -> "OR" | Not -> "NOT"
+    | Lsl -> "LSL" | Lsr -> "LSR" | Asr -> "ASR" 
+    | BitAnd -> "BITAND" | BitOr -> "BITOR" | BitNot -> "BITNOT"
+
+let fOp w = fStr (op_name w)
+
+let fType1 =
+  function 0 -> fStr "" | 1 -> fStr "W" | s -> fMeta "*$*" [fNum s]
+
+let fInst =
+  function
+      CONST x ->        fMeta "CONST $" [fNum x]
+    | GLOBAL a ->       fMeta "GLOBAL $" [fStr a]
+    | LOCAL n ->        fMeta "LOCAL $" [fNum n]
+    | REGVAR i ->       fMeta "REGVAR $" [fNum i]
+    | LOADC ->          fStr "LOADC"
+    | LOADW ->          fStr "LOADW"
+    | STOREC ->         fStr "STOREC"
+    | STOREW ->         fStr "STOREW"
+    | ARG n ->          fMeta "ARG $" [fNum n]
+    | SLINK ->          fStr "STATLINK"
+    | PCALL n ->        fMeta "PCALL $" [fNum n]
+    | RESULTW ->        fStr "RESULTW"
+    | MONOP w ->        fStr (op_name w)
+    | BINOP w ->        fStr (op_name w)
+    | OFFSET ->         fStr "OFFSET"
+    | BOUND ->          fStr "BOUND"
+    | NCHECK ->         fStr "NCHECK"
+    | LABEL l ->        fMeta "LABEL $" [fLab l]
+    | JUMP l ->         fMeta "JUMP $" [fLab l]
+    | JUMPC (w, l) ->   fMeta "J$ $" [fStr (op_name w); fLab l]
+    | JCASE (labs, def) -> fMeta "JCASE $ $" [fNum (List.length labs); fLab def]
+    | LINE n ->         fMeta "LINE $" [fNum n]
+    | NOP ->            fStr "NOP"
+    | SEQ ->            fStr "SEQ"
+    | AFTER ->          fStr "AFTER"
+    | DEFTMP n ->       fMeta "DEFTMP $" [fNum n]
+    | TEMP n ->         fMeta "TEMP $" [fNum n]
+
+let int_of_bool b = if b then 1 else 0
+
+(* |do_monop| -- evaluate unary operators *)
+let do_monop w x =
+  match w with
+      Uminus -> - x
+    | Not -> if x <> 0 then 0 else 1
+    | BitNot -> lnot x
+    | _ -> failwith "do_monop"
+
+(* |do_binop| -- evaluate binary operators *)
+let do_binop w x y =
+  match w with
+      Plus -> x + y
+    | Minus -> x - y
+    | Times -> x * y
+    | Div -> x / y
+    | Mod -> x mod y
+    | Eq -> int_of_bool (x = y)
+    | Lt -> int_of_bool (x < y)
+    | Gt -> int_of_bool (x > y)
+    | Leq -> int_of_bool (x <= y)
+    | Geq -> int_of_bool (x >= y)
+    | Neq -> int_of_bool (x <> y)
+    | And -> if x <> 0 then y else 0
+    | Or -> if x <> 0 then 1 else y
+    | BitAnd -> x land y
+    | BitOr -> x lor y
+    | Lsl -> x lsl y
+    | Lsr -> x lsr y
+    | Asr -> x asr y
+    | _ -> failwith "do_binop"
+
+(* |negate| -- negation of a comparison *)
+let negate = 
+  function Eq -> Neq | Neq -> Eq | Lt  -> Geq
+    | Leq -> Gt | Gt  -> Leq | Geq -> Lt
+    | _ -> failwith "negate"
+
+
+(* Operator trees *)
+
+type optree = Node of inst * optree list
+
+let rec canon_app t us =
+  match t with
+      <SEQ, @ts> -> List.fold_right canon_app ts us
+    | <NOP> -> us
+    | <LINE n> -> if n = 0 then us else <LINE n> :: set_line n us
+    | _ -> effects t (result t :: us)
+
+and set_line n ts =
+  match ts with 
+      [] -> []
+    | <LINE m> :: us -> if n <> m then ts else us
+    | u :: us -> u :: set_line n us
+
+and effects t us =
+  match t with
+      <AFTER, t1, t2> -> canon_app t1 (effects t2 us)
+    | <w, @ts> -> List.fold_right effects ts us
+
+and result =
+  function
+      <AFTER, t1, t2> -> result t2
+    | <w, @ts> -> <w, @(List.map result ts)>
+
+let canon t = canon_app t []
+
+let flat =
+  function
+      <PCALL n, @(fn::args)> -> 
+        List.rev args @ [<PCALL n, fn>]
+    | <DEFTMP k, <PCALL n, @(fn::args)>> ->
+        List.rev args @ [<DEFTMP k, <PCALL n, fn>>]
+    | t -> [t]
+
+let flatten ts = List.concat (List.map flat ts)
+
+let fSeq(f) xs = 
+  let g prf = List.iter (fun x -> prf "$" [f x]) xs in fExt g
+
+let rec fTree <x, @ts> = 
+  let op = sprintf "$" [fInst x] in
+  fMeta "<$$>" [fStr op; fSeq(fun t -> fMeta ", $" [fTree t]) ts]
+
+let print_optree pfx t =
+  match t with
+      <LINE n> ->
+        Print.printf "$$\n" [fStr pfx; fStr (Source.get_line n)]
+    | _ ->
+        fgrindf stdout pfx "$" [fTree t];