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/trunk/src/MLRISC/Tools/MDL/mdl-gen-asm.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/Tools/MDL/mdl-gen-asm.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1116 - (view) (download)

1 : leunga 744 (*
2 :     * This module generates the assembler of an architecture
3 :     * given a machine description.
4 :     *
5 :     *)
6 :     functor MDLGenAsm(Comp : MDL_COMPILE) : MDL_GEN_MODULE =
7 :     struct
8 :     structure Comp = Comp
9 :     structure Env = Comp.Env
10 :     structure Ast = Comp.Ast
11 :     structure R = Comp.Rewriter
12 :     structure T = Comp.Trans
13 :    
14 :     open Ast Comp.Util Comp.Error
15 :    
16 :     fun gen md =
17 :     let (* name of the functor and signature *)
18 :     val strName = Comp.strname md "AsmEmitter"
19 :     val sigName = "INSTRUCTION_EMITTER"
20 :    
21 :     (* Arguments of the functor *)
22 : george 984 val args = ["structure S : INSTRUCTION_STREAM",
23 :     "structure Instr : "^Comp.signame md "INSTR",
24 :     " where T = S.P.T",
25 : leunga 744 "structure Shuffle : "^Comp.signame md "SHUFFLE",
26 : george 984 " where I = Instr",
27 :     "structure MLTreeEval : MLTREE_EVAL",
28 :     " where T = Instr.T"
29 : leunga 744 ]
30 :     val args = SEQdecl[$args,Comp.fctArgOf md "Assembly"]
31 :    
32 :     (* Cellkinds declared by the user *)
33 :     val cellKinds = Comp.cells md
34 :    
35 :     (* Assembly case *)
36 :     val asmCase = Comp.asmCase md
37 :    
38 :     (* How to make a string expression *)
39 :     fun mkString s =
40 :     STRINGexp(case asmCase of VERBATIM => s
41 :     | LOWERCASE => String.map Char.toLower s
42 :     | UPPERCASE => String.map Char.toUpper s)
43 :    
44 :     (* The Instruction structure *)
45 :     val env = Env.lookupStr (Comp.env md) (IDENT([], "Instruction"))
46 :    
47 :     (* All datatype definitions in this structure *)
48 :     val datatypeDefinitions = Env.datatypeDefinitions env
49 :    
50 :     (*
51 :     * There are three assembly modes:
52 :     * EMIT: directly emit to stream
53 :     * ASM: convert to string
54 :     * NOTHING: do nothing
55 :     *)
56 :     datatype mode = EMIT | ASM | NOTHING
57 :    
58 :     (*
59 :     * Find out which assembly mode a datatype should use
60 :     *)
61 :     fun modeOf(DATATYPEbind{cbs, asm, ...}) =
62 :     let val mode = if asm then ASM else NOTHING
63 :     fun loop([], m) = m
64 :     | loop(_, EMIT) = EMIT
65 :     | loop(CONSbind{asm=NONE, ...}::cbs, m) = loop(cbs, m)
66 :     | loop(CONSbind{asm=SOME(STRINGasm _), ...}::cbs, _)=
67 :     loop(cbs, ASM)
68 :     | loop(CONSbind{asm=SOME(ASMasm a), ...}::cbs, m)=
69 :     loop(cbs, loop2(a, ASM))
70 :     and loop2([], m) = m
71 :     | loop2(EXPasm _::_, _) = EMIT
72 :     | loop2(_::a, m) = loop2(a, m)
73 :     in loop(cbs, mode) end
74 :    
75 :    
76 :     (*
77 :     * Names of emit and assembly functions.
78 :     * The assembly function converts something into a string.
79 :     * The emit function prints that to the stream for side effect.
80 :     *)
81 :     fun emit id = "emit_"^id
82 :     fun asm id = "asm_"^id
83 :    
84 :     (*
85 :     * How to emit special types
86 :     *)
87 :     fun emitTy(id,IDty(IDENT(prefix,t)), e) =
88 :     (case (prefix, t) of
89 :     ([], "int") => APP(emit t, e)
90 :     | ([], "string") => APP("emit", e)
91 :     | (["Constant"],"const") => APP(emit t, e)
92 :     | (["Label"],"label") => APP(emit t, e)
93 : leunga 775 | (["T"],"labexp") => APP(emit t, e)
94 : leunga 744 | (["Region"],"region") => APP(emit t, e)
95 :     | _ =>
96 :     if List.exists(fn db as DATATYPEbind{id=id', ...}=>
97 :     t = id' andalso modeOf db <> NOTHING)
98 :     datatypeDefinitions then
99 :     APP(emit t, e)
100 :     else
101 :     APP(emit id, e)
102 :     )
103 :     | emitTy(_,CELLty "cellset", e) = APP("emit_cellset", e)
104 :     | emitTy(_,CELLty k, e) = APP("emitCell", e)
105 :     | emitTy(id, _, e) = APP(emit id, e)
106 :    
107 :     (*
108 :     * Functions to convert assembly annotations to code
109 :     *)
110 :     fun mkAsms([], fbs) = rev fbs
111 :     | mkAsms((db as DATATYPEbind{id, cbs, ...})::dbs, fbs) =
112 :     (case modeOf db of
113 :     NOTHING => mkAsms(dbs, fbs)
114 :     | EMIT => mkAsms(dbs, FUNbind(emit id,mkAsm(EMIT,cbs))::fbs)
115 :     | ASM => mkAsms(dbs, mkEmit id::
116 :     FUNbind(asm id,mkAsm(ASM,cbs))::fbs)
117 :     )
118 :    
119 :     (* fun emitXXX x = emit(asmXXX x) *)
120 :     and mkEmit id =
121 :     FUNbind(emit id,[CLAUSE([IDpat "x"],NONE,
122 :     APP("emit",APP(asm id,ID "x")))])
123 :    
124 :     (* Translate backquoted expression *)
125 :     and mkAsm(mode, cbs) =
126 :     let fun emitIt e =
127 :     if mode = EMIT then APP("emit",e) else e
128 :     fun asmToExp E (TEXTasm s) = emitIt(mkString s)
129 :     | asmToExp E (EXPasm(IDexp(IDENT([],x)))) =
130 : leunga 797 (let val (e, ty) = E x
131 :     in emitTy(x, ty, e) end
132 :     handle e =>
133 :     fail("unknown assembly field <"^x^">")
134 :     )
135 : leunga 744 | asmToExp E (EXPasm e) =
136 :     let fun exp _ (ASMexp(STRINGasm s)) = emitIt(mkString s)
137 :     | exp _ (ASMexp(ASMasm a)) = SEQexp(map (asmToExp E) a)
138 :     | exp _ e = e
139 :     in #exp(R.rewrite{exp=exp,
140 :     ty=R.noRewrite,
141 :     pat=R.noRewrite,
142 :     sexp=R.noRewrite,
143 :     decl=R.noRewrite
144 :     }
145 :     ) e
146 :     end
147 :     fun mkClause(cb as CONSbind{id, asm, ...}) =
148 :     let val exp =
149 :     case asm of
150 :     NONE => emitIt(mkString id)
151 :     | SOME(STRINGasm s) => emitIt(mkString s)
152 :     | SOME(ASMasm a) =>
153 :     let val consEnv = T.consBindings cb
154 :     in SEQexp(map (asmToExp consEnv) a) end
155 :     in T.mapConsToClause {prefix=["I"],pat=fn p=>p, exp=exp} cb
156 :     end
157 :     in map mkClause cbs end
158 :    
159 :     (*
160 :     * For each datatype defined in the structure Instruction that
161 :     * has pretty printing annotations attached, generate an assembly
162 :     * function and an emit function.
163 :     *)
164 :     val asmFuns = FUNdecl(mkAsms(datatypeDefinitions, []))
165 :    
166 :     (* Main function for emitting an instruction *)
167 :     val emitInstrFun =
168 :     let val instructions = Comp.instructions md
169 :     in FUN("emitInstr'", IDpat "instr",
170 :     CASEexp(ID "instr", mkAsm(EMIT, instructions))
171 :     )
172 :     end
173 :    
174 :     val body =
175 :     [$["structure I = Instr",
176 :     "structure C = I.C",
177 : leunga 775 "structure T = I.T",
178 : george 984 "structure S = S",
179 : leunga 744 "structure P = S.P",
180 :     "structure Constant = I.Constant",
181 :     "",
182 :     "val show_cellset = MLRiscControl.getFlag \"asm-show-cellset\"",
183 :     "val show_region = MLRiscControl.getFlag \"asm-show-region\"",
184 : leunga 796 "val show_cutsTo = MLRiscControl.getFlag \"asm-show-cutsto\"",
185 : leunga 744 "val indent_copies = MLRiscControl.getFlag \"asm-indent-copies\"",
186 :     ""
187 :     ],
188 :     Comp.errorHandler md "AsmEmitter",
189 :     $[ "",
190 :     "fun makeStream formatAnnotations =",
191 :     "let val stream = !AsmStream.asmOutStream",
192 :     " fun emit' s = TextIO.output(stream,s)",
193 :     " val newline = ref true",
194 :     " val tabs = ref 0",
195 :     " fun tabbing 0 = ()",
196 :     " | tabbing n = (emit' \"\\t\"; tabbing(n-1))",
197 :     " fun emit s = (tabbing(!tabs); tabs := 0; newline := false; emit' s)",
198 :     " fun nl() = (tabs := 0; if !newline then () else (newline := true; emit' \"\\n\"))",
199 :     " fun comma() = emit \",\"",
200 :     " fun tab() = tabs := 1",
201 :     " fun indent() = tabs := 2",
202 :     " fun ms n = let val s = Int.toString n",
203 :     " in if n<0 then \"-\"^String.substring(s,1,size s-1)",
204 :     " else s",
205 :     " end",
206 : george 984 " fun emit_label lab = emit(P.Client.AsmPseudoOps.lexpToString(T.LABEL lab))",
207 :     " fun emit_labexp le = emit(P.Client.AsmPseudoOps.lexpToString (T.LABEXP le))",
208 : leunga 744 " fun emit_const c = emit(Constant.toString c)",
209 :     " fun emit_int i = emit(ms i)",
210 :     " fun paren f = (emit \"(\"; f(); emit \")\")",
211 : george 1017 " fun defineLabel lab = emit(P.Client.AsmPseudoOps.defineLabel lab^\"\\n\")",
212 : leunga 744 " fun entryLabel lab = defineLabel lab",
213 : george 1116 " fun comment msg = (tab(); emit(\"/* \" ^ msg ^ \" */\"); nl())",
214 : george 1108 " fun annotation a = comment(Annotations.toString a)",
215 : leunga 815 " fun getAnnotations() = error \"getAnnotations\"",
216 : leunga 744 " fun doNothing _ = ()",
217 : george 909 " fun fail _ = raise Fail \"AsmEmitter\"",
218 : leunga 744 " fun emit_region mem = comment(I.Region.toString mem)",
219 :     " val emit_region = ",
220 :     " if !show_region then emit_region else doNothing",
221 : george 984 " fun pseudoOp pOp = (emit(P.toString pOp); emit \"\\n\")",
222 : leunga 744 " fun init size = (comment(\"Code Size = \" ^ ms size); nl())",
223 :     " val emitCellInfo = AsmFormatUtil.reginfo",
224 :     " (emit,formatAnnotations)",
225 : george 889 " fun emitCell r = (emit(CellsBasis.toString r); emitCellInfo r)",
226 : leunga 744 " fun emit_cellset(title,cellset) =",
227 : jhr 900 " (nl(); comment(title^CellsBasis.CellSet.toString cellset))",
228 : leunga 744 " val emit_cellset = ",
229 :     " if !show_cellset then emit_cellset else doNothing",
230 :     " fun emit_defs cellset = emit_cellset(\"defs: \",cellset)",
231 :     " fun emit_uses cellset = emit_cellset(\"uses: \",cellset)",
232 : leunga 796 " val emit_cutsTo = ",
233 :     " if !show_cutsTo then AsmFormatUtil.emit_cutsTo emit",
234 :     " else doNothing",
235 : leunga 744 " fun emitter instr =",
236 :     " let"
237 :     ],
238 :     asmFuns,
239 :     Comp.declOf md "Assembly",
240 :     emitInstrFun,
241 : george 1003 $[" in tab(); emitInstr' instr; nl()",
242 :     " end (* emitter *)",
243 :     " and emitInstrIndented i = (indent(); emitInstr i; nl())",
244 :     " and emitInstrs instrs =",
245 : leunga 744 " app (if !indent_copies then emitInstrIndented",
246 :     " else emitInstr) instrs",
247 :     "",
248 : george 1003 " and emitInstr(I.ANNOTATION{i,a}) =",
249 :     " ( comment(Annotations.toString a);",
250 :     " nl();",
251 :     " emitInstr i )",
252 :     " | emitInstr(I.LIVE{regs, spilled}) = ",
253 :     " comment(\"live= \" ^ CellsBasis.CellSet.toString regs ^",
254 :     " \"spilled= \" ^ CellsBasis.CellSet.toString spilled)",
255 :     " | emitInstr(I.KILL{regs, spilled}) = ",
256 :     " comment(\"killed:: \" ^ CellsBasis.CellSet.toString regs ^",
257 :     " \"spilled:: \" ^ CellsBasis.CellSet.toString spilled)",
258 :     " | emitInstr(I.INSTR i) = emitter i",
259 : george 1009 " | emitInstr(I.COPY{k=CellsBasis.GP, sz, src, dst, tmp}) =",
260 :     " emitInstrs(Shuffle.shuffle{tmp=tmp, src=src, dst=dst})",
261 :     " | emitInstr(I.COPY{k=CellsBasis.FP, sz, src, dst, tmp}) =",
262 :     " emitInstrs(Shuffle.shufflefp{tmp=tmp, src=src, dst=dst})",
263 : george 1003 " | emitInstr _ = error \"emitInstr\"",
264 :     "",
265 : leunga 744 "in S.STREAM{beginCluster=init,",
266 :     " pseudoOp=pseudoOp,",
267 : george 1003 " emit=emitInstr,",
268 : george 909 " endCluster=fail,",
269 : leunga 744 " defineLabel=defineLabel,",
270 :     " entryLabel=entryLabel,",
271 :     " comment=comment,",
272 :     " exitBlock=doNothing,",
273 : leunga 815 " annotation=annotation,",
274 :     " getAnnotations=getAnnotations",
275 : leunga 744 " }",
276 :     "end"
277 :     ]
278 :     ]
279 :    
280 :     in Comp.codegen md "emit/Asm"
281 :     [Comp.mkFct' md "AsmEmitter" args sigName body]
282 :     end
283 :     end

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