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-asm.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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