SECTION "CGJ"

GET "b.CGheader"

STATIC {
   // Version of 14 Apr 86 14:02:05
   dummy = VersionMark;
   version = 1*256+6 };

/* 1.4	06 Feb 86 23:20:53
      Bug fix: selective deletion of pending stores marked as to TOS
      should cause all later ones to lose such marking (also, the
      current belief about the TOS to be revised).  Is this right yet?
    1.5  07 Mar 86 21:40:02
      k.static
    1.6  14 Apr 86 14:00:45
      FlushPendingLoadsFor{Store,SLoc} need only flush loads related to
      the one concerned (not all up to it)
*/

LET ReverseInPlace(p) = VALOF
{  LET q = 0;
   IF p=0 THEN RESULTIS p;
   {  LET r = !p;
      !p := q
      IF r=0 THEN RESULTIS p;
      q := p; p := r
   } REPEAT
}

AND LastInList(l) = VALOF
{  LET last = 0;
   WHILE l~=0 DO {
      last := l;
      l := !l };
   RESULTIS last
}

AND DeleteFromList(p, x, n) = VALOF
{  LET CopyOfP = p;
   LET q = @CopyOfP;
   WHILE p~=x & p~=0 DO {  q := p; p := !p };

   IF p~=0 THEN !q := FreeBlk(p, n);
   RESULTIS CopyOfP
}

AND DeleteList(p, n) BE
   WHILE p~=0 DO
      p := FreeBlk(p, n)

AND CopyOfList(p, n) = VALOF
{  LET q = 0;
   WHILE p~=0 & p~=Null DO {
      LET r = GetBlk(n);
      !r := q; q := r;
      FOR i  = 1 TO n-1 DO i!r := i!p;
      p := !p };
   RESULTIS q
}

AND LengthOfList(l) = VALOF
{  LET len = 0;
   WHILE l~=0 DO {  l := !l; len := len+1 };
   RESULTIS len
}

AND Assoc(x, n, p) = VALOF
{  WHILE p~=0 DO {
      IF n!p=x THEN RESULTIS p;
      p := !p };
   RESULTIS Null
}

AND Nth(n, p) = VALOF
{  FOR i = 1 TO n DO {
      IF p=0 THEN RESULTIS Null;
      p := !p };
   RESULTIS p
}

AND InsertInListBefore(p, x, el) = VALOF
{  LET copyOfP = p;
   LET pp = @copyOfP;
   WHILE p~=0 DO {
      IF p=el THEN BREAK;
      pp := p;
      p := !p };
   !pp := x;
   !x := p;
   RESULTIS copyOfP
}


AND PrintList(p, n, s1, s2, s3) BE
{  WriteS(s1);
   WHILE p~=0 DO {
      WriteS(s2);
      FOR i = 1 TO n DO {
	 LET x = i!p;
	 LET t = x&#xfff00000;
	 Wrch(' ');
	 TEST t=0 | t=#xfff00000 THEN
	    WriteN(x)
	 ELSE
	    WriteHex(x, 8) };
      p := !p };
   WriteS(s3)
}

MANIFEST {
   dr.Reg = 1; dr.Loc = 2;
   dr.size = 3 };

LET TraceIt(s, a, b, c, d) BE
{  IF (CGDebugMode&db.traceps)~=0 THEN {
      FOR i = 0 TO ps.tracedepth-1 DO WrCh('*s');
      WriteF(s, a, b, c, d) };
   ps.tracedepth := ps.tracedepth+2 }

AND ExitTrace(s) BE
{  IF s~=0 & (CGDebugMode&db.traceps)~=0 THEN {
      FOR i = 0 TO ps.tracedepth-1 DO WrCh('*s');
      WriteS(s) };
   ps.tracedepth := ps.tracedepth-2 }

LET ClearAssignedRegisters() BE
{  LET p = dedicatedRegisters;
   dedicatedRegisters := 0;

   WHILE p~=0 DO {
      LET r = dr.Reg!p;
      LET q = !p;
      DiscardReg(r, k.reg);
      FreeBlk(p, dr.Size);
      p := q }
}

AND DedicateRegisterToLoc(r, n) BE
{  dedicatedRegisters := FillBlk(dr.Size, dedicatedRegisters, r, n);
   Lock(r, k.reg)
}

AND RegisterDedicatedToLoc(n) = VALOF
{  LET p = Assoc(n, dr.Loc, dedicatedRegisters);
   TEST p=Null THEN
      RESULTIS p
   ELSE
      RESULTIS dr.Reg!p
}

AND LocHeldInRegister(r) = VALOF
{  LET p = Assoc(r, dr.Reg, dedicatedRegisters);
   TEST p=Null THEN
      RESULTIS p
   ELSE
      RESULTIS dr.Loc!p
}

AND AddToPendingStores(r, t, n, istos, offset) BE
{  TraceIt("AddToPS %n %n %n %n*n", r, t, n, offset);

   IF t=k.ireg THEN
   {  FlushPendingStoresForIregExcept(n, offset)
      FlushPendingLoadsForIreg() };

   pendingStores := FillBlk(ps.size, pendingStores, t, n, r, offset, istos);
   ExitTrace(0)
}

AND DelSLocFromPendingList(q, t, n) = VALOF
{  LET p = !q;
   LET wastos = FALSE;
   TraceIt("DelSloc %n %n*n", t, n);
   WHILE p~=0 DO {
      TEST sl.type!p=t & sl.loc!p=n THEN {
	 IF ps.istos!p THEN wastos := TRUE;
	 !q := FreeBlk(p, ps.size) }
      ELSE
	 q := p;
      p := !q };
   ExitTrace(0);
   RESULTIS wastos
}

AND DelRegFromPendingList(q, r) BE
{  LET p = !q;
   TraceIt("DelReg %n*n", r);
   WHILE p~=0 DO {
      TEST ps.reg!p=r THEN
	 !q := FreeBlk(p, ps.size)
      ELSE
	 q := p;
      p := !q };
   ExitTrace(0)
}

AND SlocInList(p, t, n) = VALOF
{  WHILE p~=0 DO {
      IF sl.type!p=t & sl.loc!p=n THEN RESULTIS p;
      p := !p };
   RESULTIS Null
}

AND OffsetInList(p, t, n, o) = VALOF
{  WHILE p~=0 DO {
      IF sl.type!p=t & sl.loc!p=n & pl.offset!p=o THEN
	 RESULTIS p;
      p := !p };
   RESULTIS Null
}

AND RegInPendingList(p, r) = Assoc(r, ps.reg, p)

AND PrintPendingList(p) BE
   PrintList(p, ps.size-1, "", "*n", "")

AND DelLocsAbove(n, adjusttos) BE
{  TraceIt("DelLocsAbove %n*n", n);

   DeleteLocalsAbove(n, adjusttos, @pendingStores);

   IF (CGDebugMode&db.TracePS)~=0 THEN {
      ExitTrace("Exit DelLocsAbove: pendingStores ");
      PrintPendingList(pendingStores);
      NewLine() }
}

AND DeleteLocalsAbove(n, adjusttos, q) BE
{  LET p = !q;
   WHILE p~=0 DO {
      TEST sl.type!p=k.loc & sl.loc!p>=n THEN {
	 IF ps.istos!p & adjusttos THEN TOSOffset := TOSOffset-1;
	 !q := FreeBlk(p, ps.size) }
      ELSE
	 q := p;
      p := !q }
}

AND CopyOfLocalsIn(q, andIregs) = VALOF
{  LET p = 0;
   WHILE q~=0 DO {
      IF sl.type!q=k.loc | (andIregs & sl.type!q=k.ireg) THEN
	 p := FillBlk(ps.size, p, sl.type!q, sl.loc!q, ps.reg!q,
				  pl.offset!q, ps.istos!q);
      q := !q };
   RESULTIS ReverseInPlace(p)
}

AND FlushPendingStoresExceptLocalsAndIregs() BE
{  LET p = CopyOfLocalsIn(pendingStores, TRUE);

   TraceIt("FlushPendingStoresExceptLocalsAndIregs*n");

   DelLocsAbove(0, FALSE);
   {  LET q = @pendingStores;
      LET p = pendingStores;
      WHILE p~=0 DO {
	 TEST sl.type!p=k.ireg
	    THEN !q := FreeBlk(p, ps.size)
	    ELSE q := p;
	 p := !q } };
   FlushPendingStoresUpTo(0);
   // Not FlushPendingStores to avoid disturbing dedicated registers
   pendingStores := p;
   ExitTrace(0)
}

AND FlushPendingStoresExceptLocals() BE
{  LET p = CopyOfLocalsIn(pendingStores, FALSE);
   TraceIt("FlushPendingStoresExceptLocals*n");

   DelLocsAbove(0, FALSE);
   FlushPendingStores();
   pendingStores := p;
   ExitTrace(0)
}

AND DelLocsExcept(rl) BE
{  LET p = pendingStores;
   LET q = @pendingStores;

   IF (CGDebugMode&db.TracePS)~=0 THEN {
      TraceIt("DelLocsExcept:");
      PrintList(rl, 1, "", "", "*n") };
   WHILE p~=0 DO {
      TEST sl.type!p=k.loc & Assoc(sl.loc!p, 1, rl)=Null THEN {
	 IF ps.istos!p THEN {
	    LET pp = pendingStores;
	    WHILE pp~=p DO {
	       IF ps.istos!pp THEN {
		  ps.istos!pp := FALSE;
		  TOSOffset := TOSOffset-1 };
	       pp := !pp };
	    TOSOffset := TOSOffset-1 };
	 !q := FreeBlk(p, ps.size) }
      ELSE
	 q := p;
      p := !q };
   IF (CGDebugMode&db.TracePS)~=0 THEN {
      ExitTrace("DelLocsExcept: ps ");
      PrintPendingList(pendingStores);
      NewLine() }
}

AND FlushPendingStoresForIregExcept(n, offset) BE
{  TraceIt("FlushPendingStoresForIregExcept %n (%n)*n", n, offset);
   FOR r = r.0 TO r.14 DO {
      LET p = r~=n -> SlocInList(pendingStores, k.ireg, r),
		      OffsetInList(pendingStores, k.reg, r, offset)
      IF p~=Null THEN FlushPendingStoresUpTo(p) };

   ExitTrace(0)
}

AND FlushPendingStoresForSloc(t, n) BE
{  LET p = SlocInList(pendingStores, t, n);
   TraceIt("FlushPendingStoresForSloc %n %n*N", t, n);
   IF p~=Null THEN FlushPendingStoresUpTo(p);
   ExitTrace(0)
}

AND FlushPendingUsesOfReg(r) BE
{  LET p = RegInPendingList(pendingStores, r);
   TraceIt("FlushPendingUsesOfReg %n*N", r);
   IF p~=Null THEN FlushPendingStoresUpTo(p);
   FlushPendingStoresForSloc(k.ireg, r);
   FlushPendingLoadsForSloc(k.ireg, r);
   ExitTrace(0)
}

AND FlushPendingStores() BE
{  LET p = dedicatedRegisters;
   TraceIt("FlushPendingStores*n");
   WHILE p~=0 DO {
      FlushPendingLoadsForReg(dr.Reg!p);
      p := !p };
   FlushPendingStoresUpTo(0);
   ExitTrace(0)
}


AND F4RegOrder(r, q, t) = VALOF
{  LET s = ps.reg!q;
   IF s=r THEN RESULTIS 0;
   TEST t=k.loc & usesFrame & reversedStack
      THEN RESULTIS s>r -> -1, 1
      ELSE RESULTIS s>r -> 1, -1
}

AND FlushPendingStoresUpTo(target) BE
{  LET p = ReverseInPlace(pendingStores);
   {  // We may have managed to get stores to the top of stack
      // in the wrong order (if there have been deletions).
      // If so, sort them out again.
      LET q = p;
      WHILE q~=0 DO {
	 IF sl.type!q=k.loc & ps.istos!q THEN {
	    LET r = !q;
	    LET n = sl.loc!q
	    LET r1 = Null;
	    WHILE r~=0 DO {
	       IF sl.type!r=k.loc & ps.istos!r & sl.loc!r<n THEN {
		  r1 := ps.reg!q;
		  sl.loc!q, ps.reg!q := sl.loc!r, ps.reg!r;
		  sl.loc!r, ps.reg!r := n, r1
		  BREAK };
	       r := !r };
	    IF r1~=Null THEN LOOP };
	 q := !q } };

   WHILE p~=0 DO {
      LET t, n, r, offset = sl.type!p, sl.loc!p, ps.reg!p, pl.offset!p;
      LET istos = ps.istos!p;
      LET q = p;
      TraceIt(":- %n %n %n %n %n*n", t, n, r, offset, istos);
      ps.tracedepth := ps.tracedepth-2;
      p := FreeBlk(p, ps.size);
      IF t~=k.ireg THEN offset := n;
      IF t~=0 THEN {
	 LET r1 = r;
	 LET r2 = r;
	 LET count = 1;
	 LET reglist = 1<<r;
	 LET n1 = offset+1;

	 LET base = t=k.loc -> r.p,
		    t=k.glob -> r.g,
		    t=k.static -> r.l,
		    t=k.ireg -> n,
				CGError(FALSE, "bad type %n in pending store",
					       t);

	 FlushPendingLoadsForReg(r);
	 {  LET q = t=k.ireg -> OffsetInList(p, t, n, n1),
				SlocInList(p, t, n1);
	    IF q=Null | F4RegOrder(r1, q, t)<=0 | ps.istos!q~=istos
	       THEN BREAK;
	    r1 := ps.reg!q; reglist := reglist+(1<<r1);
	    count := count+1;
	    FlushPendingLoadsForReg(r1);
	    n1 := n1+1;
	    sl.type!q := 0
	 } REPEAT;

	 {  LET q = t=k.ireg -> OffsetInList(p, t, n, offset-1),
				SlocInList(p, t, offset-1);
	    IF q=Null | F4RegOrder(r2, q, t)>=0 | ps.istos!q~=istos
	       THEN BREAK;
	    r2 := ps.reg!q; reglist := reglist+(1<<r2);
	    FlushPendingLoadsForReg(r2);
	    offset := offset-1;
	    count := count+1;
	    sl.type!q := 0
	 } REPEAT;

	 TraceIt("%n %n %n %n*n", reglist, r, r1, offset);
	 ps.tracedepth := ps.tracedepth-2;

	 IF base=r.p & ~UsesFrame THEN {
	    base := r.ts;
	    offset := offset-saveSpaceSize };

	 TEST base=r.p & istos & UsesFrame THEN {
	    IF linkageNotStored=r.b & offset=0 THEN
	       SetRtoRplusK(r.b, r.pc, ValueOfLabel(baseLab)-8-locCtr);
	    F4Inst(f.stm, r.ts, reglist, f.wb+upStack) }
	 ELSE TEST r2=r1 & (offset~=R0Offset | base~=r.p) THEN {
	    TEST base=r.p | base=r.ts THEN
	       offset := nextStackWord*offset
	    ELSE
	       offset := 4*offset;
	    GenF2(f.str, r, base, 0, offset) }
	 ELSE {
	    LET type = f.postup;
	    TEST base=r.p THEN {
	       type := f.wb+upStack;
	       IF offset~=R0Offset THEN
		  SetRtoRplusK(r.0, r.p, nextStackWord*offset);
	       R0Offset := n1
	       base := r.0 }
	    ELSE TEST offset=1 THEN
	       type := f.preup
	    ELSE IF offset~=0 THEN {
	       offset := base=r.ts -> nextStackWord*offset, 4*offset;
	       SetRtoRplusK(r.0, base, offset);
	       base := r.0;
	       R0Offset := Null };

	    F4Inst(f.stm, base, reglist, type) };

	 IF base=r.p & linkageNotStored & offset=0 THEN {
	    SetRToRPlusK(r.p, r.ts, -count*nextStackWord);
	    IF usesRL THEN {
	       RLLoadList := FillBlk(2, RLLoadList, locCtr);
	       GenF2(f.ldr, r.l, r.pc, 0,
		     ValueOfLabel(baseLab)-12-locCtr-(procNames -> 12, 0)) };
	    linkageNotStored := FALSE } };
      IF q=target THEN BREAK
   };

   pendingStores := ReverseInPlace(p);
   IF (CGDebugMode&db.TracePS)~=0 THEN {
      WriteS("Exit FlushPS*N");
      PrintPendingList(pendingStores);
      NewLine() }
}

AND AddToPendingLoads(r, t, n, offset) BE
{  IF t=k.ireg THEN FlushPendingStoresForIregExcept(n, offset);
   pendingLoads := FillBlk(ps.size, pendingLoads, t, n, r, offset, Null);
   IF (CGDebugMode&db.TracePS)~=0
      THEN WriteF("addtopl %n %n %n %n*n", r, t, n, offset)
}

AND FlushPendingLoadsForIreg() BE
{  TraceIt("FlushPendingLoadsForIreg*n");
   FOR r = r.0 TO r.14 DO {
      LET p = SlocInList(pendingLoads, k.ireg, r);
      IF p~=Null THEN FlushPendingLoadsUpTo(p) };
   ExitTrace(0)
}

AND FlushPendingLoadsForReg(r) BE
{  LET p = RegInPendingList(pendingLoads, r);
   TraceIt("FlushPendingLoadsForReg %n*N", r);
   IF p~=Null THEN FlushPendingLoadsRelatedTo(p, pendingLoads);
   FlushPendingLoadsForSloc(k.ireg, r);
   ExitTrace(0)
}

AND FlushPendingLoadsForSloc(t, n) BE
{  /* A given sloc may be in pending loads many times, wherefore the loop */
   TraceIt("FlushPLForSloc %n %n*n", t, n);
   {  LET p = SlocInList(pendingLoads, t, n);
      IF p=Null THEN BREAK;
      FlushPendingLoadsRelatedTo(p, pendingLoads) } REPEAT;
   ExitTrace(0) }

AND FlushPendingLoadsExceptLocals() BE
{  LET p = CopyOfLocalsIn(pendingLoads, FALSE);
   TraceIt("FlushPendingLoadsExceptLocals*N");
   DeleteLocalsAbove(0, FALSE, @pendingLoads);
   FlushPendingLoads();
   pendingLoads := p;
   ExitTrace(0)
}

AND FlushPendingLoads() BE
{  TraceIt("FlushPendingLoads*n");
   FlushPendingLoadsUpTo(0);
   ExitTrace(0)
}

AND FlushPendingLoadsRelatedTo(p, pl) BE
{  LET t, n, r, offset = sl.type!p, sl.loc!p, ps.reg!p, pl.offset!p;
   sl.type!p := 0;
   TraceIt(":- %n %n %n %n*n", t, n, r, offset);
   ps.tracedepth := ps.tracedepth-2;
   IF t~=k.ireg THEN offset := n;
   IF t~=0 THEN {
      LET r1 = r;
      LET r2 = r;
      LET reglist = 1<<r;
      LET n1 = offset+1;

      LET base = t=k.loc -> r.p,
		 t=k.glob -> r.g,
		 t=k.static -> r.l,
		 t=k.ireg -> n,
			     CGError(FALSE, "bad type %n in pending load",
					    t);

      {  LET q = t=k.ireg -> OffsetInList(pl, t, n, n1),
			     SlocInList(pl, t, n1);
	 IF q=Null | F4RegOrder(r1, q, t)<=0 THEN BREAK;
	 r1 := ps.reg!q; reglist := reglist+(1<<r1);
	 n1 := n1+1;
	 sl.type!q := 0
      } REPEAT;

      {  LET q = t=k.ireg -> OffsetInList(pl, t, n, offset-1),
			     SlocInList(pl, t, offset-1);
	 IF q=Null | F4RegOrder(r2, q, t)>=0 THEN BREAK;
	 r2 := ps.reg!q; reglist := reglist+(1<<r2);
	 offset := offset-1;
	 sl.type!q := 0
      } REPEAT;

      TraceIt("%n %n %n %n*n", reglist, r, r1, offset);
      ps.tracedepth := ps.tracedepth-2;

      IF base=r.p THEN
	 TEST ~UsesFrame THEN {
	    base := r.ts;
	    offset := offset-saveSpaceSize }
	 ELSE IF linkageNotStored THEN
	    base := r.ts;

      TEST base=r.p & n1=TOSOffset THEN
	 F4Inst(f.ldm, r.ts, reglist, reversedStack -> f.preup,
							  f.predown)
      ELSE TEST r2=r1 & (n~=R0Offset | base~=r.p) THEN {
	 TEST base=r.p | base=r.ts THEN
	    offset := nextStackWord*offset
	 ELSE
	    offset := 4*offset;
	 GenF2(f.ldr, r, base, 0, offset) }
      ELSE {
	 LET type = f.postup;
	 TEST base=r.p THEN {
	    type := f.wb+upStack;
	    TEST n1-1=R0Offset THEN
	       type := upStack NEQV f.up
	    ELSE TEST n1=R0Offset THEN
	       type := upStack NEQV f.preup
	    ELSE {
	       IF offset~=R0Offset THEN
		  SetRtoRplusK(r.0, r.p, nextStackWord*offset);
	       R0Offset := n1 };
	    base := r.0 }
	 ELSE TEST offset=1 THEN
	    type := f.preup
	 ELSE IF offset~=0 THEN {
	    offset := base=r.ts -> nextStackWord*offset, 4*offset;
	    SetRtoRplusK(r.0, base, offset);
	    base := r.0;
	    R0Offset := Null };

	 F4Inst(f.ldm, base, reglist, type) } } }


AND FlushPendingLoadsUpTo(target) BE
{  LET p = ReverseInPlace(pendingLoads);
   WHILE p~=0 DO {
      LET q = p;
      FlushPendingLoadsRelatedTo(p, !p);
      p := FreeBlk(p, ps.size);
      IF q=target THEN BREAK };

   pendingLoads := ReverseInPlace(p);
   IF (CGDebugMode&db.TracePS)~=0 THEN {
      WriteS("Exit FlushPL*N");
      PrintPendingList(pendingLoads) }
}

