SECTION "CGB"

GET "b.CGheader"

STATIC {
/* Version of 07 Feb 86 11:03:42
 */
   dummy = VersionMark;
   version = 1*256+7 };

// 1.5	05 Nov 85 10:02:04
//   Temporary removal of 'no RL' optimisation if just no static use
// 1.6	23 Jan 86 11:49:14
//   Optimisation which used to say "If a call is of a local procedure
//   which uses no frame, no need to set up RTS" to add "and contains no
//   calls" (exit calls do not need a frame, but the called procedure may
//   use one).
// 1.7	07 Feb 86 11:03:01
//   Improvement of algorithm for discard of pending stores to stack frame
//   on exit call.

STATIC { swr=0; swd=0; casek=0; casel=0 };

LET CGSwitch(n) BE {
   LET a = GetVec(2*n);
   LET b = a+n;
   swd := ReadL();

   casek, casel := a, b;

   FOR i = 1 TO n DO
   {  LET a = ReadN();
      LET l = ReadL();
      LET j = i-1;

      WHILE j~=0 DO
      {  IF a>casek!j THEN BREAK;
	 casek!(j+1) := casek!j;
	 casel!(j+1) := casel!j;
	 j := j-1 };

      casek!(j+1), casel!(j+1) := a, l };

   Store(0, ssp-2);
   swr := MoveToAnyR(arg1);
   InitStack(ssp-1);

   // care with overflow!!
   TEST 0<=16+casek!n-casek!1<5*n THEN
      LabVecSwitch(1, n)
   ELSE {
      BinTreeSwitch(1, n);
      Jump(swd) };

   DeadCode := Dead }

AND LabVecSwitch(p, q) BE {
   LET min, max = casek!p, casek!q;

   IF min=1 THEN min := 0;
   IF min~=0 THEN DiscardReg(swr, k.reg);

   GenF1K(f.subs, swr, swr, min);
   CondJump(m.lt, swd);
   GenF1K(f.cmps, 0, swr, max-min);
   CondJump(m.gt, swd);

   FlushPendingInsts(Null, FALSE);
   F2Inst(f.ldr, r.pc, r.pc, 0, swr, f.preup, sh.asl, 2, m.always);
   PutWord(0);

   FOR k = min TO max DO {
      LET lab = ?;
      TEST casek!p=k THEN {
	 lab := casel!p;
	 SaveStateForLab(lab);
	 p := p+1 }
      ELSE
	 lab := swd;
      lab := TransferredLabel(lab);
      IF lab=0 THEN lab := exitLab;
      AddRelocatedLoc(locCtr, lab);
      AddressInCode(lab, 0) } }

AND BinTreeSwitch(p, q) BE
   TEST q-p>6 THEN {
      LET m = NextLabel();
      LET t = (p+q)/2;

      CaseCompare(t);
      CondJump(m.gt, m);
      CondJump(m.eq, casel!t);
      BinTreeSwitch(p, t-1);

      CondJump(m.always, swd);
      FlushPendingInsts(Null, FALSE);

      SetLabel(m);
      BinTreeSwitch(t+1, q) }

   ELSE FOR i = p TO q DO {
      CaseCompare(i);
      CondJump(m.eq, casel!i) }

AND CaseCompare(i) BE {
   LET n = casek!i;
   TEST n<0
      THEN GenF1K(f.cmns, 0, swr, -n)
      ELSE GenF1K(f.cmps, 0, swr, n) }

AND CGEntry(n, m) BE {
   LET p = 0;
   {  LET w = VEC 256/BytesPerWord;
      LET v = VEC 1;
      LET k = sectionName%0;
      FOR i = 1 TO k DO w%i := sectionName%i;
      k := k+1;
      w%k := '.';
      FOR i = 1 TO n DO
      {  LET c = ReadN();
	 w%(i+k) := c;
	 IF i<=7 THEN v%i := c };
      w%0 := n+k;
      FOR i = n+1 TO 7 DO v%i := '*s';
      v%0 := 7;

      AddressInCode(staticDataLab, 0);
      IF procNames THEN {
	 TEST naming THEN {
	    p := procLabel;
	    procLabel := NextLabel();
	    AddressInCode(procLabel, locCtr) }
	 ELSE
	    PutWord(-1);

	 PutWord(v!0);
	 PutWord(v!1) };

      AddXSymbol(w, 1, m);

      base!0, base!1 := baseLab, baseAddr;
      {  LET f = 0;
	 IF localsSafe THEN f := f+1;
	 IF usesFrame THEN f := f+2;
	 IF containsCalls THEN f := f+4;
	 IF usesRL THEN f := f+8;
	 IF linkageNotStored THEN
	    TEST linkageNotStored=r.b THEN
	       f := f+16
	    ELSE
	       f := f+32;
	 base!2 := f };
      base := base+3;
      baseLab, baseAddr := m, locCtr;
      localsSafe := ~LabelFlagged(m, lab.lvptaken);
      usesFrame := LabelFlagged(m, lab.frameneeded);
      containsCalls := LabelFlagged(m, lab.prochascalls);
      usesRL := usesFrame | LabelFlagged(m, lab.procstatics);
      IF CGDebugMode~=0 THEN {
	 WriteF("****** %s", v);
	 IF ~usesFrame THEN WriteS(" - no frame");
	 IF ~containsCalls THEN WriteS(" - no calls");
	 IF localsSafe THEN WriteS(" - locals safe");
	 WriteS(" *******n") };
      SetLabel(m) };

   DiscardRegs();
   deadCode := Alive;
   IF naming THEN
   {  LET n, b = namel, blockLabel;
      namel, blockLabel := namet, -1;
      op := ReadOp();
      Scan()
      namet := namel;
      namel, blockLabel, procLabel := n, b, p } }

AND CGSave(n) BE {
   LET a = 1+n-saveSpaceSize-1;
   LET regset = 0;
   IF a>4 THEN a, usesFrame := 4, TRUE;
   linkageNotStored := FALSE;

   TEST counting | callCounting THEN {
      usesFrame := TRUE;
      InsertCount(sr.entrycount) }
   ELSE IF usesFrame THEN {
      LET r = reversedStack -> (TABLE r.14, r.l, r.p, r.b),
	    saveSpaceSize=4 -> (TABLE r.b, r.p, r.l, r.14),
			       (TABLE r.p, r.l, r.14);
      linkageNotStored := TRUE;
      IF saveSpaceSize=4 THEN {
	    // The only point in saving RB at all is to allow
	    // diagnostic programs easily to see to whom stack
	    // frames belong.  If, therefore, it looks as though
	    // a procedure will be called by direct BL, we must
	    // take steps to ensure that the stored RB is right.

	 LET p = Assoc(baseLab, 2, staticLabels);
	 IF p~=Null & LabelFlagged(p!1, lab.called) THEN
	    linkageNotStored := r.b };

      FOR i = 0 TO saveSpaceSize-1 DO
	 AddToPendingStores(r!i, k.loc, i, TRUE, 0) };

   TOSOffset := saveSpaceSize;
   InitStack(n)
   TEST ~usesFrame & ~containsCalls & a<=3 THEN
      FOR r = 1 TO 3 DO {
	 LET n = TOSOffset+r-1;
	 LET s = ArgumentRegister(r);
	 DedicateRegisterToLoc(s, n);
	 IF r<=a THEN MoveSToR(k.reg, s, k.loc, n) }
   ELSE
      FOR r = 1 TO a DO {
	 LET s = ArgumentRegister(r);
	 MoveStoR(k.reg, s, k.loc, TOSOffset)
	 AddToPendingStores(s, k.loc, TOSOffset, TRUE, 0);
	 TOSoffset := TOSOffset+1 } }

AND CheckRLLoaded() = VALOF
   TEST ~usesRL THEN
      RESULTIS r.pc
   ELSE {
      IF linkageNotStored THEN FlushPendingUsesOfReg(r.l);
      IF linkageNotStored THEN {
	 RLLoadList := FillBlk(2, RLLoadList, locCtr);
	 GenF2(f.ldr, r.0, r.pc, 0,
	       ValueOfLabel(baseLab)-12-locCtr-(procNames->12,0));
	 RESULTIS r.0 };
      RESULTIS r.l }

AND CGApply(callType, k) BE TEST XSymInStatic(arg1)~=Null THEN
   CGApplyX(callType, k)
ELSE {
   LET argbase = k+saveSpaceSize;
   LET tempbase = h5!tempv-argbase;
   LET rmin, rmax = 1+tempbase, 1+h5!arg2-argbase;
   LET argmax = rmax;
   LET exitCall = FALSE;
   LET stackAtEnd = k;
   LET procLab = Null;

   IF rmin<1 THEN rmin := 1;
   IF rmax>4 THEN rmax := 4;

   op := ReadOp();
   WHILE op=s.stack DO {
      stackAtEnd := ReadN();
      op := ReadOp() };


   IF rmax=argmax &
   // you can't have exit calls with more arguments than are passed
   // in registers (or rather you can, but they're tricky to handle)
      localsSafe THEN
   // If an argument may be a pointer into this procedure's frame,
   // we'd better not compile an exit call (which would throw away
   // the frame)
      TEST op=s.fnrn | op=s.rtrn THEN {
	 op := ReadOp();
	 exitCall := TRUE }

      ELSE IF (op=s.res | op=s.jump | op=s.lab) &
	      TransferredLabel(PeekN())=0 THEN {
	 ReadN(); op := ReadOp();
	 exitCall := TRUE };

   FOR r = rmin TO rmax DO
      IF Using(r) THEN Lock(ArgumentRegister(r), k.reg);

   IF argmax>5 THEN {
      LET n = k+4+saveSpaceSize;
      FlushPendingStores();
      SetRtoRplusK(r.ts, r.p, nextStackWord*n);
      TOSOffset := n };

   Store(argbase+4, ssp-2);
   FOR t = tempv TO arg2 BY sssize DO {
      LET s = h5!t;
      IF s>k THEN BREAK;
      IF h1!t=k.reg THEN StoreT(t) };

   FOR r = rmin TO rmax DO
      Lock(ArgumentRegister(r), k.reg);

   IF h1!arg1=k.reg & h3!arg1<=rmax THEN {
      MoveToR(r.w1, arg1);
      Lock(r.w1, k.reg) };

   IF exitCall THEN {
   /* Construct a list of the frame values which are needed
      in loading values of arguments.  Pending stores to other
      locations in the frame may then be discarded
    */
      LET p = 0;
      FOR r = 1 TO rmax DO {
	 LET l = argbase+r-1;
	 TEST l<(argbase+tempbase) THEN
	    p := FillBlk(2, p, l)
	 ELSE {
	    l := tempv+sssize*(l-tempbase-argbase);
	    IF h1!l=k.loc THEN {
	       LET s = LookFor(l, NotAddr);
	       IF s=Null | s>r
		  THEN p := FillBlk(2, p, h3!l) } } };

      IF linkageNotStored THEN
	 FOR i = 0 TO saveSpaceSize-1 DO
	    p := FillBlk(2, p, i);

      DelLocsExcept(p);
      WHILE p~=0 DO {
	 LET q = !p;
	 FreeBlk(p, 2);
	 p := q } }

   loadRegFromFRegOK := TRUE;
   FOR t = arg2 TO tempv BY -sssize DO {
      LET r = r.a1+h5!t-argbase;
      IF r<rmin THEN BREAK;
      TEST r<=rmax THEN {
	 LET n = ArgumentRegister(r);
	 MoveToRSomeTime(n, t) }
      ELSE
	 StoreT(t) };
   loadRegFromFRegOK := FALSE;

   FlushPendingLoads();
   IF exitCall THEN DelLocsAbove(0, TRUE);
   FlushPendingStores();

   procLab := LabelInStatic(arg1);

   TEST exitCall
      THEN TOSOffset := -1
      ELSE IF k~=TOSOffset &
	      (procLab=Null |
	       LabelFlagged(procLab, lab.frameneeded) |
	       LabelFlagged(procLab, lab.prochascalls)) THEN {
	 SetRtoRplusK(r.ts, r.p, nextStackWord*k);
	 TOSOffset := k };

   IF tempbase>0 THEN {
      LET r = 1+tempbase-1;
      LET offset = nextStackWord*(k+saveSpaceSize);
      IF r>4 THEN r := 4;
      TEST r=1 THEN
	 GenF2(f.ldr, ArgumentRegister(1), r.p, 0, offset)
      ELSE {
	 LET regset = 0;
	 SetRtoRplusK(r.0, r.p, offset);
	 FOR s = 1 TO r DO
	    regset := regset+(1<<ArgumentRegister(s));
	 F4Inst(f.ldm, r.0, regset, upStack) } };

   TEST procLab~=Null THEN
      TEST exitCall THEN {
	 IF usesFrame & ~linkageNotStored THEN {
	    LET ldmType = reversedStack | saveSpaceSize=3 -> upStack,
							     upStack+f.pre;
	    GenRR(f.mov, r.ts, 0, r.p);
	    F4Inst(f.ldm, r.p, f4.pl14, ldmType) };
	 Jump(procLab) }
      ELSE
	 F5InstL(m.always, procLab, f.bl)


   ELSE TEST ~usesFrame | linkageNotStored THEN
      TEST rbInCalls THEN {  // must be an exit call.
	 MoveToR(r.b, arg1);
	 GenRR(f.mov, r.pc, r.pc, r.b)
	 // The second r.pc distinguishes this as an
	 // exit call.
      }
      ELSE
	 MoveToR(r.pc, arg1)

   ELSE TEST compactCode THEN
      TEST exitCall THEN {
	 MoveToR(r.b, arg1);
	 CondJump(m.always, exitCallLab) }
      ELSE {
	 MoveToR(r.b, arg1);
	 F5InstL(m.always, CallLab, f.bl) }

   ELSE TEST exitCall THEN {
      LET ldmtype = reversedStack | saveSpaceSize=3 -> upStack,
						       upStack+f.pre;
      LET directCall = TRUE;
      IF rbInCalls |
	 (h1!arg1~=k.reg & h1!arg1~=k.glob) THEN {
	 MoveToR(r.b, arg1);
	 directCall := FALSE };

      GenRR(f.mov, r.ts, 0, r.p);
      F4Inst(f.ldm, r.p, f4.pl14, ldmType);
      TEST directCall
	 THEN MoveToR(r.pc, arg1)
	 ELSE GenRR(f.mov, r.pc, r.pc, r.b) }

   ELSE {
      LET directCall = TRUE;
      IF rbInCalls |
	 (h2!arg1>=0 | h4!arg1~=0) THEN {
	 MoveToR(r.b, arg1);
	 directCall := FALSE };
      GenRR(f.mov, r.14, 0, r.pc)
      TEST directCall
	 THEN MoveToR(r.pc, arg1)
	 ELSE GenRR(f.mov, r.pc, 0, r.b) };

   DiscardRegs();
   TEST exitCall THEN {
      InitStack(stackAtEnd);
      deadCode := Dead }
   ELSE {
      Stack(k);
      IF callType=s.fnap THEN Load(k.reg, ArgumentRegister(1));
      IF stackAtEnd~=k THEN Stack(stackAtEnd) } }

AND CGApplyX(callType, k) BE {
   LET argbase = k+saveSpaceSize;
   LET tempbase = h5!tempv-argbase;
   LET rmin, rmax = 1+tempbase, 1+h5!arg2-argbase;
   LET argmax = rmax;
   LET stackAtEnd = k;
   LET procLab = Null;
   LET xsym = XSymInStatic(arg1);
   LET bcplContext = 0;

   IF rmin<1 THEN rmin := 1;
   IF rmax>4 THEN rmax := 4;

   op := ReadOp();
   WHILE op=s.stack DO {
      stackAtEnd := ReadN();
      op := ReadOp() };

   FOR r = rmin TO rmax DO
      IF Using(r-1) THEN Lock(r-1, k.reg);

   IF argmax>5 THEN {
      LET n = k+4+saveSpaceSize;
      FlushPendingStores();
      SetRtoRplusK(r.ts, r.p, nextStackWord*n);
      TOSOffset := n };

   Store(argbase+4, ssp-2);
   FOR t = tempv TO arg2 BY sssize DO {
      LET s = h5!t;
      IF s>k THEN BREAK;
      IF h1!t=k.reg THEN StoreT(t) };

   FOR r = rmin TO rmax DO
      Lock(r-1, k.reg);

   loadRegFromFRegOK := TRUE;
   FOR t = arg2 TO tempv BY -sssize DO {
      LET r = r.a1+h5!t-argbase;
      IF r<rmin THEN BREAK;
      TEST r<=rmax THEN {
	 LET n = r-1;
	 MoveToRSomeTime(n, t) }
      ELSE
	 StoreT(t) };
   loadRegFromFRegOK := FALSE;

   FlushPendingLoads();
   FlushPendingStores();

   IF k~=TOSOffset THEN {
     SetRtoRplusK(r.ts, r.p, nextStackWord*k);
     TOSOffset := k };

   IF tempbase>0 THEN {
      LET r = 1+tempbase-1;
      LET offset = nextStackWord*(k+saveSpaceSize);
      IF r>4 THEN r := 4;
      TEST r=1 THEN
	 GenF2(f.ldr, r.0, r.p, 0, offset)
      ELSE {
	 LET regset = 0;
	 SetRtoRplusK(r.0, r.p, offset);
	 FOR s = 1 TO r DO
	    regset := regset+(1<<(s-1));
	 F4Inst(f.ldm, r.0, regset, upStack) } };

// The arguments are in the right registers; it remains to
//     save the BCPL context
//     restore the "Modula" context
//     copy over arguments above 4

// There's guaranteed space to store the BCPL context, where the called
// procedure would save its linkage if it were a BCPL one.  There only
// could be any problem if the procedure has more than four arguments.
// It's a bit silly doing the save in store if there's only one register
// that's important
   {  LET stmType = reversedStack -> f.postdown, f.postup;
      bcplContext := (1<<r.p)+(1<<r.nil);
      IF usesRl THEN bcplContext := bcplContext+(1<<r.l);
      IF linkageNotStored THEN bcplContext := bcplContext|((1<<r.l)+(1<<r.14));
      F4Inst(f.stm, r.ts, bcplContext, stmType);
      GenRR(f.mov, 4, 0, r.ts) }

   GenF1K(f.sub, 5, r.g, 80);
   F4Inst(f.ldm, 5, (1<<10)+(1<<12)+(1<<13), f.postup);

   // Copy over arguments.  We don't need to worry about the linkageNotStored
   // case: it can't happen if we need to copy.
   // Falling stacks not supported !!!!!
   TEST argmax=5 THEN {
      GenF2(f.ldr, 5, r.ts, 0, nextStackWord*(saveSpaceSize+4));
      F4Inst(f.stm, 12, 1<<5, f.predown+f.wb) }
   ELSE IF argmax>5 THEN {
      LET n = argmax-4;
      SetRToRPlusK(r.ts, r.ts, nextStackWord*(saveSpaceSize+argMax));
      WHILE n>0 DO {
	 LET regSet = n=1 -> (1<<5),
		      n=2 -> (1<<5)+(1<<8),
			     (1<<5)+(1<<8)+(1<<14);
	 F4Inst(f.ldm, r.ts, regSet, f.predown);
	 F4Inst(f.stm, 12, regSet, f.predown+f.wb);
	 n := n-3 } };

   F5InstX(f.bl, AddXSymbol(xsym, 0, 0), m.always);
   IF callType=s.fnap THEN GenRR(f.mov, ArgumentRegister(1), 0, r.0);
   {  LET ldmType = reversedStack -> f.postdown, f.postup;
      F4Inst(f.ldm, 4, bcplContext, ldmType) }

   DiscardRegs();
   Stack(k);
   IF callType=s.fnap THEN Load(k.reg, ArgumentRegister(1));
   IF stackAtEnd~=k THEN Stack(stackAtEnd);
   tosOffset := Null }

