/* BCPL Code-Generator for ARM
   H.C.M.Meekings
*/

SECTION "CGM"

GET "b.CGheader"

STATIC {
 /* Version of 11 Sep 87 13:40:03
 */
   dummy = VersionMark;
   version = 1*256+9 };

STATIC {
   maxl = 0;
   nextFreeLabel = 0;
   pendingN = 0; pendingNExists = FALSE;
   err.p = 0; err.l = 0;
   ocodePosn = 0; endOfOcode = FALSE;
   ocptr = 0;
   writeOcode = 0 };

MANIFEST {
   infinity = #x7fffffff };

LET BCPL.cg() BE
{  // called once for each input section.
   LET mark = VEC mk.size-1;
   LET originalBase = ?;

   WriteF("ARM CodeGenerator %n.%n*n",
	   CGMajorVersion, CGMinorVersion);

   reversedStack := backwardVecs;
   upStack := reversedStack -> f.postdown, f.postup;
   nextStackWord := reversedStack -> -4, 4;
   err.p, err.l := Level(), die;

   ReadOp, ReadN := ReadBytes, ReadBytes;
   pendingNExists := FALSE;
   ocodeBuf := ocodeBufs;
   ocptr := oc.firstbyte;
   writeOcode := CGDebugMode&db.poc;

   labelBlockV := GetVector(LabelBlockVSize)
   FOR j = 0 TO LabelBlockVSize-1 DO labelBlockV!j := 0;

   tempv := GetVector(tempsize)
   tempt := tempv + tempsize

   InitialiseRegisterSlave();

   base := GetVector(30);
   baseAddr := 0;

   InitPendingInsts();

   MarkHeap(mark);
   nextFreeLabel := last.label.number-1;

   originalbase := base;
   Flab := NextLabel();
   Slab := NextLabel();
   staticDataLab:=NextLabel();
   endSectLabel := NextLabel();
   callLab := NextLabel();
   exitCallLab := NextLabel();
   exitLab := NextLabel();
   quotLab := NextLabel();
   multLab := NextLabel();
   localConstLab := NextLabel();

   InitStack(saveSpaceSize);

   blockLabel := -1;
   baselab := 0;
   pendingJump := 0;
   TOSoffset, R0Offset := Null, Null;
   locCtr := 0
   argumentNumber := Null;
   lineCounts := 0;

   staticLabels, DataLabel := 0, Null;
   staticOffset := 0; staticDataSize := 0;
   ps.tracedepth := 0;
   xrefsyms := 0;

   InitDataLists();
   maxgn, maxl := 100, 0;
   countFlag, deadCode := FALSE, Dead;

   loadRegFromFRegOK := FALSE;

   DiscardRegs();

   transferLabs := 0;
   ocodePosn := 0;
   op := ReadOp();
   PreScan1();
   IF (CGDebugMode&db.tlabs)~=0 THEN
      PrintList(transferLabs, 2, "transferlabs", ":", "*n");

   ocodeBuf := ocodeBufs;
   ocptr := oc.firstbyte;
   ocodePosn := 0;

   op := ReadOp();
   PreScan2();
   base := originalBase;
   ocodeBuf := ocodeBufs;
   ocptr := oc.firstbyte;

   op := ReadOp();
   IF op=0 THEN RETURN;

   // Generate the section name string

   TEST op=s.section THEN {
      sectionName := ReadString(ReadN());
      op := ReadOp() }
   ELSE
      sectionName := "BCPL";

   // Read and code generate the rest of the section

   PutWord(#x4c504342);
   AddressInCode(endSectLabel, 0);
   IF procNames THEN {
      PutString(sectionName, 8);
      {  LET v = VEC 4;
	 LET d = Date() AND t = TimeOfDay();
	 LET nd = d%0 AND nt = t%0;
	 v%0 := nd+nt+1;
	 FOR i = 1 TO nd DO v%i := d%i;
	 FOR i = 0 TO nt DO v%(nd+i+1) := t%i;
	 PutString(v, 20) };
      IF (hostProcessor&#xffff)~='A' THEN
	 // The ARM library sets this, but the 32016 doesn't
	 hostProcessor := #x3233;

      PutWord([CGMajorVersion<<24] |
	      [CGMinorVersion<<16] |
	      hostProcessor) };
   Scan();
   CGEnd();

   WriteF("Section %s: size", sectionName);
   programSize := PrintSizes(programSize);
   NewLine();

   // Reset the heap to release the store used in code
   // generating the section.
die:
   ResetHeap(mark) }

AND ReadBytes() = VALOF
{  LET n = ?;
   TEST pendingNExists THEN {
      pendingNExists := FALSE;
      n := pendingN }
   ELSE {
      n := ReadByte();
      TEST n=#X80 THEN {
	 n := 0;
	 FOR j = 1 TO bytesperword DO
	    n := (n<<8) + ReadByte() }
      ELSE IF (n & #X80)~=0 THEN
	 n := n | #XFFFFFF00 };

   IF writeOcode~=0 THEN {
      WrCh(' '); WriteN(n) };
   RESULTIS n
}

AND ReadByte() = VALOF
{  IF ocodeBuf=0 THEN RESULTIS 0;

   IF ocptr>=ocodeBuf!oc.lastbyte THEN {
      ocodeBuf := !ocodeBuf;
      IF ocodeBuf=0 THEN {
	 endOfOcode := TRUE; RESULTIS 0 };
      ocptr := oc.firstbyte };

   {  LET n = ocodeBuf%ocptr;
      ocptr := ocptr+1;
      ocodePosn := ocodePosn+1;
      RESULTIS n }
}

AND PeekN() = VALOF
{  LET n = ReadN();
   pendingN, pendingNExists := n, TRUE;
   RESULTIS n
}

AND ReadL() = VALOF
{  LET l = ReadN();
   IF l>maxl THEN {
      maxl := l;
      IF l>nextFreeLabel THEN CGError("") };
   RESULTIS l
}

AND ReadGN() = VALOF
{  LET g = ReadN()
   IF maxgn<g THEN maxgn := g
   RESULTIS g
}

AND NextLabel() = VALOF
{  LET w = nextFreeLabel;
   nextFreeLabel := nextFreeLabel-1;
   RESULTIS w
}

AND CGError(isItFatal, message, a, b, c) BE {
   WriteF("*N****** %s: ", (isItFatal=OnlyWarning -> "Warning", "Error"));
   IF lineCount>=0 THEN WriteF("near line %n:", lineCount);
   WriteF(message, a, b, c);
   NewLine();
   rc := 10;
   IF isItFatal=FatalError THEN
   {  IF (BackTrace>>24)~=#xAE THEN { BackTrace(); MapStore() };
      Collapse(10) } }

AND Collapse(n) BE {
   IF rc<n THEN rc := n
   LongJump(err.p, err.l) }

AND WriteByte(n) BE
{  IF ocptrw>=oc.bytes THEN {
      LET v = GetVector(oc.size);
      !ocodeBufw := v;
      ocodeBufw := v;
      !v := 0;
      ocptrw := oc.firstbyte };
   ocodeBufw%ocptrw := n;
   ocptrw := ocptrw+1;
   ocodeBufw!oc.lastbyte := ocptrw
}

AND WriteBytes(n) BE
   TEST -127<=n<=127 THEN
      WriteByte(n)
   ELSE {
      WriteByte(#x80);
      FOR i = 8*(BytesPerWord-1) TO 0 BY -8 DO
	 WriteByte(n>>i) }

AND DelNonAssoc(q, others, size) BE
{  LET p = !q;
   WHILE p~=0 DO {
      TEST Assoc(1!p, 1, others)=Null THEN
	 !q := FreeBlk(p, size)
      ELSE
	 q := p;
      p := !q } }

AND Copy(start, end) BE
{  // Copy ocode from byte start (inclusive) to end (exclusive)
   // out of the old into the new ocode buffer
   LET startblock = start/(oc.bytes-oc.firstbyte);
   ocptr := (start REM (oc.bytes-oc.firstbyte))+oc.firstbyte;
   IF (CGDebugMode&db.shuffle)~=0 THEN
      WriteF("copying from %n to %n*n", start, end);
   ocodePosn := start;
   ocodeBuf := Nth(startblock, ocodeBufs);
   UNTIL ocodePosn>=end | endOfOcode DO WriteByte(ReadByte()) }

AND PreScan1() BE
{  LET AddTransferLab(source, dest) BE
      IF source~=Null & source~=dest & TransferredLabel(dest)~=source THEN
	 transferLabs := FillBlk(3, transferLabs, source, dest);

   LET precedingLabel = Null;
   LET blockStart, blockLabel = Null, Null;
   LET insideBlock = FALSE;
   LET blocks, blockRefs = 0, 0;
   LET dataLabel = 0;

   {s
   SWITCHON op INTO
   {  CASE 0:
	 CGError(TRUE, "Premature end of ocode stream");

      DEFAULT:
	 CGError(FALSE, "Unexpected ocode operator %n", op);

      CASE s.debug: CASE s.query:
      CASE s.true: CASE s.false: CASE s.nil: CASE s.stnil:

      CASE s.getbyte: CASE s.putbyte:
      CASE s.stvcar: CASE s.stvcdr: CASE s.stcar: CASE s.stcdr:
      CASE s.stind: CASE s.mod: CASE s.modslct:
      CASE s.vcar: CASE s.vcdr: CASE s.car: CASE s.cdr:
      CASE s.rv:

      CASE s.mult: CASE s.plus: CASE s.div: CASE s.rem: CASE s.minus:
      CASE s.fmult: CASE s.fplus: CASE s.fdiv: CASE s.fminus:
      CASE s.lls: CASE s.lgr: CASE s.lle: CASE s.lge:
      CASE s.eq:  CASE s.ne:  CASE s.ls:
      CASE s.gr:  CASE s.le:  CASE s.ge:
      CASE s.feq: CASE s.fne: CASE s.fls:
      CASE s.fgr: CASE s.fle: CASE s.fge:
      CASE s.lshift: CASE s.rshift:
      CASE s.logand: CASE s.logor: CASE s.eqv: CASE s.neqv:
      CASE s.not: CASE s.neg: CASE s.abs:
      CASE s.fneg: CASE s.fabs:
      CASE s.fix:  CASE s.float:

      CASE s.store:
	 ENDCASE

      CASE s.slctap: CASE s.slctst:
	 ReadN();

      CASE s.fconst:
      CASE s.dtab:
	 ReadN();
	 ReadN();
	 ENDCASE

      CASE s.iteml:
      {  LET lab = ReadN();
	 FlagLabel(lab, lab.procorlabel);
	 staticDataSize := staticDataSize+4;
	 ENDCASE }

      CASE s.itemn:
	 staticDataSize := staticDataSize+4;
      CASE s.linecount:
      CASE s.argno:
      CASE s.lg: CASE s.lp: CASE s.ll: CASE s.ln:
      CASE s.llg:
      CASE s.sg: CASE s.sp:
      CASE s.save:
      CASE s.datalab:
      CASE s.fnap: CASE s.rtap:
	 ReadN();
	 ENDCASE

      CASE s.refext:
      {  LET lab = ReadL();
	 LET sval = ReadString(ReadN());
	 xrefsyms := FillBlk(3, xrefsyms, lab, sval);
	 Data(s.datalab, lab);
	 staticLabels := FillBlk(4, staticLabels, lab, Null, staticOffset);
	 Data(s.itemx, sval);
	 staticOffset := staticOffset+4;
	 staticDataSize := staticDataSize+4;
	 ENDCASE }

      CASE s.dstr:
      CASE s.defext:
	 ReadN();
      CASE s.section: CASE s.needs:
      CASE s.lstr:
	 DiscardN(ReadN());
	 ENDCASE

      CASE s.llp:
	 ReadN();
	 ENDCASE

      CASE s.lll:
	 FlagLabel(ReadN(), lab.lvtaken);
	 ENDCASE

      CASE s.sl:
	 FlagLabel(ReadN(), lab.stored);
	 ENDCASE

      CASE s.jt: CASE s.jf:
      CASE s.endfor:
	 ReadN();
	 ENDCASE

      CASE s.stack: CASE s.rstack:
	 ReadN();
	 op := ReadOp();
	 LOOP

      CASE s.lab:
	 {  LET p = ocodePosn-1;
	    LET l = ReadN();
	    AddTransferLab(precedingLabel, l);
	    precedingLabel := l;
	    TEST insideBlock THEN
	       blockStart := Null
	    ELSE
	       blockStart, blockLabel := p, l;
	    insideBlock := TRUE;
	    op := ReadOp();
	    LOOP }

      CASE s.entry:
	 DiscardN(ReadN()+1);
	 insideBlock := TRUE;
	 blockStart := Null;
	 ENDCASE

      CASE s.endproc:
      CASE s.endblock:
	 IgnoreNames();
	 ENDCASE

      CASE s.switchon:
	 {  LET n = ReadN();
	    LET d = ReadN();
	    FOR i = 1 TO 2*n DO ReadN();
	    IF Assoc(d, 1, blockRefs)=Null THEN
	       blockRefs := FillBlk(3, blockRefs, d, ocodePosn)
	    GOTO EndOfBlock };

      CASE s.fnrn: CASE s.rtrn:
	 AddTransferLab(precedingLabel, 0);
	 GOTO EndOfBlock

      CASE s.res:
      CASE s.jump:
	 {  LET l = ReadN();
	    LET p = Assoc(l, 1, blockRefs);
	    AddTransferLab(precedingLabel, l);
	    IF p~=Null THEN
	       blockRefs := DeleteFromList(blockRefs, p, 3);
	    blockRefs := FillBlk(3, blockRefs, l, ocodePosn) }

      CASE s.goto:
      CASE s.finish:
      EndOfBlock:
	 IF insideBlock & blockStart~=Null THEN
	    blocks := FillBlk(4, blocks, blockLabel, blockStart, ocodePosn);
	 insideBlock := FALSE;
	 ENDCASE

      CASE s.global:
	 BREAK
   };

   precedingLabel := Null;
   op := ReadOp()
   }s REPEAT;

   IF (CGDebugMode&db.shuffle)~=0 THEN
   {  PrintList(blocks, 3, "blocks", ":", "*n");
      PrintList(blockRefs, 2, "blockrefs", ":", "*n") };

   DelNonAssoc(@blockRefs, blocks, 3);
   DelNonAssoc(@blocks, blockRefs, 4);

   IF blocks~=0 & (CGOptMode&op.shuffle)~=0 THEN
   {  LET posn = 0;
      LET blockp = ?;
      LET insert, ignoreStart, ignoreEnd = ?, ?, ?;
      LET newBufs = GetVector(oc.size);

      blocks := ReverseInPlace(blocks);
      blockRefs := ReverseInPlace(blockRefs);

      IF (CGDebugMode&db.shuffle)~=0 THEN
      {  PrintList(blocks, 3, "blocks", ":", "*n");
	 PrintList(blockRefs, 2, "blockrefs", ":", "*n") };

      writeOcode := 0;
      ocptr := oc.firstbyte; ocodeBuf := ocodeBufs;
      ocodeBufw := newBufs;
      !ocodeBufw := 0;
      ocptrw := oc.firstbyte;
      endOfOcode := FALSE;
      blockp := blocks;

      {  insert := blockRefs=0 -> infinity, blockRefs!2;
	 ignoreStart := blockp=0 -> infinity, blockp!2;
	 ignoreEnd   := blockp=0 -> infinity, blockp!3;

	 IF (CGDebugMode&db.shuffle)~=0 THEN
	    writef("%n, [%n, %n]*n", insert, ignoreStart, ignoreEnd);

	 TEST insert<=ignoreStart & insert~=infinity THEN {
	    LET p = blockRefs;
	    LET target = ?;
	    Copy(posn, insert);
	    WHILE p~=Null DO
	    {  target := Assoc(1!p, 1, blocks);
	       Copy(target!2, target!3);
	       blockRefs := DeleteFromList(blockRefs, p, 3);
	       p := Assoc(target!3, 2, blockRefs) };
	    posn := insert }
	 ELSE {
	    Copy(posn, ignoreStart);
	    posn := ignoreEnd;
	    blockp := !blockp }
      } REPEATWHILE insert~=infinity | ignoreStart~=infinity;

      endOfOcode := FALSE;
      ocodeBufs := newBufs;
      ocptr := oc.firstbyte;
      ocodeBuf := ocodeBufs;
      IF (CGDebugMode&db.shuffle)~=0 THEN
      {  {  WriteF("%n ", ReadN()) } REPEATWHILE ~endOfOcode } }
}

AND PreJump(lab) BE
{  LET p = FindLabelEntry(TransferredLabel(lab));
   LET e = !p;

   TEST (e&lab.defined)~=0 THEN
      e := e & ~(lab.forwardjump+lab.onlyonejump)
   ELSE TEST (e&lab.forwardjump)~=0 THEN
      e := e & ~lab.onlyonejump
   ELSE
      e := e | (lab.forwardjump+lab.onlyonejump);

   !p := e
}

AND PreScan2() BE
{s LET stackFrame = 0;
   ssp := 0;

   {  SWITCHON op INTO
      {  DEFAULT:

	 CASE s.debug:

	 CASE s.vcar: CASE s.vcdr: CASE s.car: CASE s.cdr:
	 CASE s.rv:

	 CASE s.not: CASE s.neg: CASE s.abs:
	 CASE s.fneg: CASE s.fabs:
	 CASE s.fix: CASE s.float:

	 CASE s.finish:
	 CASE s.store:
	 CASE s.fnrn: CASE s.rtrn:
	    ENDCASE

	 CASE s.fconst:
	    ReadN();
	 CASE s.lg: CASE s.ln:
	 CASE s.llg:
	 CASE s.sg:
	    ReadN()
	 CASE s.true: CASE s.false: CASE s.nil:
	 incssp:
	    ssp := ssp+1;
	    IF ssp>stackframe THEN stackframe := ssp;
	    ENDCASE

	 CASE s.mult: CASE s.div: CASE s.rem:
	    // These may be handled by branch & link to global
	    // routines, so link storage is needed.
	    FlagLabel(baseLab, lab.frameneeded);

	 CASE s.stnil:
	 CASE s.plus: CASE s.minus:
	 CASE s.fplus: CASE s.fminus: CASE s.fmult: CASE s.fdiv:
	 CASE s.lls: CASE s.lgr: CASE s.lle: CASE s.lge:
	 CASE s.eq:  CASE s.ne:  CASE s.ls:
	 CASE s.gr:  CASE s.le:  CASE s.ge:
	 CASE s.feq: CASE s.fne: CASE s.fls:
	 CASE s.fgr: CASE s.fle: CASE s.fge:
	 CASE s.lshift: CASE s.rshift:
	 CASE s.logand: CASE s.logor: CASE s.eqv: CASE s.neqv:
	 CASE s.stvcar: CASE s.stvcdr: CASE s.stcar: CASE s.stcdr:
	 CASE s.mod: CASE s.modslct:
	 CASE s.getbyte:
	    ssp := ssp-1;
	    ENDCASE

	 CASE s.slctst:
	    ReadN(); ReadN(); ReadN();
	 CASE s.stind: CASE s.putbyte:
	    ssp := ssp-2;
	    ENDCASE

	 CASE s.slctap:
	    ReadN();

	 CASE s.dtab:
	    ReadN();

	 CASE s.linecount:
	 CASE s.argno:
	 CASE s.datalab:
	 CASE s.itemn: CASE s.iteml:
	    ReadN();
	    ENDCASE

	 CASE s.dstr:
	 CASE s.defext:
	 CASE s.refext:
	    ReadN();
	 CASE s.section: CASE s.needs:
	    DiscardN(ReadN());
	    ENDCASE

	 CASE s.lstr:
	    DiscardN(ReadN());
	    IF (CGOptMode&op.strings)=0 THEN
	       FlagLabel(baseLab, lab.frameneeded+lab.procstatics);
	    GOTO incssp

	 CASE s.save:
	    stackFrame := ReadN();
	    IF stackFrame>SaveSpaceSize+4 THEN
	       FlagLabel(baseLab, lab.frameneeded);
	    ENDCASE

	 CASE s.rstack: CASE s.stack:
	    ssp := ReadN();
	    IF ssp>stackFrame THEN stackFrame := ssp;
	    ENDCASE

	 CASE s.lp:
	    {  LET n = ReadN();
	       IF n>stackFrame THEN stackFrame := n
	       GOTO incssp
	    };

	 CASE s.sp:
	    {  LET n = ReadN();
	       IF n>stackFrame THEN stackFrame := n
	       ssp := ssp-1;
	       ENDCASE
	    };

	 CASE s.fnap: CASE s.rtap:
	    {  LET oldssp = ssp;
	       ssp := ReadN();
	       {  op := ReadOp();
		  IF op~=s.stack & op~=s.rstack THEN BREAK;
		  ReadN()
	       } REPEAT;
	       // Exit calls are OK
	       IF (~[(op=s.res | op=s.jump | op=s.lab) &
		    TransferredLabel(PeekN())=0] &
		   ~[op=s.rtrn | op=s.fnrn]) |
	       // unless they have more than four arguments
		  oldssp-ssp-saveSpaceSize>5 // one for the procedure called
	       THEN FlagLabel(baseLab, lab.frameneeded);

	    // whether this is an exit call or not, it may need arguments
	    // loading. (It's not easy to detect a call with none)
	       FlagLabel(baseLab, lab.prochascalls);
	       LOOP }

	 CASE s.ll:
	    {  LET l = ReadN();
	       LET n = ?;
	       n := PeekN();
	       TEST n=s.rtap | n=s.fnap THEN {
		  FlagLabel(l, lab.called);
		  IF LabelFlagged(l, lab.lvtaken+lab.stored) THEN
		     FlagLabel(baseLab, lab.frameneeded+lab.procstatics) }
	       ELSE
		  FlagLabel(baseLab, lab.frameneeded+lab.procstatics);
	       GOTO incssp
	    }

	 CASE s.llp:
	    ReadN();
	    FlagLabel(baseLab, lab.lvptaken);
	    FlagLabel(baseLab, lab.frameneeded);  // temporary expedient
	    GOTO incssp

	 CASE s.lll:
	    ReadN();
	    FlagLabel(baseLab, lab.frameneeded+lab.procstatics);
	    GOTO incssp

	 CASE s.sl:
	    ReadN();
	    FlagLabel(baseLab, lab.frameneeded+lab.procstatics);
	    ssp := ssp-1;
	    ENDCASE

	 CASE s.jt: CASE s.jf:
	 CASE s.endfor:
	    ssp := ssp-1;
	 CASE s.jump:
	    PreJump(ReadN());
	    ENDCASE

	 CASE s.res:
	    {  LET lab = ReadN();
	    // this is of course strictly a lie.  What it means
	    // is that a fixed register is going to be used, so
	    // my simple-minded register assignment is out.
	       IF TransferredLabel(lab)~=0
		  THEN FlagLabel(baseLab, lab.prochascalls);
	       PreJump(lab);
	       ENDCASE }

	 CASE s.goto:
	    ssp := ssp-1;
	    ENDCASE

	 CASE s.lab:
	    {  LET lab = ReadN();
	       FlagLabel(lab, lab.defined);
	       IF LabelFlagged(lab, lab.procorlabel) THEN
		  FlagLabel(baselab, lab.lvptaken+lab.frameneeded);
	       /* That was to disable exit calls from a procedure
		  containing a (source) label, in case a called
		  procedure tried to longjump to this one.  (Really,
		  this check should be on calls of Level, but I can't
		  see them)
	       */
	       ENDCASE }

	 CASE s.entry:
	    {  LET n = ReadN();
	       base!0 := baseLab;
	       base := base+1;
	       baseLab := ReadN();
	       DiscardN(n);
	       stackFrame := saveSpaceSize;
	       ENDCASE }

	 CASE s.endproc:
	    IF stackFrame>MaxStaticFrame+saveSpaceSize-4
	       THEN FlagLabel(baseLab, lab.frameneeded);
	    base := base-1;
	    baseLab := base!0;
	 CASE s.endblock:
	    IgnoreNames();
	    ENDCASE

	 CASE s.switchon:
	    {  LET n = ReadN();
	       PreJump(ReadN());
	       FOR i = 1 TO n DO
	       {  ReadN();
		  PreJump(ReadN()) };
	       ENDCASE }

	 CASE s.global:
	    RETURN
      };
      op := ReadOp()
   } REPEAT
}s

AND ReadString(n) = VALOF {
   LET w = VEC 256;
   w%0 := n;
   FOR i = 1 TO n DO w%i := ReadN();
   RESULTIS InternString(w) }
