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/SMLNJ/src/compiler/CodeGen/main/mlriscGen.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/CodeGen/main/mlriscGen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 498 - (view) (download)

1 : monnier 429 (* mlriscGenNew.sml --- translate CPS to MLRISC.
2 :     *
3 :     * This version of MLRiscGen also injects GC types to the MLRISC backend.
4 :     * I've also reorganized it a bit and added a few comments
5 :     * so that I can understand it.
6 : monnier 247 *
7 :     * COPYRIGHT (c) 1996 AT&T Bell Laboratories.
8 :     *
9 :     *)
10 :    
11 : monnier 429 signature MLRISCGEN =
12 :     sig
13 : monnier 247 val codegen :
14 :     CPS.function list * (CPS.lvar -> (int * int)) * ErrorMsg.complainer -> unit
15 :     end
16 :    
17 :     functor MLRiscGen
18 :     ( structure MachineSpec: MACH_SPEC
19 :     structure PseudoOp : SMLNJ_PSEUDO_OP_TYPE
20 :     structure C : CPSREGS
21 :     where type T.Constant.const = SMLNJConstant.const
22 :     where T.Region = CPSRegions
23 :     and T.PseudoOp = PseudoOp
24 : monnier 429 structure InvokeGC : INVOKE_GC
25 :     where T = C.T
26 :     structure Cells : CELLS
27 : monnier 411 structure MLTreeComp : MLTREECOMP
28 :     where T = C.T
29 :     structure Flowgen : FLOWGRAPH_GEN
30 :     where T = MLTreeComp.T
31 :     and I = MLTreeComp.I
32 : monnier 498 val compile : Flowgen.flowgraph -> unit
33 : monnier 247 ): MLRISCGEN =
34 :     struct
35 :     structure M : MLTREE = C.T
36 :     structure P = CPS.P
37 :     structure LE = LabelExp
38 :     structure R = CPSRegions
39 :     structure CG = Control.CG
40 :     structure MS = MachineSpec
41 :    
42 :     structure D = MS.ObjDesc
43 : monnier 429 val dtoi = LargeWord.toInt (* convert object descriptor to int *)
44 : monnier 247
45 :     structure ArgP =
46 :     ArgPassing(structure Cells=Cells
47 : monnier 429 structure C=C
48 :     structure MS=MachineSpec)
49 : monnier 247
50 :     structure Frag = Frag(M)
51 :    
52 : monnier 411 structure MemAliasing = MemAliasing(Cells)
53 : monnier 247
54 : monnier 411 structure MkRecord = MkRecord(C)
55 : monnier 247
56 : monnier 429 (*
57 :     * GC Safety
58 :     *)
59 :     structure GCCells =
60 :     GCCells(structure C = Cells
61 : monnier 475 structure GCMap = SMLGCMap)
62 : monnier 247
63 : monnier 498 val I31 = SMLGCType.I31 (* tagged integers *)
64 :     val I32 = SMLGCType.I32 (* untagged integers *)
65 :     val REAL64 = SMLGCType.REAL64 (* untagged floats *)
66 :     val PTR = SMLGCType.PTR (* boxed objects *)
67 :     val NO_OPT = #create MLRiscAnnotations.NO_OPTIMIZATION ()
68 : monnier 429
69 : monnier 247 fun error msg = ErrorMsg.impossible ("MLRiscGen." ^ msg)
70 :    
71 : monnier 429 (*
72 :     * These are the type widths of ML. They are hardwired for now.
73 :     *)
74 :     val pty = 32 (* size of ML's pointer *)
75 :     val ity = 32 (* size of ML's integer *)
76 :     val fty = 64 (* size of ML's real number *)
77 : monnier 247
78 : monnier 429 (*
79 :     * The allocation pointer
80 :     *)
81 : monnier 411 val M.REG(_,allocptrR) = C.allocptr
82 : monnier 247
83 : monnier 429 (*
84 :     * Dedicated registers.
85 :     *)
86 : monnier 247 val dedicated' =
87 : monnier 411 map (fn r => M.GPR(M.REG(ity,r))) C.dedicatedR @
88 :     map (fn f => M.FPR(M.FREG(fty,f))) C.dedicatedF
89 : monnier 429
90 : monnier 247 val dedicated =
91 : monnier 429 case C.exhausted of NONE => dedicated'
92 :     | SOME cc => M.CCR cc :: dedicated'
93 : monnier 247
94 : monnier 498 val mlrisc = Control.MLRISC.getFlag "mlrisc"
95 :    
96 : monnier 429 (*
97 :     * If this flag is on then annotate the registers with GC type info.
98 :     * Otherwise use the default behavior.
99 :     *)
100 :     val gcsafety = Control.MLRISC.getFlag "mlrisc-gcsafety"
101 : monnier 411
102 : monnier 429 (*
103 : monnier 475 * If this flag is on then split the entry block.
104 :     * This should be on for SSA optimizations.
105 : monnier 429 *)
106 : monnier 475 val splitEntry = Control.MLRISC.getFlag "split-entry-block"
107 : monnier 247
108 : monnier 429 (*
109 : monnier 475 * This dummy annotation is used to get an empty block
110 :     *)
111 : monnier 498 val EMPTY_BLOCK = #create MLRiscAnnotations.EMPTY_BLOCK ()
112 : monnier 475
113 :     (*
114 : monnier 429 * The codegen function.
115 :     *)
116 :     fun codegen(funcs : CPS.function list, limits:CPS.lvar -> (int*int), err) =
117 :     let val stream as M.Stream.STREAM
118 :     { beginCluster, (* start a cluster *)
119 :     endCluster, (* end a cluster *)
120 :     emit, (* emit MLTREE stm *)
121 :     alias, (* generate register alias *)
122 :     defineLabel, (* define a local label *)
123 :     entryLabel, (* define an external entry *)
124 :     exitBlock, (* mark the end of a procedure *)
125 :     pseudoOp, (* emit a pseudo op *)
126 : monnier 475 annotation, (* add an annotation *)
127 : monnier 429 ... } =
128 : monnier 498 MLTreeComp.selectInstructions
129 :     (Flowgen.newStream{compile=compile, flowgraph=NONE})
130 : monnier 429 val maxAlloc = #1 o limits
131 :     val instructionCount = #2 o limits
132 : monnier 475 val splitEntry = !splitEntry
133 : monnier 247
134 : monnier 429 (*
135 :     * The natural address arithmetic width of the architecture.
136 :     * For most architecture this is 32 but for the Alpha this is 64,
137 :     * since 64-bit address arithmetic is more efficiently implemented
138 :     * on the Alpha.
139 : monnier 247 *)
140 : monnier 429 val addrTy = C.addressWidth
141 : monnier 247
142 : monnier 429 (*
143 :     * These functions generate new virtual register names.
144 :     * When the gc-safety feature is turned on, we'll use the
145 :     * versions of newReg that automatically update the GCMap.
146 :     * Otherwise, we'll just use the normal version.
147 : monnier 247 *)
148 : monnier 498 val (newReg,newFreg,markPTR) =
149 : monnier 429 if !gcsafety then
150 : monnier 498 let val gcMap = GCCells.newGCMap()
151 :     val enterGC = Intmap.add gcMap
152 :     in GCCells.setGCMap gcMap;
153 :     (GCCells.newCell Cells.GP,
154 :     GCCells.newCell Cells.FP,
155 :     #create MLRiscAnnotations.MARK_REG(fn r => enterGC(r,PTR))
156 :     )
157 :     end
158 :     else (Cells.newReg, Cells.newFreg, NO_OPT)
159 : monnier 247
160 : monnier 498 (*
161 :     * Known functions have parameters passed in fresh temporaries.
162 :     * We also annotate the gc types of these temporaries.
163 :     *)
164 :     fun known [] = []
165 :     | known(cty::rest) =
166 :     (case cty of
167 :     CPS.FLTt => M.FPR(M.FREG(64,newFreg REAL64))
168 :     | CPS.INTt => M.GPR(M.REG(32,newReg I31))
169 :     | CPS.INT32t => M.GPR(M.REG(32,newReg I32))
170 :     | _ => M.GPR(M.REG(32,newReg PTR))
171 :     )::known rest
172 : monnier 247
173 : monnier 429 (* labelTbl: mapping of function names (CPS.lvars) to labels *)
174 :     exception LabelBind and TypTbl
175 :     val labelTbl : Label.label Intmap.intmap = Intmap.new(32, LabelBind)
176 :     val functionLabel = Intmap.map labelTbl
177 :     val addLabelTbl = Intmap.add labelTbl
178 : monnier 247
179 : monnier 429 val typTbl : CPS.cty Intmap.intmap = Intmap.new(32, TypTbl)
180 :     val addTypBinding = Intmap.add typTbl
181 :     val typmap = Intmap.map typTbl
182 : monnier 411
183 : monnier 429 fun mkGlobalTables(fk, f, _, _, _) =
184 : monnier 475 ((* internal label *)
185 :     addLabelTbl (f, Label.newLabel "");
186 :     (* external entry label *)
187 :     if splitEntry then
188 :     (case fk of
189 :     (CPS.CONT | CPS.ESCAPE) =>
190 :     addLabelTbl (~f-1, Label.newLabel(Int.toString f))
191 :     | _ => ()
192 :     )
193 :     else ();
194 : monnier 429 case fk
195 :     of CPS.CONT => addTypBinding(f, CPS.CNTt)
196 :     | _ => addTypBinding(f, CPS.BOGt)
197 :     (*esac*))
198 : monnier 247
199 : monnier 429 (*
200 :     * This is the GC comparison test used. We have a choice of signed
201 :     * and unsigned comparisons. This usually doesn't matter, but some
202 :     * architectures work better in one way or the other, so we are given
203 :     * a choice here.
204 : monnier 247 *)
205 : monnier 429 val gcTest = M.CMP(pty, if C.signedGCTest then M.GT else M.GTU,
206 :     C.allocptr, C.limitptr)
207 : monnier 498
208 : monnier 429 (*
209 : monnier 498 * Convert kind to gc type
210 :     *)
211 :     fun kindToGC(CPS.P.INT 31) = I31
212 :     | kindToGC(CPS.P.UINT 31) = I31
213 :     | kindToGC(_) = I32
214 :    
215 :     (*
216 : monnier 429 * Function for generating code for one cluster.
217 : monnier 247 *)
218 : monnier 429 fun genCluster(cluster) =
219 :     let val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
220 :     val clusterSize = length cluster
221 : monnier 247
222 : monnier 429 (* per-cluster tables *)
223 :     exception RegMap and GenTbl
224 :     (*
225 :     * genTbl -- is used to retrieve the parameter passing
226 :     * conventions once a function has been compiled.
227 :     *)
228 :     val genTbl : Frag.frag Intmap.intmap = Intmap.new(clusterSize, GenTbl)
229 :     val addGenTbl = Intmap.add genTbl
230 :     val lookupGenTbl = Intmap.map genTbl
231 : monnier 247
232 : monnier 429 (*
233 :     * {fp,gp}RegTbl -- mapping of lvars to registers
234 :     *)
235 :     val fpRegTbl : M.fexp Intmap.intmap = Intmap.new(2, RegMap)
236 :     val gpRegTbl : M.rexp Intmap.intmap = Intmap.new(32, RegMap)
237 :     fun clearTables() =(Intmap.clear fpRegTbl; Intmap.clear gpRegTbl)
238 :     val addExpBinding = Intmap.add gpRegTbl
239 :     fun addRegBinding(x,r) = addExpBinding(x,M.REG(ity,r))
240 :     val addFregBinding = Intmap.add fpRegTbl
241 : monnier 247
242 : monnier 429 (*
243 :     * The following function is used to translate CPS into
244 :     * larger trees.
245 :     *)
246 :     val treeify = CpsTreeify.usage cluster
247 : monnier 247
248 : monnier 429 (*
249 :     * memDisambiguation uses the new register counters,
250 :     * so this must be reset here.
251 :     *)
252 :     val _ = Cells.reset()
253 :     val memDisambig = MemAliasing.analyze(cluster)
254 : monnier 247
255 : monnier 429 (*
256 :     * Points-to analysis projection.
257 :     *)
258 :     fun pi(x as ref(R.PT.TOP _),_) = x
259 :     | pi(x as ref(R.PT.NAMED _),_) = x
260 :     | pi(x,i) = R.PT.pi(x,i)
261 : monnier 247
262 : monnier 429 val memDisambigFlag = !CG.memDisambiguate
263 :     val top = ref(R.PT.NAMED("mem",R.PT.newTop()))
264 : monnier 247
265 : monnier 429 fun getRegion(e,i) =
266 :     if memDisambigFlag then
267 :     (case e of
268 :     CPS.VAR v => pi(memDisambig v,i)
269 :     | _ => R.readonly
270 :     )
271 :     else top
272 : monnier 411
273 : monnier 429 (*
274 :     * The following function is used to check whether alignment
275 :     * of the allocation pointer is necessary.
276 :     *)
277 :     val align = Alignment.build cluster
278 :     fun alignAllocptr f =
279 :     if align f then
280 :     emit(M.MV(pty,allocptrR, M.ORB(pty,C.allocptr, M.LI 4)))
281 :     else ()
282 : monnier 247
283 : monnier 429 (*
284 :     * Function grabty lookups the CPS type of a value expression in CPS.
285 :     *)
286 :     fun grabty(CPS.VAR v) = typmap v
287 :     | grabty(CPS.LABEL v) = typmap v
288 :     | grabty(CPS.INT _) = CPS.INTt
289 :     | grabty(CPS.INT32 _) = CPS.INT32t
290 :     | grabty(CPS.VOID) = CPS.FLTt
291 :     | grabty _ = CPS.BOGt
292 : monnier 247
293 : monnier 429 (*
294 :     * The baseptr contains the start address of the entire
295 :     * compilation unit. This function generates the address of
296 :     * a label that is embedded in the same compilation unit. The
297 :     * generated address is relative to the baseptr.
298 : monnier 498 *
299 :     * Note: For GC safety, we considered this to be an object reference
300 : monnier 429 *)
301 :     fun laddr(lab, k) =
302 : monnier 498 let val e =
303 : monnier 429 M.ADD(addrTy, C.baseptr,
304 :     M.LABEL(LE.PLUS(LE.LABEL lab,
305 :     LE.CONST(k-MachineSpec.constBaseRegOffset))))
306 : monnier 498 in if !gcsafety then M.MARK(e,markPTR) else e
307 :     end
308 : monnier 247
309 : monnier 429 (*
310 :     * A CPS register may be implemented as a physical
311 :     * register or a memory location. The function assign moves a
312 :     * value v into a register or a memory location.
313 :     *)
314 :     fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
315 :     | assign(r as M.LOAD(ty, ea, region), v) =
316 :     M.STORE(ty, ea, v, region)
317 :     | assign _ = error "assign"
318 : monnier 247
319 : monnier 429 (*
320 :     * The following function looks up the MLTREE expression associated
321 :     * with a general purpose value expression.
322 :     *)
323 :     val lookupGpRegTbl = Intmap.map gpRegTbl
324 :     fun regbind(CPS.VAR v) = lookupGpRegTbl v
325 :     (*
326 :     (lookupGpRegTbl v handle e =>
327 :     (print ("\n* can't find a register for lvar " ^
328 :     (Int.toString v) ^ "\n");
329 :     raise e)) *)
330 :     | regbind(CPS.INT i) = M.LI (i+i+1)
331 :     | regbind(CPS.INT32 w) = M.LI32 w
332 : monnier 475 | regbind(CPS.LABEL v) =
333 :     laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
334 : monnier 429 | regbind _ = error "regbind"
335 : monnier 247
336 : monnier 429 (*
337 :     * The following function looks up the MLTREE expression associated
338 :     * with a floating point value expression.
339 :     *)
340 :     val lookupFpRegTbl = Intmap.map fpRegTbl
341 :     fun fregbind(CPS.VAR v) = lookupFpRegTbl v
342 :     (*
343 :     (lookupFpRegTbl v handle e =>
344 :     (print ("\n* can't find a fpregister for lvar " ^
345 :     (Int.toString v) ^ "\n");
346 :     raise e)) *)
347 :     | fregbind _ = error "fregbind"
348 : monnier 247
349 : monnier 429 (*
350 :     * Add type bindings for each definition. This is used to determine
351 :     * the parameter passing convention for standard functions.
352 :     *)
353 :     fun initTypBindings e =
354 :     let val add = addTypBinding
355 :     in case e
356 :     of CPS.RECORD(_,_,v,e) => (add(v,CPS.BOGt); initTypBindings e)
357 :     | CPS.SELECT(_,_,v,t,e) => (add(v,t); initTypBindings e)
358 :     | CPS.OFFSET(_,_,v,e) => (add(v,CPS.BOGt); initTypBindings e)
359 :     | CPS.SWITCH(_,_,el) => app initTypBindings el
360 :     | CPS.SETTER(_,_,e) => initTypBindings e
361 :     | CPS.LOOKER(_,_,v,t,e) => (add(v,t); initTypBindings e)
362 :     | CPS.ARITH(_,_,v,t,e) => (add(v,t); initTypBindings e)
363 :     | CPS.PURE(_,_,v,t,e) => (add(v,t); initTypBindings e)
364 :     | CPS.BRANCH(_,_,_,e1,e2) =>
365 :     (initTypBindings e1; initTypBindings e2)
366 :     | CPS.APP _ => ()
367 :     | _ => error "initTypBindings"
368 :     end
369 : monnier 247
370 : monnier 429 (* On entry to a function, the parameters will be in formal
371 :     * parameter passing registers. Within the body of the function, they
372 :     * are moved immediately to fresh temporary registers. This ensures
373 :     * that the life time of the formal paramters is restricted to the
374 :     * function body and is critical in avoiding artificial register
375 :     * interferences.
376 :     *)
377 :     fun initialRegBindingsEscaping(vl, rl, tl) =
378 :     let fun eCopy(x::xs, M.GPR(M.REG(_,r))::rl, rds, rss, xs', rl') =
379 : monnier 498 let val t = newReg PTR
380 : monnier 429 in addRegBinding(x, t);
381 :     eCopy(xs, rl, t::rds, r::rss, xs', rl')
382 :     end
383 :     | eCopy(x::xs, r::rl, rds, rss, xs', rl') =
384 :     eCopy(xs, rl, rds, rss, x::xs', r::rl')
385 :     | eCopy([], [], [], [], xs', rl') = (xs', rl')
386 :     | eCopy([], [], rds, rss, xs', rl') =
387 :     (emit(M.COPY(ity, rds, rss)); (xs', rl'))
388 : monnier 247
389 : monnier 429 fun eOther(x::xs, M.GPR(r)::rl, xs', rl') =
390 : monnier 498 let val t = newReg PTR
391 : monnier 429 in addRegBinding(x, t); emit(M.MV(ity, t, r));
392 :     eOther(xs, rl, xs', rl')
393 :     end
394 :     | eOther(x::xs, (M.FPR(M.FREG(_,f)))::rl, xs', rl') =
395 :     eOther(xs, rl, x::xs', f::rl')
396 :     | eOther([], [], xs, rl) = (xs, rl)
397 : monnier 247
398 : monnier 429 fun eFcopy([], []) = ()
399 :     | eFcopy(xs, rl) =
400 : monnier 498 let val fs = map (fn _ => newFreg REAL64) xs
401 : monnier 429 in ListPair.app
402 :     (fn (x,f) => addFregBinding(x,M.FREG(fty,f))) (xs,fs);
403 :     emit(M.FCOPY(fty, fs, rl))
404 :     end
405 :     val (vl', rl') = eCopy(vl, rl, [], [], [], [])
406 :     in eFcopy(eOther(vl', rl', [], []));
407 :     ListPair.app addTypBinding (vl, tl)
408 :     end
409 : monnier 247
410 : monnier 429 fun initialRegBindingsKnown(vl, rl, tl) =
411 :     let fun f(v, M.GPR(reg as M.REG _)) = addExpBinding(v, reg)
412 :     | f(v, M.FPR(freg as M.FREG _)) = addFregBinding(v, freg)
413 :     | f _ = error "initialRegBindingsKnown.f"
414 :     in ListPair.app f (vl, rl);
415 :     ListPair.app addTypBinding (vl, tl)
416 :     end
417 : monnier 247
418 : monnier 429 (* Keep allocation pointer aligned on odd boundary
419 :     * Note: We have accounted for the extra space this eats up in
420 :     * limit.sml
421 :     *)
422 :     fun updtHeapPtr(hp) =
423 :     let fun advBy hp = emit(M.MV(pty, allocptrR,
424 :     M.ADD(addrTy, C.allocptr, M.LI hp)))
425 :     in if hp = 0 then ()
426 :     else if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then advBy(hp+4)
427 :     else advBy(hp)
428 :     end
429 : monnier 247
430 : monnier 429 fun testLimit hp =
431 :     let fun assignCC(M.CC cc, v) = emit(M.CCMV(cc, v))
432 :     | assignCC _ = error "testLimit.assign"
433 :     in updtHeapPtr(hp);
434 :     case C.exhausted
435 :     of NONE => ()
436 :     | SOME cc => assignCC(cc, gcTest)
437 :     (*esac*)
438 :     end
439 : monnier 247
440 : monnier 429 (* Int 31 tag optimization *)
441 :     val one = M.LI 1
442 :     val two = M.LI 2
443 : monnier 247
444 : monnier 429 fun addTag e = M.ADD(ity, e, one)
445 :     fun stripTag e = M.SUB(ity, e, one)
446 :     fun orTag e = M.ORB(ity, e, one)
447 :     fun tag(signed, e) = (* true if signed *)
448 :     let fun double r = if signed then M.ADDT(ity,r,r) else M.ADD(ity, r,r)
449 :     in case e
450 :     of M.REG _ => addTag(double e)
451 : monnier 498 | _ => let val tmp = newReg PTR
452 : monnier 429 in M.SEQ(M.MV(ity, tmp, e),
453 :     addTag(double (M.REG(ity,tmp))))
454 :     end
455 :     end
456 :     val mlZero = tag(false, M.LI 0)
457 :     fun untag(_, CPS.INT i) = M.LI i
458 :     | untag(true, v) = M.SRA(ity, regbind v, one)
459 :     | untag(false, v) = M.SRL(ity, regbind v, one)
460 : monnier 247
461 : monnier 429 fun int31add(addOp, [CPS.INT k, w]) = addOp(ity, M.LI(k+k), regbind w)
462 :     | int31add(addOp, [w, v as CPS.INT _]) = int31add(addOp, [v,w])
463 :     | int31add(addOp, [v,w]) = addOp(ity,regbind v,stripTag(regbind w))
464 : monnier 247
465 : monnier 429 fun int31sub(subOp, [CPS.INT k,w]) = subOp(ity, M.LI(k+k+2),regbind w)
466 :     | int31sub(subOp, [v, CPS.INT k]) = subOp(ity, regbind v, M.LI(k+k))
467 :     | int31sub(subOp, [v,w]) = addTag(subOp(ity, regbind v, regbind w))
468 : monnier 247
469 : monnier 429 fun int31xor([CPS.INT k, w]) = M.XORB(ity, M.LI(k+k), regbind w)
470 :     | int31xor([w,v as CPS.INT _]) = int31xor [v,w]
471 :     | int31xor([v,w]) = addTag (M.XORB(ity, regbind v, regbind w))
472 : monnier 247
473 : monnier 429 fun int31mul(signed, args) =
474 :     let val mul = if signed then M.MULT else M.MULU
475 :     fun f [CPS.INT k, CPS.INT j] = addTag(mul(ity,M.LI(k+k),M.LI(j)))
476 :     | f [CPS.INT k, w] = addTag(mul(ity,untag(signed,w),M.LI(k+k)))
477 :     | f [v, w as CPS.INT _] = f ([w, v])
478 :     | f [v, w] = addTag(mul(ity, stripTag(regbind v),
479 :     untag(signed,w)))
480 :     in f args
481 :     end
482 : monnier 247
483 : monnier 429 fun int31div(signed, args) =
484 :     let val divOp = if signed then M.DIVT else M.DIVU
485 :     fun f [CPS.INT k, CPS.INT j] = divOp(ity,M.LI k, M.LI j)
486 :     | f [CPS.INT k, w] = divOp(ity,M.LI k, untag(signed, w))
487 :     | f [v, CPS.INT k] = divOp(ity,untag(signed, v), M.LI(k))
488 :     | f [v, w] = divOp(ity,untag(signed, v), untag(signed, w))
489 :     in tag(signed, f args)
490 :     end
491 : monnier 247
492 : monnier 429 fun int31lshift [CPS.INT k, w] =
493 :     addTag (M.SLL(ity, M.LI(k+k), untag(false, w)))
494 :     | int31lshift [v, CPS.INT k] =
495 :     addTag(M.SLL(ity,stripTag(regbind v), M.LI(k)))
496 :     | int31lshift [v,w] =
497 :     addTag(M.SLL(ity,stripTag(regbind v), untag(false, w)))
498 : monnier 247
499 : monnier 429 fun int31rshift(rshiftOp, [v, CPS.INT k]) =
500 :     orTag(rshiftOp(ity, regbind v, M.LI(k)))
501 :     | int31rshift(rshiftOp, [v,w]) =
502 :     orTag(rshiftOp(ity, regbind v, untag(false, w)))
503 : monnier 247
504 : monnier 429 fun getObjDescriptor(v) =
505 :     M.LOAD(ity, M.SUB(pty, regbind v, M.LI(4)), getRegion(v, ~1))
506 : monnier 247
507 : monnier 429 fun getObjLength(v) =
508 :     M.SRL(ity, getObjDescriptor(v), M.LI(D.tagWidth -1))
509 : monnier 247
510 : monnier 429 (*
511 :     * Note: because formals are moved into fresh temporaries,
512 :     * (formals intersection actuals) is empty.
513 :     *)
514 :     fun callSetup(formals, actuals) =
515 :     let fun gather([], [], cpRd, cpRs, fcopies, moves) =
516 :     (case (cpRd,cpRs)
517 :     of ([],[]) => ()
518 :     | _ => emit(M.COPY(ity, cpRd, cpRs));
519 :     case fcopies
520 :     of [] => ()
521 :     | _ => emit(M.FCOPY(fty, map #1 fcopies, map #2 fcopies));
522 :     app emit moves
523 :     )
524 :     | gather(M.GPR(M.REG(ty,rd))::fmls,act::acts,cpRd,cpRs,f,m) =
525 :     (case regbind act
526 : monnier 475 of M.REG(_,rs) => gather(fmls,acts,rd::cpRd,rs::cpRs,f,m)
527 : monnier 429 | e => gather(fmls, acts, cpRd, cpRs, f,
528 : monnier 475 M.MV(ty, rd, e)::m)
529 : monnier 429 (*esac*))
530 :     | gather(M.GPR(M.LOAD(ty,ea,r))::fmls,act::acts,cpRd,cpRs,f,m) =
531 :     gather(fmls,acts,cpRd,cpRs,f,
532 :     M.STORE(ty,ea,regbind act,r)::m)
533 :     | gather(M.FPR(M.FREG(ty,fd))::fmls,act::acts,cpRd,cpRs,f,m) =
534 :     (case fregbind act
535 :     of M.FREG(_,fs) =>
536 : monnier 475 gather(fmls,acts,cpRd,cpRs,(fd,fs)::f,m)
537 : monnier 429 | e =>
538 : monnier 475 gather(fmls,acts,cpRd,cpRs,f,M.FMV(ty, fd, e)::m)
539 : monnier 429 (*esac*))
540 :     | gather _ = error "callSetup.gather"
541 :     in gather(formals, actuals, [], [], [], [])
542 :     end
543 : monnier 247
544 : monnier 429 (* scale-and-add *)
545 :     fun scale1(a, CPS.INT 0) = a
546 :     | scale1(a, CPS.INT k) = M.ADD(ity, a, M.LI(k))
547 :     | scale1(a, i) = M.ADD(ity, a, untag(true, i))
548 : monnier 247
549 : monnier 429 fun scale4(a, CPS.INT 0) = a
550 :     | scale4(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*4))
551 :     | scale4(a, i) = M.ADD(ity, a, M.SLL(ity, untag(true,i), two))
552 :    
553 : monnier 247
554 : monnier 429 fun scale8(a, CPS.INT 0) = a
555 :     | scale8(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*8))
556 :     | scale8(a, i) = M.ADD(ity, a, M.SLL(ity, stripTag(regbind i),
557 :     M.LI(2)))
558 :    
559 :     (* add to storelist, the address where a boxed update has occured *)
560 :     fun recordStore(tmp, hp) =
561 :     (emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp)),
562 :     tmp,R.storelist));
563 :     emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
564 :     C.storeptr,R.storelist));
565 :     emit(assign(C.storeptr, M.ADD(addrTy, C.allocptr, M.LI(hp)))))
566 :    
567 :     fun unsignedCmp oper =
568 :     case oper
569 :     of P.> => M.GTU
570 :     | P.>= => M.GEU
571 :     | P.< => M.LTU
572 :     | P.<= => M.LEU
573 :     | P.eql => M.EQ
574 :     | P.neq => M.NE
575 :    
576 :     fun signedCmp oper =
577 :     case oper
578 :     of P.> => M.GT
579 :     | P.>= => M.GE
580 :     | P.< => M.LT
581 :     | P.<= => M.LE
582 :     | P.neq => M.NE
583 :     | P.eql => M.EQ
584 :    
585 :     fun branchToLabel(lab) = M.JMP(M.LABEL(LE.LABEL(lab)), [lab])
586 :    
587 :     local
588 :     open CPS
589 :     in
590 :    
591 :     val offp0 = CPS.OFFp 0
592 : monnier 498
593 : monnier 429 (*
594 : monnier 498 * x <- e where e is an integer expression
595 : monnier 429 *)
596 : monnier 498 fun alloc(gc, x, e, rest, hp) =
597 :     let val r = newReg gc
598 : monnier 429 in addRegBinding(x, r);
599 :     emit(M.MV(ity, r, e));
600 :     gen(rest, hp)
601 : monnier 247 end
602 : monnier 498
603 :     and int31alloc(x, e, rest, hp) = alloc(I31, x, e, rest, hp)
604 :     and int32alloc(x, e, rest, hp) = alloc(I32, x, e, rest, hp)
605 :     and palloc(x, e, rest, hp) = alloc(PTR, x, e, rest, hp)
606 : monnier 247
607 : monnier 429 (*
608 :     * x <- e where e contains an floating-point value
609 :     *)
610 :     and falloc(x, e, rest, hp) =
611 :     (case treeify x
612 :     of CpsTreeify.DEAD => gen(rest, hp)
613 :     | CpsTreeify.TREEIFY => (addFregBinding(x,e); gen(rest, hp))
614 :     | CpsTreeify.COMPUTE =>
615 : monnier 498 let val f = newFreg REAL64
616 : monnier 429 in addFregBinding(x, M.FREG(fty, f));
617 :     emit(M.FMV(fty, f, e));
618 :     gen(rest, hp)
619 :     end
620 :     (*esac*))
621 :    
622 : monnier 498 and nop(x, v, e, hp) = int31alloc(x, regbind v, e, hp)
623 : monnier 429
624 : monnier 498 and copy(gc, x, v, rest, hp) =
625 :     let val dst = newReg gc
626 : monnier 429 in addRegBinding(x, dst);
627 :     case regbind v
628 :     of M.REG(_,src) => emit(M.COPY(ity, [dst], [src]))
629 :     | e => emit(M.MV(ity, dst, e))
630 :     (*esac*);
631 :     gen(rest, hp)
632 :     end
633 : monnier 498
634 :     and copyM(31, x, v, rest, hp) = copy(I31, x, v, rest, hp)
635 :     | copyM(_, x, v, rest, hp) = copy(I32, x, v, rest, hp)
636 :    
637 : monnier 429 and branch (cmp, [v,w], d, e, hp) =
638 :     let val trueLab = Label.newLabel""
639 :     in (* is single assignment great or what! *)
640 :     emit(M.BCC(cmp, M.CMP(32, cmp, regbind v, regbind w), trueLab));
641 :     gen(e, hp);
642 :     genlab(trueLab, d, hp)
643 :     end
644 :    
645 : monnier 498 and arith(gc, oper, v, w, x, e, hp) =
646 :     alloc(gc, x, oper(ity, regbind v, regbind w), e, hp)
647 :    
648 :     and arith31(oper, v, w, x, e, hp) =
649 :     arith(I31, oper, v, w, x, e, hp)
650 :    
651 :     and arith32(oper, v, w, x, e, hp) =
652 :     arith(I32, oper, v, w, x, e, hp)
653 : monnier 429
654 : monnier 498 and logical(gc, oper, v, w, x, e, hp) =
655 :     alloc(gc, x, oper(ity, regbind v, untag(false, w)), e, hp)
656 :    
657 :     and logical31(oper, v, w, x, e, hp) =
658 :     logical(I31, oper, v, w, x, e, hp)
659 :    
660 :     and logical32(oper, v, w, x, e, hp) =
661 :     logical(I32, oper, v, w, x, e, hp)
662 : monnier 429
663 :     and genlab(lab, e, hp) = (defineLabel lab; gen(e, hp))
664 : monnier 411
665 : monnier 429
666 :     (*
667 :     * Generate code
668 :     *)
669 : monnier 247
670 : monnier 429 (** RECORD **)
671 :     and gen(RECORD((CPS.RK_SPILL | CPS.RK_CONT), vl, w, e), hp) =
672 :     gen(RECORD(CPS.RK_RECORD, vl, w, e), hp)
673 :     | gen(RECORD(CPS.RK_FCONT, vl, w, e), hp) =
674 :     gen(RECORD(CPS.RK_FBLOCK, vl, w, e), hp)
675 :     | gen(RECORD(CPS.RK_FBLOCK, vl, w, e), hp) =
676 :     let val len = List.length vl
677 :     val desc = dtoi(D.makeDesc(len+len, D.tag_raw64))
678 :     val vl' =
679 :     map (fn (x, p as SELp _) => (M.GPR(regbind x), p)
680 :     | (x, p as OFFp 0) => (M.FPR(fregbind x), p)
681 :     | _ => error "gen:RECORD:RK_FBLOCK")
682 :     vl
683 : monnier 498 val ptr = newReg PTR
684 : monnier 429 (* At initialization the allocation pointer is aligned on
685 :     * an odd-word boundary, and the heap offset set to zero. If an
686 :     * odd number of words have been allocated then the heap pointer
687 :     * is misaligned for this record creation.
688 :     *)
689 :     val hp =
690 :     if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then hp+4 else hp
691 :     in addRegBinding(w, ptr);
692 :     MkRecord.frecord
693 :     {desc=M.LI desc, fields=vl', ans=ptr, mem=memDisambig w,
694 :     hp=hp, emit=emit};
695 :     gen(e, hp + 4 + len*8)
696 :     end
697 :     | gen(RECORD(CPS.RK_VECTOR, vl, w, e), hp) =
698 :     let val len = length vl
699 :     val hdrDesc = dtoi(D.desc_polyvec)
700 :     val dataDesc = dtoi(D.makeDesc(len, D.tag_vec_data))
701 :     val contents = map (fn (v,p) => (regbind v, p)) vl
702 : monnier 498 val dataPtr = newReg PTR
703 :     val hdrPtr = newReg PTR
704 : monnier 429 val hdrM = memDisambig w
705 :     val dataM = hdrM (* Allen *)
706 :     in addRegBinding(w, hdrPtr);
707 :     MkRecord.record {
708 :     desc = M.LI(dataDesc), fields = contents,
709 :     ans = dataPtr,
710 :     mem = dataM, hp = hp, emit=emit
711 :     };
712 :     MkRecord.record {
713 :     desc = M.LI hdrDesc,
714 :     fields = [
715 :     (M.REG(ity,dataPtr), offp0),
716 :     (tag(false, M.LI len), offp0)
717 :     ],
718 :     ans = hdrPtr,
719 :     mem = hdrM, hp = hp + 4 + len*4, emit=emit
720 :     };
721 :     gen (e, hp + 16 + len*4)
722 :     end
723 :     | gen(RECORD(kind, vl, w, e), hp) =
724 :     let val len = length vl
725 :     val desc = case (kind, len)
726 :     of (CPS.RK_I32BLOCK, l) => dtoi(D.makeDesc (l, D.tag_raw32))
727 :     | (_, l) => dtoi(D.makeDesc (l, D.tag_record))
728 :     (*esac*)
729 :     val contents = map (fn (v,p) => (regbind v, p)) vl
730 : monnier 498 val ptr = newReg PTR
731 : monnier 429 in addRegBinding(w, ptr);
732 :     MkRecord.record
733 :     {desc=M.LI desc, fields=contents, ans=ptr,
734 :     mem=memDisambig w, hp=hp, emit=emit};
735 :     gen(e, hp + 4 + len*4 )
736 :     end
737 :    
738 :     (*** SELECT ***)
739 :     | gen(SELECT(i, INT k, x, t, e), hp) =
740 :     let val unboxedfloat = MS.unboxedFloats
741 :     fun isFlt t =
742 :     if unboxedfloat then (case t of FLTt => true | _ => false)
743 :     else false
744 :     fun fallocSp(x,e,hp) =
745 : monnier 498 (addFregBinding(x,M.FREG(fty,newFreg REAL64));gen(e, hp))
746 : monnier 429 (* warning: the following generated code should never be
747 :     executed; its semantics is completely screwed up !
748 :     *)
749 :     in if isFlt t then fallocSp(x, e, hp)
750 : monnier 498 else int32alloc(x, M.LI k, e, hp)(* BOGUS *)
751 : monnier 429 end
752 :     | gen(SELECT(i, v, x, FLTt, e), hp) =
753 :     falloc(x, M.FLOAD(fty, scale8(regbind v, INT i), R.real), e, hp)
754 :     | gen(SELECT(i, v, x, _, e), hp) =
755 :     let val select =
756 :     M.LOAD(ity,scale4(regbind v,INT i),getRegion(v,i))
757 :     in
758 :     (* This business is only done with SELECTs because it is
759 :     * where I think it has the most benefit. [Lal]
760 :     *)
761 :     case treeify x
762 :     of CpsTreeify.COMPUTE => palloc(x, select, e, hp)
763 :     | CpsTreeify.TREEIFY => (addExpBinding(x, select); gen(e,hp))
764 :     | CpsTreeify.DEAD => gen(e,hp)
765 :     end
766 : monnier 247
767 : monnier 429 (*** OFFSET ***)
768 :     | gen(OFFSET(i, v, x, e), hp) =
769 :     palloc(x, scale4(regbind v, INT i), e, hp)
770 : monnier 247
771 : monnier 429 (*** APP ***)
772 :     | gen(APP(INT k, args), hp) = updtHeapPtr(hp)
773 :     | gen(APP(func as VAR f, args), hp) =
774 :     let val formals as (M.GPR dest::_) =
775 :     ArgP.standard(typmap f, map grabty args)
776 :     in callSetup(formals, args);
777 :     testLimit hp;
778 :     emit(M.JMP(dest, []));
779 :     exitBlock(formals @ dedicated)
780 :     end
781 :     | gen(APP(func as LABEL f, args), hp) =
782 :     (case lookupGenTbl f
783 :     of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
784 :     (updtHeapPtr(hp);
785 :     callSetup(formals, args);
786 :     emit(branchToLabel(functionLabel f)))
787 :     | Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
788 : monnier 498 let val formals = known tl
789 : monnier 429 val lab = functionLabel f
790 :     in r := Frag.GEN formals;
791 :     updtHeapPtr(hp);
792 :     callSetup(formals, args);
793 :     defineLabel lab;
794 :     alignAllocptr f;
795 :     initialRegBindingsEscaping(vl, formals, tl);
796 :     initTypBindings e;
797 :     gen(e, 0)
798 :     end
799 :     | Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
800 :     let val formals =
801 :     if MS.fixedArgPassing then ArgP.fixed tl
802 : monnier 498 else known tl
803 : monnier 429 val lab = functionLabel f
804 :     in r:=Frag.GEN formals;
805 :     callSetup(formals, args);
806 :     testLimit hp;
807 :     (*** CAN WE REMOVE THIS BRANCH???
808 :     emit(branchToLabel(lab));
809 :     ***)
810 :     defineLabel lab;
811 : monnier 498 (if !mlrisc andalso !gcsafety then
812 :     InvokeGC.optimizedKnwCheckLimit else
813 :     InvokeGC.knwCheckLimit)
814 :     stream
815 : monnier 429 {maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tl,
816 :     return=branchToLabel(lab)};
817 :     alignAllocptr f;
818 :     initialRegBindingsEscaping(vl, formals, tl);
819 :     initTypBindings e;
820 :     gen(e, 0)
821 :     end
822 :     | Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
823 :     (callSetup(formals, args);
824 :     testLimit hp;
825 :     emit(branchToLabel(functionLabel f)))
826 :     | Frag.STANDARD{fmlTyps, ...} =>
827 :     let val formals = ArgP.standard(typmap f, fmlTyps)
828 :     in callSetup(formals, args);
829 :     testLimit hp;
830 :     emit(branchToLabel(functionLabel f))
831 :     end
832 :     (*esac*))
833 : monnier 247
834 : monnier 429 (*** SWITCH ***)
835 :     | gen(SWITCH(INT _, _, _), hp) = error "SWITCH"
836 :     | gen(SWITCH(v, _, l), hp) =
837 :     let val lab = Label.newLabel""
838 :     val labs = map (fn _ => Label.newLabel"") l
839 : monnier 498 val tmpR = newReg I32 val tmp = M.REG(ity,tmpR)
840 : monnier 429 in emit(M.MV(ity, tmpR, laddr(lab, 0)));
841 :     emit(M.JMP(M.ADD(addrTy, tmp, M.LOAD(pty, scale4(tmp, v),
842 :     R.readonly)), labs));
843 :     pseudoOp(PseudoOp.JUMPTABLE{base=lab, targets=labs});
844 :     ListPair.app (fn (lab, e) => genlab(lab, e, hp)) (labs, l)
845 :     end
846 : monnier 247
847 : monnier 429 (*** PURE ***)
848 : monnier 498 | gen(PURE(P.pure_arith{oper=P.orb, kind}, [v,w], x, _, e), hp) =
849 :     alloc(kindToGC kind, x, M.ORB(ity, regbind v, regbind w), e, hp)
850 :     | gen(PURE(P.pure_arith{oper=P.andb, kind}, [v,w], x, _, e), hp) =
851 :     alloc(kindToGC kind, x, M.ANDB(ity, regbind v, regbind w), e, hp)
852 : monnier 429 | gen(PURE(P.pure_arith{oper, kind}, args as [v,w], x, ty, e), hp) =
853 :     (case kind
854 :     of P.INT 31 => (case oper
855 : monnier 498 of P.xorb => int31alloc(x, int31xor(args), e, hp)
856 :     | P.lshift => int31alloc(x, int31lshift args, e, hp)
857 :     | P.rshift => int31alloc(x, int31rshift(M.SRA,args),e,hp)
858 : monnier 429 | _ => error "gen:PURE INT 31"
859 :     (*esac*))
860 :     | P.INT 32 => (case oper
861 : monnier 498 of P.xorb => arith32(M.XORB, v, w, x, e, hp)
862 :     | P.lshift => logical32(M.SLL, v, w, x, e, hp)
863 :     | P.rshift => logical32(M.SRA, v, w, x, e, hp)
864 : monnier 429 | _ => error "gen:PURE INT 32"
865 :     (*esac*))
866 :     | P.UINT 31 => (case oper
867 : monnier 498 of P.+ => int31alloc(x, int31add(M.ADD, args), e, hp)
868 :     | P.- => int31alloc(x, int31sub(M.SUB, args), e, hp)
869 :     | P.* => int31alloc(x, int31mul(false, args), e, hp)
870 : monnier 429 | P./ => (* This is not really a pure
871 :     operation -- oh well *)
872 :     (updtHeapPtr hp;
873 : monnier 498 int31alloc(x, int31div(false, args), e, 0))
874 :     | P.xorb => int31alloc(x, int31xor(args), e, hp)
875 :     | P.lshift => int31alloc(x, int31lshift args, e, hp)
876 :     | P.rshift => int31alloc(x,int31rshift(M.SRA,args),e,hp)
877 :     | P.rshiftl => int31alloc(x,int31rshift(M.SRL,args),e,hp)
878 : monnier 429 | _ => error "gen:PURE UINT 31"
879 :     (*esac*))
880 :     | P.UINT 32 => (case oper
881 : monnier 498 of P.+ => arith32(M.ADD, v, w, x, e, hp)
882 :     | P.- => arith32(M.SUB, v, w, x, e, hp)
883 :     | P.* => arith32(M.MULU, v, w, x, e, hp)
884 : monnier 429 | P./ => (updtHeapPtr hp;
885 : monnier 498 arith32(M.DIVU, v, w, x, e, 0))
886 :     | P.xorb => arith32(M.XORB, v, w, x, e, hp)
887 :     | P.lshift => logical32(M.SLL, v, w, x, e, hp)
888 :     | P.rshift => logical32(M.SRA, v, w, x, e, hp)
889 :     | P.rshiftl=> logical32(M.SRL, v, w, x, e, hp)
890 : monnier 429 | _ => error "gen:PURE UINT 32"
891 :     (*esac*))
892 :     (*esac*))
893 :     | gen(PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) =
894 :     (case kind
895 : monnier 498 of P.UINT 32 => int32alloc(x,M.XORB(ity, regbind v,
896 : monnier 429 M.LI32 0wxFFFFFFFF), e, hp)
897 : monnier 498 | P.INT 32 => int32alloc(x,M.XORB(ity, regbind v,
898 : monnier 429 M.LI32 0wxFFFFFFFF), e, hp)
899 : monnier 498 | P.UINT 31 => int31alloc(x,M.SUB(ity, M.LI 0, regbind v), e, hp)
900 :     | P.INT 31 => int31alloc(x,M.SUB(ity, M.LI 0, regbind v), e, hp)
901 : monnier 429 (*esac*))
902 :     | gen(PURE(P.copy ft, [v], x, _, e), hp) =
903 :     (case ft
904 : monnier 498 of (31, 32) => int32alloc(x, M.SRL(ity, regbind v, one), e, hp)
905 :     | (8, 31) => copy(I31, x, v, e, hp)
906 :     | (8, 32) => int32alloc(x, M.SRL(ity, regbind v, one), e, hp)
907 :     | (n,m) => if n = m then copyM(m, x, v, e, hp)
908 : monnier 429 else error "gen:PURE:copy"
909 :     (*esac*))
910 :     | gen(PURE(P.extend ft, [v], x, _ ,e), hp) =
911 :     (case ft
912 :     of (8,31) =>
913 : monnier 498 int31alloc(x,
914 :     M.SRA(ity, M.SLL(ity, regbind v,M.LI 23), M.LI 23),
915 : monnier 429 e, hp)
916 :     | (8,32) =>
917 : monnier 498 int32alloc(x,
918 :     M.SRA(ity, M.SLL(ity, regbind v, M.LI 23), M.LI 24),
919 : monnier 429 e, hp)
920 : monnier 498 | (31,32) => int32alloc(x, M.SRA(ity, regbind v, one), e, hp)
921 :     | (n, m) => if n = m then copyM(m, x, v, e, hp)
922 : monnier 429 else error "gen:PURE:extend"
923 :     (*esac*))
924 :     | gen(PURE(P.trunc ft, [v], x, _, e), hp) =
925 :     (case ft
926 :     of (32, 31) =>
927 : monnier 498 int31alloc(x,
928 :     M.ORB(ity, M.SLL(ity, regbind v, one), one), e, hp)
929 :     | (31, 8) => int32alloc(x, M.ANDB(ity, regbind v, M.LI 0x1ff), e, hp)
930 :     | (32, 8) => int32alloc(x, tag(false, M.ANDB(ity, regbind v,
931 :     M.LI 0xff)), e, hp)
932 :     | (n, m) => if n = m then copyM(m, x, v, e, hp)
933 : monnier 429 else error "gen:PURE:trunc"
934 :     (*esac*))
935 :     | gen(PURE(P.real{fromkind=P.INT 31, tokind}, [v], x, _, e), hp) =
936 :     (case tokind
937 :     of P.FLOAT 64 => (case v
938 : monnier 475 of INT n => falloc(x,M.CVTI2F(fty,M.SIGN_EXTEND,ity,M.LI n),e, hp)
939 :     | _ => falloc(x,M.CVTI2F(fty,M.SIGN_EXTEND,ity,untag(true, v)), e, hp)
940 : monnier 429 (*esac*))
941 :     | _ => error "gen:PURE:P.real"
942 :     (*esac*))
943 :     | gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) =
944 :     let val r = fregbind v
945 :     in case oper
946 :     of P.~ => falloc(x, M.FNEG(fty,r), e, hp)
947 :     | P.abs => falloc(x, M.FABS(fty,r), e, hp)
948 :     end
949 :     | gen(PURE(P.objlength, [v], x, _, e), hp) =
950 : monnier 498 int31alloc(x, orTag(getObjLength(v)), e, hp)
951 : monnier 429 | gen(PURE(P.length, [v], x, t, e), hp) =
952 :     (* array/vector length operation *)
953 :     gen(SELECT(1, v, x, t, e), hp)
954 :     | gen(PURE(P.subscriptv, [v, INT i], x, t, e), hp) =
955 :     let val region = getRegion(v, 0)
956 :     (* get data pointer *)
957 :     val a = M.LOAD(ity, regbind v, region)
958 :     val region' = region (* Allen *)
959 : monnier 498 in palloc(x, M.LOAD(ity, scale4(a, INT i), region'), e, hp)
960 : monnier 429 end
961 :     | gen(PURE(P.subscriptv, [v, w], x, _, e), hp) =
962 :     let (* get data pointer *)
963 :     val a = M.LOAD(ity, regbind v, R.readonly)
964 : monnier 498 in palloc(x, M.LOAD(ity, scale4(a, w), R.readonly), e, hp)
965 : monnier 429 end
966 :     | gen(PURE(P.pure_numsubscript{kind=P.INT 8}, [v,i], x, _, e), hp) =
967 :     let (* get data pointer *)
968 :     val a = M.LOAD(ity, regbind v, R.readonly)
969 : monnier 498 in int31alloc(x,
970 :     tag(false,M.LOAD(8,scale1(a, i), R.memory)), e, hp)
971 : monnier 429 end
972 :     | gen(PURE(P.gettag, [v], x, _, e), hp) =
973 : monnier 498 int31alloc(x, tag(false, M.ANDB(ity,
974 : monnier 429 getObjDescriptor(v), M.LI(D.powTagWidth-1))),
975 :     e, hp)
976 :     | gen(PURE(P.mkspecial, [i, v], x, _, e), hp) =
977 :     let val desc = case i
978 :     of INT n => M.LI(dtoi(D.makeDesc(n, D.tag_special)))
979 :     | _ => M.ORB(ity, M.SLL(ity, untag(true, i),M.LI D.tagWidth),
980 :     M.LI(dtoi D.desc_special))
981 : monnier 498 val ptr = newReg PTR
982 : monnier 429 in MkRecord.record{desc=desc, fields=[(regbind v, offp0)],
983 :     ans=ptr, mem=memDisambig x, hp=hp, emit=emit};
984 :     addRegBinding(x, ptr);
985 :     gen(e, hp+8)
986 :     end
987 :     | gen(PURE(P.makeref, [v], x, _, e), hp) =
988 : monnier 498 let val ptr = newReg PTR
989 : monnier 429 val tag = M.LI(dtoi D.desc_ref)
990 :     val mem = memDisambig x
991 :     in emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI hp),tag,mem));
992 :     emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
993 :     regbind v, mem));
994 :     emit(M.MV(pty, ptr, M.ADD(addrTy, C.allocptr, M.LI(hp+4))));
995 :     addRegBinding(x, ptr);
996 :     gen(e, hp+8)
997 :     end
998 :     | gen(PURE(P.fwrap,[u],w,_,e), hp) =
999 :     gen(RECORD(CPS.RK_FBLOCK,[(u, offp0)],w,e), hp)
1000 :     | gen(PURE(P.funwrap,[u],w,_,e), hp) = gen(SELECT(0,u,w,FLTt,e), hp)
1001 :     | gen(PURE(P.iwrap,[u],w,_,e), _) = error "iwrap not implemented"
1002 :     | gen(PURE(P.iunwrap,[u],w,_,e), _) = error "iunwrap not implemented"
1003 :     | gen(PURE(P.i32wrap,[u],w,_,e), hp) =
1004 :     gen(RECORD(CPS.RK_I32BLOCK,[(u, offp0)],w,e), hp)
1005 :     | gen(PURE(P.i32unwrap,[u],w,_,e), hp) =
1006 :     gen(SELECT(0,u,w,INT32t,e), hp)
1007 : monnier 498
1008 :     | gen(PURE(P.wrap,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1009 :     | gen(PURE(P.unwrap,[u],w,_,e), hp) = copy(I32, w, u, e, hp)
1010 :    
1011 :     (* Note: the gc type is unsafe! *)
1012 :     | gen(PURE(P.cast,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1013 :    
1014 : monnier 429 | gen(PURE(P.getcon,[u],w,t,e), hp) = gen(SELECT(0,u,w,t,e), hp)
1015 :     | gen(PURE(P.getexn,[u],w,t,e), hp) = gen(SELECT(0,u,w,t,e), hp)
1016 :     | gen(PURE(P.getseqdata, [u], x, t, e), hp) =
1017 :     gen(SELECT(0,u,x,t,e), hp)
1018 :     | gen(PURE(P.recsubscript, [v, INT w], x, t, e), hp) =
1019 :     gen(SELECT(w, v, x, t, e), hp)
1020 :     | gen(PURE(P.recsubscript, [v, w], x, _, e), hp) =
1021 : monnier 498 int31alloc(x,
1022 :     M.LOAD(ity, scale4(regbind v, w), R.readonly), e, hp)
1023 : monnier 429 | gen(PURE(P.raw64subscript, [v, INT i], x, _, e), hp) =
1024 :     gen(SELECT(i, v, x, FLTt, e), hp)
1025 :     | gen(PURE(P.raw64subscript, [v, i], x, _, e), hp) =
1026 :     falloc(x, M.FLOAD(fty,scale8(regbind v, i),R.readonly), e, hp)
1027 :     | gen(PURE(P.newarray0, [_], x, t, e), hp) =
1028 :     let val hdrDesc = dtoi(D.desc_polyarr)
1029 :     val dataDesc = dtoi D.desc_ref
1030 : monnier 498 val dataPtr = newReg PTR
1031 :     val hdrPtr = newReg PTR
1032 : monnier 429 val hdrM = memDisambig x
1033 :     val (tagM, valM) = (hdrM, hdrM) (* Allen *)
1034 :     in addRegBinding(x, hdrPtr);
1035 :     (* gen code to allocate "ref()" for array data *)
1036 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI hp),
1037 :     M.LI dataDesc, tagM));
1038 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI(hp+4)),
1039 :     mlZero, valM));
1040 :     emit(M.MV(pty, dataPtr, M.ADD(addrTy,C.allocptr,M.LI(hp+4))));
1041 :     (* gen code to allocate array header *)
1042 :     MkRecord.record {
1043 :     desc = M.LI hdrDesc,
1044 :     fields = [(M.REG(ity,dataPtr), offp0), (mlZero, offp0)],
1045 :     ans = hdrPtr,
1046 :     mem = hdrM, hp = hp + 8, emit=emit
1047 :     };
1048 :     gen (e, hp + 20)
1049 :     end
1050 :     (*** ARITH ***)
1051 :     | gen(ARITH(P.arith{kind=P.INT 31, oper}, args, x, _, e), hp) =
1052 :     (updtHeapPtr hp;
1053 :     case oper
1054 : monnier 498 of P.+ => int31alloc(x, int31add(M.ADDT, args), e, 0)
1055 :     | P.- => int31alloc(x, int31sub(M.SUBT, args), e, 0)
1056 :     | P.* => int31alloc(x, int31mul(true, args), e, 0)
1057 :     | P./ => int31alloc(x, int31div(true, args), e, 0)
1058 :     | P.~ => int31alloc(x,
1059 :     M.SUBT(ity, M.LI 2, regbind(hd args)), e, 0)
1060 : monnier 429 | _ => error "gen:ARITH INT 31"
1061 :     (*esac*))
1062 :     | gen(ARITH(P.arith{kind=P.INT 32, oper}, [v,w], x, _, e), hp) =
1063 :     (updtHeapPtr hp;
1064 :     case oper
1065 : monnier 498 of P.+ => arith32(M.ADDT, v, w, x, e, 0)
1066 :     | P.- => arith32(M.SUBT, v, w, x, e, 0)
1067 :     | P.* => arith32(M.MULT, v, w, x, e, 0)
1068 :     | P./ => arith32(M.DIVT, v, w, x, e, 0)
1069 : monnier 429 | _ => error "P.arith{kind=INT 32, oper}, [v,w], ..."
1070 :     (*esac*))
1071 :     | gen(ARITH(P.arith{kind=P.INT 32, oper=P.~ }, [v], x, _, e), hp) =
1072 :     (updtHeapPtr hp;
1073 : monnier 498 int32alloc(x, M.SUBT(ity, M.LI 0, regbind v), e, 0))
1074 : monnier 429
1075 :     (* Note: for testu operations we use a somewhat arcane method
1076 :     * to generate traps on overflow conditions. A better approach
1077 :     * would be to generate a trap-if-negative instruction available
1078 :     * on a variety of machines, e.g. mips and sparc (maybe others).
1079 :     *)
1080 :     | gen(ARITH(P.testu(32, 32), [v], x, _, e), hp) =
1081 : monnier 498 let val xreg = newReg I32
1082 : monnier 429 val vreg = regbind v
1083 :     in updtHeapPtr hp;
1084 :     emit(M.MV(ity, xreg, M.ADDT(ity, vreg,
1085 :     regbind(INT32 0wx80000000))));
1086 : monnier 498 int32alloc(x, vreg, e, 0)
1087 : monnier 429 end
1088 :     | gen(ARITH(P.testu(31, 31), [v], x, _, e), hp) =
1089 : monnier 498 let val xreg = newReg I31
1090 : monnier 429 val vreg = regbind v
1091 :     in updtHeapPtr hp;
1092 :     emit(M.MV(ity,xreg,M.ADDT(ity, vreg,
1093 :     regbind(INT32 0wx80000000))));
1094 : monnier 498 int31alloc(x, vreg, e, 0)
1095 : monnier 429 end
1096 :     | gen(ARITH(P.testu(32,31), [v], x, _, e), hp) =
1097 :     let val vreg = regbind v
1098 : monnier 498 val tmp = newReg I32
1099 : monnier 429 val tmpR = M.REG(ity,tmp)
1100 :     val lab = Label.newLabel ""
1101 :     in emit(M.MV(ity, tmp, regbind(INT32 0wx3fffffff)));
1102 :     emit(M.BCC(M.LEU, M.CMP(32, M.LEU, vreg, tmpR), lab));
1103 :     updtHeapPtr hp;
1104 :     emit(M.MV(ity, tmp, M.SLL(ity, tmpR, one)));
1105 :     emit(M.MV(ity, tmp, M.ADDT(ity, tmpR, tmpR)));
1106 :     defineLabel lab;
1107 : monnier 498 int31alloc(x, tag(false, vreg), e, hp)
1108 : monnier 429 end
1109 :     | gen(ARITH(P.test(32,31), [v], x, _, e), hp) =
1110 : monnier 498 (updtHeapPtr hp; int31alloc(x, tag(true, regbind v), e, 0))
1111 : monnier 429 | gen(ARITH(P.test(n, m), [v], x, _, e), hp) =
1112 : monnier 498 if n = m then copyM(m, x, v, e, hp) else error "gen:ARITH:test"
1113 : monnier 429 | gen(ARITH(P.arith{oper, kind=P.FLOAT 64}, vl, x, _, e), hp) =
1114 :     let fun binary(oper, [v,w]) =
1115 :     falloc(x, oper(fty, fregbind v, fregbind w), e, hp)
1116 :     in case oper
1117 :     of P.+ => binary(M.FADD, vl)
1118 :     | P.* => binary(M.FMUL, vl)
1119 :     | P.- => binary(M.FSUB, vl)
1120 :     | P./ => binary(M.FDIV, vl)
1121 :     end
1122 :     (*** LOOKER ***)
1123 :     | gen(LOOKER(P.!, [v], x, _, e), hp) =
1124 :     palloc (x, M.LOAD(ity, regbind v, R.memory), e, hp)
1125 :     | gen(LOOKER(P.subscript, [v,w], x, _, e), hp) =
1126 :     let (* get data pointer *)
1127 :     val a = M.LOAD(ity, regbind v, R.readonly)
1128 :     in palloc (x, M.LOAD(ity, scale4(a, w), R.memory), e, hp)
1129 :     end
1130 :     | gen(LOOKER(P.numsubscript{kind=P.INT 8},[v,i],x,_,e), hp) =
1131 :     let (* get data pointer *)
1132 :     val a = M.LOAD(ity, regbind v, R.readonly)
1133 : monnier 498 in int31alloc(x,
1134 :     tag(false, M.LOAD(8,scale1(a, i),R.memory)), e, hp)
1135 : monnier 429 end
1136 :     | gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [v,i], x, _, e), hp)=
1137 :     let (* get data pointer *)
1138 :     val a = M.LOAD(ity,regbind v, R.readonly)
1139 :     in falloc(x, M.FLOAD(fty,scale8(a, i),R.memory), e, hp)
1140 :     end
1141 :     | gen(LOOKER(P.gethdlr,[],x,_,e), hp) = palloc(x, C.exnptr, e, hp)
1142 :     | gen(LOOKER(P.getvar, [], x, _, e), hp)= palloc(x, C.varptr, e, hp)
1143 :     | gen(LOOKER(P.deflvar, [], x, _, e), hp)= palloc(x, M.LI 0, e, hp)
1144 :     | gen(LOOKER(P.getspecial, [v], x, _, e), hp) =
1145 :     palloc(x,
1146 :     orTag(M.SRA(ity, getObjDescriptor(v),
1147 :     M.LI (D.tagWidth-1))),
1148 :     e, hp)
1149 :     | gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
1150 :     (print "getpseudo not implemented\n"; nop(x, i, e, hp))
1151 :     (*** SETTER ***)
1152 :     | gen(SETTER(P.assign, [a as VAR arr, v], e), hp) =
1153 :     let val ea = regbind a
1154 :     in recordStore(ea, hp);
1155 :     emit(M.STORE(ity, ea, regbind v, memDisambig arr));
1156 :     gen(e, hp+8)
1157 :     end
1158 :     | gen(SETTER(P.unboxedassign, [a, v], e), hp) =
1159 :     (emit(M.STORE(ity, regbind a, regbind v, R.memory));
1160 :     gen(e, hp))
1161 :     | gen(SETTER(P.update, [v,i,w], e), hp) =
1162 :     let (* get data pointer *)
1163 :     val a = M.LOAD(ity, regbind v, R.readonly)
1164 :     val tmpR = Cells.newReg() (* derived pointer! *)
1165 :     val tmp = M.REG(ity, tmpR)
1166 :     val ea = scale4(a, i) (* address of updated cell *)
1167 :     in emit(M.MV(ity, tmpR, ea));
1168 :     recordStore(tmp, hp);
1169 :     emit(M.STORE(ity, tmp, regbind w, R.memory));
1170 :     gen(e, hp+8)
1171 :     end
1172 :     | gen(SETTER(P.boxedupdate, args, e), hp) =
1173 :     gen(SETTER(P.update, args, e), hp)
1174 :     | gen(SETTER(P.unboxedupdate, [v, i, w], e), hp) =
1175 :     let (* get data pointer *)
1176 :     val a = M.LOAD(ity, regbind v, R.readonly)
1177 :     in emit(M.STORE(ity, scale4(a, i), regbind w, R.memory));
1178 :     gen(e, hp)
1179 :     end
1180 :     | gen(SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) =
1181 :     let (* get data pointer *)
1182 :     val a = M.LOAD(ity, regbind s, R.readonly)
1183 :     val ea = scale1(a, i)
1184 :     in emit(M.STORE(8,ea, untag(false, v), R.memory));
1185 :     gen(e, hp)
1186 :     end
1187 :     | gen(SETTER(P.numupdate{kind=P.FLOAT 64},[v,i,w],e), hp) =
1188 :     let (* get data pointer *)
1189 :     val a = M.LOAD(ity, regbind v, R.readonly)
1190 :     in emit(M.FSTORE(fty,scale8(a, i), fregbind w, R.memory));
1191 :     gen(e, hp)
1192 :     end
1193 :     | gen(SETTER(P.setspecial, [v, i], e), hp) =
1194 :     let val ea = M.SUB(ity, regbind v, M.LI 4)
1195 :     val i' =
1196 :     case i
1197 :     of INT k => M.LI(dtoi(D.makeDesc(k, D.tag_special)))
1198 :     | _ => M.ORB(ity, M.SLL(ity, untag(true, i),
1199 :     M.LI D.tagWidth),
1200 :     M.LI(dtoi D.desc_special))
1201 :     in emit(M.STORE(ity, ea, i',R.memory));
1202 :     gen(e, hp)
1203 :     end
1204 :     | gen(SETTER(P.sethdlr,[x],e), hp) =
1205 :     (emit(assign(C.exnptr, regbind x)); gen(e, hp))
1206 :     | gen(SETTER(P.setvar,[x],e), hp) =
1207 :     (emit(assign(C.varptr, regbind x)); gen(e, hp))
1208 :     | gen(SETTER(P.uselvar,[x],e), hp) = gen(e, hp)
1209 :     | gen(SETTER(P.acclink,_,e), hp) = gen(e, hp)
1210 :     | gen(SETTER(P.setmark,_,e), hp) = gen(e, hp)
1211 :     | gen(SETTER(P.free,[x],e), hp) = gen(e, hp)
1212 :     | gen(SETTER(P.setpseudo,_,e), hp) =
1213 :     (print "setpseudo not implemented\n"; gen(e, hp))
1214 :    
1215 :     (*** BRANCH ***)
1216 :     | gen(BRANCH(P.cmp{oper,kind=P.INT 31},[INT v, INT k],_,e,d), hp) =
1217 :     let val itow = Word.fromInt
1218 :     in if (case oper
1219 :     of P.> => v>k
1220 :     | P.>= => v>=k
1221 :     | P.< => v<k
1222 :     | P.<= => v<=k
1223 :     | P.eql => v=k
1224 :     | P.neq => v<>k
1225 :     (*esac*))
1226 :     then gen(e, hp)
1227 :     else gen(d, hp)
1228 :     end
1229 :     | gen(BRANCH(P.cmp{oper, kind=P.INT 31}, vw, _, e, d), hp) =
1230 :     branch(signedCmp oper, vw, e, d, hp)
1231 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 31},[INT v', INT k'],_,e,d),hp)=
1232 :     let open Word
1233 :     val v = fromInt v'
1234 :     val k = fromInt k'
1235 :     in if (case oper
1236 :     of P.> => v>k
1237 :     | P.>= => v>=k
1238 :     | P.< => v<k
1239 :     | P.<= => v<=k
1240 :     | P.eql => v=k
1241 :     | P.neq => v<>k
1242 :     (*esac*))
1243 :     then gen(e, hp)
1244 :     else gen(d, hp)
1245 :     end
1246 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 31}, vw, _, e, d), hp) =
1247 :     branch(unsignedCmp oper, vw, e, d, hp)
1248 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 32},[INT32 v,INT32 k],_,e,d),
1249 :     hp) =
1250 :     let open Word32
1251 :     in if (case oper
1252 :     of P.> => v>k
1253 :     | P.>= => v>=k
1254 :     | P.< => v<k
1255 :     | P.<= => v<=k
1256 :     | P.eql => v=k
1257 :     | P.neq => v<>k
1258 :     (*esac*))
1259 :     then gen(e, hp)
1260 :     else gen(d, hp)
1261 :     end
1262 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 32}, vw, _, e, d), hp) =
1263 :     branch(unsignedCmp oper, vw, e, d, hp)
1264 :    
1265 :     | gen(BRANCH(P.cmp{oper, kind=P.INT 32}, vw, _, e, d), hp) =
1266 :     branch(signedCmp oper, vw, e, d, hp)
1267 :     | gen(BRANCH(P.fcmp{oper,size=64}, [v,w], _, d, e), hp) =
1268 :     let val trueLab = Label.newLabel""
1269 :     val fcond =
1270 :     case oper
1271 :     of P.fEQ => M.==
1272 :     | P.fULG => M.?<>
1273 :     | P.fUN => M.?
1274 :     | P.fLEG => M.<=>
1275 :     | P.fGT => M.>
1276 :     | P.fGE => M.>=
1277 :     | P.fUGT => M.?>
1278 :     | P.fUGE => M.?>=
1279 :     | P.fLT => M.<
1280 :     | P.fLE => M.<=
1281 :     | P.fULT => M.?<
1282 :     | P.fULE => M.?<=
1283 :     | P.fLG => M.<>
1284 :     | P.fUE => M.?=
1285 :    
1286 :     val cmp = M.FCMP(64, fcond, fregbind v, fregbind w)
1287 :     in emit(M.FBCC(fcond, cmp, trueLab));
1288 :     gen(e, hp);
1289 :     genlab(trueLab, d, hp)
1290 :     end
1291 :     | gen(BRANCH(P.peql, vw, _,e,d), hp) = branch(M.EQ, vw, e, d, hp)
1292 :     | gen(BRANCH(P.pneq, vw, _, e, d), hp) = branch(M.NE, vw, e, d, hp)
1293 :     | gen(BRANCH(P.strneq, [n,v,w],c,d,e), hp) =
1294 :     gen(BRANCH(P.streq, [n,v,w],c,e,d), hp)
1295 :     | gen(BRANCH(P.streq, [INT n,v,w],_,d,e), hp) =
1296 :     let val n' = ((n+3) div 4) * 4
1297 :     val false_lab = Label.newLabel ""
1298 : monnier 498 val r1 = newReg I32
1299 :     val r2 = newReg I32
1300 : monnier 429 fun cmpWord(i) =
1301 :     M.CMP(32, M.NE,
1302 :     M.LOAD(ity,M.ADD(ity,M.REG(ity, r1),i),R.readonly),
1303 :     M.LOAD(ity,M.ADD(ity,M.REG(ity, r2),i),R.readonly))
1304 :     fun unroll i =
1305 :     if i=n' then ()
1306 :     else (emit(M.BCC(M.NE, cmpWord(M.LI(i)), false_lab));
1307 :     unroll (i+4))
1308 :     in emit(M.MV(ity, r1, M.LOAD(ity, regbind v, R.readonly)));
1309 :     emit(M.MV(ity, r2, M.LOAD(ity, regbind w, R.readonly)));
1310 :     unroll 0;
1311 :     gen(d, hp);
1312 :     genlab(false_lab, e, hp)
1313 :     end
1314 :     | gen(BRANCH(P.boxed, [x], _, a, b), hp) =
1315 :     let val lab = Label.newLabel""
1316 :     val cmp = M.CMP(32, M.NE, M.ANDB(ity, regbind x, one), M.LI 0)
1317 :     in emit(M.BCC(M.NE, cmp, lab));
1318 :     gen(a, hp);
1319 :     genlab(lab, b, hp)
1320 :     end
1321 :     | gen(BRANCH(P.unboxed, x,c,a,b), hp) =
1322 :     gen(BRANCH(P.boxed,x,c,b,a), hp)
1323 :     | gen(e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
1324 :     end (*local*)
1325 :    
1326 :     fun fragComp() =
1327 :     let fun continue() = fcomp (Frag.next())
1328 :     and fcomp(NONE) = ()
1329 :     | fcomp(SOME(_, Frag.KNOWNFUN _)) = continue()
1330 :     | fcomp(SOME(_, Frag.KNOWNCHK _)) = continue()
1331 :     | fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue()
1332 :     | fcomp(SOME(lab,
1333 :     Frag.STANDARD{func as ref(SOME (zz as (_,f,vl,tl,e))),
1334 :     ...})) =
1335 :     let val regfmls as (M.GPR linkreg::regfmlsTl) =
1336 :     ArgP.standard(typmap f, tl)
1337 : monnier 475 val entryLab =
1338 :     if splitEntry then functionLabel(~f-1) else lab
1339 : monnier 429 val baseval =
1340 :     M.ADD(addrTy,linkreg,
1341 :     M.LABEL(LE.MINUS(
1342 :     LE.CONST MachineSpec.constBaseRegOffset,
1343 : monnier 475 LE.LABEL entryLab)))
1344 : monnier 429 in func := NONE;
1345 :     pseudoOp PseudoOp.ALIGN4;
1346 : monnier 475 if splitEntry then
1347 :     (entryLabel entryLab;
1348 :     annotation EMPTY_BLOCK;
1349 :     defineLabel lab
1350 :     )
1351 :     else
1352 :     entryLabel lab;
1353 : monnier 429 alignAllocptr f;
1354 :     emit(assign(C.baseptr, baseval));
1355 :     InvokeGC.stdCheckLimit stream
1356 :     {maxAlloc=4 * maxAlloc f, regfmls=regfmls,
1357 :     regtys=tl, return=M.JMP(linkreg,[])};
1358 :     clearTables();
1359 :     initialRegBindingsEscaping(List.tl vl, regfmlsTl, List.tl tl);
1360 :     initTypBindings e;
1361 :     if !Control.CG.printit then (
1362 :     print "*********************************************** \n";
1363 :     PPCps.printcps0 zz;
1364 :     print "*********************************************** \n")
1365 :     else ();
1366 :     continue(gen(e, 0))
1367 :     end
1368 :     in fcomp (Frag.next())
1369 :     end (* fragComp *)
1370 : monnier 247
1371 : monnier 429 (*
1372 :     * execution starts at the first CPS function -- the frag
1373 :     * is maintained as a queue.
1374 :     *)
1375 :     fun initFrags (start::rest : CPS.function list) =
1376 :     let fun init(func as (fk, f, _, _, _)) =
1377 :     addGenTbl (f, Frag.makeFrag(func, functionLabel f))
1378 :     in app init rest;
1379 :     init start
1380 : monnier 247 end
1381 :     in
1382 : monnier 498 initFrags cluster;
1383 :     beginCluster 0;
1384 :     if !gcsafety then Intmap.clear(GCCells.getGCMap()) else ();
1385 : monnier 429 fragComp();
1386 :     InvokeGC.emitLongJumpsToGCInvocation stream;
1387 :     endCluster(
1388 :     if !gcsafety then
1389 :     let val gcmap = GCCells.getGCMap()
1390 : monnier 475 in [#create SMLGCMap.GCMAP gcmap,
1391 : monnier 469 #create
1392 : monnier 498 MLRiscAnnotations.REGINFO(SMLGCMap.toString gcmap)
1393 : monnier 429 ]
1394 :     end
1395 :     else []
1396 :     )
1397 :     end (* genCluster *)
1398 : monnier 247
1399 : monnier 469 fun emitMLRiscUnit f =
1400 : monnier 429 (Cells.reset();
1401 :     beginCluster 0;
1402 :     f stream;
1403 : monnier 498 endCluster [NO_OPT]
1404 : monnier 429 )
1405 :     in app mkGlobalTables funcs;
1406 :     app genCluster (Cluster.cluster funcs);
1407 :     emitMLRiscUnit InvokeGC.emitModuleGC
1408 : monnier 247 end (* codegen *)
1409 :     end (* MLRiscGen *)
1410 :    

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