annotate ppc/keiko.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 (* ppc/keiko.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
mike@0 29 | Lsl | Lsr | Asr | BitAnd | BitOr | BitNot
mike@0 30
mike@0 31 (* |code| -- type of intermediate instructions *)
mike@0 32 type code =
mike@0 33 CONST of int (* Constant (value) *)
mike@0 34 | GLOBAL of symbol (* Constant (symbol) *)
mike@0 35 | LOCAL of int (* Local address (offset) *)
mike@0 36 | LOAD of int (* Load (size) *)
mike@0 37 | STORE of int (* Store (size) *)
mike@0 38 | FIXCOPY (* Copy multiple values (size) *)
mike@0 39 | PCALL of int * int (* Call procedure (nparams, rsize) *)
mike@0 40 | RETURN of int (* Procedure return (rsize) *)
mike@0 41 | MONOP of op (* Perform unary operation (op) *)
mike@0 42 | BINOP of op (* Perform binary operation (op) *)
mike@0 43 | OFFSET (* Add address and offset *)
mike@0 44 | BOUND of int (* Array bound check (line) *)
mike@0 45 | NCHECK of int (* Null pointer check (line) *)
mike@0 46 | ERETURN of int (* Failure to return (line) *)
mike@0 47 | LABEL of codelab (* Set code label *)
mike@0 48 | JUMP of codelab (* Unconditional branch (dest) *)
mike@0 49 | JUMPC of op * codelab (* Conditional branch (cond, dest) *)
mike@0 50 | JCASE of codelab list (* Jump table *)
mike@0 51 | LINE of int (* Line number *)
mike@0 52
mike@0 53 | LDL of int * int (* LDL (n, s) = LOCAL n / LOAD s *)
mike@0 54 | STL of int * int (* STL (n, s) = LOCAL n / STORE s *)
mike@0 55 | LDG of symbol * int (* LDG (x, s) = GLOBAL x / LOAD s *)
mike@0 56 | STG of symbol * int (* STG (x, s) = GLOBAL x / STORE s *)
mike@0 57 | LDNW of int (* LDNW n = CONST n / OFFSET / LOAD 4 *)
mike@0 58 | STNW of int (* STNW n = CONST n / OFFSET / STORE 4 *)
mike@0 59 | LDI of int (* LDI s = CONST s / TIMES / OFFSET / LOAD s *)
mike@0 60 | STI of int (* STI s = CONST s / TIMES / OFFSET / STORE s *)
mike@0 61 | JUMPCZ of op * codelab (* Conditional branch with zero (cond, dest) *)
mike@0 62
mike@0 63 | SEQ of code list (* Sequence of other instructions *)
mike@0 64 | NOP (* Null operation *)
mike@0 65
mike@0 66 let mark_line n ys =
mike@0 67 if n = 0 then ys else
mike@0 68 match ys with
mike@0 69 [] | LINE _ :: _ -> ys
mike@0 70 | _ -> LINE n :: ys
mike@0 71
mike@0 72 let canon x =
mike@0 73 let rec accum x ys =
mike@0 74 match x with
mike@0 75 SEQ xs -> List.fold_right accum xs ys
mike@0 76 | NOP -> ys
mike@0 77 | LINE n -> mark_line n ys
mike@0 78 | _ -> x :: ys in
mike@0 79 SEQ (accum x [])
mike@0 80
mike@0 81 let op_name =
mike@0 82 function
mike@0 83 Plus -> "PLUS" | Minus -> "MINUS" | Times -> "TIMES"
mike@0 84 | Div -> "DIV" | Mod -> "MOD" | Eq -> "EQ"
mike@0 85 | Uminus -> "UMINUS" | Lt -> "LT" | Gt -> "GT"
mike@0 86 | Leq -> "LEQ" | Geq -> "GEQ" | Neq -> "NEQ"
mike@0 87 | And -> "AND" | Or -> "OR" | Not -> "NOT"
mike@0 88 | Lsl -> "LSL" | Lsr -> "LSR" | Asr -> "ASR"
mike@0 89 | BitAnd -> "BITAND" | BitOr -> "BITOR" | BitNot -> "BITNOT"
mike@0 90
mike@0 91 let fOp w = fStr (op_name w)
mike@0 92
mike@0 93 let fType =
mike@0 94 function 1 -> fStr "C" | 4 -> fStr "W" | s -> fMeta "*$*" [fNum s]
mike@0 95
mike@0 96 let fType1 =
mike@0 97 function 0 -> fStr "" | 1 -> fStr "W" | s -> fMeta "*$*" [fNum s]
mike@0 98
mike@0 99 let fInst =
mike@0 100 function
mike@0 101 CONST x -> fMeta "CONST $" [fNum x]
mike@0 102 | GLOBAL a -> fMeta "GLOBAL $" [fStr a]
mike@0 103 | LOCAL n -> fMeta "LOCAL $" [fNum n]
mike@0 104 | LOAD s -> fMeta "LOAD$" [fType s]
mike@0 105 | STORE s -> fMeta "STORE$" [fType s]
mike@0 106 | FIXCOPY -> fStr "FIXCOPY"
mike@0 107 | PCALL (n, s) -> fMeta "PCALL$ $" [fType1 s; fNum n]
mike@0 108 | RETURN s -> fMeta "RETURN$" [fType1 s]
mike@0 109 | MONOP w -> fStr (op_name w)
mike@0 110 | BINOP w -> fStr (op_name w)
mike@0 111 | OFFSET -> fStr "OFFSET"
mike@0 112 | BOUND n -> fMeta "BOUND $" [fNum n]
mike@0 113 | NCHECK n -> fMeta "NCHECK $" [fNum n]
mike@0 114 | ERETURN n -> fMeta "ERROR E_RETURN $" [fNum n]
mike@0 115 | LABEL l -> fMeta "LABEL $" [fLab l]
mike@0 116 | JUMP l -> fMeta "JUMP $" [fLab l]
mike@0 117 | JUMPC (w, l) -> fMeta "J$ $" [fStr (op_name w); fLab l]
mike@0 118 | JCASE labs -> fMeta "JCASE $" [fNum (List.length labs)]
mike@0 119 | LINE n -> fMeta "LINE $" [fNum n]
mike@0 120
mike@0 121 | LDL (n, s) -> fMeta "LDL$ $" [fType s; fNum n]
mike@0 122 | STL (n, s) -> fMeta "STL$ $" [fType s; fNum n]
mike@0 123 | LDG (x, s) -> fMeta "LDG$ $" [fType s; fStr x]
mike@0 124 | STG (x, s) -> fMeta "STG$ $" [fType s; fStr x]
mike@0 125 | LDNW n -> fMeta "LDNW $" [fNum n]
mike@0 126 | STNW n -> fMeta "STNW $" [fNum n]
mike@0 127 | LDI s -> fMeta "LDI$" [fType s]
mike@0 128 | STI s -> fMeta "STI$" [fType s]
mike@0 129 | JUMPCZ (w, lab) -> fMeta "J$Z $" [fStr (op_name w); fLab lab]
mike@0 130
mike@0 131 | SEQ _ -> fStr "SEQ ..."
mike@0 132 | NOP -> fStr "NOP"
mike@0 133
mike@0 134 (* |output| -- output code sequence *)
mike@0 135 let output code =
mike@0 136 let line = ref 0 in
mike@0 137 let rec out =
mike@0 138 function
mike@0 139 SEQ xs -> List.iter out xs
mike@0 140 | NOP -> ()
mike@0 141 | LINE n ->
mike@0 142 if !line <> n then begin
mike@0 143 printf "! $\n" [fStr (Source.get_line n)];
mike@0 144 line := n
mike@0 145 end
mike@0 146 | JCASE labs ->
mike@0 147 printf "$\n" [fInst (JCASE labs)];
mike@0 148 List.iter (fun lab -> printf "CASEL $\n" [fLab lab]) labs
mike@0 149 | x -> printf "$\n" [fInst x] in
mike@0 150 out code
mike@0 151
mike@0 152
mike@0 153 let int_of_bool b = if b then 1 else 0
mike@0 154
mike@0 155 (* |do_monop| -- evaluate unary operators *)
mike@0 156 let do_monop w x =
mike@0 157 match w with
mike@0 158 Uminus -> - x
mike@0 159 | Not -> if x <> 0 then 0 else 1
mike@0 160 | BitNot -> lnot x
mike@0 161 | _ -> failwith "do_monop"
mike@0 162
mike@0 163 (* |do_binop| -- evaluate binary operators *)
mike@0 164 let do_binop w x y =
mike@0 165 match w with
mike@0 166 Plus -> x + y
mike@0 167 | Minus -> x - y
mike@0 168 | Times -> x * y
mike@0 169 | Div -> x / y
mike@0 170 | Mod -> x mod y
mike@0 171 | Eq -> int_of_bool (x = y)
mike@0 172 | Lt -> int_of_bool (x < y)
mike@0 173 | Gt -> int_of_bool (x > y)
mike@0 174 | Leq -> int_of_bool (x <= y)
mike@0 175 | Geq -> int_of_bool (x >= y)
mike@0 176 | Neq -> int_of_bool (x <> y)
mike@0 177 | And -> if x <> 0 then y else 0
mike@0 178 | Or -> if x <> 0 then 1 else y
mike@0 179 | Lsl -> x lsl y
mike@0 180 | Lsr -> x lsr y
mike@0 181 | Asr -> x asr y
mike@0 182 | BitAnd -> x land y
mike@0 183 | BitOr -> x lor y
mike@0 184 | _ -> failwith (sprintf "do_binop $" [fOp w])
mike@0 185
mike@0 186 (* |negate| -- negation of a comparison *)
mike@0 187 let negate =
mike@0 188 function Eq -> Neq | Neq -> Eq | Lt -> Geq
mike@0 189 | Leq -> Gt | Gt -> Leq | Geq -> Lt
mike@0 190 | _ -> failwith "negate"