comparison lab1/keiko.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* common/keiko.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Tree
5 open Print
6
7 (* |codelab| -- type of code labels *)
8 type codelab = int
9
10 (* |lastlab| -- last used code label *)
11 let lastlab = ref 0
12
13 (* |label| -- allocate a code label *)
14 let label () = incr lastlab; !lastlab
15
16 (* |fLab| -- format a code label for printf *)
17 let fLab n = fMeta "L$" [fNum n]
18
19 (* |op| -- type of picoPascal operators *)
20 type op = Plus | Minus | Times | Div | Mod | Eq
21 | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
22
23 (* |code| -- type of intermediate instructions *)
24 type code =
25 CONST of int (* Push constant (value) *)
26 | GLOBAL of string (* Push global address (name) *)
27 | LOCAL of int (* Push local adddress (offset) *)
28 | LOADW (* Load word *)
29 | STOREW (* Store word *)
30 | LOADC (* Load character *)
31 | STOREC (* Store character *)
32 | MONOP of op (* Perform unary operation (op) *)
33 | BINOP of op (* Perform binary operation (op) *)
34 | OFFSET (* Add address and offset *)
35 | LABEL of codelab (* Set code label *)
36 | JUMP of codelab (* Unconditional branch (dest) *)
37 | JUMPC of op * codelab (* Conditional branch (op, dest) *)
38 | PCALL of int (* Call procedure *)
39 | PCALLW of int (* Proc call with result (nargs) *)
40 | RETURNW (* Return from procedure *)
41 | BOUND of int (* Bounds check *)
42 | CASEJUMP of int (* Case jump (num cases) *)
43 | CASEARM of int * codelab (* Case value and label *)
44 | PACK (* Pack two values into one *)
45 | UNPACK (* Unpack one value into two *)
46 | DUP
47 | POP
48
49 | LDGW of string (* Load Global Word (name) *)
50 | STGW of string (* Store Global Word (name) *)
51 | LDLW of int (* Load Local Word (offset) *)
52 | STLW of int (* Store Local Word (offset) *)
53 | LDNW of int (* Load word with offset *)
54 | STNW of int (* Store word with offset *)
55
56 | LINE of int
57 | SEQ of code list
58 | NOP
59
60 (* op_name -- map an operator to its name *)
61 let op_name =
62 function
63 Plus -> "Plus" | Minus -> "Minus" | Times -> "Times"
64 | Div -> "Div" | Mod -> "Mod" | Eq -> "Eq"
65 | Uminus -> "Uminus" | Lt -> "Lt" | Gt -> "Gt"
66 | Leq -> "Leq" | Geq -> "Geq" | Neq -> "Neq"
67 | And -> "And" | Or -> "Or" | Not -> "Not"
68
69 (* fOp -- format an operator as an instruction *)
70 let fOp w =
71 (* Avoid the deprecated String.uppercase *)
72 let upc ch =
73 if ch >= 'a' && ch <= 'z' then Char.chr (Char.code ch - 32) else ch in
74 fStr (String.map upc (op_name w))
75
76 (* |fInst| -- format an instruction for |printf| *)
77 let fInst =
78 function
79 CONST x -> fMeta "CONST $" [fNum x]
80 | GLOBAL a -> fMeta "GLOBAL $" [fStr a]
81 | LOCAL n -> fMeta "LOCAL $" [fNum n]
82 | LOADW -> fStr "LOADW"
83 | STOREW -> fStr "STOREW"
84 | LOADC -> fStr "LOADC"
85 | STOREC -> fStr "STOREC"
86 | MONOP w -> fOp w
87 | BINOP w -> fOp w
88 | OFFSET -> fStr "OFFSET"
89 | LABEL l -> fMeta "LABEL $" [fLab l]
90 | JUMP l -> fMeta "JUMP $" [fLab l]
91 | JUMPC (w, l) -> fMeta "J$ $" [fOp w; fLab l]
92 | PCALL n -> fMeta "PCALL $" [fNum n]
93 | PCALLW n -> fMeta "PCALLW $" [fNum n]
94 | RETURNW -> fStr "RETURNW"
95 | BOUND n -> fMeta "BOUND $" [fNum n]
96 | CASEJUMP n -> fMeta "CASEJUMP $" [fNum n]
97 | CASEARM (v, l) -> fMeta "CASEARM $ $" [fNum v; fLab l]
98 | PACK -> fStr "PACK"
99 | UNPACK -> fStr "UNPACK"
100 | DUP -> fStr "DUP 0"
101 | POP -> fStr "POP 1"
102 | LDGW a -> fMeta "LDGW $" [fStr a]
103 | STGW a -> fMeta "STGW $" [fStr a]
104 | LDLW n -> fMeta "LDLW $" [fNum n]
105 | STLW n -> fMeta "STLW $" [fNum n]
106 | LDNW n -> fMeta "LDNW $" [fNum n]
107 | STNW n -> fMeta "STNW $" [fNum n]
108 | LINE n -> fMeta "LINE $" [fNum n]
109 | SEQ _ -> fStr "SEQ ..."
110 | NOP -> fStr "NOP"
111
112 let mark_line n ys =
113 if n = 0 then ys else
114 match ys with
115 [] | LINE _ :: _ -> ys
116 | _ -> LINE n :: ys
117
118 (* |canon| -- flatten a code sequence *)
119 let canon x =
120 let rec accum x ys =
121 match x with
122 SEQ xs -> List.fold_right accum xs ys
123 | NOP -> ys
124 | LINE n ->
125 if n = 0 then
126 ys
127 else begin
128 match ys with
129 [] -> ys
130 | LINE _ :: _ -> ys
131 | _ -> LINE n :: ys
132 end
133 | _ -> x :: ys in
134 SEQ (accum x [])
135
136
137 (* SANITY CHECKS *)
138
139 (* The checks implemented here ensure that the value stack is used in a
140 consistent way, and that CASEJUMP instructions are followed by the
141 correct number of case labels. There are a few assumptions, the main
142 one being that backwards jumps leave nothing on the stack. *)
143
144 (* Compute pair (a, b) if an instruction pops a values and pushes b *)
145 let delta =
146 function
147 CONST _ | GLOBAL _ | LOCAL _ | LDGW _ | LDLW _ -> (0, 1)
148 | STGW _ | STLW _ -> (1, 0)
149 | LOADW | LOADC | LDNW _ -> (1, 1)
150 | STOREW | STOREC | STNW _ -> (2, 0)
151 | MONOP _ -> (1, 1)
152 | BINOP _ | OFFSET -> (2, 1)
153 | PCALL n -> (n+2, 0)
154 | PCALLW n -> (n+2, 1)
155 | RETURNW -> (1, 0)
156 | BOUND _ -> (2, 1)
157 | PACK -> (2, 1)
158 | UNPACK -> (1, 2)
159 | LINE _ -> (0, 0)
160 | DUP -> (1, 2)
161 | POP -> (1, 0)
162 | i -> failwith (sprintf "delta $" [fInst i])
163
164 (* Output code and check for basic sanity *)
165 let check_and_output code =
166 let line = ref 0 in
167
168 (* Output an instruction *)
169 let out =
170 function
171 LINE n ->
172 if n <> 0 && !line <> n then begin
173 printf "! $\n" [fStr (Source.get_line n)];
174 line := n
175 end
176 | x -> printf "$\n" [fInst x] in
177
178 (* Report failure of sanity checks *)
179 let insane fmt args =
180 fprintf stderr "WARNING: Code failed sanity checks -- $\n" [fMeta fmt args];
181 printf "! *** HERE!\n" [];
182 raise Exit in
183
184 (* Map labels to (depth, flag) pairs *)
185 let labdict = Hashtbl.create 50 in
186
187 (* Note the depth at a label and check for consistency *)
188 let note_label lab def d =
189 try
190 let (d1, f) = Hashtbl.find labdict lab in
191 if d >= 0 && d <> d1 then
192 insane "inconsistent stack depth ($ <> $) at label $"
193 [fNum d; fNum d1; fNum lab];
194 if def then begin
195 if !f then insane "multiply defined label $" [fNum lab];
196 f := true
197 end;
198 d1
199 with Not_found ->
200 (* If this point is after an unconditional jump (d < 0) and
201 the label is not defined previously, assume depth 0 *)
202 let d1 = max d 0 in
203 Hashtbl.add labdict lab (d1, ref def);
204 d1 in
205
206 (* Check all mentioned labels have been defined *)
207 let check_labs () =
208 Hashtbl.iter (fun lab (d, f) ->
209 if not !f then insane "label $ is not defined" [fNum lab]) labdict in
210
211 let tail = ref [] in
212
213 let output () = out (List.hd !tail); tail := List.tl !tail in
214
215 (* Scan an instruction sequence, keeping track of the stack depth *)
216 let rec scan d =
217 match !tail with
218 [] ->
219 if d <> 0 then insane "stack not empty at end" []
220 | x :: _ ->
221 let need a =
222 if d < a then
223 insane "stack underflow at instruction $" [fInst x] in
224 output ();
225 begin match x with
226 LABEL lab ->
227 scan (note_label lab true d)
228 | JUMP lab ->
229 unreachable (note_label lab false d)
230 | JUMPC (_, lab) ->
231 need 2; scan (note_label lab false (d-2))
232 | CASEARM (_, _) ->
233 insane "unexpected CASEARM" []
234 | CASEJUMP n ->
235 need 1; jumptab n (d-1)
236 | SEQ _ | NOP ->
237 failwith "sanity2"
238 | _ ->
239 let (a, b) = delta x in need a; scan (d-a+b)
240 end
241
242 (* Scan a jump table, checking for the correct number of entries *)
243 and jumptab n d =
244 match !tail with
245 CASEARM (_, lab) :: _ ->
246 output ();
247 if n = 0 then
248 insane "too many CASEARMs after CASEJUMP" [];
249 jumptab (n-1) (note_label lab false d)
250 | _ ->
251 if n > 0 then
252 insane "too few CASEARMs after CASEJUMP" [];
253 scan d
254
255 (* Scan code after an unconditional jump *)
256 and unreachable d =
257 match !tail with
258 [] -> ()
259 | LABEL lab :: _ ->
260 output ();
261 scan (note_label lab true (-1))
262 | _ ->
263 (* Genuinely unreachable code -- assume stack is empty *)
264 scan 0 in
265
266 match canon code with
267 SEQ xs ->
268 tail := xs;
269 (try scan 0; check_labs () with Exit ->
270 (* After error, output rest of code without checks *)
271 List.iter out !tail; exit 1)
272 | _ -> failwith "sanity"
273
274 let output code =
275 try check_and_output code with Exit -> exit 1
276