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

Annotation of /sml/trunk/src/compiler/CodeGen/main/mlriscGen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 586 - (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 : leunga 585 structure C : CPSREGS where T.Region = CPSRegions
21 :     and T.Constant = SMLNJConstant
22 :     structure InvokeGC : INVOKE_GC where T = C.T
23 :     structure MLTreeComp : MLTREECOMP where T = C.T
24 :     structure Flowgen : FLOWGRAPH_GEN where T = C.T
25 :     structure Cells : CELLS
26 :     sharing C.T.PseudoOp = PseudoOp
27 :     sharing Flowgen.I = MLTreeComp.I
28 : monnier 498 val compile : Flowgen.flowgraph -> unit
29 : leunga 585 ) : MLRISCGEN =
30 : monnier 247 struct
31 :    
32 : leunga 585 structure M = C.T (* MLTree *)
33 :     structure P = CPS.P (* CPS primitive operators *)
34 :     structure LE = M.LabelExp (* Label Expression *)
35 :     structure R = CPSRegions (* Regions *)
36 :     structure CG = Control.CG (* Compiler Control *)
37 :     structure MS = MachineSpec (* Machine Specification *)
38 :     structure D = MS.ObjDesc (* ML Object Descriptors *)
39 : monnier 247
40 : leunga 585 structure ArgP = (* Argument passing *)
41 : monnier 247 ArgPassing(structure Cells=Cells
42 : monnier 429 structure C=C
43 :     structure MS=MachineSpec)
44 : monnier 247
45 : leunga 585 structure Frag = Frag(M) (* Decompose a compilation unit into clusters *)
46 : monnier 247
47 : leunga 585 structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)
48 :    
49 :     structure MkRecord = MkRecord(C) (* How to build records *)
50 : monnier 247
51 : leunga 585 fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)
52 : monnier 247
53 : leunga 585 (*
54 :     * Debugging
55 :     *)
56 :     fun printCPSFun cps =
57 :     (Control.Print.say "*********************************************** \n";
58 :     PPCps.printcps0 cps;
59 :     Control.Print.say "*********************************************** \n";
60 :     Control.Print.flush()
61 :     )
62 :     val print = Control.Print.say
63 :    
64 :    
65 : monnier 429 (*
66 :     * GC Safety
67 :     *)
68 : leunga 585 structure GCCells = (* How to annotate GC information *)
69 : monnier 429 GCCells(structure C = Cells
70 : monnier 475 structure GCMap = SMLGCMap)
71 : monnier 247
72 : monnier 498 val I31 = SMLGCType.I31 (* tagged integers *)
73 :     val I32 = SMLGCType.I32 (* untagged integers *)
74 :     val REAL64 = SMLGCType.REAL64 (* untagged floats *)
75 :     val PTR = SMLGCType.PTR (* boxed objects *)
76 : leunga 585 val NO_OPT = [#create MLRiscAnnotations.NO_OPTIMIZATION ()]
77 : monnier 429
78 : leunga 585 val enterGC = ref (fn _ => error "enterGC") :
79 :     (int * SMLGCType.gctype -> unit) ref
80 :    
81 :     val ptr = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,PTR))
82 :     val i32 = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,I32))
83 :     val i31 = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,I32))
84 :     val flt = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,REAL64))
85 :     fun ctyToAnn CPS.INTt = i31
86 :     | ctyToAnn CPS.INT32t = i32
87 :     | ctyToAnn CPS.FLTt = flt
88 :     | ctyToAnn _ = ptr
89 :    
90 : george 546 (*
91 :     * Convert kind to gc type
92 :     *)
93 : leunga 585 fun kindToGCty(CPS.P.INT 31) = I31
94 :     | kindToGCty(CPS.P.UINT 31) = I31
95 :     | kindToGCty(_) = I32
96 : george 546
97 : leunga 585 fun ctyToGCty(CPS.FLTt) = REAL64
98 :     | ctyToGCty(CPS.INTt) = I31
99 :     | ctyToGCty(CPS.INT32t) = I32
100 :     | ctyToGCty _ = PTR
101 :    
102 : monnier 429 (*
103 :     * These are the type widths of ML. They are hardwired for now.
104 :     *)
105 :     val pty = 32 (* size of ML's pointer *)
106 :     val ity = 32 (* size of ML's integer *)
107 :     val fty = 64 (* size of ML's real number *)
108 : monnier 247
109 : leunga 585 val zero = M.LI 0
110 :     val one = M.LI 1
111 :     val two = M.LI 2
112 :     val mlZero = M.LI 1
113 :     val offp0 = CPS.OFFp 0
114 :    
115 : monnier 429 (*
116 : leunga 585 * The allocation pointer. This must be a register
117 : monnier 429 *)
118 : monnier 411 val M.REG(_,allocptrR) = C.allocptr
119 : monnier 247
120 : monnier 429 (*
121 :     * Dedicated registers.
122 :     *)
123 : george 555 val dedicated' =
124 : monnier 411 map (fn r => M.GPR(M.REG(ity,r))) C.dedicatedR @
125 :     map (fn f => M.FPR(M.FREG(fty,f))) C.dedicatedF
126 : monnier 429
127 : monnier 247 val dedicated =
128 : monnier 429 case C.exhausted of NONE => dedicated'
129 :     | SOME cc => M.CCR cc :: dedicated'
130 : monnier 247
131 : leunga 585 (*
132 :     * This flag controls whether extra MLRISC optimizations should be
133 :     * performed. By default, this is off.
134 :     *)
135 : monnier 498 val mlrisc = Control.MLRISC.getFlag "mlrisc"
136 :    
137 : monnier 429 (*
138 :     * If this flag is on then annotate the registers with GC type info.
139 :     * Otherwise use the default behavior.
140 :     *)
141 : george 546 val gctypes = Control.MLRISC.getFlag "mlrisc-gc-types"
142 :    
143 :     (*
144 :     * If this flag is on then perform optimizations before generating gc code.
145 :     * If this flag is on then gctypes must also be turned on!
146 :     * Otherwise use the default behavior.
147 :     *)
148 : monnier 429 val gcsafety = Control.MLRISC.getFlag "mlrisc-gcsafety"
149 : monnier 411
150 : monnier 429 (*
151 : monnier 475 * If this flag is on then split the entry block.
152 :     * This should be on for SSA optimizations.
153 : monnier 429 *)
154 : monnier 475 val splitEntry = Control.MLRISC.getFlag "split-entry-block"
155 : monnier 247
156 : monnier 429 (*
157 : monnier 475 * This dummy annotation is used to get an empty block
158 :     *)
159 : monnier 498 val EMPTY_BLOCK = #create MLRiscAnnotations.EMPTY_BLOCK ()
160 : george 546
161 : monnier 475 (*
162 : leunga 585 * convert object descriptor to int
163 : monnier 429 *)
164 : leunga 585 val dtoi = LargeWord.toInt
165 :    
166 :     (*
167 :     * The mltree stream
168 :     *)
169 :     val stream as M.Stream.STREAM
170 : monnier 429 { beginCluster, (* start a cluster *)
171 :     endCluster, (* end a cluster *)
172 :     emit, (* emit MLTREE stm *)
173 :     alias, (* generate register alias *)
174 :     defineLabel, (* define a local label *)
175 :     entryLabel, (* define an external entry *)
176 :     exitBlock, (* mark the end of a procedure *)
177 :     pseudoOp, (* emit a pseudo op *)
178 : monnier 475 annotation, (* add an annotation *)
179 : monnier 429 ... } =
180 : monnier 498 MLTreeComp.selectInstructions
181 : george 555 (Flowgen.newStream{compile=compile, flowgraph=NONE})
182 : leunga 585
183 :     (*
184 :     * The main codegen function.
185 :     *)
186 :     fun codegen(funcs : CPS.function list, limits:CPS.lvar -> (int*int), err) =
187 :     let
188 : monnier 429 val maxAlloc = #1 o limits
189 : monnier 475 val splitEntry = !splitEntry
190 : monnier 247
191 : monnier 429 (*
192 :     * The natural address arithmetic width of the architecture.
193 :     * For most architecture this is 32 but for the Alpha this is 64,
194 :     * since 64-bit address arithmetic is more efficiently implemented
195 :     * on the Alpha.
196 : monnier 247 *)
197 : monnier 429 val addrTy = C.addressWidth
198 : monnier 247
199 : monnier 429 (*
200 : leunga 585 * These functions generate new virtual register names and
201 :     * mark expressions with their gc types.
202 : monnier 429 * When the gc-safety feature is turned on, we'll use the
203 :     * versions of newReg that automatically update the GCMap.
204 :     * Otherwise, we'll just use the normal version.
205 : monnier 247 *)
206 : george 546 val gctypes = !gctypes
207 : leunga 586
208 :     val _ = if gctypes then
209 :     let val gcMap = GCCells.newGCMap()
210 :     in enterGC := Intmap.add gcMap;
211 :     GCCells.setGCMap gcMap
212 :     end
213 :     else ()
214 :    
215 : leunga 585 val (newReg, newRegWithCty, newRegWithKind, newFreg) =
216 :     if gctypes then
217 :     let val newReg = GCCells.newCell Cells.GP
218 :     val newFreg = GCCells.newCell Cells.FP
219 :     fun newRegWithCty cty = newReg(ctyToGCty cty)
220 :     fun newRegWithKind kind = newReg(kindToGCty kind)
221 :     in (newReg, newRegWithCty, newRegWithKind, newFreg) end
222 :     else (Cells.newReg, Cells.newReg, Cells.newReg, Cells.newFreg)
223 :    
224 :     fun markPTR e = if gctypes then M.MARK(e,ptr) else e
225 :     fun markI32 e = if gctypes then M.MARK(e,i32) else e
226 :     fun markFLT e = if gctypes then M.FMARK(e,flt) else e
227 :     fun markGC(e,cty) = if gctypes then M.MARK(e,ctyToAnn cty) else e
228 : george 546 fun markNothing e = e
229 : monnier 247
230 : monnier 498 (*
231 :     * Known functions have parameters passed in fresh temporaries.
232 :     * We also annotate the gc types of these temporaries.
233 :     *)
234 :     fun known [] = []
235 :     | known(cty::rest) =
236 :     (case cty of
237 : leunga 585 CPS.FLTt => M.FPR(M.FREG(fty,newFreg REAL64))
238 :     | CPS.INTt => M.GPR(M.REG(ity,newReg I31))
239 :     | CPS.INT32t => M.GPR(M.REG(ity,newReg I32))
240 :     | _ => M.GPR(M.REG(pty,newReg PTR))
241 : monnier 498 )::known rest
242 : monnier 247
243 : leunga 585 (*
244 :     * labelTbl is a mapping of function names (CPS.lvars) to labels.
245 :     * If the flag splitEntry is on, we also distinguish between external and
246 :     * internal labels, make sure that no directly branches go to the
247 :     * external labels.
248 :     *)
249 : monnier 429 exception LabelBind and TypTbl
250 :     val labelTbl : Label.label Intmap.intmap = Intmap.new(32, LabelBind)
251 :     val functionLabel = Intmap.map labelTbl
252 :     val addLabelTbl = Intmap.add labelTbl
253 : monnier 247
254 : leunga 585 (*
255 :     * typTbl is a mapping of CPS.lvars to CPS types
256 :     *)
257 : monnier 429 val typTbl : CPS.cty Intmap.intmap = Intmap.new(32, TypTbl)
258 :     val addTypBinding = Intmap.add typTbl
259 :     val typmap = Intmap.map typTbl
260 : monnier 411
261 : leunga 585 (*
262 :     * mkGlobalTables define the labels and cty for all CPS functions
263 :     *)
264 : monnier 429 fun mkGlobalTables(fk, f, _, _, _) =
265 : monnier 475 ((* internal label *)
266 :     addLabelTbl (f, Label.newLabel "");
267 :     (* external entry label *)
268 :     if splitEntry then
269 :     (case fk of
270 :     (CPS.CONT | CPS.ESCAPE) =>
271 :     addLabelTbl (~f-1, Label.newLabel(Int.toString f))
272 :     | _ => ()
273 :     )
274 :     else ();
275 : monnier 429 case fk
276 :     of CPS.CONT => addTypBinding(f, CPS.CNTt)
277 :     | _ => addTypBinding(f, CPS.BOGt)
278 :     (*esac*))
279 : monnier 247
280 : monnier 429 (*
281 :     * This is the GC comparison test used. We have a choice of signed
282 :     * and unsigned comparisons. This usually doesn't matter, but some
283 :     * architectures work better in one way or the other, so we are given
284 : leunga 585 * a choice here. For example, the Alpha has to do extra for unsigned
285 :     * tests, so on the Alpha we use signed tests.
286 : monnier 247 *)
287 : monnier 429 val gcTest = M.CMP(pty, if C.signedGCTest then M.GT else M.GTU,
288 :     C.allocptr, C.limitptr)
289 : monnier 498
290 : monnier 429 (*
291 :     * Function for generating code for one cluster.
292 : monnier 247 *)
293 : monnier 429 fun genCluster(cluster) =
294 :     let val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
295 :     val clusterSize = length cluster
296 : monnier 247
297 : monnier 429 (* per-cluster tables *)
298 :     exception RegMap and GenTbl
299 : leunga 585
300 : monnier 429 (*
301 :     * genTbl -- is used to retrieve the parameter passing
302 :     * conventions once a function has been compiled.
303 :     *)
304 :     val genTbl : Frag.frag Intmap.intmap = Intmap.new(clusterSize, GenTbl)
305 :     val addGenTbl = Intmap.add genTbl
306 :     val lookupGenTbl = Intmap.map genTbl
307 : monnier 247
308 : monnier 429 (*
309 :     * {fp,gp}RegTbl -- mapping of lvars to registers
310 :     *)
311 : george 555 val fpRegTbl : M.fexp Intmap.intmap = Intmap.new(2, RegMap)
312 :     val gpRegTbl : M.rexp Intmap.intmap = Intmap.new(32, RegMap)
313 : monnier 429 val addExpBinding = Intmap.add gpRegTbl
314 :     fun addRegBinding(x,r) = addExpBinding(x,M.REG(ity,r))
315 :     val addFregBinding = Intmap.add fpRegTbl
316 : monnier 247
317 : monnier 429 (*
318 :     * The following function is used to translate CPS into
319 : leunga 585 * larger trees. Definitions marked TREEIFY can be forward
320 :     * propagated to their (only) use. This can drastically reduce
321 :     * register pressure.
322 : monnier 429 *)
323 : leunga 585 datatype treeify = TREEIFY | TREEIFIED | COMPUTE | DEAD
324 :     exception UseCntTbl
325 :     val useCntTbl : treeify Intmap.intmap = Intmap.new(32, UseCntTbl)
326 :     val treeify = Intmap.mapWithDefault(useCntTbl,DEAD)
327 :     val addCntTbl = Intmap.add useCntTbl
328 :     fun markAsTreeified r = addCntTbl(r, TREEIFIED)
329 :     (*
330 :     * Reset the bindings and use count tables. These tables
331 :     * can be reset at the same time.
332 :     *)
333 :     fun clearTables() =
334 :     (Intmap.clear gpRegTbl;
335 :     Intmap.clear fpRegTbl;
336 :     Intmap.clear useCntTbl
337 :     )
338 : monnier 247
339 : monnier 429 (*
340 :     * memDisambiguation uses the new register counters,
341 :     * so this must be reset here.
342 :     *)
343 :     val _ = Cells.reset()
344 :     val memDisambig = MemAliasing.analyze(cluster)
345 : monnier 247
346 : monnier 429 (*
347 :     * Points-to analysis projection.
348 :     *)
349 :     fun pi(x as ref(R.PT.TOP _),_) = x
350 :     | pi(x,i) = R.PT.pi(x,i)
351 : monnier 247
352 : monnier 429 val memDisambigFlag = !CG.memDisambiguate
353 : leunga 585 (* val top = ref(R.PT.NAMED("mem",R.PT.newTop())) *)
354 :     val top = R.memory
355 : monnier 247
356 : monnier 429 fun getRegion(e,i) =
357 :     if memDisambigFlag then
358 :     (case e of
359 :     CPS.VAR v => pi(memDisambig v,i)
360 :     | _ => R.readonly
361 :     )
362 :     else top
363 : monnier 411
364 : leunga 585 (* This keeps track of all the advanced offset on the hp
365 :     * since the beginning of the CPS function.
366 :     * This is important for generating the correct address offset
367 :     * for newly allocated records.
368 : monnier 429 *)
369 : leunga 585 val advancedHP = ref 0
370 :    
371 : monnier 429 (*
372 :     * Function grabty lookups the CPS type of a value expression in CPS.
373 :     *)
374 :     fun grabty(CPS.VAR v) = typmap v
375 :     | grabty(CPS.LABEL v) = typmap v
376 :     | grabty(CPS.INT _) = CPS.INTt
377 :     | grabty(CPS.INT32 _) = CPS.INT32t
378 :     | grabty(CPS.VOID) = CPS.FLTt
379 :     | grabty _ = CPS.BOGt
380 : monnier 247
381 : monnier 429 (*
382 :     * The baseptr contains the start address of the entire
383 :     * compilation unit. This function generates the address of
384 :     * a label that is embedded in the same compilation unit. The
385 :     * generated address is relative to the baseptr.
386 : monnier 498 *
387 :     * Note: For GC safety, we considered this to be an object reference
388 : monnier 429 *)
389 :     fun laddr(lab, k) =
390 : monnier 498 let val e =
391 : monnier 429 M.ADD(addrTy, C.baseptr,
392 :     M.LABEL(LE.PLUS(LE.LABEL lab,
393 : george 546 LE.INT(k-MachineSpec.constBaseRegOffset))))
394 :     in markPTR e end
395 : monnier 247
396 : monnier 429 (*
397 :     * A CPS register may be implemented as a physical
398 :     * register or a memory location. The function assign moves a
399 :     * value v into a register or a memory location.
400 :     *)
401 :     fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
402 : leunga 585 | assign(M.LOAD(ty, ea, mem), v) = M.STORE(ty, ea, v, mem)
403 : monnier 429 | assign _ = error "assign"
404 : monnier 247
405 : monnier 429 (*
406 :     * The following function looks up the MLTREE expression associated
407 :     * with a general purpose value expression.
408 :     *)
409 : leunga 585 val lookupGpRegTbl = Intmap.map gpRegTbl
410 :    
411 :     (*
412 :     * This function resolve the address computation of the
413 :     * form M.CONST k, where offset is a reference to the
414 :     * kth byte allocated since the beginning of the CPS function.
415 :     *)
416 :     fun resolveHpOffset(M.CONST(absoluteHpOffset)) =
417 :     let val tmpR = newReg PTR
418 :     val offset = absoluteHpOffset - !advancedHP
419 :     in emit(M.MV(pty, tmpR, M.ADD(addrTy, C.allocptr, M.LI offset)));
420 :     M.REG(pty, tmpR)
421 :     end
422 :     | resolveHpOffset(e) = e
423 :    
424 :     fun regbind(CPS.VAR v) = resolveHpOffset(lookupGpRegTbl v)
425 : monnier 429 | regbind(CPS.INT i) = M.LI (i+i+1)
426 :     | regbind(CPS.INT32 w) = M.LI32 w
427 : monnier 475 | regbind(CPS.LABEL v) =
428 :     laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
429 : monnier 429 | regbind _ = error "regbind"
430 : monnier 247
431 : leunga 585 (*
432 :     * This version allows the value to be further propagated
433 :     *)
434 :     fun resolveHpOffset'(M.CONST(absoluteHpOffset)) =
435 :     let val tmpR = newReg PTR
436 :     val offset = absoluteHpOffset - !advancedHP
437 :     in M.ADD(addrTy, C.allocptr, M.LI offset)
438 :     end
439 :     | resolveHpOffset'(e) = e
440 :    
441 :     fun regbind'(CPS.VAR v) = resolveHpOffset'(lookupGpRegTbl v)
442 :     | regbind'(CPS.INT i) = M.LI (i+i+1)
443 :     | regbind'(CPS.INT32 w) = M.LI32 w
444 :     | regbind'(CPS.LABEL v) =
445 :     laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
446 :     | regbind' _ = error "regbind'"
447 :    
448 :    
449 : monnier 429 (*
450 :     * The following function looks up the MLTREE expression associated
451 :     * with a floating point value expression.
452 :     *)
453 :     val lookupFpRegTbl = Intmap.map fpRegTbl
454 :     fun fregbind(CPS.VAR v) = lookupFpRegTbl v
455 :     | fregbind _ = error "fregbind"
456 : monnier 247
457 : monnier 429 (* On entry to a function, the parameters will be in formal
458 :     * parameter passing registers. Within the body of the function, they
459 :     * are moved immediately to fresh temporary registers. This ensures
460 :     * that the life time of the formal paramters is restricted to the
461 :     * function body and is critical in avoiding artificial register
462 :     * interferences.
463 :     *)
464 :     fun initialRegBindingsEscaping(vl, rl, tl) =
465 :     let fun eCopy(x::xs, M.GPR(M.REG(_,r))::rl, rds, rss, xs', rl') =
466 : monnier 498 let val t = newReg PTR
467 : monnier 429 in addRegBinding(x, t);
468 :     eCopy(xs, rl, t::rds, r::rss, xs', rl')
469 :     end
470 :     | eCopy(x::xs, r::rl, rds, rss, xs', rl') =
471 :     eCopy(xs, rl, rds, rss, x::xs', r::rl')
472 :     | eCopy([], [], [], [], xs', rl') = (xs', rl')
473 :     | eCopy([], [], rds, rss, xs', rl') =
474 :     (emit(M.COPY(ity, rds, rss)); (xs', rl'))
475 : monnier 247
476 : monnier 429 fun eOther(x::xs, M.GPR(r)::rl, xs', rl') =
477 : monnier 498 let val t = newReg PTR
478 : monnier 429 in addRegBinding(x, t); emit(M.MV(ity, t, r));
479 :     eOther(xs, rl, xs', rl')
480 :     end
481 :     | eOther(x::xs, (M.FPR(M.FREG(_,f)))::rl, xs', rl') =
482 :     eOther(xs, rl, x::xs', f::rl')
483 :     | eOther([], [], xs, rl) = (xs, rl)
484 : monnier 247
485 : monnier 429 fun eFcopy([], []) = ()
486 :     | eFcopy(xs, rl) =
487 : monnier 498 let val fs = map (fn _ => newFreg REAL64) xs
488 : monnier 429 in ListPair.app
489 :     (fn (x,f) => addFregBinding(x,M.FREG(fty,f))) (xs,fs);
490 :     emit(M.FCOPY(fty, fs, rl))
491 :     end
492 :     val (vl', rl') = eCopy(vl, rl, [], [], [], [])
493 :     in eFcopy(eOther(vl', rl', [], []));
494 :     ListPair.app addTypBinding (vl, tl)
495 :     end
496 : monnier 247
497 : monnier 429 fun initialRegBindingsKnown(vl, rl, tl) =
498 :     let fun f(v, M.GPR(reg as M.REG _)) = addExpBinding(v, reg)
499 :     | f(v, M.FPR(freg as M.FREG _)) = addFregBinding(v, freg)
500 :     | f _ = error "initialRegBindingsKnown.f"
501 :     in ListPair.app f (vl, rl);
502 :     ListPair.app addTypBinding (vl, tl)
503 :     end
504 : monnier 247
505 : monnier 429 (* Keep allocation pointer aligned on odd boundary
506 :     * Note: We have accounted for the extra space this eats up in
507 :     * limit.sml
508 :     *)
509 : leunga 585
510 : monnier 429 fun updtHeapPtr(hp) =
511 : leunga 585 let fun advBy hp =
512 :     (advancedHP := !advancedHP + hp;
513 :     emit(M.MV(pty, allocptrR, M.ADD(addrTy, C.allocptr, M.LI hp))))
514 : monnier 429 in if hp = 0 then ()
515 :     else if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then advBy(hp+4)
516 :     else advBy(hp)
517 :     end
518 : monnier 247
519 : monnier 429 fun testLimit hp =
520 : george 546 let fun assignCC(M.CC(_, cc), v) = emit(M.CCMV(cc, v))
521 : monnier 429 | assignCC _ = error "testLimit.assign"
522 :     in updtHeapPtr(hp);
523 :     case C.exhausted
524 :     of NONE => ()
525 :     | SOME cc => assignCC(cc, gcTest)
526 :     (*esac*)
527 :     end
528 : monnier 247
529 : leunga 585 (*
530 :     * Int 31 tag optimizations.
531 :     * Note: if the tagging scheme changes then we'll have to redo these.
532 :     *)
533 : monnier 247
534 : leunga 585 fun addTag e = M.ADD(ity, e, one)
535 : monnier 429 fun stripTag e = M.SUB(ity, e, one)
536 : leunga 585 fun orTag e = M.ORB(ity, e, one)
537 : monnier 247
538 : leunga 585 fun tag(false, e) = tagUnsigned e
539 :     | tag(true, e) = tagSigned e
540 :     and tagUnsigned e =
541 :     let fun double r = M.ADD(ity,r,r)
542 :     in case e
543 :     of M.REG _ => addTag(double e)
544 :     | _ => let val tmp = newReg PTR (* XXX ??? *)
545 :     in M.LET(M.MV(ity, tmp, e),
546 :     addTag(double(M.REG(ity,tmp))))
547 :     end
548 :     end
549 :     and tagSigned e =
550 :     let fun double r = M.ADDT(ity,r,r)
551 :     in case e
552 :     of M.REG _ => addTag(double e)
553 :     | _ => let val tmp = newReg PTR (* XXX ??? *)
554 :     in M.LET(M.MV(ity, tmp, e),
555 :     addTag(double(M.REG(ity,tmp))))
556 :     end
557 :     end
558 : monnier 247
559 : leunga 585 fun untag(true, e) = untagSigned e
560 :     | untag(false, e) = untagUnsigned e
561 :     and untagUnsigned(CPS.INT i) = M.LI i
562 :     | untagUnsigned v = M.SRL(ity, regbind v, one)
563 :     and untagSigned(CPS.INT i) = M.LI i
564 :     | untagSigned v = M.SRA(ity, regbind v, one)
565 : monnier 247
566 : leunga 585 (*
567 :     * Integer operators
568 :     *)
569 :     fun int31add(addOp, CPS.INT k, w) = addOp(ity, M.LI(k+k), regbind w)
570 :     | int31add(addOp, w, v as CPS.INT _) = int31add(addOp, v, w)
571 :     | int31add(addOp, v, w) = addOp(ity,regbind v,stripTag(regbind w))
572 : monnier 247
573 : leunga 585 fun int31sub(subOp, CPS.INT k, w) = subOp(ity, M.LI(k+k+2),regbind w)
574 :     | int31sub(subOp, v, CPS.INT k) = subOp(ity, regbind v, M.LI(k+k))
575 :     | int31sub(subOp, v, w) = addTag(subOp(ity, regbind v, regbind w))
576 :    
577 :     fun int31xor(CPS.INT k, w) = M.XORB(ity, M.LI(k+k), regbind w)
578 :     | int31xor(w, v as CPS.INT _) = int31xor (v,w)
579 :     | int31xor(v, w) = addTag (M.XORB(ity, regbind v, regbind w))
580 :    
581 :     fun int31mul(signed, v, w) =
582 :     let fun f(CPS.INT k, CPS.INT j) = (M.LI(k+k), M.LI(j))
583 :     | f(CPS.INT k, w) = (untag(signed,w), M.LI(k+k))
584 :     | f(v, w as CPS.INT _) = f(w, v)
585 :     | f(v, w) = (stripTag(regbind v), untag(signed,w))
586 :     val (v, w) = f(v, w)
587 :     in addTag(if signed then M.MULT(ity, v, w) else M.MULU(ity, v, w))
588 : monnier 429 end
589 : monnier 247
590 : leunga 585 fun int31div(signed, v, w) =
591 :     let val (v, w) =
592 :     case (v, w) of
593 :     (CPS.INT k, CPS.INT j) => (M.LI k, M.LI j)
594 :     | (CPS.INT k, w) => (M.LI k, untag(signed, w))
595 :     | (v, CPS.INT k) => (untag(signed, v), M.LI(k))
596 :     | (v, w) => (untag(signed, v), untag(signed, w))
597 :     in tag(signed,
598 :     if signed then M.DIVT(ity, v, w) else M.DIVU(ity, v, w))
599 : monnier 429 end
600 : monnier 247
601 : leunga 585 fun int31lshift(CPS.INT k, w) =
602 :     addTag (M.SLL(ity, M.LI(k+k), untagUnsigned(w)))
603 :     | int31lshift(v, CPS.INT k) =
604 : monnier 429 addTag(M.SLL(ity,stripTag(regbind v), M.LI(k)))
605 : leunga 585 | int31lshift(v,w) =
606 :     addTag(M.SLL(ity,stripTag(regbind v), untagUnsigned(w)))
607 : monnier 247
608 : leunga 585 fun int31rshift(rshiftOp, v, CPS.INT k) =
609 : monnier 429 orTag(rshiftOp(ity, regbind v, M.LI(k)))
610 : leunga 585 | int31rshift(rshiftOp, v, w) =
611 :     orTag(rshiftOp(ity, regbind v, untagUnsigned(w)))
612 : monnier 247
613 : monnier 429 fun getObjDescriptor(v) =
614 :     M.LOAD(ity, M.SUB(pty, regbind v, M.LI(4)), getRegion(v, ~1))
615 : monnier 247
616 : monnier 429 fun getObjLength(v) =
617 :     M.SRL(ity, getObjDescriptor(v), M.LI(D.tagWidth -1))
618 : monnier 247
619 : monnier 429 (*
620 :     * Note: because formals are moved into fresh temporaries,
621 :     * (formals intersection actuals) is empty.
622 : leunga 585 *
623 :     * Do the treeified computation first so as to prevent extra
624 :     * interferences from being created.
625 :     *
626 : monnier 429 *)
627 :     fun callSetup(formals, actuals) =
628 : leunga 585 let fun isTreeified(CPS.VAR r) = treeify r = TREEIFIED
629 :     | isTreeified _ = false
630 :     fun gather([], [], cpRd, cpRs, fcopies, treeified, moves) =
631 :     (app emit treeified;
632 :     case (cpRd,cpRs)
633 : monnier 429 of ([],[]) => ()
634 :     | _ => emit(M.COPY(ity, cpRd, cpRs));
635 :     case fcopies
636 :     of [] => ()
637 :     | _ => emit(M.FCOPY(fty, map #1 fcopies, map #2 fcopies));
638 :     app emit moves
639 :     )
640 : leunga 585 | gather(M.GPR(M.REG(ty,rd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
641 : monnier 429 (case regbind act
642 : leunga 585 of M.REG(_,rs) => gather(fmls,acts,rd::cpRd,rs::cpRs,f,t,m)
643 :     | e => if isTreeified act then
644 :     gather(fmls, acts, cpRd, cpRs, f,
645 :     M.MV(ty, rd, e)::t, m)
646 :     else
647 :     gather(fmls, acts, cpRd, cpRs, f,
648 :     t, M.MV(ty, rd, e)::m)
649 : monnier 429 (*esac*))
650 : leunga 585 | gather(M.GPR(M.LOAD(ty,ea,r))::fmls,act::acts,cpRd,cpRs,f,t,m) =
651 :     (* Always store them early! *)
652 : monnier 429 gather(fmls,acts,cpRd,cpRs,f,
653 : leunga 585 M.STORE(ty,ea,regbind act,r)::t, m)
654 :     | gather(M.FPR(M.FREG(ty,fd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
655 : monnier 429 (case fregbind act
656 :     of M.FREG(_,fs) =>
657 : leunga 585 gather(fmls,acts,cpRd,cpRs,(fd,fs)::f,t,m)
658 : monnier 429 | e =>
659 : leunga 585 if isTreeified act then
660 :     gather(fmls,acts,cpRd,cpRs,f,M.FMV(ty, fd, e)::t,m)
661 :     else
662 :     gather(fmls,acts,cpRd,cpRs,f,t,M.FMV(ty, fd, e)::m)
663 : monnier 429 (*esac*))
664 :     | gather _ = error "callSetup.gather"
665 : leunga 585 in gather(formals, actuals, [], [], [], [], [])
666 : monnier 429 end
667 : monnier 247
668 : monnier 429 (* scale-and-add *)
669 :     fun scale1(a, CPS.INT 0) = a
670 :     | scale1(a, CPS.INT k) = M.ADD(ity, a, M.LI(k))
671 : leunga 585 | scale1(a, i) = M.ADD(ity, a, untagSigned(i))
672 : monnier 247
673 : monnier 429 fun scale4(a, CPS.INT 0) = a
674 :     | scale4(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*4))
675 : leunga 585 | scale4(a, i) = M.ADD(ity, a, M.SLL(ity, untagSigned(i), two))
676 : monnier 429
677 : monnier 247
678 : monnier 429 fun scale8(a, CPS.INT 0) = a
679 :     | scale8(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*8))
680 :     | scale8(a, i) = M.ADD(ity, a, M.SLL(ity, stripTag(regbind i),
681 :     M.LI(2)))
682 :    
683 :     (* add to storelist, the address where a boxed update has occured *)
684 :     fun recordStore(tmp, hp) =
685 :     (emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp)),
686 :     tmp,R.storelist));
687 :     emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
688 :     C.storeptr,R.storelist));
689 :     emit(assign(C.storeptr, M.ADD(addrTy, C.allocptr, M.LI(hp)))))
690 :    
691 :     fun unsignedCmp oper =
692 :     case oper
693 : leunga 585 of P.> => M.GTU | P.>= => M.GEU
694 :     | P.< => M.LTU | P.<= => M.LEU
695 :     | P.eql => M.EQ | P.neq => M.NE
696 : monnier 429
697 :     fun signedCmp oper =
698 :     case oper
699 : leunga 585 of P.> => M.GT | P.>= => M.GE
700 :     | P.< => M.LT | P.<= => M.LE
701 :     | P.neq => M.NE | P.eql => M.EQ
702 : monnier 429
703 : george 546 fun branchToLabel(lab) = M.JMP([],M.LABEL(LE.LABEL lab),[])
704 : monnier 429
705 :     local
706 :     open CPS
707 :     in
708 : monnier 498
709 : leunga 585 (*
710 :     * This function initializes a CPS function before we generate
711 :     * code for it. Its tasks include:
712 :     * 1. Add type bindings for each definition. This is used to determine
713 :     * the parameter passing convention for standard functions.
714 :     * 2. Compute the number of uses for each variable. This is
715 :     * used in the forward propagation logic.
716 :     * 3. Check whether the base pointer is needed.
717 :     * It is needed iff
718 :     * a. There is a reference to LABEL
719 :     * b. It uses SWITCH (the jumptable requires the basepointer)
720 :     * 4. Generate the gc tests for STANDARD and KNOWN functions
721 :     * 5. Check to see if floating point allocation is being performed
722 :     * in the function. If so, we will align the allocptr.
723 : monnier 429 *)
724 : leunga 585 fun genCPSFunction(lab, kind, f, params, formals, tys, e) =
725 :     let val add = addTypBinding
726 :     fun addUse v =
727 :     case treeify v of
728 :     DEAD => addCntTbl(v, TREEIFY)
729 :     | TREEIFY => addCntTbl(v, COMPUTE)
730 :     | COMPUTE => ()
731 :     | _ => error "addUse"
732 :    
733 :     val hasFloats = ref false (* default is no *)
734 :     val needBasePtr = ref false
735 :    
736 :     fun addValue(VAR v) = addUse v
737 :     | addValue(LABEL _) = needBasePtr := true
738 :     | addValue _ = ()
739 :    
740 :     fun addValues [] = ()
741 :     | addValues(VAR v::vs) = (addUse v; addValues vs)
742 :     | addValues(LABEL _::vs) = (needBasePtr := true; addValues vs)
743 :     | addValues(_::vs) = addValues vs
744 :    
745 :     fun addRecValues [] = ()
746 :     | addRecValues((VAR v,_)::l) = (addUse v; addRecValues l)
747 :     | addRecValues((LABEL v,_)::l) =
748 :     (needBasePtr := true; addRecValues l)
749 :     | addRecValues(_::l) = addRecValues l
750 :    
751 :     fun init e =
752 :     case e
753 :     of RECORD(k,vl,x,e) =>
754 :     (case k of
755 :     (RK_FCONT | RK_FBLOCK) => hasFloats := true
756 :     | _ => ();
757 :     addRecValues vl; add(x,BOGt); init e
758 :     )
759 :     | SELECT(_,v,x,t,e) => (addValue v; add(x,t); init e)
760 :     | OFFSET(_,v,x,e) => (addValue v; add(x,BOGt); init e)
761 :     | SWITCH(v,_,el) =>
762 :     (needBasePtr := true; addValue v; app init el)
763 :     | SETTER(_,vl,e) => (addValues vl; init e)
764 :     | LOOKER(looker,vl,x,t,e) =>
765 :     (addValues vl;
766 :     (* floating subscript cannot move past a floating update.
767 :     * For now subscript operations cannot be treeified.
768 :     * This is hacked by making it (falsely) used
769 :     * more than once.
770 :     *)
771 :     case looker of
772 :     P.numsubscript{kind=P.FLOAT _} => addCntTbl(x,COMPUTE)
773 :     | _ => ();
774 :     add(x,t); init e
775 :     )
776 :     | ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
777 :     | PURE(p,vl,x,t,e) =>
778 :     (case p of
779 :     P.fwrap => hasFloats := true
780 :     | _ => ();
781 :     addValues vl; add(x,t); init e
782 :     )
783 :     | BRANCH(_,vl,_,e1,e2) => (addValues vl; init e1; init e2)
784 :     | APP(v,vl) => (addValue v; addValues vl)
785 :     | _ => error "genCPSFunction"
786 :    
787 :     in (* Print debugging information *)
788 :     if !CG.printit then printCPSFun(kind,f,params,tys,e) else ();
789 :    
790 :     (* Move parameters *)
791 :     case kind of
792 :     KNOWN =>
793 :     (defineLabel lab;
794 :     init e;
795 :     initialRegBindingsEscaping(params, formals, tys)
796 :     )
797 :     | KNOWN_CHECK =>
798 :     (defineLabel lab;
799 :     (* gc test *)
800 :     (if !mlrisc andalso !gcsafety then
801 :     InvokeGC.optimizedKnwCheckLimit else
802 :     InvokeGC.knwCheckLimit)
803 :     stream
804 :     {maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tys,
805 :     return=branchToLabel(lab)};
806 :     init e;
807 :     initialRegBindingsEscaping(params, formals, tys)
808 :     )
809 :     | _ =>
810 :     (* Standard function *)
811 :     let val regfmls as (M.GPR linkreg::regfmlsTl) = formals
812 :     val entryLab =
813 :     if splitEntry then functionLabel(~f-1) else lab
814 :     in if splitEntry then
815 :     (entryLabel entryLab;
816 :     annotation EMPTY_BLOCK;
817 :     defineLabel lab
818 :     )
819 :     else
820 :     entryLabel lab;
821 :     clearTables();
822 :     init e;
823 :     if !needBasePtr then
824 :     let val baseval =
825 :     M.ADD(addrTy,linkreg,
826 :     M.LABEL(LE.MINUS(
827 :     LE.INT MachineSpec.constBaseRegOffset,
828 :     LE.LABEL entryLab)))
829 :     in emit(assign(C.baseptr, baseval)) end
830 :     else ();
831 :     InvokeGC.stdCheckLimit stream
832 :     {maxAlloc=4 * maxAlloc f, regfmls=regfmls,
833 :     regtys=tys, return=M.JMP([], linkreg,[])};
834 :     initialRegBindingsEscaping
835 :     (List.tl params, regfmlsTl, List.tl tys)
836 :     end
837 :     ;
838 :    
839 :     (* Align the allocation pointer if necessary *)
840 :     if !hasFloats then
841 :     emit(M.MV(pty,allocptrR, M.ORB(pty,C.allocptr, M.LI 4)))
842 :     else ();
843 :    
844 :     (* Generate code *)
845 :     advancedHP := 0;
846 :     gen(e, 0)
847 : monnier 247 end
848 : leunga 585
849 :     (*
850 :     * Generate code for x := e; k
851 :     *)
852 :     and define(r, x, e, k, hp) =
853 :     (addRegBinding(x, r);
854 :     emit(M.MV(ity, r, e));
855 :     gen(k, hp)
856 :     )
857 :    
858 :     and def(gc, x, e, k, hp) = define(newReg gc,x,e,k,hp)
859 :    
860 :     and defWithCty(cty, x, e, k, hp) = define(newRegWithCty cty,x,e,k,hp)
861 :    
862 :     and defWithKind(kind, x, e, k, hp) =
863 :     define(newRegWithKind kind,x,e,k,hp)
864 : monnier 498
865 : leunga 585 and defI31(x, e, k, hp) = def(I31, x, e, k, hp)
866 :     and defI32(x, e, k, hp) = def(I32, x, e, k, hp)
867 :     and defBoxed(x, e, k, hp) = def(PTR, x, e, k, hp)
868 : monnier 247
869 : monnier 429 (*
870 : leunga 585 * Generate code for x : cty := e; k
871 :     *)
872 :     and treeifyDef(x, e, cty, k, hp) =
873 :     case treeify x of
874 :     COMPUTE => defWithCty(cty, x, e, k, hp)
875 :     | TREEIFY => (markAsTreeified x;
876 :     addExpBinding(x, markGC(e, cty)); gen(k, hp))
877 :     | DEAD => gen(k, hp)
878 :     | _ => error "treeifyDef"
879 :    
880 :     (*
881 :     * Generate code for
882 :     * x := allocptr + offset; k
883 :     * where offset is the address offset of a newly allocated record.
884 :     * If x is only used once, we try to propagate that to its use.
885 :     *)
886 :     and defAlloc(x, offset, k, hp) =
887 :     defBoxed(x, M.ADD(addrTy, C.allocptr, M.LI offset), k, hp)
888 :    
889 :    
890 :     (* Generate code for
891 :     * x := allocptr + offset; k
892 :     * If there is only one reference then we delay the computation
893 :     * until it is used.
894 :     *)
895 :     and treeifyAlloc(x, offset, k, hp) =
896 :     (case treeify x of
897 :     COMPUTE => defAlloc(x, offset, k, hp)
898 :     | TREEIFY =>
899 :     (* Note, don't mark this as treeified since it has low
900 :     * register pressure.
901 :     *)
902 :     let val absoluteAllocOffset = offset + !advancedHP
903 :     in addExpBinding(x, M.CONST(absoluteAllocOffset));
904 :     gen(k, hp)
905 :     end
906 :     | DEAD => gen(k, hp)
907 :     | _ => error "treeifyAlloc"
908 :     )
909 :    
910 :     (*
911 : monnier 429 * x <- e where e contains an floating-point value
912 :     *)
913 : leunga 585 and treeifyDefF64(x, e, k, hp) =
914 : monnier 429 (case treeify x
915 : leunga 585 of DEAD => gen(k, hp)
916 :     | TREEIFY => (markAsTreeified x;
917 :     addFregBinding(x,e); gen(k, hp))
918 :     | COMPUTE =>
919 : monnier 498 let val f = newFreg REAL64
920 : monnier 429 in addFregBinding(x, M.FREG(fty, f));
921 :     emit(M.FMV(fty, f, e));
922 : leunga 585 gen(k, hp)
923 : monnier 429 end
924 : leunga 585 | _ => error "treeifyDefF64"
925 : monnier 429 (*esac*))
926 :    
927 : leunga 585 and nop(x, v, e, hp) = defI31(x, regbind v, e, hp)
928 : monnier 429
929 : leunga 585 and copy(gc, x, v, k, hp) =
930 : monnier 498 let val dst = newReg gc
931 : monnier 429 in addRegBinding(x, dst);
932 :     case regbind v
933 :     of M.REG(_,src) => emit(M.COPY(ity, [dst], [src]))
934 :     | e => emit(M.MV(ity, dst, e))
935 :     (*esac*);
936 : leunga 585 gen(k, hp)
937 : monnier 429 end
938 : monnier 498
939 : leunga 585 and copyM(31, x, v, k, hp) = copy(I31, x, v, k, hp)
940 :     | copyM(_, x, v, k, hp) = copy(I32, x, v, k, hp)
941 : monnier 498
942 : leunga 585 and eqVal(VAR x,VAR y) = x = y
943 :     | eqVal(LABEL x,LABEL y) = x = y
944 :     | eqVal(INT x, INT y) = x = y
945 :     | eqVal _ = false
946 :    
947 :     (* Perform conditional move folding *)
948 :     (*
949 :     and branch(cmp, [v,w], yes, no, hp) =
950 :     case (yes, no) of
951 :     (APP(f,fs), APP(g,gs)) =>
952 :     if eqVal(f,g) then
953 :     let val cmp = M.CMP(32, cmp, regbind v, regbind w)
954 :     fun condMove([],[]) = []
955 :     | condMove(x::xs,y::ys) =
956 :     if eqVal(x,y) then x::condMove(xs,ys)
957 :     else
958 :     let val v = LambdaVar.mkLvar()
959 :     val tmp = newReg PTR
960 :     in emit(M.MV(32, tmp,
961 :     M.COND(32, cmp, regbind x, regbind y)));
962 :     addRegBinding(v, tmp);
963 :     addTypBinding(v, grabty x);
964 :     VAR v::condMove(xs, ys)
965 :     end
966 :     | condMove _ = error "condMove"
967 :     val e = APP(f,condMove(fs, gs))
968 :     in gen(e, hp)
969 :     end
970 :     else normalBranch(cmp, v, w, yes, no, hp)
971 :     | _ => normalBranch(cmp, v, w, yes, no, hp)
972 :     *)
973 :    
974 :     (* normal branches *)
975 :     and branch (cmp, [v, w], yes, no, hp) =
976 : monnier 429 let val trueLab = Label.newLabel""
977 :     in (* is single assignment great or what! *)
978 : george 546 emit(M.BCC([], M.CMP(32, cmp, regbind v, regbind w), trueLab));
979 : leunga 585 genCont(no, hp);
980 :     genlab(trueLab, yes, hp)
981 : monnier 429 end
982 : leunga 585
983 :     (* branch if x is boxed *)
984 :     and branchOnBoxed(x, yes, no, hp) =
985 :     let val lab = Label.newLabel ""
986 :     val cmp = M.CMP(32, M.NE, M.ANDB(ity, regbind x, one), zero)
987 :     in emit(M.BCC([], cmp, lab));
988 :     genCont(yes, hp);
989 :     genlab(lab, no, hp)
990 :     end
991 :    
992 :     (* branch if are identical strings v, w of length n *)
993 :     and branchStreq(n, v, w, yes, no, hp) =
994 :     let val n' = ((n+3) div 4) * 4
995 :     val false_lab = Label.newLabel ""
996 :     val r1 = newReg I32
997 :     val r2 = newReg I32
998 :     fun cmpWord(i) =
999 :     M.CMP(32, M.NE,
1000 :     M.LOAD(ity,M.ADD(ity,M.REG(ity, r1),i),R.readonly),
1001 :     M.LOAD(ity,M.ADD(ity,M.REG(ity, r2),i),R.readonly))
1002 :     fun unroll i =
1003 :     if i=n' then ()
1004 :     else (emit(M.BCC([], cmpWord(M.LI(i)), false_lab));
1005 :     unroll (i+4))
1006 :     in emit(M.MV(ity, r1, M.LOAD(ity, regbind v, R.readonly)));
1007 :     emit(M.MV(ity, r2, M.LOAD(ity, regbind w, R.readonly)));
1008 :     unroll 0;
1009 :     genCont(yes, hp);
1010 :     genlab(false_lab, no, hp)
1011 :     end
1012 :    
1013 : monnier 498 and arith(gc, oper, v, w, x, e, hp) =
1014 : leunga 585 def(gc, x, oper(ity, regbind v, regbind w), e, hp)
1015 : monnier 498
1016 :     and arith32(oper, v, w, x, e, hp) =
1017 :     arith(I32, oper, v, w, x, e, hp)
1018 : monnier 429
1019 : monnier 498 and logical(gc, oper, v, w, x, e, hp) =
1020 : leunga 585 def(gc, x, oper(ity, regbind v, untagUnsigned(w)), e, hp)
1021 : monnier 498
1022 :     and logical31(oper, v, w, x, e, hp) =
1023 :     logical(I31, oper, v, w, x, e, hp)
1024 :    
1025 :     and logical32(oper, v, w, x, e, hp) =
1026 :     logical(I32, oper, v, w, x, e, hp)
1027 : monnier 429
1028 : leunga 585 and genCont(e, hp) =
1029 :     let val save = !advancedHP
1030 :     in gen(e, hp); advancedHP := save end
1031 :    
1032 : monnier 429 and genlab(lab, e, hp) = (defineLabel lab; gen(e, hp))
1033 : monnier 411
1034 : leunga 585 and genlabCont(lab, e, hp) = (defineLabel lab; genCont(e, hp))
1035 : monnier 247
1036 : leunga 585 (* Allocate a normal record *)
1037 :     and mkRecord(vl, w, e, hp) =
1038 :     let val len = length vl
1039 :     val desc = dtoi(D.makeDesc (len, D.tag_record))
1040 :     val contents = map (fn (v,p) => (regbind' v, p)) vl
1041 :     in treeifyAlloc(w,
1042 :     MkRecord.record
1043 :     {desc=M.LI desc, fields=contents,
1044 :     mem=memDisambig w, hp=hp, emit=emit,
1045 :     markPTR=markPTR, markComp=markPTR},
1046 :     e, hp + 4 + len*4)
1047 :     end
1048 :    
1049 :     (* Allocate a record with I32 components *)
1050 :     and mkI32block(vl, w, e, hp) =
1051 :     let val len = length vl
1052 :     val desc = dtoi(D.makeDesc (len, D.tag_raw32))
1053 :     val contents = map (fn (v,p) => (regbind' v, p)) vl
1054 :     in treeifyAlloc(w,
1055 :     MkRecord.record
1056 :     {desc=M.LI desc, fields=contents,
1057 :     mem=memDisambig w, hp=hp, emit=emit,
1058 :     markPTR=markPTR, markComp=markI32},
1059 :     e, hp + 4 + len*4)
1060 :     end
1061 :    
1062 :     (* Allocate a floating point record *)
1063 :     and mkFblock(vl, w, e, hp) =
1064 : monnier 429 let val len = List.length vl
1065 :     val desc = dtoi(D.makeDesc(len+len, D.tag_raw64))
1066 :     val vl' =
1067 : leunga 585 map (fn (x, p as SELp _) => (M.GPR(regbind' x), p)
1068 : monnier 429 | (x, p as OFFp 0) => (M.FPR(fregbind x), p)
1069 :     | _ => error "gen:RECORD:RK_FBLOCK")
1070 :     vl
1071 :     (* At initialization the allocation pointer is aligned on
1072 :     * an odd-word boundary, and the heap offset set to zero. If an
1073 :     * odd number of words have been allocated then the heap pointer
1074 :     * is misaligned for this record creation.
1075 :     *)
1076 :     val hp =
1077 :     if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then hp+4 else hp
1078 : leunga 585 in (* The components are floating points *)
1079 :     treeifyAlloc(w,
1080 :     MkRecord.frecord
1081 :     {desc=M.LI desc, fields=vl', mem=memDisambig w,
1082 :     hp=hp, emit=emit, markPTR=markPTR, markComp=markFLT},
1083 :     e, hp + 4 + len * 8)
1084 : monnier 429 end
1085 : leunga 585
1086 :     (* Allocate a vector *)
1087 :     and mkVector(vl, w, e, hp) =
1088 : monnier 429 let val len = length vl
1089 :     val hdrDesc = dtoi(D.desc_polyvec)
1090 :     val dataDesc = dtoi(D.makeDesc(len, D.tag_vec_data))
1091 : leunga 585 val contents = map (fn (v,p) => (regbind' v, p)) vl
1092 : monnier 498 val dataPtr = newReg PTR
1093 : monnier 429 val hdrM = memDisambig w
1094 :     val dataM = hdrM (* Allen *)
1095 : leunga 585 in (* The components are boxed *)
1096 : monnier 429 MkRecord.record {
1097 :     desc = M.LI(dataDesc), fields = contents,
1098 : george 546 mem = dataM, hp = hp, emit=emit,
1099 :     markPTR=markPTR, markComp=markPTR
1100 : leunga 585 };
1101 :     emit(M.MV(pty, dataPtr, M.ADD(addrTy, C.allocptr,
1102 :     M.LI(hp+4))));
1103 :     treeifyAlloc(w,
1104 :     MkRecord.record {
1105 : monnier 429 desc = M.LI hdrDesc,
1106 : leunga 585 fields = [ (M.REG(ity,dataPtr), offp0),
1107 :     (M.LI(len+len+1), offp0)
1108 :     ],
1109 : george 546 mem = hdrM, hp = hp + 4 + len*4, emit=emit,
1110 :     markPTR=markPTR, markComp=markPTR
1111 : leunga 585 },
1112 :     e, hp + 16 + len * 4)
1113 : monnier 429 end
1114 : leunga 585
1115 :     (*
1116 :     * Floating point select
1117 :     *)
1118 :     and fselect(i, v, x, e, hp) =
1119 :     treeifyDefF64(x,
1120 :     M.FLOAD(fty, scale8(regbind v, INT i), R.real),
1121 :     e, hp)
1122 :    
1123 :     (*
1124 :     * Non-floating point select
1125 :     *)
1126 :     and select(i, v, x, t, e, hp) =
1127 :     treeifyDef(x,
1128 :     M.LOAD(ity,scale4(regbind v,INT i),getRegion(v,i)),
1129 :     t, e, hp)
1130 :    
1131 :     (*
1132 :     * Funny select; I don't know that this does
1133 :     *)
1134 :     and funnySelect(i, k, x, t, e, hp) =
1135 :     let val unboxedfloat = MS.unboxedFloats
1136 :     fun isFlt t =
1137 :     if unboxedfloat then (case t of FLTt => true | _ => false)
1138 :     else false
1139 :     fun fallocSp(x,e,hp) =
1140 :     (addFregBinding(x,M.FREG(fty,newFreg REAL64));gen(e, hp))
1141 :     (* warning: the following generated code should never be
1142 :     executed; its semantics is completely screwed up !
1143 : monnier 429 *)
1144 : leunga 585 in if isFlt t then fallocSp(x, e, hp)
1145 :     else defI32(x, M.LI k, e, hp)(* BOGUS *)
1146 : monnier 429 end
1147 : monnier 247
1148 : leunga 585 (*
1149 :     * Call an external function
1150 :     *)
1151 :     and externalApp(f, args, hp) =
1152 : monnier 429 let val formals as (M.GPR dest::_) =
1153 :     ArgP.standard(typmap f, map grabty args)
1154 :     in callSetup(formals, args);
1155 :     testLimit hp;
1156 : george 546 emit(M.JMP([], dest, []));
1157 : monnier 429 exitBlock(formals @ dedicated)
1158 :     end
1159 : leunga 585
1160 :     (*
1161 :     * Call an internal function
1162 :     *)
1163 :     and internalApp(f, args, hp) =
1164 : monnier 429 (case lookupGenTbl f
1165 :     of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
1166 :     (updtHeapPtr(hp);
1167 :     callSetup(formals, args);
1168 :     emit(branchToLabel(functionLabel f)))
1169 :     | Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1170 : monnier 498 let val formals = known tl
1171 : monnier 429 val lab = functionLabel f
1172 :     in r := Frag.GEN formals;
1173 :     updtHeapPtr(hp);
1174 :     callSetup(formals, args);
1175 : leunga 585 genCPSFunction(lab, KNOWN, f, vl, formals, tl, e)
1176 : monnier 429 end
1177 :     | Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1178 :     let val formals =
1179 :     if MS.fixedArgPassing then ArgP.fixed tl
1180 : monnier 498 else known tl
1181 : monnier 429 val lab = functionLabel f
1182 : leunga 585 in r := Frag.GEN formals;
1183 : monnier 429 callSetup(formals, args);
1184 :     testLimit hp;
1185 : leunga 585 genCPSFunction(lab, KNOWN_CHECK, f, vl, formals, tl, e)
1186 : monnier 429 end
1187 :     | Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
1188 :     (callSetup(formals, args);
1189 :     testLimit hp;
1190 :     emit(branchToLabel(functionLabel f)))
1191 :     | Frag.STANDARD{fmlTyps, ...} =>
1192 :     let val formals = ArgP.standard(typmap f, fmlTyps)
1193 :     in callSetup(formals, args);
1194 :     testLimit hp;
1195 :     emit(branchToLabel(functionLabel f))
1196 :     end
1197 :     (*esac*))
1198 : monnier 247
1199 : leunga 585 (*
1200 :     * Generate code
1201 :     *)
1202 :    
1203 :     (** RECORD **)
1204 :     and gen(RECORD(RK_FCONT, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1205 :     | gen(RECORD(RK_FBLOCK, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1206 :     | gen(RECORD(RK_VECTOR, vl, w, e), hp) = mkVector(vl, w, e, hp)
1207 :     | gen(RECORD(RK_I32BLOCK, vl, w, e), hp) = mkI32block(vl, w, e, hp)
1208 :     | gen(RECORD(_, vl, w, e), hp) = mkRecord(vl, w, e, hp)
1209 :    
1210 :     (*** SELECT ***)
1211 :     | gen(SELECT(i, INT k, x, t, e), hp) = funnySelect(i,k,x,t,e,hp)
1212 :     | gen(SELECT(i, v, x, FLTt, e), hp) = fselect(i, v, x, e, hp)
1213 :     | gen(SELECT(i, v, x, t, e), hp) = select(i, v, x, t, e, hp)
1214 :    
1215 :     (*** OFFSET ***)
1216 :     | gen(OFFSET(i, v, x, e), hp) =
1217 :     defBoxed(x, scale4(regbind v, INT i), e, hp)
1218 :    
1219 :     (*** APP ***)
1220 :     | gen(APP(INT k, args), hp) = updtHeapPtr(hp)
1221 :     | gen(APP(VAR f, args), hp) = externalApp(f, args, hp)
1222 :     | gen(APP(LABEL f, args), hp) = internalApp(f, args, hp)
1223 :    
1224 : monnier 429 (*** SWITCH ***)
1225 :     | gen(SWITCH(INT _, _, _), hp) = error "SWITCH"
1226 :     | gen(SWITCH(v, _, l), hp) =
1227 :     let val lab = Label.newLabel""
1228 :     val labs = map (fn _ => Label.newLabel"") l
1229 : monnier 498 val tmpR = newReg I32 val tmp = M.REG(ity,tmpR)
1230 : monnier 429 in emit(M.MV(ity, tmpR, laddr(lab, 0)));
1231 : george 546 emit(M.JMP([], M.ADD(addrTy, tmp, M.LOAD(pty, scale4(tmp, v),
1232 : monnier 429 R.readonly)), labs));
1233 :     pseudoOp(PseudoOp.JUMPTABLE{base=lab, targets=labs});
1234 : leunga 585 ListPair.app (fn (lab, e) => genlabCont(lab, e, hp)) (labs, l)
1235 : monnier 429 end
1236 : monnier 247
1237 : monnier 429 (*** PURE ***)
1238 : monnier 498 | gen(PURE(P.pure_arith{oper=P.orb, kind}, [v,w], x, _, e), hp) =
1239 : leunga 585 defWithKind(kind, x, M.ORB(ity, regbind v, regbind w), e, hp)
1240 : monnier 498 | gen(PURE(P.pure_arith{oper=P.andb, kind}, [v,w], x, _, e), hp) =
1241 : leunga 585 defWithKind(kind, x, M.ANDB(ity, regbind v, regbind w), e, hp)
1242 :     | gen(PURE(P.pure_arith{oper, kind}, [v,w], x, ty, e), hp) =
1243 : monnier 429 (case kind
1244 :     of P.INT 31 => (case oper
1245 : leunga 585 of P.xorb => defI31(x, int31xor(v,w), e, hp)
1246 :     | P.lshift => defI31(x, int31lshift(v,w), e, hp)
1247 :     | P.rshift => defI31(x, int31rshift(M.SRA,v,w),e,hp)
1248 : monnier 429 | _ => error "gen:PURE INT 31"
1249 :     (*esac*))
1250 :     | P.INT 32 => (case oper
1251 : monnier 498 of P.xorb => arith32(M.XORB, v, w, x, e, hp)
1252 :     | P.lshift => logical32(M.SLL, v, w, x, e, hp)
1253 :     | P.rshift => logical32(M.SRA, v, w, x, e, hp)
1254 : monnier 429 | _ => error "gen:PURE INT 32"
1255 :     (*esac*))
1256 :     | P.UINT 31 => (case oper
1257 : leunga 585 of P.+ => defI31(x, int31add(M.ADD, v, w), e, hp)
1258 :     | P.- => defI31(x, int31sub(M.SUB, v, w), e, hp)
1259 :     | P.* => defI31(x, int31mul(false, v, w), e, hp)
1260 : monnier 429 | P./ => (* This is not really a pure
1261 :     operation -- oh well *)
1262 : leunga 585 (updtHeapPtr hp;
1263 :     defI31(x, int31div(false, v, w), e, 0))
1264 :     | P.xorb => defI31(x, int31xor(v, w), e, hp)
1265 :     | P.lshift => defI31(x,int31lshift(v, w), e, hp)
1266 :     | P.rshift => defI31(x,int31rshift(M.SRA,v, w),e,hp)
1267 :     | P.rshiftl => defI31(x,int31rshift(M.SRL,v, w),e,hp)
1268 : monnier 429 | _ => error "gen:PURE UINT 31"
1269 :     (*esac*))
1270 :     | P.UINT 32 => (case oper
1271 : monnier 498 of P.+ => arith32(M.ADD, v, w, x, e, hp)
1272 : leunga 585 | P.- => arith32(M.SUB, v, w, x, e, hp)
1273 : monnier 498 | P.* => arith32(M.MULU, v, w, x, e, hp)
1274 : monnier 429 | P./ => (updtHeapPtr hp;
1275 : monnier 498 arith32(M.DIVU, v, w, x, e, 0))
1276 :     | P.xorb => arith32(M.XORB, v, w, x, e, hp)
1277 :     | P.lshift => logical32(M.SLL, v, w, x, e, hp)
1278 :     | P.rshift => logical32(M.SRA, v, w, x, e, hp)
1279 :     | P.rshiftl=> logical32(M.SRL, v, w, x, e, hp)
1280 : monnier 429 | _ => error "gen:PURE UINT 32"
1281 :     (*esac*))
1282 :     (*esac*))
1283 :     | gen(PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) =
1284 : leunga 585 (case kind
1285 :     of P.UINT 32 => defI32(x,M.XORB(ity, regbind v,
1286 : monnier 429 M.LI32 0wxFFFFFFFF), e, hp)
1287 : leunga 585 | P.INT 32 => defI32(x,M.XORB(ity, regbind v,
1288 : monnier 429 M.LI32 0wxFFFFFFFF), e, hp)
1289 : leunga 585 | P.UINT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
1290 :     | P.INT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
1291 : monnier 429 (*esac*))
1292 :     | gen(PURE(P.copy ft, [v], x, _, e), hp) =
1293 :     (case ft
1294 : leunga 585 of (31, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
1295 : monnier 498 | (8, 31) => copy(I31, x, v, e, hp)
1296 : leunga 585 | (8, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
1297 : monnier 498 | (n,m) => if n = m then copyM(m, x, v, e, hp)
1298 : monnier 429 else error "gen:PURE:copy"
1299 :     (*esac*))
1300 :     | gen(PURE(P.extend ft, [v], x, _ ,e), hp) =
1301 :     (case ft
1302 :     of (8,31) =>
1303 : leunga 585 defI31(x,
1304 : monnier 498 M.SRA(ity, M.SLL(ity, regbind v,M.LI 23), M.LI 23),
1305 : monnier 429 e, hp)
1306 :     | (8,32) =>
1307 : leunga 585 defI32(x,
1308 : monnier 498 M.SRA(ity, M.SLL(ity, regbind v, M.LI 23), M.LI 24),
1309 : monnier 429 e, hp)
1310 : leunga 585 | (31,32) => defI32(x, M.SRA(ity, regbind v, one), e, hp)
1311 : monnier 498 | (n, m) => if n = m then copyM(m, x, v, e, hp)
1312 : monnier 429 else error "gen:PURE:extend"
1313 :     (*esac*))
1314 :     | gen(PURE(P.trunc ft, [v], x, _, e), hp) =
1315 :     (case ft
1316 :     of (32, 31) =>
1317 : leunga 585 defI31(x, M.ORB(ity, M.SLL(ity, regbind v, one), one), e, hp)
1318 :     | (31,8) => defI32(x, M.ANDB(ity, regbind v, M.LI 0x1ff), e, hp)
1319 :     | (32,8) => defI32(x, tagUnsigned(M.ANDB(ity, regbind v,
1320 :     M.LI 0xff)), e, hp)
1321 : monnier 498 | (n, m) => if n = m then copyM(m, x, v, e, hp)
1322 : monnier 429 else error "gen:PURE:trunc"
1323 :     (*esac*))
1324 : leunga 585 | gen(PURE(P.real{fromkind=P.INT 31, tokind=P.FLOAT 64},
1325 :     [v], x, _, e), hp) =
1326 :     treeifyDefF64(x,M.CVTI2F(fty,ity,untagSigned(v)), e, hp)
1327 : monnier 429 | gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) =
1328 :     let val r = fregbind v
1329 :     in case oper
1330 : leunga 585 of P.~ => treeifyDefF64(x, M.FNEG(fty,r), e, hp)
1331 :     | P.abs => treeifyDefF64(x, M.FABS(fty,r), e, hp)
1332 : monnier 429 end
1333 :     | gen(PURE(P.objlength, [v], x, _, e), hp) =
1334 : leunga 585 defI31(x, orTag(getObjLength(v)), e, hp)
1335 :     | gen(PURE(P.length, [v], x, t, e), hp) = select(1, v, x, t, e, hp)
1336 : monnier 429 | gen(PURE(P.subscriptv, [v, INT i], x, t, e), hp) =
1337 :     let val region = getRegion(v, 0)
1338 :     (* get data pointer *)
1339 : george 546 val a = markPTR(M.LOAD(ity, regbind v, region))
1340 : monnier 429 val region' = region (* Allen *)
1341 : leunga 585 in defBoxed(x, M.LOAD(ity, scale4(a, INT i), region'), e, hp)
1342 : monnier 429 end
1343 :     | gen(PURE(P.subscriptv, [v, w], x, _, e), hp) =
1344 :     let (* get data pointer *)
1345 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1346 : leunga 585 in defBoxed(x, M.LOAD(ity, scale4(a, w), R.readonly), e, hp)
1347 : monnier 429 end
1348 :     | gen(PURE(P.pure_numsubscript{kind=P.INT 8}, [v,i], x, _, e), hp) =
1349 :     let (* get data pointer *)
1350 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1351 : leunga 585 in defI31(x,tagUnsigned(M.LOAD(8,scale1(a, i), R.memory)), e, hp)
1352 : monnier 429 end
1353 :     | gen(PURE(P.gettag, [v], x, _, e), hp) =
1354 : leunga 585 defI31(x, tagUnsigned(M.ANDB(ity,
1355 : monnier 429 getObjDescriptor(v), M.LI(D.powTagWidth-1))),
1356 :     e, hp)
1357 :     | gen(PURE(P.mkspecial, [i, v], x, _, e), hp) =
1358 :     let val desc = case i
1359 :     of INT n => M.LI(dtoi(D.makeDesc(n, D.tag_special)))
1360 : leunga 585 | _ => M.ORB(ity, M.SLL(ity, untagSigned(i),M.LI D.tagWidth),
1361 : monnier 429 M.LI(dtoi D.desc_special))
1362 : george 546 in (* What gc types are the components? *)
1363 : leunga 585 treeifyAlloc(x,
1364 :     MkRecord.record{desc=desc, fields=[(regbind' v, offp0)],
1365 :     mem=memDisambig x, hp=hp, emit=emit,
1366 :     markPTR=markPTR, markComp=markNothing},
1367 :     e, hp+8)
1368 : monnier 429 end
1369 :     | gen(PURE(P.makeref, [v], x, _, e), hp) =
1370 : leunga 585 let val tag = M.LI(dtoi D.desc_ref)
1371 : monnier 429 val mem = memDisambig x
1372 :     in emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI hp),tag,mem));
1373 :     emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
1374 : leunga 585 regbind' v, mem));
1375 :     treeifyAlloc(x, hp+4, e, hp+8)
1376 : monnier 429 end
1377 : leunga 585 | gen(PURE(P.fwrap,[u],w,_,e), hp) = mkFblock([(u, offp0)],w,e,hp)
1378 :     | gen(PURE(P.funwrap,[u],w,_,e), hp) = fselect(0,u,w,e,hp)
1379 : monnier 429 | gen(PURE(P.iwrap,[u],w,_,e), _) = error "iwrap not implemented"
1380 :     | gen(PURE(P.iunwrap,[u],w,_,e), _) = error "iunwrap not implemented"
1381 :     | gen(PURE(P.i32wrap,[u],w,_,e), hp) =
1382 : leunga 585 mkI32block([(u, offp0)], w, e, hp)
1383 : monnier 429 | gen(PURE(P.i32unwrap,[u],w,_,e), hp) =
1384 : leunga 585 select(0, u, w, INT32t, e, hp)
1385 : monnier 498
1386 :     | gen(PURE(P.wrap,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1387 :     | gen(PURE(P.unwrap,[u],w,_,e), hp) = copy(I32, w, u, e, hp)
1388 :    
1389 : leunga 585 (* Note: the gc type is unsafe! XXX *)
1390 : monnier 498 | gen(PURE(P.cast,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1391 :    
1392 : leunga 585 | gen(PURE(P.getcon,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1393 :     | gen(PURE(P.getexn,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1394 :     | gen(PURE(P.getseqdata, [u], x, t, e), hp) = select(0,u,x,t,e,hp)
1395 : monnier 429 | gen(PURE(P.recsubscript, [v, INT w], x, t, e), hp) =
1396 : leunga 585 select(w,v,x,t,e,hp)
1397 : monnier 429 | gen(PURE(P.recsubscript, [v, w], x, _, e), hp) =
1398 : leunga 585 defI31(x, M.LOAD(ity, scale4(regbind v, w), R.readonly), e, hp)
1399 : monnier 429 | gen(PURE(P.raw64subscript, [v, INT i], x, _, e), hp) =
1400 : leunga 585 fselect(i, v, x, e, hp)
1401 : monnier 429 | gen(PURE(P.raw64subscript, [v, i], x, _, e), hp) =
1402 : leunga 585 treeifyDefF64(x, M.FLOAD(fty,scale8(regbind v, i),R.readonly),
1403 :     e, hp)
1404 : monnier 429 | gen(PURE(P.newarray0, [_], x, t, e), hp) =
1405 :     let val hdrDesc = dtoi(D.desc_polyarr)
1406 :     val dataDesc = dtoi D.desc_ref
1407 : monnier 498 val dataPtr = newReg PTR
1408 : monnier 429 val hdrM = memDisambig x
1409 :     val (tagM, valM) = (hdrM, hdrM) (* Allen *)
1410 : leunga 585 in (* gen code to allocate "ref()" for array data *)
1411 : monnier 429 emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI hp),
1412 :     M.LI dataDesc, tagM));
1413 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI(hp+4)),
1414 :     mlZero, valM));
1415 :     emit(M.MV(pty, dataPtr, M.ADD(addrTy,C.allocptr,M.LI(hp+4))));
1416 : leunga 585 (* gen code to allocate array header *)
1417 :     treeifyAlloc(x,
1418 :     MkRecord.record {
1419 : monnier 429 desc = M.LI hdrDesc,
1420 :     fields = [(M.REG(ity,dataPtr), offp0), (mlZero, offp0)],
1421 : george 546 mem = hdrM, hp = hp + 8, emit=emit,
1422 :     markPTR=markPTR, markComp=markPTR (* boxed components *)
1423 : leunga 585 },
1424 :     e, hp + 20)
1425 : monnier 429 end
1426 :     (*** ARITH ***)
1427 : leunga 585 | gen(ARITH(P.arith{kind=P.INT 31, oper=P.~}, [v], x, _, e), hp) =
1428 :     (updtHeapPtr hp;
1429 :     defI31(x, M.SUBT(ity, M.LI 2, regbind v), e, 0)
1430 :     )
1431 :     | gen(ARITH(P.arith{kind=P.INT 31, oper}, [v, w], x, _, e), hp) =
1432 :     (updtHeapPtr hp;
1433 :     let val t =
1434 :     case oper
1435 :     of P.+ => int31add(M.ADDT, v, w)
1436 :     | P.- => int31sub(M.SUBT, v, w)
1437 :     | P.* => int31mul(true, v, w)
1438 :     | P./ => int31div(true, v, w)
1439 :     | _ => error "gen:ARITH INT 31"
1440 :     in defI31(x, t, e, 0) end
1441 : monnier 429 (*esac*))
1442 :     | gen(ARITH(P.arith{kind=P.INT 32, oper}, [v,w], x, _, e), hp) =
1443 :     (updtHeapPtr hp;
1444 :     case oper
1445 : monnier 498 of P.+ => arith32(M.ADDT, v, w, x, e, 0)
1446 :     | P.- => arith32(M.SUBT, v, w, x, e, 0)
1447 :     | P.* => arith32(M.MULT, v, w, x, e, 0)
1448 :     | P./ => arith32(M.DIVT, v, w, x, e, 0)
1449 : monnier 429 | _ => error "P.arith{kind=INT 32, oper}, [v,w], ..."
1450 :     (*esac*))
1451 :     | gen(ARITH(P.arith{kind=P.INT 32, oper=P.~ }, [v], x, _, e), hp) =
1452 :     (updtHeapPtr hp;
1453 : leunga 585 defI32(x, M.SUBT(ity, zero, regbind v), e, 0))
1454 : monnier 429
1455 :     (* Note: for testu operations we use a somewhat arcane method
1456 :     * to generate traps on overflow conditions. A better approach
1457 :     * would be to generate a trap-if-negative instruction available
1458 :     * on a variety of machines, e.g. mips and sparc (maybe others).
1459 :     *)
1460 :     | gen(ARITH(P.testu(32, 32), [v], x, _, e), hp) =
1461 : monnier 498 let val xreg = newReg I32
1462 : monnier 429 val vreg = regbind v
1463 :     in updtHeapPtr hp;
1464 :     emit(M.MV(ity, xreg, M.ADDT(ity, vreg,
1465 :     regbind(INT32 0wx80000000))));
1466 : leunga 585 defI32(x, vreg, e, 0)
1467 : monnier 429 end
1468 :     | gen(ARITH(P.testu(31, 31), [v], x, _, e), hp) =
1469 : monnier 498 let val xreg = newReg I31
1470 : monnier 429 val vreg = regbind v
1471 :     in updtHeapPtr hp;
1472 :     emit(M.MV(ity,xreg,M.ADDT(ity, vreg,
1473 :     regbind(INT32 0wx80000000))));
1474 : leunga 585 defI31(x, vreg, e, 0)
1475 : monnier 429 end
1476 :     | gen(ARITH(P.testu(32,31), [v], x, _, e), hp) =
1477 :     let val vreg = regbind v
1478 : monnier 498 val tmp = newReg I32
1479 : monnier 429 val tmpR = M.REG(ity,tmp)
1480 :     val lab = Label.newLabel ""
1481 :     in emit(M.MV(ity, tmp, regbind(INT32 0wx3fffffff)));
1482 : leunga 585 updtHeapPtr hp;
1483 : george 546 emit(M.BCC([], M.CMP(32, M.LEU, vreg, tmpR),lab));
1484 : monnier 429 emit(M.MV(ity, tmp, M.SLL(ity, tmpR, one)));
1485 :     emit(M.MV(ity, tmp, M.ADDT(ity, tmpR, tmpR)));
1486 :     defineLabel lab;
1487 : leunga 585 defI31(x, tagUnsigned(vreg), e, 0)
1488 : monnier 429 end
1489 :     | gen(ARITH(P.test(32,31), [v], x, _, e), hp) =
1490 : leunga 585 (updtHeapPtr hp; defI31(x, tagSigned(regbind v), e, 0))
1491 : monnier 429 | gen(ARITH(P.test(n, m), [v], x, _, e), hp) =
1492 : monnier 498 if n = m then copyM(m, x, v, e, hp) else error "gen:ARITH:test"
1493 : leunga 585 | gen(ARITH(P.arith{oper, kind=P.FLOAT 64}, [v,w], x, _, e), hp) =
1494 :     let val v = fregbind v
1495 :     val w = fregbind w
1496 :     val t =
1497 :     case oper
1498 :     of P.+ => M.FADD(fty, v, w)
1499 :     | P.* => M.FMUL(fty, v, w)
1500 :     | P.- => M.FSUB(fty, v, w)
1501 :     | P./ => M.FDIV(fty, v, w)
1502 :     in treeifyDefF64(x, t, e, hp)
1503 : monnier 429 end
1504 :     (*** LOOKER ***)
1505 :     | gen(LOOKER(P.!, [v], x, _, e), hp) =
1506 : leunga 585 defBoxed (x, M.LOAD(ity, regbind v, R.memory), e, hp)
1507 : monnier 429 | gen(LOOKER(P.subscript, [v,w], x, _, e), hp) =
1508 :     let (* get data pointer *)
1509 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1510 : leunga 585 in defBoxed (x, M.LOAD(ity, scale4(a, w), R.memory), e, hp)
1511 : monnier 429 end
1512 :     | gen(LOOKER(P.numsubscript{kind=P.INT 8},[v,i],x,_,e), hp) =
1513 :     let (* get data pointer *)
1514 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1515 : leunga 585 in defI31(x, tagUnsigned(M.LOAD(8,scale1(a, i),R.memory)), e, hp)
1516 : monnier 429 end
1517 :     | gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [v,i], x, _, e), hp)=
1518 :     let (* get data pointer *)
1519 : george 546 val a = markPTR(M.LOAD(ity,regbind v, R.readonly))
1520 : leunga 585 in treeifyDefF64(x, M.FLOAD(fty,scale8(a, i),R.memory), e, hp)
1521 : monnier 429 end
1522 : leunga 585 | gen(LOOKER(P.gethdlr,[],x,_,e), hp) = defBoxed(x, C.exnptr, e, hp)
1523 :     | gen(LOOKER(P.getvar, [], x, _, e), hp)= defBoxed(x, C.varptr, e, hp)
1524 :     | gen(LOOKER(P.deflvar, [], x, _, e), hp)= defBoxed(x, zero, e, hp)
1525 : monnier 429 | gen(LOOKER(P.getspecial, [v], x, _, e), hp) =
1526 : leunga 585 defBoxed(x, orTag(M.SRA(ity, getObjDescriptor(v),
1527 :     M.LI (D.tagWidth-1))),
1528 :     e, hp)
1529 : monnier 429 | gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
1530 :     (print "getpseudo not implemented\n"; nop(x, i, e, hp))
1531 :     (*** SETTER ***)
1532 :     | gen(SETTER(P.assign, [a as VAR arr, v], e), hp) =
1533 :     let val ea = regbind a
1534 :     in recordStore(ea, hp);
1535 :     emit(M.STORE(ity, ea, regbind v, memDisambig arr));
1536 :     gen(e, hp+8)
1537 :     end
1538 :     | gen(SETTER(P.unboxedassign, [a, v], e), hp) =
1539 :     (emit(M.STORE(ity, regbind a, regbind v, R.memory));
1540 :     gen(e, hp))
1541 :     | gen(SETTER(P.update, [v,i,w], e), hp) =
1542 :     let (* get data pointer *)
1543 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1544 : monnier 429 val tmpR = Cells.newReg() (* derived pointer! *)
1545 :     val tmp = M.REG(ity, tmpR)
1546 :     val ea = scale4(a, i) (* address of updated cell *)
1547 :     in emit(M.MV(ity, tmpR, ea));
1548 :     recordStore(tmp, hp);
1549 :     emit(M.STORE(ity, tmp, regbind w, R.memory));
1550 :     gen(e, hp+8)
1551 :     end
1552 :     | gen(SETTER(P.boxedupdate, args, e), hp) =
1553 :     gen(SETTER(P.update, args, e), hp)
1554 :     | gen(SETTER(P.unboxedupdate, [v, i, w], e), hp) =
1555 :     let (* get data pointer *)
1556 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1557 : monnier 429 in emit(M.STORE(ity, scale4(a, i), regbind w, R.memory));
1558 :     gen(e, hp)
1559 :     end
1560 :     | gen(SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) =
1561 :     let (* get data pointer *)
1562 : george 546 val a = markPTR(M.LOAD(ity, regbind s, R.readonly))
1563 : monnier 429 val ea = scale1(a, i)
1564 : leunga 585 in emit(M.STORE(8,ea, untagUnsigned(v), R.memory));
1565 : monnier 429 gen(e, hp)
1566 :     end
1567 :     | gen(SETTER(P.numupdate{kind=P.FLOAT 64},[v,i,w],e), hp) =
1568 :     let (* get data pointer *)
1569 : george 546 val a = markPTR(M.LOAD(ity, regbind v, R.readonly))
1570 : monnier 429 in emit(M.FSTORE(fty,scale8(a, i), fregbind w, R.memory));
1571 :     gen(e, hp)
1572 :     end
1573 :     | gen(SETTER(P.setspecial, [v, i], e), hp) =
1574 :     let val ea = M.SUB(ity, regbind v, M.LI 4)
1575 :     val i' =
1576 :     case i
1577 :     of INT k => M.LI(dtoi(D.makeDesc(k, D.tag_special)))
1578 : leunga 585 | _ => M.ORB(ity, M.SLL(ity, untagSigned(i),
1579 : monnier 429 M.LI D.tagWidth),
1580 :     M.LI(dtoi D.desc_special))
1581 :     in emit(M.STORE(ity, ea, i',R.memory));
1582 :     gen(e, hp)
1583 :     end
1584 :     | gen(SETTER(P.sethdlr,[x],e), hp) =
1585 : leunga 585 (emit(assign(C.exnptr, regbind x)); gen(e, hp))
1586 : monnier 429 | gen(SETTER(P.setvar,[x],e), hp) =
1587 : leunga 585 (emit(assign(C.varptr, regbind x)); gen(e, hp))
1588 : monnier 429 | gen(SETTER(P.uselvar,[x],e), hp) = gen(e, hp)
1589 :     | gen(SETTER(P.acclink,_,e), hp) = gen(e, hp)
1590 :     | gen(SETTER(P.setmark,_,e), hp) = gen(e, hp)
1591 :     | gen(SETTER(P.free,[x],e), hp) = gen(e, hp)
1592 :     | gen(SETTER(P.setpseudo,_,e), hp) =
1593 :     (print "setpseudo not implemented\n"; gen(e, hp))
1594 :    
1595 :     (*** BRANCH ***)
1596 :     | gen(BRANCH(P.cmp{oper,kind=P.INT 31},[INT v, INT k],_,e,d), hp) =
1597 : leunga 585 if (case oper
1598 :     of P.> => v>k
1599 :     | P.>= => v>=k
1600 :     | P.< => v<k
1601 :     | P.<= => v<=k
1602 :     | P.eql => v=k
1603 :     | P.neq => v<>k
1604 :     (*esac*))
1605 :     then gen(e, hp)
1606 :     else gen(d, hp)
1607 : monnier 429 | gen(BRANCH(P.cmp{oper, kind=P.INT 31}, vw, _, e, d), hp) =
1608 :     branch(signedCmp oper, vw, e, d, hp)
1609 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 31},[INT v', INT k'],_,e,d),hp)=
1610 :     let open Word
1611 :     val v = fromInt v'
1612 :     val k = fromInt k'
1613 :     in if (case oper
1614 :     of P.> => v>k
1615 :     | P.>= => v>=k
1616 :     | P.< => v<k
1617 :     | P.<= => v<=k
1618 :     | P.eql => v=k
1619 :     | P.neq => v<>k
1620 :     (*esac*))
1621 :     then gen(e, hp)
1622 :     else gen(d, hp)
1623 :     end
1624 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 31}, vw, _, e, d), hp) =
1625 :     branch(unsignedCmp oper, vw, e, d, hp)
1626 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 32},[INT32 v,INT32 k],_,e,d),
1627 :     hp) =
1628 :     let open Word32
1629 :     in if (case oper
1630 :     of P.> => v>k
1631 :     | P.>= => v>=k
1632 :     | P.< => v<k
1633 :     | P.<= => v<=k
1634 :     | P.eql => v=k
1635 :     | P.neq => v<>k
1636 :     (*esac*))
1637 :     then gen(e, hp)
1638 :     else gen(d, hp)
1639 :     end
1640 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 32}, vw, _, e, d), hp) =
1641 :     branch(unsignedCmp oper, vw, e, d, hp)
1642 :    
1643 :     | gen(BRANCH(P.cmp{oper, kind=P.INT 32}, vw, _, e, d), hp) =
1644 :     branch(signedCmp oper, vw, e, d, hp)
1645 :     | gen(BRANCH(P.fcmp{oper,size=64}, [v,w], _, d, e), hp) =
1646 :     let val trueLab = Label.newLabel""
1647 :     val fcond =
1648 :     case oper
1649 :     of P.fEQ => M.==
1650 :     | P.fULG => M.?<>
1651 :     | P.fUN => M.?
1652 :     | P.fLEG => M.<=>
1653 :     | P.fGT => M.>
1654 :     | P.fGE => M.>=
1655 :     | P.fUGT => M.?>
1656 :     | P.fUGE => M.?>=
1657 :     | P.fLT => M.<
1658 :     | P.fLE => M.<=
1659 :     | P.fULT => M.?<
1660 :     | P.fULE => M.?<=
1661 :     | P.fLG => M.<>
1662 :     | P.fUE => M.?=
1663 :    
1664 :     val cmp = M.FCMP(64, fcond, fregbind v, fregbind w)
1665 : george 546 in emit(M.BCC([], cmp, trueLab));
1666 : leunga 585 genCont(e, hp);
1667 : monnier 429 genlab(trueLab, d, hp)
1668 :     end
1669 :     | gen(BRANCH(P.peql, vw, _,e,d), hp) = branch(M.EQ, vw, e, d, hp)
1670 :     | gen(BRANCH(P.pneq, vw, _, e, d), hp) = branch(M.NE, vw, e, d, hp)
1671 : leunga 585 | gen(BRANCH(P.strneq, [INT n,v,w], _, d, e), hp) =
1672 :     branchStreq(n,v,w,e,d,hp)
1673 : monnier 429 | gen(BRANCH(P.streq, [INT n,v,w],_,d,e), hp) =
1674 : leunga 585 branchStreq(n,v,w,d,e,hp)
1675 :     | gen(BRANCH(P.boxed, [x], _, a, b), hp) = branchOnBoxed(x,a,b,hp)
1676 :     | gen(BRANCH(P.unboxed, [x], _, a, b), hp) = branchOnBoxed(x,b,a,hp)
1677 : monnier 429 | gen(e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
1678 : leunga 585
1679 :     end (*local*)
1680 : monnier 429
1681 :     fun fragComp() =
1682 :     let fun continue() = fcomp (Frag.next())
1683 :     and fcomp(NONE) = ()
1684 :     | fcomp(SOME(_, Frag.KNOWNFUN _)) = continue()
1685 :     | fcomp(SOME(_, Frag.KNOWNCHK _)) = continue()
1686 :     | fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue()
1687 :     | fcomp(SOME(lab,
1688 : leunga 585 Frag.STANDARD{func as ref(SOME (zz as (k,f,vl,tl,e))),
1689 : monnier 429 ...})) =
1690 : leunga 585 let val formals = ArgP.standard(typmap f, tl)
1691 :     in func := NONE;
1692 :     pseudoOp PseudoOp.ALIGN4;
1693 :     genCPSFunction(lab, k, f, vl, formals, tl, e);
1694 :     continue()
1695 : monnier 429 end
1696 :     in fcomp (Frag.next())
1697 :     end (* fragComp *)
1698 : monnier 247
1699 : monnier 429 (*
1700 :     * execution starts at the first CPS function -- the frag
1701 :     * is maintained as a queue.
1702 :     *)
1703 :     fun initFrags (start::rest : CPS.function list) =
1704 :     let fun init(func as (fk, f, _, _, _)) =
1705 :     addGenTbl (f, Frag.makeFrag(func, functionLabel f))
1706 :     in app init rest;
1707 :     init start
1708 : monnier 247 end
1709 :     in
1710 : monnier 498 initFrags cluster;
1711 :     beginCluster 0;
1712 : george 546 if gctypes then Intmap.clear(GCCells.getGCMap()) else ();
1713 : monnier 429 fragComp();
1714 :     InvokeGC.emitLongJumpsToGCInvocation stream;
1715 :     endCluster(
1716 : george 546 if gctypes then
1717 : monnier 429 let val gcmap = GCCells.getGCMap()
1718 : monnier 475 in [#create SMLGCMap.GCMAP gcmap,
1719 : monnier 469 #create
1720 : george 546 MLRiscAnnotations.REGINFO(
1721 :     let val pr = SMLGCMap.toString gcmap
1722 :     in fn (_,r) => pr r end
1723 :     )
1724 : monnier 429 ]
1725 :     end
1726 :     else []
1727 :     )
1728 :     end (* genCluster *)
1729 : monnier 247
1730 : monnier 469 fun emitMLRiscUnit f =
1731 : monnier 429 (Cells.reset();
1732 :     beginCluster 0;
1733 :     f stream;
1734 : leunga 585 endCluster NO_OPT
1735 : monnier 429 )
1736 :     in app mkGlobalTables funcs;
1737 :     app genCluster (Cluster.cluster funcs);
1738 : leunga 586 emitMLRiscUnit InvokeGC.emitModuleGC
1739 : monnier 247 end (* codegen *)
1740 :     end (* MLRiscGen *)
1741 :    

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