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 744 - (view) (download)
Original Path: sml/trunk/src/MLRISC/Tools/MDL/mdl-rtl-comp.sml

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 :     let val warn = Compiler.Control.MC.bindNonExhaustiveWarn
236 :     val previous = !warn
237 :     fun reset() = warn := previous
238 :     in warn := false;
239 :     (Compiler.Interact.useFile filename; reset())
240 :     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 :     $["structure C = T.CellsBasis"]
292 :     ],
293 :     [userRtlDecls])]),
294 :     STRUCTUREdecl(strname,[],NONE,
295 :     APPsexp(IDENT([],strname),
296 :     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 :     "structure C : "^Comp.signame md "CELLS",
417 :     " sharing type C.cellkind = RTL.T.CellsBasis.cellkind"
418 :     ]
419 :     ],
420 :     NONE,
421 :     DECLsexp decls
422 :     )
423 :    
424 :     (* Write the functor to a file *)
425 :     val _ = Comp.codegen md "mltree/RTL" [AstPP.decl archRTL]
426 :     in ()
427 :     end
428 :    
429 :    
430 :     (*------------------------------------------------------------------------
431 :     *
432 :     * Generic routine for generating query functions from rtl definitions.
433 :     *
434 :     *------------------------------------------------------------------------*)
435 :     fun makeQuery warning (COMPILED_RTLs{rtls, md, rtlTable, ...}) =
436 :     let (* The instructions *)
437 :     val instructions = Comp.instructions md
438 :    
439 :     datatype rtlpat = LIT of string
440 :     | TYP of string * datatypebind
441 :    
442 :     (* Lookup rtl *)
443 :     fun lookupRTL name =
444 :     H.lookup rtlTable name handle e =>
445 :     (warning("Can't find definition for rtl "^name); raise e)
446 :    
447 :     (* error handler *)
448 :     val errorHandler = APP("undefined",TUPLEexp [])
449 :     val errorHandlingClause = CLAUSE([WILDpat],NONE,errorHandler)
450 :    
451 :     fun mkQueryFun{namedArguments, name, args, body, caseArgs, decls} =
452 :     let
453 :     val extraCaseArgs = map ID caseArgs
454 :    
455 :     (* Generate constants *)
456 :     val constTbl = Consts.newConstTable()
457 :     val mkConst = Consts.const constTbl
458 :    
459 :     (* Enumerate all rtl patterns and generate a case expression
460 :     * that branch to different cases.
461 :     *)
462 :     fun foreachRtlPat genCode rtlpats =
463 :     let fun enum([], pats, name) = [(pats, name)]
464 :     | enum(LIT s::rest,pats,name) = enum(rest,pats,s^name)
465 :     | enum(TYP(_,DATATYPEbind{cbs, ...})::rest,pats,name) =
466 :     let val names =
467 :     map (fn cb as CONSbind{id, ...} =>
468 :     let val pat =
469 :     Tr.mapConsToPat
470 :     {prefix=["I"],
471 :     id=fn{newName,...}=>IDpat newName
472 :     } cb
473 :     in enum(rest, pat::pats, id^name)
474 :     end) cbs
475 :     in List.concat names end
476 :     fun caseExps [] = []
477 :     | caseExps (LIT _::rest) = caseExps rest
478 :     | caseExps (TYP(x,_)::rest) = ID x::caseExps rest
479 :     val exps = caseExps rtlpats
480 :     val cases = enum(rev rtlpats, [], "")
481 :     val clauses = map genCode cases
482 :     in CASEexp(tupleexp(exps @ extraCaseArgs), clauses)
483 :     end
484 :    
485 :     (* Enumerate each instruction *)
486 :     and doInstr (CONSbind{rtl=NONE, ...}) = raise NoRTL
487 :     | doInstr (instr as CONSbind{rtl=SOME rtlDef,id,loc, ...})=
488 :     let val _ = setLoc loc
489 :     val E = Tr.consBindings instr (* bindings for the instr *)
490 :    
491 :     (* Translate rtl definition *)
492 :     fun trans(TEXTasm s) = LIT s
493 :     | trans(EXPasm(IDexp(IDENT([],x)))) =
494 :     let val (_, ty) = E x handle _ =>
495 :     fail("unknown identifier "^x^
496 :     " in rtl expression: "^e2s rtlDef)
497 :     val db =
498 :     case ty of
499 :     IDty(IDENT([],t)) => Comp.lookupDatatype md t
500 :     | t => fail("illegal type "^t2s t)
501 :     in TYP(x,db) end
502 :     | trans(EXPasm e) = fail("illegal rtl expression "^e2s e)
503 :    
504 :     fun exp _ (e as RTLexp [COMPOSITErtl _]) = e
505 :     | exp _ (ASMexp(ASMasm rtl)) =
506 :     foreachRtlPat (genCode(instr, E)) (map trans rtl)
507 :     val rw = rw{exp=exp,decl=NIL,pat=NIL,ty=NIL,sexp=NIL}
508 :     in #exp rw rtlDef
509 :     end
510 :    
511 :     (* Call the user defined callback and generate code *)
512 :     and genCode (instr, E) (pats, rtlName) =
513 :     let val rtl as RTLDEF{args,...} = lookupRTL rtlName
514 :     val {casePats,exp} =
515 :     body{const=mkConst,rtl=rtl,instr=instr}
516 :     fun simpList(ps) =
517 :     let fun loop [] = []
518 :     | loop (WILDpat::ps) =
519 :     (case loop ps of
520 :     [] => []
521 :     | ps => WILDpat::ps
522 :     )
523 :     | loop (p::ps) = p::loop ps
524 :     in case loop ps of
525 :     [] => WILDpat
526 :     | ps => LISTpat(ps,SOME WILDpat)
527 :     end
528 :     fun simplifyPat(LISTpat(ps,NONE)) = simpList ps
529 :     | simplifyPat(LISTpat(ps,SOME WILDpat)) = simpList ps
530 :     | simplifyPat(TUPLEpat[p]) = simplifyPat p
531 :     | simplifyPat pat = pat
532 :     val casePats = map simplifyPat casePats
533 :     in CLAUSE([tuplepat(pats@casePats)],NONE,exp)
534 :     end handle _ => errorHandlingClause
535 :    
536 :    
537 :     datatype err = OK | BAD
538 :    
539 :     (* process all instructions *)
540 :     fun foreachInstr([], OK) = []
541 :     | foreachInstr([], BAD) = [errorHandlingClause]
542 :     | foreachInstr(instr::instrs, err) =
543 :     Tr.mapConsToClause{prefix=["I"],
544 :     pat=fn pat => pat,
545 :     exp=doInstr instr
546 :     } instr::
547 :     foreachInstr(instrs, err)
548 :     handle _ => foreachInstr(instrs, BAD)
549 :    
550 :     val clauses = foreachInstr(instructions, OK)
551 :    
552 :     val queryFun = FUNdecl[FUNbind("query", clauses)]
553 :    
554 :     (* How to make an argument:
555 :     * If the argument has more than one
556 :     * name we'll first pack them into a record pattern.
557 :     *)
558 :     fun mkArg [x] = IDpat x
559 :     | mkArg xs =
560 :     if namedArguments then
561 :     RECORDpat(map (fn x => (x,IDpat x)) xs,false)
562 :     else
563 :     TUPLEpat(map IDpat xs)
564 :    
565 :     val wrapper =
566 :     [FUNdecl[FUNbind(name,
567 :     [CLAUSE(map mkArg args,
568 :     NONE,
569 :     LETexp(decls @ [queryFun],
570 :     [APP("query",ID "instr")]))
571 :     ])
572 :     ]
573 :     ]
574 :    
575 :     val constants = Consts.genConsts constTbl
576 :     in Tr.simplifyDecl
577 :     (case constants of
578 :     [] => SEQdecl wrapper
579 :     | _ => LOCALdecl(constants, wrapper)
580 :     )
581 :     end
582 :    
583 :     in mkQueryFun
584 :     end
585 :    
586 :     val mkQuery = makeQuery (fn _ => ())
587 :    
588 :     (*------------------------------------------------------------------------
589 :     *
590 :     * Generic routine that enumerates all arguments in an
591 :     * instruction constructor.
592 :     *
593 :     *------------------------------------------------------------------------*)
594 :     fun forallArgs{instr, rtl=RTLDEF{rtl, ...}, rtlArg, nonRtlArg} unit =
595 :     let val lookupArg = RTL.argOf rtl
596 :     fun every({origName,newName,ty},x) =
597 :     let val (exp, pos) = lookupArg newName
598 :     in rtlArg(newName, ty, exp, pos, x)
599 :     end handle RTL.NotAnArgument => nonRtlArg(newName, ty, x)
600 :     in Tr.foldCons every unit instr
601 :     end
602 :    
603 :     (*------------------------------------------------------------------------
604 :     *
605 :     * Generic routine for generating a query function on the operand type
606 :     *
607 :     *------------------------------------------------------------------------*)
608 :     fun mkOperandQuery compiled_rtls =
609 :     let val md = md compiled_rtls
610 :     in ()
611 :     end
612 :    
613 :    
614 :     (*------------------------------------------------------------------------
615 :     *
616 :     * Generic routine that maps an instruction
617 :     *
618 :     *------------------------------------------------------------------------*)
619 :     fun mapInstr{instr, rtl=RTLDEF{rtl, ...}, rtlArg, nonRtlArg} =
620 :     let val lookupArg = RTL.argOf rtl
621 :     val changed = ref false
622 :     fun mapArg{origName,newName,ty} =
623 :     let val (exp, pos) = lookupArg newName
624 :     in case rtlArg(newName, ty, exp, pos) of
625 :     SOME e => (changed := true; e)
626 :     | NONE => ID newName
627 :     end handle RTL.NotAnArgument =>
628 :     (case nonRtlArg(newName, ty) of
629 :     SOME e => (changed := true; e)
630 :     | NONE => ID newName
631 :     )
632 :     val exp = Tr.mapConsToExp {prefix=["I"], id=mapArg} instr
633 :     in if !changed then exp else ID "instr"
634 :     end
635 :    
636 :     (*------------------------------------------------------------------------
637 :     *
638 :     * Generate RTL code for def/use like queries
639 :     *
640 :     *------------------------------------------------------------------------*)
641 :     fun mkDefUseQuery compiled_rtls { name, decls, def, use } =
642 :     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 :     let val CELLdecl{from, ...} =
659 :     Comp.lookupCellKind md (C.cellkindToString k)
660 :     in add(f,INTexp(i + !from),e,exp)
661 :     end
662 :     | fold f (_, exp) = exp
663 :    
664 :     val (d, u) = RTL.defUse rtl
665 :     val d = List.foldr (fold def) Nil d
666 :     val u = List.foldr (fold use) Nil u
667 :     in case (d, u) of
668 :     (LISTexp([], NONE), LISTexp([], NONE)) => ()
669 :     | _ => trivial := false;
670 :     {exp=TUPLEexp[d, u],
671 :     casePats=[]
672 :     }
673 :     end
674 :     val decl =
675 :     mkQuery compiled_rtls
676 :     {name=name, namedArguments=false, args=[["instr"]], decls=decls,
677 :     caseArgs=[], body=defUseBody
678 :     }
679 :     in if !trivial then FUN(name,WILDpat,TUPLEexp[Nil,Nil])
680 :     else decl
681 :     end
682 :    
683 :     (*------------------------------------------------------------------------
684 :     *
685 :     * Make a simple error handler
686 :     *
687 :     *------------------------------------------------------------------------*)
688 :     fun simpleErrorHandler name =
689 :     $["fun undefined() = error \""^name^"\""]
690 :    
691 :     (*------------------------------------------------------------------------
692 :     *
693 :     * Make a complex error handler
694 :     *
695 :     *------------------------------------------------------------------------*)
696 :     fun complexErrorHandler name =
697 :     $["fun undefined() = bug(\""^name^"\",instr)"]
698 :    
699 :     (*------------------------------------------------------------------------
700 :     *
701 :     * Make a complex error handler
702 :     *
703 :     *------------------------------------------------------------------------*)
704 :     fun complexErrorHandlerDef() =
705 :     $["fun bug(msg,instr) =",
706 :     "let val Asm.S.STREAM{emit, ...} = Asm.makeStream []",
707 :     "in emit (fn r => r) instr; error msg end"
708 :     ]
709 :    
710 :     (*------------------------------------------------------------------------
711 :     *
712 :     * Do consistency checking on the RTL and instruction representation.
713 :     * Call mkQuery to test the entire process.
714 :     *
715 :     *------------------------------------------------------------------------*)
716 :     fun consistencyCheck compiled_rtls =
717 :     let val md = md compiled_rtls
718 :    
719 :     (* Check one instruction *)
720 :     fun check{instr as CONSbind{id=instrName,...},
721 :     rtl=RTLDEF{id=f,args,rtl,...},const} =
722 :     let (* Find all arguments in the instruction constructor *)
723 :     val bindings =
724 :     Tr.foldCons
725 :     (fn({newName,ty,...},L) =>
726 :     (newName,ref false,ty)::L) [] instr
727 :    
728 :     fun lookup id = List.find (fn (x,_,_) => x=id) bindings
729 :     val lookupRTLArg = RTL.argOf rtl
730 :    
731 :     fun checkIt(x,exp,pos,ty) =
732 :     let fun err(why) =
733 :     (error("in instruction "^instrName^" (rtl "^f^"):");
734 :     if why = "" then () else log(why);
735 :     log("rtl argument "^re2s exp^
736 :     " cannot be represented as "^t2s ty)
737 :     )
738 :     in MLRiscTypes.insertRepCoercion(exp,ty);
739 :     case (exp,ty) of
740 :     (T.$(_,k,T.ARG _),CELLty cellkind) =>
741 :     let val CELLdecl{id, ...} =
742 :     Comp.lookupCellKind md cellkind
743 :     in if C.cellkindToString k = id then ()
744 :     else err("cellkind mismatched")
745 :     end
746 :     | (exp, CELLty _) => err("rtl is not a register reference")
747 :     | (T.$(_,_,T.ARG _),ty) => err ""
748 :     | (T.ARG(ty,ref(T.REP k),_),IDty(IDENT(_,typeName))) =>
749 :     if k = typeName then ()
750 :     else err("representation mismatch")
751 :     | (_, _) => err("")
752 :     end handle _ => ()
753 :    
754 :     (* Check one argument in rtl *)
755 :     fun checkRTLArg x =
756 :     let val (exp,pos) = lookupRTLArg x
757 :     in case lookup x of
758 :     SOME(_,found,ty) => (found := true; checkIt(x,exp,pos,ty))
759 :     | NONE => error("'"^x^"' of rtl "^f^
760 :     " is missing from instruction "^instrName)
761 :     end
762 :    
763 :     (* Check one argument in instruction *)
764 :     fun checkInstrArg(name,ref true,ty) = ()
765 :     | checkInstrArg(name,ref false,ty) =
766 :     if MLRiscTypes.isSpecialRepType ty then
767 :     warning("In instruction "^instrName^" (rtl "^f^"): '"^
768 :     name^"' has type "^
769 :     t2s ty^" but its meaning is unspecified in the rtl"
770 :     )
771 :     else ()
772 :    
773 :     in app checkRTLArg args;
774 :     app checkInstrArg bindings;
775 :     {casePats=[], exp=TUPLEexp []}
776 :     end
777 :     val _ = print "Consistency checking...\n"
778 :     val _ = makeQuery warning compiled_rtls
779 :     {name="check",namedArguments=false,
780 :     args=[],decls=[],caseArgs=[], body=check}
781 :     in ()
782 :     end
783 :    
784 :     (*------------------------------------------------------------------------
785 :     *
786 :     * Generate RTL code and write the log
787 :     *
788 :     *------------------------------------------------------------------------*)
789 :     fun gen compiled_rtls =
790 :     (genArchFunctor compiled_rtls;
791 :     consistencyCheck compiled_rtls
792 :     )
793 :     end

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