annotate lab4/optree.ml @ 1:b5139af1a420 tip basis

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