MODULE FoxTRMBackend; (** AUTHOR "fof"; PURPOSE "backend for the tiny register machine"; *) IMPORT Basic := FoxBasic, SyntaxTree := FoxSyntaxTree, Global := FoxGlobal, Backend := FoxBackend, Sections := FoxSections, IntermediateCode := FoxIntermediateCode, IntermediateBackend := FoxIntermediateBackend, BinaryCode := FoxBinaryCode, SemanticChecker := FoxSemanticChecker, Formats := FoxFormats, Assembler := FoxTRMAssembler, InstructionSet := FoxTRMInstructionSet, SYSTEM, Diagnostics, Streams, Options, Strings, ObjectFile, Scanner := FoxScanner, ObjectFileFormat := FoxIntermediateObjectFile, CodeGenerators := FoxCodeGenerators, D := Debugging, Compiler; CONST TraceFixups = FALSE; HaltIRQNumber=8; Registers = 8; None=-1; Low=0; High=1; FPSupported = TRUE; (* setting this to false increases code size slightly but also reduces register pressure *) opAND= InstructionSet.opAND; opBIC* = InstructionSet.opBIC; opOR= InstructionSet.opOR; opXOR= InstructionSet.opXOR; opADD= InstructionSet.opADD; opFADD = InstructionSet.opFADD; opSUB= InstructionSet.opSUB; opFSUB = InstructionSet.opFSUB; opMUL= InstructionSet.opMUL; opFMUL = InstructionSet.opFMUL; opNOT= InstructionSet.opNOT; opLDH= InstructionSet.opLDH; opMOV= InstructionSet.opMOV; opROR= InstructionSet.opROR; opBLR= InstructionSet.opBLR; opBR= InstructionSet.opBR; opIRET* = InstructionSet.opIRET; opLD= InstructionSet.opLD; opST= InstructionSet.opST; opBL= InstructionSet.opBL; opBEQ= InstructionSet.opBEQ; opBNE= InstructionSet.opBNE; opBAE= InstructionSet.opBAE; opBB= InstructionSet.opBB; opBN= InstructionSet.opBN; opBNN= InstructionSet.opBNN; opBO* = InstructionSet.opBO; opBNO* = InstructionSet.opBNO; opBA= InstructionSet.opBA; opBBE= InstructionSet.opBBE; opBGE= InstructionSet.opBGE; opBLT= InstructionSet.opBLT; opBGT= InstructionSet.opBGT; opBLE= InstructionSet.opBLE; opBT= InstructionSet.opBT; opBF* = InstructionSet.opBF; opSPSR* = InstructionSet.opSPSR; VectorSupportFlag = "vectorSupport"; FloatingPointSupportFlag ="floatingPoint"; FPSupportFlag = "supportFP"; PatchSpartan6 ="patchSpartan6"; TYPE Operand=InstructionSet.Operand; FixupEntry=POINTER TO RECORD maxPC: LONGINT; fixup: BinaryCode.Fixup; next: FixupEntry; END; ForwardFixupList=OBJECT VAR first,last: FixupEntry; PROCEDURE &Init; BEGIN first := NIL; last := NIL; END Init; PROCEDURE Enter(fixup: BinaryCode.Fixup; currentPC: LONGINT; bits: LONGINT); VAR entry: FixupEntry; maxPC: LONGINT; BEGIN maxPC := currentPC + ASH(1,bits-1) -1; (* signed *) NEW(entry); entry.fixup := fixup; entry.maxPC := maxPC-1; (* one instruction necessary to jump over the instruction *) IF first = NIL THEN first := entry; last := entry; ELSE ASSERT(last.maxPC <= maxPC); (* otherwise we have to insert sorted but this does not seem necessary *) last.next := entry; last := entry; END; END Enter; PROCEDURE Check(outPC: LONGINT): BinaryCode.Fixup; VAR fixup: BinaryCode.Fixup; BEGIN IF (first # NIL) & (outPC >= first.maxPC) THEN fixup := first.fixup; IF first = last THEN first := NIL; last := NIL ELSE first := first.next END; RETURN fixup; ELSE RETURN NIL END; END Check; END ForwardFixupList; Ticket=CodeGenerators.Ticket; PhysicalRegisters*=OBJECT (CodeGenerators.PhysicalRegisters) VAR toVirtual: ARRAY Registers OF Ticket; (* registers real register -> none / reserved / split / blocked / virtual register (>0) *) reserved: ARRAY Registers OF BOOLEAN; unusable: Ticket; hint: LONGINT; PROCEDURE &InitPhysicalRegisters(supportFP: BOOLEAN); VAR i: LONGINT; BEGIN FOR i := 0 TO LEN(toVirtual)-1 DO toVirtual[i] := NIL; reserved[i] := FALSE; END; (* reserve stack and base pointer registers *) NEW(unusable); toVirtual[InstructionSet.SP] := unusable; toVirtual[InstructionSet.LR] := unusable; IF supportFP THEN toVirtual[InstructionSet.FP] := unusable END; END InitPhysicalRegisters; PROCEDURE SupportFP(b: BOOLEAN); BEGIN IF b THEN toVirtual[InstructionSet.FP] := unusable ELSE toVirtual[InstructionSet.FP] := NIL END; END SupportFP; PROCEDURE NumberRegisters*(): LONGINT; BEGIN RETURN Registers END NumberRegisters; PROCEDURE Allocate*(index: LONGINT; virtualRegister: Ticket); BEGIN Assert(toVirtual[index]=NIL,"register already allocated"); toVirtual[index] := virtualRegister; ASSERT(~virtualRegister.spilled); END Allocate; PROCEDURE SetReserved*(index: LONGINT; res: BOOLEAN); BEGIN reserved[index] := res; END SetReserved; PROCEDURE Reserved*(index: LONGINT): BOOLEAN; BEGIN RETURN (index>0) & reserved[index] END Reserved; PROCEDURE Free*(index: LONGINT); BEGIN Assert((toVirtual[index] # NIL),"register not reserved"); toVirtual[index] := NIL; END Free; PROCEDURE NextFree*(CONST type: IntermediateCode.Type):LONGINT; VAR i: LONGINT; BEGIN ASSERT(type.sizeInBits=32); i := 0; IF (hint # None) THEN IF toVirtual[hint] = NIL THEN i := hint END; hint := None END; WHILE (i 975) ); instructionSet.Emit(op, op1, op2, out); (* do this AFTER each instruction because otherwise presumptions on the size of the PC in the generator are wrong *) (* note, in general, by the inclusion of the following code, no assumptions are true about the actual size of instructions in code emission --> forward jumps do have to be patched in all cases *) PatchSpartan6; END Emit; PROCEDURE Emit2(op: LONGINT; CONST op1, op2: InstructionSet.Operand); BEGIN CheckStackPointer(op1); Emit(op, op1, op2); END Emit2; PROCEDURE Emit2N(op: LONGINT; CONST op1: InstructionSet.Operand; n: LONGINT); VAR op2: InstructionSet.Operand; BEGIN CheckStackPointer(op1); instructionSet.InitImmediate(op2,0,n); Emit(op, op1, op2); END Emit2N; PROCEDURE Emit1(op: LONGINT; CONST op1: InstructionSet.Operand); BEGIN Emit(op, op1, emptyOperand); END Emit1; PROCEDURE Emit1N(op: LONGINT; n: LONGINT); VAR op1: InstructionSet.Operand; BEGIN instructionSet.InitImmediate(op1,0,n); Emit(op, op1, emptyOperand); END Emit1N; (*------------------- overwritten methods ----------------------*) PROCEDURE Section*(in: IntermediateCode.Section; out: BinaryCode.Section); VAR oldSpillStackSize: LONGINT; PROCEDURE CheckEmptySpillStack(): BOOLEAN; BEGIN IF spillStack.Size()#0 THEN Error(Basic.invalidPosition,"implementation error, spill stack not cleared"); IF dump # NIL THEN spillStack.Dump(dump); tickets.Dump(dump); END; RETURN FALSE ELSE RETURN TRUE END; END CheckEmptySpillStack; BEGIN physicalRegisters(PhysicalRegisters).SupportFP(FPSupported); supportFP := FPSupported; tickets.Init; spillStack.Init; stackSizeKnown := TRUE; forwardFixups.Init; Section^(in,out); IF ~stackSizeKnown THEN supportFP := TRUE; tickets.Init; spillStack.Init; forwardFixups.Init; out.Reset; physicalRegisters(PhysicalRegisters).SupportFP(TRUE); Section^(in,out); END; IF CheckEmptySpillStack() & (spillStack.MaxSize() >0) THEN forwardFixups.Init; oldSpillStackSize := spillStack.MaxSize(); out.Reset; Section^(in,out); ASSERT(spillStack.MaxSize() = oldSpillStackSize); END; IF CheckEmptySpillStack() THEN END; END Section; PROCEDURE Supported*(CONST instr: IntermediateCode.Instruction; VAR moduleName, procedureName: ARRAY OF CHAR): BOOLEAN; VAR sizeInBits: LONGINT; form: LONGINT; opcode: LONGINT; value: HUGEINT; exp: LONGINT; BEGIN opcode := instr.opcode; form := instr.op1.type.form; COPY(builtinsModuleName, moduleName); IF opcode = IntermediateCode.conv THEN (* conversions between float and integer types in a library *) IF form = IntermediateCode.Float THEN IF instr.op2.type.form = IntermediateCode.Float THEN IF (instr.op1.type.sizeInBits = 32) & (instr.op2.type.sizeInBits = 64) THEN procedureName := "ConvertXR"; RETURN FALSE ELSIF (instr.op1.type.sizeInBits = 64) & (instr.op2.type.sizeInBits = 32) THEN procedureName := "ConvertRX"; RETURN FALSE ELSE HALT(100); END; ELSE ASSERT( instr.op2.type.form = IntermediateCode.SignedInteger); IF (instr.op2.type.sizeInBits = 32) THEN IF instr.op1.type.sizeInBits = 32 THEN procedureName := "ConvertIR"; RETURN FALSE ELSIF instr.op1.type.sizeInBits = 64 THEN procedureName := "ConvertHR"; RETURN FALSE ELSE HALT(100); END; ELSIF (instr.op2.type.sizeInBits=64) THEN IF instr.op1.type.sizeInBits = 32 THEN procedureName := "ConvertIX"; RETURN FALSE ELSIF instr.op1.type.sizeInBits = 64 THEN procedureName := "ConvertHX"; RETURN FALSE ELSE HALT(100); END; ELSE HALT(100); END END; ELSIF instr.op2.type.form = IntermediateCode.Float THEN ASSERT(instr.op1.type.form = IntermediateCode.SignedInteger); IF (instr.op2.type.sizeInBits = 32) THEN IF instr.op1.type.sizeInBits = 32 THEN procedureName := "ConvertRI"; RETURN FALSE ELSIF instr.op1.type.sizeInBits = 64 THEN procedureName := "ConvertRH"; RETURN FALSE ELSE HALT(100); END; ELSIF (instr.op2.type.sizeInBits=64) THEN IF instr.op1.type.sizeInBits = 32 THEN procedureName := "ConvertXI"; RETURN FALSE ELSIF instr.op1.type.sizeInBits = 64 THEN procedureName := "ConvertXH"; RETURN FALSE ELSE HALT(100); END; ELSE HALT(100); END END; ELSIF form IN IntermediateCode.Integer THEN IF instr.op1.type.sizeInBits = IntermediateCode.Bits64 THEN CASE instr.opcode OF IntermediateCode.div: procedureName := "DivH"; RETURN FALSE | IntermediateCode.mod: IF IntermediateCode.IsConstantInteger(instr.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN RETURN TRUE END; procedureName := "ModH"; RETURN FALSE | IntermediateCode.abs: procedureName := "AbsH"; RETURN FALSE; | IntermediateCode.shl : IF instr.op1.type.form = IntermediateCode.SignedInteger THEN procedureName := "AslH"; RETURN FALSE; ELSE procedureName := "LslH"; RETURN FALSE; END; | IntermediateCode.shr : IF instr.op1.type.form = IntermediateCode.SignedInteger THEN procedureName := "AsrH"; RETURN FALSE; ELSE procedureName := "LsrH"; RETURN FALSE; END; | IntermediateCode.ror: procedureName := "RorH"; RETURN FALSE; | IntermediateCode.rol: procedureName := "RolH"; RETURN FALSE; ELSE RETURN TRUE END ELSIF instr.op1.type.sizeInBits = IntermediateCode.Bits32 THEN CASE instr.opcode OF IntermediateCode.div: IF IntermediateCode.IsConstantInteger(instr.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN RETURN TRUE ELSE procedureName := "DivL"; RETURN FALSE END; | IntermediateCode.mod: IF IntermediateCode.IsConstantInteger(instr.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN RETURN TRUE END; procedureName := "ModL"; RETURN FALSE | IntermediateCode.mul: IF (Global.NoMulCapability IN backend.capabilities) THEN (*mul forbidden*) IF IntermediateCode.IsConstantInteger(instr.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN RETURN TRUE ELSE procedureName:="MulL"; RETURN FALSE END; ELSE RETURN TRUE; END ELSE RETURN TRUE END; ELSE sizeInBits := instr.op1.type.sizeInBits; HALT(100) END; ELSIF (form = IntermediateCode.Float) THEN IF instr.op1.type.sizeInBits = IntermediateCode.Bits64 THEN CASE instr.opcode OF | IntermediateCode.add: procedureName := "AddX"; RETURN FALSE; | IntermediateCode.sub: procedureName := "SubX"; RETURN FALSE; | IntermediateCode.mul: procedureName := "MulX"; RETURN FALSE; | IntermediateCode.div: procedureName := "DivX"; RETURN FALSE | IntermediateCode.abs: procedureName := "AbsX"; RETURN FALSE; ELSE RETURN TRUE END; ELSIF instr.op1.type.sizeInBits = IntermediateCode.Bits32 THEN CASE instr.opcode OF | IntermediateCode.add: IF Global.FloatingPointCapability IN backend.capabilities THEN RETURN TRUE ELSE procedureName := "AddR"; RETURN FALSE END | IntermediateCode.sub: IF Global.FloatingPointCapability IN backend.capabilities THEN RETURN TRUE ELSE procedureName := "SubR"; RETURN FALSE END | IntermediateCode.mul: IF Global.FloatingPointCapability IN backend.capabilities THEN RETURN TRUE ELSE procedureName := "MulR"; RETURN FALSE END | IntermediateCode.div: procedureName := "DivR"; RETURN FALSE | IntermediateCode.abs: procedureName := "AbsR"; RETURN FALSE; ELSE RETURN TRUE END; ELSE HALT(100) END; ELSIF form = IntermediateCode.Undefined THEN RETURN TRUE ELSE HALT(100) END; RETURN TRUE END Supported; (* input: type (such as that of an intermediate operand), output: low and high type (such as in low and high type of an operand) *) PROCEDURE GetPartType*(CONST type: IntermediateCode.Type; part: LONGINT; VAR typePart: IntermediateCode.Type); BEGIN ASSERT(type.sizeInBits >0); ASSERT(part < 2); IF (part = 0) OR (type.sizeInBits =64) THEN IntermediateCode.InitType(typePart,type.form,32); ELSE typePart := IntermediateCode.undef END; END GetPartType; PROCEDURE GetSpillOperand(ticket: Ticket; VAR mem: Operand); VAR offset: LONGINT; register: LONGINT; BEGIN D.String("spill stack used in "); Basic.WriteSegmentedName(D.Log, in.name); D.String(": "); D.Int(inPC,1); D.Ln; offset := spillStackPosition-ticket.offset; (* relative to logical frame pointer ! *) register := PhysicalRegister(IntermediateCode.FP,Low,offset); instructionSet.InitMemory(mem, register, offset); END GetSpillOperand; PROCEDURE ToSpillStack*(ticket: Ticket); VAR mem, reg:Operand; BEGIN IF dump # NIL THEN dump.String("spill: "); CodeGenerators.DumpTicket(dump,ticket); dump.Ln; END; GetSpillOperand(ticket,mem); instructionSet.InitRegister(reg,ticket.register); Emit2(opST,reg,mem); END ToSpillStack; PROCEDURE AllocateSpillStack*(size: LONGINT); BEGIN END AllocateSpillStack; PROCEDURE ToRegister*(ticket: Ticket); VAR mem,reg: Operand; BEGIN IF dump # NIL THEN dump.String("unspill: "); CodeGenerators.DumpTicket(dump,ticket); dump.Ln END; GetSpillOperand(ticket,mem); instructionSet.InitRegister(reg,ticket.register); Emit2(opLD,reg,mem); END ToRegister; PROCEDURE ExchangeTickets*(ticket1,ticket2: Ticket); VAR op1,op2,temp: Operand; BEGIN TicketToOperand(ticket1,op1); TicketToOperand(ticket2,op2); GetTemporaryRegister(temp); IF op1.type = InstructionSet.Register THEN ASSERT(op2.type = InstructionSet.Memory); Emit2(opMOV,temp,op1); Emit2(opLD,op1,op2); Emit2(opST,temp,op2); ELSE ASSERT(op2.type = InstructionSet.Register); ASSERT(op1.type = InstructionSet.Memory); Emit2(opMOV,temp,op2); Emit2(opLD,op2,op1); Emit2(opST,temp,op1); END; ReleaseHint(temp.register); (* spill stack not yet supported *) END ExchangeTickets; PROCEDURE CheckFixups; VAR fixup, forward, newFixup: BinaryCode.Fixup; fixupOp: InstructionSet.Operand; checkPC, iterCount: LONGINT; PROCEDURE CheckPC(): LONGINT; CONST safety=16; (* max number of TRM instructions to emit IR instruction *) BEGIN IF patchSpartan6 & out.os.fixed & ((out.pc+out.os.alignment) MOD 1024 < 960) & ((out.pc+out.os.alignment) MOD 1024 > 960-safety) THEN RETURN out.pc + safety + 16 ELSE RETURN out.pc + safety (* assuming that an IR instruction can be emitted within at most 10 instructions *) END; END CheckPC; BEGIN fixup := forwardFixups.Check(CheckPC()); iterCount:=0; WHILE(fixup # NIL) DO INC(iterCount); IF(iterCount>30) THEN D.String("too many iterations in forward fixup");D.Ln; HALT(100); END; (*problem: sometimes causes problems when there are large backwards jumps*) (*but is needed for long jumps in general*) (*!TODO: sometimes leads to infinite loop in instruction sizes <= 14*) (* sometimes, compiler continues to work fine without this section.*) (*apparently this section resolves the multihop jumps, but fails if it's supposed to go backward?*) IF fixup.symbolOffset < inPC THEN (* already resolved ok *) ELSE (* must be handled *) IF TraceFixups THEN D.String("relative branch fixup bits: ");D.Int(instructionSet.RelativeBranchFixupBits,1); D.String(" at inPC="); D.Int(inPC,1); D.String(", outPC="); D.Int(out.pc,1); D.String(", symbol offset=");D.Int(fixup.symbolOffset,1); D.String(", fixup from outPC = "); D.Int(fixup.offset,1); D.String(" to "); fixup.Dump(D.Log); D.String(" forwarded."); D.Ln; END; forward := BrForward(opBT); (* Emit1N(opBT, 1); *) newFixup := BinaryCode.NewFixup(fixup.mode, out.pc, fixup.symbol, fixup.symbolOffset, 0, 0, NIL); fixup.SetSymbol(fixup.symbol.name, fixup.symbol.fingerprint, 0, fixup.displacement+out.pc); ASSERT(ABS(out.pc - fixup.displacement) < 512); instructionSet.InitFixup(fixupOp,0,newFixup); forwardFixups.Enter(newFixup, out.pc, instructionSet.RelativeBranchFixupBits); Emit1(opBT, fixupOp); SetTarget(forward); END; fixup := forwardFixups.Check(CheckPC()); END; END CheckFixups; PROCEDURE IsComplex(CONST operand: IntermediateCode.Operand): BOOLEAN; BEGIN RETURN (operand.type.sizeInBits > 32) END IsComplex; PROCEDURE IsFloat(CONST operand: IntermediateCode.Operand): BOOLEAN; BEGIN RETURN operand.type.form = IntermediateCode.Float END IsFloat; PROCEDURE Generate*(VAR instruction: IntermediateCode.Instruction); VAR opcode: SHORTINT; ticket: Ticket; hwreg, lastUse: LONGINT; BEGIN CheckFixups; (* IF ((instruction.opcode = IntermediateCode.mov) OR (instruction.opcode = IntermediateCode.pop)) & (instruction.op1.register <= IntermediateCode.ParameterRegister) THEN hwreg := ParameterRegister(IntermediateCode.ParameterRegister-instruction.op1.register, instruction.op1.type); Spill(physicalRegisters.Mapped(hwreg)); lastUse := inPC+1; WHILE (lastUse < in.pc) & ((in.instructions[lastUse].opcode # IntermediateCode.push) OR (in.instructions[lastUse].op1.register # instruction.op1.register)) & (in.instructions[lastUse].opcode # IntermediateCode.call) DO INC(lastUse) END; ticket := ReservePhysicalRegister(instruction.op1.type,hwreg,lastUse); END; *) ReserveOperandRegisters(instruction.op1,TRUE); ReserveOperandRegisters(instruction.op2,TRUE);ReserveOperandRegisters(instruction.op3,TRUE); opcode := instruction.opcode; CASE opcode OF IntermediateCode.nop: (* do nothing *) |IntermediateCode.mov: EmitMov(instruction.op1,instruction.op2,Low); IF IsComplex(instruction.op1) THEN EmitMov(instruction.op1,instruction.op2,High) END; |IntermediateCode.conv: EmitConv(instruction); |IntermediateCode.call: EmitCall(instruction); |IntermediateCode.enter: EmitEnter(instruction); |IntermediateCode.leave: EmitLeave(instruction); |IntermediateCode.exit: EmitExit(instruction); |IntermediateCode.return: EmitReturn(instruction,Low); IF IsComplex(instruction.op1) THEN EmitReturn(instruction,High) END; |IntermediateCode.result: EmitResult(instruction,Low); IF IsComplex(instruction.op1) THEN EmitResult(instruction,High) END; |IntermediateCode.trap: EmitTrap(instruction); |IntermediateCode.br .. IntermediateCode.brlt: EmitBr(instruction) |IntermediateCode.pop: EmitPop(instruction.op1,Low); IF IsComplex(instruction.op1) THEN EmitPop(instruction.op1,High); END; |IntermediateCode.push: IF IsComplex(instruction.op1) THEN EmitPush(instruction.op1,High); END; EmitPush(instruction.op1,Low); |IntermediateCode.neg: EmitNeg(instruction); |IntermediateCode.not: EmitNot(instruction,Low); IF IsComplex(instruction.op1) THEN EmitNot(instruction,High) END; |IntermediateCode.abs: EmitAbs(instruction); |IntermediateCode.mul: IF IsFloat(instruction.op1) THEN EmitFMul(instruction) ELSE EmitMul(instruction) END |IntermediateCode.div: EmitDiv(instruction); |IntermediateCode.mod: EmitMod(instruction); |IntermediateCode.sub: IF IsFloat(instruction.op1) THEN EmitFSub(instruction) ELSE EmitSub(instruction) END |IntermediateCode.add: IF IsFloat(instruction.op1) THEN EmitFAdd(instruction) ELSE EmitAdd(instruction) END |IntermediateCode.and: EmitAnd(instruction); |IntermediateCode.or: EmitOr(instruction,Low); IF IsComplex(instruction.op1) THEN EmitOr(instruction,High) END; |IntermediateCode.xor: EmitXor(instruction,Low); IF IsComplex(instruction.op1) THEN EmitXor(instruction,High) END; |IntermediateCode.shl: EmitShift(instruction); |IntermediateCode.shr: EmitShift(instruction); |IntermediateCode.rol: EmitShift(instruction); |IntermediateCode.ror: EmitShift(instruction); |IntermediateCode.copy: EmitCopy(instruction); |IntermediateCode.fill: EmitFill(instruction, FALSE); |IntermediateCode.asm: EmitAsm(instruction); END; ReserveOperandRegisters(instruction.op3,FALSE); ReserveOperandRegisters(instruction.op2,FALSE); ReserveOperandRegisters(instruction.op1,FALSE); END Generate; PROCEDURE PostGenerate*(CONST instruction: IntermediateCode.Instruction); VAR ticket: Ticket; BEGIN TryUnmap(instruction.op3); TryUnmap(instruction.op2); TryUnmap(instruction.op1); ticket := tickets.live; WHILE (ticket # NIL) & (ticket.lastuse = inPC) DO UnmapTicket(ticket); ticket := tickets.live END; END PostGenerate; PROCEDURE TicketToOperand(ticket:Ticket; VAR op: InstructionSet.Operand); BEGIN ASSERT(ticket # NIL); IF ticket.spilled THEN GetSpillOperand(ticket,op); ELSE instructionSet.InitRegister(op,ticket.register) END; END TicketToOperand; (* updateStackSize is important as intermediate RETURNS should not change stack size *) PROCEDURE AllocateStack(size: LONGINT; updateStackSize: BOOLEAN); VAR sizeOperand: InstructionSet.Operand; BEGIN inStackAllocation := TRUE; IF size > 0 THEN IF size < ASH(1,instructionSet.ImmediateFixupBits) THEN instructionSet.InitImmediate(sizeOperand, 0, size) ELSE ImmediateToOperand(size,Low,FALSE,instructionSet.ImmediateFixupBits,sizeOperand) END; Emit2(opSUB, opSP, sizeOperand); IF updateStackSize THEN INC(stackSize, size) END; ELSIF size < 0 THEN size := -size; IF size < ASH(1,instructionSet.ImmediateFixupBits) THEN instructionSet.InitImmediate(sizeOperand, 0, size); ELSE ImmediateToOperand(size,Low, FALSE, instructionSet.ImmediateFixupBits,sizeOperand); END; Emit2(opADD, opSP, sizeOperand); IF updateStackSize THEN DEC(stackSize, size) END; END; inStackAllocation := FALSE; END AllocateStack; PROCEDURE EmitEnter(CONST instr: IntermediateCode.Instruction); VAR cc: LONGINT; mem: InstructionSet.Operand; BEGIN stackSize := 0; (* stack layout: p1 ... pm (parameters pushed by caller) LR (explicitly pushed by frontend because hasLinkRegister = TRUE) prev FP <-- FP = logicalFP (explicitly pushed by frontend) v1 ... vn spill1 <- logicalFP + spillStackPosition (negative) ... spilln <-- SP *) cc := SHORT(instr.op1.intValue); spillStackPosition := - LONGINT(instr.op2.intValue)-1; (* relative to logical frame pointer ! *) AllocateStack(LONGINT(instr.op2.intValue+spillStack.MaxSize()), TRUE); END EmitEnter; PROCEDURE EmitLeave(CONST instr: IntermediateCode.Instruction); VAR cc: LONGINT; mem: InstructionSet.Operand; BEGIN IF ~supportFP THEN (* frame pointer might have been used *) AllocateStack(-stackSize, FALSE); Emit2(opMOV, opFP, opSP); END; END EmitLeave; PROCEDURE EmitExit(CONST instr: IntermediateCode.Instruction); VAR cc: LONGINT; mem: InstructionSet.Operand; BEGIN instructionSet.InitMemory(mem, InstructionSet.SP, 0); Emit2(opLD, opLR, mem); AllocateStack(-1,FALSE); Emit1(opBR, opLR); END EmitExit; PROCEDURE ResultRegister(part: LONGINT): InstructionSet.Operand; VAR register: InstructionSet.Operand; BEGIN IF part = Low THEN instructionSet.InitRegister(register,0) ELSE instructionSet.InitRegister(register,1) END; RETURN register END ResultRegister; PROCEDURE EmitResult(VAR instr: IntermediateCode.Instruction; part: LONGINT); VAR op,result: Operand; BEGIN AcquireDestinationRegister(instr.op1, part,op); result := ResultRegister(part); MovIfDifferent(op, result); ReleaseDestinationRegister(instr.op1,part,op); END EmitResult; PROCEDURE EmitReturn(VAR instr: IntermediateCode.Instruction; part: LONGINT); VAR op,result: Operand; BEGIN MakeRegister(instr.op1,part,op); result := ResultRegister(part); MovIfDifferent(result, op); END EmitReturn; PROCEDURE EmitMov(VAR vop1,vop2: IntermediateCode.Operand; part: LONGINT); VAR left,right: Operand; rightTicket: Ticket; neg: BOOLEAN; BEGIN rightTicket := NIL; IF vop2.mode = IntermediateCode.ModeMemory THEN (*GetMemory(vop2,part,right,rightTicket);*) (* done in load *) ELSIF ~UnsignedImmediate(vop2,part,instructionSet.ImmediateFixupBits,FALSE,neg,right) THEN MakeRegister(vop2,part,right); ReleaseHint(right.register); END; AcquireDestinationRegister(vop1,part,left); IF vop2.mode = IntermediateCode.ModeMemory THEN Load(vop2,part,left); ELSE MovIfDifferent(left, right); END; IF vop1.mode = IntermediateCode.ModeMemory THEN Store(vop1,part,left); END; ReleaseHint(left.register); END EmitMov; PROCEDURE EmitConv(VAR instr: IntermediateCode.Instruction); VAR left,right,temp: Operand; srcSize, destSize: LONGINT; BEGIN srcSize := instr.op2.type.sizeInBits; destSize := instr.op1.type.sizeInBits; ASSERT( (srcSize = 32) OR (srcSize = 64)); ASSERT( (destSize = 32) OR (destSize = 64)); ASSERT(instr.op1.type.form IN IntermediateCode.Integer); ASSERT(instr.op2.type.form IN IntermediateCode.Integer); IF srcSize >= destSize THEN MakeRegister(instr.op2,Low,right); ReleaseHint(right.register); AcquireDestinationRegister(instr.op1,Low,left); MovIfDifferent(left, right); ReleaseDestinationRegister(instr.op1,Low, left); ELSE MakeRegister(instr.op2, Low, right); ReleaseHint(right.register); AcquireDestinationRegister(instr.op1,Low,left); MovIfDifferent(left,right); ReleaseDestinationRegister(instr.op1,Low,left); IF (instr.op2.type.form = IntermediateCode.SignedInteger) & (instr.op1.type.form = IntermediateCode.SignedInteger) THEN GetTemporaryRegister(temp); Emit2(opMOV, temp,left); AcquireDestinationRegister(instr.op1,High,left); Emit2(opMOV, left, temp); Emit2N(opROR, temp, 31); Emit2N(opAND, temp, 1); Emit2(opNOT, left, temp); Emit2N(opADD, left, 1); ELSE AcquireDestinationRegister(instr.op1,High,left); Emit2N(opMOV, left, 0); END; ReleaseDestinationRegister(instr.op1,High,left); END; END EmitConv; PROCEDURE Resolve(VAR op: IntermediateCode.Operand); BEGIN IF (op.symbol.name # "") & (op.resolved = NIL) THEN op.resolved := module.allSections.FindByName(op.symbol.name) END; END Resolve; PROCEDURE EmitCall(VAR instruction: IntermediateCode.Instruction); VAR op: InstructionSet.Operand; section: IntermediateCode.Section; code: BinaryCode.Section; symbol: ObjectFile.Identifier; fixup, newFixup: BinaryCode.Fixup; pc: LONGINT; regOp: Operand; offset,reloffset: LONGINT; BEGIN IF (instruction.op1.symbol.name # "") & (instruction.op1.mode # IntermediateCode.ModeMemory) THEN Resolve(instruction.op1); IF instruction.op1.resolved # NIL THEN section := instruction.op1.resolved(IntermediateCode.Section); END; IF (section # NIL) & (section.type = Sections.InlineCodeSection) THEN code := section.resolved; ASSERT(code # NIL); out.CopyBits(code.os.bits, 0, code.os.bits.GetSize()); fixup := code.fixupList.firstFixup; pc := code.pc; WHILE (fixup # NIL) DO newFixup := BinaryCode.NewFixup(fixup.mode, fixup.offset+pc, fixup.symbol, fixup.symbolOffset, fixup.displacement, fixup.scale, fixup.pattern); out.fixupList.AddFixup(newFixup); fixup := fixup.nextFixup; END; ELSE IF out.os.fixed THEN (* only if my own address is already known .. *) offset := GetSymbolOffset(instruction.op1, symbol); ELSE offset := instruction.op1.offset; Resolve(instruction.op1); symbol := instruction.op1.symbol; END; reloffset := offset - out.pc-out.os.alignment-1; IF symbol.name # "" THEN fixup := BinaryCode.NewFixup(BinaryCode.Relative,out.pc,symbol, offset, 0, 0, NIL); instructionSet.InitFixup(op, 32, fixup); Emit1(opBL, op); ELSIF (-ASH(1,instructionSet.BranchAndLinkFixupBits-1) <= reloffset) & (reloffset < ASH(1,instructionSet.BranchAndLinkFixupBits-1)) THEN ImmediateToOperand(reloffset, Low, TRUE, instructionSet.BranchAndLinkFixupBits,op); ASSERT(op.type = InstructionSet.Immediate); Emit1(opBL, op); ELSE GetTemporaryRegister(op); ImmediateToOperand(offset, Low, FALSE, instructionSet.ImmediateFixupBits,op); ASSERT(op.type = InstructionSet.Register); Emit2(opBLR, opLR, op); END; END; ELSE MakeRegister(instruction.op1,Low,regOp); Emit2(opBLR, opLR, regOp); END; AllocateStack(-SHORT(instruction.op2.intValue), TRUE) END EmitCall; PROCEDURE GetImmediate32(val: LONGINT; CONST reg: InstructionSet.Operand; emit: BOOLEAN): LONGINT; VAR ops: LONGINT; set: SET; PROCEDURE Add(val,pos: LONGINT; VAR first: BOOLEAN): LONGINT; VAR imm: InstructionSet.Operand; ops: LONGINT; op: InstructionSet.Operand; BEGIN instructionSet.InitImmediate(imm, 0, val); IF pos # 0 THEN IF first THEN ops := 2; IF emit THEN Emit2(opMOV, reg, imm); instructionSet.InitImmediate(imm, 0, 32-pos); (*!TODO: if instruction width is <=13, immediate for ror is so small it can't express this number!*) Emit2(opROR, reg, imm); END; ELSE ops := 3; IF emit THEN GetTemporaryRegister(op); Emit2(opMOV, op, imm); instructionSet.InitImmediate(imm, 0, 32-pos); Emit2(opROR, op, imm); Emit2(opADD, reg, op); ReleaseHint(op.register); END; END; ELSE ops := 1; IF emit THEN Emit2(opADD, reg, imm) END; END; first := FALSE; RETURN ops END Add; PROCEDURE Compute(val: SET): LONGINT; VAR v,i: LONGINT; ops: LONGINT; first: BOOLEAN; BEGIN v := 0; ops := 0; first := TRUE; FOR i := 31 TO 0 BY -1 DO v := v * 2; IF i IN val THEN INC(v) END; IF v*2 >= ASH(1,instructionSet.ImmediateFixupBits) THEN ops := ops + Add(v,i,first); v := 0; END; END; IF v # 0 THEN ops := ops + Add(v,0,first) END; RETURN ops END Compute; BEGIN set := SYSTEM.VAL(SET,val); ops := Compute(set); RETURN ops END GetImmediate32; PROCEDURE ImmediateToOperand(imm: HUGEINT; part: LONGINT; signed: BOOLEAN; bits: LONGINT; VAR op: Operand); VAR immOp: InstructionSet.Operand; maxImmValue, minImmValue : LONGINT; PROCEDURE ImmediateToOp32(imm: LONGINT; VAR op: InstructionSet.Operand); VAR ops: LONGINT; BEGIN IF (imm>=0) & (imm < ASH(1,instructionSet.ImmediateFixupBits)) THEN instructionSet.InitImmediate(immOp, 0, imm); Emit2(opMOV, op, immOp); ELSIF (imm <0) & (imm > MIN(LONGINT)) & (ABS(imm) < ASH(1,instructionSet.ImmediateFixupBits)) THEN instructionSet.InitImmediate(immOp, 0, 0); Emit2(opMOV, op, immOp); instructionSet.InitImmediate(immOp, 0, ABS(imm)); Emit2(opSUB, op, immOp); ELSE ops := GetImmediate32(imm, op, TRUE); END; END ImmediateToOp32; BEGIN IF signed THEN minImmValue := -ASH(1,bits-1); maxImmValue := ASH(1,bits-1)-1; ELSE minImmValue := 0; maxImmValue := ASH(1,bits)-1 END; IF (op.type # InstructionSet.Register) & (imm >=minImmValue) & (imm <=maxImmValue) THEN (* immediate operand *) IF part = Low THEN instructionSet.InitImmediate(op,0,SHORT(imm)); ELSE instructionSet.InitImmediate(op,0,0); END; ELSE IF op.type # InstructionSet.Register THEN GetTemporaryRegister(op); END; IF part = Low THEN ImmediateToOp32(SHORT(imm), op) ELSE ImmediateToOp32(SHORT(imm DIV 10000H DIV 10000H),op); END END; END ImmediateToOperand; PROCEDURE MakeRegister(VAR vop: IntermediateCode.Operand; part: LONGINT; VAR rop: Operand); VAR virtualReg: LONGINT; tmp, imm: Operand; offset: LONGINT; symbol: ObjectFile.Identifier; sizeInBits: LONGINT; BEGIN (*InstructionSet.InitOperand(rop); *) instructionSet.InitOperand(imm); sizeInBits := vop.type.sizeInBits; virtualReg := vop.register; offset := GetSymbolOffset(vop,symbol); CASE vop.mode OF IntermediateCode.ModeMemory: GetTemporaryRegister(rop); Load(vop,part,rop); |IntermediateCode.ModeRegister: GetRegister(vop,part,rop); |IntermediateCode.ModeImmediate: IF symbol.name # "" THEN instructionSet.InitFixup(tmp, 14, BinaryCode.NewFixup(BinaryCode.Absolute,out.pc,vop.symbol, vop.symbolOffset, vop.offset,0,NIL)); GetTemporaryRegister(rop); Emit2(opMOV, rop, tmp); ELSE IF vop.type.form IN IntermediateCode.Integer THEN ASSERT ((vop.intValue = 0) OR (offset = 0)); ImmediateToOperand(vop.intValue+offset, part, FALSE, instructionSet.ImmediateFixupBits,rop); ELSE ASSERT(vop.type.form = IntermediateCode.Float); ASSERT(vop.type.sizeInBits=32); ImmediateToOperand(BinaryCode.ConvertReal(SHORT(vop.floatValue)),part,FALSE,instructionSet.ImmediateFixupBits,rop); END; IF rop.type # InstructionSet.Register THEN GetTemporaryRegister(tmp); Emit2(opMOV, tmp, rop); rop := tmp END; END; ELSE HALT(200) END; END MakeRegister; (* if the symbol has a statically known offset then return offset and set resulting section to nil, otherwise do not set resulting section to nil *) PROCEDURE GetSymbolOffset(VAR vop: IntermediateCode.Operand; VAR sectionName: ObjectFile.Identifier): LONGINT; VAR offset: LONGINT; section: Sections.Section; BEGIN sectionName := vop.symbol; Resolve(vop); section := vop.resolved; offset := vop.offset; IF (section # NIL) & (section(IntermediateCode.Section).resolved # NIL) & (section(IntermediateCode.Section).resolved.os.fixed) THEN INC(offset, section(IntermediateCode.Section).resolved.os.alignment); IF vop.symbolOffset > 0 THEN INC(offset, section(IntermediateCode.Section).instructions[vop.symbolOffset].pc); END; sectionName.name := ""; END; RETURN offset END GetSymbolOffset; PROCEDURE GetMemory(VAR vop: IntermediateCode.Operand; part: LONGINT; VAR memoryOperand: InstructionSet.Operand; ticket: Ticket); VAR virtualReg: LONGINT; register: LONGINT; registerOperand, temporary: InstructionSet.Operand; symbol: ObjectFile.Identifier; offset: LONGINT; BEGIN virtualReg := vop.register; ASSERT(vop.mode = IntermediateCode.ModeMemory); offset := GetSymbolOffset(vop, symbol) + part; register := PhysicalRegister(vop.register,Low,offset); IF register = None THEN IF symbol.name = "" THEN offset := offset + SHORT(vop.intValue); END; register := InstructionSet.None; END; IF (0<=offset) & (offset < ASH(1,instructionSet.MemoryOffsetFixupBits)) THEN instructionSet.InitMemory(memoryOperand, register, offset); ELSE IF ticket = NIL THEN ticket := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); END; TicketToOperand(ticket, temporary); ImmediateToOperand(offset, Low, FALSE, instructionSet.ImmediateFixupBits,temporary); instructionSet.InitRegister(registerOperand,register); IF register # InstructionSet.None THEN Emit2(opADD,temporary,registerOperand); END; instructionSet.InitMemory(memoryOperand, temporary.register, 0); END; IF symbol.name # "" THEN instructionSet.AddFixup(memoryOperand, BinaryCode.NewFixup(BinaryCode.Absolute, 0, symbol, vop.symbolOffset, offset, 0, NIL)); END; END GetMemory; PROCEDURE Load(VAR vop: IntermediateCode.Operand; part: LONGINT; CONST register: Operand); VAR memoryOperand: Operand; BEGIN ASSERT(register.type = InstructionSet.Register); GetMemory(vop,part,memoryOperand,physicalRegisters.Mapped(register.register)); Emit2(opLD,register,memoryOperand); END Load; PROCEDURE Store(VAR vop: IntermediateCode.Operand; part: LONGINT; CONST register: Operand); VAR memoryOperand: Operand; BEGIN GetMemory(vop,part,memoryOperand,NIL); Emit2(opST,register,memoryOperand); END Store; PROCEDURE UnsignedImmediate(vop: IntermediateCode.Operand; part: LONGINT; bits: LONGINT; allowNegation: BOOLEAN; VAR neg: BOOLEAN; VAR rop: Operand): BOOLEAN; VAR value,offset : LONGINT; symbol: ObjectFile.Identifier; BEGIN IF (vop.mode = IntermediateCode.ModeImmediate) THEN offset := GetSymbolOffset(vop, symbol); IF part = Low THEN value := SHORT(vop.intValue + offset); ELSE value := SHORT((vop.intValue + offset) DIV 1000H DIV 1000H); END; IF symbol.name # "" THEN RETURN FALSE ELSIF vop.type.form = IntermediateCode.Float THEN RETURN FALSE ELSIF (value >= 0) & (value < ASH(1,bits)) THEN instructionSet.InitImmediate(rop, 0, value); neg := FALSE; RETURN TRUE ELSIF allowNegation & (value <0) & (value # MIN(LONGINT)) & (-value < ASH(1,bits)) THEN instructionSet.InitImmediate(rop, 0, -value); neg := TRUE; RETURN TRUE END; END; RETURN FALSE END UnsignedImmediate; PROCEDURE HardwareIntegerRegister(index: LONGINT; sizeInBits: LONGINT): LONGINT; BEGIN RETURN index END HardwareIntegerRegister; PROCEDURE HardwareFloatRegister(index: LONGINT; sizeInBits: LONGINT): LONGINT; BEGIN RETURN index END HardwareFloatRegister; PROCEDURE GetTypedHardwareRegister(index: LONGINT; type: IntermediateCode.Type): LONGINT; VAR size: LONGINT; BEGIN IF type.form IN IntermediateCode.Integer THEN RETURN HardwareIntegerRegister(index, type.sizeInBits) ELSIF type.form = IntermediateCode.Float THEN RETURN HardwareFloatRegister(index, type.sizeInBits) ELSE HALT(100); END; END GetTypedHardwareRegister; PROCEDURE ParameterRegister(CONST type: IntermediateCode.Type; index: LONGINT): LONGINT; BEGIN RETURN GetTypedHardwareRegister(index, type) END ParameterRegister; PROCEDURE PhysicalRegister(virtualReg: LONGINT; part: LONGINT; VAR offset: LONGINT): LONGINT; VAR register: LONGINT; fpOffset: LONGINT; ticket: Ticket; BEGIN IF virtualReg = IntermediateCode.FP THEN IF stackSizeKnown THEN register := InstructionSet.SP; INC(offset, stackSize); ELSE (* stack size unknown, actually fp must be supported *) register := InstructionSet.FP; END; ELSIF virtualReg = IntermediateCode.SP THEN register := InstructionSet.SP; ELSIF virtualReg = IntermediateCode.LR THEN register := InstructionSet.LR; (*!ELSIF virtualReg <= IntermediateCode.ParameterRegister THEN register := ParameterRegister(IntermediateCode.ParameterRegister-virtualReg, IntermediateCode.int32); *) ELSE ticket := virtualRegisters.Mapped(virtualReg,part); IF ticket = NIL THEN register := None ELSE UnSpill(ticket); register := ticket.register END; END; RETURN register END PhysicalRegister; PROCEDURE GetRegister(CONST virtual: IntermediateCode.Operand; part:LONGINT; VAR physical: Operand); VAR type: IntermediateCode.Type; virtualRegister, physicalRegister: LONGINT; tmp,imm: Operand; offset: LONGINT; ticket: Ticket; ops: LONGINT; BEGIN ASSERT(virtual.mode = IntermediateCode.ModeRegister); GetPartType(virtual.type,part,type); virtualRegister := virtual.register; offset := virtual.offset; physicalRegister := PhysicalRegister(virtual.register,part,offset); instructionSet.InitRegister(physical, physicalRegister); IF offset # 0 THEN (* offset := virtual.offset; *) Assert(type.form # IntermediateCode.Float,"forbidden offset on float"); ReleaseHint(physical.register); GetTemporaryRegister(tmp); MovIfDifferent(tmp, physical); physical := tmp; IF (offset >= 0) & (offset < ASH(1,instructionSet.ImmediateFixupBits)) THEN instructionSet.InitImmediate(imm, 0, offset); Emit2(opADD,physical,imm); ELSIF (offset <0) & (-offset < ASH(1,instructionSet.ImmediateFixupBits)) THEN instructionSet.InitImmediate(imm, 0, -offset); Emit2(opSUB,physical,imm); ELSE GetTemporaryRegister(tmp); ops := GetImmediate32(offset,tmp,TRUE); Emit2(opADD,physical,tmp); ReleaseHint(tmp.register); END; END; END GetRegister; PROCEDURE IsSameRegister(CONST a, b : InstructionSet.Operand) : BOOLEAN; BEGIN IF (a.fixup # NIL) OR (b.fixup # NIL) OR (a.type # InstructionSet.Register) OR (b.type # InstructionSet.Register) THEN RETURN FALSE END; RETURN a.register = b.register; END IsSameRegister; PROCEDURE MovIfDifferent(CONST a,b: InstructionSet.Operand); BEGIN IF ~IsSameRegister(a,b) THEN Emit2(opMOV, a, b) END; END MovIfDifferent; PROCEDURE AcquireDestinationRegister(CONST vop: IntermediateCode.Operand; part: LONGINT; VAR op: Operand); VAR type: IntermediateCode.Type; BEGIN GetPartType(vop.type,part,type); IF vop.mode = IntermediateCode.ModeMemory THEN GetTemporaryRegister(op); ELSE IF virtualRegisters.Mapped(vop.register,part)=NIL THEN TryAllocate(vop,part); END; GetRegister(vop,part,op); END; END AcquireDestinationRegister; PROCEDURE PrepareOp3(CONST instruction: IntermediateCode.Instruction;part: LONGINT; allowNegation: BOOLEAN; VAR negate: BOOLEAN; VAR dest, left, right: Assembler.Operand); VAR vop1,vop2, vop3: IntermediateCode.Operand; op2: InstructionSet.Operand; opx: Operand; BEGIN vop1 := instruction.op1; vop2 := instruction.op2; vop3 := instruction.op3; IF (IntermediateCode.Commute23 IN IntermediateCode.instructionFormat[instruction.opcode].flags) THEN IF IntermediateCode.OperandEquals(vop1,vop3) OR UnsignedImmediate(vop2,part,instructionSet.ImmediateFixupBits,FALSE,negate,right) THEN vop3 := instruction.op2; vop2 := instruction.op3; END; END; IF ~UnsignedImmediate(vop3, part, instructionSet.ImmediateFixupBits, allowNegation, negate,right) THEN instructionSet.InitOperand(right); MakeRegister(vop3,part,right); END; MakeRegister(vop2,part,op2); ReleaseHint(op2.register); AcquireDestinationRegister(vop1,part,left); dest := left; IF ~IsSameRegister(left,op2) THEN IF IsSameRegister(left,right) THEN GetTemporaryRegister(opx); MovIfDifferent(opx, op2); dest := left; left := opx; ELSE MovIfDifferent(left, op2); END; END; END PrepareOp3; PROCEDURE PrepareFOp3(CONST instruction: IntermediateCode.Instruction; VAR dest, left, right: Assembler.Operand); VAR vop1,vop2, vop3: IntermediateCode.Operand; op2: InstructionSet.Operand; opx: Operand; BEGIN vop1 := instruction.op1; vop2 := instruction.op2; vop3 := instruction.op3; instructionSet.InitOperand(right); MakeRegister(vop3,Low,right); MakeRegister(vop2,Low,op2); ReleaseHint(op2.register); AcquireDestinationRegister(vop1,Low,left); dest := left; IF ~IsSameRegister(left,op2) THEN IF IsSameRegister(left,right) THEN GetTemporaryRegister(opx); MovIfDifferent(opx, op2); dest := left; left := opx; ELSE MovIfDifferent(left, op2); END; END; END PrepareFOp3; PROCEDURE PrepareOp2(CONST instruction: IntermediateCode.Instruction;part: LONGINT; allowNegation: BOOLEAN; VAR negate: BOOLEAN; VAR left, right: Assembler.Operand); VAR vop1,vop2: IntermediateCode.Operand; BEGIN vop1 := instruction.op1; vop2 := instruction.op2; IF ~UnsignedImmediate(vop2, part, instructionSet.ImmediateFixupBits, allowNegation, negate,right) THEN instructionSet.InitOperand(right); MakeRegister(vop2,part,right); END; ReleaseHint(right.register); AcquireDestinationRegister(vop1,part,left); END PrepareOp2; PROCEDURE ReleaseDestinationRegister(VAR vop: IntermediateCode.Operand; part: LONGINT; left: Assembler.Operand); BEGIN IF vop.mode = IntermediateCode.ModeMemory THEN ASSERT(left.type = InstructionSet.Register); Store(vop,part,left); ReleaseHint(left.register); END; END ReleaseDestinationRegister; PROCEDURE FinishOp(VAR vop: IntermediateCode.Operand; part: LONGINT; dest, left: Assembler.Operand); VAR op: Operand; BEGIN IF vop.mode = IntermediateCode.ModeMemory THEN ASSERT(left.type = InstructionSet.Register); Store(vop,part,left); ReleaseHint(left.register); ELSIF dest.register # left.register THEN Emit2(opMOV, dest, left); END; END FinishOp; PROCEDURE EmitAdd(VAR instruction: IntermediateCode.Instruction); VAR destLow, destHigh, leftLow,rightLow,leftHigh,rightHigh: InstructionSet.Operand;negateLow,negateHigh: BOOLEAN; fixup: BinaryCode.Fixup; BEGIN PrepareOp3(instruction,Low,TRUE,negateLow,destLow, leftLow,rightLow); IF IsComplex(instruction.op1) THEN PrepareOp3(instruction,High,TRUE,negateHigh,destHigh, leftHigh,rightHigh); END; IF negateLow THEN Emit2(opSUB,leftLow,rightLow) ELSE Emit2(opADD,leftLow,rightLow) END; FinishOp(instruction.op1,Low,destLow, leftLow); IF IsComplex(instruction.op1) THEN fixup := BrForward(opBB); (* Emit1N(opBB, 1); *) Emit2N(opADD, leftHigh, 1); SetTarget(fixup); IF negateHigh THEN Emit2(opSUB,leftHigh,rightHigh) ELSE Emit2(opADD,leftHigh,rightHigh) END; FinishOp(instruction.op1,High,destHigh, leftHigh); END; END EmitAdd; PROCEDURE EmitFAdd(VAR instruction: IntermediateCode.Instruction); VAR destLow, destHigh, leftLow, rightLow, leftHigh, rightHigh: Operand; negateLow, negateHigh: BOOLEAN; BEGIN PrepareFOp3(instruction,destLow, leftLow,rightLow); Emit2(opFADD,leftLow,rightLow); FinishOp(instruction.op1,Low,destLow, leftLow); END EmitFAdd; PROCEDURE EmitSub(VAR instruction: IntermediateCode.Instruction); VAR destLow, destHigh, leftLow, rightLow, leftHigh, rightHigh: Operand; negateLow, negateHigh: BOOLEAN; fixup: BinaryCode.Fixup; BEGIN IF (instruction.op1.mode = IntermediateCode.ModeRegister) & (instruction.op1.register = IntermediateCode.SP) & (instruction.op2.mode = IntermediateCode.ModeRegister) & (instruction.op2.register = IntermediateCode.SP) & (instruction.op3.mode = IntermediateCode.ModeImmediate) & (instruction.op3.symbol.name = "") THEN AllocateStack(SHORT(instruction.op3.intValue), TRUE); RETURN END; PrepareOp3(instruction,Low,TRUE,negateLow, destLow, leftLow,rightLow); IF IsComplex(instruction.op1) THEN PrepareOp3(instruction,High,TRUE,negateHigh,destHigh, leftHigh,rightHigh); IF negateHigh THEN Emit2(opADD,leftHigh,rightHigh) ELSE Emit2(opSUB,leftHigh,rightHigh) END; END; IF negateLow THEN Emit2(opADD,leftLow,rightLow) ELSE Emit2(opSUB,leftLow,rightLow) END; FinishOp(instruction.op1,Low,destLow, leftLow); IF IsComplex(instruction.op1) THEN fixup := BrForward(opBAE); (*  Emit1N(opBAE, 1);  *) Emit2N(opSUB,leftHigh, 1); SetTarget(fixup); FinishOp(instruction.op1,High,destHigh, leftHigh) END; END EmitSub; PROCEDURE EmitFSub(VAR instruction: IntermediateCode.Instruction); VAR destLow, destHigh, leftLow, rightLow, leftHigh, rightHigh: Operand; negateLow, negateHigh: BOOLEAN; BEGIN PrepareFOp3(instruction,destLow, leftLow,rightLow); Emit2(opFSUB,leftLow,rightLow); FinishOp(instruction.op1,Low,destLow, leftLow); END EmitFSub; PROCEDURE EmitMul(VAR instruction: IntermediateCode.Instruction); VAR negate: BOOLEAN; op1Low, op2Low, op3Low, op1High, op2High, op3High, destLow, destHigh: Operand; value: HUGEINT; exp: LONGINT; iop3: IntermediateCode.Operand; inst: IntermediateCode.Instruction; BEGIN IF IntermediateCode.IsConstantInteger(instruction.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN IntermediateCode.InitImmediate(iop3, instruction.op3.type, exp); IntermediateCode.InitInstruction(inst, Basic.invalidPosition, IntermediateCode.shl, instruction.op1, instruction.op2, iop3); EmitShift(inst); RETURN; END; IF ~IsComplex(instruction.op1) THEN PrepareOp3(instruction,Low,FALSE,negate,destLow, op1Low,op2Low); Emit2(opMUL,op1Low,op2Low); FinishOp(instruction.op1,Low,destLow, op1Low) ELSE AcquireDestinationRegister(instruction.op1,Low,op1Low); AcquireDestinationRegister(instruction.op1,High,op1High); MakeRegister(instruction.op2,Low,op2Low); MakeRegister(instruction.op2,High,op2High); MakeRegister(instruction.op3,Low,op3Low); MakeRegister(instruction.op3,High,op3High); Emit2(opMOV, op1Low, op2Low); Emit2(opMUL, op1Low, op3Low); Emit1(opLDH, op1High); Emit2(opMUL, op2High, op3Low); Emit2(opADD, op1High, op2High); Emit2(opMUL, op2Low, op3High); Emit2(opADD, op1High, op2Low); ReleaseDestinationRegister(instruction.op1,Low,op1Low); ReleaseDestinationRegister(instruction.op1,High,op1High); END; END EmitMul; PROCEDURE EmitFMul(VAR instruction: IntermediateCode.Instruction); VAR destLow, destHigh, leftLow, rightLow, leftHigh, rightHigh: Operand; negateLow, negateHigh: BOOLEAN; BEGIN PrepareFOp3(instruction,destLow, leftLow,rightLow); Emit2(opFMUL,leftLow,rightLow); FinishOp(instruction.op1,Low,destLow, leftLow); END EmitFMul; PROCEDURE EmitDiv(CONST instruction: IntermediateCode.Instruction); VAR value: HUGEINT; exp: LONGINT; iop3: IntermediateCode.Operand; inst: IntermediateCode.Instruction; BEGIN IF instruction.opcode = IntermediateCode.div THEN IF IntermediateCode.IsConstantInteger(instruction.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN IntermediateCode.InitImmediate(iop3, instruction.op3.type, exp); IntermediateCode.InitInstruction(inst, Basic.invalidPosition, IntermediateCode.shr, instruction.op1, instruction.op2, iop3); EmitShift(inst); RETURN; END; END; HALT(100); (*! div is not supported by hardware, must be runtime call -- cf. method Supported *) END EmitDiv; (* undefined for float and huegint, huegint version as library *) PROCEDURE EmitMod(CONST instruction: IntermediateCode.Instruction); VAR value: HUGEINT;exp: LONGINT; op3:IntermediateCode.Operand; inst: IntermediateCode.Instruction; BEGIN IF IntermediateCode.IsConstantInteger(instruction.op3,value) & IntermediateBackend.PowerOf2(value,exp) THEN IntermediateCode.InitImmediate(op3, instruction.op3.type, value-1); IntermediateCode.InitInstruction(inst, Basic.invalidPosition, IntermediateCode.and, instruction.op1, instruction.op2, op3); EmitAnd(inst); RETURN; END; HALT(100); (*! mod is not supported by hardware, must be runtime call -- cf. method Supported *) END EmitMod; PROCEDURE EmitAndPart(VAR instruction: IntermediateCode.Instruction; part: LONGINT); VAR left, right, dest: Operand; negate: BOOLEAN; BEGIN PrepareOp3(instruction,part,FALSE,negate,dest,left,right); Emit2(opAND,left,right); FinishOp(instruction.op1, part,dest, left) END EmitAndPart; PROCEDURE EmitAnd(VAR instruction: IntermediateCode.Instruction); BEGIN EmitAndPart(instruction,Low); IF IsComplex(instruction.op1) THEN EmitAndPart(instruction,High); END; END EmitAnd; PROCEDURE EmitOr(VAR instruction: IntermediateCode.Instruction; part: LONGINT); VAR left, right, dest: Operand; negate: BOOLEAN; BEGIN PrepareOp3(instruction,part,FALSE,negate,dest, left,right); Emit2(opOR,left,right); FinishOp(instruction.op1,part,dest, left) END EmitOr; PROCEDURE EmitXor(VAR instruction: IntermediateCode.Instruction; part: LONGINT); VAR dest, left, right: Operand; negate: BOOLEAN; BEGIN PrepareOp3(instruction,part,FALSE,negate,dest,left,right); Emit2(opXOR,left,right); FinishOp(instruction.op1,part,dest,left) END EmitXor; PROCEDURE GetTemporaryRegister(VAR op: Operand); VAR ticket: Ticket; BEGIN ticket := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); TicketToOperand(ticket,op); END GetTemporaryRegister; PROCEDURE EmitShift(VAR instr: IntermediateCode.Instruction); VAR op2, op3, dest, imm, one, opx, mask, opx2: Operand; shift: LONGINT; fixup, fixup2: BinaryCode.Fixup; BEGIN instructionSet.InitOperand(imm); instructionSet.InitOperand(one); ASSERT(instr.op1.type.sizeInBits < 64); AcquireDestinationRegister(instr.op1, Low, dest); MakeRegister(instr.op2, Low, op2); (*! caution: do not use dest and op2 / op3 more than once in one line: dest might be source (as in shl $1,1,$1) *) IF instr.op3.mode = IntermediateCode.ModeImmediate THEN shift := SHORT(instr.op3.intValue) MOD 32; IF shift = 0 THEN MovIfDifferent(dest, op2); Emit2N(opROR, dest, shift); ELSE CASE instr.opcode OF |IntermediateCode.ror: MovIfDifferent(dest, op2); Emit2N(opROR, dest, shift); |IntermediateCode.rol: MovIfDifferent(dest, op2); Emit2N(opROR, dest, 32-shift); |IntermediateCode.shl: MovIfDifferent(dest, op2); Emit2N(opROR, dest, 32-shift); ImmediateToOperand(ASH(1, shift)-1, Low, FALSE, instructionSet.ImmediateFixupBits,imm); Emit2(opBIC, dest, imm); ReleaseHint(imm.register); |IntermediateCode.shr: IF instr.op1.type.form # IntermediateCode.SignedInteger THEN (* logical shift right *) ImmediateToOperand(ASH(1,shift)-1,Low,FALSE,instructionSet.ImmediateFixupBits,imm); Emit2(opBIC, op2, imm); MovIfDifferent(dest, op2); Emit2N(opROR, dest, shift); ReleaseHint(imm.register); ELSE (* arithmetic shift right *) ImmediateToOperand(ASH(1,shift)-1,Low,FALSE,instructionSet.ImmediateFixupBits,imm); MovIfDifferent(dest, op2); Emit2(opOR,dest,dest); fixup := BrForward(opBN); (* Emit1N(opBN, 2); (* if op2 < 0 then skip next two instructions *) *) Emit2(opBIC, dest,imm); fixup2 := BrForward(opBT); (* Emit1N(opBT, 1); (* skip next instruction *) *) SetTarget(fixup); Emit2(opOR, dest, imm); SetTarget(fixup2); Emit2N(opROR, dest, shift); ReleaseHint(imm.register); END; END; END; ELSE MakeRegister(instr.op3, Low, op3); CASE instr.opcode OF |IntermediateCode.ror: Emit2(opROR, op2, op3); MovIfDifferent(dest, op2); |IntermediateCode.rol: GetTemporaryRegister(imm); ImmediateToOperand(32, Low, FALSE, instructionSet.ImmediateFixupBits, imm); Emit2(opSUB, imm, op3); Emit2(opROR, op2, imm); MovIfDifferent(dest, op2); ReleaseHint(imm.register); |IntermediateCode.shl: GetTemporaryRegister(imm); ImmediateToOperand(32, Low, FALSE, instructionSet.ImmediateFixupBits,imm); Emit2(opSUB, imm, op3); Emit2(opROR, op2, imm); IF IsSameRegister(dest, op2) THEN GetTemporaryRegister(op2); ELSE Emit2(opMOV, dest, op2); END; (*GetTemporaryRegister(one,32);*) ImmediateToOperand(1, Low, FALSE, instructionSet.ImmediateFixupBits, op2); Emit2(opROR, op2, imm); Emit2N(opSUB, op2, 1); Emit2(opBIC, dest, op2); ReleaseHint(imm.register); ReleaseHint(op2.register); |IntermediateCode.shr: IF instr.op1.type.form # IntermediateCode.SignedInteger THEN GetTemporaryRegister(mask); ImmediateToOperand(1, Low, FALSE, instructionSet.ImmediateFixupBits,mask); IF IsSameRegister(dest, op3) THEN GetTemporaryRegister(opx); Emit2(opMOV, opx, op3); Emit2(opMOV, dest, op2); op3 := opx; ELSE MovIfDifferent(dest, op2); END; IF physicalRegisters.NextFree(IntermediateCode.int32)#None THEN GetTemporaryRegister(opx2); ELSE EmitPush(instr.op1,Low); (* save dest *) opx2 := dest; END; Emit2N(opMOV, opx2, 32); Emit2(opSUB, opx2, op3); Emit2(opROR, mask, opx2); Emit2N(opSUB, mask, 1); IF opx2.register = dest.register THEN EmitPop(instr.op1,Low); (* restore dest *) ELSE ReleaseHint(opx2.register); END; Emit2(opBIC, dest, mask); Emit2(opROR, dest, op3); ReleaseHint(opx.register); ReleaseHint(mask.register); ELSE GetTemporaryRegister(imm); ImmediateToOperand(32, Low, FALSE, instructionSet.ImmediateFixupBits, imm); Emit2(opSUB, imm, op3); GetTemporaryRegister(one); ImmediateToOperand(1, Low, FALSE, instructionSet.ImmediateFixupBits, one); Emit2(opROR, one, imm); Emit2N(opSUB, one, 1); Emit2(opOR, op2, op2); (* if negative *) fixup := BrForward(opBN); (* Emit1N(opBN, 2); (* then skip next two instructions *) *) Emit2(opBIC, op2,one); fixup2 := BrForward(opBT); (* Emit1N(opBT, 1); (* skip next instruction *) *) SetTarget(fixup); Emit2(opOR, op2, one); SetTarget(fixup2); Emit2(opROR, op2, op3); MovIfDifferent(dest, op2); ReleaseHint(imm.register); ReleaseHint(one.register); END; END; END; ReleaseDestinationRegister(instr.op1, Low, dest); END EmitShift; PROCEDURE EmitCopy(VAR instr: IntermediateCode.Instruction); VAR op1, op2, op3: Operand; mem1, mem2: InstructionSet.Operand; reg: Operand; prevSize, i: LONGINT; ticket: Ticket; BEGIN MakeRegister(instr.op1, Low, op1); MakeRegister(instr.op2, Low, op2); IF (instr.op3.mode = IntermediateCode.ModeImmediate) & (instr.op3.intValue < 16) THEN GetTemporaryRegister(reg); FOR i := 0 TO SHORT(instr.op3.intValue)-1 DO instructionSet.InitMemory(mem1, op1.register, i); instructionSet.InitMemory(mem2, op2.register, i); Emit2(opLD, reg, mem2); Emit2(opST, reg, mem1); END; ReleaseHint(reg.register); ELSE MakeRegister(instr.op3, Low, op3); ticket := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); TicketToOperand(ticket,reg); instructionSet.InitMemory(mem1, op1.register, 0); instructionSet.InitMemory(mem2, op2.register, 0); prevSize := out.pc; Emit2(opLD, reg, mem2); Emit2(opST, reg, mem1); Emit2N(opADD, op1, 1); Emit2N(opADD, op2, 1); Emit2N(opSUB, op3, 1); Emit1N(opBGT, -(out.pc-prevSize+1)); UnmapTicket(ticket); END; END EmitCopy; PROCEDURE EmitFill(VAR instr: IntermediateCode.Instruction; down: BOOLEAN); VAR op1, op2, op3: Operand; mem1: InstructionSet.Operand; prevSize: LONGINT; i: LONGINT; ticket: Ticket; BEGIN MakeRegister(instr.op1, Low, op1); MakeRegister(instr.op2, Low, op2); IF ~down & (instr.op3.mode = IntermediateCode.ModeImmediate) & (instr.op3.intValue < 16) THEN FOR i := 0 TO SHORT(instr.op3.intValue)-1 DO instructionSet.InitMemory(mem1, op1.register, i); Emit2(opST, op2, mem1); END; ELSE MakeRegister(instr.op3, Low, op3); instructionSet.InitMemory(mem1, op1.register, 0); prevSize := out.pc; Emit2(opST, op2, mem1); IF down THEN Emit2N(opSUB, op1, 1); ELSE Emit2N(opADD, op1, 1); END; Emit2N(opSUB, op3, 1); Emit1N(opBGT, -(out.pc-prevSize+1)); UnmapTicket(ticket); END; END EmitFill; PROCEDURE BrForward(op: LONGINT): BinaryCode.Fixup; VAR fixupOp: InstructionSet.Operand; fixup: BinaryCode.Fixup; identifier: ObjectFile.Identifier; BEGIN identifier.name := in.name; identifier.fingerprint := in.fingerprint; fixup := BinaryCode.NewFixup(BinaryCode.Relative, out.pc, identifier, 0,0,0,NIL); fixup.resolved := in; instructionSet.InitFixup(fixupOp,32,fixup); Emit1(op, fixupOp); RETURN fixup; END BrForward; PROCEDURE SetTarget(fixup: BinaryCode.Fixup); BEGIN fixup.SetSymbol(in.name, in.fingerprint, 0, out.pc+fixup.displacement (* displacement offset computed during operand emission, typically -1 *) ); fixup.resolved := in; END SetTarget; PROCEDURE EmitBr (VAR instr: IntermediateCode.Instruction); VAR dest, destPC, offset: LONGINT; target: Operand; reverse: BOOLEAN; (* jump operands *) op2, op3: Operand; hiHit, hiFail, lowHit: LONGINT; failPC: LONGINT; pattern: ObjectFile.FixupPatterns; fixup, failFixup: BinaryCode.Fixup; float,negate: BOOLEAN; identifier: ObjectFile.Identifier; PROCEDURE JmpDest(brop: LONGINT); VAR op1: Operand; fixupOp: InstructionSet.Operand; oldLR, thisPC: Operand; ticket1, ticket2: Ticket; BEGIN IF instr.op1.mode = IntermediateCode.ModeImmediate THEN Assert(instr.op1.symbol.name # "", "branch without symbol destination"); dest := (instr.op1.symbolOffset); (* this is the offset in the in-data section (intermediate code), it is not byte-relative *) destPC := in.instructions[dest].pc + instr.op1.offset; offset := destPC - out.pc; fixup := BinaryCode.NewFixup(BinaryCode.Relative, out.pc, instr.op1.symbol, instr.op1.symbolOffset, instr.op1.offset,0,NIL); IF (fixup.symbol.name = in.name) & (fixup.symbolOffset > inPC) THEN (* forward jump *) forwardFixups.Enter(fixup, out.pc, instructionSet.RelativeBranchFixupBits); ELSIF (fixup.symbol.name = in.name) & (fixup.symbolOffset < inPC) THEN (* backward jump *) ASSERT(offset < 0); offset := -offset; IF offset >= ASH(1,instructionSet.RelativeBranchFixupBits-1)-1 THEN (*D.String("fixup too far for immediate fixup, offset=");D.Int(offset,1);D.Ln;*) (* cannot enter fixup / use immediate jump, jump too far *) fixup := BrForward(instructionSet.inverseCondition[brop]); (* jump over absolute branch (skip) *) (* fixup := BinaryCode.NewFixup(BinaryCode.Relative, out.pc, in, 0,0,0,NIL); InstructionSet.InitFixup(fixupOp,32,fixup); Emit1(InstructionSet.inverseCondition[brop], fixupOp); (* jump over absolute branch (skip) *) *) (* do a relative register jump, an absolute jump would require a fixup with unpredictable size => have to get program counter, misuse BL here: MOV Rx, LR BL 0; get PC of next line MOV Ry, LR MOV LR, Rx ; restore LR ADD Ry, offset BR R2 *) ticket1 := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); ticket2 := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); TicketToOperand(ticket1,oldLR); TicketToOperand(ticket2,thisPC); Emit2(opMOV,oldLR, opLR); Emit1N(opBL,0); (* exactly here we have the current PC in LR, so we compute the offset here *) offset := out.pc-destPC; Emit2(opMOV, thisPC, opLR); Emit2(opMOV, opLR, oldLR); UnmapTicket(ticket1); instructionSet.InitOperand(target); ImmediateToOperand(offset,Low,FALSE, instructionSet.ImmediateFixupBits,target); Emit2(opSUB, thisPC, target); Emit1(InstructionSet.opBR, thisPC); ReleaseHint(target.register); (* patch fixup for skip long jump code *) SetTarget(fixup); (* fixup.SetSymbol(in, 0, out.pc+fixup.displacement (* displacement offset computed during operand emission, typically -1 *) ); *) RETURN END; END; instructionSet.InitFixup(target, 32, fixup); (* fixup mask entered curing code emission *) Emit1(brop, target); ELSIF brop = opBT THEN (* register jump, unconditional *) MakeRegister(instr.op1,Low,op1); Emit1(opBR, op1); ELSE HALT(100); (* no conditional jump on register implemented *) END; END JmpDest; PROCEDURE Cmp(left, right: InstructionSet.Operand); VAR destOp: Operand; ticket: Ticket; fixup, fixup2: BinaryCode.Fixup; BEGIN IF float THEN ticket := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); TicketToOperand(ticket,destOp); Emit2(opMOV, destOp, left); Emit2(opAND, destOp, right); fixup := BrForward(opBN); (* Emit1N(opBN, 3); *) Emit2(opMOV, destOp, left); Emit2(opSUB, destOp, right); fixup2 := BrForward(opBT); SetTarget(fixup); (* Emit1N(opBT, 2); *) Emit2(opMOV, destOp, right); Emit2(opSUB, destOp, left); SetTarget(fixup2); UnmapTicket(ticket); ELSE IF (left.register >= 0) & (physicalRegisters.Mapped(left.register) = NIL) THEN IF negate THEN Emit2(opADD, left, right); ELSE Emit2(opSUB, left, right); END; ELSE ticket := TemporaryTicket(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32); TicketToOperand(ticket,destOp); Emit2(opMOV, destOp, left); IF negate THEN Emit2(opADD, destOp, right); ELSE Emit2(opSUB, destOp, right); END; UnmapTicket(ticket); END; END; END Cmp; BEGIN hiFail := None; hiHit := None; lowHit := None; float := instr.op2.type.form = IntermediateCode.Float; failPC := 0; IF (instr.op1.symbol.name = in.name) & (instr.op1.symbolOffset = inPC +1) THEN (* jump to next instruction can be ignored *) IF dump # NIL THEN dump.String("jump to next instruction ignored"); dump.Ln END; RETURN END; IF instr.opcode = IntermediateCode.br THEN JmpDest(opBT); ELSE (* conditional branch for 32 bit operands quite simple cmp left right brc(hit) target ... target: .... for 64 bit operands transformed to cmp hi(left) hi(right) brc(hiHit) target brc(hiFail) fail cmp low(left) low(right) brc(lowHit) target fail: .... target: ..... *) IF instr.op2.type.sizeInBits # 64 THEN CASE instr.opcode OF IntermediateCode.breq: lowHit := opBEQ; |IntermediateCode.brne: lowHit := opBNE; |IntermediateCode.brge: IF instr.op2.type.form IN {IntermediateCode.SignedInteger, IntermediateCode.Float} THEN IF reverse THEN lowHit := opBLE ELSE lowHit := opBGE END; ELSIF instr.op2.type.form = IntermediateCode.UnsignedInteger THEN IF reverse THEN lowHit := opBBE ELSE lowHit := opBAE END; END; |IntermediateCode.brlt: IF instr.op2.type.form IN {IntermediateCode.SignedInteger, IntermediateCode.Float} THEN IF reverse THEN lowHit := opBGT ELSE lowHit := opBLT END; ELSIF instr.op2.type.form = IntermediateCode.UnsignedInteger THEN IF reverse THEN lowHit := opBA ELSE lowHit := opBB END; END; END; ELSE Assert(instr.op2.type.form # IntermediateCode.UnsignedInteger, "no unsigned integer64 branch implemented"); CASE instr.opcode OF IntermediateCode.breq: hiHit := None; hiFail := opBNE; lowHit := opBEQ |IntermediateCode.brne: hiHit := opBNE; hiFail := None; lowHit := opBNE |IntermediateCode.brge: IF reverse THEN hiHit := opBLT; hiFail := opBGT; lowHit := opBBE ELSE hiHit := opBGT; hiFail := opBLT; lowHit := opBAE END; |IntermediateCode.brlt: IF reverse THEN hiHit := opBGT; hiFail := opBLT; lowHit := opBA ELSE hiHit := opBLT; hiFail := opBGT; lowHit := opBB END; END; MakeRegister(instr.op2, High, op2); negate := FALSE; IF float THEN MakeRegister(instr.op3, High, op3) ELSIF ~UnsignedImmediate(instr.op3, High, instructionSet.ImmediateFixupBits, TRUE, negate,op3) THEN MakeRegister(instr.op3, High, op3) END; Cmp(op2, op3); ReleaseHint(op2.register); ReleaseHint(op3.register); float := FALSE; (* lower bits must always be compared as (unsigned) integers *) IF hiHit # None THEN JmpDest(hiHit); END; IF hiFail # None THEN NEW(pattern,1); pattern[0].offset := 0; pattern[0].bits := instructionSet.RelativeBranchFixupBits; identifier.name := in.name; identifier.fingerprint := in.fingerprint; failFixup := BinaryCode.NewFixup(BinaryCode.Relative, out.pc, identifier, 0, 0, 0 , pattern); failFixup.resolved := in; instructionSet.InitImmediate(target,32,0); instructionSet.AddFixup(target, failFixup); Emit1(hiFail, target); END; (*ReleaseHint(op2.register); ReleaseHint(op3.register);*) END; MakeRegister(instr.op2, Low, op2); negate := FALSE; IF float THEN MakeRegister(instr.op3, Low, op3) ELSIF ~UnsignedImmediate(instr.op3, Low, instructionSet.ImmediateFixupBits, TRUE, negate,op3) THEN MakeRegister(instr.op3, Low, op3) END; Cmp(op2, op3); ReleaseHint(op2.register); ReleaseHint(op3.register); ASSERT(lowHit # None); JmpDest(lowHit); IF hiFail # None THEN failFixup.SetSymbol(in.name, in.fingerprint, 0, out.pc+failFixup.displacement (* displacement offset computed during operand emission, typically -1 *) ); failFixup.resolved := in; END; END; END EmitBr; PROCEDURE EmitPop(VAR vop: IntermediateCode.Operand; part: LONGINT); VAR mem: InstructionSet.Operand; reg: Operand; BEGIN instructionSet.InitMemory(mem, InstructionSet.SP, 0); AcquireDestinationRegister(vop, part, reg); Emit2(opLD, reg, mem); AllocateStack(-1, TRUE); ReleaseDestinationRegister(vop, part, reg); END EmitPop; PROCEDURE EmitPush(VAR vop: IntermediateCode.Operand; part: LONGINT); VAR mem: InstructionSet.Operand; reg: Operand; pc: LONGINT; BEGIN MakeRegister(vop, part, reg); IF pushChainLength = 0 THEN (* check for chain of pushes *) pc := inPC+1; pushChainLength := 1; WHILE ~inEmulation & (pc < in.pc) & (in.instructions[pc].opcode = IntermediateCode.push) DO INC(pc); INC(pushChainLength); END; AllocateStack(pushChainLength,TRUE); END; DEC(pushChainLength); instructionSet.InitMemory(mem, InstructionSet.SP, pushChainLength); Emit2(opST, reg, mem); END EmitPush; PROCEDURE EmitNeg(VAR instr: IntermediateCode.Instruction); VAR leftLow, leftHigh, rightLow, rightHigh, reg: Operand; neg: BOOLEAN; fixup: BinaryCode.Fixup; BEGIN IF instr.op1.type.form IN IntermediateCode.Integer THEN PrepareOp2(instr,Low,FALSE,neg,leftLow, rightLow); Emit2(opNOT, leftLow, rightLow); IF IsComplex(instr.op1) THEN PrepareOp2(instr,High,FALSE,neg,leftHigh,rightHigh); Emit2(opNOT, leftHigh, rightHigh); END; Emit2N(opADD,leftLow,1); FinishOp(instr.op1,Low,leftLow, leftLow); IF IsComplex(instr.op1) THEN fixup := BrForward(opBB); (* Emit1N(opBB, 1); *) Emit2N(opADD, leftHigh, 1); SetTarget(fixup); FinishOp(instr.op1,High,leftHigh, leftHigh); END; ELSIF instr.op1.type.form = IntermediateCode.Float THEN PrepareOp2(instr,Low,FALSE,neg,leftLow,rightLow); IF IsComplex(instr.op1) THEN PrepareOp2(instr,High,FALSE,neg,leftHigh,rightHigh); END; Emit2(opMOV,leftLow,rightLow); IF ~IsComplex(instr.op1) THEN reg := leftLow ELSE ASSERT(instr.op1.type.sizeInBits=64); Emit2(opMOV,leftHigh,rightHigh); reg := leftHigh; END; Emit2N(opROR,reg,31); Emit2N(opXOR,reg,1); Emit2N(opROR,reg,1); ReleaseDestinationRegister(instr.op1, Low, leftLow); IF IsComplex(instr.op1) THEN ReleaseDestinationRegister(instr.op1,High,leftHigh); END; END; END EmitNeg; PROCEDURE EmitNot(VAR instr: IntermediateCode.Instruction; part: LONGINT); VAR left,right: Operand; negate: BOOLEAN; BEGIN PrepareOp2(instr,part,FALSE,negate,left,right); Emit2(opNOT, left,right); FinishOp(instr.op1,part,left,left); END EmitNot; PROCEDURE EmitAbs(VAR instr: IntermediateCode.Instruction); VAR left,right: Operand; neg: BOOLEAN; fixup: BinaryCode.Fixup; BEGIN PrepareOp2(instr,Low,FALSE,neg,left,right); Emit2(opMOV, left, right); fixup := BrForward(opBNN); (* Emit1N(opBNN, 2); *) Emit2(opNOT, left,right); Emit2N(opADD, left, 1); SetTarget(fixup); FinishOp(instr.op1,Low, left,left); END EmitAbs; PROCEDURE EmitTrap(CONST instr: IntermediateCode.Instruction); VAR reg: Operand; reserve: Ticket; BEGIN instructionSet.InitRegister(reg, 0); ImmediateToOperand(instr.op1.intValue,Low, FALSE, instructionSet.ImmediateFixupBits,reg); IF physicalRegisters.Mapped(0)=NIL THEN reserve := ReservePhysicalRegister(IntermediateCode.GeneralPurposeRegister,IntermediateCode.int32,0,inPC); ELSE reserve := NIL END; GetTemporaryRegister(reg); Emit2N(opMOV, reg, HaltIRQNumber); Emit2(opBLR, opLR, reg); ReleaseHint(reg.register); IF reserve # NIL THEN UnmapTicket(reserve) END; END EmitTrap; PROCEDURE EmitAsm(CONST instr: IntermediateCode.Instruction); VAR reader: Streams.StringReader; procedure: SyntaxTree.Procedure; scope: SyntaxTree.Scope; len: LONGINT; symbol: SyntaxTree.Symbol; assembler: Assembler.Assembler; scanner: Scanner.AssemblerScanner; BEGIN len := Strings.Length(instr.op1.string^); NEW(reader, len); reader.Set(instr.op1.string^); symbol := in.symbol; IF (symbol = NIL) THEN scope := NIL ELSE procedure := symbol(SyntaxTree.Procedure); scope := procedure.procedureScope; END; NEW(assembler, diagnostics, backend.capabilities,instructionSet ); scanner := Scanner.NewAssemblerScanner(module.moduleName(*module.module.sourceName*), reader, SHORT(instr.op1.intValue), diagnostics); scanner.useLineNumbers := Compiler.UseLineNumbers IN backend.flags; assembler.InlineAssemble(scanner, in, scope, module); error := error OR assembler.error END EmitAsm; END CodeGeneratorTRM; System = OBJECT (Global.System) PROCEDURE SizeOf*(type: SyntaxTree.Type): LONGINT; BEGIN type := type.resolved; IF type IS SyntaxTree.BasicType THEN IF (type.sizeInBits=64) THEN RETURN 64 ELSE RETURN 32 END ELSE RETURN SizeOf^(type) END; END SizeOf; END System; BackendTRM = OBJECT (IntermediateBackend.IntermediateBackend) VAR cg: CodeGeneratorTRM; patchSpartan6: BOOLEAN; myInstructionSet: InstructionSet.InstructionSet; recentInstructionWidth : LONGINT; PROCEDURE &InitBackendTRM; BEGIN InitIntermediateBackend; SetSimpleMetaData(TRUE); myInstructionSet:=defaultInstructionSet; SetHasLinkRegister; recentInstructionWidth := Sections.UnknownSize; SetName("TRM"); END InitBackendTRM; PROCEDURE Initialize*(diagnostics: Diagnostics.Diagnostics; log: Streams.Writer; flags: SET; checker: SemanticChecker.Checker; system: Global.System); VAR BEGIN Initialize^(diagnostics, log, flags, checker, system); (*goes up the inheritance hierarchy all the way to Backend.Mod*) NEW(cg, builtinsModuleName, diagnostics, SELF,myInstructionSet); cg.patchSpartan6 := patchSpartan6; recentInstructionWidth := Sections.UnknownSize; END Initialize; PROCEDURE SetInstructionWidth* (instructionWidth: LONGINT); (*override*) BEGIN IF SELF.instructionWidth # instructionWidth THEN SetInstructionWidth^(instructionWidth); NEW(myInstructionSet,instructionWidth); cg.SetInstructionSet(myInstructionSet); END; END SetInstructionWidth; PROCEDURE GetSystem*(): Global.System; VAR system: System; BEGIN NEW(system, 18, 32, 32, 32, 32, 32, 32, 64(* parameter offset 0: handled locally *), cooperative); Global.SetDefaultDeclarations(system,32); Global.SetDefaultOperators(system); RETURN system END GetSystem; PROCEDURE SupportedInstruction*(CONST instruction: IntermediateCode.Instruction; VAR moduleName, procedureName: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN cg.Supported(instruction, moduleName, procedureName); END SupportedInstruction; PROCEDURE SupportedImmediate*(CONST immediate: IntermediateCode.Operand): BOOLEAN; VAR reg: InstructionSet.Operand; int: LONGINT; BEGIN IF immediate.type.form IN IntermediateCode.Integer THEN IF immediate.type.sizeInBits < 64 THEN int := LONGINT(immediate.intValue); RETURN ((ABS(int) < ASH(1,myInstructionSet.ImmediateFixupBits)) OR (cg.GetImmediate32(int, reg, FALSE) < 3)) ELSE RETURN (ABS(immediate.intValue) < ASH(1,myInstructionSet.ImmediateFixupBits)) END; ELSE RETURN FALSE END END SupportedImmediate; PROCEDURE GenerateBinary(module: Sections.Module; dump: Streams.Writer); VAR in: Sections.Section; out: BinaryCode.Section; name: Basic.SectionName; procedure: SyntaxTree.Procedure; i, j, initialSectionCount: LONGINT; PROCEDURE Resolve(VAR fixup: BinaryCode.Fixup); BEGIN IF (fixup.symbol.name #"") & (fixup.resolved = NIL) THEN fixup.resolved := module.allSections.FindByName(fixup.symbol.name) END; END Resolve; (* recompute fixup positions and assign binary sections *) PROCEDURE PatchFixups(section: BinaryCode.Section); VAR resolved: BinaryCode.Section; fixup: BinaryCode.Fixup; symbolOffset: LONGINT; in: IntermediateCode.Section; BEGIN fixup := section.fixupList.firstFixup; WHILE fixup # NIL DO Resolve(fixup); IF (fixup.resolved # NIL) THEN resolved := fixup.resolved(IntermediateCode.Section).resolved(BinaryCode.Section); in := fixup.resolved(IntermediateCode.Section); symbolOffset := fixup.symbolOffset; IF (symbolOffset # 0) & (symbolOffset < in.pc) THEN symbolOffset := in.instructions[symbolOffset].pc; END; fixup.SetSymbol(fixup.symbol.name, fixup.symbol.fingerprint, 0, symbolOffset+fixup.displacement); END; fixup := fixup.nextFixup; END; END PatchFixups; BEGIN cg.SetModule(module); cg.dump := dump; FOR i := 0 TO module.allSections.Length() - 1 DO in := module.allSections.GetSection(i); in(IntermediateCode.Section).EnableComments(trace); IF in.type = Sections.InlineCodeSection THEN Basic.SegmentedNameToString(in.name, name); out := ResolvedSection(in(IntermediateCode.Section)); cg.dump := out.comments; SetInstructionWidth(out.os.unit); cg.Section(in(IntermediateCode.Section), out); (*compilation*) IF in.symbol # NIL THEN procedure := in.symbol(SyntaxTree.Procedure); procedure.procedureScope.body.code.SetBinaryCode(out.os.bits); END; END END; initialSectionCount := 0; REPEAT j := initialSectionCount; initialSectionCount := module.allSections.Length() ; FOR i := j TO initialSectionCount - 1 DO in := module.allSections.GetSection(i); IF (in.type # Sections.InlineCodeSection) (*& (in(IntermediateCode.Section).resolved = NIL) *) THEN out := ResolvedSection(in(IntermediateCode.Section)); SetInstructionWidth(out.os.unit); cg.Section(in(IntermediateCode.Section),out); END END UNTIL initialSectionCount = module.allSections.Length(); (* process remaining sections that have been added during traversal of sections *) (* FOR i := 0 TO module.allSections.Length() - 1 DO in := module.allSections.GetSection(i); IF ~in.IsExternal() THEN IF in.type # Sections.InlineCodeSection THEN Basic.SegmentedNameToString(in.name, name); out := ResolvedSection(in(IntermediateCode.Section)); cg.Section(in(IntermediateCode.Section), out); END END; END; *) FOR i := 0 TO module.allSections.Length() - 1 DO in := module.allSections.GetSection(i); PatchFixups(in(IntermediateCode.Section).resolved) END; IF cg.error THEN Error("", Basic.invalidPosition, Streams.Invalid, "") END; END GenerateBinary; (* genasm *) PROCEDURE ProcessIntermediateCodeModule*(intermediateCodeModule: Formats.GeneratedModule): Formats.GeneratedModule; VAR result: Formats.GeneratedModule; BEGIN ASSERT(intermediateCodeModule IS Sections.Module); result := ProcessIntermediateCodeModule^(intermediateCodeModule); recentInstructionWidth := Sections.UnknownSize; IF ~error THEN GenerateBinary(result(Sections.Module), dump); IF dump # NIL THEN dump.Ln; dump.Ln; dump.String("------------------ binary code -------------------"); dump.Ln; IF (traceString="") OR (traceString="*") THEN result.Dump(dump); dump.Update ELSE Sections.DumpFiltered(dump, result(Sections.Module), traceString); dump.Update; END END; END; RETURN result FINALLY IF dump # NIL THEN dump.Ln; dump.Ln; dump.String("------------------ rescued code (code generation trapped) -------------------"); dump.Ln; IF (traceString="") OR (traceString="*") THEN result.Dump(dump); dump.Update ELSE Sections.DumpFiltered(dump,result(Sections.Module),traceString); dump.Update; END END; RETURN result END ProcessIntermediateCodeModule; PROCEDURE DefineOptions*(options: Options.Options); BEGIN options.Add(0X,VectorSupportFlag,Options.Flag); options.Add(0X,FloatingPointSupportFlag,Options.Flag); options.Add(0X,PatchSpartan6, Options.Flag); DefineOptions^(options); END DefineOptions; PROCEDURE GetOptions*(options: Options.Options); VAR capabilities: SET; BEGIN capabilities := SELF.capabilities; IF options.GetFlag(VectorSupportFlag) THEN INCL(capabilities, Global.VectorCapability) END; IF options.GetFlag(FloatingPointSupportFlag) THEN INCL(capabilities, Global.FloatingPointCapability) END; IF options.GetFlag(PatchSpartan6) THEN D.String("patchSpartan6=TRUE"); D.Ln; patchSpartan6 := TRUE END; SetCapabilities(capabilities); GetOptions^(options); END GetOptions; PROCEDURE DefaultObjectFileFormat*(): Formats.ObjectFileFormat; BEGIN RETURN ObjectFileFormat.Get(); END DefaultObjectFileFormat; PROCEDURE DefaultSymbolFileFormat*(): Formats.SymbolFileFormat; BEGIN RETURN NIL END DefaultSymbolFileFormat; PROCEDURE GetDescription*(VAR instructionSet: ARRAY OF CHAR); BEGIN instructionSet := "TRM" END GetDescription; PROCEDURE FindPC*(x: SyntaxTree.Module; CONST sectionName: ARRAY OF CHAR; sectionOffset: LONGINT); VAR section: Sections.Section; binarySection: BinaryCode.Section; label: BinaryCode.LabelList; module: Formats.GeneratedModule; i: LONGINT; pooledName: Basic.SegmentedName; BEGIN module := ProcessSyntaxTreeModule(x); Basic.ToSegmentedName(sectionName, pooledName); i := 0; REPEAT section := module(Sections.Module).allSections.GetSection(i); INC(i); UNTIL (i = module(Sections.Module).allSections.Length()) OR (section.name = pooledName); IF section.name # pooledName THEN Basic.Error(diagnostics, module.module.sourceName,Basic.invalidPosition," could not locate pc"); ELSE binarySection := section(IntermediateCode.Section).resolved; label := binarySection.labels; WHILE (label # NIL) & (label.offset >= sectionOffset) DO label := label.prev; END; IF label # NIL THEN Basic.Information(diagnostics, module.module.sourceName,label.position," pc position"); ELSE Basic.Error(diagnostics, module.module.sourceName, Basic.invalidPosition," could not locate pc"); END; END; END FindPC; PROCEDURE CheckCodeAddress*(VAR adr: LONGINT); BEGIN IF (patchSpartan6) & (adr MOD 1024 >= 959) (* need one instruction to jump, therefore include 959 in check *) & (adr MOD 1024 <= 975) THEN adr := (adr DIV 1024) * 1024 +976; END; END CheckCodeAddress; PROCEDURE ResolvedSection(in: IntermediateCode.Section): BinaryCode.Section; VAR section: BinaryCode.Section; unit: LONGINT; BEGIN (*VAR and CONST sections go to the data memory, only code sections go to code memory Note that data memory has 32 bit words while code has standard 18. *) IF in.bitsPerUnit # Sections.UnknownSize THEN unit := in.bitsPerUnit; ELSIF in.type IN {Sections.VarSection, Sections.ConstSection} THEN unit := 32; ELSE IF (recentInstructionWidth # Sections.UnknownSize) THEN unit := recentInstructionWidth(* instructionWidth*); ELSE unit:=18; END END; IF in.IsCode() THEN recentInstructionWidth := unit; END; IF in.resolved = NIL THEN NEW(section, in.type, unit, in.name, in.comments # NIL, FALSE); section.SetAlignment(in.fixed, in.positionOrAlignment); in.SetResolved(section); ELSE section := in.resolved END; RETURN section END ResolvedSection; END BackendTRM; VAR defaultInstructionSet: InstructionSet.InstructionSet; emptyOperand: InstructionSet.Operand; PROCEDURE Assert(b: BOOLEAN; CONST s: ARRAY OF CHAR); BEGIN ASSERT(b, 100); END Assert; PROCEDURE Halt(CONST s: ARRAY OF CHAR); BEGIN HALT(100); END Halt; PROCEDURE Init; BEGIN NEW(defaultInstructionSet,18); (*TODO: maybe it's better to have all these init functions outside of instruction set object?*) defaultInstructionSet.InitOperand(emptyOperand); END Init; PROCEDURE Get*(): Backend.Backend; VAR backend: BackendTRM; BEGIN NEW(backend); RETURN backend END Get; BEGIN Init; END FoxTRMBackend. System.FreeDownTo FoxTRMBackend ~