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

Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/MDL/mdl-rtl-comp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1002 - (view) (download)

1 : leunga 744 (*
2 :     * Process rtl descriptions
3 :     *)
4 :     functor MDLRTLComp
5 :     (structure Typing : MDL_TYPING
6 :     structure RTLTools : MDL_RTL_TOOLS
7 :     structure MLRiscTypes : MLRISC_TYPES
8 :     sharing Typing.Ast = RTLTools.Ast = MLRiscTypes.Ast
9 :     sharing MLRiscTypes.RTL = RTLTools.RTL
10 :     ) : MDL_RTL_COMP =
11 :     struct
12 :     structure Comp = Typing.Comp
13 :     structure Ast = Comp.Ast
14 :     structure AstPP = Comp.AstPP
15 :     structure Env = Comp.Env
16 :     structure Consts = Comp.Consts
17 :     structure Tr = Comp.Trans
18 :     structure R = Comp.Rewriter
19 :     structure H = HashTable
20 :     structure TypeUtil = Typing.TypeUtil
21 :     structure MLRiscTypes = MLRiscTypes
22 :     structure RTL = RTLTools.RTL
23 :     structure T = RTL.T
24 :     structure C = CellsBasis
25 :    
26 :     open Ast Comp.Util Comp.Error
27 :    
28 :     val t2s = PP.text o AstPP.ty
29 :     val e2s = PP.text o AstPP.exp
30 :     val p2s = PP.text o AstPP.pat
31 :     val d2s = PP.text o AstPP.decl
32 :     val re2s = RTL.Util.rexpToString
33 :    
34 :     val rw = R.rewrite
35 :     val NIL = R.noRewrite
36 :     val i2s = Int.toString
37 :    
38 :     fun tuplepat [p] = p
39 :     | tuplepat ps = TUPLEpat ps
40 :     fun tupleexp [e] = e
41 :     | tupleexp es = TUPLEexp es
42 :    
43 :    
44 :     exception NoRTL
45 :    
46 :     datatype rtl_def =
47 :     RTLDEF of {id : Ast.id,
48 :     args : Ast.id list,
49 :     rtl : RTL.rtl
50 :     }
51 :    
52 :    
53 :     datatype compiled_rtls = COMPILED_RTLs of
54 :     { md : Comp.md,
55 :     env : Env.env,
56 :     rtls : rtl_def list,
57 :     newOps : T.Basis.misc_op list,
58 :     rtlTable : (string,rtl_def) H.hash_table
59 :     }
60 :    
61 :     val current_rtls = ref [] : rtl_def list ref
62 :    
63 :     val makeRTLDEF = IDexp(IDENT(["MDLRTLComp"],"RTLDEF"))
64 :     fun md(COMPILED_RTLs{md, ...}) = md
65 :     fun rtls(COMPILED_RTLs{rtls, ...}) = rtls
66 :    
67 :     fun noError() = !errorCount = 0
68 :    
69 :     (*------------------------------------------------------------------------
70 :     *
71 :     * Perform type interference and arity raising
72 :     *
73 :     *------------------------------------------------------------------------*)
74 :     fun typeInference(md, rtlDecls) =
75 :     let (* Perform typechecking + arity raising *)
76 :     val (semantics, env) =
77 :     (print "Typechecking...\n";
78 :     Typing.typeCheck md rtlDecls)
79 :    
80 :     (* Make sure that there are
81 :     * no unresolved type applications after
82 :     * arity raising.
83 :     *)
84 :     fun checkSemantics semantics =
85 :     let fun checkUnresolvedTypeApplications(d,loc) =
86 :     let val poly = ref false
87 :     fun exp ==> (e as TYPEexp t) =
88 :     (if Typing.isPolymorphic t then poly := true else (); e)
89 :     | exp ==> e = e
90 :     in #decl (rw{exp=exp,ty=NIL,decl=NIL,sexp=NIL,pat=NIL}) d;
91 :     if !poly then
92 :     errorPos(loc,"unresolved polytype application in:\n"^d2s d)
93 :     else ()
94 :     end
95 :    
96 :     fun decl ==> d =
97 :     (case d of
98 :     MARKdecl(l,d as VALdecl _) =>
99 :     checkUnresolvedTypeApplications(d, l)
100 :     | RTLdecl(_,_,loc) => checkUnresolvedTypeApplications(d, loc)
101 :     | _ => ();
102 :     d
103 :     )
104 :     in #decl (rw{exp=NIL,ty=NIL,decl=decl,sexp=NIL,pat=NIL}) semantics;
105 :     ()
106 :     end
107 :    
108 :     in if noError() then checkSemantics semantics else ();
109 :     (semantics, env)
110 :     end
111 :    
112 :     (*------------------------------------------------------------------------
113 :     * Translate the rtl declarations into an executable form.
114 :     *------------------------------------------------------------------------*)
115 :     fun codeGen(md, env, rtlDecls) =
116 :     let fun cellOf k =
117 :     let val CELLdecl{id, bits, ...} = Comp.lookupCellKind md k
118 :     in TUPLEexp[IDexp(IDENT(["C"],id)),INTexp bits]
119 :     end
120 :    
121 :     fun exp ==> (LOCexp(m,e,NONE)) = APPexp(APP("$",cellOf m),e)
122 :     | exp ==> (LOCexp(m,e,SOME r)) =
123 :     APPexp(APP("Mem",cellOf m),TUPLEexp[e,ID r])
124 :     | exp ==> (IFexp(a,b,c)) = APP("If",TUPLEexp[a,b,c])
125 :     | exp ==> (TUPLEexp []) = ID "Nop"
126 :     | exp ==> (IDexp(IDENT([],"="))) = ID "=="
127 :     | exp ==> (TYPEDexp(e,_)) = e
128 :     | exp ==> (APPexp(BITSLICEexp(e,r),t)) =
129 :     APPexp(APPexp(APP("BitSlice",t),
130 :     LISTexp(map (fn (a,b) => TUPLEexp[INTexp a,INTexp b]) r,
131 :     NONE)),e)
132 :     | exp ==> (LITexp(BOOLlit false)) = ID "False"
133 :     | exp ==> (LITexp(BOOLlit true)) = ID "True"
134 :     | exp ==> (IDexp(IDENT([],"not"))) = ID "Not"
135 :     | exp ==> (IDexp(IDENT([],"andalso"))) = ID "And"
136 :     | exp ==> (IDexp(IDENT([],"cond"))) = ID "Cond"
137 :     | exp ==> (IDexp(IDENT([],"orelse"))) = ID "Or"
138 :     | exp ==> (IDexp(IDENT([],"||"))) = ID "Par"
139 :     | exp ==> e = e
140 :    
141 :     (* All rtl definitions *)
142 :     val allRtls = ref []
143 :    
144 :     fun addRtls(p, loc) =
145 :     let fun processBinding x =
146 :     let val (_,t) = Env.lookupVal env (IDENT([],x))
147 :     val t = #ty (rw{exp=NIL,pat=NIL,decl=NIL,sexp=NIL,ty=NIL}) t
148 :     in if Typing.isPolymorphic t then
149 :     errorPos(loc, "rtl "^x^" has polymorphic type "^
150 :     t2s t)
151 :     else
152 :     case t of
153 :     FUNty(RECORDty lts,_) => (allRtls := (x,lts,loc) :: !allRtls)
154 :     | t => errorPos(loc,
155 :     "rtl "^x^" has a non-function type "^t2s t)
156 :     end
157 :     fun pat ==> (p as IDpat x) = (processBinding x; p)
158 :     | pat ==> p = p
159 :     in #pat (rw{exp=NIL,ty=NIL,decl=NIL,sexp=NIL,pat=pat}) p end
160 :    
161 :     fun decl ==> (DATATYPEdecl _) = SEQdecl[]
162 :     | decl ==> (TYPESIGdecl _) = SEQdecl[]
163 :     | decl ==> (VALSIGdecl _) = SEQdecl[]
164 :     | decl ==> (VALdecl[VALbind(LISTpat(pats,NONE),
165 :     APPexp(
166 :     APPexp(APPexp(IDexp(IDENT([],"map")),_),f),
167 :     LISTexp(es,NONE)))]) =
168 :     VALdecl(ListPair.map (fn (p,e) => VALbind(p,APPexp(f,e)))
169 :     (pats,es))
170 :     | decl ==> (VALdecl[VALbind(LISTpat(pats,NONE),LISTexp(es,NONE))]) =
171 :     VALdecl(ListPair.map VALbind (pats,es))
172 :     | decl ==> (RTLdecl(pat,exp,loc)) =
173 :     (addRtls(pat,loc); ==>(VALdecl[VALbind(pat,exp)]))
174 :     | decl ==> (MARKdecl(_,SEQdecl [])) = SEQdecl[]
175 :     | decl ==> d = d
176 :    
177 :     (* Define the cellkinds in a substructure C *)
178 :     val cellKindDecls =
179 :     VALdecl(map (fn CELLdecl{id, nickname, ...} =>
180 :     VALbind(IDpat id,
181 :     APPexp(
182 :     IDexp(IDENT(["C"],"newCellKind")),
183 :     RECORDexp[("name",STRINGexp id),
184 :     ("nickname",STRINGexp nickname)
185 :     ])))
186 :     (Comp.cells md))
187 :    
188 :     val userRtlDecls =
189 :     #decl (rw{exp=exp,pat=NIL,sexp=NIL,decl=decl,ty=NIL}) rtlDecls
190 :     val allDecls = SEQdecl[STRUCTUREdecl("C",[],NONE,
191 :     DECLsexp[cellKindDecls]),
192 :     userRtlDecls]
193 :     in (allDecls, rev(!allRtls))
194 :     end
195 :    
196 :     (*------------------------------------------------------------------------
197 :     * Rewrite the program to fill in all syntactic shorthands
198 :     *------------------------------------------------------------------------*)
199 :     fun expandSyntacticSugar(md, rtlDecls) =
200 :     let (* Function to define a new operator *)
201 :     fun newRtlOp argTy f =
202 :     let fun newVars(i,n) =
203 :     if i < n then ("x"^i2s i)::newVars(i+1,n)
204 :     else []
205 :     fun arity(TUPLEty x) = length x
206 :     | arity _ = 1
207 :     val names = newVars(0,arity argTy)
208 :     val formals = TUPLEpat(map IDpat names)
209 :     val actuals = LISTexp(map ID names,NONE)
210 :     in LOCALdecl([VAL("newOper",APP("newOp",STRINGexp f))],
211 :     [FUN(f,formals,APP("newOper",actuals))])
212 :     end
213 :    
214 :     (* Rewrite the program first to fill in all syntactic shorthands *)
215 :     fun exp ==> (e as LITexp(INTlit _)) = APP("intConst", e)
216 :     | exp ==> (e as LITexp(WORD32lit _)) = APP("wordConst",e)
217 :     | exp ==> (e as LITexp(WORDlit _)) = APP("wordConst",e)
218 :     | exp ==> e = e
219 :     fun decl ==> (RTLSIGdecl(fs,FUNty(argTy,_))) =
220 :     SEQdecl(map (newRtlOp argTy) fs)
221 :     | decl ==> (d as RTLSIGdecl(fs,ty)) = (error("bad type in "^d2s d); d)
222 :     | decl ==> d = d
223 :    
224 :     val rtlDecls =
225 :     #decl (rw{exp=exp,pat=NIL,decl=decl,sexp=NIL,ty=NIL}) rtlDecls
226 :    
227 :     in rtlDecls
228 :     end
229 :    
230 :     (*------------------------------------------------------------------------
231 :     * Compile a file.
232 :     * Turn off pattern matching warnings
233 :     *------------------------------------------------------------------------*)
234 :     fun compileFile filename =
235 : blume 1002 let val warn = Control.MC.bindNonExhaustiveWarn
236 : leunga 744 val previous = !warn
237 :     fun reset() = warn := previous
238 :     in warn := false;
239 : blume 1002 (Backend.Interact.useFile filename; reset())
240 : leunga 744 handle e => (reset(); raise e)
241 :     end
242 :    
243 :     (*------------------------------------------------------------------------
244 :     * Process the rtl description
245 :     ------------------------------------------------------------------------*)
246 :     fun compile md =
247 :     let (* The semantics environment *)
248 :     val semantics = Comp.declOf md "RTL"
249 :    
250 :     (* Expand Syntactic sugar *)
251 :     val semantics = expandSyntacticSugar(md, semantics)
252 :    
253 :     (* Perform typechecking *)
254 :     val (semantics, env) = typeInference(md, semantics)
255 :    
256 :     (* Generate the rtl functions defined by the user *)
257 :     val (userRtlDecls, allRtls) = codeGen(md, env, semantics)
258 :    
259 :     (* Generate the rtl table *)
260 :     val rtlTable =
261 :     if !errorCount = 0 then
262 :     let fun mkEntry (name,args,loc) =
263 :     let fun mkArg(arg,ty) =
264 :     let val (sz,kind) =
265 :     MLRiscTypes.representationOf(name, arg, loc, ty)
266 :     in (arg,APP("Arg",
267 :     TUPLEexp[INTexp sz,STRINGexp kind,STRINGexp arg])
268 :     )
269 :     end
270 :    
271 :     in APPexp(makeRTLDEF,
272 :     RECORDexp
273 :     [("id",STRINGexp name),
274 :     ("args",
275 :     LISTexp(map (fn (x,_) => STRINGexp x) args,NONE)),
276 :     ("rtl",APP(name, RECORDexp(map mkArg args)))
277 :     ]
278 :     )
279 :     end
280 :     in VALdecl[VALbind(IDpat "rtls", LISTexp(map mkEntry allRtls,NONE))]
281 :     end else $[]
282 :    
283 :     val strname = Comp.strname md "RTL"
284 :    
285 :     (* Now generate the code that MDGen uses *)
286 :     val code =
287 :     LOCALdecl(
288 :     [STRUCTUREdecl(strname,[$["Build : RTL_BUILD"]],NONE,
289 :     DECLsexp
290 :     [LOCALdecl([OPENdecl [IDENT([],"Build")],
291 : leunga 775 $["structure C = CellsBasis"]
292 : leunga 744 ],
293 :     [userRtlDecls])]),
294 :     STRUCTUREdecl(strname,[],NONE,
295 : leunga 775 APPsexp(IDsexp(IDENT([],strname)),
296 : leunga 744 IDsexp(IDENT([],"MDLRTLBuilder")))),
297 :     LOCALdecl([OPENdecl [IDENT([],"MDLRTLBuilder"),
298 :     IDENT([],strname)]],
299 :     [rtlTable])
300 :     ],
301 :     [
302 :     $["val _ = MDLRTLComp.current_rtls := rtls"]
303 :     ]
304 :     )
305 :    
306 :     (* Compile RTL into internal form *)
307 :     fun elaborateRTL(code) =
308 :     if !errorCount = 0 then
309 :     let val _ = current_rtls := []
310 :     val name = "CompileRTL"
311 :     val _ = print "Generating ML code for computing RTLs...\n";
312 :     val _ = Comp.codegen md name [AstPP.decl code]
313 :     val filename = Comp.pathName md name ".sml"
314 :     in print "Calling the ML compiler to build the rtls ...\n";
315 :     print "This may take a while...\n";
316 :     compileFile filename
317 :     end
318 :     else ()
319 :    
320 :    
321 :     (* Execute the code *)
322 :     val _ = elaborateRTL(code)
323 :     val newOps = MDLRTLBuilder.getNewOps()
324 :     val _ = MDLRTLBuilder.clearNewOps()
325 :    
326 :     (* Build a table of rtls *)
327 :     val rtlTable = H.mkTable(HashString.hashString,op=) (32,NoRTL)
328 :     val allRtls = !current_rtls
329 :     val _ =
330 :     app (fn def as RTLDEF{id,...} => H.insert rtlTable (id,def)) allRtls
331 :    
332 :     in COMPILED_RTLs{md = md,
333 :     env = env,
334 :     rtls = allRtls,
335 :     newOps = newOps,
336 :     rtlTable = rtlTable
337 :     }
338 :     end
339 :    
340 :     (*------------------------------------------------------------------------
341 :     * Pretty print RTL code
342 :     *------------------------------------------------------------------------*)
343 :     fun dumpLog(COMPILED_RTLs{md, rtls, newOps, ...}) =
344 :     let fun prNewOp{name, hash, attribs} =
345 :     "New abstract operator "^name^"\n"
346 :    
347 :     fun prRTL(def as RTLDEF{id=f, args, rtl, ...}) =
348 :     let fun listify es = foldr (fn (x,"") => x | (x,y) => x^", "^y) "" es
349 :     fun prs es = listify(map RTL.expToString es)
350 :     fun prs' es =
351 :     listify(map (fn (e,r) => RTL.expToString e^"="^i2s r) es)
352 :     val pretty = String.translate (fn #"\n" => "\n\t"
353 :     | #";" => " ||"
354 :     | c => Char.toString c)
355 :     val (d, u) = RTL.defUse rtl
356 :     val {fixedDefs, fixedUses, twoAddress} = RTL.namingConstraints(d,u)
357 :     val rtlText = pretty(RTL.rtlToString rtl)
358 :     val rtl = RTLTools.simplify rtl
359 :    
360 :     fun line(title,"") = ""
361 :     | line(title,text) = "\t"^title^":\t"^text^"\n"
362 :     in "rtl "^f^
363 :     "{"^List.foldr(fn (x,"") => x | (x,y) => x^","^y) "" args^
364 :     "} =\n\t"^rtlText^"\n"^
365 :     line("Define",prs d)^
366 :     line("Use",prs u)^
367 :     line("Pinned definitions",prs' fixedDefs)^
368 :     line("Pinned uses",prs' fixedUses)^
369 :     line("Two address operand",prs twoAddress)^
370 :     line("Constructor",
371 :     PP.text(AstPP.decl(RTLTools.rtlToFun(f, args, rtl))))^
372 :     line("Destructor",
373 :     PP.text(AstPP.pat(RTLTools.rtlToPat(rtl))))^
374 :     "\n"
375 :     end
376 :    
377 :     (* Sort them alphabetically *)
378 :     val rtls =
379 :     ListMergeSort.sort
380 :     (fn (RTLDEF{id=f,...},RTLDEF{id=g,...}) => String.>(f,g)) rtls
381 :    
382 :     val nRTLs = length rtls
383 :     val nNewOps = length newOps
384 :    
385 :     val text =
386 :     "There are a total of "::i2s nRTLs::" rtl templates defined.\n"::
387 :     "There are a total of "::i2s nNewOps::" new abstract operators.\n"::
388 :     "RTL information follows:\n\n"::
389 :     map prNewOp newOps @
390 :     ["\n\n"] @
391 :     map prRTL rtls
392 :    
393 :     in Comp.Error.printToLog (String.concat text)
394 :     end
395 :    
396 :     (*------------------------------------------------------------------------
397 :     * Gnerate code the ArchRTL functor
398 :     *------------------------------------------------------------------------*)
399 :     fun genArchFunctor(COMPILED_RTLs{md, rtls, newOps, ...}) =
400 :     let (* The ArchRTL functor *)
401 :     val strname = Comp.strname md "RTL"
402 :    
403 :     (* The main body are just the RTL constructor functions *)
404 :     val decls =
405 :     $["structure T = RTL.T"
406 :     ]::
407 :     STRUCTUREdecl("P",[],NONE,
408 :     DECLsexp(map RTLTools.createNewOp newOps))::
409 :     map (fn RTLDEF{id,args,rtl} => RTLTools.rtlToFun(id,args,rtl))
410 :     rtls
411 :    
412 :     val archRTL =
413 :     STRUCTUREdecl(
414 :     strname,
415 :     [$["structure RTL : MLTREE_RTL",
416 : leunga 775 "structure C : "^Comp.signame md "CELLS"
417 : leunga 744 ]
418 :     ],
419 :     NONE,
420 :     DECLsexp decls
421 :     )
422 :    
423 :     (* Write the functor to a file *)
424 :     val _ = Comp.codegen md "mltree/RTL" [AstPP.decl archRTL]
425 :     in ()
426 :     end
427 :    
428 :    
429 :     (*------------------------------------------------------------------------
430 :     *
431 :     * Generic routine for generating query functions from rtl definitions.
432 :     *
433 :     *------------------------------------------------------------------------*)
434 :     fun makeQuery warning (COMPILED_RTLs{rtls, md, rtlTable, ...}) =
435 :     let (* The instructions *)
436 :     val instructions = Comp.instructions md
437 :    
438 :     datatype rtlpat = LIT of string
439 :     | TYP of string * datatypebind
440 :    
441 :     (* Lookup rtl *)
442 :     fun lookupRTL name =
443 :     H.lookup rtlTable name handle e =>
444 :     (warning("Can't find definition for rtl "^name); raise e)
445 :    
446 :     (* error handler *)
447 :     val errorHandler = APP("undefined",TUPLEexp [])
448 :     val errorHandlingClause = CLAUSE([WILDpat],NONE,errorHandler)
449 :    
450 :     fun mkQueryFun{namedArguments, name, args, body, caseArgs, decls} =
451 :     let
452 :     val extraCaseArgs = map ID caseArgs
453 :    
454 :     (* Generate constants *)
455 :     val constTbl = Consts.newConstTable()
456 :     val mkConst = Consts.const constTbl
457 :    
458 :     (* Enumerate all rtl patterns and generate a case expression
459 :     * that branch to different cases.
460 :     *)
461 :     fun foreachRtlPat genCode rtlpats =
462 :     let fun enum([], pats, name) = [(pats, name)]
463 :     | enum(LIT s::rest,pats,name) = enum(rest,pats,s^name)
464 :     | enum(TYP(_,DATATYPEbind{cbs, ...})::rest,pats,name) =
465 :     let val names =
466 :     map (fn cb as CONSbind{id, ...} =>
467 :     let val pat =
468 :     Tr.mapConsToPat
469 :     {prefix=["I"],
470 :     id=fn{newName,...}=>IDpat newName
471 :     } cb
472 :     in enum(rest, pat::pats, id^name)
473 :     end) cbs
474 :     in List.concat names end
475 :     fun caseExps [] = []
476 :     | caseExps (LIT _::rest) = caseExps rest
477 :     | caseExps (TYP(x,_)::rest) = ID x::caseExps rest
478 :     val exps = caseExps rtlpats
479 :     val cases = enum(rev rtlpats, [], "")
480 :     val clauses = map genCode cases
481 :     in CASEexp(tupleexp(exps @ extraCaseArgs), clauses)
482 :     end
483 :    
484 :     (* Enumerate each instruction *)
485 :     and doInstr (CONSbind{rtl=NONE, ...}) = raise NoRTL
486 :     | doInstr (instr as CONSbind{rtl=SOME rtlDef,id,loc, ...})=
487 :     let val _ = setLoc loc
488 :     val E = Tr.consBindings instr (* bindings for the instr *)
489 :    
490 :     (* Translate rtl definition *)
491 :     fun trans(TEXTasm s) = LIT s
492 :     | trans(EXPasm(IDexp(IDENT([],x)))) =
493 :     let val (_, ty) = E x handle _ =>
494 :     fail("unknown identifier "^x^
495 :     " in rtl expression: "^e2s rtlDef)
496 :     val db =
497 :     case ty of
498 :     IDty(IDENT([],t)) => Comp.lookupDatatype md t
499 :     | t => fail("illegal type "^t2s t)
500 :     in TYP(x,db) end
501 :     | trans(EXPasm e) = fail("illegal rtl expression "^e2s e)
502 :    
503 :     fun exp _ (e as RTLexp [COMPOSITErtl _]) = e
504 :     | exp _ (ASMexp(ASMasm rtl)) =
505 :     foreachRtlPat (genCode(instr, E)) (map trans rtl)
506 :     val rw = rw{exp=exp,decl=NIL,pat=NIL,ty=NIL,sexp=NIL}
507 :     in #exp rw rtlDef
508 :     end
509 :    
510 :     (* Call the user defined callback and generate code *)
511 :     and genCode (instr, E) (pats, rtlName) =
512 :     let val rtl as RTLDEF{args,...} = lookupRTL rtlName
513 :     val {casePats,exp} =
514 :     body{const=mkConst,rtl=rtl,instr=instr}
515 :     fun simpList(ps) =
516 :     let fun loop [] = []
517 :     | loop (WILDpat::ps) =
518 :     (case loop ps of
519 :     [] => []
520 :     | ps => WILDpat::ps
521 :     )
522 :     | loop (p::ps) = p::loop ps
523 :     in case loop ps of
524 :     [] => WILDpat
525 :     | ps => LISTpat(ps,SOME WILDpat)
526 :     end
527 :     fun simplifyPat(LISTpat(ps,NONE)) = simpList ps
528 :     | simplifyPat(LISTpat(ps,SOME WILDpat)) = simpList ps
529 :     | simplifyPat(TUPLEpat[p]) = simplifyPat p
530 :     | simplifyPat pat = pat
531 :     val casePats = map simplifyPat casePats
532 :     in CLAUSE([tuplepat(pats@casePats)],NONE,exp)
533 :     end handle _ => errorHandlingClause
534 :    
535 :    
536 :     datatype err = OK | BAD
537 :    
538 :     (* process all instructions *)
539 :     fun foreachInstr([], OK) = []
540 :     | foreachInstr([], BAD) = [errorHandlingClause]
541 :     | foreachInstr(instr::instrs, err) =
542 :     Tr.mapConsToClause{prefix=["I"],
543 :     pat=fn pat => pat,
544 :     exp=doInstr instr
545 :     } instr::
546 :     foreachInstr(instrs, err)
547 :     handle _ => foreachInstr(instrs, BAD)
548 :    
549 :     val clauses = foreachInstr(instructions, OK)
550 :    
551 :     val queryFun = FUNdecl[FUNbind("query", clauses)]
552 :    
553 :     (* How to make an argument:
554 :     * If the argument has more than one
555 :     * name we'll first pack them into a record pattern.
556 :     *)
557 :     fun mkArg [x] = IDpat x
558 :     | mkArg xs =
559 :     if namedArguments then
560 :     RECORDpat(map (fn x => (x,IDpat x)) xs,false)
561 :     else
562 :     TUPLEpat(map IDpat xs)
563 :    
564 :     val wrapper =
565 :     [FUNdecl[FUNbind(name,
566 :     [CLAUSE(map mkArg args,
567 :     NONE,
568 :     LETexp(decls @ [queryFun],
569 :     [APP("query",ID "instr")]))
570 :     ])
571 :     ]
572 :     ]
573 :    
574 :     val constants = Consts.genConsts constTbl
575 :     in Tr.simplifyDecl
576 :     (case constants of
577 :     [] => SEQdecl wrapper
578 :     | _ => LOCALdecl(constants, wrapper)
579 :     )
580 :     end
581 :    
582 :     in mkQueryFun
583 :     end
584 :    
585 :     val mkQuery = makeQuery (fn _ => ())
586 :    
587 :     (*------------------------------------------------------------------------
588 :     *
589 :     * Generic routine that enumerates all arguments in an
590 :     * instruction constructor.
591 :     *
592 :     *------------------------------------------------------------------------*)
593 :     fun forallArgs{instr, rtl=RTLDEF{rtl, ...}, rtlArg, nonRtlArg} unit =
594 :     let val lookupArg = RTL.argOf rtl
595 :     fun every({origName,newName,ty},x) =
596 :     let val (exp, pos) = lookupArg newName
597 :     in rtlArg(newName, ty, exp, pos, x)
598 :     end handle RTL.NotAnArgument => nonRtlArg(newName, ty, x)
599 :     in Tr.foldCons every unit instr
600 :     end
601 :    
602 :     (*------------------------------------------------------------------------
603 :     *
604 :     * Generic routine for generating a query function on the operand type
605 :     *
606 :     *------------------------------------------------------------------------*)
607 :     fun mkOperandQuery compiled_rtls =
608 :     let val md = md compiled_rtls
609 :     in ()
610 :     end
611 :    
612 :    
613 :     (*------------------------------------------------------------------------
614 :     *
615 :     * Generic routine that maps an instruction
616 :     *
617 :     *------------------------------------------------------------------------*)
618 :     fun mapInstr{instr, rtl=RTLDEF{rtl, ...}, rtlArg, nonRtlArg} =
619 :     let val lookupArg = RTL.argOf rtl
620 :     val changed = ref false
621 :     fun mapArg{origName,newName,ty} =
622 :     let val (exp, pos) = lookupArg newName
623 :     in case rtlArg(newName, ty, exp, pos) of
624 :     SOME e => (changed := true; e)
625 :     | NONE => ID newName
626 :     end handle RTL.NotAnArgument =>
627 :     (case nonRtlArg(newName, ty) of
628 :     SOME e => (changed := true; e)
629 :     | NONE => ID newName
630 :     )
631 :     val exp = Tr.mapConsToExp {prefix=["I"], id=mapArg} instr
632 :     in if !changed then exp else ID "instr"
633 :     end
634 :    
635 :     (*------------------------------------------------------------------------
636 :     *
637 :     * Generate RTL code for def/use like queries
638 :     *
639 :     *------------------------------------------------------------------------*)
640 : leunga 775 fun mkDefUseQuery compiled_rtls
641 :     { name, decls, def, use, namedArguments, args } =
642 : leunga 744 let val md = md compiled_rtls
643 :     val trivial = ref true
644 :     val Nil = LISTexp([], NONE)
645 :    
646 :     fun defUseBody{instr, rtl=RTLDEF{rtl, ...}, const} =
647 :     let val bindings =
648 :     Tr.foldCons (fn({newName,ty,...},L) => (newName,ty)::L) [] instr
649 :     fun lookup id = List.find (fn (x,_) => x=id) bindings
650 :     fun add(f, x, e, y) =
651 :     case f(x, e, y) of
652 :     SOME e => e
653 :     | NONE => y
654 :    
655 :     fun fold f (e as T.ARG(_,_,x),exp) = add(f, ID x, e, exp)
656 :     | fold f (e as T.$(_,_,T.ARG(_,_,x)),exp) = add(f, ID x,e,exp)
657 :     | fold f (e as T.$(_,k,T.LI i), exp) =
658 : leunga 775 let val CELLdecl{id, ...} =
659 : leunga 744 Comp.lookupCellKind md (C.cellkindToString k)
660 : leunga 775 val cell =
661 :     APPexp(APPexp(IDexp(IDENT(["C"],"Reg")),
662 :     IDexp(IDENT(["C"],id))),
663 :     INTexp(IntInf.toInt i))
664 :     in add(f,const cell,e,exp)
665 : leunga 744 end
666 :     | fold f (_, exp) = exp
667 :    
668 :     val (d, u) = RTL.defUse rtl
669 :     val d = List.foldr (fold def) Nil d
670 :     val u = List.foldr (fold use) Nil u
671 :     in case (d, u) of
672 :     (LISTexp([], NONE), LISTexp([], NONE)) => ()
673 :     | _ => trivial := false;
674 :     {exp=TUPLEexp[d, u],
675 :     casePats=[]
676 :     }
677 :     end
678 :     val decl =
679 :     mkQuery compiled_rtls
680 : leunga 775 {name=name, namedArguments=namedArguments, args=args, decls=decls,
681 : leunga 744 caseArgs=[], body=defUseBody
682 :     }
683 :     in if !trivial then FUN(name,WILDpat,TUPLEexp[Nil,Nil])
684 :     else decl
685 :     end
686 :    
687 :     (*------------------------------------------------------------------------
688 :     *
689 :     * Make a simple error handler
690 :     *
691 :     *------------------------------------------------------------------------*)
692 :     fun simpleErrorHandler name =
693 :     $["fun undefined() = error \""^name^"\""]
694 :    
695 :     (*------------------------------------------------------------------------
696 :     *
697 :     * Make a complex error handler
698 :     *
699 :     *------------------------------------------------------------------------*)
700 :     fun complexErrorHandler name =
701 :     $["fun undefined() = bug(\""^name^"\",instr)"]
702 :    
703 :     (*------------------------------------------------------------------------
704 :     *
705 :     * Make a complex error handler
706 :     *
707 :     *------------------------------------------------------------------------*)
708 :     fun complexErrorHandlerDef() =
709 :     $["fun bug(msg,instr) =",
710 :     "let val Asm.S.STREAM{emit, ...} = Asm.makeStream []",
711 : leunga 775 "in emit instr; error msg end"
712 : leunga 744 ]
713 :    
714 :     (*------------------------------------------------------------------------
715 :     *
716 :     * Do consistency checking on the RTL and instruction representation.
717 :     * Call mkQuery to test the entire process.
718 :     *
719 :     *------------------------------------------------------------------------*)
720 :     fun consistencyCheck compiled_rtls =
721 :     let val md = md compiled_rtls
722 :    
723 :     (* Check one instruction *)
724 :     fun check{instr as CONSbind{id=instrName,...},
725 :     rtl=RTLDEF{id=f,args,rtl,...},const} =
726 :     let (* Find all arguments in the instruction constructor *)
727 :     val bindings =
728 :     Tr.foldCons
729 :     (fn({newName,ty,...},L) =>
730 :     (newName,ref false,ty)::L) [] instr
731 :    
732 :     fun lookup id = List.find (fn (x,_,_) => x=id) bindings
733 :     val lookupRTLArg = RTL.argOf rtl
734 :    
735 :     fun checkIt(x,exp,pos,ty) =
736 :     let fun err(why) =
737 :     (error("in instruction "^instrName^" (rtl "^f^"):");
738 :     if why = "" then () else log(why);
739 :     log("rtl argument "^re2s exp^
740 :     " cannot be represented as "^t2s ty)
741 :     )
742 :     in MLRiscTypes.insertRepCoercion(exp,ty);
743 :     case (exp,ty) of
744 :     (T.$(_,k,T.ARG _),CELLty cellkind) =>
745 :     let val CELLdecl{id, ...} =
746 :     Comp.lookupCellKind md cellkind
747 :     in if C.cellkindToString k = id then ()
748 :     else err("cellkind mismatched")
749 :     end
750 :     | (exp, CELLty _) => err("rtl is not a register reference")
751 :     | (T.$(_,_,T.ARG _),ty) => err ""
752 :     | (T.ARG(ty,ref(T.REP k),_),IDty(IDENT(_,typeName))) =>
753 :     if k = typeName then ()
754 :     else err("representation mismatch")
755 :     | (_, _) => err("")
756 :     end handle _ => ()
757 :    
758 :     (* Check one argument in rtl *)
759 :     fun checkRTLArg x =
760 :     let val (exp,pos) = lookupRTLArg x
761 :     in case lookup x of
762 :     SOME(_,found,ty) => (found := true; checkIt(x,exp,pos,ty))
763 :     | NONE => error("'"^x^"' of rtl "^f^
764 :     " is missing from instruction "^instrName)
765 :     end
766 :    
767 :     (* Check one argument in instruction *)
768 :     fun checkInstrArg(name,ref true,ty) = ()
769 :     | checkInstrArg(name,ref false,ty) =
770 :     if MLRiscTypes.isSpecialRepType ty then
771 :     warning("In instruction "^instrName^" (rtl "^f^"): '"^
772 :     name^"' has type "^
773 :     t2s ty^" but its meaning is unspecified in the rtl"
774 :     )
775 :     else ()
776 :    
777 :     in app checkRTLArg args;
778 :     app checkInstrArg bindings;
779 :     {casePats=[], exp=TUPLEexp []}
780 :     end
781 :     val _ = print "Consistency checking...\n"
782 :     val _ = makeQuery warning compiled_rtls
783 :     {name="check",namedArguments=false,
784 :     args=[],decls=[],caseArgs=[], body=check}
785 :     in ()
786 :     end
787 :    
788 :     (*------------------------------------------------------------------------
789 :     *
790 :     * Generate RTL code and write the log
791 :     *
792 :     *------------------------------------------------------------------------*)
793 :     fun gen compiled_rtls =
794 :     (genArchFunctor compiled_rtls;
795 :     consistencyCheck compiled_rtls
796 :     )
797 :     end

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