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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 775 - (view) (download)

1 : leunga 744 (*
2 :     * Generate the <arch>SSAProps functor.
3 :     * This structure extracts semantics and dependence
4 :     * information about the instruction set needed for SSA optimizations.
5 :     *)
6 :    
7 :     functor MDLGenSSAProps(RTLComp : MDL_RTL_COMP) : MDL_GEN_MODULE2 =
8 :     struct
9 :    
10 :     structure RTLComp = RTLComp
11 :     structure Comp = RTLComp.Comp
12 :     structure Ast = Comp.Ast
13 :     structure Env = Comp.Env
14 :     structure RTL = RTLComp.RTL
15 :     structure T = RTL.T
16 :     structure C = CellsBasis
17 : leunga 775 structure M = RTLComp.MLRiscTypes
18 : leunga 744
19 :     open Ast Comp.Util Comp.Error
20 :    
21 :     (* Insert copies *)
22 :    
23 :     fun copyFuns hasImpl =
24 :     let val (implInit,implPat,implCopy) =
25 :     if hasImpl then
26 :     ("impl=ref NONE,","impl,", "impl=impl,")
27 :     else
28 :     ("", "", "")
29 :     in
30 :     $["fun copies cps =",
31 :     "let fun f([],id,is,fd,fs) = (id,is,fd,fs)",
32 : leunga 775 " | f({dst,src}::cps,id,is,fd,fs) =",
33 :     " if C.sameColor(dst,src) then f(cps,id,is,fd,fs)",
34 :     " else case C.cellkind dst of",
35 : leunga 744 " C.GP => f(cps,dst::id,src::is,fd,fs)",
36 :     " | C.FP => f(cps,id,is,dst::fd,src::fs)",
37 :     " | C.MEM => f(cps,id,is,fd,fs)",
38 :     " | C.CTRL => f(cps,id,is,fd,fs)",
39 : leunga 775 " | kind => error(\"copies: \"^C.cellkindToString kind^",
40 :     " \" dst=\"^C.toString dst^",
41 :     " \" src=\"^C.toString src)",
42 : leunga 744 " val (id,is,fd,fs) = f(cps,[],[],[],[])",
43 :     " val icopy = case id of",
44 :     " [] => []",
45 :     " | [_] => [I.COPY{src=is,dst=id,"^implInit^"tmp=NONE}]",
46 :     " | _ => [I.COPY{src=is,dst=id,"^implInit,
47 :     " tmp=SOME(I.Direct(C.newReg()))}]",
48 :     " val fcopy = case fd of",
49 :     " [] => []",
50 :     " | [_] => [I.FCOPY{src=fs,dst=fd,"^implInit^"tmp=NONE}]",
51 :     " | _ => [I.FCOPY{src=fs,dst=fd,"^implInit,
52 :     " tmp=SOME(I.FDirect(C.newFreg()))}]",
53 :     "in icopy @ fcopy end"
54 :     ]
55 :     end
56 :    
57 :     (* Expressions building utilities *)
58 :     fun consexp(x,LISTexp(a,b)) = LISTexp(x::a,b)
59 :     | consexp(x,y) = LISTexp([x],SOME y)
60 :     val nilexp = LISTexp([],NONE)
61 :     fun conspat(x,LISTpat(a,b)) = LISTpat(x::a,b)
62 :     | conspat(x,y) = LISTpat([x],SOME y)
63 :     val nilpat = LISTpat([],NONE)
64 :    
65 :     fun gen compiled_rtls =
66 :     let (* The machine description *)
67 :     val md = RTLComp.md compiled_rtls
68 :    
69 :     (* name of the structure/signature *)
70 :     val strName = Comp.strname md "SSAProps"
71 : leunga 775 val sigName = "MLRISC_SSA_PROPERTIES"
72 : leunga 744
73 :     (* query function *)
74 :     val mkQuery = RTLComp.mkQuery compiled_rtls
75 :    
76 :     fun In x = "in_"^x
77 :     fun Out x = "out_"^x
78 :    
79 : leunga 775
80 : leunga 744 (* Function for extracting naming constraints from an RTL *)
81 :     val namingConstraints =
82 : leunga 775 let
83 :     fun body{instr,rtl,const} =
84 : leunga 744 let fun ignore p = conspat(WILDpat,p)
85 : leunga 775 fun cell(k,r) =
86 :     const(
87 :     APPexp(APPexp(IDexp(IDENT(["C"],"Reg")),
88 :     IDexp(IDENT(["C"],C.cellkindToString k))),
89 :     INTexp(IntInf.toInt r)))
90 : leunga 744
91 : leunga 775 fun addSrc(id,r,(d,u,C)) =
92 : leunga 744 (d,
93 :     conspat(IDpat(In id),u),
94 : leunga 775 APP("USE",RECORDexp[("var",ID(In id)),("color",r)])::C
95 : leunga 744 )
96 :    
97 : leunga 775 fun addDst(id,r,(d,u,C)) =
98 : leunga 744 (conspat(IDpat(Out id),d),
99 :     u,
100 : leunga 775 APP("DEF",RECORDexp[("var",ID(Out id)),("color",r)])::C
101 : leunga 744 )
102 :    
103 : leunga 775 fun addDstSrc(id,(d,u,C)) =
104 : leunga 744 (conspat(IDpat(Out id),d),
105 :     conspat(IDpat(In id),u),
106 : leunga 775 APP("SAME",RECORDexp[("x",ID(Out id)),("y",ID(In id))])::
107 :     C
108 : leunga 744 )
109 :    
110 : leunga 775 fun ignoreUse(d,u,C) = (d, conspat(WILDpat,u), C)
111 : leunga 744
112 : leunga 775 fun ignoreDef(d,u,C) = (conspat(WILDpat,d), u, C)
113 : leunga 744
114 : leunga 775 fun f(id,ty,T.$(_,k,T.LI r),RTL.IN _,x) =
115 :     addSrc(id,cell(k,r),x)
116 :     | f(id,ty,T.$(_,k,T.LI r),RTL.OUT _,x) =
117 :     addDst(id,cell(k,r),x)
118 : leunga 744 | f(id,ty,_,RTL.IO _,x) = addDstSrc(id, x)
119 :     | f(id,ty,_,RTL.IN _,x) = ignoreUse x
120 :     | f(id,ty,_,RTL.OUT _,x) = ignoreDef x
121 :    
122 :     fun g(id,ty,x) = x
123 :    
124 : leunga 775 val (d,u,C) =
125 : leunga 744 RTLComp.forallArgs
126 : leunga 775 {instr=instr,rtl=rtl,rtlArg=f,nonRtlArg=g} (nilpat,nilpat,[])
127 :     in {exp=LISTexp(C,NONE), casePats=[d,u]}
128 : leunga 744 end
129 :    
130 : leunga 775 val decls=[RTLComp.complexErrorHandler "namingConstraints",
131 :     $["val dst_list = dst and src_list = src"]
132 :     ]
133 : leunga 744 in mkQuery
134 :     {name = "namingConstraints",
135 :     namedArguments = true,
136 :     args = [["instr","src","dst"]],
137 : leunga 775 caseArgs = ["dst_list","src_list"],
138 : leunga 744 decls = decls,
139 :     body = body
140 :     }
141 :     end
142 :    
143 :     (* Function for rewriting the operands of an RTL *)
144 : leunga 775 val substituteOperands =
145 : leunga 744 let fun body {instr,rtl,const} =
146 :     let fun Ignore p = conspat(WILDpat, p)
147 :    
148 :     fun add(RTL.IN _,x,d,u) = (d,conspat(IDpat(In x),u))
149 :     | add(RTL.OUT _,x,d,u) = (conspat(IDpat(Out x),d),u)
150 :     | add(RTL.IO _,x,d,u) = (conspat(IDpat(Out x),d),Ignore u)
151 :    
152 :     fun nochange(d,u) = (Ignore d,Ignore u)
153 :    
154 :     fun f(id,ty,T.$(_,k,T.LI r),pos,(d,u)) = nochange(d,u)
155 :     | f(id,ty,exp,pos,(d,u)) = add(pos,id,d,u)
156 :    
157 :     fun g(id,ty,(d,u)) = (Ignore d,Ignore u)
158 :    
159 : leunga 775 fun arg(T.$(_,k,_),name) =
160 :     if C.cellkindToString k = "CELLSET" then NONE
161 :     else SOME(ID name)
162 :     | arg(T.ARG _,name) = SOME(APP("get_operand",ID name))
163 :    
164 : leunga 744 fun f'(id,ty,T.$(_,k,T.LI r),pos) = NONE
165 : leunga 775 | f'(id,ty,exp,RTL.IN _) = arg(exp,In id)
166 :     | f'(id,ty,exp,RTL.OUT _) = arg(exp,Out id)
167 :     | f'(id,ty,exp,RTL.IO _) = arg(exp,Out id)
168 : leunga 744
169 :     fun g' _ = NONE
170 :    
171 :     val (d, u) =
172 :     RTLComp.forallArgs{instr=instr,rtl=rtl,rtlArg=f,nonRtlArg=g}
173 :     (nilpat,nilpat)
174 :     val exp =
175 :     RTLComp.mapInstr{instr=instr,rtl=rtl,rtlArg=f',nonRtlArg=g'}
176 :     in {exp=exp, casePats=[d, u]}
177 :     end
178 :    
179 : leunga 775 val decls=[RTLComp.complexErrorHandler "substituteOperands",
180 :     $["fun get_operand x = error \"get_operand\"",
181 :     "val dst_list = dst and src_list = src"
182 :     ]
183 :     ]
184 : leunga 744 in mkQuery
185 : leunga 775 {name = "substituteOperands",
186 : leunga 744 namedArguments = true,
187 :     args = [["const"],["instr","dst","src"]],
188 : leunga 775 caseArgs = ["dst_list","src_list"],
189 : leunga 744 decls = decls,
190 :     body = body
191 :     }
192 :     end
193 :    
194 :     (* Arguments to the instruction functor *)
195 :     val args =
196 :     ["structure Instr : "^Comp.signame md "INSTR",
197 :     "structure RegionProps : REGION_PROPERTIES ",
198 :     "structure RTLProps : RTL_PROPERTIES where I = Instr",
199 : leunga 775 "structure InsnProps : INSN_PROPERTIES where I = Instr",
200 : leunga 744 "structure Asm : INSTRUCTION_EMITTER where I = Instr",
201 :     "structure OperandTable : OPERAND_TABLE where I = Instr",
202 :     " sharing RegionProps.Region = Instr.Region",
203 : leunga 775 "val volatile : Instr.C.cell list",
204 :     "val pinnedDef : Instr.C.cell list",
205 :     "val pinnedUse : Instr.C.cell list",
206 :     "val dedicatedDef : Instr.C.cell list",
207 :     "val dedicatedUse : Instr.C.cell list"
208 : leunga 744 ]
209 :    
210 :     (* The functor *)
211 :     val strBody =
212 : leunga 775 [$ ["structure I = Instr",
213 :     "structure C = I.C",
214 :     "structure RTLProps = RTLProps",
215 :     "structure InsnProps = InsnProps",
216 :     "structure RTL = RTLProps.RTL",
217 :     "structure T = RTL.T",
218 :     "structure OT = OperandTable",
219 :     "structure RP = RegionProps",
220 : leunga 744 "",
221 :     "datatype const = datatype OT.const",
222 : leunga 775 "datatype constraint =",
223 :     " DEF of {var:C.cell, color:C.cell}",
224 :     "| USE of {var:C.cell, color:C.cell}",
225 :     "| SAME of {x:C.cell, y:C.cell}",
226 : leunga 744 ""
227 :     ],
228 :     Comp.errorHandler md "SSAProps",
229 :     RTLComp.complexErrorHandlerDef (),
230 :     $ ["",
231 :     "val volatile = volatile",
232 : leunga 775 "val dedicatedDef = dedicatedDef",
233 :     "val dedicatedUse = dedicatedUse",
234 :     "val pinnedDef = pinnedDef",
235 :     "val pinnedUse = pinnedUse",
236 : leunga 744 "val source = I.SOURCE{}",
237 :     "val sink = I.SINK{}",
238 :     "val phi = I.PHI{}",
239 :     ""
240 :     ],
241 :     namingConstraints,
242 : leunga 775 substituteOperands,
243 : leunga 744 copyFuns (Comp.hasCopyImpl md),
244 :     Comp.declOf md "SSA"
245 :     ]
246 :    
247 :     in Comp.codegen md "SSA/SSAProps"
248 :     [Comp.mkFct md "SSAProps" args sigName
249 :     strBody
250 :     (* (map Comp.Trans.simplifyDecl strBody) *)
251 :     ]
252 :     end
253 :    
254 :     end

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