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

Annotation of /sml/branches/arith64/compiler/CodeGen/main/mlriscGen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4874 - (view) (download)

1 : jhr 4454 (* mlriscGen.sml
2 : jhr 4242 *
3 : jhr 4874 * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org)
4 : jhr 4454 * All rights reserved.
5 :     *
6 :     * Translate CPS to MLRISC.
7 :     *
8 : monnier 429 * This version of MLRiscGen also injects GC types to the MLRISC backend.
9 :     * I've also reorganized it a bit and added a few comments
10 :     * so that I can understand it.
11 : monnier 247 *)
12 :    
13 : jhr 4242 signature MLRISCGEN =
14 : monnier 429 sig
15 : blume 977 val codegen : { funcs: CPS.function list,
16 :     limits: CPS.lvar -> int * int,
17 :     err: ErrorMsg.complainer,
18 : blume 986 source: string }
19 : blume 1128 -> (unit -> int)
20 :     (* The result is a thunk around the address of the resulting code
21 :     * object's entry point. The client must promise to first call
22 :     * "finish" before forcing it. *)
23 : monnier 247 end
24 :    
25 : jhr 4874 functor MLRiscGen (
26 :     structure MachineSpec: MACH_SPEC
27 : blume 773 structure Ext : SMLNJ_MLTREE_EXT
28 : jhr 4242 structure C : CPSREGS
29 :     where T.Region = CPSRegions
30 : george 984 and T.Constant = SMLNJConstant
31 :     and T.Extension = Ext
32 :     structure ClientPseudoOps : SMLNJ_PSEUDO_OPS
33 :     structure PseudoOp : PSEUDO_OPS
34 :     where T = C.T
35 :     and Client = ClientPseudoOps
36 : jhr 4242 structure MLTreeComp : MLTREECOMP
37 : george 984 where TS.T = C.T
38 :     and TS.S.P = PseudoOp
39 : jhr 4242 structure Flowgen : CONTROL_FLOWGRAPH_GEN
40 : george 984 where S = MLTreeComp.TS.S
41 : george 909 and I = MLTreeComp.I
42 : jhr 4242 and CFG = MLTreeComp.CFG
43 :     structure InvokeGC : INVOKE_GC
44 : george 984 where TS = MLTreeComp.TS
45 : george 909 and CFG = Flowgen.CFG
46 :    
47 : jhr 4242 structure Cells : CELLS
48 :     structure CCalls : C_CALLS
49 : george 909 where T = C.T
50 :     val compile : Flowgen.CFG.cfg -> unit
51 : leunga 585 ) : MLRISCGEN =
52 : monnier 247 struct
53 :    
54 : george 984 structure M = C.T (* MLTree *)
55 :     structure E = Ext (* Extensions *)
56 :     structure P = CPS.P (* CPS primitive operators *)
57 :     structure R = CPSRegions (* Regions *)
58 :     structure PT = R.PT (* PointsTo *)
59 :     structure CG = Control.CG (* Compiler Control *)
60 :     structure MS = MachineSpec (* Machine Specification *)
61 :     structure D = MS.ObjDesc (* ML Object Descriptors *)
62 :     structure TS = MLTreeComp.TS (* MLTREE streams *)
63 :     structure CPs = ClientPseudoOps
64 :     structure PB = PseudoOpsBasisTyp
65 : george 823 structure An = MLRiscAnnotations
66 : george 889 structure CB = CellsBasis
67 : jhr 4242
68 : leunga 585 structure ArgP = (* Argument passing *)
69 : monnier 247 ArgPassing(structure Cells=Cells
70 : monnier 429 structure C=C
71 :     structure MS=MachineSpec)
72 : monnier 247
73 : leunga 585 structure Frag = Frag(M) (* Decompose a compilation unit into clusters *)
74 : monnier 247
75 : leunga 585 structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)
76 : leunga 1174
77 :     structure CPSCCalls = (* C-Calls handling *)
78 :     CPSCCalls(structure MS = MachineSpec
79 :     structure C = C
80 :     structure MLTreeComp = MLTreeComp
81 :     structure Cells = Cells
82 : jhr 4242 structure CCalls = CCalls
83 : leunga 1174 )
84 : jhr 4242
85 : leunga 585 fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)
86 : monnier 247
87 : jhr 4242 (*
88 : leunga 585 * Debugging
89 :     *)
90 :     fun printCPSFun cps =
91 :     (Control.Print.say "*********************************************** \n";
92 :     PPCps.printcps0 cps;
93 :     Control.Print.say "*********************************************** \n";
94 :     Control.Print.flush()
95 :     )
96 :     val print = Control.Print.say
97 :    
98 : jhr 4242
99 : monnier 429 (*
100 : jhr 4242 * GC Safety
101 : monnier 429 *)
102 : monnier 247
103 : jhr 4874 (* How to annotate GC information *)
104 :     structure GCCells = GCCells(
105 :     structure C = Cells
106 :     structure GC = SMLGCType)
107 :    
108 :     val TAGINT = SMLGCType.TAGGED_INT
109 :     val INT = SMLGCType.INT
110 : jhr 4454 (* REAL32: *)
111 : monnier 498 val REAL64 = SMLGCType.REAL64 (* untagged floats *)
112 :     val PTR = SMLGCType.PTR (* boxed objects *)
113 : george 823 val NO_OPT = [#create An.NO_OPTIMIZATION ()]
114 : monnier 429
115 : leunga 775 val enterGC = GCCells.setGCType
116 : leunga 585
117 : george 889 fun sameRegAs x y = CB.sameCell (x, y)
118 : blume 838
119 : jhr 4874 val annPTR = #create An.MARK_REG(fn r => enterGC(r,PTR))
120 :     val annINT = #create An.MARK_REG(fn r => enterGC(r,INT))
121 :     val annTAGINT = #create An.MARK_REG(fn r => enterGC(r,TAGINT))
122 :     val annREAL64 = #create An.MARK_REG(fn r => enterGC(r,REAL64))
123 :    
124 :     fun ctyToAnn (CPS.NUMt{tag=true, ...}) = annTAGINT
125 :     | ctyToAnn (CPS.NUMt{tag=false, ...}) = annINT
126 :     | ctyToAnn (CPS.FLTt 64) = annREAL64
127 :     (* REAL32: FIXME *)
128 : jhr 4717 | ctyToAnn (CPS.FLTt n) = raise Fail(concat["ctyToAnn: FLTt ", Int.toString n, " is unsupported"])
129 : jhr 4874 | ctyToAnn _ = annPTR
130 : leunga 585
131 : jhr 4874 (* Convert kind to gc type *)
132 :     fun kindToGCty (CPS.P.INT sz) = if (sz = Target.defaultIntSz) then TAGINT else INT
133 :     | kindToGCty (CPS.P.UINT sz) = if (sz = Target.defaultIntSz) then TAGINT else INT
134 :     | kindToGCty _ = error "kindToGCty: bogus kind"
135 : george 546
136 : jhr 4874 (* convert CPS type to gc type *)
137 : jhr 4454 fun ctyToGCty (CPS.FLTt 64) = REAL64
138 : jhr 4717 | ctyToGCty (CPS.FLTt n) = raise Fail(concat["ctyToGCty: FLTt ", Int.toString n, " is unsupported"])
139 : jhr 4874 | ctyToGCty (CPS.NUMt{tag=true, ...}) = TAGINT
140 :     | ctyToGCty (CPS.NUMt{tag=false, ...}) = INT
141 : jhr 4454 | ctyToGCty _ = PTR
142 : leunga 624
143 : jhr 4874 (* Make a GC livein/liveout annotation *)
144 : leunga 624 fun gcAnnotation(an, args, ctys) =
145 :     let fun collect(M.GPR(M.REG(_,r))::args,cty::ctys,gctys) =
146 :     collect(args,ctys,(r,ctyToGCty cty)::gctys)
147 :     | collect(M.FPR(M.FREG(_,r))::args,cty::ctys,gctys) =
148 :     collect(args,ctys,(r,ctyToGCty cty)::gctys)
149 :     | collect(_::args,_::ctys,gctys) = collect(args,ctys,gctys)
150 :     | collect([], [], gctys) = gctys
151 :     | collect _ = error "gcAnnotation"
152 :     in an(collect(args, ctys, [])) end
153 : jhr 4242
154 : monnier 429 (*
155 :     * These are the type widths of ML. They are hardwired for now.
156 :     *)
157 : jhr 4874 (* QUESTION: do we care about the redundancy between Target.mlValueSz and MS.wordBitWidth? *)
158 : jhr 4316 val pty = MS.wordBitWidth (* size of ML's pointer *)
159 :     val ity = MS.wordBitWidth (* size of ML's integer *)
160 : monnier 429 val fty = 64 (* size of ML's real number *)
161 : jhr 4316 val ws = MS.wordByteWidth
162 : monnier 247
163 : mblume 1347 val zero = M.LI 0
164 :     val one = M.LI 1
165 :     val two = M.LI 2
166 : jhr 4874 val allOnes = M.LI(ConstArith.bNot(ity, 0)) (* machine word all 1s *)
167 :     val allOnes' = M.LI(ConstArith.bNot(Target.defaultIntSz, 0)) (* tagged int all 1s *)
168 :     val signBit = M.LI(IntInf.<<(1, Word.fromInt ity - 0w1))
169 : leunga 775 val mlZero = one (* tagged zero *)
170 : jhr 4242 val offp0 = CPS.OFFp 0
171 : jhr 4550 val LI = M.LI
172 :     fun LI' i = LI (M.I.fromInt(ity, i))
173 :     fun LW' w = LI (M.I.fromWord(ity, w))
174 : jhr 4242
175 : jhr 4550 val constBaseRegOffset = LI' MachineSpec.constBaseRegOffset
176 :    
177 : jhr 4874 (* CPS tagged integer constants *)
178 : jhr 4560 local
179 :     val ty = {sz = Target.defaultIntSz, tag = true}
180 :     in
181 : jhr 4874 fun cpsInt n = CPS.NUM{ival = IntInf.fromInt n, ty = ty}
182 : jhr 4560 end (* local *)
183 :    
184 : monnier 429 (*
185 : leunga 585 * The allocation pointer. This must be a register
186 : monnier 429 *)
187 : jhr 4548 val M.REG(_,allocptrR) = C.allocptr
188 : monnier 247
189 : monnier 429 (*
190 :     * Dedicated registers.
191 :     *)
192 : george 555 val dedicated' =
193 : jhr 4874 map (fn r => M.GPR(M.REG(ity,r))) C.dedicatedR @
194 :     map (fn f => M.FPR(M.FREG(fty,f))) C.dedicatedF
195 : monnier 429
196 : jhr 4874 val dedicated = (case C.exhausted
197 :     of NONE => dedicated'
198 :     | SOME cc => M.CCR cc :: dedicated'
199 :     (* end case *))
200 : monnier 247
201 : leunga 585 (*
202 :     * This flag controls whether extra MLRISC optimizations should be
203 :     * performed. By default, this is off.
204 :     *)
205 : blume 1126 val mlrisc = Control.MLRISC.mkFlag ("mlrisc", "whether to do MLRISC optimizations")
206 : monnier 498
207 : jhr 4242 (*
208 :     * If this flag is on then annotate the registers with GC type info.
209 : monnier 429 * Otherwise use the default behavior.
210 :     *)
211 : blume 1126 val gctypes = Control.MLRISC.mkFlag ("mlrisc-gc-types", "whether to use GC type info")
212 : george 546
213 :     (*
214 : jhr 4242 * If this flag is on then perform optimizations before generating gc code.
215 : george 546 * If this flag is on then gctypes must also be turned on!
216 :     * Otherwise use the default behavior.
217 :     *)
218 : blume 1126 val gcsafety = Control.MLRISC.mkFlag ("mlrisc-gcsafety",
219 :     "whether to optimize before generating GC code")
220 : monnier 411
221 : monnier 429 (*
222 : monnier 475 * If this flag is on then split the entry block.
223 : jhr 4242 * This should be on for SSA optimizations.
224 : monnier 429 *)
225 : blume 1126 val splitEntry = Control.MLRISC.mkFlag ("split-entry-block", "whether to split entry block")
226 : monnier 247
227 : monnier 429 (*
228 : jhr 4242 * This dummy annotation is used to get an empty block
229 : monnier 475 *)
230 : george 823 val EMPTY_BLOCK = #create An.EMPTY_BLOCK ()
231 : jhr 4242
232 :     val newLabel = Label.anon
233 : leunga 585
234 :     (*
235 :     * The main codegen function.
236 :     *)
237 : jhr 4874 fun codegen args = let
238 : blume 977 val { funcs : CPS.function list,
239 :     limits:CPS.lvar -> (int*int),
240 : blume 986 err, source } =
241 :     args
242 : monnier 429 val maxAlloc = #1 o limits
243 : monnier 475 val splitEntry = !splitEntry
244 : monnier 247
245 : monnier 429 (*
246 : jhr 4242 * The natural address arithmetic width of the architecture.
247 : monnier 247 *)
248 : jhr 4381 val addrTy = MachineSpec.addressBitWidth
249 : monnier 247
250 : jhr 4242 (*
251 : leunga 585 * These functions generate new virtual register names and
252 :     * mark expressions with their gc types.
253 : monnier 429 * When the gc-safety feature is turned on, we'll use the
254 :     * versions of newReg that automatically update the GCMap.
255 :     * Otherwise, we'll just use the normal version.
256 : monnier 247 *)
257 : george 546 val gctypes = !gctypes
258 : leunga 586
259 : jhr 4242 val (newReg, newRegWithCty, newRegWithKind, newFreg) =
260 :     if gctypes then
261 : george 889 let val newReg = GCCells.newCell CB.GP
262 :     val newFreg = GCCells.newCell CB.FP
263 : leunga 585 fun newRegWithCty cty = newReg(ctyToGCty cty)
264 :     fun newRegWithKind kind = newReg(kindToGCty kind)
265 :     in (newReg, newRegWithCty, newRegWithKind, newFreg) end
266 :     else (Cells.newReg, Cells.newReg, Cells.newReg, Cells.newFreg)
267 :    
268 : jhr 4874 fun markPTR e = if gctypes then M.MARK(e, annPTR) else e
269 :     fun markINT e = if gctypes then M.MARK(e, annINT) else e
270 :     fun markREAL64 e = if gctypes then M.FMARK(e, annREAL64) else e
271 :     fun markGC (e, cty) = if gctypes then M.MARK(e, ctyToAnn cty) else e
272 : george 546 fun markNothing e = e
273 : monnier 247
274 : monnier 498 (*
275 : jhr 4242 * Known functions have parameters passed in fresh temporaries.
276 : monnier 498 * We also annotate the gc types of these temporaries.
277 :     *)
278 :     fun known [] = []
279 : jhr 4717 | known (cty::rest) = (case cty
280 : jhr 4874 of CPS.FLTt 64 => M.FPR(M.FREG(fty, newFreg REAL64))
281 :     (* REAL32: FIXME *)
282 : jhr 4717 | CPS.FLTt n => raise Fail(concat["known: FLTt ", Int.toString n, " is unsupported"]) (* REAL32: FIXME *)
283 : jhr 4874 | CPS.NUMt{tag=true, ...} => M.GPR(M.REG(ity, newReg TAGINT))
284 :     | CPS.NUMt{tag=false, ...} => M.GPR(M.REG(ity, newReg INT))
285 : jhr 4454 | _ => M.GPR(M.REG(pty,newReg PTR))
286 :     (* end case *)) :: known rest
287 : monnier 247
288 : jhr 4242 (*
289 : leunga 585 * labelTbl is a mapping of function names (CPS.lvars) to labels.
290 :     * If the flag splitEntry is on, we also distinguish between external and
291 :     * internal labels, make sure that no directly branches go to the
292 : jhr 4242 * external labels.
293 : leunga 585 *)
294 : monnier 429 exception LabelBind and TypTbl
295 : blume 733 val labelTbl : Label.label IntHashTable.hash_table =
296 :     IntHashTable.mkTable(32, LabelBind)
297 :     val functionLabel = IntHashTable.lookup labelTbl
298 :     val addLabelTbl = IntHashTable.insert labelTbl
299 : monnier 247
300 : jhr 4242 (*
301 : leunga 585 * typTbl is a mapping of CPS.lvars to CPS types
302 : jhr 4242 *)
303 : blume 733 val typTbl : CPS.cty IntHashTable.hash_table =
304 :     IntHashTable.mkTable(32, TypTbl)
305 :     val addTypBinding = IntHashTable.insert typTbl
306 :     val typmap = IntHashTable.lookup typTbl
307 : monnier 411
308 : leunga 585 (*
309 :     * mkGlobalTables define the labels and cty for all CPS functions
310 :     *)
311 : monnier 429 fun mkGlobalTables(fk, f, _, _, _) =
312 : monnier 475 ((* internal label *)
313 : george 909 addLabelTbl (f, newLabel());
314 : monnier 475 (* external entry label *)
315 :     if splitEntry then
316 :     (case fk of
317 : jhr 4242 (CPS.CONT | CPS.ESCAPE) =>
318 : george 909 addLabelTbl (~f-1, Label.label(Int.toString f) ())
319 : monnier 475 | _ => ()
320 :     )
321 :     else ();
322 : monnier 429 case fk
323 :     of CPS.CONT => addTypBinding(f, CPS.CNTt)
324 :     | _ => addTypBinding(f, CPS.BOGt)
325 :     (*esac*))
326 : monnier 247
327 : george 1168 val brProb = CpsBranchProb.branchProb funcs
328 :    
329 :     fun branchWithProb(br, NONE) = br
330 : jhr 4242 | branchWithProb(br, SOME prob) =
331 : george 1168 M.ANNOTATION(br, #create MLRiscAnnotations.BRANCH_PROB prob)
332 :    
333 : george 1116 (*
334 : jhr 4242 * A CPS register may be implemented as a physical
335 : george 1116 * register or a memory location. The function assign moves a
336 :     * value v into a register or a memory location.
337 :     *)
338 :     fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
339 :     | assign(M.LOAD(ty, ea, mem), v) = M.STORE(ty, ea, v, mem)
340 :     | assign _ = error "assign"
341 :    
342 : jhr 4242
343 : monnier 429 (*
344 :     * Function for generating code for one cluster.
345 : monnier 247 *)
346 : george 909 fun genCluster(cluster) = let
347 :     val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
348 : george 823
349 : george 909 (*
350 :     * The mltree stream
351 :     *)
352 : george 984 val stream as TS.S.STREAM
353 : george 909 { beginCluster, (* start a cluster *)
354 :     endCluster, (* end a cluster *)
355 :     emit, (* emit MLTREE stm *)
356 :     defineLabel, (* define a local label *)
357 : jhr 4242 entryLabel, (* define an external entry *)
358 : george 909 exitBlock, (* mark the end of a procedure *)
359 :     pseudoOp, (* emit a pseudo op *)
360 :     annotation, (* add an annotation *)
361 : jhr 4242 ...
362 : george 933 } = MLTreeComp.selectInstructions (Flowgen.build ())
363 : george 909
364 : george 823 (*
365 :     * If RCC is present we need to use the virtual frame pointer
366 :     *)
367 :     local
368 :     fun hasRCC([]) = false
369 : blume 840 | hasRCC((_,_,_,_,cexp)::rest) =
370 :     CPS.hasRCC(cexp) orelse hasRCC(rest)
371 : george 823 in
372 : blume 840 val vfp = not MS.framePtrNeverVirtual andalso hasRCC(cluster)
373 : george 823 val _ = ClusterAnnotation.useVfp := vfp
374 :     end
375 :    
376 :     (*
377 :     * This is the GC comparison test used. We have a choice of signed
378 :     * and unsigned comparisons. This usually doesn't matter, but some
379 : jhr 4242 * architectures work better in one way or the other, so we are given
380 : george 823 * a choice here. For example, the Alpha has to do extra for unsigned
381 :     * tests, so on the Alpha we use signed tests.
382 :     *)
383 : jhr 4242 val gcTest = M.CMP(pty, if C.signedGCTest then M.GT else M.GTU,
384 : george 823 C.allocptr, C.limitptr(vfp))
385 :    
386 : monnier 429 val clusterSize = length cluster
387 : monnier 247
388 : monnier 429 (* per-cluster tables *)
389 : jhr 4242 exception RegMap and GenTbl
390 : leunga 585
391 : jhr 4242 (*
392 :     * genTbl -- is used to retrieve the parameter passing
393 : monnier 429 * conventions once a function has been compiled.
394 :     *)
395 : blume 733 val genTbl : Frag.frag IntHashTable.hash_table =
396 :     IntHashTable.mkTable(clusterSize, GenTbl)
397 :     val addGenTbl = IntHashTable.insert genTbl
398 :     val lookupGenTbl = IntHashTable.lookup genTbl
399 : monnier 247
400 : jhr 4242 (*
401 :     * {fp,gp}RegTbl -- mapping of lvars to registers
402 : monnier 429 *)
403 : blume 733 val fpRegTbl : M.fexp IntHashTable.hash_table =
404 :     IntHashTable.mkTable(2, RegMap)
405 :     val gpRegTbl : M.rexp IntHashTable.hash_table =
406 :     IntHashTable.mkTable(32, RegMap)
407 :     val addExpBinding = IntHashTable.insert gpRegTbl
408 : monnier 429 fun addRegBinding(x,r) = addExpBinding(x,M.REG(ity,r))
409 : blume 733 val addFregBinding = IntHashTable.insert fpRegTbl
410 : monnier 247
411 : monnier 429 (*
412 : jhr 4242 * The following function is used to translate CPS into
413 : leunga 585 * larger trees. Definitions marked TREEIFY can be forward
414 :     * propagated to their (only) use. This can drastically reduce
415 :     * register pressure.
416 : monnier 429 *)
417 : leunga 585 datatype treeify = TREEIFY | TREEIFIED | COMPUTE | DEAD
418 : jhr 4242 exception UseCntTbl
419 : blume 733 val useCntTbl : treeify IntHashTable.hash_table =
420 : jhr 4874 IntHashTable.mkTable(32, UseCntTbl)
421 : blume 733 fun treeify i = getOpt (IntHashTable.find useCntTbl i, DEAD)
422 :     val addCntTbl = IntHashTable.insert useCntTbl
423 : leunga 585 fun markAsTreeified r = addCntTbl(r, TREEIFIED)
424 : jhr 4874
425 : leunga 585 (*
426 :     * Reset the bindings and use count tables. These tables
427 :     * can be reset at the same time.
428 :     *)
429 : jhr 4874 fun clearTables() = (
430 :     IntHashTable.clear gpRegTbl;
431 :     IntHashTable.clear fpRegTbl;
432 :     IntHashTable.clear useCntTbl)
433 : monnier 247
434 : jhr 4242 (*
435 :     * memDisambiguation uses the new register counters,
436 : monnier 429 * so this must be reset here.
437 :     *)
438 :     val _ = Cells.reset()
439 : jhr 4242 val memDisambig = MemAliasing.analyze(cluster)
440 : monnier 247
441 : monnier 429 (*
442 :     * Points-to analysis projection.
443 :     *)
444 : jhr 4874 fun pi (x as ref(PT.TOP _), _) = x
445 :     | pi (x, i) = PT.pi(x, i)
446 : monnier 247
447 : monnier 429 val memDisambigFlag = !CG.memDisambiguate
448 : monnier 247
449 : jhr 4242 fun getRegion e =
450 :     if memDisambigFlag then
451 : monnier 429 (case e of
452 : leunga 590 CPS.VAR v => memDisambig v
453 :     | _ => R.readonly
454 :     )
455 :     else R.memory
456 :    
457 : jhr 4874 fun getRegionPi (e, i) = if memDisambigFlag
458 :     then (case e
459 :     of CPS.VAR v => pi(memDisambig v, i)
460 :     | _ => R.readonly)
461 : leunga 590 else R.memory
462 : monnier 411
463 : leunga 590 fun dataptrRegion v = getRegionPi(v, 0)
464 :    
465 :     (* fun arrayRegion(x as ref(PT.TOP _)) = x
466 : jhr 4242 | arrayRegion x = PT.weakSubscript x *)
467 : leunga 590 (* For safety, let's assume it's the global memory right now *)
468 : jhr 4242 fun arrayRegion _ = R.memory
469 : leunga 590
470 : leunga 585 (* This keeps track of all the advanced offset on the hp
471 :     * since the beginning of the CPS function.
472 :     * This is important for generating the correct address offset
473 :     * for newly allocated records.
474 : monnier 429 *)
475 : jhr 4242 val advancedHP = ref 0
476 :    
477 : monnier 429 (*
478 :     * Function grabty lookups the CPS type of a value expression in CPS.
479 :     *)
480 : jhr 4454 fun grabty (CPS.VAR v) = typmap v
481 :     | grabty (CPS.LABEL v) = typmap v
482 : jhr 4560 | grabty (CPS.NUM{ty, ...}) = CPS.NUMt ty
483 : jhr 4454 | grabty (CPS.VOID) = CPS.FLTt 64 (* why? *)
484 : monnier 429 | grabty _ = CPS.BOGt
485 : monnier 247
486 : jhr 4242 (*
487 :     * The baseptr contains the start address of the entire
488 : monnier 429 * compilation unit. This function generates the address of
489 :     * a label that is embedded in the same compilation unit. The
490 :     * generated address is relative to the baseptr.
491 : monnier 498 *
492 :     * Note: For GC safety, we considered this to be an object reference
493 : monnier 429 *)
494 : jhr 4550 fun laddr (lab, k) = let
495 :     val e = M.ADD(addrTy, C.baseptr vfp,
496 :     M.LABEXP(M.ADD(addrTy, M.LABEL lab,
497 :     LI'(k - MachineSpec.constBaseRegOffset))))
498 :     in
499 :     markPTR e
500 :     end
501 : monnier 247
502 : monnier 429 (*
503 :     * The following function looks up the MLTREE expression associated
504 : jhr 4242 * with a general purpose value expression.
505 : monnier 429 *)
506 : jhr 4242 val lookupGpRegTbl = IntHashTable.lookup gpRegTbl
507 : leunga 585
508 :     (*
509 :     * This function resolve the address computation of the
510 :     * form M.CONST k, where offset is a reference to the
511 :     * kth byte allocated since the beginning of the CPS function.
512 :     *)
513 : leunga 1094 fun resolveHpOffset(M.CONST(absoluteHpOffset)) =
514 : jhr 4242 let val tmpR = newReg PTR
515 : leunga 585 val offset = absoluteHpOffset - !advancedHP
516 : jhr 4550 in emit(M.MV(pty, tmpR, M.ADD(addrTy, C.allocptr, LI' offset)));
517 : leunga 1094 M.REG(pty, tmpR)
518 : leunga 585 end
519 :     | resolveHpOffset(e) = e
520 :    
521 : jhr 4540 fun regbind (CPS.VAR v) = resolveHpOffset(lookupGpRegTbl v)
522 : jhr 4560 | regbind (CPS.NUM{ival, ty={tag=true, ...}}) = LI(ival+ival+1)
523 :     | regbind (CPS.NUM{ival, ...}) = LI ival
524 : jhr 4540 | regbind (CPS.LABEL v) =
525 :     laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
526 : monnier 429 | regbind _ = error "regbind"
527 : monnier 247
528 : jhr 4242 (*
529 : leunga 585 * This version allows the value to be further propagated
530 :     *)
531 : jhr 4242 fun resolveHpOffset'(M.CONST(absoluteHpOffset)) =
532 : leunga 593 let val offset = absoluteHpOffset - !advancedHP
533 : jhr 4550 in markPTR(M.ADD(addrTy, C.allocptr, LI' offset))
534 : leunga 585 end
535 :     | resolveHpOffset'(e) = e
536 :    
537 : jhr 4540 fun regbind' (CPS.VAR v) = resolveHpOffset'(lookupGpRegTbl v)
538 : jhr 4560 | regbind' (CPS.NUM{ival, ty={tag=true, ...}}) = LI(ival+ival+1)
539 :     | regbind' (CPS.NUM{ival, ...}) = LI ival
540 : jhr 4540 | regbind' (CPS.LABEL v) =
541 : leunga 585 laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
542 :     | regbind' _ = error "regbind'"
543 :    
544 : monnier 429 (*
545 :     * The following function looks up the MLTREE expression associated
546 : jhr 4242 * with a floating point value expression.
547 : monnier 429 *)
548 : blume 733 val lookupFpRegTbl = IntHashTable.lookup fpRegTbl
549 : monnier 429 fun fregbind(CPS.VAR v) = lookupFpRegTbl v
550 :     | fregbind _ = error "fregbind"
551 : monnier 247
552 : monnier 429 (* On entry to a function, the parameters will be in formal
553 :     * parameter passing registers. Within the body of the function, they
554 :     * are moved immediately to fresh temporary registers. This ensures
555 : jhr 4242 * that the life time of the formal paramters is restricted to the
556 : monnier 429 * function body and is critical in avoiding artificial register
557 :     * interferences.
558 :     *)
559 : jhr 4242 fun initialRegBindingsEscaping(vl, rl, tl) =
560 :     let fun eCopy(x::xs, M.GPR(M.REG(_,r))::rl, rds, rss, xs', rl') =
561 : monnier 498 let val t = newReg PTR
562 : jhr 4242 in addRegBinding(x, t);
563 : monnier 429 eCopy(xs, rl, t::rds, r::rss, xs', rl')
564 :     end
565 : jhr 4242 | eCopy(x::xs, r::rl, rds, rss, xs', rl') =
566 : monnier 429 eCopy(xs, rl, rds, rss, x::xs', r::rl')
567 :     | eCopy([], [], [], [], xs', rl') = (xs', rl')
568 : jhr 4242 | eCopy([], [], rds, rss, xs', rl') =
569 : monnier 429 (emit(M.COPY(ity, rds, rss)); (xs', rl'))
570 : mblume 1334 | eCopy (([], _::_, _, _, _, _) | (_::_, [], _, _, _, _)) =
571 :     error "eCopy"
572 : monnier 247
573 : jhr 4242 fun eOther(x::xs, M.GPR(r)::rl, xs', rl') =
574 : monnier 498 let val t = newReg PTR
575 : jhr 4242 in addRegBinding(x, t); emit(M.MV(ity, t, r));
576 : monnier 429 eOther(xs, rl, xs', rl')
577 :     end
578 : jhr 4242 | eOther(x::xs, (M.FPR(M.FREG(_,f)))::rl, xs', rl') =
579 : monnier 429 eOther(xs, rl, x::xs', f::rl')
580 :     | eOther([], [], xs, rl) = (xs, rl)
581 : mblume 1334 | eOther (_, M.FPR _ :: _, _, _) =
582 :     error "eOther: FPR but not FREG"
583 :     | eOther (_, M.CCR _ :: _, _, _) =
584 :     error "eOther: CCR"
585 :     | eOther (([], _::_, _, _) | (_::_, [], _, _)) =
586 :     error "eOther"
587 : monnier 247
588 : monnier 429 fun eFcopy([], []) = ()
589 : jhr 4242 | eFcopy(xs, rl) =
590 : monnier 498 let val fs = map (fn _ => newFreg REAL64) xs
591 : jhr 4242 in ListPair.app
592 : monnier 429 (fn (x,f) => addFregBinding(x,M.FREG(fty,f))) (xs,fs);
593 :     emit(M.FCOPY(fty, fs, rl))
594 :     end
595 :     val (vl', rl') = eCopy(vl, rl, [], [], [], [])
596 :     in eFcopy(eOther(vl', rl', [], []));
597 :     ListPair.app addTypBinding (vl, tl)
598 :     end
599 : monnier 247
600 : jhr 4242 fun initialRegBindingsKnown(vl, rl, tl) =
601 : monnier 429 let fun f(v, M.GPR(reg as M.REG _)) = addExpBinding(v, reg)
602 :     | f(v, M.FPR(freg as M.FREG _)) = addFregBinding(v, freg)
603 :     | f _ = error "initialRegBindingsKnown.f"
604 :     in ListPair.app f (vl, rl);
605 :     ListPair.app addTypBinding (vl, tl)
606 :     end
607 : monnier 247
608 : jhr 4242 (* Keep allocation pointer aligned on odd boundary
609 :     * Note: We have accounted for the extra space this eats up in
610 : monnier 429 * limit.sml
611 :     *)
612 : jhr 4667 fun updtHeapPtr 0 = ()
613 :     | updtHeapPtr hp = let
614 :     fun advBy hp = (
615 :     advancedHP := !advancedHP + hp;
616 :     emit(M.MV(pty, allocptrR, M.ADD(addrTy, C.allocptr, LI' hp))))
617 :     in
618 :     if Word.andb(Word.fromInt hp, Word.fromInt ws) <> 0w0
619 :     then advBy(hp+ws)
620 :     else advBy hp
621 :     end
622 : leunga 585
623 : jhr 4874 fun testLimit hp = let
624 :     fun assignCC(M.CC(_, cc), v) = emit(M.CCMV(cc, v))
625 :     | assignCC _ = error "testLimit.assign"
626 :     in
627 :     updtHeapPtr hp;
628 :     case C.exhausted
629 :     of NONE => ()
630 :     | SOME cc => assignCC(cc, gcTest)
631 :     (* end case *)
632 :     end
633 : monnier 247
634 : leunga 585 (*
635 : leunga 590 * Function to allocate an integer record
636 :     * x <- [descriptor ... fields]
637 : jhr 4242 *)
638 : leunga 590 fun ea(r, 0) = r
639 : jhr 4550 | ea(r, n) = M.ADD(addrTy, r, LI' n)
640 : leunga 590 fun indexEA(r, 0) = r
641 : jhr 4550 | indexEA(r, n) = M.ADD(addrTy, r, LI'(n*ws))
642 : leunga 590
643 : jhr 4874 fun allocRecord (markComp, mem, desc, fields, hp) = let
644 :     fun getField (v, e, CPS.OFFp 0) = e
645 :     | getField (v, e, CPS.OFFp n) = M.ADD(addrTy, e, LI'(ws*n))
646 :     | getField (v, e, p) = getPath(getRegion v, e, p)
647 :     and getPath (mem, e, CPS.OFFp n) = indexEA(e, n)
648 :     | getPath (mem, e, CPS.SELp(n, CPS.OFFp 0)) =
649 :     markComp(M.LOAD(ity, indexEA(e, n), pi(mem, n)))
650 :     | getPath(mem, e, CPS.SELp(n, p)) = let
651 :     val mem = pi(mem, n)
652 :     in
653 :     getPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)), p)
654 :     end
655 :     fun storeFields([], hp, elem) = hp
656 :     | storeFields((v, p)::fields, hp, elem) = (
657 :     emit(M.STORE(ity,
658 :     M.ADD(addrTy, C.allocptr, LI' hp),
659 :     getField (v, regbind' v, p), pi(mem, elem)));
660 :     storeFields (fields, hp+ws, elem+1))
661 :     in
662 :     emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
663 :     storeFields(fields, hp+ws, 0);
664 :     hp+ws
665 :     end
666 : leunga 590
667 :     (*
668 :     * Functions to allocate a floating point record
669 :     * x <- [descriptor ... fields]
670 : jhr 4242 *)
671 : jhr 4874 (* REAL32: FIXME *)
672 : jhr 4242 fun allocFrecord(mem, desc, fields, hp) =
673 : leunga 590 let fun fea(r, 0) = r
674 : jhr 4550 | fea(r, n) = M.ADD(addrTy, r, LI'(n*8))
675 : leunga 590 fun fgetField(v, CPS.OFFp 0) = fregbind v
676 :     | fgetField(v, CPS.OFFp _) = error "allocFrecord.fgetField"
677 :     | fgetField(v, p) = fgetPath(getRegion v, regbind' v, p)
678 :    
679 :     and fgetPath(mem, e, CPS.OFFp _) = error "allocFrecord.fgetPath"
680 :     | fgetPath(mem, e, CPS.SELp(n, CPS.OFFp 0)) =
681 : jhr 4874 markREAL64(M.FLOAD(fty, fea(e, n), pi(mem, n)))
682 : leunga 590 | fgetPath(mem, e, CPS.SELp(n, p)) =
683 :     let val mem = pi(mem, n)
684 : jhr 4242 in fgetPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)),p)
685 : leunga 590 end
686 : jhr 4242
687 : leunga 590 fun fstoreFields([], hp, elem) = hp
688 : jhr 4242 | fstoreFields((v, p)::fields, hp, elem) =
689 : jhr 4550 (emit(M.FSTORE(fty, M.ADD(addrTy, C.allocptr, LI' hp),
690 : leunga 590 fgetField(v, p), pi(mem, elem)));
691 :     fstoreFields(fields, hp+8, elem+1)
692 :     )
693 :     in emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
694 : jhr 4316 fstoreFields(fields, hp+ws, 0);
695 :     hp+ws
696 : leunga 590 end
697 :    
698 : jhr 4540 (* Allocate a header pair for a known-length vector or array *)
699 :     fun allocHeaderPair (hdrDesc, mem, dataPtr, len, hp) = (
700 : jhr 4550 emit(M.STORE(ity, ea(C.allocptr, hp), LI hdrDesc, pi(mem,~1)));
701 : jhr 4540 emit(M.STORE(ity, ea(C.allocptr, hp+ws), M.REG(ity, dataPtr),pi(mem, 0)));
702 : jhr 4550 emit(M.STORE(ity, ea(C.allocptr, hp+2*ws), LI'(len+len+1), pi(mem, 1)));
703 : jhr 4540 hp+ws)
704 : leunga 590
705 :     (*
706 : leunga 585 * Int 31 tag optimizations.
707 :     * Note: if the tagging scheme changes then we'll have to redo these.
708 :     *)
709 : monnier 247
710 : leunga 585 fun addTag e = M.ADD(ity, e, one)
711 : monnier 429 fun stripTag e = M.SUB(ity, e, one)
712 : leunga 585 fun orTag e = M.ORB(ity, e, one)
713 : monnier 247
714 : jhr 4540 fun tag (false, e) = tagUnsigned e
715 :     | tag (true, e) = tagSigned e
716 : jhr 4242 and tagUnsigned e =
717 : leunga 585 let fun double r = M.ADD(ity,r,r)
718 : jhr 4242 in case e
719 : leunga 585 of M.REG _ => addTag(double e)
720 :     | _ => let val tmp = newReg PTR (* XXX ??? *)
721 :     in M.LET(M.MV(ity, tmp, e),
722 :     addTag(double(M.REG(ity,tmp))))
723 :     end
724 :     end
725 : jhr 4242 and tagSigned e =
726 : leunga 585 let fun double r = M.ADDT(ity,r,r)
727 : jhr 4242 in case e
728 : leunga 585 of M.REG _ => addTag(double e)
729 :     | _ => let val tmp = newReg PTR (* XXX ??? *)
730 :     in M.LET(M.MV(ity, tmp, e),
731 :     addTag(double(M.REG(ity,tmp))))
732 :     end
733 :     end
734 : monnier 247
735 : jhr 4540 fun untag (true, e) = untagSigned e
736 :     | untag (false, e) = untagUnsigned e
737 : jhr 4560 and untagUnsigned (CPS.NUM{ty={tag=true, ...}, ival}) = LI ival
738 :     | untagUnsigned (CPS.NUM _) = error "untagUnsigned: boxed int"
739 : jhr 4544 | untagUnsigned v = M.SRL(ity, regbind v, one)
740 : jhr 4560 and untagSigned (CPS.NUM{ty={tag=true, ...}, ival}) = LI ival
741 :     | untagSigned (CPS.NUM _) = error "untagSigned: boxed int"
742 : jhr 4544 | untagSigned v = M.SRA(ity, regbind v, one)
743 : monnier 247
744 : leunga 585 (*
745 : jhr 4548 * Tagged integer operators
746 : leunga 585 *)
747 : jhr 4874 fun tagIntAdd (addOp, CPS.NUM{ival=k, ...}, w) = addOp(ity, LI(k+k), regbind w)
748 :     | tagIntAdd (addOp, w, v as CPS.NUM _) = tagIntAdd(addOp, v, w)
749 :     | tagIntAdd (addOp, v, w) = addOp(ity,regbind v,stripTag(regbind w))
750 : monnier 247
751 : jhr 4874 fun tagIntSub (subOp, CPS.NUM{ival=k, ...}, w) = subOp(ity, LI(k+k+2), regbind w)
752 :     | tagIntSub (subOp, v, CPS.NUM{ival=k, ...}) = subOp(ity, regbind v, LI(k+k))
753 :     | tagIntSub (subOp, v, w) = addTag(subOp(ity, regbind v, regbind w))
754 : leunga 585
755 : jhr 4874 fun tagIntXor (CPS.NUM{ival=k, ...}, w) = M.XORB(ity, LI(k+k), regbind w)
756 :     | tagIntXor (w, v as CPS.NUM _) = tagIntXor (v,w)
757 :     | tagIntXor (v, w) = addTag (M.XORB(ity, regbind v, regbind w))
758 : leunga 585
759 : jhr 4874 fun tagIntMul (signed, mulOp, v, w) = let
760 : jhr 4560 fun f (CPS.NUM{ival=k, ...}, CPS.NUM{ival=j, ...}) = (LI(k+k), LI j)
761 :     | f (CPS.NUM{ival=k, ...}, w) = (untag(signed,w), LI(k+k))
762 :     | f (v, w as CPS.NUM _) = f(w, v)
763 : jhr 4544 | f (v, w) = (stripTag(regbind v), untag(signed,w))
764 :     val (v, w) = f(v, w)
765 :     in
766 :     addTag(mulOp(ity, v, w))
767 :     end
768 : monnier 247
769 : jhr 4874 fun tagIntDiv (signed, drm, v, w) = let
770 : jhr 4544 val (v, w) = (case (v, w)
771 : jhr 4560 of (CPS.NUM{ival=k, ...}, CPS.NUM{ival=j, ...}) => (LI k, LI j)
772 :     | (CPS.NUM{ival=k, ...}, w) => (LI k, untag(signed, w))
773 :     | (v, CPS.NUM{ival=k, ...}) => (untag(signed, v), LI k)
774 : jhr 4544 | (v, w) => (untag(signed, v), untag(signed, w))
775 :     (* end case *))
776 :     in
777 :     (* The only way a 31-bit div can overflow is when the result gets retagged.
778 :     * Therefore, we can use M.DIVS instead of M.DIVT.
779 :     *)
780 :     tag (signed,
781 :     if signed then M.DIVS (drm, ity, v, w) else M.DIVU (ity, v, w))
782 :     end
783 : monnier 247
784 : jhr 4874 fun tagIntRem (signed, drm, v, w) = let
785 : jhr 4544 val (v, w) = (case (v, w)
786 : jhr 4560 of (CPS.NUM{ival=k, ...}, CPS.NUM{ival=j, ...}) => (LI k, LI j)
787 :     | (CPS.NUM{ival=k, ...}, w) => (LI k, untag(signed, w))
788 :     | (v, CPS.NUM{ival=k, ...}) => (untag(signed, v), LI k)
789 : jhr 4544 | (v, w) => (untag(signed, v), untag(signed, w))
790 :     (* end case *))
791 :     in
792 :     tag (false, (* cannot overflow, so we tag like unsigned *)
793 :     if signed then M.REMS (drm, ity, v, w) else M.REMU (ity, v, w))
794 :     end
795 : blume 1183
796 : jhr 4874 fun tagIntLShift (CPS.NUM{ival=k, ...}, w) =
797 :     addTag (M.SLL(ity, LI(k+k), untagUnsigned w))
798 :     | tagIntLShift (v, CPS.NUM{ival=k, ...}) =
799 : jhr 4560 addTag(M.SLL(ity,stripTag(regbind v), LI k))
800 : jhr 4874 | tagIntLShift (v,w) =
801 :     addTag(M.SLL(ity,stripTag(regbind v), untagUnsigned w))
802 : monnier 247
803 : jhr 4874 fun tagIntRShift (rshiftOp, v, CPS.NUM{ival=k, ...}) =
804 : jhr 4560 orTag(rshiftOp(ity, regbind v, LI k))
805 : jhr 4874 | tagIntRShift (rshiftOp, v, w) =
806 :     orTag(rshiftOp(ity, regbind v, untagUnsigned w))
807 : monnier 247
808 : jhr 4540 fun getObjDescriptor v =
809 : jhr 4550 M.LOAD(ity, M.SUB(pty, regbind v, LI' ws), getRegionPi(v, ~1))
810 : monnier 247
811 : jhr 4540 fun getObjLength v =
812 : jhr 4544 M.SRL(ity, getObjDescriptor v, LW'(D.tagWidth - 0w1))
813 : monnier 247
814 : jhr 4242 (*
815 : monnier 429 * Note: because formals are moved into fresh temporaries,
816 : jhr 4242 * (formals intersection actuals) is empty.
817 : leunga 585 *
818 :     * Do the treeified computation first so as to prevent extra
819 : jhr 4242 * interferences from being created.
820 : leunga 585 *
821 : monnier 429 *)
822 : jhr 4242 fun callSetup(formals, actuals) =
823 : leunga 585 let fun isTreeified(CPS.VAR r) = treeify r = TREEIFIED
824 :     | isTreeified _ = false
825 : jhr 4242 fun gather([], [], cpRd, cpRs, fcopies, treeified, moves) =
826 : leunga 585 (app emit treeified;
827 : jhr 4242 case (cpRd,cpRs)
828 :     of ([],[]) => ()
829 : monnier 429 | _ => emit(M.COPY(ity, cpRd, cpRs));
830 :     case fcopies
831 : jhr 4242 of [] => ()
832 : monnier 429 | _ => emit(M.FCOPY(fty, map #1 fcopies, map #2 fcopies));
833 :     app emit moves
834 :     )
835 : jhr 4242 | gather(M.GPR(M.REG(ty,rd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
836 : monnier 429 (case regbind act
837 : leunga 585 of M.REG(_,rs) => gather(fmls,acts,rd::cpRd,rs::cpRs,f,t,m)
838 :     | e => if isTreeified act then
839 : jhr 4242 gather(fmls, acts, cpRd, cpRs, f,
840 : leunga 585 M.MV(ty, rd, e)::t, m)
841 :     else
842 : jhr 4242 gather(fmls, acts, cpRd, cpRs, f,
843 : leunga 585 t, M.MV(ty, rd, e)::m)
844 : monnier 429 (*esac*))
845 : leunga 585 | gather(M.GPR(M.LOAD(ty,ea,r))::fmls,act::acts,cpRd,cpRs,f,t,m) =
846 :     (* Always store them early! *)
847 : monnier 429 gather(fmls,acts,cpRd,cpRs,f,
848 : leunga 585 M.STORE(ty,ea,regbind act,r)::t, m)
849 : jhr 4242 | gather(M.FPR(M.FREG(ty,fd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
850 : monnier 429 (case fregbind act
851 : jhr 4242 of M.FREG(_,fs) =>
852 : leunga 585 gather(fmls,acts,cpRd,cpRs,(fd,fs)::f,t,m)
853 : jhr 4242 | e =>
854 : leunga 585 if isTreeified act then
855 :     gather(fmls,acts,cpRd,cpRs,f,M.FMV(ty, fd, e)::t,m)
856 :     else
857 :     gather(fmls,acts,cpRd,cpRs,f,t,M.FMV(ty, fd, e)::m)
858 : monnier 429 (*esac*))
859 :     | gather _ = error "callSetup.gather"
860 : leunga 585 in gather(formals, actuals, [], [], [], [], [])
861 : monnier 429 end
862 : monnier 247
863 : jhr 4803 (* scale-and-add, where the second argument is a tagged integer *)
864 : jhr 4560 fun scale1 (a, CPS.NUM{ival=0, ...}) = a
865 :     | scale1 (a, CPS.NUM{ival, ...}) = M.ADD(ity, a, LI ival)
866 : jhr 4540 | scale1 (a, i) = M.ADD(ity, a, untagSigned(i))
867 : monnier 247
868 : jhr 4560 fun scale4 (a, CPS.NUM{ival=0, ...}) = a
869 :     | scale4 (a, CPS.NUM{ival, ...}) = M.ADD(ity, a, LI(ival*4))
870 : jhr 4540 | scale4 (a, i) = M.ADD(ity, a, M.SLL(ity, untagSigned(i), two))
871 : monnier 247
872 : jhr 4560 fun scale8 (a, CPS.NUM{ival=0, ...}) = a
873 :     | scale8 (a, CPS.NUM{ival, ...}) = M.ADD(ity, a, LI(ival*8))
874 : jhr 4540 | scale8 (a, i) = M.ADD(ity, a, M.SLL(ity, stripTag(regbind i), two))
875 : jhr 4242
876 : jhr 4803 (* scale by the target word size *)
877 : jhr 4316 val scaleWord = (case ws
878 :     of 4 => scale4
879 :     | 8 => scale8
880 :     | _ => error "scaleWord"
881 :     (* end case *))
882 : jhr 4328
883 : jhr 4874 (* zero-extend and sign-extend to full machine-word width *)
884 :     fun zeroExtend (sz, e) = M.ZX (ity, sz, e)
885 :     fun signExtend (sz, e) = M.SX (ity, sz, e)
886 : leunga 775
887 : jhr 4874 (* add to storelist, the address where a boxed update has occured *)
888 : jhr 4540 fun recordStore (tmp, hp) = (
889 : jhr 4550 emit (M.STORE(pty, M.ADD(addrTy, C.allocptr, LI' hp), tmp, R.storelist));
890 :     emit (M.STORE(pty, M.ADD(addrTy, C.allocptr, LI'(hp+ws)),
891 : jhr 4544 C.storeptr(vfp), R.storelist));
892 : jhr 4550 emit (assign(C.storeptr(vfp), M.ADD(addrTy, C.allocptr, LI' hp))))
893 : jhr 4242
894 :     fun unsignedCmp oper =
895 : monnier 429 case oper
896 : jhr 4242 of P.> => M.GTU | P.>= => M.GEU
897 : leunga 585 | P.< => M.LTU | P.<= => M.LEU
898 :     | P.eql => M.EQ | P.neq => M.NE
899 : jhr 4242
900 :     fun signedCmp oper =
901 : monnier 429 case oper
902 : jhr 4242 of P.> => M.GT | P.>= => M.GE
903 : leunga 585 | P.< => M.LT | P.<= => M.LE
904 : jhr 4242 | P.neq => M.NE | P.eql => M.EQ
905 : leunga 1174
906 : jhr 4242 fun real64Cmp(oper, v, w) =
907 :     let val fcond =
908 : leunga 1174 case oper
909 : jhr 4242 of P.fEQ => M.==
910 :     | P.fULG => M.?<>
911 :     | P.fUN => M.?
912 :     | P.fLEG => M.<=>
913 :     | P.fGT => M.>
914 :     | P.fGE => M.>=
915 :     | P.fUGT => M.?>
916 :     | P.fUGE => M.?>=
917 :     | P.fLT => M.<
918 :     | P.fLE => M.<=
919 :     | P.fULT => M.?<
920 :     | P.fULE => M.?<=
921 :     | P.fLG => M.<>
922 :     | P.fUE => M.?=
923 : gkuan 2732 | P.fsgn => error "unary fsgn used as binary operator"
924 : leunga 1174 in M.FCMP(64, fcond, fregbind v, fregbind w) end
925 : jhr 4242
926 : leunga 775 fun branchToLabel(lab) = M.JMP(M.LABEL lab,[])
927 : jhr 4242
928 : monnier 429 local
929 :     open CPS
930 : jhr 4550 (* evaluate a comparison of constants. *)
931 :     fun evalCmp (nk, cmpOp, a, b) = (case (nk, cmpOp)
932 :     of (P.UINT sz, P.>) => ConstArith.uLess(sz, b, a)
933 :     | (P.INT _, P.>) => (a > b)
934 :     | (P.UINT sz, P.>=) => ConstArith.uLessEq(sz, b, a)
935 :     | (P.INT _, P.>=) => (a >= b)
936 :     | (P.UINT sz, P.<) => ConstArith.uLess(sz, a, b)
937 :     | (P.INT _, P.<) => (a < b)
938 :     | (P.UINT sz, P.<=) => ConstArith.uLessEq(sz, a, b)
939 :     | (P.INT _, P.<=) => (a <= b)
940 :     | (_, P.eql) => (a = b)
941 :     | (_, P.neq) => (a <> b)
942 :     | _ => error "evalCmp: bogus numkind"
943 :     (* end case *))
944 : monnier 429 in
945 : monnier 498
946 : jhr 4242 (*
947 : leunga 585 * This function initializes a CPS function before we generate
948 :     * code for it. Its tasks include:
949 :     * 1. Add type bindings for each definition. This is used to determine
950 :     * the parameter passing convention for standard functions.
951 :     * 2. Compute the number of uses for each variable. This is
952 :     * used in the forward propagation logic.
953 : jhr 4242 * 3. Check whether the base pointer is needed.
954 :     * It is needed iff
955 : leunga 585 * a. There is a reference to LABEL
956 :     * b. It uses SWITCH (the jumptable requires the basepointer)
957 :     * 4. Generate the gc tests for STANDARD and KNOWN functions
958 :     * 5. Check to see if floating point allocation is being performed
959 :     * in the function. If so, we will align the allocptr.
960 : monnier 429 *)
961 : jhr 4242 fun genCPSFunction(lab, kind, f, params, formals, tys, e) =
962 : leunga 585 let val add = addTypBinding
963 :     fun addUse v =
964 :     case treeify v of
965 :     DEAD => addCntTbl(v, TREEIFY)
966 :     | TREEIFY => addCntTbl(v, COMPUTE)
967 :     | COMPUTE => ()
968 :     | _ => error "addUse"
969 :    
970 :     val hasFloats = ref false (* default is no *)
971 :     val needBasePtr = ref false
972 :    
973 : jhr 4242 fun addValue(VAR v) = addUse v
974 : leunga 585 | addValue(LABEL _) = needBasePtr := true
975 :     | addValue _ = ()
976 :    
977 :     fun addValues [] = ()
978 :     | addValues(VAR v::vs) = (addUse v; addValues vs)
979 :     | addValues(LABEL _::vs) = (needBasePtr := true; addValues vs)
980 :     | addValues(_::vs) = addValues vs
981 :    
982 :     fun addRecValues [] = ()
983 :     | addRecValues((VAR v,_)::l) = (addUse v; addRecValues l)
984 : jhr 4242 | addRecValues((LABEL v,_)::l) =
985 : leunga 585 (needBasePtr := true; addRecValues l)
986 :     | addRecValues(_::l) = addRecValues l
987 :    
988 : jhr 4242 fun init e =
989 : leunga 585 case e
990 : jhr 4242 of RECORD(k,vl,x,e) =>
991 :     (case k of
992 : leunga 585 (RK_FCONT | RK_FBLOCK) => hasFloats := true
993 :     | _ => ();
994 :     addRecValues vl; add(x,BOGt); init e
995 :     )
996 :     | SELECT(_,v,x,t,e) => (addValue v; add(x,t); init e)
997 :     | OFFSET(_,v,x,e) => (addValue v; add(x,BOGt); init e)
998 : jhr 4874 | SWITCH(v,_,el) => (needBasePtr := true; addValue v; app init el)
999 : leunga 585 | SETTER(_,vl,e) => (addValues vl; init e)
1000 : jhr 4874 | LOOKER(looker,vl,x,t,e) => (
1001 :     addValues vl;
1002 :     (* floating subscript cannot move past a floating update.
1003 :     * For now subscript operations cannot be treeified.
1004 :     * This is hacked by making it (falsely) used
1005 :     * more than once.
1006 :     *)
1007 :     case looker
1008 :     of (P.numsubscript{kind=P.FLOAT _} | P.rawload {kind=P.FLOAT _}) =>
1009 :     addCntTbl(x,COMPUTE)
1010 :     | _ => ()
1011 :     (* end case *);
1012 :     add(x,t); init e)
1013 : leunga 585 | ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
1014 : mblume 1755 | RCC(_,_,_,vl,wl,e) => (addValues vl; app add wl; init e)
1015 : jhr 4874 | PURE(p,vl,x,t,e) => (
1016 :     case p
1017 :     of P.wrap(P.FLOAT _) => hasFloats := true
1018 :     | _ => ()
1019 :     (* end case *);
1020 :     addValues vl; add(x,t); init e)
1021 : leunga 585 | BRANCH(_,vl,_,e1,e2) => (addValues vl; init e1; init e2)
1022 :     | APP(v,vl) => (addValue v; addValues vl)
1023 :     | _ => error "genCPSFunction"
1024 :    
1025 :     in (* Print debugging information *)
1026 :     if !CG.printit then printCPSFun(kind,f,params,tys,e) else ();
1027 : jhr 4242
1028 : leunga 585 (* Move parameters *)
1029 : jhr 4242 case kind of
1030 : leunga 585 KNOWN =>
1031 :     (defineLabel lab;
1032 :     init e;
1033 :     initialRegBindingsEscaping(params, formals, tys)
1034 :     )
1035 :     | KNOWN_CHECK =>
1036 :     (defineLabel lab;
1037 :     (* gc test *)
1038 :     (if !mlrisc andalso !gcsafety then
1039 :     InvokeGC.optimizedKnwCheckLimit else
1040 : jhr 4242 InvokeGC.knwCheckLimit)
1041 : leunga 585 stream
1042 : jhr 4242 {maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tys,
1043 : leunga 585 return=branchToLabel(lab)};
1044 :     init e;
1045 :     initialRegBindingsEscaping(params, formals, tys)
1046 :     )
1047 :     | _ =>
1048 :     (* Standard function *)
1049 : mblume 1334 let val regfmls = formals
1050 :     val (linkreg, regfmlsTl) =
1051 :     case formals of
1052 :     (M.GPR linkreg::regfmlsTl) => (linkreg, regfmlsTl)
1053 :     | _ => error "no linkreg for standard function"
1054 : jhr 4242 val entryLab =
1055 : leunga 585 if splitEntry then functionLabel(~f-1) else lab
1056 : jhr 4242 in
1057 : leunga 624 if splitEntry then
1058 : jhr 4242 (entryLabel entryLab;
1059 : leunga 585 annotation EMPTY_BLOCK;
1060 :     defineLabel lab
1061 :     )
1062 : jhr 4242 else
1063 : leunga 585 entryLabel lab;
1064 : leunga 624 clearTables();
1065 :     init e;
1066 : jhr 4242 if !needBasePtr then
1067 :     let val baseval =
1068 :     M.ADD(addrTy,linkreg,
1069 : leunga 775 M.LABEXP(M.SUB(addrTy,
1070 :     constBaseRegOffset,
1071 :     M.LABEL entryLab)))
1072 : george 823 in emit(assign(C.baseptr(vfp), baseval)) end
1073 : leunga 624 else ();
1074 :     InvokeGC.stdCheckLimit stream
1075 : jhr 4242 {maxAlloc=4 * maxAlloc f, regfmls=regfmls,
1076 : leunga 744 regtys=tys, return=M.JMP(linkreg,[])};
1077 : leunga 624 initialRegBindingsEscaping
1078 :     (List.tl params, regfmlsTl, List.tl tys)
1079 :     end
1080 : leunga 585 ;
1081 :    
1082 :     (* Align the allocation pointer if necessary *)
1083 : jhr 4874 if !hasFloats andalso not Target.is64
1084 : jhr 4550 then emit(M.MV(pty, allocptrR, M.ORB(pty, C.allocptr, LI' ws)))
1085 : jhr 4540 else ();
1086 : leunga 585
1087 :     (* Generate code *)
1088 :     advancedHP := 0;
1089 :     gen(e, 0)
1090 : jhr 4316 (*+DEBUG*)
1091 : jhr 4242 handle ex => (
1092 : jhr 4540 print(concat["***** exception (", exnMessage ex, ")\n"]);
1093 : jhr 4242 printCPSFun(kind,f,params,tys,e);
1094 :     raise ex)
1095 : jhr 4316 (*-DEBUG*)
1096 : jhr 4242
1097 : monnier 247 end
1098 : leunga 585
1099 : jhr 4242 (*
1100 : jhr 4874 * Generate code for `x := e; k`, where `r` is the register to hold `x`.
1101 : jhr 4242 *)
1102 : jhr 4874 and define (r, x, e, k, hp) = (
1103 :     addRegBinding(x, r);
1104 :     emit(M.MV(ity, r, e));
1105 :     gen(k, hp))
1106 : leunga 585
1107 : jhr 4874 and def (gc, x, e, k, hp) = define(newReg gc, x, e, k, hp)
1108 : leunga 585
1109 : jhr 4874 and defWithKind (kind, x, e, k, hp) = define(newRegWithKind kind, x, e, k, hp)
1110 : leunga 585
1111 : jhr 4874 and defTAGINT (x, e, k, hp) = def(TAGINT, x, e, k, hp)
1112 :     and defINT (x, e, k, hp) = def(INT, x, e, k, hp)
1113 :     and defBoxed (x, e, k, hp) = def(PTR, x, e, k, hp)
1114 : jhr 4242
1115 : monnier 429 (*
1116 : leunga 585 * Generate code for x : cty := e; k
1117 :     *)
1118 : jhr 4874 and treeifyDef(x, e, cty, k, hp) = (case treeify x
1119 :     of COMPUTE => define(newRegWithCty cty, x, e, k, hp)
1120 :     | TREEIFY => (
1121 :     markAsTreeified x;
1122 :     addExpBinding(x, markGC(e, cty));
1123 :     gen(k, hp))
1124 :     | DEAD => gen(k, hp)
1125 :     | _ => error "treeifyDef"
1126 :     (* end case *))
1127 : jhr 4242
1128 : leunga 585 (*
1129 :     * Generate code for
1130 :     * x := allocptr + offset; k
1131 :     * where offset is the address offset of a newly allocated record.
1132 :     * If x is only used once, we try to propagate that to its use.
1133 :     *)
1134 : jhr 4540 and defAlloc (x, offset, k, hp) =
1135 : jhr 4550 defBoxed(x, M.ADD(addrTy, C.allocptr, LI' offset), k, hp)
1136 : leunga 585
1137 :     (* Generate code for
1138 :     * x := allocptr + offset; k
1139 : leunga 1094 * Forward propagate until it is used.
1140 : leunga 585 *)
1141 : jhr 4540 and treeifyAlloc (x, offset : int, k, hp) = (case treeify x
1142 :     of COMPUTE => defAlloc(x, offset, k, hp)
1143 :     | TREEIFY => let
1144 :     (* Note, don't mark this as treeified since it has low
1145 :     * register pressure.
1146 :     *)
1147 :     val absoluteAllocOffset = offset + !advancedHP
1148 :     in
1149 :     addExpBinding(x, M.CONST(absoluteAllocOffset));
1150 :     gen(k, hp)
1151 :     end
1152 :     | DEAD => gen(k, hp)
1153 :     | _ => error "treeifyAlloc"
1154 :     (* end case *))
1155 : leunga 585
1156 : jhr 4540 and computef64 (x, e, k, hp : int) = let
1157 :     val f = newFreg REAL64
1158 :     in
1159 :     addFregBinding(x, M.FREG(fty, f));
1160 :     emit(M.FMV(fty, f, e));
1161 :     gen(k, hp)
1162 :     end
1163 : leunga 585 (*
1164 : monnier 429 * x <- e where e contains an floating-point value
1165 :     *)
1166 : jhr 4242 and treeifyDefF64(x, e, k, hp) =
1167 : monnier 429 (case treeify x
1168 : leunga 585 of DEAD => gen(k, hp)
1169 : jhr 4242 | TREEIFY => (markAsTreeified x;
1170 : leunga 585 addFregBinding(x,e); gen(k, hp))
1171 : george 717 | COMPUTE => computef64(x, e, k, hp)
1172 : leunga 585 | _ => error "treeifyDefF64"
1173 : monnier 429 (*esac*))
1174 : jhr 4242
1175 : jhr 4874 and nop (x, v, e, hp) = defTAGINT(x, regbind v, e, hp)
1176 : jhr 4242
1177 : jhr 4874 and copy (gc, x, v, k, hp) = let
1178 :     val dst = newReg gc
1179 :     in
1180 :     addRegBinding(x, dst);
1181 :     case regbind v
1182 :     of M.REG(_,src) => emit(M.COPY(ity, [dst], [src]))
1183 :     | e => emit(M.MV(ity, dst, e))
1184 :     (*esac*);
1185 :     gen(k, hp)
1186 :     end
1187 : monnier 498
1188 : jhr 4874 and copyM (sz, x, v, k, hp) = if (sz <= Target.defaultIntSz)
1189 :     then copy(TAGINT, x, v, k, hp)
1190 :     else copy(INT, x, v, k, hp)
1191 : monnier 498
1192 : jhr 4874 (* normal branches *)
1193 : jhr 4242 and branch (cv, cmp, [v, w], yes, no, hp) =
1194 : mblume 1334 let val trueLab = newLabel ()
1195 :     in (* is single assignment great or what! *)
1196 :     emit
1197 :     (branchWithProb
1198 : jhr 4874 (M.BCC(M.CMP(ity, cmp, regbind v, regbind w), trueLab),
1199 : mblume 1334 brProb cv));
1200 :     genCont(no, hp);
1201 :     genlab(trueLab, yes, hp)
1202 :     end
1203 :     | branch _ = error "branch"
1204 : leunga 585
1205 : jhr 4874 (* branch if x is boxed *)
1206 : jhr 4242 and branchOnBoxed(cv, x, yes, no, hp) =
1207 : george 909 let val lab = newLabel()
1208 : jhr 4874 val cmp = M.CMP(ity, M.NE, M.ANDB(ity, regbind x, one), zero)
1209 : jhr 4242 in
1210 : george 1168 emit(branchWithProb(M.BCC(cmp, lab), brProb cv));
1211 : leunga 585 genCont(yes, hp);
1212 :     genlab(lab, no, hp)
1213 :     end
1214 :    
1215 : jhr 4874 (* branch if are identical strings v, w of length n *)
1216 :     and branchStreq (n, v, w, yes, no, hp) = let
1217 :     (* round number of bytes up to ws bytes *)
1218 :     val n = IntInf.fromInt(((IntInf.toInt n + ws - 1) div ws) * ws)
1219 :     val false_lab = newLabel ()
1220 :     val r1 = newReg INT
1221 :     val r2 = newReg INT
1222 :     fun cmpWord i =
1223 :     M.CMP(ity, M.NE,
1224 :     M.LOAD(ity, M.ADD(ity,M.REG(ity, r1),i), R.readonly),
1225 :     M.LOAD(ity, M.ADD(ity,M.REG(ity, r2),i), R.readonly))
1226 :     fun unroll i = if i=n
1227 :     then ()
1228 : jhr 4560 else (emit(M.BCC(cmpWord(LI i), false_lab));
1229 : leunga 585 unroll (i+4))
1230 : jhr 4874 in emit(M.MV(ity, r1, M.LOAD(ity, regbind v, R.readonly)));
1231 :     emit(M.MV(ity, r2, M.LOAD(ity, regbind w, R.readonly)));
1232 :     unroll 0;
1233 :     genCont(yes, hp);
1234 :     genlab(false_lab, no, hp)
1235 :     end
1236 : leunga 1174
1237 : jhr 4874 and arithINT (oper, v, w, x, e, hp) =
1238 :     defINT(x, oper(ity, regbind v, regbind w), e, hp)
1239 : monnier 498
1240 : jhr 4874 and shiftINT (oper, v, w, x, e, hp) =
1241 :     defINT(x, oper(ity, regbind v, untagUnsigned w), e, hp)
1242 : jhr 4242
1243 : jhr 4874 and genCont (e, hp) = let
1244 :     val save = !advancedHP
1245 :     in
1246 :     gen(e, hp);
1247 :     advancedHP := save
1248 :     end
1249 : monnier 498
1250 : jhr 4874 and genlab (lab, e, hp) = (defineLabel lab; gen(e, hp))
1251 : monnier 498
1252 : jhr 4874 and genlabCont (lab, e, hp) = (defineLabel lab; genCont(e, hp))
1253 : jhr 4242
1254 : jhr 4540 (* Allocate a normal record *)
1255 :     and mkRecord (vl, w, e, hp) = let
1256 :     val len = length vl
1257 : jhr 4544 val desc = D.makeDesc' (len, D.tag_record)
1258 : jhr 4540 in
1259 :     treeifyAlloc(w,
1260 : jhr 4550 allocRecord(markPTR, memDisambig w, LI desc, vl, hp),
1261 : jhr 4548 e, hp+ws+len*ws)
1262 : jhr 4540 end
1263 : leunga 585
1264 : jhr 4874 (* Allocate a record with machine-int-sized components *)
1265 :     and mkIntBlock (vl, w, e, hp) = let
1266 : jhr 4540 val len = length vl
1267 : jhr 4544 val desc = D.makeDesc' (len, D.tag_raw32)
1268 : jhr 4540 in
1269 :     treeifyAlloc(w,
1270 : jhr 4874 allocRecord(markINT, memDisambig w, LI desc, vl, hp),
1271 : jhr 4540 e, hp+ws+len*ws)
1272 :     end
1273 : jhr 4242
1274 : jhr 4540 (* Allocate a floating point record *)
1275 :     and mkFblock (vl, w, e, hp) = let
1276 :     val len = List.length vl
1277 : jhr 4544 val desc = D.makeDesc'(len+len, D.tag_raw64)
1278 : monnier 429 (* At initialization the allocation pointer is aligned on
1279 :     * an odd-word boundary, and the heap offset set to zero. If an
1280 :     * odd number of words have been allocated then the heap pointer
1281 :     * is misaligned for this record creation.
1282 :     *)
1283 : jhr 4540 val hp = if ws = 4 andalso Word.andb(Word.fromInt hp, 0w4) <> 0w0
1284 : jhr 4316 then hp+4
1285 :     else hp
1286 : jhr 4540 in (* The components are floating point *)
1287 :     treeifyAlloc(w,
1288 : jhr 4550 allocFrecord(memDisambig w, LI desc, vl, hp),
1289 : jhr 4548 e, hp+ws+len*8)
1290 : jhr 4540 end
1291 : leunga 585
1292 : jhr 4540 (* Allocate a vector *)
1293 :     and mkVector (vl, w, e, hp) = let
1294 :     val len = length vl
1295 : jhr 4544 val hdrDesc = D.desc_polyvec
1296 :     val dataDesc = D.makeDesc'(len, D.tag_vec_data)
1297 : jhr 4540 val dataPtr = newReg PTR
1298 :     val mem = memDisambig w
1299 :     val hp' = hp + ws + len*ws
1300 :     in (* The components are boxed *)
1301 : leunga 590 (* Allocate the data *)
1302 : jhr 4550 allocRecord(markPTR, mem, LI dataDesc, vl, hp);
1303 : jhr 4316 emit(M.MV(pty, dataPtr, ea(C.allocptr, hp+ws)));
1304 : leunga 590 (* Now allocate the header pair *)
1305 : jhr 4242 treeifyAlloc(w,
1306 : jhr 4328 allocHeaderPair(hdrDesc, mem, dataPtr, len, hp+ws+len*ws),
1307 : jhr 4316 e, hp'+3*ws)
1308 : jhr 4540 end
1309 : leunga 585
1310 :     (*
1311 :     * Floating point select
1312 :     *)
1313 : jhr 4540 (* REAL32: FIXME *)
1314 :     and fselect (i, v, x, e, hp) =
1315 :     treeifyDefF64(x,
1316 : jhr 4874 M.FLOAD(fty, scale8(regbind v, cpsInt i), R.real),
1317 : jhr 4540 e, hp)
1318 : leunga 585
1319 :     (*
1320 :     * Non-floating point select
1321 :     *)
1322 : jhr 4540 and select (i, v, x, t, e, hp) =
1323 :     treeifyDef(x,
1324 : jhr 4874 M.LOAD(ity, scaleWord(regbind v, cpsInt i), getRegionPi(v, i)),
1325 : jhr 4540 t, e, hp)
1326 : leunga 585
1327 :     (*
1328 :     * Funny select; I don't know that this does
1329 :     *)
1330 :     and funnySelect(i, k, x, t, e, hp) =
1331 :     let val unboxedfloat = MS.unboxedFloats
1332 : jhr 4242 fun isFlt t =
1333 : jhr 4454 if unboxedfloat then (case t of FLTt _ => true | _ => false)
1334 : leunga 585 else false
1335 :     fun fallocSp(x,e,hp) =
1336 :     (addFregBinding(x,M.FREG(fty,newFreg REAL64));gen(e, hp))
1337 : jhr 4242 (* warning: the following generated code should never be
1338 : leunga 585 executed; its semantics is completely screwed up !
1339 : monnier 429 *)
1340 : leunga 585 in if isFlt t then fallocSp(x, e, hp)
1341 : jhr 4874 else defINT(x, LI k, e, hp)(* BOGUS *)
1342 : monnier 429 end
1343 : monnier 247
1344 : leunga 585 (*
1345 :     * Call an external function
1346 :     *)
1347 : jhr 4242 and externalApp(f, args, hp) =
1348 : leunga 624 let val ctys = map grabty args
1349 : mblume 1334 val formals =
1350 : george 823 ArgP.standard{fnTy=typmap f, vfp=vfp, argTys=ctys}
1351 : mblume 1334 val dest =
1352 :     case formals of
1353 :     (M.GPR dest::_) => dest
1354 :     | _ => error "externalApp: dest"
1355 : monnier 429 in callSetup(formals, args);
1356 : leunga 624 if gctypes then
1357 : jhr 4242 annotation(gcAnnotation(#create GCCells.GCLIVEOUT,
1358 : leunga 624 formals, ctys))
1359 :     else ();
1360 : monnier 429 testLimit hp;
1361 : leunga 744 emit(M.JMP(dest, []));
1362 : monnier 429 exitBlock(formals @ dedicated)
1363 :     end
1364 : leunga 585
1365 :     (*
1366 :     * Call an internal function
1367 :     *)
1368 : jhr 4242 and internalApp(f, args, hp) =
1369 : monnier 429 (case lookupGenTbl f
1370 : jhr 4242 of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
1371 : monnier 429 (updtHeapPtr(hp);
1372 : jhr 4242 callSetup(formals, args);
1373 : monnier 429 emit(branchToLabel(functionLabel f)))
1374 : jhr 4242 | Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1375 : monnier 498 let val formals = known tl
1376 : monnier 429 val lab = functionLabel f
1377 :     in r := Frag.GEN formals;
1378 :     updtHeapPtr(hp);
1379 :     callSetup(formals, args);
1380 : leunga 585 genCPSFunction(lab, KNOWN, f, vl, formals, tl, e)
1381 : monnier 429 end
1382 : jhr 4242 | Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1383 :     let val formals =
1384 : george 823 if MS.fixedArgPassing then ArgP.fixed{argTys=tl, vfp=vfp}
1385 : monnier 498 else known tl
1386 : monnier 429 val lab = functionLabel f
1387 : leunga 585 in r := Frag.GEN formals;
1388 : monnier 429 callSetup(formals, args);
1389 :     testLimit hp;
1390 : leunga 585 genCPSFunction(lab, KNOWN_CHECK, f, vl, formals, tl, e)
1391 : monnier 429 end
1392 : jhr 4242 | Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
1393 :     (callSetup(formals, args);
1394 : monnier 429 testLimit hp;
1395 :     emit(branchToLabel(functionLabel f)))
1396 : jhr 4242 | Frag.STANDARD{fmlTyps, ...} =>
1397 : george 823 let val formals = ArgP.standard{fnTy=typmap f, argTys=fmlTyps, vfp=vfp}
1398 : monnier 429 in callSetup(formals, args);
1399 :     testLimit hp;
1400 :     emit(branchToLabel(functionLabel f))
1401 :     end
1402 :     (*esac*))
1403 : monnier 247
1404 : jhr 4874 and rawload (kind, i, x, e, hp) = (case kind
1405 :     of P.INT sz => if (sz = ity)
1406 :     then defINT (x, M.LOAD (ity, i, R.memory), e, hp)
1407 :     else if (sz < ity)
1408 :     then defINT (x, signExtend (sz, M.LOAD (sz, i, R.memory)), e, hp)
1409 :     else error ("rawload: unsupported INT " ^ Int.toString sz)
1410 :     | P.UINT sz => if (sz = ity)
1411 :     then defINT (x, M.LOAD (ity, i, R.memory), e, hp)
1412 :     else if (sz < ity)
1413 :     then defINT (x, zeroExtend (sz, M.LOAD (sz, i, R.memory)), e, hp)
1414 :     else error ("rawload: unsupported UINT " ^ Int.toString sz)
1415 :     | P.FLOAT 32 =>
1416 :     (* REAL32: FIXME *)
1417 :     treeifyDefF64 (x, M.CVTF2F (64, 32, M.FLOAD (32, i, R.memory)), e, hp)
1418 :     | P.FLOAT 64 => treeifyDefF64 (x, M.FLOAD (64, i, R.memory), e, hp)
1419 :     | P.FLOAT sz => error ("rawload: unsupported float size: " ^ Int.toString sz)
1420 :     (* end case *))
1421 : blume 772
1422 : jhr 4874 and rawstore (kind, i, x) = (case kind
1423 :     of P.INT sz => if (sz <= ity)
1424 :     (* value is `ity` bits, but only `sz` bits are stored *)
1425 :     then emit (M.STORE (sz, i, regbind x, R.memory))
1426 :     else error ("rawstore: unsupported INT " ^ Int.toString sz)
1427 :     | P.UINT sz => if (sz <= ity)
1428 :     (* value is `ity` bits, but only `sz` bits are stored *)
1429 :     then emit (M.STORE (sz, i, regbind x, R.memory))
1430 :     else error ("rawstore: unsupported INT " ^ Int.toString sz)
1431 :     | P.FLOAT 32 => emit (M.FSTORE (32, i, fregbind x, R.memory))
1432 :     | P.FLOAT 64 => emit (M.FSTORE (64, i, fregbind x, R.memory))
1433 :     | P.FLOAT sz => error ("rawstore: unsupported float size: " ^ Int.toString sz)
1434 :     (* end case *))
1435 : blume 772
1436 : jhr 4242 (*
1437 :     * Generate code
1438 : leunga 585 *)
1439 :    
1440 :     (** RECORD **)
1441 : jhr 4540 and gen (RECORD(RK_FCONT, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1442 :     | gen (RECORD(RK_FBLOCK, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1443 :     | gen (RECORD(RK_VECTOR, vl, w, e), hp) = mkVector(vl, w, e, hp)
1444 : jhr 4874 | gen (RECORD(RK_I32BLOCK, vl, w, e), hp) = mkIntBlock(vl, w, e, hp)
1445 : jhr 4540 | gen (RECORD(_, vl, w, e), hp) = mkRecord(vl, w, e, hp)
1446 : george 984
1447 : leunga 585 (*** SELECT ***)
1448 : jhr 4560 | gen (SELECT(i, NUM{ty={tag=true, ...}, ival}, x, t, e), hp) =
1449 :     funnySelect(IntInf.fromInt i, ival, x, t, e, hp)
1450 : jhr 4540 | gen (SELECT(i, v, x, FLTt 64, e), hp) = fselect(i, v, x, e, hp) (* REAL32: *)
1451 :     | gen (SELECT(i, v, x, t, e), hp) = select(i, v, x, t, e, hp)
1452 : leunga 585
1453 :     (*** OFFSET ***)
1454 : jhr 4540 | gen (OFFSET(i, v, x, e), hp) =
1455 : jhr 4874 defBoxed(x, scaleWord(regbind v, cpsInt i), e, hp)
1456 : leunga 585
1457 :     (*** APP ***)
1458 : jhr 4560 | gen (APP(NUM{ty={tag=true, ...}, ...}, args), hp) = updtHeapPtr hp
1459 : jhr 4540 | gen (APP(VAR f, args), hp) = externalApp(f, args, hp)
1460 :     | gen (APP(LABEL f, args), hp) = internalApp(f, args, hp)
1461 : leunga 585
1462 : monnier 429 (*** SWITCH ***)
1463 : jhr 4560 | gen (SWITCH(NUM _, _, _), hp) = error "SWITCH on constant"
1464 : jhr 4540 | gen (SWITCH(v, _, l), hp) =
1465 : george 909 let val lab = newLabel ()
1466 :     val labs = map (fn _ => newLabel()) l
1467 : jhr 4874 val tmpR = newReg INT val tmp = M.REG(ity,tmpR)
1468 : monnier 429 in emit(M.MV(ity, tmpR, laddr(lab, 0)));
1469 : jhr 4328 emit(M.JMP(M.ADD(addrTy, tmp, M.LOAD(pty, scaleWord(tmp, v),
1470 : monnier 429 R.readonly)), labs));
1471 : george 984 pseudoOp(PB.DATA_READ_ONLY);
1472 :     pseudoOp(PB.EXT(CPs.JUMPTABLE{base=lab, targets=labs}));
1473 :     pseudoOp(PB.TEXT);
1474 : leunga 585 ListPair.app (fn (lab, e) => genlabCont(lab, e, hp)) (labs, l)
1475 : monnier 429 end
1476 : monnier 247
1477 : monnier 429 (*** PURE ***)
1478 : jhr 4540 | gen (PURE(P.real{fromkind=P.INT 31, tokind=P.FLOAT 64},
1479 : jhr 4242 [v], x, _, e), hp) =
1480 : george 717 treeifyDefF64(x,M.CVTI2F(fty,ity,untagSigned(v)), e, hp)
1481 : jhr 4540 | gen (PURE(P.real{fromkind=P.INT 32, tokind=P.FLOAT 64},
1482 : mblume 1380 [v], x, _, e), hp) =
1483 :     treeifyDefF64(x,M.CVTI2F(fty,ity,regbind v), e, hp)
1484 : jhr 4540 | gen (PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) = let
1485 : george 717 val r = fregbind v
1486 :     in
1487 :     case oper
1488 :     of P.~ => treeifyDefF64(x, M.FNEG(fty,r), e, hp)
1489 :     | P.abs => treeifyDefF64(x, M.FABS(fty,r), e, hp)
1490 :     | P.fsqrt => treeifyDefF64(x, M.FSQRT(fty,r), e, hp)
1491 :     | P.fsin => computef64(x, M.FEXT(fty, E.FSINE r), e, hp)
1492 :     | P.fcos => computef64(x, M.FEXT(fty, E.FCOSINE r), e, hp)
1493 :     | P.ftan => computef64(x, M.FEXT(fty, E.FTANGENT r), e, hp)
1494 : mblume 1334 | _ => error "unexpected primop in pure unary float64"
1495 : george 717 end
1496 : jhr 4540 | gen (PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v,w], x, _, e), hp) =
1497 : jhr 4242 let val v = fregbind v
1498 : george 717 val w = fregbind w
1499 : jhr 4242 val t =
1500 : george 717 case oper
1501 :     of P.+ => M.FADD(fty, v, w)
1502 :     | P.* => M.FMUL(fty, v, w)
1503 :     | P.- => M.FSUB(fty, v, w)
1504 :     | P./ => M.FDIV(fty, v, w)
1505 : mblume 1334 | _ => error "unexpected primop in pure binary float64"
1506 : george 717 in treeifyDefF64(x, t, e, hp)
1507 :     end
1508 : jhr 4540 | gen (PURE(P.pure_arith{oper=P.orb, kind}, [v,w], x, _, e), hp) =
1509 : leunga 585 defWithKind(kind, x, M.ORB(ity, regbind v, regbind w), e, hp)
1510 : jhr 4540 | gen (PURE(P.pure_arith{oper=P.andb, kind}, [v,w], x, _, e), hp) =
1511 : leunga 585 defWithKind(kind, x, M.ANDB(ity, regbind v, regbind w), e, hp)
1512 : jhr 4874 | gen (PURE(P.pure_arith{oper, kind}, [v,w], x, ty, e), hp) = (case kind
1513 :     of P.INT sz => if (sz <= Target.defaultIntSz)
1514 :     then (case oper
1515 :     of P.xorb => defTAGINT(x, tagIntXor(v,w), e, hp)
1516 :     | P.lshift => defTAGINT(x, tagIntLShift(v,w), e, hp)
1517 :     | P.rshift => defTAGINT(x, tagIntRShift(M.SRA,v,w),e,hp)
1518 :     | P.+ => defTAGINT(x, tagIntAdd(M.ADD, v, w), e, hp)
1519 :     | P.- => defTAGINT(x, tagIntSub(M.SUB, v, w), e, hp)
1520 :     | P.* => defTAGINT(x, tagIntMul(true, M.MULS, v, w), e, hp)
1521 :     | _ => error "gen: PURE INT TAGGED"
1522 :     (* end case *))
1523 :     else (case oper
1524 :     of P.xorb => arithINT(M.XORB, v, w, x, e, hp)
1525 :     | P.lshift => shiftINT(M.SLL, v, w, x, e, hp)
1526 :     | P.rshift => shiftINT(M.SRA, v, w, x, e, hp)
1527 :     | _ => error "gen: PURE INT"
1528 :     (* end case *))
1529 :     | P.UINT sz => if (sz <= Target.defaultIntSz)
1530 :     then (case oper
1531 :     of P.+ => defTAGINT(x, tagIntAdd(M.ADD, v, w), e, hp)
1532 :     | P.- => defTAGINT(x, tagIntSub(M.SUB, v, w), e, hp)
1533 :     | P.* => defTAGINT(x, tagIntMul(false, M.MULU, v, w), e, hp)
1534 :     (* we now explicitly defend agains div by 0 in translate, so these
1535 :     * two operations can be treated as pure op:
1536 :     *)
1537 :     | P./ => defTAGINT(x, tagIntDiv(false, M.DIV_TO_ZERO, v, w), e, hp)
1538 :     | P.rem => defTAGINT(x, tagIntRem(false, M.DIV_TO_ZERO, v, w), e, hp)
1539 :     | P.xorb => defTAGINT(x, tagIntXor(v, w), e, hp)
1540 :     | P.lshift => defTAGINT(x, tagIntLShift(v, w), e, hp)
1541 :     | P.rshift => defTAGINT(x, tagIntRShift(M.SRA, v, w), e, hp)
1542 :     | P.rshiftl => defTAGINT(x, tagIntRShift(M.SRL, v, w), e, hp)
1543 :     | _ => error "gen: PURE UINT TAGGED"
1544 :     (* end case *))
1545 :     else (case oper
1546 :     of P.+ => arithINT(M.ADD, v, w, x, e, hp)
1547 :     | P.- => arithINT(M.SUB, v, w, x, e, hp)
1548 :     | P.* => arithINT(M.MULU, v, w, x, e, hp)
1549 :     (* we now explicitly defend agains div by 0 in translate, so these
1550 :     * two operations can be treated as pure op:
1551 :     *)
1552 :     | P./ => arithINT(M.DIVU, v, w, x, e, hp)
1553 :     | P.rem => arithINT(M.REMU, v, w, x, e, hp)
1554 :     | P.xorb => arithINT(M.XORB, v, w, x, e, hp)
1555 :     | P.lshift => shiftINT(M.SLL, v, w, x, e, hp)
1556 :     | P.rshift => shiftINT(M.SRA, v, w, x, e, hp)
1557 :     | P.rshiftl=> shiftINT(M.SRL, v, w, x, e, hp)
1558 :     | _ => error "gen:PURE UINT 32"
1559 :     (* end case *))
1560 :     | _ => error "unexpected numkind in pure binary arithop"
1561 :     (* end case *))
1562 :     | gen (PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) = let
1563 :     val sz = (case kind
1564 :     of P.UINT sz => sz
1565 :     | P.INT sz => sz
1566 :     | _ => error "unexpected numkind in pure notb arithop")
1567 :     in
1568 :     if (sz <= Target.defaultIntSz)
1569 :     then defTAGINT(x, M.SUB(ity, zero, regbind v), e, hp)
1570 :     else defINT(x, M.XORB(ity, regbind v, allOnes), e, hp)
1571 :     end
1572 :     | gen (PURE(P.pure_arith{oper=P.~, kind}, [v], x, _, e), hp) = let
1573 :     val sz = (case kind
1574 :     of P.UINT sz => sz
1575 :     | P.INT sz => sz
1576 :     | _ => error "unexpected numkind in pure ~ arithop")
1577 :     in
1578 :     if (sz <= Target.defaultIntSz)
1579 :     then defTAGINT (x, M.SUB (ity, two, regbind v), e, hp)
1580 :     else defINT (x, M.SUB(ity, zero, regbind v), e, hp)
1581 :     end
1582 :     | gen (PURE(P.copy(8, toSz), [v], x, _, e), hp) =
1583 :     if (toSz <= Target.defaultIntSz)
1584 :     then copy (TAGINT, x, v, e, hp)
1585 :     else defINT (x, M.SRL(ity, regbind v, one), e, hp)
1586 :     | gen (PURE(P.copy(fromSz, toSz), [v], x, _, e), hp) =
1587 :     if (fromSz = toSz)
1588 :     then copyM(fromSz, x, v, e, hp)
1589 :     else if (fromSz = Target.defaultIntSz) andalso (toSz = ity)
1590 :     then defINT (x, M.SRL(ity, regbind v, one), e, hp)
1591 :     else error "gen:PURE:copy"
1592 : mblume 1347 | gen (PURE(P.copy_inf _, _, _, _, _), hp) =
1593 :     error "gen:PURE:copy_inf"
1594 : jhr 4874 | gen (PURE(P.extend(8, toSz), [v], x, _ ,e), hp) = let
1595 :     val sa = IntInf.fromInt(Target.defaultIntSz - 8)
1596 :     in
1597 :     if (toSz <= Target.defaultIntSz)
1598 :     then defTAGINT (x, M.SRA(ity, M.SLL(ity, regbind v, LI sa), LI sa), e, hp)
1599 :     else defINT (x, M.SRA(ity, M.SLL(ity, regbind v, LI sa), LI(sa+1)), e, hp)
1600 :     end
1601 :     | gen (PURE(P.extend(fromSz, toSz), [v], x, _ ,e), hp) =
1602 :     if (fromSz = toSz)
1603 :     then copyM(fromSz, x, v, e, hp)
1604 :     else if (fromSz = Target.defaultIntSz) andalso (toSz = ity)
1605 :     then defINT (x, M.SRA(ity, regbind v, one), e, hp)
1606 :     else error "gen:PURE:extend"
1607 : mblume 1347 | gen (PURE(P.extend_inf _, _, _, _, _), hp) =
1608 :     error "gen:PURE:extend_inf"
1609 : jhr 4874 | gen (PURE(P.trunc(fromSz, toSz), [v], x, _, e), hp) =
1610 :     if (fromSz = toSz)
1611 :     then copyM(fromSz, x, v, e, hp)
1612 :     else if (toSz = 8)
1613 :     then if (fromSz <= Target.defaultIntSz)
1614 :     then defTAGINT (x, M.ANDB(ity, regbind v, LI 0x1ff), e, hp) (* mask includes tag bit *)
1615 :     else defTAGINT (x, tagUnsigned(M.ANDB(ity, regbind v, LI 0xff)), e, hp)
1616 :     else if (fromSz = ity) andalso (toSz = Target.defaultIntSz)
1617 :     then defTAGINT (x, M.ORB(ity, M.SLL(ity, regbind v, one), one), e, hp)
1618 :     else error "gen:PURE:trunc"
1619 : mblume 1347 | gen (PURE(P.trunc_inf _, _, _, _, _), hp) =
1620 :     error "gen:PURE:trunc_inf"
1621 : jhr 4540 | gen (PURE(P.objlength, [v], x, _, e), hp) =
1622 : jhr 4874 defTAGINT(x, orTag(getObjLength v), e, hp)
1623 : jhr 4540 | gen (PURE(P.length, [v], x, t, e), hp) = select(1, v, x, t, e, hp)
1624 : jhr 4560 | gen (PURE(P.subscriptv, [v, ix as NUM{ty={tag=true, ...}, ...}], x, t, e), hp) =
1625 : leunga 590 let (* get data pointer *)
1626 :     val mem = dataptrRegion v
1627 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1628 :     val mem' = arrayRegion mem
1629 : jhr 4560 in defBoxed(x, M.LOAD(ity, scaleWord(a, ix), mem'), e, hp)
1630 : monnier 429 end
1631 : jhr 4540 | gen (PURE(P.subscriptv, [v, w], x, _, e), hp) =
1632 : monnier 429 let (* get data pointer *)
1633 : leunga 590 val mem = dataptrRegion v
1634 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1635 :     val mem' = arrayRegion mem
1636 : jhr 4316 in defBoxed(x, M.LOAD(ity, scaleWord(a, w), mem'), e, hp)
1637 : monnier 429 end
1638 : jhr 4540 | gen (PURE(P.pure_numsubscript{kind=P.INT 8}, [v,i], x, _, e), hp) =
1639 : monnier 429 let (* get data pointer *)
1640 : leunga 590 val mem = dataptrRegion v
1641 : jhr 4242 val a = markPTR(M.LOAD(ity, regbind v, mem))
1642 : leunga 590 val mem' = arrayRegion mem
1643 : jhr 4874 in defTAGINT(x,tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
1644 : monnier 429 end
1645 : jhr 4540 | gen (PURE(P.gettag, [v], x, _, e), hp) =
1646 : jhr 4874 defTAGINT(x,
1647 :     tagUnsigned(M.ANDB(ity, getObjDescriptor v, LI(D.powTagWidth-1))),
1648 :     e, hp)
1649 :     | gen (PURE(P.mkspecial, [i, v], x, _, e), hp) = let
1650 :     val desc = (case i
1651 :     of NUM{ty={tag=true, ...}, ival} => LI(D.makeDesc(ival, D.tag_special))
1652 :     | _ => M.ORB(ity, M.SLL(ity, untagSigned i, LW' D.tagWidth), LI D.desc_special)
1653 :     (* end case *))
1654 :     in (* What gc types are the components? *)
1655 :     treeifyAlloc(x,
1656 :     allocRecord(markNothing, memDisambig x,
1657 :     desc, [(v, offp0)], hp),
1658 :     e, hp+8)
1659 :     end
1660 :     | gen (PURE(P.makeref, [v], x, _, e), hp) = let
1661 :     val tag = LI D.desc_ref
1662 :     val mem = memDisambig x
1663 :     in
1664 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI' hp), tag, mem));
1665 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI'(hp+ws)), regbind' v, mem));
1666 : jhr 4316 treeifyAlloc(x, hp+ws, e, hp+2*ws)
1667 : jhr 4874 end
1668 :     | gen (PURE(P.box, [u], w, _, e), hp) = copy(PTR, w, u, e, hp)
1669 :     | gen (PURE(P.unbox, [u], w, _, e), hp) = copy(INT, w, u, e, hp)
1670 :     | gen (PURE(P.wrap kind, [u], w, _, e), hp) = (case kind
1671 :     of P.FLOAT 64 => mkFblock([(u, offp0)],w,e,hp)
1672 :     (* REAL32: FIXME *)
1673 :     | P.INT sz => if (sz < ity)
1674 :     then error "wrap for tagged ints is not implemented"
1675 :     else if (sz = ity)
1676 :     then mkIntBlock([(u, offp0)], w, e, hp)
1677 :     else error(concat["wrap(INT ", Int.toString sz, ") is not implemented"])
1678 :     | _ => error "wrap: bogus kind"
1679 :     (* end case *))
1680 :     | gen (PURE(P.unwrap kind, [u], w, _, e), hp) = (case kind
1681 :     of P.FLOAT 64 => fselect(0,u,w,e,hp)
1682 :     (* REAL32: FIXME *)
1683 :     | P.INT sz => if (sz < ity)
1684 :     then error "unwrap for tagged ints is not implemented"
1685 :     else if (sz = ity)
1686 :     then select(0, u, w, NUMt{sz=sz, tag=false}, e, hp)
1687 :     else error(concat["unwrap(INT ", Int.toString sz, ") is not implemented"])
1688 :     | _ => error "unwrap: bogus kind"
1689 :     (* end case *))
1690 : monnier 498
1691 : leunga 585 (* Note: the gc type is unsafe! XXX *)
1692 : jhr 4540 | gen (PURE(P.cast,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1693 : jhr 4242
1694 : jhr 4540 | gen (PURE(P.getcon,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1695 :     | gen (PURE(P.getexn,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1696 :     | gen (PURE(P.getseqdata, [u], x, t, e), hp) = select(0,u,x,t,e,hp)
1697 : jhr 4560 | gen (PURE(P.recsubscript, [v, NUM{ty={tag=true, ...}, ival}], x, t, e), hp) =
1698 :     select(IntInf.toInt ival, v, x, t, e, hp)
1699 : jhr 4874 | gen (PURE(P.recsubscript, [v, w], x, _, e), hp) = let
1700 :     (* no indirection! *)
1701 :     val mem = arrayRegion(getRegion v)
1702 :     in
1703 :     defTAGINT(x, M.LOAD(ity, scaleWord(regbind v, w), mem), e, hp)
1704 :     end
1705 : jhr 4540 | gen (PURE(P.raw64subscript, [v, i], x, _, e), hp) =
1706 : leunga 590 let val mem = arrayRegion(getRegion v)
1707 :     in treeifyDefF64(x, M.FLOAD(fty,scale8(regbind v, i), mem),
1708 :     e, hp)
1709 :     end
1710 : jhr 4540 | gen (PURE(P.newarray0, [_], x, t, e), hp) =
1711 : jhr 4544 let val hdrDesc = D.desc_polyarr
1712 :     val dataDesc = D.desc_ref
1713 : monnier 498 val dataPtr = newReg PTR
1714 : monnier 429 val hdrM = memDisambig x
1715 :     val (tagM, valM) = (hdrM, hdrM) (* Allen *)
1716 : leunga 585 in (* gen code to allocate "ref()" for array data *)
1717 : jhr 4550 emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI' hp),
1718 :     LI dataDesc, tagM));
1719 :     emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI'(hp+ws)),
1720 : monnier 429 mlZero, valM));
1721 : jhr 4550 emit(M.MV(pty, dataPtr, M.ADD(addrTy,C.allocptr,LI'(hp+ws))));
1722 : leunga 585 (* gen code to allocate array header *)
1723 : jhr 4242 treeifyAlloc(x,
1724 : jhr 4316 allocHeaderPair(hdrDesc, hdrM, dataPtr, 0, hp+2*ws),
1725 :     e, hp+5*ws)
1726 : monnier 429 end
1727 : jhr 4560 | gen (PURE(P.rawrecord NONE, [NUM{ty={tag=true, ...}, ival}], x, _, e), hp) =
1728 : leunga 1094 (* allocate space for CPS spilling *)
1729 : jhr 4560 treeifyAlloc(x, hp, e, hp + IntInf.toInt ival * ws) (* no tag! *)
1730 :     | gen (PURE(P.rawrecord(SOME rk), [NUM{ty={tag=true, ...}, ival}], x, _, e), hp) = let
1731 : jhr 4540 (* allocate an uninitialized record with a tag *)
1732 :     val (tag, fp) = (case rk (* tagged version *)
1733 :     of (RK_FCONT | RK_FBLOCK) => (D.tag_raw64, true)
1734 :     | RK_I32BLOCK => (D.tag_raw32, false)
1735 :     | RK_VECTOR => error "rawrecord VECTOR unsupported"
1736 :     | _ => (D.tag_record, false)
1737 :     (* end case *))
1738 :     (* len of record in 32-bit words *)
1739 : jhr 4874 (* 64BIT: FIXME *)
1740 : jhr 4560 val len = if ws = 4 andalso fp then ival+ival else ival
1741 : jhr 4540 (* record descriptor *)
1742 : jhr 4560 val desc = D.makeDesc(len, tag)
1743 : jhr 4540 (* Align floating point *)
1744 : jhr 4560 (* 64BIT: REAL32: FIXME *)
1745 : jhr 4540 val hp = if ws = 4 andalso fp
1746 :     andalso Word.andb(Word.fromInt hp, 0w4) <> 0w0
1747 :     then hp+4
1748 :     else hp
1749 :     val mem = memDisambig x
1750 :     in
1751 :     (* store tag now! *)
1752 : jhr 4550 emit(M.STORE(ity, ea(C.allocptr, hp), LI desc, pi(mem, ~1)));
1753 : jhr 4540 (* assign the address to x *)
1754 : jhr 4560 treeifyAlloc(x, hp+ws, e, hp+(IntInf.toInt len)*ws+ws)
1755 : jhr 4540 end
1756 : leunga 1094
1757 : monnier 429 (*** ARITH ***)
1758 : jhr 4874 | gen (ARITH(P.arith{kind=P.INT sz, oper=P.~}, [v], x, _, e), hp) = (
1759 :     updtHeapPtr hp;
1760 :     if (sz <= Target.defaultIntSz)
1761 :     then defTAGINT(x, M.SUBT(ity, two, regbind v), e, 0)
1762 :     else defINT(x, M.SUBT(ity, zero, regbind v), e, 0))
1763 :     | gen (ARITH(P.arith{kind=P.INT sz, oper}, [v, w], x, _, e), hp) = (
1764 :     updtHeapPtr hp;
1765 :     if (sz <= Target.defaultIntSz)
1766 :     then (case oper
1767 :     of P.+ => defTAGINT(x, tagIntAdd(M.ADDT, v, w), e, 0)
1768 :     | P.- => defTAGINT(x, tagIntSub(M.SUBT, v, w), e, 0)
1769 :     | P.* => defTAGINT(x, tagIntMul(true, M.MULT, v, w), e, 0)
1770 :     | P./ => defTAGINT(x, tagIntDiv(true, M.DIV_TO_ZERO, v, w), e, 0)
1771 :     | P.div => defTAGINT(x, tagIntDiv(true, M.DIV_TO_NEGINF, v, w), e, 0)
1772 :     | P.rem => defTAGINT(x, tagIntRem(true, M.DIV_TO_ZERO, v, w), e, 0)
1773 :     | P.mod => defTAGINT(x, tagIntRem(true, M.DIV_TO_NEGINF, v, w), e, 0)
1774 :     | P.~ => error "gen: ~ INT TAG"
1775 :     | P.abs => error "gen: abs INT TAG"
1776 :     | P.fsqrt => error "gen: fsqrt INT TAG"
1777 :     | P.fsin => error "gen: fsin INT TAG"
1778 :     | P.fcos => error "gen: fcos INT TAG"
1779 :     | P.ftan => error "gen: ftan INT TAG"
1780 :     | P.lshift => error "gen: lshift INT TAG"
1781 :     | P.rshift => error "gen: rshift INT TAG"
1782 :     | P.rshiftl => error "gen: rshiftl INT TAG"
1783 :     | P.andb => error "gen: andb INT TAG"
1784 :     | P.orb => error "gen: orb INT TAG"
1785 :     | P.xorb => error "gen: xorb INT TAG"
1786 :     | P.notb => error "gen: notb INT TAG"
1787 :     (* end case *))
1788 :     else (case oper
1789 :     of P.+ => arithINT(M.ADDT, v, w, x, e, 0)
1790 :     | P.- => arithINT(M.SUBT, v, w, x, e, 0)
1791 :     | P.* => arithINT(M.MULT, v, w, x, e, 0)
1792 :     | P./ => arithINT(fn(ty,x,y)=>M.DIVT(M.DIV_TO_ZERO,ty,x,y),
1793 :     v, w, x, e, 0)
1794 :     | P.div => arithINT(fn(ty,x,y)=>M.DIVT(M.DIV_TO_NEGINF,ty,x,y),
1795 :     v, w, x, e, 0)
1796 :     | P.rem => arithINT(fn(ty,x,y)=>M.REMS(M.DIV_TO_ZERO,ty,x,y),
1797 :     v, w, x, e, 0)
1798 :     | P.mod => arithINT(fn(ty,x,y)=>M.REMS(M.DIV_TO_NEGINF,ty,x,y),
1799 :     v, w, x, e, 0)
1800 :     | P.~ => error "gen: ~ INT"
1801 :     | P.abs => error "gen: abs INT"
1802 :     | P.fsqrt => error "gen: fsqrt INT"
1803 :     | P.fsin => error "gen: fsin INT"
1804 :     | P.fcos => error "gen: fcos INT"
1805 :     | P.ftan => error "gen: ftan INT"
1806 :     | P.lshift => error "gen: lshift INT"
1807 :     | P.rshift => error "gen: rshift INT"
1808 :     | P.rshiftl => error "gen: rshiftl INT"
1809 :     | P.andb => error "gen: andb INT"
1810 :     | P.orb => error "gen: orb INT"
1811 :     | P.xorb => error "gen: xorb INT"
1812 :     | P.notb => error "gen: notb INT"
1813 :     (* end case *)))
1814 : jhr 4242
1815 : jhr 4874 | gen (ARITH(P.testu(fromSz, toSz), [v], x, _, e), hp) =
1816 : monnier 429 (* Note: for testu operations we use a somewhat arcane method
1817 :     * to generate traps on overflow conditions. A better approach
1818 :     * would be to generate a trap-if-negative instruction available
1819 :     * on a variety of machines, e.g. mips and sparc (maybe others).
1820 :     *)
1821 : jhr 4874 if (fromSz = toSz)
1822 :     then let
1823 :     val gc = if (fromSz < ity) then TAGINT else INT
1824 :     val xreg = newReg gc
1825 :     val vreg = regbind v
1826 :     in
1827 :     updtHeapPtr hp;
1828 :     emit(M.MV(ity, xreg, M.ADDT(ity, vreg, signBit)));
1829 :     def(gc, x, vreg, e, 0)
1830 :     end
1831 :     else if (fromSz = ity) andalso (toSz = Target.defaultIntSz)
1832 :     then let
1833 :     val vreg = regbind v
1834 :     val tmp = newReg INT
1835 :     val tmpR = M.REG(ity, tmp)
1836 :     val lab = newLabel ()
1837 :     in
1838 :     emit(M.MV(ity, tmp, allOnes'));
1839 :     updtHeapPtr hp;
1840 :     emit(branchWithProb(
1841 :     M.BCC(M.CMP(ity, M.LEU, vreg, tmpR),lab),
1842 :     SOME Probability.likely));
1843 :     emit(M.MV(ity, tmp, M.SLL(ity, tmpR, one)));
1844 :     emit(M.MV(ity, tmp, M.ADDT(ity, tmpR, tmpR)));
1845 :     defineLabel lab;
1846 :     defTAGINT(x, tagUnsigned(vreg), e, 0)
1847 :     end
1848 :     else error "gen:ARITH:testu with unexpected precisions (not implemented)"
1849 :    
1850 :     | gen (ARITH(P.test(fromSz, toSz), [v], x, _, e), hp) =
1851 :     if (fromSz = toSz)
1852 :     then copyM(fromSz, x, v, e, hp)
1853 :     else if (fromSz = ity) andalso (toSz = Target.defaultIntSz)
1854 :     then (updtHeapPtr hp; defTAGINT(x, tagSigned(regbind v), e, 0))
1855 :     else error "gen:ARITH:test with unexpected precisions (not implemented)"
1856 : mblume 1347 | gen (ARITH(P.test_inf _, _, _, _, _), hp) =
1857 :     error "gen:ARITH:test_inf"
1858 : jhr 4874
1859 :     | gen (ARITH(P.arith{oper, kind=P.FLOAT sz}, [v,w], x, _, e), hp) = let
1860 :     val v = fregbind v
1861 :     val w = fregbind w
1862 :     val t = (case oper
1863 :     of P.+ => M.FADD(sz, v, w)
1864 :     | P.* => M.FMUL(sz, v, w)
1865 :     | P.- => M.FSUB(sz, v, w)
1866 :     | P./ => M.FDIV(sz, v, w)
1867 :     | _ => error "unexpected primop in binary float64"
1868 :     (* end case *))
1869 :     in
1870 :     (* REAL32: FIXME *)
1871 :     treeifyDefF64(x, t, e, hp)
1872 :     end
1873 :    
1874 : monnier 429 (*** LOOKER ***)
1875 : jhr 4874 | gen (LOOKER(P.!, [v], x, _, e), hp) = let
1876 :     val mem = arrayRegion(getRegion v)
1877 :     in
1878 :     defBoxed (x, M.LOAD(ity, regbind v, mem), e, hp)
1879 :     end
1880 :     | gen (LOOKER(P.subscript, [v,w], x, _, e), hp) = let
1881 :     (* get data pointer *)
1882 :     val mem = dataptrRegion v
1883 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1884 :     val mem' = arrayRegion mem
1885 :     in
1886 :     defBoxed (x, M.LOAD(ity, scaleWord(a, w), mem'), e, hp)
1887 :     end
1888 :     | gen (LOOKER(P.numsubscript{kind=P.INT 8}, [v, i], x, _, e), hp) = let
1889 :     (* get data pointer *)
1890 :     val mem = dataptrRegion v
1891 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1892 :     val mem' = arrayRegion mem
1893 :     in
1894 :     defTAGINT(x, tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
1895 :     end
1896 :     (* REAL32: FIXME *)
1897 :     | gen (LOOKER(P.numsubscript{kind=P.FLOAT 64}, [v,i], x, _, e), hp) = let
1898 :     (* get data pointer *)
1899 :     val mem = dataptrRegion v
1900 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1901 :     val mem' = arrayRegion mem
1902 :     in
1903 :     treeifyDefF64(x, M.FLOAD(fty,scale8(a, i), mem'), e, hp)
1904 :     end
1905 : jhr 4540 | gen (LOOKER(P.gethdlr,[],x,_,e), hp) = defBoxed(x, C.exnptr(vfp), e, hp)
1906 :     | gen (LOOKER(P.getvar, [], x, _, e), hp) = defBoxed(x, C.varptr(vfp), e, hp)
1907 :     | gen (LOOKER(P.getspecial, [v], x, _, e), hp) = defBoxed(
1908 :     x,
1909 : jhr 4544 orTag(M.SRA(ity, getObjDescriptor v, LW'(D.tagWidth-0w1))),
1910 : jhr 4540 e,
1911 :     hp)
1912 :     | gen (LOOKER(P.getpseudo, [i], x, _, e), hp) =
1913 : monnier 429 (print "getpseudo not implemented\n"; nop(x, i, e, hp))
1914 : jhr 4540 | gen (LOOKER(P.rawload { kind }, [i], x, _, e), hp) =
1915 : leunga 1174 rawload (kind, regbind i, x, e, hp)
1916 : jhr 4540 | gen (LOOKER(P.rawload { kind }, [i,j], x, _, e), hp) =
1917 : leunga 1174 rawload (kind, M.ADD(addrTy,regbind i, regbind j), x, e, hp)
1918 : jhr 4242
1919 : monnier 429 (*** SETTER ***)
1920 : jhr 4874 | gen (SETTER(P.rawupdate(FLTt 64),[v,i,w],e),hp) = (
1921 :     (* REAL32: FIXME *)
1922 :     emit(M.FSTORE(fty, scale8(regbind' v, i), fregbind w,R.memory));
1923 :     gen(e, hp))
1924 :     | gen (SETTER(P.rawupdate _, [v,i,w], e), hp) = (
1925 :     emit(M.STORE(ity, scaleWord(regbind' v, i), regbind' w, R.memory));
1926 :     gen(e, hp))
1927 : jhr 4242
1928 : jhr 4540 | gen (SETTER(P.assign, [a as VAR arr, v], e), hp) =
1929 : monnier 429 let val ea = regbind a
1930 : leunga 590 val mem = arrayRegion(getRegion a)
1931 : monnier 429 in recordStore(ea, hp);
1932 : leunga 590 emit(M.STORE(ity, ea, regbind v, mem));
1933 : jhr 4316 gen(e, hp+2*ws)
1934 : monnier 429 end
1935 : jhr 4540 | gen (SETTER(P.unboxedassign, [a, v], e), hp) =
1936 : leunga 590 let val mem = arrayRegion(getRegion a)
1937 :     in emit(M.STORE(ity, regbind a, regbind v, mem));
1938 :     gen(e, hp)
1939 :     end
1940 : jhr 4540 | gen (SETTER(P.update, [v,i,w], e), hp) =
1941 : monnier 429 let (* get data pointer *)
1942 : leunga 590 val mem = dataptrRegion v
1943 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1944 : monnier 429 val tmpR = Cells.newReg() (* derived pointer! *)
1945 : leunga 590 val tmp = M.REG(ity, tmpR)
1946 : jhr 4316 val ea = scaleWord(a, i) (* address of updated cell *)
1947 : leunga 590 val mem' = arrayRegion(mem)
1948 : monnier 429 in emit(M.MV(ity, tmpR, ea));
1949 :     recordStore(tmp, hp);
1950 : leunga 590 emit(M.STORE(ity, tmp, regbind w, mem'));
1951 : jhr 4316 gen(e, hp+2*ws)
1952 : monnier 429 end
1953 : jhr 4540 | gen (SETTER(P.unboxedupdate, [v, i, w], e), hp) =
1954 : monnier 429 let (* get data pointer *)
1955 : leunga 590 val mem = dataptrRegion v
1956 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1957 :     val mem' = arrayRegion mem
1958 : jhr 4316 in emit(M.STORE(ity, scaleWord(a, i), regbind w, mem'));
1959 : monnier 429 gen(e, hp)
1960 :     end
1961 : jhr 4540 | gen (SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) =
1962 : monnier 429 let (* get data pointer *)
1963 : leunga 590 val mem = dataptrRegion v
1964 :     val a = markPTR(M.LOAD(ity, regbind s, mem))
1965 :     val ea = scale1(a, i)
1966 :     val mem' = arrayRegion mem
1967 :     in emit(M.STORE(8, ea, untagUnsigned(v), mem'));
1968 : monnier 429 gen(e, hp)
1969 :     end
1970 : jhr 4540 | gen (SETTER(P.numupdate{kind=P.FLOAT 64},[v,i,w],e), hp) =
1971 : monnier 429 let (* get data pointer *)
1972 : leunga 590 val mem = dataptrRegion v
1973 :     val a = markPTR(M.LOAD(ity, regbind v, mem))
1974 :     val mem' = arrayRegion mem
1975 : jhr 4242 in emit(M.FSTORE(fty,scale8(a, i), fregbind w, mem'));
1976 : monnier 429 gen(e, hp)
1977 :     end
1978 : jhr 4540 | gen (SETTER(P.setspecial, [v, i], e), hp) =
1979 : george 761 let val ea = M.SUB(ity, regbind v, LI 4)
1980 : jhr 4242 val i' =
1981 :     case i
1982 : jhr 4560 of NUM{ty={tag=true, ...}, ival} => LI(D.makeDesc(ival, D.tag_special))
1983 : jhr 4544 | _ => M.ORB(ity, M.SLL(ity, untagSigned i, LW' D.tagWidth),
1984 : jhr 4550 LI D.desc_special)
1985 : leunga 590 val mem = getRegionPi(v, 0)
1986 :     in emit(M.STORE(ity, ea, i', mem));
1987 : monnier 429 gen(e, hp)
1988 :     end
1989 : jhr 4540 | gen (SETTER(P.sethdlr,[x],e), hp) =
1990 : george 823 (emit(assign(C.exnptr(vfp), regbind x)); gen(e, hp))
1991 : jhr 4540 | gen (SETTER(P.setvar,[x],e), hp) =
1992 : george 823 (emit(assign(C.varptr(vfp), regbind x)); gen(e, hp))
1993 : jhr 4540 | gen (SETTER(P.acclink,_,e), hp) = gen(e, hp)
1994 :     | gen (SETTER(P.setmark,_,e), hp) = gen(e, hp)
1995 :     | gen (SETTER(P.free,[x],e), hp) = gen(e, hp)
1996 : jhr 4874 | gen (SETTER(P.setpseudo,_,e), hp) = (print "setpseudo not implemented\n"; gen(e, hp))
1997 :     | gen (SETTER (P.rawstore { kind }, [i, x], e), hp) = (
1998 :     rawstore (kind, regbind i, x); gen (e, hp))
1999 :     | gen (SETTER (P.rawstore { kind }, [i, j, x], e), hp) = (
2000 :     rawstore (kind, M.ADD(addrTy, regbind i, regbind j), x);
2001 :     gen (e, hp))
2002 :     | gen (RCC(arg as (_, _, _, _, wtl, e)), hp) = let
2003 :     val {result, hp} = CPSCCalls.c_call {
2004 :     stream = stream, regbind = regbind,
2005 :     fregbind = fregbind, typmap = typmap,
2006 :     vfp = vfp, hp = hp
2007 :     } arg
2008 :     in
2009 :     case (result, wtl)
2010 :     of ([], [(w, _)]) => defTAGINT (w, mlZero, e, hp) (* void result *)
2011 :     | ([M.FPR x],[(w,CPS.FLTt 64)]) => treeifyDefF64 (w, x, e, hp) (* REAL32: *)
2012 :     (* more sanity checking here ? *)
2013 :     | ([M.GPR x],[(w, CPS.NUMt{tag=false, ...})]) => defINT (w, x, e, hp)
2014 :     | ([M.GPR x],[(w, CPS.PTRt _)]) => defBoxed (w, x, e, hp)
2015 :     | ([M.GPR x1, M.GPR x2],
2016 :     [(w1, CPS.NUMt{tag=false, ...}), (w2, CPS.NUMt{tag=false, ...})]
2017 :     ) => let
2018 :     val (r1, r2) = (newReg INT, newReg INT)
2019 :     in
2020 :     addRegBinding(w1, r1);
2021 :     addRegBinding(w2, r2);
2022 :     emit(M.MV(ity,r1,x1));
2023 :     emit(M.MV(ity,r2,x2));
2024 :     gen(e,hp)
2025 :     end
2026 :     | _ => error "RCC: bad results"
2027 :     (* end case *)
2028 :     end
2029 : jhr 4242
2030 : monnier 429 (*** BRANCH ***)
2031 : jhr 4560 | gen (BRANCH(P.cmp{oper, kind}, [NUM v, NUM k], _, e, d), hp) =
2032 :     if evalCmp(kind, oper, #ival v, #ival k)
2033 : jhr 4550 then gen(e, hp)
2034 :     else gen(d, hp)
2035 : jhr 4548 | gen (BRANCH(P.cmp{oper, kind=P.INT _}, vw, p, e, d), hp) =
2036 : george 1168 branch(p, signedCmp oper, vw, e, d, hp)
2037 : jhr 4548 | gen (BRANCH(P.cmp{oper, kind=P.UINT _}, vw, p, e, d), hp) =
2038 : george 1168 branch(p, unsignedCmp oper, vw, e, d, hp)
2039 : jhr 4540 (* REAL32: FIXME *)
2040 :     | gen (BRANCH(P.fcmp{oper=P.fsgn,size=64}, [v], p, d, e), hp) = let
2041 : jhr 3673 val trueLab = newLabel ()
2042 :     val r = fregbind v
2043 : jhr 4874 val r' = newReg INT
2044 : jhr 3673 val rReg = M.REG(ity, r')
2045 :     (* address of the word that contains the sign bit *)
2046 :     val addr = if MachineSpec.bigEndian
2047 : jhr 4550 then M.ADD(addrTy, C.allocptr, LI' hp)
2048 :     else M.ADD(pty, rReg, LI'((fty - pty) div 8))
2049 : jhr 3673 in
2050 : jhr 4550 emit(M.MV(ity, r', M.ADD(addrTy, C.allocptr, LI' hp)));
2051 : gkuan 2732 emit(M.FSTORE(fty,rReg,r,R.memory));
2052 : jhr 3673 emit(M.BCC(M.CMP(ity, M.LT, M.LOAD(ity, addr, R.memory), zero), trueLab));
2053 : gkuan 2732 genCont(e, hp);
2054 : jhr 3673 genlab(trueLab, d, hp)
2055 :     end
2056 : jhr 4540 (* REAL32: FIXME *)
2057 :     | gen (BRANCH(P.fcmp{oper,size=64}, [v,w], p, d, e), hp) =
2058 : george 909 let val trueLab = newLabel ()
2059 : leunga 1174 val cmp = real64Cmp(oper, v, w)
2060 : leunga 744 in emit(M.BCC(cmp, trueLab));
2061 : leunga 585 genCont(e, hp);
2062 : monnier 429 genlab(trueLab, d, hp)
2063 :     end
2064 : jhr 4550 | gen (BRANCH(P.peql, vw, p, e, d), hp) = branch(p, M.EQ, vw, e, d, hp)
2065 : jhr 4540 | gen (BRANCH(P.pneq, vw, p, e, d), hp) = branch(p, M.NE, vw, e, d, hp)
2066 : jhr 4560 | gen (BRANCH(P.strneq, [NUM{ty={tag=true, ...}, ival},v,w], p, d, e), hp) =
2067 :     branchStreq(ival, v, w, e, d, hp)
2068 :     | gen (BRANCH(P.streq, [NUM{ty={tag=true, ...}, ival},v,w],p,d,e), hp) =
2069 :     branchStreq(ival, v, w, d, e, hp)
2070 : jhr 4550 | gen (BRANCH(P.boxed, [x], p, a, b), hp) = branchOnBoxed(p, x, a, b, hp)
2071 :     | gen (BRANCH(P.unboxed, [x], p, a, b), hp) = branchOnBoxed(p, x, b, a, hp)
2072 :     | gen (e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
2073 : leunga 585
2074 :     end (*local*)
2075 : jhr 4242
2076 :     fun fragComp() =
2077 : monnier 429 let fun continue() = fcomp (Frag.next())
2078 :     and fcomp(NONE) = ()
2079 :     | fcomp(SOME(_, Frag.KNOWNFUN _)) = continue()
2080 :     | fcomp(SOME(_, Frag.KNOWNCHK _)) = continue()
2081 :     | fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue()
2082 : jhr 4242 | fcomp(SOME(lab,
2083 :     Frag.STANDARD{func as ref(SOME (zz as (k,f,vl,tl,e))),
2084 :     ...})) =
2085 : george 823 let val formals = ArgP.standard{fnTy=typmap f, argTys=tl, vfp=vfp}
2086 : leunga 585 in func := NONE;
2087 : george 984 pseudoOp(PB.ALIGN_SZ 2);
2088 : leunga 585 genCPSFunction(lab, k, f, vl, formals, tl, e);
2089 :     continue()
2090 : monnier 429 end
2091 :     in fcomp (Frag.next())
2092 :     end (* fragComp *)
2093 : monnier 247
2094 : jhr 4242 (*
2095 :     * execution starts at the first CPS function -- the frag
2096 : monnier 429 * is maintained as a queue.
2097 :     *)
2098 : mblume 1334 fun initFrags (start::rest : CPS.function list) =
2099 : jhr 4242 let fun init(func as (fk, f, _, _, _)) =
2100 : mblume 1334 addGenTbl (f, Frag.makeFrag(func, functionLabel f))
2101 :     in
2102 :     app init rest;
2103 :     init start
2104 :     end
2105 :     | initFrags [] = error "initFrags"
2106 : leunga 602
2107 :     (*
2108 :     * Create cluster annotations.
2109 :     * Currently, we only need to enter the appropriate
2110 :     * gc map information.
2111 :     *)
2112 : george 823 fun clusterAnnotations() = let
2113 :     val cellinfo =
2114 : jhr 4242 if gctypes then
2115 : george 823 let fun enter(M.REG(_,r),ty) = enterGC(r, ty)
2116 :     | enter _ = ()
2117 :     in enterGC(allocptrR, SMLGCType.ALLOCPTR);
2118 :     enter(C.limitptr(vfp), SMLGCType.LIMITPTR);
2119 :     enter(C.baseptr(vfp), PTR);
2120 :     enter(C.stdlink(vfp), PTR);
2121 :     [#create An.PRINT_CELLINFO(GCCells.printType)
2122 :     ]
2123 :     end
2124 :     else []
2125 :     in
2126 :     if vfp then #set An.USES_VIRTUAL_FRAME_POINTER ((), cellinfo)
2127 :     else cellinfo
2128 :     end
2129 : leunga 602 in
2130 : george 823 initFrags cluster;
2131 :     beginCluster 0;
2132 : george 1192 pseudoOp PB.TEXT;
2133 : george 823 fragComp();
2134 :     InvokeGC.emitLongJumpsToGCInvocation stream;
2135 : george 909 compile(endCluster(clusterAnnotations()))
2136 : monnier 429 end (* genCluster *)
2137 : monnier 247
2138 : george 984 fun finishCompilationUnit file = let
2139 : george 933 val stream = MLTreeComp.selectInstructions (Flowgen.build ())
2140 : george 984 val TS.S.STREAM{beginCluster, pseudoOp, endCluster, ...} = stream
2141 : george 909 in
2142 :     Cells.reset();
2143 :     ClusterAnnotation.useVfp := false;
2144 : jhr 4242 beginCluster 0;
2145 : george 1192 pseudoOp PB.TEXT;
2146 : george 984 InvokeGC.emitModuleGC stream;
2147 :     pseudoOp (PB.DATA_READ_ONLY);
2148 :     pseudoOp (PB.EXT(CPs.FILENAME file));
2149 : george 909 compile(endCluster NO_OPT)
2150 :     end
2151 : george 1116
2152 : blume 1128 fun entrypoint ((_,f,_,_,_)::_) () = Label.addrOf (functionLabel f)
2153 : mblume 1334 | entrypoint [] () = error "entrypoint: no functions"
2154 : jhr 4242 in
2155 : george 909 app mkGlobalTables funcs;
2156 :     app genCluster (Cluster.cluster funcs);
2157 : blume 1128 finishCompilationUnit source;
2158 :     entrypoint (funcs)
2159 : monnier 247 end (* codegen *)
2160 :     end (* MLRiscGen *)

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