annotate 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
rev   line source
mike@0 1 (* lab4/optree.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 open Print
mike@0 5
mike@0 6 (* |symbol| -- global symbols *)
mike@0 7 type symbol = string
mike@0 8
mike@0 9 type codelab = int
mike@0 10
mike@0 11 let nolab = -1
mike@0 12
mike@0 13 (* |lab| -- last used code label *)
mike@0 14 let lab = ref 0
mike@0 15
mike@0 16 (* |label| -- allocate a code label *)
mike@0 17 let label () = incr lab; !lab
mike@0 18
mike@0 19 (* |fLab| -- format a code label for printf *)
mike@0 20 let fLab n = fMeta "L$" [fNum n]
mike@0 21
mike@0 22 let nosym = "*nosym*"
mike@0 23
mike@0 24 let gensym () = sprintf "g$" [fNum (label ())]
mike@0 25
mike@0 26 (* |op| -- type of picoPascal operators *)
mike@0 27 type op = Plus | Minus | Times | Div | Mod | Eq
mike@0 28 | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not | Lsl
mike@0 29 | Lsr | Asr | BitAnd | BitOr | BitNot
mike@0 30
mike@0 31 (* |inst| -- type of intermediate instructions *)
mike@0 32 type inst =
mike@0 33 CONST of int (* Constant (value) *)
mike@0 34 | GLOBAL of symbol (* Constant (symbol, offset) *)
mike@0 35 | LOCAL of int (* Local address (offset) *)
mike@0 36 | REGVAR of int (* Register (index) *)
mike@0 37 | LOADC (* Load char *)
mike@0 38 | LOADW (* Load word *)
mike@0 39 | STOREC (* Store char *)
mike@0 40 | STOREW (* Store word *)
mike@0 41 | ARG of int (* Pass argument (index) *)
mike@0 42 | SLINK (* Pass static link *)
mike@0 43 | PCALL of int (* Call procedure (nparams) *)
mike@0 44 | RESULTW (* Procedure result *)
mike@0 45 | MONOP of op (* Perform unary operation (op) *)
mike@0 46 | BINOP of op (* Perform binary operation (op) *)
mike@0 47 | OFFSET (* Add address and offset *)
mike@0 48 | BOUND (* Array bound check *)
mike@0 49 | NCHECK (* Null pointer check *)
mike@0 50 | LABEL of codelab (* Set code label *)
mike@0 51 | JUMP of codelab (* Unconditional branch (dest) *)
mike@0 52 | JUMPC of op * codelab (* Conditional branch (cond, dest) *)
mike@0 53 | JCASE of codelab list * codelab (* Jump table *)
mike@0 54
mike@0 55 (* Extra instructions *)
mike@0 56 | LINE of int (* Line number *)
mike@0 57 | NOP
mike@0 58 | SEQ
mike@0 59 | AFTER (* Expression with side effect *)
mike@0 60 | DEFTMP of int
mike@0 61 | TEMP of int (* Temporary *)
mike@0 62
mike@0 63 let op_name =
mike@0 64 function
mike@0 65 Plus -> "PLUS" | Minus -> "MINUS" | Times -> "TIMES"
mike@0 66 | Div -> "DIV" | Mod -> "MOD" | Eq -> "EQ"
mike@0 67 | Uminus -> "UMINUS" | Lt -> "LT" | Gt -> "GT"
mike@0 68 | Leq -> "LEQ" | Geq -> "GEQ" | Neq -> "NEQ"
mike@0 69 | And -> "AND" | Or -> "OR" | Not -> "NOT"
mike@0 70 | Lsl -> "LSL" | Lsr -> "LSR" | Asr -> "ASR"
mike@0 71 | BitAnd -> "BITAND" | BitOr -> "BITOR" | BitNot -> "BITNOT"
mike@0 72
mike@0 73 let fOp w = fStr (op_name w)
mike@0 74
mike@0 75 let fType1 =
mike@0 76 function 0 -> fStr "" | 1 -> fStr "W" | s -> fMeta "*$*" [fNum s]
mike@0 77
mike@0 78 let fInst =
mike@0 79 function
mike@0 80 CONST x -> fMeta "CONST $" [fNum x]
mike@0 81 | GLOBAL a -> fMeta "GLOBAL $" [fStr a]
mike@0 82 | LOCAL n -> fMeta "LOCAL $" [fNum n]
mike@0 83 | REGVAR i -> fMeta "REGVAR $" [fNum i]
mike@0 84 | LOADC -> fStr "LOADC"
mike@0 85 | LOADW -> fStr "LOADW"
mike@0 86 | STOREC -> fStr "STOREC"
mike@0 87 | STOREW -> fStr "STOREW"
mike@0 88 | ARG n -> fMeta "ARG $" [fNum n]
mike@0 89 | SLINK -> fStr "STATLINK"
mike@0 90 | PCALL n -> fMeta "PCALL $" [fNum n]
mike@0 91 | RESULTW -> fStr "RESULTW"
mike@0 92 | MONOP w -> fStr (op_name w)
mike@0 93 | BINOP w -> fStr (op_name w)
mike@0 94 | OFFSET -> fStr "OFFSET"
mike@0 95 | BOUND -> fStr "BOUND"
mike@0 96 | NCHECK -> fStr "NCHECK"
mike@0 97 | LABEL l -> fMeta "LABEL $" [fLab l]
mike@0 98 | JUMP l -> fMeta "JUMP $" [fLab l]
mike@0 99 | JUMPC (w, l) -> fMeta "J$ $" [fStr (op_name w); fLab l]
mike@0 100 | JCASE (labs, def) -> fMeta "JCASE $ $" [fNum (List.length labs); fLab def]
mike@0 101 | LINE n -> fMeta "LINE $" [fNum n]
mike@0 102 | NOP -> fStr "NOP"
mike@0 103 | SEQ -> fStr "SEQ"
mike@0 104 | AFTER -> fStr "AFTER"
mike@0 105 | DEFTMP n -> fMeta "DEFTMP $" [fNum n]
mike@0 106 | TEMP n -> fMeta "TEMP $" [fNum n]
mike@0 107
mike@0 108 let int_of_bool b = if b then 1 else 0
mike@0 109
mike@0 110 (* |do_monop| -- evaluate unary operators *)
mike@0 111 let do_monop w x =
mike@0 112 match w with
mike@0 113 Uminus -> - x
mike@0 114 | Not -> if x <> 0 then 0 else 1
mike@0 115 | BitNot -> lnot x
mike@0 116 | _ -> failwith "do_monop"
mike@0 117
mike@0 118 (* |do_binop| -- evaluate binary operators *)
mike@0 119 let do_binop w x y =
mike@0 120 match w with
mike@0 121 Plus -> x + y
mike@0 122 | Minus -> x - y
mike@0 123 | Times -> x * y
mike@0 124 | Div -> x / y
mike@0 125 | Mod -> x mod y
mike@0 126 | Eq -> int_of_bool (x = y)
mike@0 127 | Lt -> int_of_bool (x < y)
mike@0 128 | Gt -> int_of_bool (x > y)
mike@0 129 | Leq -> int_of_bool (x <= y)
mike@0 130 | Geq -> int_of_bool (x >= y)
mike@0 131 | Neq -> int_of_bool (x <> y)
mike@0 132 | And -> if x <> 0 then y else 0
mike@0 133 | Or -> if x <> 0 then 1 else y
mike@0 134 | BitAnd -> x land y
mike@0 135 | BitOr -> x lor y
mike@0 136 | Lsl -> x lsl y
mike@0 137 | Lsr -> x lsr y
mike@0 138 | Asr -> x asr y
mike@0 139 | _ -> failwith "do_binop"
mike@0 140
mike@0 141 (* |negate| -- negation of a comparison *)
mike@0 142 let negate =
mike@0 143 function Eq -> Neq | Neq -> Eq | Lt -> Geq
mike@0 144 | Leq -> Gt | Gt -> Leq | Geq -> Lt
mike@0 145 | _ -> failwith "negate"
mike@0 146
mike@0 147
mike@0 148 (* Operator trees *)
mike@0 149
mike@0 150 type optree = Node of inst * optree list
mike@0 151
mike@0 152 let rec canon_app t us =
mike@0 153 match t with
mike@0 154 <SEQ, @ts> -> List.fold_right canon_app ts us
mike@0 155 | <NOP> -> us
mike@0 156 | <LINE n> -> if n = 0 then us else <LINE n> :: set_line n us
mike@0 157 | _ -> effects t (result t :: us)
mike@0 158
mike@0 159 and set_line n ts =
mike@0 160 match ts with
mike@0 161 [] -> []
mike@0 162 | <LINE m> :: us -> if n <> m then ts else us
mike@0 163 | u :: us -> u :: set_line n us
mike@0 164
mike@0 165 and effects t us =
mike@0 166 match t with
mike@0 167 <AFTER, t1, t2> -> canon_app t1 (effects t2 us)
mike@0 168 | <w, @ts> -> List.fold_right effects ts us
mike@0 169
mike@0 170 and result =
mike@0 171 function
mike@0 172 <AFTER, t1, t2> -> result t2
mike@0 173 | <w, @ts> -> <w, @(List.map result ts)>
mike@0 174
mike@0 175 let canon t = canon_app t []
mike@0 176
mike@0 177 let flat =
mike@0 178 function
mike@0 179 <PCALL n, @(fn::args)> ->
mike@0 180 List.rev args @ [<PCALL n, fn>]
mike@0 181 | <DEFTMP k, <PCALL n, @(fn::args)>> ->
mike@0 182 List.rev args @ [<DEFTMP k, <PCALL n, fn>>]
mike@0 183 | t -> [t]
mike@0 184
mike@0 185 let flatten ts = List.concat (List.map flat ts)
mike@0 186
mike@0 187 let fSeq(f) xs =
mike@0 188 let g prf = List.iter (fun x -> prf "$" [f x]) xs in fExt g
mike@0 189
mike@0 190 let rec fTree <x, @ts> =
mike@0 191 let op = sprintf "$" [fInst x] in
mike@0 192 fMeta "<$$>" [fStr op; fSeq(fun t -> fMeta ", $" [fTree t]) ts]
mike@0 193
mike@0 194 let print_optree pfx t =
mike@0 195 match t with
mike@0 196 <LINE n> ->
mike@0 197 Print.printf "$$\n" [fStr pfx; fStr (Source.get_line n)]
mike@0 198 | _ ->
mike@0 199 fgrindf stdout pfx "$" [fTree t];