Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/MDL/mdl-gen-mc.sml
ViewVC logotype

Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/MDL/mdl-gen-mc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1232 - (view) (download)

1 : leunga 744 (*
2 :     * This module generates the machine code emitter of an architecture
3 :     * given a machine description.
4 :     *
5 :     *)
6 :     functor MDLGenMC(Comp : MDL_COMPILE) : MDL_GEN_MODULE =
7 :     struct
8 :     structure Comp = Comp
9 :     structure Ast = Comp.Ast
10 :     structure Env = Comp.Env
11 :     structure T = Comp.Trans
12 :     structure W = Word32
13 :    
14 :     open Ast Comp.Util Comp.Error
15 :    
16 :     infix << || &&
17 :    
18 :     val op << = W.<<
19 :     val op || = W.orb
20 :     val op && = W.andb
21 :     val notb = W.notb
22 :    
23 :     val itow = W.fromInt
24 :     val itos = Int.toString
25 :    
26 :     fun gen md =
27 :     let (* name of the functor and signature *)
28 :     val strName = Comp.strname md "MCEmitter"
29 :     val sigName = "INSTRUCTION_EMITTER"
30 :    
31 :     (* Is debugging turned on? *)
32 :     val debugOn = Comp.debugging md "MC"
33 :    
34 :     (* Arguments for the functor *)
35 :     val args = ["structure Instr : "^Comp.signame md "INSTR",
36 : blume 1002 "structure MLTreeEval : MLTREE_EVAL where T = Instr.T",
37 :     "structure Stream : INSTRUCTION_STREAM ",
38 : leunga 744 "structure CodeString : CODE_STRING"
39 :     ] @
40 :     (if debugOn then
41 :     ["structure Assembler : INSTRUCTION_EMITTER",
42 : blume 1002 " where I = Instr and S = MLTreeStream.S.Stream"
43 : leunga 744 ]
44 :     else [])
45 :    
46 :     (* Instruction formats that are declared in the description *)
47 :     val formats = Comp.formats md
48 :    
49 :     (* Instruction widths that are defined in this architecture *)
50 :     val widths = ListMergeSort.uniqueSort Int.compare
51 :     (foldr (fn ((SOME w,_),l) => w::l | (_,l) => l) []
52 :     formats)
53 :    
54 :     (* The Instruction structure *)
55 :     val env = Env.lookupStr (Comp.env md) (IDENT([],"Instruction"))
56 :    
57 :     (* Make sure that all widths are either 8, 16, 24, or 32 bits *)
58 :     val _ = app
59 :     (fn w =>
60 :     if w < 8 orelse w > 32 orelse w mod 8 <> 0 then
61 :     error("instruction format must be 8, 16, 24, or 32 bits; found"^itos w)
62 :     else ()) widths
63 :    
64 :     (* Endianess *)
65 :     val endianess = Comp.endianess md
66 :    
67 :     (* Name of an emit function *)
68 :     fun emit id = "emit_"^id
69 :    
70 :     (*
71 :     * For each width N, generate a function eWordN for emitting a word
72 :     * of that width.
73 :     *)
74 :     val emitFuns =
75 :     let val DUMMYbind = FUNbind("dummy",[])
76 :     fun mkEmitWord width =
77 :     let fun f 0 = []
78 :     | f 8 = [VAL("b8",ID "w")]
79 :     | f b = VAL("b"^itos b,ID "w")::
80 :     VAL("w",SLR(ID "w",WORD32exp 0w8))::f(b - 8)
81 :     fun g 0 = []
82 :     | g b = APP("eByteW",ID("b"^itos b))::g(b - 8)
83 :     val debug =
84 :     if debugOn then
85 :     [VAL("_", ID "print(\"0x\"^Word32.toString w^\"\\t\")")]
86 :     else []
87 :     val body = case endianess of
88 :     BIG => g width
89 :     | LITTLE => rev(g width)
90 :     in FUNbind("eWord"^itos width,
91 :     [CLAUSE([IDpat "w"],
92 :     NONE,
93 :     LET(debug@rev(f width),SEQexp body))])
94 :     end
95 :     in FUNdecl(map mkEmitWord widths) end
96 :    
97 :     (* Functions for emitting the encoding for a cell *)
98 :     val cellFuns =
99 :     let fun mkEmitCell(CELLdecl{id, from, ...}) =
100 :     FUN'(emit id, IDpat "r",
101 : blume 1002 APP("itow", APP("CellsBasis.physicalRegisterNum", ID "r")))
102 : leunga 744 in FUNdecl(map mkEmitCell (Comp.cells md)) end
103 :    
104 :     (*
105 :     * For each datatype T defined in the structure Instruction that
106 :     * has code generation annotations defined, generate a function emit_T.
107 :     *)
108 :     val datatypeFuns =
109 :     let fun WORD w = TYPEDexp(WORD32exp w,WORD32ty)
110 :     fun mkEmitDatatypes([], fbs) = rev fbs
111 :     | mkEmitDatatypes(DATATYPEbind{id,mc,cbs,...}::dbs, fbs) =
112 :     let fun missing() =
113 :     error("machine encoding is missing for constructor "^id)
114 :     fun loop(w, [], cs, found) = (w, rev cs, found)
115 :     | loop(w, (cb as CONSbind{id, ty, mc, ...})::cbs,
116 :     cs, found) =
117 :     let val (e, found) =
118 :     case (mc, w) of
119 :     (NONE, SOME(x::_)) => (WORD(itow x), true)
120 :     | (NONE, SOME []) => (missing(); (WORD 0w0, true))
121 :     | (NONE, NONE) => (APP("error",STRINGexp id), found)
122 :     | (SOME(WORDmc w'), SOME(w::l')) =>
123 :     (if itow w <> w' then
124 :     error ("constructor "^id^" encoding is 0x"^
125 :     W.toString w'^" but is expecting 0x"^
126 :     W.toString(itow w)) else ();
127 :     (WORD w', true))
128 :     | (SOME(WORDmc w'), SOME []) => (WORD w', true)
129 :     | (SOME(WORDmc w'), NONE) => (WORD w', true)
130 :     | (SOME(EXPmc e), _) => (e, true)
131 :     val w = case w of NONE => NONE
132 :     | SOME(_::w) => SOME w
133 :     | SOME [] => (missing(); NONE)
134 :     in loop(w, cbs,
135 :     T.mapConsToClause
136 :     {prefix=["I"], pat=fn p=>p, exp=e} cb::cs,
137 :     found)
138 :     end
139 :     val (w, cs, found) = loop(mc, cbs, [], false)
140 :     val _ = case w of
141 :     SOME(_::_) =>
142 :     error("Extra machine encodings in datatype "^id)
143 :     | _ => ()
144 :     in mkEmitDatatypes(dbs,
145 :     if found then FUNbind(emit id, cs)::fbs else fbs)
146 :     end
147 :     val dbs = Env.datatypeDefinitions env
148 :     in FUNdecl(mkEmitDatatypes(dbs,[]))
149 :     end
150 :    
151 :     (*
152 :     * Generate a formatting function for each machine instruction format
153 :     * defined in the machine description.
154 :     *)
155 :     val formatFuns =
156 :     let fun mkFormat(SOME width, FORMATbind(formatName, fields, NONE)) =
157 :     mkDefinedFormat(width, formatName, fields)
158 :     | mkFormat(NONE, FORMATbind(formatName, fields, NONE)) =
159 :     (error("missing width in format "^formatName);
160 :     FUNbind(formatName, []))
161 :     | mkFormat(_, FORMATbind(formatName, fields, SOME e)) =
162 :     mkFormatFun(formatName, fields, e)
163 :    
164 :     (*
165 :     * Generate an expression that builds up the format
166 :     *)
167 :     and mkDefinedFormat(totalWidth, formatName, fields) =
168 :     let (* factor out the constant and the variable part *)
169 :     fun loop([], bit, constant, exps) = (bit, constant, exps)
170 :     | loop(FIELD{id, width, value, sign, ...}::fs,
171 :     bit, constant, exps) =
172 :     let val width =
173 :     case width of
174 :     WIDTH w => w
175 :     | RANGE(from, to) =>
176 :     (if bit <> from then
177 :     error("field "^id^
178 :     " in format "^formatName^
179 :     " starts from bit "^itos from^
180 :     " (bit "^itos bit^" expected")
181 :     else ();
182 :     to - from + 1)
183 :     val mask = (0w1 << Word.fromInt width) - 0w1
184 :     val (constant, exps) =
185 :     case value of
186 :     SOME v =>
187 :     (if (v && (notb mask)) <> 0w0 then
188 :     error("value 0x"^W.toString v^
189 :     "in field "^id^
190 :     " is out of range")
191 :     else ();
192 :     (constant || (v << Word.fromInt bit),
193 :     exps))
194 :     | NONE =>
195 :     let val e = ID id
196 :     val e = if sign = UNSIGNED then e else
197 :     ANDB(e,WORD32exp mask)
198 :     val e = SLL(e,WORD32exp(itow bit))
199 :     in (constant, e::exps) end
200 :     in loop(fs, bit+width, constant, exps) end
201 :     val (realWidth, constant, exps) =
202 :     loop(rev fields, 0, 0w0, [])
203 :     in if realWidth <> totalWidth then
204 :     error("format "^formatName^" is declared to have "^
205 :     itos totalWidth^" bits but I counted "^
206 :     itos realWidth)
207 :     else ();
208 :     mkFormatFun(formatName, fields,
209 :     APP("eWord"^itos totalWidth,
210 :     foldr PLUS (WORD32exp constant) exps))
211 :     end
212 :    
213 :     (* Generate a format function that includes implicit
214 :     * argument conversions.
215 :     *)
216 :     and mkFormatFun(id, fields, exp) =
217 :     FUNbind(id, [CLAUSE(
218 :     [RECORDpat(foldr (fn (FIELD{id="",...}, fs) => fs
219 :     | (FIELD{value=SOME _,...}, fs) => fs
220 :     | (FIELD{id,...},fs) => (id,IDpat id)::fs ) [] fields, false)],
221 :     NONE,
222 :     LET(foldr (fn (FIELD{id,cnv=NOcnv, ...},ds) => ds
223 :     | (FIELD{id,cnv=CELLcnv k, ...},ds) =>
224 :     VAL(id, APP(emit k,ID id))::ds
225 :     | (FIELD{id,cnv=FUNcnv f, ...},ds) =>
226 :     VAL(id, APP(emit f,ID id))::ds
227 :     ) [] fields, exp))])
228 :     in FUNdecl(map mkFormat (Comp.formats md)) end
229 :    
230 :     (* The main emitter function *)
231 :     val emitInstrFun =
232 :     let fun mkEmitInstr(cb as CONSbind{id, mc, ...}) =
233 :     T.mapConsToClause
234 :     {prefix=["I"],pat=fn p=>p,
235 :     exp=case mc of
236 :     SOME(EXPmc e) => e
237 :     | _ => APP("error", STRINGexp id)
238 :     } cb
239 :     val instructions = Comp.instructions md
240 :     in FUNdecl[FUNbind("emitInstr", map mkEmitInstr instructions)]
241 :     end
242 :    
243 :    
244 :     (* Body of the module *)
245 :     val strBody =
246 :     [$["structure I = Instr",
247 :     "structure C = I.C",
248 :     "structure Constant = I.Constant",
249 : leunga 775 "structure T = I.T",
250 : blume 1002 "structure S = Stream",
251 : leunga 744 "structure P = S.P",
252 :     "structure W = Word32",
253 :     "",
254 :     "(* "^Comp.name md^" is "^
255 :     (case endianess of BIG => "big" | LITTLE => "little")^
256 :     " endian *)",
257 :     ""
258 :     ],
259 :     Comp.errorHandler md "MC",
260 :     $["fun makeStream _ =",
261 :     "let infix && || << >> ~>>",
262 :     " val op << = W.<<",
263 :     " val op >> = W.>>",
264 :     " val op ~>> = W.~>>",
265 :     " val op || = W.orb",
266 :     " val op && = W.andb",
267 :     " val itow = W.fromInt",
268 :     " fun emit_bool false = 0w0 : W.word",
269 :     " | emit_bool true = 0w1 : W.word",
270 :     " val emit_int = itow",
271 :     " fun emit_word w = w",
272 :     " fun emit_label l = itow(Label.addrOf l)",
273 : blume 1002 " fun emit_labexp le = itow(MLTreeEval.valueOf le)",
274 : leunga 744 " fun emit_const c = itow(Constant.valueOf c)",
275 :     " val loc = ref 0",
276 :     "",
277 :     " (* emit a byte *)",
278 :     " fun eByte b =",
279 :     " let val i = !loc in loc := i + 1; CodeString.update(i,b) end",
280 :     "",
281 :     " (* emit the low order byte of a word *)",
282 :     " (* note: fromLargeWord strips the high order bits! *)",
283 :     " fun eByteW w =",
284 :     " let val i = !loc",
285 :     " in loc := i + 1; CodeString.update(i,Word8.fromLargeWord w) end",
286 :     "",
287 :     " fun doNothing _ = ()",
288 : blume 1002 " fun fail _ = raise Fail \"MCEmitter\"",
289 : blume 859 " fun getAnnotations () = error \"getAnnotations\"",
290 : leunga 744 "",
291 :     " fun pseudoOp pOp = P.emitValue{pOp=pOp, loc= !loc,emit=eByte}",
292 :     "",
293 :     " fun init n = (CodeString.init n; loc := 0)",
294 :     "",
295 :     (if debugOn then
296 :     "val S.STREAM{emit=asm,...} = Assembler.makeStream()"
297 :     else ""
298 :     )
299 :     ],
300 :     emitFuns,
301 :     cellFuns,
302 :     datatypeFuns,
303 :     formatFuns,
304 :     Comp.declOf md "MC",
305 :     $[" fun emitter instr =",
306 :     " let"
307 :     ],
308 :     emitInstrFun,
309 :     $[" in",
310 :     (if debugOn then
311 :     " emitInstr instr; asm instr"
312 :     else
313 :     " emitInstr instr"
314 :     ),
315 :     " end",
316 :     "",
317 : blume 1232 "fun emitInstruction(I.ANNOTATION{i, ...}) = emitInstruction(i)",
318 :     " | emitInstruction(I.INSTR(i)) = emitter(i)",
319 :     " | emitInstruction(I.LIVE _) = ()",
320 :     " | emitInstruction(I.KILL _) = ()",
321 :     "| emitInstruction _ = error \"emitInstruction\"",
322 :     "",
323 : leunga 744 "in S.STREAM{beginCluster=init,",
324 :     " pseudoOp=pseudoOp,",
325 : blume 1232 " emit=emitInstruction,",
326 : blume 1002 " endCluster=fail,",
327 : leunga 744 " defineLabel=doNothing,",
328 :     " entryLabel=doNothing,",
329 :     " comment=doNothing,",
330 :     " exitBlock=doNothing,",
331 : blume 859 " annotation=doNothing,",
332 :     " getAnnotations=getAnnotations",
333 : leunga 744 " }",
334 :     "end"
335 :     ]
336 :     ]
337 :    
338 :     in Comp.codegen md "emit/MC"
339 :     [Comp.mkFct md "MCEmitter" args sigName strBody]
340 :     end
341 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0