DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / gpcp-linux.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Remove batch
[gpcp-linux.git] / gpcp / MsilMaker.cp
1 (* ============================================================ *)
2 (* MsilMaker is the concrete class for emitting COM2+ *)
3 (* intermediate language for the VOS. *)
4 (* Copyright (c) John Gough 1999, 2000. *)
5 (* Ugly kludge for covariant OUT params comes out *)
6 (* next time. Search "fixup". (kjg, 19 May 2001) *)
7 (* ============================================================ *)
8
9 MODULE MsilMaker;
10
11 IMPORT
12 GPCPcopyright,
13 Error,
14 GPText,
15 Console,
16 FileNames,
17 MsilAsm,
18 MsilBase,
19 ClassMaker,
20 GPFiles,
21 GPBinFiles,
22 GPTextFiles,
23 PeUtil,
24 IlasmUtil,
25 Nh := NameHash,
26 Scn := CPascalS,
27 Psr := CPascalP,
28 CSt := CompState,
29 Asm := IlasmCodes,
30 Mu := MsilUtil,
31 Lv := LitValue,
32 Bi := Builtin,
33 Sy := Symbols,
34 Id := IdDesc ,
35 Ty := TypeDesc,
36 Xp := ExprDesc,
37 St := StatDesc;
38
39 (* ============================================================ *)
40
41 CONST pubStat = Asm.att_public + Asm.att_static;
42 staticAtt = Asm.att_static;
43 extern = Asm.att_extern;
44
45 CONST inlineLimit = 4; (* limit for inline expansion of element copies *)
46
47 (* ============================================================ *)
48
49 TYPE MsilEmitter* =
50 POINTER TO
51 RECORD (MsilBase.ClassEmitter)
52 (* --------------------------- *
53 * mod* : Id.BlkId; *
54 * --------------------------- *)
55 work : Sy.IdSeq;
56 outF : Mu.MsilFile;
57 END;
58
59 (* ------------------------------------ *)
60
61 TYPE MsilAssembler* =
62 POINTER TO
63 RECORD (ClassMaker.Assembler)
64 emit : Mu.MsilFile;
65 END;
66
67 (* ------------------------------------ *)
68
69 VAR asmName : Lv.CharOpen;
70 asmExe : BOOLEAN;
71
72 (* ============================================================ *)
73 (* ============================================================ *)
74
75 PROCEDURE newMsilEmitter*(mod : Id.BlkId) : MsilEmitter;
76 VAR emitter : MsilEmitter;
77 BEGIN
78 NEW(emitter);
79 emitter.mod := mod;
80 MsilBase.emitter := emitter;
81 Sy.InitIdSeq(emitter.work, 4);
82 Sy.AppendIdnt(emitter.work, mod);
83 RETURN emitter;
84 END newMsilEmitter;
85
86 (* ============================================================ *)
87
88 PROCEDURE newMsilAsm*() : MsilAssembler;
89 VAR asm : MsilAssembler;
90 BEGIN
91 NEW(asm);
92 MsilAsm.Init();
93 RETURN asm;
94 END newMsilAsm;
95
96 (* ============================================================ *)
97
98 PROCEDURE IdentOf(x : Sy.Expr) : Sy.Idnt;
99 BEGIN
100 WITH x : Xp.IdLeaf DO RETURN x.ident;
101 | x : Xp.IdentX DO RETURN x.ident;
102 ELSE RETURN NIL;
103 END;
104 END IdentOf;
105
106 (* ============================================================ *)
107
108 PROCEDURE fieldAttr(id : Sy.Idnt; in : SET) : SET;
109 BEGIN
110 IF id.type IS Ty.Event THEN (* backing field of event *)
111 RETURN in + Asm.att_private;
112 ELSIF id.vMod # Sy.prvMode THEN
113 RETURN in + Asm.att_public;
114 ELSE
115 RETURN in + Asm.att_assembly;
116 END;
117 END fieldAttr;
118
119 (* ============================================================ *)
120 (* Creates basic imports for System, and inserts a few type *)
121 (* descriptors for Object, Exception, and String. *)
122 (* ============================================================ *)
123
124 PROCEDURE (this : MsilEmitter)Init*();
125 VAR tId : Id.TypId;
126 blk : Id.BlkId;
127 obj : Id.TypId;
128 str : Id.TypId;
129 exc : Id.TypId;
130 typ : Id.TypId;
131 del : Id.TypId;
132 evt : Id.TypId;
133 BEGIN
134 (*
135 * Create import descriptor for [mscorlib]System
136 *)
137 Bi.MkDummyImport("mscorlib_System", "[mscorlib]System", blk);
138 CSt.SetSysLib(blk);
139 (*
140 * Create various classes.
141 *)
142 Bi.MkDummyClass("Object", blk, Ty.isAbs, obj);
143 CSt.ntvObj := obj.type;
144 Bi.MkDummyClass("String", blk, Ty.noAtt, str);
145 Bi.SetPtrBase(str, obj);
146 CSt.ntvStr := str.type;
147 Bi.MkDummyClass("Exception", blk, Ty.extns, exc);
148 Bi.SetPtrBase(exc, obj);
149 CSt.ntvExc := exc.type;
150 Bi.MkDummyClass("Type", blk, Ty.isAbs, typ);
151 Bi.SetPtrBase(typ, obj);
152 CSt.ntvTyp := typ.type;
153
154 Bi.MkDummyClass("Delegate", blk, Ty.extns, del);
155 Bi.SetPtrBase(del, obj);
156 Bi.MkDummyClass("MulticastDelegate", blk, Ty.extns, evt);
157 Bi.SetPtrBase(evt, del);
158 CSt.ntvEvt := evt.type;
159
160 (* NEED SOME WORK HERE?? *)
161
162 Bi.MkDummyClass("ValueType", blk, Ty.extns, del);
163 Bi.SetPtrBase(del, obj);
164 CSt.ntvVal := del.type.boundRecTp();
165
166 Mu.SetNativeNames();
167
168 (*
169 * Create import descriptor for [RTS]RTS
170 *)
171 Bi.MkDummyImport("RTS", "[RTS]", blk);
172 Bi.MkDummyAlias("NativeType", blk, typ.type, CSt.clsId);
173 Bi.MkDummyAlias("NativeObject", blk, obj.type, CSt.objId);
174 Bi.MkDummyAlias("NativeString", blk, str.type, CSt.strId);
175 Bi.MkDummyAlias("NativeException", blk, exc.type, CSt.excId);
176 INCL(blk.xAttr, Sy.need);
177 CSt.rtsBlk := blk;
178 (*
179 * Uplevel addressing stuff. This is part of RTS assembly.
180 *)
181 Bi.MkDummyClass("XHR", blk, Ty.isAbs, typ);
182 CSt.rtsXHR := typ.type;
183 CSt.xhrId.recTyp := CSt.rtsXHR.boundRecTp();
184 CSt.xhrId.type := CSt.rtsXHR;
185 (*
186 * Access to [RTS]RTS::dblPosInfinity, etc.
187 *)
188 Bi.MkDummyVar("dblPosInfinity", blk, Bi.realTp, CSt.dblInf);
189 Bi.MkDummyVar("dblNegInfinity", blk, Bi.realTp, CSt.dblNInf);
190 Bi.MkDummyVar("fltPosInfinity", blk, Bi.sReaTp, CSt.fltInf);
191 Bi.MkDummyVar("fltNegInfinity", blk, Bi.sReaTp, CSt.fltNInf);
192 (*
193 * Access to [RTS]ProgArgs::argList
194 *)
195 Bi.MkDummyImport("ProgArgs", "", blk);
196 Bi.MkDummyVar("argList", blk, Ty.mkArrayOf(CSt.ntvStr), CSt.argLst);
197 INCL(blk.xAttr, Sy.rtsMd);
198 CSt.prgArg := blk;
199 END Init;
200
201 (* ============================================================ *)
202
203 PROCEDURE (this : MsilEmitter)ObjectFeatures*();
204 VAR prcSig : Ty.Procedure;
205 thePar : Id.ParId;
206 BEGIN
207 NEW(prcSig);
208 prcSig.retType := CSt.strId.type;
209 Id.InitParSeq(prcSig.formals, 2);
210 Bi.MkDummyMethodAndInsert("ToString", prcSig, CSt.ntvObj, CSt.sysLib, Sy.pubMode, Sy.var, Id.extns);
211
212 NEW(prcSig);
213 prcSig.retType := Bi.intTp;
214 Id.InitParSeq(prcSig.formals, 2);
215 Bi.MkDummyMethodAndInsert("GetHashCode", prcSig, CSt.ntvObj, CSt.sysLib, Sy.pubMode, Sy.var, Id.extns);
216
217 NEW(prcSig);
218 prcSig.retType := CSt.ntvObj;
219 Id.InitParSeq(prcSig.formals, 2);
220 Bi.MkDummyMethodAndInsert("MemberwiseClone", prcSig, CSt.ntvObj, CSt.sysLib, Sy.protect, Sy.var, Id.extns);
221
222 NEW(prcSig);
223 NEW(thePar);
224 prcSig.retType := Bi.boolTp;
225 Id.InitParSeq(prcSig.formals, 2);
226 thePar.parMod := Sy.val;
227 thePar.type := CSt.ntvObj;
228 thePar.varOrd := 1;
229 Id.AppendParam(prcSig.formals, thePar);
230 Bi.MkDummyMethodAndInsert("Equals", prcSig, CSt.ntvObj, CSt.sysLib, Sy.pubMode, Sy.var, Id.extns);
231 END ObjectFeatures;
232
233 (* ============================================================ *)
234
235 PROCEDURE (this : MsilEmitter)mkThreadAssign() : Sy.Stmt,NEW;
236 VAR stmt : Sy.Stmt;
237 text : ARRAY 3 OF Lv.CharOpen;
238 BEGIN
239 text[0] := BOX("__thread__ := mscorlib_System_Threading.Thread.init(__wrapper__);");
240 text[1] := BOX("__thread__.set_ApartmentState(mscorlib_System_Threading.ApartmentState.STA);");
241 text[2] := BOX("__thread__.Start(); END");
242 stmt := Psr.parseTextAsStatement(text, CSt.thisMod);
243 stmt.StmtAttr(CSt.thisMod);
244 RETURN stmt;
245 END mkThreadAssign;
246
247 (* ============================================================ *)
248
249 PROCEDURE (this : MsilEmitter)AddStaMembers(),NEW;
250 VAR text : ARRAY 3 OF Lv.CharOpen;
251 proc : Sy.Idnt;
252 BEGIN
253 text[0] := BOX("VAR __thread__ : mscorlib_System_Threading.Thread;");
254 text[1] := BOX("PROCEDURE __wrapper__(); BEGIN END __wrapper__;");
255 text[2] := BOX("END");
256 Psr.ParseDeclarationText(text, CSt.thisMod);
257 proc := Sy.bindLocal(Nh.enterStr("__wrapper__"), CSt.thisMod);
258 proc(Id.PrcId).body := CSt.thisMod.modBody;
259 END AddStaMembers;
260
261 (* ============================================================ *)
262
263 PROCEDURE (this : MsilAssembler)Assemble*();
264 (** Overrides EMPTY method in ClassMaker *)
265 VAR rslt : INTEGER;
266 optA : Lv.CharOpen;
267 (* ------------------------------------ *)
268 PROCEDURE buildOption(isExe : BOOLEAN) : Lv.CharOpen;
269 VAR str : Lv.CharOpen;
270 ext : ARRAY 5 OF CHAR;
271 BEGIN
272 str := NIL;
273 IF isExe THEN ext := ".exe" ELSE ext := ".dll" END;
274 IF CSt.binDir # "" THEN
275 str := BOX("/OUT=" + CSt.binDir);
276 IF str[LEN(str) - 2] = GPFiles.fileSep THEN
277 str := BOX(str^ + asmName^ + ext);
278 ELSE
279 str := BOX(str^ + "\" + asmName^ + ext);
280 END;
281 END;
282 IF CSt.debug THEN
283 IF str = NIL THEN str := BOX("/debug");
284 ELSE str := BOX(str^ + " /debug");
285 END;
286 END;
287 IF str = NIL THEN RETURN BOX(" ") ELSE RETURN str END;
288 END buildOption;
289 (* ------------------------------------ *)
290 BEGIN
291 IF asmName # NIL THEN
292 MsilAsm.DoAsm(asmName, buildOption(asmExe), asmExe, CSt.verbose, rslt);
293 IF rslt # 0 THEN CSt.thisMod.IdError(298) END;
294 END;
295 END Assemble;
296
297 (* ============================================================ *)
298
299 PROCEDURE (this : MsilEmitter)AddNewRecEmitter*(inTp : Sy.Type);
300 (* Overrides AddNewRecEmitter() in MsilBase. *)
301 VAR idnt : Sy.Idnt;
302 BEGIN
303 idnt := NIL;
304 WITH inTp : Ty.Record DO
305 IF inTp.bindTp # NIL THEN idnt := inTp.bindTp.idnt;
306 ELSIF inTp.idnt # NIL THEN idnt := inTp.idnt;
307 ELSE ASSERT(FALSE);
308 END;
309 ELSE
310 idnt := inTp.idnt;
311 END;
312 Sy.AppendIdnt(this.work, idnt);
313 END AddNewRecEmitter;
314
315 (* ============================================================ *)
316
317 PROCEDURE^ (e : MsilEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
318 PROCEDURE^ (e : MsilEmitter)EmitProc(proc : Id.Procs; attr : SET),NEW;
319 PROCEDURE^ (e : MsilEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
320 PROCEDURE^ (e : MsilEmitter)PushHandle(exp : Sy.Expr; typ : Sy.Type),NEW;
321 PROCEDURE^ (e : MsilEmitter)PushRef(exp : Sy.Expr; typ : Sy.Type),NEW;
322 PROCEDURE^ (e : MsilEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
323 PROCEDURE^ (e : MsilEmitter)PushCall(callX : Xp.CallX),NEW;
324 PROCEDURE^ (e : MsilEmitter)FallFalse(exp : Sy.Expr; tLb : Mu.Label),NEW;
325
326 PROCEDURE^ (e : MsilEmitter)RefRecCopy(typ : Ty.Record),NEW;
327 PROCEDURE^ (e : MsilEmitter)RefArrCopy(typ : Ty.Array),NEW;
328 PROCEDURE^ (e : MsilEmitter)GetArgP(act : Sy.Expr; frm : Id.ParId),NEW;
329
330 (* ============================================================ *)
331
332 PROCEDURE (t : MsilEmitter)MakeInit(rec : Ty.Record;
333 prc : Id.PrcId),NEW;
334 VAR out : Mu.MsilFile;
335 idx : INTEGER;
336 fld : Sy.Idnt;
337 spr : Id.PrcId;
338 frm : Id.ParId;
339 exp : Sy.Expr;
340 spT : Ty.Procedure;
341 lve : BOOLEAN;
342 BEGIN
343 spr := NIL;
344 out := t.outF;
345 out.Blank();
346 IF prc = NIL THEN
347 IF Sy.noNew IN rec.xAttr THEN
348 out.Comment("There is no no-arg constructor for this class");
349 out.Blank();
350 RETURN; (* PREMATURE RETURN HERE *)
351 ELSIF Sy.xCtor IN rec.xAttr THEN
352 out.Comment("There is an explicit no-arg constructor for this class");
353 out.Blank();
354 RETURN; (* PREMATURE RETURN HERE *)
355 END;
356 END;
357 out.MkNewProcInfo(prc);
358 out.InitHead(rec, prc);
359 IF prc # NIL THEN
360 spr := prc.basCll.sprCtor(Id.PrcId);
361 IF spr # NIL THEN
362 spT := spr.type(Ty.Procedure);
363 IF spT.xName = NIL THEN Mu.MkCallAttr(spr, out) END;
364 FOR idx := 0 TO prc.basCll.actuals.tide - 1 DO
365 frm := spT.formals.a[idx];
366 exp := prc.basCll.actuals.a[idx];
367 t.GetArgP(exp, frm);
368 END;
369 END;
370 END;
371 out.CallSuper(rec, spr);
372 (*
373 * Initialize fields, as necessary.
374 *)
375 IF rec # NIL THEN
376 FOR idx := 0 TO rec.fields.tide-1 DO
377 fld := rec.fields.a[idx];
378 IF Mu.needsInit(fld.type) THEN
379 out.CommentT("Initialize embedded object");
380 out.Code(Asm.opc_ldarg_0);
381 out.StructInit(fld);
382 END;
383 END;
384 END;
385 IF (prc # NIL) & (prc.body # NIL) THEN
386 IF prc.rescue # NIL THEN out.Try END;
387 t.EmitStat(prc.body, lve);
388 IF lve THEN out.DoReturn END;
389 IF prc.rescue # NIL THEN
390 out.Catch(prc);
391 t.EmitStat(prc.rescue, lve);
392 IF lve THEN out.DoReturn END;
393 out.EndCatch;
394 END;
395 ELSE
396 out.Code(Asm.opc_ret);
397 END;
398 out.InitTail(rec);
399 END MakeInit;
400
401 (* ============================================================ *)
402
403 PROCEDURE (t : MsilEmitter)CopyProc(recT : Ty.Record),NEW;
404 VAR out : Mu.MsilFile;
405 indx : INTEGER;
406 fTyp : Sy.Type;
407 idnt : Id.FldId;
408 BEGIN
409 (*
410 * Emit the copy procedure "__copy__()
411 *)
412 out := t.outF;
413 out.Blank();
414 out.MkNewProcInfo(t.mod);
415 out.CopyHead(recT);
416 (*
417 * Recurse to super class, if necessary.
418 *)
419 IF (recT.baseTp # NIL) &
420 ~recT.baseTp.isNativeObj() THEN
421 (*
422 * (recT.baseTp IS Ty.Record) THEN
423 *)
424 out.Code(Asm.opc_ldarg_0);
425 out.Code(Asm.opc_ldarg_1);
426 t.RefRecCopy(recT.baseTp(Ty.Record));
427 END;
428 (*
429 * Emit field-by-field copy.
430 *)
431 FOR indx := 0 TO recT.fields.tide-1 DO
432 idnt := recT.fields.a[indx](Id.FldId);
433 fTyp := idnt.type;
434 out.Code(Asm.opc_ldarg_0);
435 IF Mu.hasValueRep(fTyp) THEN
436 out.Code(Asm.opc_ldarg_1);
437 out.GetField(idnt);
438 out.PutField(idnt);
439 ELSE
440 out.GetField(idnt);
441 out.Code(Asm.opc_ldarg_1);
442 out.GetField(idnt);
443 WITH fTyp : Ty.Array DO
444 t.RefArrCopy(fTyp);
445 | fTyp : Ty.Record DO
446 t.RefRecCopy(fTyp);
447 END;
448 END;
449 END;
450 out.Code(Asm.opc_ret);
451 out.CopyTail;
452 END CopyProc;
453
454 (* ============================================================ *)
455
456 PROCEDURE (this : MsilEmitter)
457 EmitMethod(out : Mu.MsilFile; method : Id.MthId),NEW;
458 VAR mthSet : SET;
459 attSet : SET;
460 BEGIN
461 mthSet := method.mthAtt * Id.mask;
462 (*
463 * Get the extension bits:
464 * {} == att_final ==> inextensible, ie. final AND virtual
465 * {1} == att_isAbs ==> abstract AND virtual
466 * {2} == att_empty ==> empty, and thus virtual
467 * {1,2} == att_extns ==> extensible, thus virtual
468 *)
469 IF mthSet = {} THEN
470 IF Id.newBit IN method.mthAtt THEN
471 attSet := Asm.att_instance;
472 ELSE
473 attSet := Asm.att_final + Asm.att_virtual;
474 END;
475 ELSIF mthSet = Id.isAbs THEN
476 attSet := Asm.att_virtual + Asm.att_abstract;
477 IF Id.newBit IN method.mthAtt THEN
478 attSet := attSet + Asm.att_newslot END;
479 ELSE
480 attSet := Asm.att_virtual;
481 IF Id.newBit IN method.mthAtt THEN
482 attSet := attSet + Asm.att_newslot END;
483 END;
484 IF Id.widen IN method.mthAtt THEN attSet := attSet + Asm.att_public END;
485 this.EmitProc(method, attSet)
486 END EmitMethod;
487
488 (* ============================================================ *)
489
490 PROCEDURE (this : MsilEmitter)
491 EmitRecBody(out : Mu.MsilFile; typId : Id.TypId),NEW;
492 (** Create the assembler for a class file for this record. *)
493 VAR index : INTEGER;
494 ident : Sy.Idnt;
495 baseT : Sy.Type;
496 field : Id.FldId;
497 method : Id.MthId;
498 attSet : SET;
499 clsSet : SET;
500 mthSet : SET;
501 record : Ty.Record;
502 valRec : BOOLEAN;
503 mkInit : BOOLEAN;
504 mkCopy : BOOLEAN;
505 boxMth : Sy.IdSeq;
506
507 BEGIN
508 out.Blank();
509 record := typId.type.boundRecTp()(Ty.Record);
510 mkInit := Sy.clsTp IN record.xAttr;
511 mkCopy := ~(Sy.noCpy IN record.xAttr);
512 valRec := ~(Sy.clsTp IN record.xAttr);
513 (*
514 * Account for the record attributes.
515 *)
516 CASE record.recAtt OF
517 | Ty.noAtt : attSet := Asm.att_sealed;
518 | Ty.isAbs : attSet := Asm.att_abstract;
519 | Ty.cmpnd : attSet := Asm.att_abstract;
520 | Ty.limit : attSet := Asm.att_empty;
521 | Ty.extns : attSet := Asm.att_empty;
522 | Ty.iFace : attSet := Asm.att_interface;
523 mkInit := FALSE;
524 mkCopy := FALSE;
525 END;
526 (*
527 * Account for the identifier visibility.
528 * It appears that the VOS only supports two kinds:
529 * "public" == exported from this assembly
530 * <empty> == not exported from this assembly
531 * Note that private is enforced by the name mangling
532 * for types that are local to a procedure.
533 *)
534 IF typId.vMod = Sy.pubMode THEN
535 attSet := attSet + Asm.att_public;
536 END;
537 clsSet := attSet;
538 IF valRec THEN attSet := attSet + Asm.att_value END;
539 out.Comment("RECORD " + record.name()^);
540 (*
541 * Emit header with optional super class attribute.
542 *)
543 out.ClassHead(attSet, record, record.superType());
544 (*
545 * List the interfaces, if any.
546 *)
547 IF record.interfaces.tide > 0 THEN
548 out.MarkInterfaces(record.interfaces);
549 END;
550 out.OpenBrace(2);
551 (*
552 * Emit all the fields ...
553 *)
554 FOR index := 0 TO record.fields.tide-1 DO
555 ident := record.fields.a[index];
556 field := ident(Id.FldId);
557 out.EmitField(field, fieldAttr(field, Asm.att_empty));
558 END;
559 (*
560 * Emit any constructors.
561 *)
562 IF mkInit THEN this.MakeInit(record, NIL) END;
563 FOR index := 0 TO record.statics.tide-1 DO
564 ident := record.statics.a[index];
565 this.MakeInit(record, ident(Id.PrcId));
566 END;
567 IF mkCopy THEN this.CopyProc(record) END;
568 (*
569 * Emit all the (non-forward) methods ...
570 *)
571 FOR index := 0 TO record.methods.tide-1 DO
572 ident := record.methods.a[index];
573 method := ident(Id.MthId);
574 IF (method.kind = Id.conMth) THEN
575 IF valRec & (method.rcvFrm.type IS Ty.Pointer) THEN
576 Sy.AppendIdnt(boxMth, method);
577 ELSE
578 this.EmitMethod(out, method);
579 END;
580 END;
581 END;
582 FOR index := 0 TO record.events.tide-1 DO
583 out.EmitEventMethods(record.events.a[index](Id.AbVar));
584 END;
585 out.CloseBrace(2);
586 out.ClassTail();
587 IF valRec THEN (* emit boxed class type *)
588 out.StartBoxClass(record, clsSet, this.mod);
589 FOR index := 0 TO boxMth.tide-1 DO
590 ident := boxMth.a[index];
591 method := ident(Id.MthId);
592 this.EmitMethod(out, method);
593 END;
594 out.CloseBrace(2);
595 out.ClassTail();
596 END;
597 END EmitRecBody;
598
599 (* ============================================================ *)
600
601 PROCEDURE (this : MsilEmitter)EmitModBody(out : Mu.MsilFile;
602 mod : Id.BlkId),NEW;
603 (** Create the assembler for a class file for this module. *)
604 VAR index : INTEGER;
605 proc : Id.Procs;
606 recT : Sy.Type;
607 varId : Sy.Idnt;
608 cfLive : BOOLEAN; (* Control Flow is (still) live *)
609 threadDummy : Sy.Stmt;
610 threadField : Sy.Idnt;
611 BEGIN
612 out.MkBodyClass(mod);
613
614 threadDummy := NIL; (* to avoid warning *)
615 IF Sy.sta IN this.mod.xAttr THEN
616 this.AddStaMembers();
617 threadDummy := this.mkThreadAssign();
618 END;
619
620 out.OpenBrace(2);
621 FOR index := 0 TO this.mod.procs.tide-1 DO
622 (*
623 * Create the mangled name for all procedures
624 * (including static and type-bound methods).
625 *)
626 proc := this.mod.procs.a[index];
627 Mu.MkProcName(proc, out);
628 Mu.RenumberLocals(proc, out);
629 END;
630 (*
631 * Emit all of the static fields
632 *)
633 FOR index := 0 TO this.mod.locals.tide-1 DO
634 varId := this.mod.locals.a[index];
635 out.EmitField(varId(Id.VarId), fieldAttr(varId, Asm.att_static));
636 END;
637 (*
638 * Emit all of the static event methods
639 *)
640 FOR index := 0 TO this.mod.locals.tide-1 DO
641 varId := this.mod.locals.a[index];
642 IF varId.type IS Ty.Event THEN out.EmitEventMethods(varId(Id.AbVar)) END;
643 END;
644 (*
645 * No constructor for the module "class",
646 * there are never any instances created.
647 *)
648 asmExe := this.mod.main; (* Boolean flag for assembler *)
649 IF asmExe THEN
650 (*
651 * Emit '<clinit>' with variable initialization
652 *)
653 out.Blank();
654 out.MkNewProcInfo(this.mod);
655 out.ClinitHead();
656 out.InitVars(this.mod);
657 out.Code(Asm.opc_ret);
658 out.ClinitTail();
659 out.Blank();
660 (*
661 * Emit module body as 'CPmain() or WinMain'
662 *)
663 out.MkNewProcInfo(this.mod);
664 out.MainHead(this.mod.xAttr);
665 IF Sy.sta IN this.mod.xAttr THEN
666 out.Comment("Real entry point for STA");
667 this.EmitStat(threadDummy, cfLive);
668 ELSE
669 this.EmitStat(this.mod.modBody, cfLive);
670 END;
671 IF cfLive THEN
672 out.Comment("Continuing directly to CLOSE");
673 this.EmitStat(this.mod.modClose, cfLive);
674 (* Sequence point for the implicit RETURN *)
675 out.LineSpan(Scn.mkSpanT(this.mod.endTok));
676 IF cfLive THEN out.Code(Asm.opc_ret) END;
677 END;
678 out.MainTail();
679 ELSE
680 (*
681 * Emit single <clinit> incorporating module body
682 *)
683 out.MkNewProcInfo(this.mod);
684 out.ClinitHead();
685 out.InitVars(this.mod);
686 this.EmitStat(this.mod.modBody, cfLive);
687 IF cfLive THEN out.Code(Asm.opc_ret) END;
688 out.ClinitTail();
689 END;
690 (*
691 * Emit all of the static procedures
692 *)
693 out.Blank();
694 FOR index := 0 TO this.mod.procs.tide-1 DO
695 proc := this.mod.procs.a[index];
696 IF (proc.kind = Id.conPrc) &
697 (proc.dfScp.kind = Id.modId) THEN this.EmitProc(proc, staticAtt) END;
698 END;
699 (*
700 * And now, just in case exported types that
701 * have class representation have been missed ...
702 *)
703 FOR index := 0 TO this.mod.expRecs.tide-1 DO
704 recT := this.mod.expRecs.a[index];
705 IF recT.xName = NIL THEN Mu.MkTypeName(recT, out) END;
706 END;
707 out.CloseBrace(2);
708 out.ClassTail();
709 END EmitModBody;
710
711 (* ============================================================ *)
712 (* Mainline emitter, consumes worklist emitting assembler *)
713 (* files until the worklist is empty. *)
714 (* ============================================================ *)
715
716 PROCEDURE (this : MsilEmitter)MakeAbsName(),NEW;
717 VAR nPtr : POINTER TO ARRAY OF CHAR;
718 dPtr : POINTER TO ARRAY OF CHAR;
719 BEGIN
720 IF this.mod.main THEN
721 nPtr := BOX(this.mod.pkgNm$ + ".EXE");
722 ELSE
723 nPtr := BOX(this.mod.pkgNm$ + ".DLL");
724 END;
725 IF CSt.binDir # "" THEN
726 dPtr := BOX(CSt.binDir$);
727 IF dPtr[LEN(dPtr) - 2] = GPFiles.fileSep THEN
728 nPtr := BOX(dPtr^ + nPtr^);
729 ELSE
730 nPtr := BOX(dPtr^ + "\" + nPtr^);
731 END;
732 END;
733 CSt.outNam := nPtr;
734 END MakeAbsName;
735
736 PROCEDURE (this : MsilEmitter)Emit*();
737 (** Create the file-state structure for this output
738 module: overrides EMPTY method in ClassMaker *)
739 VAR out : Mu.MsilFile;
740 classIx : INTEGER;
741 idDesc : Sy.Idnt;
742 impElem : Id.BlkId;
743 callApi : BOOLEAN;
744 BEGIN
745 (*
746 * callApi := CSt.doCode & ~CSt.debug;
747 *)
748 callApi := CSt.doCode & ~CSt.doIlasm;
749 Mu.MkBlkName(this.mod);
750 IF callApi THEN
751 out := PeUtil.newPeFile(this.mod.pkgNm, ~this.mod.main);
752 this.outF := out;
753 ELSE (* just produce a textual IL file *)
754 out := IlasmUtil.newIlasmFile(this.mod.pkgNm);
755 this.outF := out;
756 END;
757
758 IF ~out.fileOk() THEN
759 Scn.SemError.Report(177, 0, 0);
760 Error.WriteString("Cannot create out-file <" + out.outN^ + ">");
761 Error.WriteLn;
762 RETURN;
763 END;
764 IF CSt.verbose THEN CSt.Message("Created "+ out.outN^) END;
765 out.Header(CSt.srcNam);
766 IF this.mod.main THEN out.Comment("This module implements CPmain") END;
767 out.Blank();
768 (*
769 * out.AsmDef(this.mod.pkgNm); (* Define this assembly *)
770 *)
771 out.RefRTS(); (* Reference runtime asm *)
772 out.ExternList(); (* Reference import list *)
773 out.AsmDef(this.mod.pkgNm); (* Define this assembly *)
774 out.Blank();
775 out.SubSys(this.mod.xAttr);
776
777 IF Sy.wMain IN this.mod.xAttr THEN
778 out.Comment("WinMain entry");
779 ELSIF Sy.cMain IN this.mod.xAttr THEN
780 out.Comment("CPmain entry");
781 END;
782 IF Sy.sta IN this.mod.xAttr THEN
783 out.Comment("Single Thread Apartment");
784 END;
785
786 IF LEN(this.mod.xName$) # 0 THEN
787 out.StartNamespace(this.mod.xName);
788 out.OpenBrace(0);
789 ELSE
790 out.Comment("No Namespace");
791 END;
792 classIx := 0;
793 (*
794 * Emit all classes on worklist until empty.
795 *)
796 WHILE classIx < this.work.tide DO
797 idDesc := this.work.a[classIx];
798 WITH idDesc : Id.BlkId DO
799 this.EmitModBody(out, idDesc);
800 | idDesc : Id.TypId DO
801 IF idDesc.type IS Ty.Procedure THEN
802 out.EmitPTypeBody(idDesc);
803 ELSE
804 this.EmitRecBody(out, idDesc);
805 END;
806 END;
807 INC(classIx);
808 END;
809 IF callApi THEN
810 out.Finish();
811 IF ~CSt.quiet THEN CSt.Message("Emitted "+ out.outN^) END;
812 ELSE (* just produce a textual IL file *)
813 out.Blank();
814 IF LEN(this.mod.xName$) # 0 THEN
815 out.CloseBrace(0);
816 out.Comment("end namespace " + this.mod.xName^);
817 END;
818 out.Comment("end output produced by gpcp");
819 out.Finish();
820 (*
821 * Store the filename for the assembler.
822 *)
823 asmName := this.mod.pkgNm;
824 END;
825 (* Set the output name for MSBuild *)
826 this.MakeAbsName();
827 END Emit;
828
829 (* ============================================================ *)
830 (* Shared code-emission methods *)
831 (* ============================================================ *)
832
833 PROCEDURE (e : MsilEmitter)EmitProc(proc : Id.Procs; attr : SET),NEW;
834 VAR out : Mu.MsilFile;
835 live : BOOLEAN;
836 retn : Sy.Type;
837 indx : INTEGER;
838 nest : Id.Procs;
839 BEGIN
840 (*
841 * Recursively emit nested procedures first.
842 *)
843 FOR indx := 0 TO proc.nestPs.tide-1 DO
844 nest := proc.nestPs.a[indx];
845 IF nest.kind = Id.conPrc THEN e.EmitProc(nest, staticAtt) END;
846 END;
847 out := e.outF;
848 out.MkNewProcInfo(proc);
849 out.Blank();
850 out.Comment("PROCEDURE " + proc.prcNm^);
851 (*
852 * Compute the method attributes
853 *)
854 IF proc.vMod = Sy.pubMode THEN (* explicitly public *)
855 attr := attr + Asm.att_public;
856 ELSIF proc.dfScp IS Id.Procs THEN (* nested procedure *)
857 attr := attr + Asm.att_private;
858 ELSIF Asm.att_public * attr = {} THEN
859 (*
860 * method visiblibity could have been widened
861 * to match the demanded semantics of the CLR.
862 *)
863 attr := attr + Asm.att_assembly;
864 END;
865 out.MethodDecl(attr, proc);
866 (*
867 * Output the body if not ABSTRACT
868 *)
869 IF attr * Asm.att_abstract = {} THEN
870 out.OpenBrace(4);
871 out.LineSpan(Scn.mkSpanT(proc.token));
872 out.Code(Asm.opc_nop);
873 (*
874 * Initialize any locals which need this.
875 *)
876 out.InitVars(proc);
877 IF proc.rescue # NIL THEN out.Try END;
878 (*
879 * Finally! Emit the method body.
880 *)
881 e.EmitStat(proc.body, live);
882 (*
883 * For proper procedure which reach the fall-
884 * through ending just return.
885 *)
886 IF live & proc.type.isProperProcType() THEN
887 out.LineSpan(proc.endSpan);
888 out.DoReturn;
889 END;
890 IF proc.rescue # NIL THEN
891 out.Catch(proc);
892 e.EmitStat(proc.rescue, live);
893 IF live & proc.type.isProperProcType() THEN
894 out.LineSpan(proc.endSpan);
895 out.DoReturn;
896 END;
897 out.EndCatch;
898 END;
899 out.MethodTail(proc);
900 END;
901 END EmitProc;
902
903 (* ============================================================ *)
904 (* Expression Handling Methods *)
905 (* ============================================================ *)
906
907 PROCEDURE longValue(lit : Sy.Expr) : LONGINT;
908 BEGIN
909 RETURN lit(Xp.LeafX).value.long();
910 END longValue;
911
912 PROCEDURE intValue(lit : Sy.Expr) : INTEGER;
913 BEGIN
914 RETURN lit(Xp.LeafX).value.int();
915 END intValue;
916
917 PROCEDURE isStrExp(exp : Sy.Expr) : BOOLEAN;
918 BEGIN
919 RETURN (exp.type = Bi.strTp) &
920 (exp.kind # Xp.mkStr) OR
921 exp.type.isNativeStr();
922 END isStrExp;
923
924 PROCEDURE isNilExp(exp : Sy.Expr) : BOOLEAN;
925 BEGIN
926 RETURN exp.kind = Xp.nilLt;
927 END isNilExp;
928
929 (* ============================================================ *)
930
931 PROCEDURE (e : MsilEmitter)PushSetCmp(lOp,rOp : Sy.Expr;
932 theTest : INTEGER),NEW;
933 VAR out : Mu.MsilFile;
934 l,r : INTEGER;
935 BEGIN
936 out := e.outF;
937 e.PushValue(lOp, Bi.setTp);
938 CASE theTest OF
939 (* ---------------------------------- *)
940 | Xp.equal, Xp.notEq :
941 e.PushValue(rOp, Bi.setTp);
942 out.Code(Asm.opc_ceq);
943 IF theTest = Xp.notEq THEN
944 out.Code(Asm.opc_ldc_i4_1);
945 out.Code(Asm.opc_xor);
946 END;
947 (* ---------------------------------- *)
948 | Xp.greEq, Xp.lessEq :
949 (*
950 * The semantics are implemented by the identities
951 *
952 * (L <= R) == (L AND R = L)
953 * (L >= R) == (L OR R = L)
954 *)
955 out.Code(Asm.opc_dup);
956 e.PushValue(rOp, Bi.setTp);
957 IF theTest = Xp.greEq THEN
958 out.Code(Asm.opc_or);
959 ELSE
960 out.Code(Asm.opc_and);
961 END;
962 out.Code(Asm.opc_ceq);
963 (* ---------------------------------- *)
964 | Xp.greT, Xp.lessT :
965 l := out.proc.newLocal(Bi.setTp);
966 r := out.proc.newLocal(Bi.setTp);
967 (*
968 * The semantics are implemented by the identities
969 *
970 * (L < R) == (L AND R = L) AND NOT (L = R)
971 * (L > R) == (L OR R = L) AND NOT (L = R)
972 *)
973 out.Code(Asm.opc_dup); (* ... L,L *)
974 out.Code(Asm.opc_dup); (* ... L,L,L *)
975 out.StoreLocal(l); (* ... L,L, *)
976 e.PushValue(rOp, Bi.setTp); (* ... L,L,R *)
977 out.Code(Asm.opc_dup); (* ... L,L,R,R *)
978 out.StoreLocal(r); (* ... L,L,R *)
979 IF theTest = Xp.greT THEN
980 out.Code(Asm.opc_or); (* ... L,LvR *)
981 ELSE
982 out.Code(Asm.opc_and); (* ... L,L^R *)
983 END;
984 out.Code(Asm.opc_ceq); (* ... L@R *)
985 out.PushLocal(l); (* ... L@R,l *)
986 out.PushLocal(r); (* ... L@R,l,r *)
987 out.Code(Asm.opc_ceq); (* ... L@R,l=r *)
988 out.Code(Asm.opc_ldc_i4_1); (* ... L@R,l=r,1 *)
989 out.Code(Asm.opc_xor); (* ... L@R,l#r *)
990 out.Code(Asm.opc_and); (* ... result *)
991 out.proc.ReleaseLocal(r);
992 out.proc.ReleaseLocal(l);
993 END;
994 END PushSetCmp;
995
996 (* ---------------------------------------------------- *)
997
998 PROCEDURE (e : MsilEmitter)DoCmp(cmpE : INTEGER;
999 tLab : Mu.Label;
1000 type : Sy.Type),NEW;
1001 (** Compare two TOS elems and jump to tLab if true. *)
1002 (* ------------------------------------------------- *)
1003 VAR out : Mu.MsilFile;
1004 (* ------------------------------------------------- *)
1005 PROCEDURE test(t : INTEGER; r : BOOLEAN) : INTEGER;
1006 BEGIN
1007 CASE t OF
1008 | Xp.equal : RETURN Asm.opc_beq;
1009 | Xp.notEq : RETURN Asm.opc_bne_un;
1010 | Xp.greT : RETURN Asm.opc_bgt;
1011 | Xp.lessT : RETURN Asm.opc_blt;
1012 | Xp.greEq : IF r THEN RETURN Asm.opc_bge_un ELSE RETURN Asm.opc_bge END;
1013 | Xp.lessEq : IF r THEN RETURN Asm.opc_ble_un ELSE RETURN Asm.opc_ble END;
1014 END;
1015 END test;
1016 (* ------------------------------------------------- *)
1017 BEGIN
1018 out := e.outF;
1019 IF (type IS Ty.Base) &
1020 ((type = Bi.strTp) OR (type = Bi.sStrTp)) OR
1021 ~(type IS Ty.Base) & type.isCharArrayType() THEN
1022 (*
1023 * For strings and character arrays, we simply
1024 * call the compare function, then compare the
1025 * result with zero. Instructions are polymorphic.
1026 *)
1027 out.StaticCall(Mu.aaStrCmp, -1);
1028 (*
1029 * function will have returned ...
1030 * lessT : -1, equal : 0, greT : 1;
1031 *)
1032 IF cmpE = Xp.equal THEN
1033 out.CodeLb(Asm.opc_brfalse, tLab);
1034 ELSIF cmpE = Xp.notEq THEN
1035 out.CodeLb(Asm.opc_brtrue, tLab);
1036 ELSE
1037 out.PushInt(0);
1038 out.CodeLb(test(cmpE, FALSE), tLab);
1039 END;
1040 ELSE
1041 out.CodeLb(test(cmpE, type.isRealType()), tLab);
1042 END;
1043 END DoCmp;
1044
1045 (* ---------------------------------------------------- *)
1046
1047 PROCEDURE (e : MsilEmitter)BinCmp(exp : Xp.BinaryX;
1048 tst : INTEGER;
1049 rev : BOOLEAN;
1050 lab : Mu.Label),NEW;
1051 VAR lType : Sy.Type;
1052 BEGIN
1053 lType := exp.lKid.type;
1054 IF lType = Bi.setTp THEN (* partially ordered type *)
1055 e.PushSetCmp(exp.lKid, exp.rKid, tst);
1056 IF rev THEN
1057 e.outF.CodeLb(Asm.opc_brfalse, lab);
1058 ELSE
1059 e.outF.CodeLb(Asm.opc_brtrue, lab);
1060 END;
1061 ELSE (* totally ordered type *)
1062 e.PushValue(exp.lKid, lType);
1063 IF isStrExp(exp.lKid) & ~isNilExp(exp.rKid) THEN
1064 (*
1065 * If this is a string, convert to a character array.
1066 *)
1067 e.outF.StaticCall(Mu.vStr2ChO, 0);
1068 lType := Bi.chrArr;
1069 END;
1070
1071 e.PushValue(exp.rKid, exp.rKid.type);
1072 IF isStrExp(exp.rKid) & ~isNilExp(exp.lKid) THEN
1073 (*
1074 * If this is a string, convert to a character array.
1075 *)
1076 e.outF.StaticCall(Mu.vStr2ChO, 0);
1077 END;
1078 IF rev THEN
1079 CASE tst OF
1080 | Xp.equal : tst := Xp.notEq;
1081 | Xp.notEq : tst := Xp.equal;
1082 | Xp.greT : tst := Xp.lessEq;
1083 | Xp.lessT : tst := Xp.greEq;
1084 | Xp.greEq : tst := Xp.lessT;
1085 | Xp.lessEq : tst := Xp.greT;
1086 END;
1087 END;
1088 e.DoCmp(tst, lab, lType);
1089 END;
1090 END BinCmp;
1091
1092 (* ---------------------------------------------------- *)
1093
1094 PROCEDURE (e : MsilEmitter)PushCmpBool(lOp,rOp : Sy.Expr; tst : INTEGER),NEW;
1095 VAR lType : Sy.Type;
1096 (* ------------------------------------- *)
1097 PROCEDURE test(t : INTEGER; r : BOOLEAN) : INTEGER;
1098 BEGIN
1099 CASE t OF
1100 | Xp.equal : RETURN Asm.opc_ceq;
1101 | Xp.notEq : RETURN Asm.opc_ceq;
1102 | Xp.lessT : RETURN Asm.opc_clt;
1103 | Xp.greT : RETURN Asm.opc_cgt;
1104 | Xp.lessEq : IF r THEN RETURN Asm.opc_cgt_un ELSE RETURN Asm.opc_cgt END;
1105 | Xp.greEq : IF r THEN RETURN Asm.opc_clt_un ELSE RETURN Asm.opc_clt END;
1106 END;
1107 END test;
1108 (* ------------------------------------- *)
1109 PROCEDURE MkBool(tst : INTEGER; typ : Sy.Type; out : Mu.MsilFile);
1110 BEGIN
1111 IF (typ IS Ty.Base) &
1112 ((typ = Bi.strTp) OR (typ = Bi.sStrTp)) OR
1113 ~(typ IS Ty.Base) & typ.isCharArrayType() THEN
1114 out.StaticCall(Mu.aaStrCmp, -1);
1115 (*
1116 * function will have returned ...
1117 * lessT : -1, equal : 0, greT : 1;
1118 *)
1119 out.Code(Asm.opc_ldc_i4_0);
1120 END;
1121 out.Code(test(tst, typ.isRealType()));
1122 IF (tst = Xp.lessEq) OR (tst = Xp.greEq) OR (tst = Xp.notEq) THEN
1123 out.Code(Asm.opc_ldc_i4_1);
1124 out.Code(Asm.opc_xor);
1125 END;
1126 END MkBool;
1127 (* ------------------------------------- *)
1128 BEGIN
1129 IF lOp.isSetExpr() THEN e.PushSetCmp(lOp, rOp, tst); RETURN END;
1130
1131 lType := lOp.type;
1132 e.PushValue(lOp, lOp.type);
1133 IF isStrExp(lOp) & ~isNilExp(rOp) THEN
1134 (*
1135 * If this is a string, convert to a character array.
1136 *)
1137 e.outF.StaticCall(Mu.vStr2ChO, 0);
1138 lType := Bi.chrArr;
1139 END;
1140
1141 e.PushValue(rOp, rOp.type);
1142 IF isStrExp(rOp) & ~isNilExp(lOp) THEN
1143 (*
1144 * If this is a string, convert to a character array.
1145 *)
1146 e.outF.StaticCall(Mu.vStr2ChO, 0);
1147 END;
1148
1149 MkBool(tst, lType, e.outF);
1150 END PushCmpBool;
1151
1152 (* ---------------------------------------------------- *)
1153 (* ---------------------------------------------------- *)
1154
1155 PROCEDURE (e : MsilEmitter)FallTrue(exp : Sy.Expr; fLb : Mu.Label),NEW;
1156 (** Evaluate exp, fall through if true, jump to fLab otherwise *)
1157 VAR binOp : Xp.BinaryX;
1158 label : Mu.Label;
1159 out : Mu.MsilFile;
1160 BEGIN
1161 out := e.outF;
1162 CASE exp.kind OF
1163 | Xp.tBool : (* just do nothing *)
1164 | Xp.fBool :
1165 out.CodeLb(Asm.opc_br, fLb);
1166 | Xp.blNot :
1167 e.FallFalse(exp(Xp.UnaryX).kid, fLb);
1168 | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
1169 e.BinCmp(exp(Xp.BinaryX), exp.kind, TRUE, fLb);
1170 | Xp.blOr :
1171 binOp := exp(Xp.BinaryX);
1172 label := out.newLabel();
1173 e.FallFalse(binOp.lKid, label);
1174 e.FallTrue(binOp.rKid, fLb);
1175 out.DefLab(label);
1176 | Xp.blAnd :
1177 binOp := exp(Xp.BinaryX);
1178 e.FallTrue(binOp.lKid, fLb);
1179 e.FallTrue(binOp.rKid, fLb);
1180 | Xp.isOp :
1181 binOp := exp(Xp.BinaryX);
1182 e.PushValue(binOp.lKid, binOp.lKid.type);
1183 out.CodeT(Asm.opc_isinst, binOp.rKid(Xp.IdLeaf).ident.type);
1184 (* if NIL then FALSE... *)
1185 out.CodeLb(Asm.opc_brfalse, fLb);
1186 | Xp.inOp :
1187 binOp := exp(Xp.BinaryX);
1188 out.Code(Asm.opc_ldc_i4_1);
1189 e.PushValue(binOp.lKid, binOp.lKid.type);
1190 out.Code(Asm.opc_shl);
1191 out.Code(Asm.opc_dup);
1192 e.PushValue(binOp.rKid, binOp.rKid.type);
1193 out.Code(Asm.opc_and);
1194 out.CodeLb(Asm.opc_bne_un, fLb);
1195 ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct *)
1196 e.PushValue(exp, exp.type); (* boolean variable *)
1197 out.CodeLb(Asm.opc_brfalse, fLb);
1198 END;
1199 END FallTrue;
1200
1201 (* ---------------------------------------------------- *)
1202
1203 PROCEDURE (e : MsilEmitter)FallFalse(exp : Sy.Expr; tLb : Mu.Label),NEW;
1204 (** Evaluate exp, fall through if false, jump to tLb otherwise *)
1205 VAR binOp : Xp.BinaryX;
1206 label : Mu.Label;
1207 out : Mu.MsilFile;
1208 BEGIN
1209 out := e.outF;
1210 CASE exp.kind OF
1211 | Xp.fBool : (* just do nothing *)
1212 | Xp.tBool :
1213 out.CodeLb(Asm.opc_br, tLb);
1214 | Xp.blNot :
1215 e.FallTrue(exp(Xp.UnaryX).kid, tLb);
1216 | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
1217 e.BinCmp(exp(Xp.BinaryX), exp.kind, FALSE, tLb);
1218 | Xp.blOr :
1219 binOp := exp(Xp.BinaryX);
1220 e.FallFalse(binOp.lKid, tLb);
1221 e.FallFalse(binOp.rKid, tLb);
1222 | Xp.blAnd :
1223 label := out.newLabel();
1224 binOp := exp(Xp.BinaryX);
1225 e.FallTrue(binOp.lKid, label);
1226 e.FallFalse(binOp.rKid, tLb);
1227 out.DefLab(label);
1228 | Xp.isOp :
1229 binOp := exp(Xp.BinaryX);
1230 e.PushValue(binOp.lKid, binOp.lKid.type);
1231 out.CodeT(Asm.opc_isinst, binOp.rKid(Xp.IdLeaf).ident.type);
1232 (* if non-NIL then TRUE... *)
1233 out.CodeLb(Asm.opc_brtrue, tLb);
1234 | Xp.inOp :
1235 binOp := exp(Xp.BinaryX);
1236 out.Code(Asm.opc_ldc_i4_1);
1237 e.PushValue(binOp.lKid, binOp.lKid.type);
1238 out.Code(Asm.opc_shl);
1239 out.Code(Asm.opc_dup);
1240 e.PushValue(binOp.rKid, binOp.rKid.type);
1241 out.Code(Asm.opc_and);
1242 out.CodeLb(Asm.opc_beq, tLb);
1243 ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct *)
1244 e.PushValue(exp, exp.type); (* boolean variable *)
1245 out.CodeLb(Asm.opc_brtrue, tLb);
1246 END;
1247 END FallFalse;
1248
1249 (* ============================================================ *)
1250
1251 PROCEDURE (e : MsilEmitter)PushUnary(exp : Xp.UnaryX; dst : Sy.Type),NEW;
1252 VAR dNum : INTEGER;
1253 code : INTEGER;
1254 labl : Mu.Label;
1255 out : Mu.MsilFile;
1256 ovfl : BOOLEAN;
1257 (* ------------------------------------- *)
1258 PROCEDURE MkBox(emt : MsilEmitter; exp : Xp.UnaryX);
1259 VAR dst : Sy.Type;
1260 src : Sy.Type;
1261 out : Mu.MsilFile;
1262 rcT : Ty.Record;
1263 BEGIN
1264 out := emt.outF;
1265 src := exp.kid.type;
1266 dst := exp.type(Ty.Pointer).boundTp;
1267 IF isStrExp(exp.kid) THEN
1268 emt.PushValue(exp.kid, src);
1269 out.StaticCall(Mu.vStr2ChO, 0);
1270 ELSIF exp.kid.kind = Xp.mkStr THEN
1271 emt.ValueCopy(exp.kid, dst);
1272 ELSIF Mu.isRefSurrogate(src) THEN
1273 emt.ValueCopy(exp.kid, dst);
1274 ELSE
1275 rcT := src(Ty.Record);
1276 (*
1277 * We want to know if this is a
1278 * foreign value type. If so it
1279 * must be boxed, since there is
1280 * no CP-defined Boxed_Rec type.
1281 *)
1282 IF Sy.isFn IN rcT.xAttr THEN
1283 emt.PushValue(exp.kid, src);
1284 out.CodeT(Asm.opc_box, src);
1285 ELSE (* normal case *)
1286 out.MkNewRecord(rcT);
1287 out.Code(Asm.opc_dup);
1288 out.GetValA(exp.type(Ty.Pointer));
1289 emt.PushValue(exp.kid, src);
1290 out.CodeT(Asm.opc_stobj, dst);
1291 END;
1292 END;
1293 END MkBox;
1294 (* ------------------------------------- *)
1295 PROCEDURE MkAdr(emt : MsilEmitter; exp : Sy.Expr);
1296 BEGIN
1297 IF Mu.isRefSurrogate(exp.type) THEN
1298 emt.PushValue(exp, exp.type);
1299 ELSE
1300 emt.PushRef(exp, exp.type);
1301 END;
1302 emt.outF.Code(Asm.opc_conv_i4);
1303 END MkAdr;
1304 (* ------------------------------------- *)
1305 BEGIN
1306 (* Eliminte special cases first *)
1307 IF exp.kind = Xp.mkBox THEN MkBox(e,exp); RETURN END; (* PRE-EMPTIVE RET *)
1308 IF exp.kind = Xp.adrOf THEN MkAdr(e,exp.kid); RETURN END; (* PRE-EMPTIVE *)
1309 (* Now do the mainstream cases *)
1310 e.PushValue(exp.kid, exp.kid.type);
1311 out := e.outF;
1312 ovfl := out.proc.prId.ovfChk;
1313 CASE exp.kind OF
1314 | Xp.mkStr : (* skip *)
1315 | Xp.deref :
1316 IF Mu.isValRecord(dst) THEN (* unbox field 'v$' *)
1317 out.GetVal(exp.kid.type(Ty.Pointer));
1318 END;
1319 | Xp.tCheck :
1320 IF Mu.isValRecord(exp.type) THEN
1321 out.CodeT(Asm.opc_unbox, exp.type.boundRecTp()(Ty.Record));
1322 out.CodeT(Asm.opc_ldobj, exp.type.boundRecTp()(Ty.Record));
1323 ELSE
1324 out.CodeT(Asm.opc_castclass, exp.type);
1325 END;
1326 (*
1327 * out.CodeT(Asm.opc_castclass, exp.type.boundRecTp()(Ty.Record));
1328 *)
1329 | Xp.mkNStr :
1330 IF ~isStrExp(exp.kid) THEN out.StaticCall(Mu.chs2Str, 0) END;
1331 | Xp.strChk :
1332 out.Code(Asm.opc_dup);
1333 out.StaticCall(Mu.aStrChk, -1); (* Do some range checks *)
1334 | Xp.compl :
1335 out.Code(Asm.opc_ldc_i4_M1);
1336 out.Code(Asm.opc_xor);
1337 | Xp.neg :
1338 out.Code(Asm.opc_neg);
1339 | Xp.absVl :
1340 dNum := dst(Ty.Base).tpOrd;
1341 IF ~ovfl THEN
1342 (*
1343 * This is the code to use for non-trapping cases
1344 *)
1345 out.Code(Asm.opc_dup);
1346 out.Code(Asm.opc_ldc_i4_0);
1347 IF dNum = Ty.realN THEN
1348 out.Code(Asm.opc_conv_r8);
1349 ELSIF dNum = Ty.sReaN THEN
1350 out.Code(Asm.opc_conv_r4);
1351 ELSIF dNum = Ty.lIntN THEN
1352 out.Code(Asm.opc_conv_i8);
1353 (* ELSE do nothing for all INTEGER cases *)
1354 END;
1355 labl := out.newLabel();
1356 out.CodeLb(Asm.opc_bge, labl);
1357 out.Code(Asm.opc_neg);
1358 out.DefLab(labl);
1359 ELSE
1360 (*
1361 * The following is the safe but slow code.
1362 *)
1363 IF dNum = Ty.realN THEN
1364 out.StaticCall(Mu.dAbs, 0);
1365 ELSIF dNum = Ty.sReaN THEN
1366 out.StaticCall(Mu.fAbs, 0);
1367 ELSIF dNum = Ty.lIntN THEN
1368 out.StaticCall(Mu.lAbs, 0);
1369 ELSE
1370 out.StaticCall(Mu.iAbs, 0);
1371 END;
1372 END;
1373 | Xp.entVl :
1374 dNum := dst(Ty.Base).tpOrd;
1375 IF dNum = Ty.sReaN THEN out.Code(Asm.opc_conv_r8) END;
1376 (*
1377 // We _could_ check if the value is >= 0.0, and
1378 // skip the call in that case, falling through
1379 // into the round-to-zero mode opc_d2l.
1380 *)
1381 out.StaticCall(Mu.dFloor, 0);
1382 IF ~ovfl THEN
1383 out.Code(Asm.opc_conv_i8);
1384 ELSE
1385 out.Code(Asm.opc_conv_ovf_i8);
1386 END;
1387 | Xp.capCh :
1388 out.StaticCall(Mu.toUpper, 0);
1389 | Xp.blNot :
1390 out.Code(Asm.opc_ldc_i4_1);
1391 out.Code(Asm.opc_xor);
1392 | Xp.strLen :
1393 out.StaticCall(Mu.aStrLen, 0);
1394 | Xp.oddTst :
1395 IF exp.kid.type.isLongType() THEN out.Code(Asm.opc_conv_i4) END;
1396 out.Code(Asm.opc_ldc_i4_1);
1397 out.Code(Asm.opc_and);
1398 | Xp.getTp :
1399 (*
1400 * Currently value records cannot arise here, since all TYPEOF()
1401 * calls are folded to their statically known type by ExprDesc.
1402 * If ever this changes, the following code is needed (and has
1403 * been checked against a non-folding version of ExprDesc.
1404 *
1405 * IF Mu.isValRecord(exp.kid.type) THEN (* box the value... *)
1406 * out.CodeT(Asm.opc_box, exp.kid.type); (* CodeTn works too *)
1407 * END;
1408 *)
1409 out.StaticCall(Mu.getTpM, 0);
1410 END;
1411 END PushUnary;
1412
1413 (* ============================================================ *)
1414
1415 PROCEDURE Rotate(e : MsilEmitter; lOp, rOp : Sy.Expr);
1416 VAR out : Mu.MsilFile;
1417 rtSz : INTEGER; (* rotate size in bits *)
1418 hstT : Sy.Type; (* host type on stack *)
1419 indx : INTEGER; (* literal rOp value *)
1420 temp : INTEGER; (* local to save lOp *)
1421 ixSv : INTEGER; (* local for left rslt *)
1422 BEGIN
1423 out := e.outF;
1424 e.PushValue(lOp, lOp.type);
1425
1426 (* Convert TOS value to unsigned *)
1427 hstT := Bi.intTp;
1428 IF (lOp.type = Bi.sIntTp) THEN
1429 rtSz := 16;
1430 out.Code(Asm.opc_conv_u2);
1431 ELSIF (lOp.type = Bi.byteTp) OR (lOp.type = Bi.uBytTp) THEN
1432 rtSz := 8;
1433 out.Code(Asm.opc_conv_u1);
1434 ELSIF lOp.type = Bi.lIntTp THEN
1435 rtSz := 64;
1436 hstT := Bi.lIntTp;
1437 ELSE
1438 rtSz := 32;
1439 (* out.Code(Asm.opc_conv_u4); *)
1440 END;
1441 IF rOp.kind = Xp.numLt THEN
1442 indx := intValue(rOp) MOD rtSz;
1443 IF indx = 0 THEN (* skip *)
1444 ELSE (*
1445 * Rotation is achieved by means of the identity
1446 * Forall 0 <= n < rtSz:
1447 * ROT(a, n) = LSH(a,n) bitwiseOR LSH(a,n-rtSz);
1448 *)
1449 temp := out.proc.newLocal(hstT);
1450 out.Code(Asm.opc_dup);
1451 out.PushInt(indx);
1452 out.Code(Asm.opc_shl);
1453 out.StoreLocal(temp);
1454 out.PushInt(rtSz - indx);
1455 out.Code(Asm.opc_shr_un);
1456 out.PushLocal(temp);
1457 out.Code(Asm.opc_or);
1458 out.proc.ReleaseLocal(temp);
1459 END;
1460 out.ConvertDn(hstT, lOp.type, FALSE);
1461 ELSE
1462 (*
1463 * This is a variable rotate.
1464 *
1465 * Note that in the case of a short left operand the value
1466 * on the stack has been converted to unsigned. The value is
1467 * saved as a int (rather than a shorter type) so that the
1468 * value does not get sign extended on each new load,
1469 * necessitating a new conversion each time.
1470 *)
1471 temp := out.proc.newLocal(hstT);
1472 ixSv := out.proc.newLocal(Bi.intTp);
1473 out.Code(Asm.opc_dup); (* TOS: lOp, lOp, ... *)
1474 out.StoreLocal(temp); (* TOS: lOp, ... *)
1475 e.PushValue(rOp, rOp.type); (* TOS: rOp, lOp, ... *)
1476 out.PushInt(rtSz-1); (* TOS: 31, rOp, lOp, ... *)
1477 out.Code(Asm.opc_and); (* TOS: rOp', lOp, ... *)
1478 out.Code(Asm.opc_dup); (* TOS: rOp', rOp', lOp, ... *)
1479 out.StoreLocal(ixSv); (* TOS: rOp', lOp, ... *)
1480 out.Code(Asm.opc_shl); (* TOS: lRz, ... (left fragment) *)
1481 out.PushLocal(temp); (* TOS: lOp, lRz, ... *)
1482 out.PushInt(rtSz); (* TOS: 32, lOp, lRz, ... *)
1483 out.PushLocal(ixSv); (* TOS: rOp', 32, lOp, lRz, ... *)
1484 out.Code(Asm.opc_sub); (* TOS: rOp'', lOp, lRz, ... *)
1485 (* mask the shift amount in case idx = 0 *)
1486 out.PushInt(rtSz-1); (* TOS: 31, rOp, lOp, ... *)
1487 out.Code(Asm.opc_and); (* TOS: rOp', lOp, ... *)
1488 out.Code(Asm.opc_shr_un); (* TOS: rRz, lRz, ... *)
1489 out.Code(Asm.opc_or); (* TOS: ROT(lOp,rOp), ... *)
1490 out.proc.ReleaseLocal(ixSv);
1491 out.proc.ReleaseLocal(temp);
1492 out.ConvertDn(hstT, lOp.type, FALSE);
1493 END;
1494 END Rotate;
1495
1496 (* ============================================================ *)
1497 (*
1498 PROCEDURE Shift(e : MsilEmitter; lOp, rOp : Sy.Expr; kind : INTEGER);
1499 VAR out : Mu.MsilFile;
1500 long : BOOLEAN;
1501 indx : INTEGER; (* literal rOp value *)
1502 temp : INTEGER; (* local to save lOp *)
1503 maskSz : INTEGER; (* size of index mask *)
1504 exitLb : Mu.Label;
1505 rshLab : Mu.Label;
1506 (* --------------------------- *)
1507 PROCEDURE ReplaceWithZero(i64 : BOOLEAN; f : Mu.MsilFile);
1508 BEGIN
1509 f.Code(Asm.opc_pop);
1510 IF i64 THEN f.PushLong(0) ELSE f.PushInt(0) END;
1511 END ReplaceWithZero;
1512 (* --------------------------- *)
1513 BEGIN
1514 out := e.outF;
1515 e.PushValue(lOp, lOp.type);
1516 long := lOp.type = Bi.lIntTp;
1517 IF long THEN maskSz := 63 ELSE maskSz := 31 END;
1518 (*
1519 * Deal with shift by literal sizes
1520 *)
1521 IF rOp.kind = Xp.numLt THEN
1522 indx := intValue(rOp);
1523 IF indx = 0 THEN (* skip *)
1524 ELSIF indx > maskSz THEN
1525 ReplaceWithZero(long, out);
1526 ELSIF indx > 0 THEN
1527 out.PushInt(indx);
1528 out.Code(Asm.opc_shl);
1529 ELSIF kind = Xp.ashInt THEN
1530 out.PushInt(MIN(-indx, 31));
1531 out.Code(Asm.opc_shr);
1532 ELSIF indx < -maskSz THEN (* LSHR > wordsize () *)
1533 ReplaceWithZero(long, out);
1534 ELSE (* ==> kind = lshInt *)
1535 out.PushInt(-indx);
1536 out.Code(Asm.opc_shr_un);
1537 END;
1538 ELSE
1539 rshLab := out.newLabel();
1540 exitLb := out.newLabel();
1541 temp := out.proc.newLocal(Bi.intTp);
1542 (*
1543 * This is a variable shift. Do it the hard way.
1544 * First, check the sign of the right hand op.
1545 *)
1546 e.PushValue(rOp, rOp.type); (* TOS: rOp, lOp, ... *)
1547 out.Code(Asm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1548 out.PushInt(0);
1549 out.CodeLb(Asm.opc_blt, rshLab); (* TOS: rOp, lOp, ... *)
1550 (*
1551 * Positive selector ==> shift left;
1552 * Do range limitation on shift index
1553 *)
1554 out.Code(Asm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1555 out.StoreLocal(temp); (* TOS: rOp, lOp, ... *)
1556 out.PushInt(maskSz+1); (* TOS: 32, rOp, lOp, ... *)
1557 out.Code(Asm.opc_clt); (* TOS: 0/1, lOp, ... *)
1558 out.Code(Asm.opc_neg);
1559 IF long THEN out.Code(Asm.opc_conv_i8) END;
1560 out.Code(Asm.opc_and);
1561 out.PushLocal(temp);
1562 (*
1563 * Now do the shift
1564 *)
1565 out.Code(Asm.opc_shl);
1566 out.CodeLb(Asm.opc_br, exitLb);
1567 (*
1568 * Negative selector ==> shift right;
1569 *)
1570 out.DefLab(rshLab);
1571 out.Code(Asm.opc_neg);
1572 IF kind = Xp.ashInt THEN
1573 out.Code(Asm.opc_dup); (* TOS: -rOp, -rOp, lOp, ... *)
1574 out.PushInt(maskSz); (* TOS: 31, -rOp, -rOp, lOp, ... *)
1575 out.Code(Asm.opc_cgt); (* TOS: 0/1, -rOp, lOp, ... *)
1576 out.PushInt(maskSz); (* TOS: 31, 0/1, rOp, lOp, ... *)
1577 out.Code(Asm.opc_mul); (* TOS: 0/31, -rOp, lOp, ... *)
1578 out.Code(Asm.opc_or); (* TOS: MIN(-rOp,31), lOp, ... *)
1579 (*
1580 * Now do the shift
1581 *)
1582 out.Code(Asm.opc_shr);
1583 ELSE (* ==> kind = lshInt *)
1584 (* FIXME *)
1585 out.Code(Asm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1586 out.StoreLocal(temp); (* TOS: rOp, lOp, ... *)
1587 out.PushInt(maskSz+1); (* TOS: 32, rOp, lOp, ... *)
1588 out.Code(Asm.opc_clt); (* TOS: 0/1, lOp, ... *)
1589 out.Code(Asm.opc_neg);
1590 IF long THEN out.Code(Asm.opc_conv_i8) END;
1591 out.Code(Asm.opc_and);
1592 out.PushLocal(temp);
1593 (*
1594 * Now do the shift
1595 *)
1596 out.Code(Asm.opc_shr_un);
1597 END;
1598 out.DefLab(exitLb);
1599 out.proc.ReleaseLocal(temp);
1600 END;
1601 END Shift;
1602 *)
1603 (* ============================================================ *)
1604
1605 PROCEDURE Shift2(e : MsilEmitter; lOp, rOp : Sy.Expr; kind : INTEGER);
1606 VAR out : Mu.MsilFile;
1607 long : BOOLEAN;
1608 indx : INTEGER; (* literal rOp value *)
1609 temp : INTEGER; (* local to save lOp *)
1610 maskSz : INTEGER; (* size of index mask *)
1611 rshLab : Mu.Label;
1612 exitLb : Mu.Label;
1613 entryL : Mu.Label;
1614 zeroLb : Mu.Label;
1615 (* --------------------------- *)
1616 PROCEDURE ReplaceWithZero(i64 : BOOLEAN; f : Mu.MsilFile);
1617 BEGIN
1618 f.Code(Asm.opc_pop);
1619 IF i64 THEN f.PushLong(0) ELSE f.PushInt(0) END;
1620 END ReplaceWithZero;
1621 (* --------------------------- *)
1622 BEGIN
1623 out := e.outF;
1624 e.PushValue(lOp, lOp.type);
1625 long := lOp.type = Bi.lIntTp;
1626 IF long THEN maskSz := 63 ELSE maskSz := 31 END;
1627 (*
1628 * Deal with shift by literal sizes
1629 *)
1630 IF rOp.kind = Xp.numLt THEN
1631 indx := intValue(rOp);
1632 IF indx = 0 THEN (* skip *)
1633 ELSIF indx > maskSz THEN
1634 ReplaceWithZero(long, out);
1635 ELSIF indx > 0 THEN
1636 out.PushInt(indx);
1637 out.Code(Asm.opc_shl);
1638 ELSIF kind = Xp.ashInt THEN
1639 out.PushInt(MIN(-indx, 31));
1640 out.Code(Asm.opc_shr);
1641 ELSIF indx < -maskSz THEN (* LSHR > wordsize () *)
1642 ReplaceWithZero(long, out);
1643 ELSE (* ==> kind = lshInt *)
1644 out.PushInt(-indx);
1645 out.Code(Asm.opc_shr_un);
1646 END;
1647 ELSE
1648 entryL := out.newLabel();
1649 rshLab := out.newLabel();
1650 zeroLb := out.newLabel();
1651 exitLb := out.newLabel();
1652 temp := out.proc.newLocal(Bi.intTp);
1653 e.PushValue(rOp, rOp.type); (* TOS: rOp, lOp, ... *)
1654 out.Code(Asm.opc_dup); (* TOS: rOp, rOp, lOp, ... *)
1655 out.StoreLocal(temp); (* TOS: rOp, lOp, ... *)
1656 IF kind = Xp.lshInt THEN (* logical shift *)
1657 out.PushInt(maskSz); (* TOS: 31, rOp, lOp, ... *)
1658 out.Code(Asm.opc_add); (* TOS: rOp*, lOp, ... *)
1659 out.PushInt(maskSz * 2); (* TOS: 62, rOp*, lOp, ... *)
1660 out.CodeLb(Asm.opc_ble_un, entryL); (* TOS: lOp, ... *)
1661 ReplaceWithZero(long, out); (* TOS: rslt, ... *)
1662 out.CodeLb(Asm.opc_br, exitLb); (* Jump directly to exit label *)
1663 (*
1664 * Normal, in-range control flow.
1665 *)
1666 out.DefLab(entryL);
1667 out.PushLocal(temp); (* TOS: rOp, lOp, ... *)
1668 out.PushInt(0); (* TOS: 0, rOp, lOp, ... *)
1669 out.CodeLb(Asm.opc_blt, rshLab); (* TOS: lOp, ... *)
1670 (*
1671 * Positive shift ==> left shift
1672 *)
1673 out.PushLocal(temp); (* TOS: rOp, lOp, ... *)
1674 out.Code(Asm.opc_shl); (* TOS: rslt, ... *)
1675 out.CodeLb(Asm.opc_br, exitLb); (* Jump directly to exit label *)
1676 (*
1677 * Negative selector ==> shift right;
1678 *)
1679 out.DefLab(rshLab);
1680 out.PushLocal(temp); (* TOS: rOp, lOp, ... *)
1681 out.Code(Asm.opc_neg); (* TOS: -rOp, lOp, ... *)
1682 out.Code(Asm.opc_shr_un); (* And fall through to exitLb *)
1683 ELSE (* kind = ashInt ==> Arithmetic Shift *)
1684 out.PushInt(maskSz); (* TOS: 31, rOp, lOp, ... *)
1685 out.CodeLb(Asm.opc_bgt, zeroLb); (* TOS: lOp, ... *)
1686 out.PushLocal(temp); (* TOS: rOp, lOp, ... *)
1687 out.PushInt(-maskSz); (* TOS: -31, rOp, lOp, ... *)
1688 out.CodeLb(Asm.opc_bgt, entryL); (* TOS: lop, ... *)
1689 (*
1690 * Negative shift is out of range.
1691 *)
1692 out.PushInt(-maskSz);
1693 out.StoreLocal(temp); (* overwrite temp! *)
1694 out.CodeLb(Asm.opc_br, rshLab); (* TOS: lop, ... *)
1695 out.DefLab(zeroLb);
1696 ReplaceWithZero(long, out);
1697 out.CodeLb(Asm.opc_br, exitLb); (* Jump directly to exit label *)
1698 (*
1699 * Normal, in-range control flow.
1700 *)
1701 out.DefLab(entryL);
1702 out.PushLocal(temp); (* TOS: rOp, lop, ... *)
1703 out.PushInt(0);
1704 out.CodeLb(Asm.opc_blt, rshLab); (* TOS: lOp, ... *)
1705 (*
1706 * Positive shift ==> left shift
1707 *)
1708 out.PushLocal(temp); (* TOS: rOp, lop, ... *)
1709 out.Code(Asm.opc_shl);
1710 out.CodeLb(Asm.opc_br, exitLb); (* Jump directly to exit label *)
1711 (*
1712 * Negative selector ==> shift right;
1713 *)
1714 out.DefLab(rshLab);
1715 out.PushLocal(temp); (* TOS: rOp, lop, ... *)
1716 out.Code(Asm.opc_neg); (* TOS: -rOp, lop, ... *)
1717 out.Code(Asm.opc_shr); (* And fall through to exitLb *)
1718 END;
1719 out.DefLab(exitLb);
1720 out.proc.ReleaseLocal(temp);
1721 END;
1722 END Shift2;
1723
1724 (* ============================================================ *)
1725
1726 PROCEDURE (e : MsilEmitter)
1727 PushBinary(exp : Xp.BinaryX; dst : Sy.Type),NEW;
1728 VAR out : Mu.MsilFile;
1729 lOp : Sy.Expr;
1730 rOp : Sy.Expr;
1731 dNum : INTEGER;
1732 sNum : INTEGER;
1733 code : INTEGER;
1734 indx : INTEGER;
1735 rLit : LONGINT;
1736 long : BOOLEAN;
1737 rasd : BOOLEAN; (* Element type is erased *)
1738 temp : INTEGER;
1739 ovfl : BOOLEAN;
1740 exLb : Mu.Label;
1741 tpLb : Mu.Label;
1742 rpTp : Sy.Type;
1743 elTp : Sy.Type;
1744 rtSz : INTEGER;
1745 ixSv : INTEGER;
1746 hstT : Sy.Type;
1747 BEGIN
1748 out := e.outF;
1749 lOp := exp.lKid;
1750 rOp := exp.rKid;
1751 ovfl := out.proc.prId.ovfChk & dst.isIntType();
1752 CASE exp.kind OF
1753 (* -------------------------------- *)
1754 | Xp.rotInt:
1755 Rotate(e, lOp, rOp);
1756 (* -------------------------------- *)
1757 | Xp.ashInt, Xp.lshInt:
1758 Shift2(e, lOp, rOp, exp.kind);
1759 (* -------------------------------- *)
1760 | Xp.index :
1761 rasd := exp(Xp.BinaryX).lKid.type IS Ty.Vector;
1762 IF rasd THEN
1763 rpTp := Mu.vecRepElTp(exp.lKid.type(Ty.Vector));
1764 ELSE
1765 (* rpTp := dst; *)
1766 rpTp := lOp.type(Ty.Array).elemTp;
1767 END;
1768 e.PushHandle(exp, rpTp);
1769 out.GetElem(rpTp); (* load the element *)
1770 IF rasd & (dst # rpTp) THEN
1771 IF Mu.isValRecord(dst) THEN
1772 out.CodeT(Asm.opc_unbox, dst);
1773 out.CodeT(Asm.opc_ldobj, dst);
1774 ELSIF rpTp = Bi.anyPtr THEN
1775 out.CodeT(Asm.opc_castclass, dst);
1776 ELSE
1777 out.ConvertDn(rpTp, dst, out.proc.prId.ovfChk);
1778 END;
1779 END;
1780 (*
1781 * previous code ---
1782 *
1783 * e.PushHandle(exp, dst);
1784 * out.GetElem(dst); (* load the element *)
1785 *)
1786 (* -------------------------------- *)
1787 | Xp.range : (* set i..j range ... *)
1788 (* We want to create an integer with bits-- *)
1789 (* [0...01...10...0] *)
1790 (* MSB==31 j i 0==LSB *)
1791 (* One method is A *)
1792 (* 1) [0..010........0] 1 << (j+1) *)
1793 (* 2) [1..110........0] negate(1) *)
1794 (* 3) [0.......010...0] 1 << i *)
1795 (* 4) [1.......110...0] negate(3) *)
1796 (* 5) [0...01...10...0] (2)xor(4) *)
1797 (* Another method is B *)
1798 (* 1) [1.............1] -1 *)
1799 (* 2) [0...01........1] (1) >>> (31-j) *)
1800 (* 3) [0........01...1] (2) >> i *)
1801 (* 4) [0...01...10...0] (3) << i *)
1802 (* --------------------------------------------- *
1803 * (* *
1804 * * Method A *
1805 * *) *
1806 * out.Code(Asm.opc_ldc_i4_1); *
1807 * out.Code(Asm.opc_ldc_i4_1); *
1808 * e.PushValue(rOp, Bi.intTp); *
1809 * (* Do unsigned less than 32 test here *) *
1810 * out.Code(Asm.opc_add); *
1811 * out.Code(Asm.opc_shl); *
1812 * out.Code(Asm.opc_neg); *
1813 * out.Code(Asm.opc_ldc_i4_1); *
1814 * e.PushValue(lOp, Bi.intTp); *
1815 * (* Do unsigned less than 32 test here *) *
1816 * out.Code(Asm.opc_shl); *
1817 * out.Code(Asm.opc_neg); *
1818 * out.Code(Asm.opc_xor); *
1819 * -------------------------------------------- *)
1820 (*
1821 * Method B
1822 *)
1823 IF rOp.kind = Xp.numLt THEN
1824 indx := intValue(rOp);
1825 IF indx = 31 THEN
1826 out.Code(Asm.opc_ldc_i4_M1);
1827 ELSE
1828 temp := ORD({0 .. indx});
1829 out.PushInt(temp);
1830 END;
1831 ELSE
1832 out.Code(Asm.opc_ldc_i4_M1);
1833 out.PushInt(31);
1834 e.PushValue(rOp, Bi.intTp);
1835 (* Do unsigned less than 32 test here ...*)
1836 out.Code(Asm.opc_sub);
1837 out.Code(Asm.opc_shr_un);
1838 END;
1839 IF lOp.kind = Xp.numLt THEN
1840 indx := intValue(lOp);
1841 IF indx > 0 THEN
1842 temp := ORD({indx .. 31});
1843 out.PushInt(temp);
1844 out.Code(Asm.opc_and);
1845 END;
1846 ELSE
1847 e.PushValue(lOp, Bi.intTp);
1848 (* Do unsigned less than 32 test here ...*)
1849 out.Code(Asm.opc_dup);
1850 temp := out.proc.newLocal(Bi.intTp);
1851 out.StoreLocal(temp);
1852 out.Code(Asm.opc_shr);
1853 out.PushLocal(temp);
1854 out.Code(Asm.opc_shl);
1855 out.proc.ReleaseLocal(temp);
1856 END;
1857 (* -------------------------------- *)
1858 | Xp.lenOf :
1859 e.PushValue(lOp, lOp.type);
1860 (* conventional arrays here *)
1861 IF lOp.type IS Ty.Vector THEN
1862 out.GetField(Mu.vecLeng(out));
1863 ELSE
1864 FOR indx := 0 TO intValue(rOp) - 1 DO
1865 out.Code(Asm.opc_ldc_i4_0);
1866 out.Code(Asm.opc_ldelem_ref);
1867 END;
1868 out.Code(Asm.opc_ldlen);
1869 END;
1870 (* -------------------------------- *)
1871 | Xp.maxOf, Xp.minOf :
1872 tpLb := out.newLabel();
1873 exLb := out.newLabel();
1874 (*
1875 * Push left operand, duplicate
1876 * stack is (top) lOp lOp...
1877 *)
1878 e.PushValue(lOp, dst);
1879 out.Code(Asm.opc_dup);
1880 (*
1881 * Push right operand, duplicate
1882 * stack is (top) rOp rOp lOp lOp ...
1883 *)
1884 e.PushValue(rOp, dst);
1885 out.Code(Asm.opc_dup);
1886 (*
1887 * Store rOp to temp
1888 * stack is (top) rOp lOp lOp ...
1889 *)
1890 temp := out.proc.newLocal(dst);
1891 out.StoreLocal(temp);
1892 (*
1893 * Compare two top items and jump
1894 * stack is (top) lOp ...
1895 *)
1896 IF exp.kind = Xp.maxOf THEN
1897 e.DoCmp(Xp.greT, exLb, dst); (* leaving lOp on stack *)
1898 ELSE
1899 e.DoCmp(Xp.lessT, exLb, dst); (* leaving lOp on stack *)
1900 END;
1901 (*
1902 * Else: discard top item
1903 * and push stored rOp instead
1904 *)
1905 out.Code(Asm.opc_pop);
1906 out.PushLocal(temp);
1907 out.DefLab(exLb);
1908 out.proc.ReleaseLocal(temp);
1909 (* -------------------------------- *)
1910 | Xp.bitAnd :
1911 e.PushValue(lOp, dst);
1912 e.PushValue(rOp, dst);
1913 out.Code(Asm.opc_and);
1914 (* -------------------------------- *)
1915 | Xp.bitOr :
1916 e.PushValue(lOp, dst);
1917 e.PushValue(rOp, dst);
1918 out.Code(Asm.opc_or);
1919 (* -------------------------------- *)
1920 | Xp.bitXor :
1921 e.PushValue(lOp, dst);
1922 e.PushValue(rOp, dst);
1923 out.Code(Asm.opc_xor);
1924 (* -------------------------------- *)
1925 | Xp.plus :
1926 e.PushValue(lOp, dst);
1927 e.PushValue(rOp, dst);
1928 IF ovfl THEN out.Code(Asm.opc_add_ovf) ELSE out.Code(Asm.opc_add) END;
1929 (* -------------------------------- *)
1930 | Xp.minus :
1931 e.PushValue(lOp, dst);
1932 e.PushValue(rOp, dst);
1933 IF ovfl THEN out.Code(Asm.opc_sub_ovf) ELSE out.Code(Asm.opc_sub) END;
1934 (* -------------------------------- *)
1935 | Xp.mult :
1936 e.PushValue(lOp, dst);
1937 e.PushValue(rOp, dst);
1938 IF ovfl THEN out.Code(Asm.opc_mul_ovf) ELSE out.Code(Asm.opc_mul) END;
1939 (* -------------------------------- *)
1940 | Xp.slash :
1941 e.PushValue(lOp, dst);
1942 e.PushValue(rOp, dst);
1943 out.Code(Asm.opc_div);
1944 (* -------------------------------- *)
1945 | Xp.rem0op :
1946 dNum := dst(Ty.Base).tpOrd;
1947 e.PushValue(lOp, dst);
1948 e.PushValue(rOp, dst);
1949 out.Code(Asm.opc_rem);
1950 (* -------------------------------- *)
1951 | Xp.modOp :
1952 long := dst(Ty.Base).tpOrd = Ty.lIntN;
1953 e.PushValue(lOp, dst);
1954 e.PushValue(rOp, dst);
1955 IF (rOp.kind = Xp.numLt) & (intValue(rOp) > 0) THEN
1956 indx := intValue(rOp);
1957 tpLb := out.newLabel();
1958 out.Code(Asm.opc_rem);
1959 out.Code(Asm.opc_dup);
1960 IF long THEN out.PushLong(0) ELSE out.PushInt(0) END;
1961 out.CodeLb(Asm.opc_bge, tpLb);
1962 IF long THEN out.PushLong(indx) ELSE out.PushInt(indx) END;
1963 out.Code(Asm.opc_add);
1964 out.DefLab(tpLb);
1965 ELSIF long THEN
1966 out.StaticCall(Mu.CpModL, -1);
1967 ELSE
1968 out.StaticCall(Mu.CpModI, -1);
1969 END;
1970 (* -------------------------------- *)
1971 | Xp.div0op :
1972 dNum := dst(Ty.Base).tpOrd;
1973 e.PushValue(lOp, dst);
1974 e.PushValue(rOp, dst);
1975 out.Code(Asm.opc_div);
1976 (* -------------------------------- *)
1977 | Xp.divOp :
1978 long := dst(Ty.Base).tpOrd = Ty.lIntN;
1979 e.PushValue(lOp, dst);
1980 IF (rOp.kind = Xp.numLt) & (longValue(rOp) > 0) THEN
1981 tpLb := out.newLabel();
1982 out.Code(Asm.opc_dup);
1983 IF long THEN
1984 rLit := longValue(rOp);
1985 out.PushLong(0);
1986 out.CodeLb(Asm.opc_bge, tpLb);
1987 out.PushLong(rLit-1);
1988 out.Code(Asm.opc_sub);
1989 out.DefLab(tpLb);
1990 out.PushLong(rLit);
1991 ELSE
1992 indx := intValue(rOp);
1993 out.PushInt(0);
1994 out.CodeLb(Asm.opc_bge, tpLb);
1995 out.PushInt(indx-1);
1996 out.Code(Asm.opc_sub);
1997 out.DefLab(tpLb);
1998 out.PushInt(indx);
1999 END;
2000 out.Code(Asm.opc_div);
2001 ELSE
2002 e.PushValue(rOp, dst);
2003 IF long THEN
2004 out.StaticCall(Mu.CpDivL, -1);
2005 ELSE
2006 out.StaticCall(Mu.CpDivI, -1);
2007 END;
2008 END;
2009 (* -------------------------------- *)
2010 | Xp.blOr, Xp.blAnd :
2011 tpLb := out.newLabel();
2012 exLb := out.newLabel();
2013 (*
2014 * Jumping code is mandated for blOr and blAnd...
2015 *)
2016 e.FallTrue(exp, tpLb);
2017 out.Code(Asm.opc_ldc_i4_1);
2018 out.CodeLb(Asm.opc_br, exLb);
2019 out.DefLab(tpLb);
2020 out.Code(Asm.opc_ldc_i4_0);
2021 out.DefLab(exLb);
2022 (* -------------------------------- *)
2023 | Xp.greT, Xp.greEq, Xp.notEq,
2024 Xp.lessEq, Xp.lessT, Xp.equal :
2025 e.PushCmpBool(lOp, rOp, exp.kind);
2026 (* -------------------------------- *)
2027 | Xp.inOp :
2028 e.PushValue(rOp, rOp.type);
2029 e.PushValue(lOp, lOp.type);
2030 out.Code(Asm.opc_shr_un);
2031 out.Code(Asm.opc_ldc_i4_1);
2032 out.Code(Asm.opc_and);
2033 (* -------------------------------- *)
2034 | Xp.isOp :
2035 e.PushValue(lOp, lOp.type);
2036 out.CodeT(Asm.opc_isinst, rOp(Xp.IdLeaf).ident.type);
2037 out.Code(Asm.opc_ldnull);
2038 out.Code(Asm.opc_cgt_un);
2039 (* -------------------------------- *)
2040 | Xp.strCat :
2041 e.PushValue(lOp, lOp.type);
2042 e.PushValue(rOp, rOp.type);
2043 IF isStrExp(lOp) THEN
2044 IF isStrExp(rOp) THEN
2045 out.StaticCall(Mu.CPJstrCatSS, -1);
2046 ELSE
2047 out.StaticCall(Mu.CPJstrCatSA, -1);
2048 END;
2049 ELSE
2050 IF isStrExp(rOp) THEN
2051 out.StaticCall(Mu.CPJstrCatAS, -1);
2052 ELSE
2053 out.StaticCall(Mu.CPJstrCatAA, -1);
2054 END;
2055 END;
2056 (* -------------------------------- *)
2057 END;
2058 END PushBinary;
2059
2060 (* ============================================================ *)
2061
2062 PROCEDURE (e : MsilEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
2063 VAR out : Mu.MsilFile;
2064 rec : Ty.Record;
2065 ix : INTEGER;
2066 elm : Sy.Expr;
2067 emt : BOOLEAN; (* ==> more than one set element expr *)
2068 BEGIN
2069 out := e.outF;
2070 WITH exp : Xp.IdLeaf DO
2071 IF exp.isProcLit() THEN
2072 out.Code(Asm.opc_ldnull);
2073 out.MkNewProcVal(exp.ident, typ);
2074 ELSIF exp.kind = Xp.typOf THEN
2075 out.LoadType(exp.ident);
2076 ELSE
2077 out.GetVar(exp.ident);
2078 END;
2079 | exp : Xp.SetExp DO
2080 emt := TRUE;
2081 (*
2082 * Write out the constant part, if there is one.
2083 *)
2084 IF exp.value # NIL THEN
2085 out.PushInt(exp.value.int()); (* const part *)
2086 emt := FALSE;
2087 END;
2088 (*
2089 * Write out the element expressions.
2090 * taking the union with any part emitted already.
2091 *)
2092 FOR ix := 0 TO exp.varSeq.tide-1 DO
2093 elm := exp.varSeq.a[ix];
2094 IF elm.kind = Xp.range THEN
2095 e.PushValue(elm, Bi.intTp);
2096 ELSE
2097 out.PushInt(1);
2098 e.PushValue(exp.varSeq.a[ix], Bi.intTp);
2099 out.Code(Asm.opc_shl);
2100 END;
2101 IF ~emt THEN out.Code(Asm.opc_or) END;
2102 emt := FALSE;
2103 END;
2104 (*
2105 * If neither of the above emitted anything, emit zero!
2106 *)
2107 IF emt THEN out.Code(Asm.opc_ldc_i4_0) END;
2108 | exp : Xp.LeafX DO
2109 CASE exp.kind OF
2110 | Xp.tBool : out.Code(Asm.opc_ldc_i4_1);
2111 | Xp.fBool : out.Code(Asm.opc_ldc_i4_0);
2112 | Xp.nilLt : out.Code(Asm.opc_ldnull);
2113 | Xp.charLt : out.PushInt(ORD(exp.value.char()));
2114 | Xp.setLt : out.PushInt(exp.value.int());
2115 | Xp.numLt :
2116 IF typ = Bi.lIntTp THEN
2117 out.PushLong(exp.value.long());
2118 ELSE
2119 out.PushInt(exp.value.int());
2120 END;
2121 | Xp.realLt :
2122 IF typ = Bi.realTp THEN
2123 out.PushReal(exp.value.real());
2124 ELSE
2125 out.PushSReal(exp.value.real());
2126 END;
2127 | Xp.strLt :
2128 IF typ = Bi.charTp THEN
2129 out.PushInt(ORD(exp.value.chr0()));
2130 ELSE
2131 out.PushStr(exp.value.chOpen());
2132 END;
2133 | Xp.infLt :
2134 IF typ = Bi.realTp THEN
2135 out.GetVar(CSt.dblInf);
2136 ELSE
2137 out.GetVar(CSt.fltInf);
2138 END;
2139 | Xp.nInfLt :
2140 IF typ = Bi.realTp THEN
2141 out.GetVar(CSt.dblNInf);
2142 ELSE
2143 out.GetVar(CSt.fltNInf);
2144 END;
2145 END;
2146 | exp : Xp.CallX DO
2147 (*
2148 * EXPERIMENTAL debug marker ...
2149 *)
2150 (*out.LinePlus(exp.token.lin, exp.token.col + exp.token.len);*)
2151 e.PushCall(exp);
2152 | exp : Xp.IdentX DO
2153 IF exp.kind = Xp.selct THEN
2154 IF exp.isProcLit() THEN
2155 out.Comment("Make event value");
2156 e.PushValue(exp.kid, exp.kid.type);
2157 out.MkNewProcVal(exp.ident, typ);
2158 ELSE
2159 e.PushHandle(exp, exp.type);
2160 out.GetField(exp.ident(Id.FldId));
2161 END;
2162 ELSE
2163 e.PushValue(exp.kid, exp.kid.type);
2164 IF exp.kind = Xp.cvrtUp THEN
2165 out.ConvertUp(exp.kid.type, typ);
2166 ELSIF exp.kind = Xp.cvrtDn THEN
2167 out.ConvertDn(exp.kid.type, typ, out.proc.prId.ovfChk);
2168 END;
2169 END;
2170 | exp : Xp.UnaryX DO
2171 e.PushUnary(exp, typ);
2172 | exp : Xp.BinaryX DO
2173 e.PushBinary(exp, typ);
2174 END;
2175 END PushValue;
2176
2177 (* ---------------------------------------------------- *)
2178 (* ---------------------------------------------------- *
2179 *
2180 *PROCEDURE (e : MsilEmitter)PushObjRef(exp : Sy.Expr),NEW;
2181 *BEGIN
2182 * IF Mu.isValRecord(exp.type) THEN
2183 * e.PushRef(exp,exp.type);
2184 * ELSE
2185 * e.PushValue(exp,exp.type);
2186 * END;
2187 *END PushObjRef;
2188 *
2189 * ---------------------------------------------------- *)
2190 (* ---------------------------------------------------- *)
2191
2192 PROCEDURE (e : MsilEmitter)PushVectorIndex(exp : Xp.BinaryX),NEW;
2193 VAR out : Mu.MsilFile;
2194 tide : INTEGER;
2195 okLb : Mu.Label;
2196 vecT : Ty.Vector;
2197 BEGIN
2198 out := e.outF;
2199 okLb := out.newLabel();
2200 vecT := exp.lKid.type(Ty.Vector);
2201 tide := out.proc.newLocal(Bi.intTp);
2202 out.Code(Asm.opc_dup); (* ... vec, vec *)
2203 out.GetField(Mu.vecLeng(out)); (* ... vec, len *)
2204 out.StoreLocal(tide); (* ... vec *)
2205 out.GetField(Mu.vecArrFld(vecT,out)); (* ... aRf *)
2206 e.PushValue(exp.rKid, Bi.intTp); (* ... aRf, idx *)
2207 out.Code(Asm.opc_dup); (* ... vec, idx, idx *)
2208 out.PushLocal(tide); (* ... vec, idx, idx, len *)
2209 out.CodeLb(Asm.opc_blt, okLb); (* ... vec, idx *)
2210 out.IndexTrap();
2211 out.DefLab(okLb);
2212 out.proc.ReleaseLocal(tide);
2213 END PushVectorIndex;
2214
2215 (* ---------------------------------------------------- *)
2216
2217 PROCEDURE (e : MsilEmitter)PushHandle(exp : Sy.Expr; typ : Sy.Type),NEW;
2218 (* Pre: exp must be a variable designator *)
2219 (* Post: Reference to containing object is on TOS. *)
2220 VAR idnt : Sy.Idnt;
2221 out : Mu.MsilFile;
2222 cTmp : INTEGER;
2223 kid : Sy.Expr;
2224 BEGIN
2225 out := e.outF;
2226 ASSERT(exp.isVarDesig());
2227 WITH exp : Xp.IdentX DO
2228 kid := exp.kid;
2229 IF Mu.isValRecord(kid.type) THEN
2230 e.PushRef(kid, kid.type);
2231 ELSE
2232 e.PushValue(kid, kid.type);
2233 END;
2234 | exp : Xp.BinaryX DO
2235 e.PushValue(exp.lKid, exp.lKid.type);
2236 IF exp.lKid.isVectorExpr() THEN
2237 e.PushVectorIndex(exp);
2238 ELSE
2239 e.PushValue(exp.rKid, Bi.intTp);
2240 IF Mu.isValRecord(typ) THEN out.CodeTn(Asm.opc_ldelema, typ) END;
2241 END;
2242 | exp : Xp.IdLeaf DO
2243 IF Mu.isRefSurrogate(typ) THEN
2244 e.PushValue(exp, typ);
2245 ELSE
2246 idnt := exp.ident;
2247 WITH idnt : Id.LocId DO
2248 IF Id.uplevA IN idnt.locAtt THEN
2249 out.XhrHandle(idnt);
2250 ELSE
2251 WITH idnt : Id.ParId DO
2252 IF idnt.boxOrd # Sy.val THEN out.PushArg(idnt.varOrd) END;
2253 ELSE (* skip *)
2254 END;
2255 END;
2256 ELSE (* skip *)
2257 END;
2258 END;
2259 | exp : Xp.UnaryX DO
2260 ASSERT(exp.kind = Xp.deref);
2261 e.PushValue(exp.kid, exp.kid.type);
2262 IF Mu.isValRecord(typ) THEN (* get adr of boxed field *)
2263 out.GetValA(exp.kid.type(Ty.Pointer));
2264 END;
2265 (*
2266 * ELSE
2267 * e.PushValue(exp, typ);
2268 *)
2269 END;
2270 END PushHandle;
2271
2272 (* ---------------------------------------------------- *)
2273
2274 PROCEDURE (e : MsilEmitter)PushRef(exp : Sy.Expr; typ : Sy.Type),NEW;
2275 VAR out : Mu.MsilFile;
2276 sav : INTEGER;
2277 BEGIN
2278 out := e.outF;
2279 WITH exp : Xp.IdLeaf DO (* A scalar variable *)
2280 out.GetVarA(exp.ident);
2281 | exp : Xp.IdentX DO (* A field reference *)
2282 e.PushHandle(exp, typ);
2283 out.GetFieldAdr(exp.ident(Id.FldId));
2284 | exp : Xp.BinaryX DO (* An array element *)
2285 e.PushValue(exp.lKid, exp.lKid.type);
2286 (*
2287 * e.PushValue(exp.rKid, Bi.intTp);
2288 * out.CodeTn(Asm.opc_ldelema, typ);
2289 *)
2290 IF exp.lKid.isVectorExpr() THEN
2291 e.PushVectorIndex(exp);
2292 IF Mu.isValRecord(typ) THEN
2293 out.Code(Asm.opc_ldelem_ref); (* ???? *)
2294 out.CodeT(Asm.opc_unbox, typ);
2295 ELSE
2296 out.CodeTn(Asm.opc_ldelema, typ); (* ???? *)
2297 END;
2298 ELSE
2299 e.PushValue(exp.rKid, Bi.intTp);
2300 out.CodeTn(Asm.opc_ldelema, typ); (* ???? *)
2301 END;
2302
2303 | exp : Xp.CallX DO
2304 (*
2305 * This case occurs where a (foreign) method is
2306 * bound to a value class. In CP, there would
2307 * be a corresponding boxed type instead.
2308 *)
2309 sav := out.proc.newLocal(typ);
2310 e.PushValue(exp, typ);
2311 out.StoreLocal(sav); (* Store in new local variable *)
2312 out.PushLocalA(sav); (* Now take address of local *)
2313 out.proc.ReleaseLocal(sav);
2314 | exp : Xp.UnaryX DO (* Dereference node *)
2315 (*
2316 * It is not always the case that typ and exp.type
2317 * denote the same type. In one usage exp is an
2318 * actual argument, and typ is the type of the formal.
2319 *)
2320 e.PushValue(exp.kid, exp.kid.type);
2321 IF exp.kind = Xp.deref THEN
2322 IF Mu.isValRecord(typ) THEN
2323 out.GetValA(exp.kid.type(Ty.Pointer));
2324 END;
2325 ELSE
2326 ASSERT(exp.kind = Xp.tCheck);
2327 IF Mu.isValRecord(typ) THEN
2328 out.CodeT(Asm.opc_unbox, exp.type);
2329 END;
2330 END;
2331 (* e.PushHandle(exp, typ); *)
2332 ELSE (* skip *)
2333 END;
2334 END PushRef;
2335
2336 (* ---------------------------------------------------- *)
2337
2338 PROCEDURE (e : MsilEmitter)ValueAssign(exp : Sy.Expr),NEW;
2339 VAR out : Mu.MsilFile;
2340 BEGIN
2341 out := e.outF;
2342 WITH exp : Xp.IdLeaf DO
2343 (* stack has ... value, (top) *)
2344 out.PutVar(exp.ident);
2345 | exp : Xp.IdentX DO
2346 (* stack has ... obj-ref, value, (top) *)
2347 out.PutField(exp.ident(Id.FldId));
2348 | exp : Xp.BinaryX DO
2349 (*
2350 * IF element type is a value-rec,
2351 * THEN Stack: ... elem-adr, value, (top)
2352 * ELSE ... arr-ref, index, value, (top)
2353 *)
2354 out.PutElem(exp.type);
2355 | exp : Xp.UnaryX DO
2356 (*
2357 * This is a deref of a value record
2358 * and Stack: ... handle, value, (top)
2359 *)
2360 out.CodeT(Asm.opc_stobj, exp.type);
2361 ELSE
2362 Console.WriteString("BAD VALUE ASSIGN"); Console.WriteLn;
2363 exp.Diagnose(0);
2364 ASSERT(FALSE);
2365 END;
2366 END ValueAssign;
2367
2368 (* ---------------------------------------------------- *)
2369
2370 PROCEDURE (e : MsilEmitter)EraseAndAssign(eT : Sy.Type; vT : Ty.Vector),NEW;
2371 VAR out : Mu.MsilFile;
2372 rT : Sy.Type; (* CLR representation elem type *)
2373 BEGIN
2374 out := e.outF;
2375
2376 rT := Mu.vecRepElTp(vT);
2377
2378 IF eT # rT THEN (* value of elTp is sitting TOS, vector needs rpTp *)
2379 (*
2380 * For the gpcp-1.2.x design all rpTp uses of
2381 * int32, char use default conversions. All
2382 * other base types represent themselves
2383 *)
2384 IF Mu.isValRecord(eT) THEN out.CodeT(Asm.opc_box, eT) END;
2385 END;
2386 out.PutElem(rT);
2387 END EraseAndAssign;
2388
2389 (* ---------------------------------------------------- *)
2390
2391 PROCEDURE (e : MsilEmitter)RefRecCopy(typ : Ty.Record),NEW;
2392 VAR nam : Lv.CharOpen;
2393 BEGIN
2394 (*
2395 * We should use a builtin here for value type, but
2396 * seem to need an element by element copy for classes.
2397 *
2398 * Stack at entry is (top) srcRef, dstRef...
2399 *)
2400 IF typ.xName = NIL THEN Mu.MkRecName(typ, e.outF) END;
2401 e.outF.CopyCall(typ);
2402 END RefRecCopy;
2403
2404 (* ---------------------------------------------------- *)
2405
2406 PROCEDURE (e : MsilEmitter)RefArrCopy(typ : Ty.Array),NEW;
2407 VAR out : Mu.MsilFile;
2408 count : INTEGER;
2409 cardN : INTEGER;
2410 dstLc : INTEGER;
2411 srcLc : INTEGER;
2412 sTemp : INTEGER;
2413 elTyp : Sy.Type;
2414 label : Mu.Label;
2415 BEGIN
2416 elTyp := typ.elemTp;
2417 (*
2418 * Stack at entry is (top) srcRef, dstRef...
2419 *)
2420 out := e.outF;
2421 label := out.newLabel();
2422 (*
2423 * Allocate two local variables.
2424 *)
2425 dstLc := out.proc.newLocal(typ);
2426 srcLc := out.proc.newLocal(typ);
2427 (*
2428 * Initialize the two locals.
2429 *)
2430 out.StoreLocal(srcLc);
2431 out.StoreLocal(dstLc); (* Stack is now empty. *)
2432 cardN := typ.length;
2433 (*
2434 * Compute the length, either now or at runtime...
2435 *)
2436 IF (cardN > 0) & (* ... not open array *)
2437 (cardN <= inlineLimit) & (* ... not too long *)
2438 Mu.hasValueRep(elTyp) THEN (* ... outer dimension *)
2439 (*
2440 * Do inline <element assign> using a compile-time loop
2441 *)
2442 FOR count := 0 TO cardN-1 DO
2443 out.PushLocal(dstLc);
2444 out.PushInt(count);
2445 IF Mu.isValRecord(elTyp) THEN
2446 out.CodeTn(Asm.opc_ldelema, elTyp);
2447 out.PushLocal(srcLc);
2448 out.PushInt(count);
2449 out.CodeTn(Asm.opc_ldelema, elTyp);
2450 out.CodeT(Asm.opc_ldobj, elTyp);
2451 out.CodeT(Asm.opc_stobj, elTyp);
2452 ELSE
2453 IF (elTyp IS Ty.Array) OR
2454 (elTyp IS Ty.Record) THEN out.GetElem(elTyp) END;
2455 out.PushLocal(srcLc);
2456 out.PushInt(count);
2457 out.GetElem(elTyp);
2458 WITH elTyp : Ty.Record DO
2459 e.RefRecCopy(elTyp);
2460 | elTyp : Ty.Array DO
2461 e.RefArrCopy(elTyp);
2462 ELSE (* scalar element type *)
2463 out.PutElem(elTyp);
2464 END;
2465 END;
2466 END;
2467 ELSE (* Do array copy using a runtime loop *)
2468 IF cardN = 0 THEN (* open array, get length from source desc *)
2469 out.PushLocal(srcLc);
2470 out.Code(Asm.opc_ldlen);
2471 ELSE
2472 out.PushInt(cardN);
2473 END;
2474 (*
2475 * Allocate an extra local variable
2476 *)
2477 count := out.proc.newLocal(Bi.intTp);
2478 out.StoreLocal(count);
2479 out.DefLab(label); (* The back-edge target *)
2480 (*
2481 * Decrement the loop count.
2482 *)
2483 out.DecTemp(count); (* Stack is now empty. *)
2484 (*
2485 * We now do the one-per-loop <element assign>
2486 *)
2487 out.PushLocal(dstLc);
2488 out.PushLocal(count);
2489 IF Mu.isValRecord(elTyp) THEN
2490 out.CodeTn(Asm.opc_ldelema, elTyp);
2491 out.PushLocal(srcLc);
2492 out.PushLocal(count);
2493 out.CodeTn(Asm.opc_ldelema, elTyp);
2494 out.CodeT(Asm.opc_ldobj, elTyp);
2495 out.CodeT(Asm.opc_stobj, elTyp);
2496 ELSE
2497 IF (elTyp IS Ty.Array) OR
2498 (elTyp IS Ty.Record) THEN out.GetElem(elTyp) END;
2499 out.PushLocal(srcLc);
2500 out.PushLocal(count);
2501 out.GetElem(elTyp);
2502 WITH elTyp : Ty.Record DO
2503 e.RefRecCopy(elTyp);
2504 | elTyp : Ty.Array DO
2505 e.RefArrCopy(elTyp);
2506 ELSE (* scalar element type *)
2507 out.PutElem(elTyp);
2508 END;
2509 END;
2510 (*
2511 * Loop back to label if count non-zero.
2512 *)
2513 out.PushLocal(count);
2514 out.CodeLb(Asm.opc_brtrue, label);
2515 (*
2516 * release the extra local.
2517 *)
2518 out.proc.ReleaseLocal(count);
2519 END;
2520 (*
2521 * ... and release the two locals.
2522 *)
2523 out.proc.ReleaseLocal(srcLc);
2524 out.proc.ReleaseLocal(dstLc);
2525 END RefArrCopy;
2526
2527 (* ---------------------------------------------------- *)
2528
2529 PROCEDURE (e : MsilEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
2530 (** Make a copy of the value of expression act, into a newly *)
2531 (* allocated destination. Leave dst reference on top of stack. *)
2532 VAR out : Mu.MsilFile;
2533 dTmp : INTEGER;
2534 sTmp : INTEGER;
2535 BEGIN
2536 (*
2537 * Copy this actual, where fmT is either an array or record.
2538 *)
2539 out := e.outF;
2540 WITH fmT : Ty.Record DO
2541 out.MkNewRecord(fmT); (* (top) dst... *)
2542 out.Code(Asm.opc_dup); (* (top) dst,dst... *)
2543 e.PushValue(act, fmT); (* (top) src,dst,dst... *)
2544 e.RefRecCopy(fmT); (* (top) dst... *)
2545 | fmT : Ty.Array DO
2546 (*
2547 * Array case: ordinary value copy
2548 *)
2549 dTmp := out.proc.newLocal(fmT); (* Holds dst reference. *)
2550 sTmp := out.proc.newLocal(fmT); (* Holds src reference. *)
2551 IF fmT.length = 0 THEN
2552 (*
2553 * This is the open array destination case.
2554 * Compute length of actual parameter and
2555 * allocate an array of the needed length.
2556 *)
2557 e.PushValue(act, fmT); (* (top) src... *)
2558 out.Code(Asm.opc_dup); (* (top) src,src... *)
2559 out.StoreLocal(sTmp); (* (top) src... *)
2560
2561 IF act.kind = Xp.mkStr THEN (* (top) src... *)
2562 out.StaticCall(Mu.aStrLp1, 0); (* (top) len... *)
2563 out.CodeTn(Asm.opc_newarr, Bi.charTp); (* (top) dst... *)
2564 ELSE (* (top) src... *)
2565 out.MkArrayCopy(fmT); (* (top) dst... *)
2566 END;
2567 out.Code(Asm.opc_dup); (* (top) dst,dst... *)
2568 out.StoreLocal(dTmp); (* (top) dst... *)
2569 out.PushLocal(sTmp); (* (top) src,dst... *)
2570 ELSE
2571 (*
2572 * This is the fixed-length destination case.
2573 * We allocate an array of the needed length.
2574 *)
2575 out.MkFixedArray(fmT);
2576 out.Code(Asm.opc_dup); (* (top) dst,dst... *)
2577 out.StoreLocal(dTmp); (* (top) dst... *)
2578 e.PushValue(act, fmT); (* (top) src,dst... *)
2579 END;
2580 IF act.kind = Xp.mkStr THEN
2581 out.StaticCall(Mu.aaStrCopy, -2); (* (top) ... *)
2582 ELSE
2583 e.RefArrCopy(fmT); (* (top) ... *)
2584 END;
2585 out.PushLocal(dTmp); (* (top) dst... *)
2586 out.proc.ReleaseLocal(dTmp);
2587 out.proc.ReleaseLocal(sTmp);
2588 END;
2589 END ValueCopy;
2590
2591 (* ---------------------------------------------------- *)
2592
2593 PROCEDURE (e : MsilEmitter)StringCopy(act : Sy.Expr; fmT : Ty.Array),NEW;
2594 VAR out : Mu.MsilFile;
2595 BEGIN
2596 out := e.outF;
2597 IF act.kind = Xp.mkStr THEN
2598 e.ValueCopy(act, fmT);
2599 ELSIF fmT.length = 0 THEN (* str passed to open array *)
2600 e.PushValue(act, fmT);
2601 e.outF.StaticCall(Mu.vStr2ChO, 0);
2602 ELSE (* str passed to fixed array *)
2603 out.PushInt(fmT.length);
2604 out.MkOpenArray(Ty.mkArrayOf(Bi.charTp));
2605 out.Code(Asm.opc_dup);
2606 e.PushValue(act, fmT);
2607 e.outF.StaticCall(Mu.vStr2ChF, -2);
2608 END;
2609 END StringCopy;
2610
2611 (* ============================================================ *)
2612
2613 PROCEDURE (e : MsilEmitter)Invoke(exp : Sy.Expr; typ : Ty.Procedure),NEW;
2614 VAR code : INTEGER;
2615 prcI : Id.PrcId;
2616 mthI : Id.MthId;
2617 BEGIN
2618 IF exp.isProcVar() THEN
2619 e.outF.CallDelegate(typ);
2620 ELSE
2621 WITH exp : Xp.IdLeaf DO (* qualid *)
2622 code := Asm.opc_call;
2623 prcI := exp.ident(Id.PrcId);
2624 IF prcI.kind # Id.ctorP THEN
2625 e.outF.CallIT(code, prcI, typ);
2626 ELSE
2627 e.outF.CallCT(prcI, typ);
2628 END;
2629 | exp : Xp.IdentX DO (* selct *)
2630 mthI := exp.ident(Id.MthId);
2631 IF exp.kind = Xp.sprMrk THEN
2632 code := Asm.opc_call;
2633 ELSIF mthI.bndType.isInterfaceType() THEN
2634 code := Asm.opc_callvirt;
2635
2636 ELSIF (mthI.mthAtt * Id.mask = Id.final) OR
2637 ~mthI.bndType.isExtnRecType() THEN
2638 (* Non-extensible record types can still have virtual *)
2639 (* methods (inherited from Object, say). It is a *)
2640 (* verify error to callvirt on these. kjg April 2006 *)
2641 code := Asm.opc_call;
2642 ELSE
2643 code := Asm.opc_callvirt;
2644 END;
2645 e.outF.CallIT(code, mthI, typ);
2646 IF Id.covar IN mthI.mthAtt THEN
2647 e.outF.CodeT(Asm.opc_castclass, typ.retType);
2648 END;
2649 END;
2650 END;
2651 END Invoke;
2652
2653 (* ---------------------------------------------------- *)
2654
2655 PROCEDURE (e : MsilEmitter)GetArgP(act : Sy.Expr;
2656 frm : Id.ParId),NEW;
2657 VAR out : Mu.MsilFile;
2658 BEGIN
2659 out := e.outF;
2660 IF (frm.boxOrd # Sy.val) OR (Id.cpVarP IN frm.locAtt) THEN
2661 e.PushRef(act, frm.type);
2662 ELSIF (frm.type IS Ty.Array) &
2663 ((act.type = Bi.strTp) OR act.type.isNativeStr()) THEN (* a string *)
2664 e.StringCopy(act, frm.type(Ty.Array));
2665 ELSIF (frm.parMod = Sy.val) & Mu.isRefSurrogate(frm.type) THEN
2666 e.ValueCopy(act, frm.type);
2667 ELSE
2668 e.PushValue(act, frm.type);
2669 END;
2670 END GetArgP;
2671
2672 (* ============================================================ *)
2673 (* Possible structures of procedure call expressions are: *)
2674 (* ============================================================ *)
2675 (* o o *)
2676 (* / / *)
2677 (* [CallX] [CallX] *)
2678 (* / +--- actuals --> ... / +--- actuals *)
2679 (* / / *)
2680 (* [IdentX] [IdLeaf] *)
2681 (* / +--- ident ---> [Procs] +--- ident ---> [Procs] *)
2682 (* / *)
2683 (* kid expr *)
2684 (* *)
2685 (* ============================================================ *)
2686 (* only the right hand case can be a standard proc or function *)
2687 (* ============================================================ *)
2688
2689 PROCEDURE (e : MsilEmitter)PushCall(callX : Xp.CallX),NEW;
2690 VAR iFile : Mu.MsilFile;
2691 index : INTEGER; (* just a counter for loops *)
2692 formT : Ty.Procedure; (* formal type of procedure *)
2693 formP : Id.ParId; (* current formal parameter *)
2694 prExp : Sy.Expr;
2695 idExp : Xp.IdentX;
2696 dummy : BOOLEAN; (* outPar for EmitStat call *)
2697 prVar : BOOLEAN; (* ==> expr is a proc-var *)
2698 (* ---------------------------------------------------- *)
2699 PROCEDURE CheckCall(expr : Sy.Expr; os : Mu.MsilFile);
2700 VAR prcI : Id.PrcId;
2701 mthI : Id.MthId;
2702 BEGIN
2703 WITH expr : Xp.IdLeaf DO (* qualid *)
2704 prcI := expr.ident(Id.PrcId);
2705 IF prcI.type.xName = NIL THEN Mu.MkCallAttr(prcI, os) END;
2706 expr.type := prcI.type;
2707 | expr : Xp.IdentX DO (* selct *)
2708 mthI := expr.ident(Id.MthId);
2709 IF mthI.type.xName = NIL THEN Mu.MkCallAttr(mthI, os) END;
2710 expr.type := mthI.type;
2711 END;
2712 END CheckCall;
2713 (* ---------------------------------------------------- *)
2714 PROCEDURE isNested(exp : Sy.Expr) : BOOLEAN;
2715 BEGIN
2716 WITH exp : Xp.IdLeaf DO (* qualid *)
2717 RETURN exp.ident(Id.PrcId).lxDepth > 0;
2718 ELSE RETURN FALSE;
2719 END;
2720 END isNested;
2721 (* ---------------------------------------------------- *)
2722 BEGIN
2723 iFile := e.outF;
2724 prExp := callX.kid;
2725 formT := prExp.type(Ty.Procedure);
2726 (*
2727 * Before we push any arguments, we must make
2728 * sure that the formal-type name is computed.
2729 *)
2730 prVar := prExp.isProcVar();
2731 IF ~prVar THEN CheckCall(prExp, iFile) END;
2732 formT := prExp.type(Ty.Procedure);
2733 IF prVar THEN
2734 iFile.CommentT("Start delegate call sequence");
2735 e.PushValue(prExp, prExp.type);
2736 ELSIF formT.receiver # NIL THEN
2737 (*
2738 * We must first deal with the receiver if this is a method.
2739 *)
2740 iFile.CommentT("Start dispatch sequence");
2741 idExp := prExp(Xp.IdentX);
2742 formP := idExp.ident(Id.MthId).rcvFrm;
2743 e.GetArgP(idExp.kid, formP);
2744 ELSE
2745 iFile.CommentT("Start static call sequence");
2746 IF isNested(prExp) THEN
2747 iFile.PushStaticLink(prExp(Xp.IdLeaf).ident(Id.Procs));
2748 END;
2749 END;
2750 (*
2751 * We push the arguments from left to right.
2752 *)
2753 FOR index := 0 TO callX.actuals.tide-1 DO
2754 formP := formT.formals.a[index];
2755 e.GetArgP(callX.actuals.a[index], formP);
2756 END;
2757 (*
2758 * Now emit the actual call instruction(s)
2759 *)
2760 e.Invoke(prExp, formT);
2761 (*
2762 * Now clean up.
2763 *)
2764 iFile.CommentT("End call sequence");
2765 END PushCall;
2766
2767 (* ---------------------------------------------------- *)
2768
2769 PROCEDURE (e : MsilEmitter)EmitStdProc(callX : Xp.CallX),NEW;
2770 CONST fMsg = "Assertion failure ";
2771 VAR out : Mu.MsilFile;
2772 cTmp : INTEGER;
2773 rTmp : INTEGER;
2774 prId : Id.PrcId;
2775 vrId : Id.FldId;
2776 pOrd : INTEGER;
2777 arg0 : Sy.Expr;
2778 argX : Sy.Expr;
2779 dstT : Sy.Type;
2780 argN : INTEGER;
2781 numL : INTEGER;
2782 incr : INTEGER;
2783 long : BOOLEAN;
2784 ovfl : BOOLEAN;
2785 subs : BOOLEAN;
2786 c : INTEGER;
2787 okLb : Mu.Label;
2788 vecT : Ty.Vector;
2789 (* --------------------------- *)
2790 BEGIN
2791 out := e.outF;
2792 prId := callX.kid(Xp.IdLeaf).ident(Id.PrcId);
2793 arg0 := callX.actuals.a[0]; (* Always need at least one arg *)
2794 argN := callX.actuals.tide;
2795 pOrd := prId.stdOrd;
2796 CASE pOrd OF
2797 (* --------------------------- *)
2798 | Bi.asrtP :
2799 okLb := out.newLabel();
2800 e.FallFalse(arg0, okLb);
2801 (*
2802 * If expression evaluates to false, fall
2803 * into the error code, else skip to okLb.
2804 *)
2805 IF argN > 1 THEN
2806 numL := intValue(callX.actuals.a[1]);
2807 out.Trap(fMsg + Lv.intToCharOpen(numL)^);
2808 ELSE
2809 numL := callX.token.lin;
2810 out.Trap(fMsg + CSt.srcNam +":"+ Lv.intToCharOpen(numL)^);
2811 END;
2812 out.DefLab(okLb);
2813 (* --------------------------- *)
2814 | Bi.incP, Bi.decP :
2815 argX := callX.actuals.a[1];
2816 dstT := arg0.type;
2817 ovfl := out.proc.prId.ovfChk;
2818 e.PushHandle(arg0, dstT);
2819 WITH arg0 : Xp.IdLeaf DO
2820 e.PushValue(arg0, dstT);
2821 | arg0 : Xp.IdentX DO
2822 vrId := arg0.ident(Id.FldId);
2823 out.Code(Asm.opc_dup);
2824 out.GetField(vrId);
2825 | arg0 : Xp.BinaryX DO
2826 (*
2827 * Here is the decision point: the stack is currently
2828 * (top) index,arrRef,...
2829 * we might reduce the 2-slot handle to an address, then go
2830 * dup; ldind; <add-n>; stind
2831 * but would this verify?
2832 * Alternatively, we can wimp out, and store both the ref
2833 * and the index then go
2834 * ldloc ref; ldloc idx; ldloc ref; ldloc idx; ldelem; <add-n>; stelem
2835 *)
2836 rTmp := out.proc.newLocal(arg0.lKid.type);
2837 cTmp := out.proc.newLocal(Bi.intTp);
2838 out.StoreLocal(cTmp); (* (top) ref,... *)
2839 out.Code(Asm.opc_dup); (* (top) ref,ref,... *)
2840 out.StoreLocal(rTmp); (* (top) ref,... *)
2841 out.PushLocal(cTmp); (* (top) idx,ref,... *)
2842 out.PushLocal(rTmp); (* (top) ref,idx,ref,... *)
2843 out.PushLocal(cTmp); (* (top) idx,ref,idx,ref,... *)
2844 out.GetElem(dstT); (* (top) idx,ref,... *)
2845 out.proc.ReleaseLocal(cTmp);
2846 out.proc.ReleaseLocal(rTmp);
2847 END;
2848 e.PushValue(argX, dstT);
2849 IF pOrd = Bi.incP THEN
2850 IF ovfl THEN c := Asm.opc_add_ovf ELSE c := Asm.opc_add END;
2851 ELSE
2852 IF ovfl THEN c := Asm.opc_sub_ovf ELSE c := Asm.opc_sub END;
2853 END;
2854 out.Code(c);
2855 e.ValueAssign(arg0);
2856 (* --------------------------- *)
2857 | Bi.cutP :
2858 argX := callX.actuals.a[1];
2859 vecT := arg0.type(Ty.Vector);
2860 cTmp := out.proc.newLocal(Bi.intTp);
2861 okLb := out.newLabel();
2862 (*
2863 * Push vector ref, and save tide
2864 *)
2865 e.PushValue(arg0, arg0.type);
2866 out.Code(Asm.opc_dup);
2867 out.GetField(Mu.vecLeng(out));
2868 out.StoreLocal(cTmp);
2869 (*
2870 * Push new leng, and check against tide
2871 *)
2872 e.PushValue(argX, Bi.intTp);
2873 out.Code(Asm.opc_dup);
2874 out.PushLocal(cTmp);
2875 out.CodeLb(Asm.opc_ble_un, okLb);
2876 out.IndexTrap();
2877 (*
2878 * If no trap, then assign the new tide
2879 *)
2880 out.DefLab(okLb);
2881 out.PutField(Mu.vecLeng(out));
2882 out.proc.ReleaseLocal(cTmp);
2883 (* --------------------------- *)
2884 | Bi.apndP :
2885 argX := callX.actuals.a[1];
2886 vecT := arg0.type(Ty.Vector);
2887 okLb := out.newLabel();
2888 cTmp := out.proc.newLocal(Bi.intTp);
2889 rTmp := out.proc.newLocal(Mu.vecRepTyp(vecT));
2890 (*
2891 * Push vector ref, and save ref and tide
2892 *)
2893 e.PushValue(arg0, vecT);
2894 out.Code(Asm.opc_dup);
2895 out.StoreLocal(rTmp);
2896 out.GetField(Mu.vecLeng(out));
2897 out.StoreLocal(cTmp);
2898 (*
2899 * Fetch capacity and compare with tide
2900 *)
2901 out.PushLocal(rTmp);
2902 out.GetField(Mu.vecArrFld(vecT, out));
2903 out.Code(Asm.opc_ldlen);
2904 out.PushLocal(cTmp);
2905 out.CodeLb(Asm.opc_bgt, okLb);
2906 (*
2907 * Call the RTS expand() method
2908 *)
2909 out.PushLocal(rTmp);
2910 out.InvokeExpand(vecT);
2911 (*
2912 * Now insert the element
2913 *)
2914 out.DefLab(okLb);
2915 out.PushLocal(rTmp);
2916 out.GetField(Mu.vecArrFld(vecT, out));
2917 out.PushLocal(cTmp);
2918 IF Mu.isRefSurrogate(argX.type) THEN
2919 (* e.ValueCopy(argX, argX.type); *)
2920 e.ValueCopy(argX, vecT.elemTp);
2921 ELSE
2922 (* e.PushValue(argX, argX.type); *)
2923 e.PushValue(argX, vecT.elemTp);
2924 END;
2925 e.EraseAndAssign(argX.type, vecT);
2926 (*
2927 * Now increment tide;
2928 *)
2929 out.PushLocal(rTmp);
2930 out.PushLocal(cTmp);
2931 out.Code(Asm.opc_ldc_i4_1);
2932 out.Code(Asm.opc_add);
2933 out.PutField(Mu.vecLeng(out));
2934
2935 out.proc.ReleaseLocal(rTmp);
2936 out.proc.ReleaseLocal(cTmp);
2937 (* --------------------------- *)
2938 | Bi.exclP, Bi.inclP :
2939 dstT := arg0.type;
2940 argX := callX.actuals.a[1];
2941 e.PushHandle(arg0, dstT);
2942 IF arg0 IS Xp.IdLeaf THEN
2943 e.PushValue(arg0, dstT);
2944 ELSE
2945 WITH arg0 : Xp.BinaryX DO
2946 ASSERT(arg0.kind = Xp.index);
2947 rTmp := out.proc.newLocal(arg0.lKid.type);
2948 cTmp := out.proc.newLocal(Bi.intTp);
2949 out.StoreLocal(cTmp);
2950 out.Code(Asm.opc_dup);
2951 out.StoreLocal(rTmp);
2952 out.PushLocal(cTmp); (* (top) idx,ref,... *)
2953 out.PushLocal(rTmp); (* (top) ref,idx,ref,... *)
2954 out.PushLocal(cTmp); (* (top) idx,ref,idx,ref,... *)
2955 out.GetElem(dstT); (* (top) idx,ref,... *)
2956 out.proc.ReleaseLocal(cTmp);
2957 out.proc.ReleaseLocal(rTmp);
2958 | arg0 : Xp.IdentX DO
2959 ASSERT(arg0.kind = Xp.selct);
2960 out.Code(Asm.opc_dup);
2961 out.GetField(arg0.ident(Id.FldId));
2962 END;
2963 END;
2964 IF argX.kind = Xp.numLt THEN
2965 out.PushInt(ORD({intValue(argX)}));
2966 ELSE
2967 out.Code(Asm.opc_ldc_i4_1);
2968 e.PushValue(argX, Bi.intTp);
2969 out.Code(Asm.opc_shl);
2970 END;
2971 IF pOrd = Bi.inclP THEN
2972 out.Code(Asm.opc_or);
2973 ELSE
2974 out.Code(Asm.opc_ldc_i4_M1);
2975 out.Code(Asm.opc_xor);
2976 out.Code(Asm.opc_and);
2977 END;
2978 e.ValueAssign(arg0);
2979 (* --------------------------- *)
2980 | Bi.subsP, Bi.unsbP :
2981 dstT := arg0.type;
2982 argX := callX.actuals.a[1];
2983 subs := pOrd = Bi.subsP;
2984 e.PushHandle(arg0, dstT);
2985 WITH argX : Xp.IdLeaf DO
2986 out.Code(Asm.opc_ldnull);
2987 out.MkAndLinkDelegate(argX.ident, IdentOf(arg0), dstT, subs);
2988 | argX : Xp.IdentX DO
2989 e.PushValue(argX.kid, CSt.ntvObj);
2990 out.MkAndLinkDelegate(argX.ident, IdentOf(arg0), dstT, subs);
2991 END;
2992 (* --------------------------- *)
2993 | Bi.haltP :
2994 out.PushInt(intValue(arg0));
2995 out.StaticCall(Mu.sysExit, -1);
2996 (*
2997 * We now do a dummy return to signal
2998 * the verifier that control exits here.
2999 *)
3000 out.PushJunkAndQuit(out.proc.prId);
3001 (* --------------------------- *)
3002 | Bi.throwP :
3003 IF CSt.ntvExc.assignCompat(arg0) THEN
3004 e.PushValue(arg0, CSt.ntvExc);
3005 out.Code(Asm.opc_throw);
3006 ELSE
3007 e.PushValue(arg0, CSt.ntvStr);
3008 out.Throw();
3009 END;
3010 (* --------------------------- *)
3011 | Bi.newP :
3012 (*
3013 * arg0 is a a vector, or a pointer to a Record or Array type.
3014 *)
3015 e.PushHandle(arg0, arg0.type);
3016 IF argN = 1 THEN
3017 (*
3018 * No LEN argument implies either:
3019 * pointer to record, OR
3020 * pointer to a fixed array.
3021 *)
3022 dstT := arg0.type(Ty.Pointer).boundTp;
3023 WITH dstT : Ty.Record DO
3024 out.MkNewRecord(dstT);
3025 | dstT : Ty.Array DO
3026 out.MkFixedArray(dstT);
3027 END;
3028 ELSIF arg0.type.kind = Ty.ptrTp THEN
3029 FOR numL := argN-1 TO 1 BY -1 DO
3030 argX := callX.actuals.a[numL];
3031 e.PushValue(argX, Bi.intTp);
3032 END;
3033 dstT := arg0.type(Ty.Pointer).boundTp;
3034 out.MkOpenArray(dstT(Ty.Array));
3035 ELSE (* must be a vector *)
3036 dstT := arg0.type(Ty.Vector).elemTp;
3037 out.MkVecRec(dstT);
3038 out.Code(Asm.opc_dup);
3039 e.PushValue(callX.actuals.a[1], Bi.intTp);
3040 out.MkVecArr(dstT);
3041 END;
3042 e.ValueAssign(arg0);
3043 (* --------------------------- *)
3044 | Bi.getP :
3045 (*
3046 * arg0 is an integer value
3047 *)
3048 argX := callX.actuals.a[1];
3049 e.PushHandle(argX, argX.type);
3050 e.PushValue(arg0, Bi.intTp);
3051 out.LoadIndirect(argX.type);
3052 e.ValueAssign(argX);
3053 (* --------------------------- *)
3054 | Bi.putP :
3055 (*
3056 * arg0 is an integer value
3057 *)
3058 argX := callX.actuals.a[1];
3059 e.PushValue(arg0, Bi.intTp);
3060 e.PushValue(argX, argX.type);
3061 out.StoreIndirect(argX.type);
3062 (* --------------------------- *)
3063 END;
3064 END EmitStdProc;
3065
3066 (* ============================================================ *)
3067 (* Statement Handling Methods *)
3068 (* ============================================================ *)
3069
3070 PROCEDURE (e : MsilEmitter)EmitAssign(stat : St.Assign),NEW;
3071 VAR lhTyp : Sy.Type;
3072 erasd : BOOLEAN;
3073 BEGIN
3074 (*
3075 * This is a value assign in CP.
3076 *)
3077 lhTyp := stat.lhsX.type;
3078 (*
3079 * Test if the erased type of the vector element
3080 * has to be reconstructed by a type assertion
3081 *)
3082 erasd := (stat.lhsX.kind = Xp.index) &
3083 (stat.lhsX(Xp.BinaryX).lKid.type IS Ty.Vector);
3084
3085 IF Mu.hasValueRep(lhTyp) THEN
3086 e.PushHandle(stat.lhsX, lhTyp);
3087 e.PushValue(stat.rhsX, lhTyp);
3088 IF erasd THEN
3089 e.EraseAndAssign(lhTyp, stat.lhsX(Xp.BinaryX).lKid.type(Ty.Vector));
3090 ELSE
3091 e.ValueAssign(stat.lhsX);
3092 END;
3093 ELSE (* a reference type *)
3094 e.PushValue(stat.lhsX, lhTyp);
3095 e.PushValue(stat.rhsX, lhTyp);
3096 WITH lhTyp : Ty.Array DO
3097 IF stat.rhsX.kind = Xp.mkStr THEN
3098 e.outF.StaticCall(Mu.aaStrCopy, -2);
3099 ELSIF isStrExp(stat.rhsX) THEN
3100 e.outF.StaticCall(Mu.vStr2ChF, -2);
3101 ELSE
3102 e.RefArrCopy(lhTyp);
3103 END;
3104 | lhTyp : Ty.Record DO
3105 e.RefRecCopy(lhTyp);
3106 END;
3107 END;
3108 END EmitAssign;
3109
3110 (* ---------------------------------------------------- *)
3111
3112 PROCEDURE (e : MsilEmitter)EmitCall(stat : St.ProcCall),NEW;
3113 VAR expr : Xp.CallX; (* the stat call expression *)
3114 BEGIN
3115 expr := stat.expr(Xp.CallX);
3116 IF (expr.kind = Xp.prCall) & expr.kid.isStdProc() THEN
3117 e.EmitStdProc(expr);
3118 ELSE (* EXPERIMENTAL debug marking *)
3119 e.PushCall(expr);
3120 IF CSt.debug THEN e.outF.Code(Asm.opc_nop) END;
3121 END;
3122 END EmitCall;
3123
3124 (* ---------------------------------------------------- *)
3125
3126 PROCEDURE (e : MsilEmitter)
3127 EmitIf(stat : St.Choice; OUT ok : BOOLEAN),NEW;
3128 VAR out : Mu.MsilFile;
3129 high : INTEGER; (* Branch count. *)
3130 indx : INTEGER;
3131 live : BOOLEAN; (* then is live *)
3132 else : BOOLEAN; (* else not seen *)
3133 then : Sy.Stmt;
3134 pred : Sy.Expr;
3135 nxtP : Mu.Label; (* Next predicate *)
3136 exLb : Mu.Label; (* Exit label *)
3137 BEGIN
3138 ok := FALSE;
3139 out := e.outF;
3140 exLb := out.newLabel();
3141 else := FALSE;
3142 high := stat.preds.tide - 1;
3143 IF CSt.debug THEN out.Code(Asm.opc_nop) END;
3144 FOR indx := 0 TO high DO
3145 live := TRUE;
3146 pred := stat.preds.a[indx];
3147 then := stat.blocks.a[indx];
3148 nxtP := out.newLabel();
3149 IF pred = NIL THEN
3150 else := TRUE;
3151 ELSE
3152 out.LineSpan(pred.tSpan);
3153 e.FallTrue(pred, nxtP);
3154 END;
3155 IF then # NIL THEN e.EmitStat(then, live) END;
3156 IF live THEN
3157 ok := TRUE;
3158 IF indx < high THEN out.CodeLb(Asm.opc_br, exLb) END;
3159 END;
3160 out.DefLab(nxtP);
3161 END;
3162 (*
3163 * If not ELSE has been seen, then control flow is still live!
3164 *)
3165 IF ~else THEN ok := TRUE END;
3166 out.DefLab(exLb);
3167 END EmitIf;
3168
3169 (* ---------------------------------------------------- *)
3170
3171 PROCEDURE (e : MsilEmitter)EmitRanges
3172 (locV : INTEGER; (* select Var *)
3173 stat : St.CaseSt; (* case stat *)
3174 minR : INTEGER; (* min rng-ix *)
3175 maxR : INTEGER; (* max rng-ix *)
3176 minI : INTEGER; (* min index *)
3177 maxI : INTEGER; (* max index *)
3178 dfLb : Mu.LbArr),NEW; (* default Lb *)
3179 (* --------------------------------------------------------- *
3180 * This procedure emits the code for a single,
3181 * dense range of selector values in the label-list.
3182 * --------------------------------------------------------- *)
3183 VAR out : Mu.MsilFile;
3184 loIx : INTEGER; (* low selector value for dense range *)
3185 hiIx : INTEGER; (* high selector value for dense range *)
3186 rNum : INTEGER; (* total number of ranges in the group *)
3187 peel : INTEGER; (* max index of range to be peeled off *)
3188 indx : INTEGER;
3189 rnge : St.Triple;
3190 BEGIN
3191 out := e.outF;
3192 rNum := maxR - minR + 1;
3193 rnge := stat.labels.a[minR];
3194 IF rNum = 1 THEN (* single range only *)
3195 out.EmitOneRange(locV, rnge.loC, rnge.hiC, rnge.ord, minI, maxI, dfLb);
3196 ELSIF rNum < 4 THEN
3197 (*
3198 * Two or three ranges only.
3199 * Peel off the lowest of the ranges, and recurse.
3200 *)
3201 loIx := rnge.loC;
3202 peel := rnge.hiC;
3203 out.PushLocal(locV);
3204 (*
3205 * There are a number of special cases
3206 * that can benefit from special code.
3207 *)
3208 IF loIx = peel THEN
3209 (*
3210 * A singleton. Leave minI unchanged, unless peel = minI.
3211 *)
3212 out.PushInt(peel);
3213 out.CodeLb(Asm.opc_beq, dfLb[rnge.ord+1]);
3214 IF minI = peel THEN minI := peel+1 END;
3215 ELSIF loIx = minI THEN
3216 (*
3217 * A range starting at the minimum selector value.
3218 *)
3219 out.PushInt(peel);
3220 out.CodeLb(Asm.opc_ble, dfLb[rnge.ord+1]);
3221 minI := peel+1;
3222 ELSE
3223 out.PushInt(loIx);
3224 out.Code(Asm.opc_sub);
3225 out.PushInt(peel-loIx);
3226 out.CodeLb(Asm.opc_ble_un, dfLb[rnge.ord+1]);
3227 (* leaving minI unchanged! *)
3228 END;
3229 e.EmitRanges(locV, stat, (minR+1), maxR, minI, maxI, dfLb);
3230 ELSE
3231 (*
3232 * Four or more ranges. Emit a dispatch table.
3233 *)
3234 loIx := rnge.loC; (* low of min-range *)
3235 hiIx := stat.labels.a[maxR].hiC; (* high of max-range *)
3236 out.PushLocal(locV);
3237 IF loIx # 0 THEN
3238 out.PushInt(loIx);
3239 out.Code(Asm.opc_sub);
3240 END;
3241 out.SwitchHead(hiIx - loIx + 1);
3242 (* ---- *)
3243 FOR indx := minR TO maxR DO
3244 rnge := stat.labels.a[indx];
3245 WHILE loIx < rnge.loC DO
3246 out.LstLab(dfLb[0]); INC(loIx);
3247 END;
3248 WHILE loIx <= rnge.hiC DO
3249 out.LstLab(dfLb[rnge.ord+1]); INC(loIx);
3250 END;
3251 END;
3252 (* ---- *)
3253 out.SwitchTail();
3254 out.CodeLb(Asm.opc_br, dfLb[0])
3255 END;
3256 END EmitRanges;
3257
3258 (* ---------------------------------------------------- *)
3259
3260 PROCEDURE (e : MsilEmitter)EmitGroups
3261 (locV : INTEGER; (* select vOrd *)
3262 stat : St.CaseSt; (* case stat *)
3263 minG : INTEGER; (* min grp-indx *)
3264 maxG : INTEGER; (* max grp-indx *)
3265 minI : INTEGER; (* min index *)
3266 maxI : INTEGER; (* max index *)
3267 dfLb : Mu.LbArr),NEW; (* default lab *)
3268 (* --------------------------------------------------------- *
3269 * This function emits the branching code which sits on top
3270 * of the selection code for each dense range of case values.
3271 * --------------------------------------------------------- *)
3272 VAR out : Mu.MsilFile;
3273 newLb : Mu.Label;
3274 midPt : INTEGER;
3275 group : St.Triple;
3276 range : St.Triple;
3277 BEGIN
3278 IF maxG = -1 THEN RETURN (* This is an empty case statement *)
3279 ELSIF minG = maxG THEN (* Only one remaining dense group *)
3280 group := stat.groups.a[minG];
3281 e.EmitRanges(locV, stat, group.loC, group.hiC, minI, maxI, dfLb);
3282 ELSE
3283 (*
3284 * We must bifurcate the group range, and recurse.
3285 * We will split the value range at the lower limit
3286 * of the low-range of the upper half-group.
3287 *)
3288 midPt := (minG + maxG + 1) DIV 2;
3289 group := stat.groups.a[midPt];
3290 range := stat.labels.a[group.loC];
3291 (*
3292 * Test and branch at range.loC
3293 *)
3294 out := e.outF;
3295 newLb := out.newLabel();
3296 out.PushLocal(locV);
3297 out.PushInt(range.loC);
3298 out.CodeLb(Asm.opc_bge, newLb);
3299 (*
3300 * Recurse!
3301 *)
3302 e.EmitGroups(locV, stat, minG, midPt-1, minI, range.loC-1, dfLb);
3303 out.DefLab(newLb);
3304 e.EmitGroups(locV, stat, midPt, maxG, range.loC, maxI, dfLb);
3305 END;
3306 END EmitGroups;
3307
3308 (* ---------------------------------------------------- *)
3309
3310 PROCEDURE (e : MsilEmitter)
3311 EmitCase(stat : St.CaseSt; OUT ok : BOOLEAN),NEW;
3312 VAR out : Mu.MsilFile;
3313 indx : INTEGER;
3314 selV : INTEGER;
3315 live : BOOLEAN;
3316 minI : INTEGER;
3317 maxI : INTEGER;
3318 dfLb : Mu.LbArr;
3319 exLb : Mu.Label;
3320 BEGIN
3321 (* ---------------------------------------------------------- *
3322 * CaseSt* = POINTER TO RECORD (Sy.Stmt)
3323 * (* ----------------------------------------- *
3324 * * kind- : INTEGER; (* tag for unions *)
3325 * * token* : S.Token; (* stmt first tok *)
3326 * * ----------------------------------------- *)
3327 * select* : Sy.Expr; (* case selector *)
3328 * chrSel* : BOOLEAN; (* ==> use chars *)
3329 * blocks* : Sy.StmtSeq; (* case bodies *)
3330 * elsBlk* : Sy.Stmt; (* elseCase | NIL *)
3331 * labels* : TripleSeq; (* label seqence *)
3332 * groups- : TripleSeq; (* dense groups *)
3333 * END;
3334 * --------------------------------------------------------- *
3335 * Notes on the semantics of this structure. "blocks" holds *
3336 * an ordered list of case statement code blocks. "labels" *
3337 * is a list of ranges, intially in textual order,with flds *
3338 * loC, hiC and ord corresponding to the range min, max and *
3339 * the selected block ordinal number. This list is later *
3340 * sorted on the loC value, and adjacent values merged if *
3341 * they select the same block. The "groups" list of triples *
3342 * groups ranges into dense subranges in the selector space *
3343 * The fields loC, hiC, and ord to hold the lower and upper *
3344 * indices into the labels list, and the number of non- *
3345 * default values in the group. Groups are guaranteed to *
3346 * have density (nonDefN / (max-min+1)) > DENSITY *
3347 * --------------------------------------------------------- *)
3348 ok := FALSE;
3349 out := e.outF;
3350 exLb := out.newLabel();
3351 dfLb := out.getLabelRange(stat.blocks.tide+1);
3352 IF stat.chrSel THEN
3353 minI := 0; maxI := ORD(MAX(CHAR));
3354 selV := out.proc.newLocal(Bi.charTp);
3355 ELSE
3356 minI := MIN(INTEGER);
3357 maxI := MAX(INTEGER);
3358 selV := out.proc.newLocal(Bi.intTp);
3359 END;
3360
3361 (*
3362 * Push the selector value, and save in local variable;
3363 *)
3364 e.PushValue(stat.select, stat.select.type);
3365 out.StoreLocal(selV);
3366 e.EmitGroups(selV, stat, 0, stat.groups.tide-1, minI, maxI, dfLb);
3367 (*
3368 * Now we emit the code for the cases.
3369 * If any branch returns, then exLb is reachable.
3370 *)
3371 FOR indx := 0 TO stat.blocks.tide-1 DO
3372 out.DefLab(dfLb[indx+1]);
3373 e.EmitStat(stat.blocks.a[indx], live);
3374 IF live THEN
3375 ok := TRUE;
3376 out.CodeLb(Asm.opc_br, exLb);
3377 END;
3378 END;
3379 (*
3380 * Now we emit the code for the elespart.
3381 * If the elsepart returns then exLb is reachable.
3382 *)
3383 out.DefLabC(dfLb[0], "Default case");
3384 IF stat.elsBlk # NIL THEN
3385 e.EmitStat(stat.elsBlk, live);
3386 IF live THEN ok := TRUE END;
3387 ELSE
3388 out.CaseTrap(selV);
3389 END;
3390 out.proc.ReleaseLocal(selV);
3391 IF ok THEN out.DefLabC(exLb, "Case exit label") END;
3392 END EmitCase;
3393
3394 (* ---------------------------------------------------- *)
3395
3396 PROCEDURE (e : MsilEmitter)
3397 EmitWhile(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3398 VAR out : Mu.MsilFile;
3399 lpLb : Mu.Label;
3400 exLb : Mu.Label;
3401 BEGIN
3402 out := e.outF;
3403 lpLb := out.newLabel();
3404 exLb := out.newLabel();
3405 IF CSt.debug THEN out.Code(Asm.opc_nop) END;
3406 out.LineSpan(stat.test.tSpan);
3407 e.FallTrue(stat.test, exLb); (* goto exLb if eval false *)
3408 out.DefLabC(lpLb, "Loop header");
3409 e.EmitStat(stat.body, ok);
3410 IF ok THEN
3411 out.LineSpan(stat.test.tSpan);
3412 e.FallFalse(stat.test, lpLb);
3413 END;
3414 out.DefLabC(exLb, "Loop exit");
3415 END EmitWhile;
3416
3417 (* ---------------------------------------------------- *)
3418
3419 PROCEDURE (e : MsilEmitter)
3420 EmitRepeat(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3421 VAR out : Mu.MsilFile;
3422 lpLb : Mu.Label;
3423 BEGIN
3424 out := e.outF;
3425 lpLb := out.newLabel();
3426 out.DefLabC(lpLb, "Loop header");
3427 e.EmitStat(stat.body, ok);
3428 IF ok THEN
3429 out.LineSpan(stat.test.tSpan);
3430 e.FallTrue(stat.test, lpLb);
3431 END; (* exit on eval true *)
3432 out.CommentT("Loop exit");
3433 END EmitRepeat;
3434
3435 (* ---------------------------------------------------- *)
3436
3437 PROCEDURE (e : MsilEmitter)
3438 EmitFor(stat : St.ForLoop; OUT ok : BOOLEAN),NEW;
3439 (* ----------------------------------------------------------- *
3440 * This code has been split into the four cases:
3441 * - long control variable, counting up;
3442 * - long control variable, counting down;
3443 * - int control variable, counting up;
3444 * - int control variable, counting down;
3445 * Of course, it is possible to fold all of this, and have
3446 * tests everywhere, but the following is cleaner, and easier
3447 * to enhance in the future.
3448 *
3449 * Note carefully the use of ForLoop::isSimple(). It is
3450 * essential to use exactly the same function here as is
3451 * used by ForLoop::flowAttr() for initialization analysis.
3452 * If this were not the case, the verifier could barf.
3453 *
3454 * 23 August 2001 -- correcting error when reference
3455 * param is used as a FOR-loop control variable (kjg)
3456 *
3457 * 07 February 2002 -- correcting error when control
3458 * variable is stored in an XHR (uplevel) record (kjg)
3459 * ----------------------------------------------------------- *)
3460 PROCEDURE LongForUp(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3461 VAR out : Mu.MsilFile;
3462 cVar : Id.AbVar;
3463 step : LONGINT;
3464 smpl : BOOLEAN;
3465 isRP : BOOLEAN;
3466 isUl : BOOLEAN; (* ==> cVar is an uplevel local var. *)
3467 indr : BOOLEAN; (* ==> cVar is indirectly accessed *)
3468 tmpL : INTEGER;
3469 topL : INTEGER;
3470 exLb : Mu.Label;
3471 lpLb : Mu.Label;
3472 BEGIN
3473 out := e.outF;
3474 lpLb := out.newLabel();
3475 exLb := out.newLabel();
3476 cVar := stat.cVar(Id.AbVar);
3477 step := longValue(stat.byXp);
3478 smpl := stat.isSimple();
3479 isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
3480 isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
3481 indr := isRP OR isUl;
3482
3483 IF indr THEN
3484 tmpL := out.proc.newLocal(Bi.lIntTp);
3485 ELSE
3486 tmpL := -1; (* keep the verifier happy! *)
3487 END;
3488 IF ~smpl THEN
3489 topL := out.proc.newLocal(Bi.lIntTp);
3490 ELSE
3491 topL := -1; (* keep the verifier happy! *)
3492 END;
3493
3494 IF smpl THEN
3495 IF isRP THEN
3496 out.PushArg(cVar.varOrd);
3497 ELSIF isUl THEN
3498 out.XhrHandle(cVar(Id.LocId));
3499 END;
3500 out.PushLong(longValue(stat.loXp));
3501 out.PutVar(cVar);
3502 ELSE
3503 e.PushValue(stat.hiXp, Bi.lIntTp);
3504 out.Code(Asm.opc_dup);
3505 out.StoreLocal(topL);
3506 IF isRP THEN
3507 out.PushArg(cVar.varOrd);
3508 ELSIF isUl THEN
3509 out.XhrHandle(cVar(Id.LocId));
3510 END;
3511 e.PushValue(stat.loXp, Bi.lIntTp);
3512 out.Code(Asm.opc_dup);
3513 IF indr THEN out.StoreLocal(tmpL) END;
3514 out.PutVar(cVar);
3515 IF indr THEN out.PushLocal(tmpL) END;
3516 (*
3517 * The top test is NEVER inside the loop.
3518 *)
3519 e.DoCmp(Xp.lessT, exLb, Bi.lIntTp);
3520 END;
3521 out.DefLabC(lpLb, "Loop header");
3522 (*
3523 * Emit the code body.
3524 * Stack contents are (top) hi, ...
3525 * and exactly the same on the backedge.
3526 *)
3527 e.EmitStat(stat.body, ok);
3528 (*
3529 * If the body returns ... do an exit test.
3530 *)
3531 IF ok THEN
3532 IF smpl THEN
3533 out.PushLong(longValue(stat.hiXp));
3534 ELSE
3535 out.PushLocal(topL);
3536 END;
3537 IF isRP THEN
3538 out.PushArg(cVar.varOrd);
3539 ELSIF isUl THEN
3540 out.XhrHandle(cVar(Id.LocId));
3541 END;
3542 out.GetVar(cVar); (* (top) cv,hi *)
3543 out.PushLong(step);
3544 out.Code(Asm.opc_add_ovf); (* (top) cv',hi *)
3545 out.Code(Asm.opc_dup); (* (top) cv',cv',hi *)
3546 IF indr THEN out.StoreLocal(tmpL) END;
3547 out.PutVar(cVar); (* (top) cv',hi *)
3548 IF indr THEN out.PushLocal(tmpL) END;
3549 e.DoCmp(Xp.greEq, lpLb, Bi.lIntTp);
3550 END;
3551 IF indr THEN out.proc.ReleaseLocal(tmpL) END;
3552 IF ~smpl THEN out.proc.ReleaseLocal(topL) END;
3553 (*
3554 * The exit label.
3555 *)
3556 out.DefLabC(exLb, "Loop trailer");
3557 END LongForUp;
3558
3559 (* ----------------------------------------- *)
3560
3561 PROCEDURE LongForDn(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3562 VAR out : Mu.MsilFile;
3563 cVar : Id.AbVar;
3564 tmpL : INTEGER;
3565 topL : INTEGER;
3566 step : LONGINT;
3567 smpl : BOOLEAN;
3568 isRP : BOOLEAN;
3569 isUl : BOOLEAN; (* ==> cVar is an uplevel local var. *)
3570 indr : BOOLEAN; (* ==> cVar is indirectly accessed *)
3571 exLb : Mu.Label;
3572 lpLb : Mu.Label;
3573 BEGIN
3574 out := e.outF;
3575 lpLb := out.newLabel();
3576 exLb := out.newLabel();
3577 cVar := stat.cVar(Id.AbVar);
3578 step := longValue(stat.byXp);
3579 smpl := stat.isSimple();
3580 isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
3581 isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
3582 indr := isRP OR isUl;
3583
3584 IF indr THEN
3585 tmpL := out.proc.newLocal(Bi.lIntTp);
3586 ELSE
3587 tmpL := -1; (* keep the verifier happy! *)
3588 END;
3589 IF ~smpl THEN
3590 topL := out.proc.newLocal(Bi.lIntTp);
3591 ELSE
3592 topL := -1; (* keep the verifier happy! *)
3593 END;
3594
3595 IF smpl THEN
3596 IF isRP THEN
3597 out.PushArg(cVar.varOrd);
3598 ELSIF isUl THEN
3599 out.XhrHandle(cVar(Id.LocId));
3600 END;
3601 out.PushLong(longValue(stat.loXp));
3602 out.PutVar(cVar);
3603 ELSE
3604 e.PushValue(stat.hiXp, Bi.lIntTp);
3605 out.Code(Asm.opc_dup);
3606 out.StoreLocal(topL);
3607 IF isRP THEN
3608 out.PushArg(cVar.varOrd);
3609 ELSIF isUl THEN
3610 out.XhrHandle(cVar(Id.LocId));
3611 END;
3612 e.PushValue(stat.loXp, Bi.lIntTp);
3613 out.Code(Asm.opc_dup);
3614 IF indr THEN out.StoreLocal(tmpL) END;
3615 out.PutVar(cVar);
3616 IF indr THEN out.PushLocal(tmpL) END;
3617 (*
3618 * The top test is NEVER inside the loop.
3619 *)
3620 e.DoCmp(Xp.greT, exLb, Bi.lIntTp);
3621 END;
3622 out.DefLabC(lpLb, "Loop header");
3623 (*
3624 * Emit the code body.
3625 * Stack contents are (top) hi, ...
3626 * and exactly the same on the backedge.
3627 *)
3628 e.EmitStat(stat.body, ok);
3629 (*
3630 * If the body returns ... do an exit test.
3631 *)
3632 IF ok THEN
3633 IF smpl THEN
3634 out.PushLong(longValue(stat.hiXp));
3635 ELSE
3636 out.PushLocal(topL);
3637 END;
3638 IF isRP THEN
3639 out.PushArg(cVar.varOrd);
3640 ELSIF isUl THEN
3641 out.XhrHandle(cVar(Id.LocId));
3642 END;
3643 out.GetVar(cVar); (* (top) cv,hi *)
3644 out.PushLong(step);
3645 out.Code(Asm.opc_add_ovf); (* (top) cv',hi *)
3646 out.Code(Asm.opc_dup); (* (top) cv',cv',hi *)
3647 IF indr THEN out.StoreLocal(tmpL) END;
3648 out.PutVar(cVar); (* (top) cv',hi *)
3649 IF indr THEN out.PushLocal(tmpL) END;
3650 e.DoCmp(Xp.lessEq, lpLb, Bi.lIntTp);
3651 END;
3652 IF indr THEN out.proc.ReleaseLocal(tmpL) END;
3653 IF ~smpl THEN out.proc.ReleaseLocal(topL) END;
3654 (*
3655 * The exit label.
3656 *)
3657 out.DefLabC(exLb, "Loop trailer");
3658 END LongForDn;
3659
3660 (* ----------------------------------------- *)
3661
3662 PROCEDURE IntForUp(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3663 VAR out : Mu.MsilFile;
3664 cVar : Id.AbVar;
3665 topV : INTEGER;
3666 tmpV : INTEGER;
3667 step : INTEGER;
3668 smpl : BOOLEAN;
3669 isRP : BOOLEAN; (* ==> cVar is a reference parameter *)
3670 isUl : BOOLEAN; (* ==> cVar is an uplevel local var. *)
3671 indr : BOOLEAN; (* ==> cVar is indirectly accessed *)
3672 exLb : Mu.Label;
3673 lpLb : Mu.Label;
3674 BEGIN
3675 (*
3676 * This is the common case, so we work a bit harder.
3677 *)
3678 out := e.outF;
3679 lpLb := out.newLabel();
3680 exLb := out.newLabel();
3681 cVar := stat.cVar(Id.AbVar);
3682 step := intValue(stat.byXp);
3683 smpl := stat.isSimple();
3684 isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
3685 isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
3686 indr := isRP OR isUl;
3687
3688 IF indr THEN
3689 tmpV := out.proc.newLocal(Bi.intTp);
3690 ELSE
3691 tmpV := -1; (* keep the verifier happy! *)
3692 END;
3693 IF ~smpl THEN
3694 topV := out.proc.newLocal(Bi.intTp);
3695 ELSE
3696 topV := -1; (* keep the verifier happy! *)
3697 END;
3698
3699 IF smpl THEN
3700 IF isRP THEN
3701 out.PushArg(cVar.varOrd);
3702 ELSIF isUl THEN
3703 out.XhrHandle(cVar(Id.LocId));
3704 END;
3705 out.PushInt(intValue(stat.loXp));
3706 out.PutVar(cVar);
3707 ELSE
3708 e.PushValue(stat.hiXp, Bi.intTp);
3709 out.Code(Asm.opc_dup);
3710 out.StoreLocal(topV);
3711 IF isRP THEN
3712 out.PushArg(cVar.varOrd);
3713 ELSIF isUl THEN
3714 out.XhrHandle(cVar(Id.LocId));
3715 END;
3716 e.PushValue(stat.loXp, Bi.intTp);
3717 out.Code(Asm.opc_dup);
3718 IF indr THEN out.StoreLocal(tmpV) END;
3719 out.PutVar(cVar);
3720 IF indr THEN out.PushLocal(tmpV) END;
3721 (*
3722 * The top test is NEVER inside the loop.
3723 *)
3724 e.DoCmp(Xp.lessT, exLb, Bi.intTp);
3725 END;
3726 out.DefLabC(lpLb, "Loop header");
3727 (*
3728 * Emit the code body.
3729 *)
3730 e.EmitStat(stat.body, ok);
3731 (*
3732 * If the body returns ... do an exit test.
3733 *)
3734 IF ok THEN
3735 IF smpl THEN
3736 out.PushInt(intValue(stat.hiXp));
3737 ELSE
3738 out.PushLocal(topV);
3739 END;
3740 IF isRP THEN
3741 out.PushArg(cVar.varOrd);
3742 ELSIF isUl THEN
3743 out.XhrHandle(cVar(Id.LocId));
3744 END;
3745 out.GetVar(cVar); (* (top) cv,hi *)
3746 out.PushInt(step);
3747 out.Code(Asm.opc_add_ovf); (* (top) cv',hi *)
3748 out.Code(Asm.opc_dup); (* (top) cv',cv',hi *)
3749 IF indr THEN out.StoreLocal(tmpV) END;
3750 out.PutVar(cVar); (* (top) cv',hi *)
3751 IF indr THEN out.PushLocal(tmpV) END;
3752 e.DoCmp(Xp.greEq, lpLb, Bi.intTp);
3753 END;
3754 IF indr THEN out.proc.ReleaseLocal(tmpV) END;
3755 IF ~smpl THEN out.proc.ReleaseLocal(topV) END;
3756 (*
3757 * The exit label.
3758 *)
3759 out.DefLabC(exLb, "Loop trailer");
3760 END IntForUp;
3761
3762 (* ----------------------------------------- *)
3763
3764 PROCEDURE IntForDn(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
3765 VAR out : Mu.MsilFile;
3766 cVar : Id.AbVar;
3767 tmpV : INTEGER;
3768 topV : INTEGER;
3769 step : INTEGER;
3770 smpl : BOOLEAN;
3771 isRP : BOOLEAN; (* ==> cVar is a reference parameter *)
3772 isUl : BOOLEAN; (* ==> cVar is an uplevel local var. *)
3773 indr : BOOLEAN; (* ==> cVar is indirectly accessed *)
3774 exLb : Mu.Label;
3775 lpLb : Mu.Label;
3776 BEGIN
3777 out := e.outF;
3778 lpLb := out.newLabel();
3779 exLb := out.newLabel();
3780 cVar := stat.cVar(Id.AbVar);
3781 step := intValue(stat.byXp);
3782 smpl := stat.isSimple();
3783 isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
3784 isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
3785 indr := isRP OR isUl;
3786
3787 IF indr THEN
3788 tmpV := out.proc.newLocal(Bi.intTp);
3789 ELSE
3790 tmpV := -1; (* keep the verifier happy! *)
3791 END;
3792 IF ~smpl THEN
3793 topV := out.proc.newLocal(Bi.intTp);
3794 ELSE
3795 topV := -1; (* keep the verifier happy! *)
3796 END;
3797
3798 IF smpl THEN
3799 IF isRP THEN
3800 out.PushArg(cVar.varOrd);
3801 ELSIF isUl THEN
3802 out.XhrHandle(cVar(Id.LocId));
3803 END;
3804 out.PushInt(intValue(stat.loXp));
3805 out.PutVar(cVar);
3806 ELSE
3807 e.PushValue(stat.hiXp, Bi.intTp);
3808 out.Code(Asm.opc_dup);
3809 out.StoreLocal(topV);
3810 IF isRP THEN
3811 out.PushArg(cVar.varOrd);
3812 ELSIF isUl THEN
3813 out.XhrHandle(cVar(Id.LocId));
3814 END;
3815 e.PushValue(stat.loXp, Bi.intTp);
3816 out.Code(Asm.opc_dup);
3817 IF indr THEN out.StoreLocal(tmpV) END;
3818 out.PutVar(cVar);
3819 IF indr THEN out.PushLocal(tmpV) END;
3820 (*
3821 * The top test is NEVER inside the loop.
3822 *)
3823 e.DoCmp(Xp.greT, exLb, Bi.intTp);
3824 END;
3825 out.DefLabC(lpLb, "Loop header");
3826 (*
3827 * Emit the code body.
3828 *)
3829 e.EmitStat(stat.body, ok);
3830 (*
3831 * If the body returns ... do an exit test.
3832 *)
3833 IF ok THEN
3834 IF smpl THEN
3835 out.PushInt(intValue(stat.hiXp));
3836 ELSE
3837 out.PushLocal(topV);
3838 END;
3839 IF isRP THEN
3840 out.PushArg(cVar.varOrd);
3841 ELSIF isUl THEN
3842 out.XhrHandle(cVar(Id.LocId));
3843 END;
3844 out.GetVar(cVar); (* (top) cv,hi *)
3845 out.PushInt(step);
3846 out.Code(Asm.opc_add_ovf); (* (top) cv',hi *)
3847 out.Code(Asm.opc_dup); (* (top) cv',cv',hi *)
3848 IF indr THEN out.StoreLocal(tmpV) END;
3849 out.PutVar(cVar); (* (top) cv',hi *)
3850 IF indr THEN out.PushLocal(tmpV) END;
3851 e.DoCmp(Xp.lessEq, lpLb, Bi.intTp);
3852 END;
3853 IF indr THEN out.proc.ReleaseLocal(tmpV) END;
3854 IF ~smpl THEN out.proc.ReleaseLocal(topV) END;
3855 (*
3856 * The exit label.
3857 *)
3858 out.DefLabC(exLb, "Loop trailer");
3859 END IntForDn;
3860
3861 (* ----------------------------------------- *)
3862 BEGIN (* body of EmitFor *)
3863 IF stat.cVar.type.isLongType() THEN
3864 IF longValue(stat.byXp) > 0 THEN LongForUp(e, stat, ok);
3865 ELSE LongForDn(e, stat, ok);
3866 END;
3867 ELSE
3868 IF longValue(stat.byXp) > 0 THEN IntForUp(e, stat, ok);
3869 ELSE IntForDn(e, stat, ok);
3870 END;
3871 END;
3872 END EmitFor;
3873
3874 (* ---------------------------------------------------- *)
3875
3876 PROCEDURE (e : MsilEmitter)
3877 EmitLoop(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
3878 VAR out : Mu.MsilFile;
3879 lpLb : Mu.Label;
3880 exLb : Mu.Label;
3881 BEGIN
3882 out := e.outF;
3883 lpLb := out.newLabel();
3884 exLb := out.newLabel();
3885 stat.tgLbl := exLb;
3886 out.DefLabC(lpLb, "Loop header");
3887 e.EmitStat(stat.body, ok);
3888 IF ok THEN out.CodeLb(Asm.opc_br, lpLb) END;
3889 out.DefLabC(exLb, "Loop exit");
3890 END EmitLoop;
3891
3892 (* ---------------------------------------------------- *)
3893
3894 PROCEDURE (e : MsilEmitter)
3895 EmitWith(stat : St.Choice; OUT ok : BOOLEAN),NEW;
3896 VAR out : Mu.MsilFile;
3897 high : INTEGER; (* Branch count. *)
3898 indx : INTEGER;
3899 live : BOOLEAN;
3900 then : Sy.Stmt;
3901 pred : Xp.BinaryX;
3902 tVar : Id.LocId;
3903 exLb : Mu.Label; (* Exit label *)
3904 nxtP : Mu.Label; (* Next predicate *)
3905 (* --------------------------- *)
3906 PROCEDURE WithTest(je : MsilEmitter;
3907 os : Mu.MsilFile;
3908 pr : Xp.BinaryX;
3909 nx : Mu.Label;
3910 to : INTEGER);
3911 VAR ty : Sy.Type;
3912 BEGIN
3913 ty := pr.rKid(Xp.IdLeaf).ident.type;
3914 je.PushValue(pr.lKid, pr.lKid.type);
3915 os.CodeT(Asm.opc_isinst, ty);
3916 (*
3917 * isinst returns the cast type, or NIL
3918 * We save this to the allocated temp or needed type.
3919 *)
3920 os.StoreLocal(to);
3921 os.PushLocal(to);
3922 os.CodeLb(Asm.opc_brfalse, nx); (* branch on NIL *)
3923 END WithTest;
3924 (* --------------------------- *)
3925 BEGIN
3926 tVar := NIL;
3927 pred := NIL;
3928 ok := FALSE;
3929 out := e.outF;
3930 exLb := out.newLabel();
3931 high := stat.preds.tide - 1;
3932 IF CSt.debug THEN out.Code(Asm.opc_nop) END;
3933 FOR indx := 0 TO high DO
3934 live := TRUE;
3935 then := stat.blocks.a[indx];
3936 pred := stat.preds.a[indx](Xp.BinaryX);
3937 tVar := stat.temps.a[indx](Id.LocId);
3938 nxtP := out.newLabel();
3939 IF pred # NIL THEN
3940 tVar.varOrd := out.proc.newLocal(tVar.type);
3941 WithTest(e, out, pred, nxtP, tVar.varOrd);
3942 END;
3943 IF then # NIL THEN e.EmitStat(then, live) END;
3944 IF live THEN
3945 ok := TRUE;
3946 (*
3947 * If this is not the else case, skip over the
3948 * later cases, or jump over the WITH ELSE trap.
3949 *)
3950 IF pred # NIL THEN out.CodeLb(Asm.opc_br, exLb) END;
3951 END;
3952 out.DefLab(nxtP);
3953 IF tVar # NIL THEN out.proc.ReleaseLocal(tVar.varOrd) END;
3954 END;
3955 IF pred # NIL THEN out.WithTrap(pred(Xp.BinaryX).lKid(Xp.IdLeaf).ident) END;
3956 out.DefLab(exLb);
3957 END EmitWith;
3958
3959 (* ---------------------------------------------------- *)
3960
3961 PROCEDURE (e : MsilEmitter)EmitExit(stat : St.ExitSt),NEW;
3962 BEGIN
3963 e.outF.CodeLb(Asm.opc_br, stat.loop(St.TestLoop).tgLbl(Mu.Label));
3964 END EmitExit;
3965
3966 (* ---------------------------------------------------- *)
3967
3968 PROCEDURE (e : MsilEmitter)EmitReturn(stat : St.Return),NEW;
3969 VAR out : Mu.MsilFile;
3970 ret : Sy.Expr;
3971 BEGIN
3972 out := e.outF;
3973 IF CSt.debug THEN
3974 out.Code(Asm.opc_nop);
3975 out.LineSpan(stat.prId(Id.Procs).endSpan);
3976 END;
3977 ret := stat.retX;
3978 IF (stat.retX # NIL) &
3979 (out.proc.prId.kind # Id.ctorP) THEN e.PushValue(ret, ret.type) END;
3980 out.DoReturn;
3981 END EmitReturn;
3982
3983 (* ---------------------------------------------------- *)
3984
3985 PROCEDURE (e : MsilEmitter)
3986 EmitBlock(stat : St.Block; OUT ok : BOOLEAN),NEW;
3987 VAR index, limit : INTEGER;
3988 BEGIN
3989 ok := TRUE;
3990 index := 0;
3991 limit := stat.sequ.tide;
3992 WHILE ok & (index < limit) DO
3993 e.EmitStat(stat.sequ.a[index], ok);
3994 INC(index);
3995 END;
3996 END EmitBlock;
3997
3998 (* ---------------------------------------------------- *)
3999 (* ---------------------------------------------------- *)
4000
4001 PROCEDURE (e : MsilEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
4002 VAR depth : INTEGER;
4003 out : Mu.MsilFile;
4004 BEGIN
4005 IF (stat = NIL) OR (stat.kind = St.emptyS) THEN ok := TRUE; RETURN END;
4006 out := e.outF;
4007 out.LineSpan(stat.Span());
4008 depth := out.proc.getDepth();
4009 CASE stat.kind OF
4010 | St.assignS : e.EmitAssign(stat(St.Assign)); ok := TRUE;
4011 | St.procCall : e.EmitCall(stat(St.ProcCall)); ok := TRUE;
4012 | St.ifStat : e.EmitIf(stat(St.Choice), ok);
4013 | St.caseS : e.EmitCase(stat(St.CaseSt), ok);
4014 | St.whileS : e.EmitWhile(stat(St.TestLoop), ok);
4015 | St.repeatS : e.EmitRepeat(stat(St.TestLoop), ok);
4016 | St.forStat : e.EmitFor(stat(St.ForLoop), ok);
4017 | St.loopS : e.EmitLoop(stat(St.TestLoop), ok);
4018 | St.withS : e.EmitWith(stat(St.Choice), ok);
4019 | St.exitS : e.EmitExit(stat(St.ExitSt)); ok := TRUE;
4020 | St.returnS : e.EmitReturn(stat(St.Return)); ok := FALSE;
4021 | St.blockS : e.EmitBlock(stat(St.Block), ok);
4022 END;
4023 IF CSt.verbose & (depth # out.proc.getDepth()) THEN
4024 out.Comment("Depth adjustment") END;
4025 out.proc.SetDepth(depth);
4026 END EmitStat;
4027
4028 (* ============================================================ *)
4029 (* ============================================================ *)
4030 END MsilMaker.
4031 (* ============================================================ *)
4032 (* ============================================================ *)
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024