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

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