mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-12-22 23:29:27 +00:00
bdd60d9d08
There is no need to reduce the optimization in other functions, which will not contain any varargs stack repair code.
2350 lines
78 KiB
ObjectPascal
2350 lines
78 KiB
ObjectPascal
{$optimize 7}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ ORCA Native Code Generation }
|
|
{ }
|
|
{ This module of the code generator is called to generate }
|
|
{ native code instructions. The native code is optimized }
|
|
{ and written to the object segment. }
|
|
{ }
|
|
{ Externally available procedures: }
|
|
{ }
|
|
{ EndSeg - close out the current segment }
|
|
{ GenNative - write a native code instruction to the output }
|
|
{ file }
|
|
{ GenImplied - short form of GenNative - reduces code size }
|
|
{ GenCall - short form of jsl to library subroutine - reduces }
|
|
{ code size }
|
|
{ GenLab - generate a label }
|
|
{ InitFile - Set up the object file }
|
|
{ InitNative - set up for a new segment }
|
|
{ RefName - handle a reference to a named label }
|
|
{ }
|
|
{---------------------------------------------------------------}
|
|
|
|
unit Native;
|
|
|
|
interface
|
|
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses CCommon, CGI, CGC, ObjOut;
|
|
|
|
{$segment 'CODEGEN'}
|
|
|
|
type
|
|
labelptr = ^labelentry; {pointer to a forward ref node}
|
|
labelentry = record {forward ref node}
|
|
addr: longint;
|
|
next: labelptr;
|
|
end;
|
|
|
|
labelrec = record {label record}
|
|
defined: boolean; {Note: form used in objout.asm}
|
|
chain: labelptr;
|
|
case boolean of
|
|
true : (val: longint);
|
|
false: (ival,hval: integer);
|
|
end;
|
|
|
|
var
|
|
{current instruction info}
|
|
{------------------------}
|
|
pc: longint; {program counter}
|
|
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
didOne: boolean; {has an optimization been done?}
|
|
labeltab: array[0..maxlabel] of labelrec; {label table}
|
|
localLabel: array[0..maxLocalLabel] of integer; {local variable label table}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure EndSeg;
|
|
|
|
{ close out the current segment }
|
|
|
|
|
|
procedure GenNative (p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
|
|
procedure GenImplied (p_opcode: integer);
|
|
|
|
{ short form of GenNative - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_code - operation code }
|
|
|
|
|
|
procedure GenCall (callNum: integer);
|
|
|
|
{ short form of jsl to library subroutine - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ callNum - subroutine # to generate a call for }
|
|
|
|
|
|
procedure GenLab (lnum: integer);
|
|
|
|
{ generate a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lnum - label number }
|
|
|
|
|
|
procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
|
|
|
|
{ Set up the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
|
|
procedure InitNative;
|
|
|
|
{ set up for a new segment }
|
|
|
|
|
|
procedure LabelSearch (lab: integer; len, shift, disp: integer);
|
|
|
|
{ resolve a label reference }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ len - # bytes for the generated code }
|
|
{ shift - shift factor }
|
|
{ disp - disp past the label }
|
|
{ }
|
|
{ Note 1: maxlabel is reserved for use as the start of the }
|
|
{ string space }
|
|
{ Note 2: negative length indicates relative branch }
|
|
{ Note 3: zero length indicates 2 byte addr -1 }
|
|
|
|
|
|
procedure RefName (lab: stringPtr; disp, len, shift: integer);
|
|
|
|
{ handle a reference to a named label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label name }
|
|
{ disp - displacement past the label }
|
|
{ len - number of bytes in the reference }
|
|
{ shift - shift factor }
|
|
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
npeepSize = 128; {native peephole optimizer window size}
|
|
nMaxPeep = 4; {max # instructions needed to opt.}
|
|
|
|
type
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
npeepRange = 1..npeepsize; {subrange for native code peephole opt.}
|
|
|
|
nativeType = record {native code instruction}
|
|
opcode: integer; {op code}
|
|
mode: addressingMode; {addressing mode}
|
|
operand: integer; {operand value}
|
|
name: stringPtr; {operand label}
|
|
flags: integer; {modifier flags}
|
|
end;
|
|
|
|
registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal);
|
|
registerType = record {used to track register contents}
|
|
condition: registerConditions;
|
|
value: integer;
|
|
lab: stringPtr;
|
|
flags: integer;
|
|
end;
|
|
|
|
var
|
|
{native peephole optimization}
|
|
{----------------------------}
|
|
aRegister, {current register contents}
|
|
xRegister,
|
|
yRegister: registerType;
|
|
nleadOpcodes: set of 0..max_opcode; {instructions that can start an opt.}
|
|
nstopOpcodes: set of 0..max_opcode; {instructions not involved in opt.}
|
|
nnextspot: npeepRange; {next empty spot in npeep}
|
|
npeep: array[npeepRange] of nativeType; {native peephole array}
|
|
|
|
{I/O files}
|
|
{---------}
|
|
fname1, fname2: gsosOutString; {file names}
|
|
nextSuffix: char; {next suffix character to use}
|
|
|
|
|
|
procedure GenSymbols (sym: ptr; doGlobals: integer); extern;
|
|
|
|
{ generate the symbol table }
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
procedure LabelSearch {lab: integer; len, shift, disp: integer};
|
|
|
|
{ resolve a label reference }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ len - # bytes for the generated code }
|
|
{ shift - shift factor }
|
|
{ disp - disp past the label }
|
|
{ }
|
|
{ Note 1: maxlabel is reserved for use as the start of the }
|
|
{ string space }
|
|
{ Note 2: negative length indicates relative branch }
|
|
{ Note 3: zero length indicates 2 byte addr -1 }
|
|
|
|
var
|
|
next: labelptr; {work pointer}
|
|
|
|
begin {LabelSearch}
|
|
if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin
|
|
|
|
{handle a relative branch to a known disp}
|
|
if len = -1 then
|
|
CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len)
|
|
else
|
|
CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len);
|
|
end {if}
|
|
else begin
|
|
if lab <> maxlabel then begin
|
|
|
|
{handle a normal label reference}
|
|
Purge; {empty the constant buffer}
|
|
if len < 0 then begin
|
|
len := -len; {generate a RELEXPR}
|
|
Out(238);
|
|
Out(len);
|
|
Out2(len); Out2(0);
|
|
end {if}
|
|
else begin
|
|
if isJSL then {generate a standard EXPR}
|
|
Out(243)
|
|
else
|
|
Out(235);
|
|
if len = 0 then
|
|
Out(2)
|
|
else
|
|
Out(len);
|
|
end; {else}
|
|
end; {if}
|
|
Out(135); {generate a relative offset from the seg. start}
|
|
if not labeltab[lab].defined then begin
|
|
next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference}
|
|
next^.next := labeltab[lab].chain;
|
|
labeltab[lab].chain := next;
|
|
next^.addr := blkcnt;
|
|
Out2(0);
|
|
Out2(0);
|
|
end {if}
|
|
else {labeltab[lab].defined} begin
|
|
Out2(labeltab[lab].ival); {value known: write it}
|
|
Out2(labeltab[lab].hval);
|
|
end; {else}
|
|
if len = 0 then begin
|
|
Out(129); {subtract 1 from addr}
|
|
Out2(1); Out2(0);
|
|
Out(2);
|
|
len := 2;
|
|
end; {if}
|
|
if disp <> 0 then begin
|
|
Out(129); {add in the displacement}
|
|
Out2(disp);
|
|
if disp < 0 then
|
|
Out2(-1)
|
|
else
|
|
Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if shift <> 0 then begin
|
|
Out(129); {shift the address}
|
|
Out2(-shift); Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
if lab <> maxlabel then {if not a string, end the expression}
|
|
Out(0);
|
|
pc := pc+len; {update the pc}
|
|
end; {else}
|
|
end; {LabelSearch}
|
|
|
|
|
|
procedure UpDate (lab: integer; labelValue: longint);
|
|
|
|
{ define a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ labelValue - displacement in seg where label is located }
|
|
|
|
var
|
|
next,temp: labelptr; {work pointers}
|
|
|
|
begin {UpDate}
|
|
if labeltab[lab].defined then
|
|
Error(cge1)
|
|
else begin
|
|
|
|
{define the label for future references}
|
|
with labeltab[lab] do begin
|
|
defined := true;
|
|
val := labelValue;
|
|
next := chain;
|
|
end; {with}
|
|
|
|
{resolve any forward references}
|
|
if next <> nil then begin
|
|
Purge;
|
|
while next <> nil do begin
|
|
segdisp := next^.addr;
|
|
Out2(long(labelvalue).lsw);
|
|
Out2(long(labelvalue).msw);
|
|
blkcnt := blkcnt-4;
|
|
temp := next;
|
|
next := next^.next;
|
|
end; {while}
|
|
segdisp := blkcnt;
|
|
end; {if}
|
|
end; {else}
|
|
end; {UpDate}
|
|
|
|
|
|
procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer;
|
|
name: stringPtr; flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ opcode - native op code }
|
|
{ mode - addressing mode }
|
|
{ operand - integer operand }
|
|
{ name - named operand }
|
|
{ flags - operand modifier flags }
|
|
|
|
label 1;
|
|
|
|
type
|
|
rkind = (k1,k2,k3); {cnv record types}
|
|
|
|
var
|
|
ch: char; {temp storage for string constants}
|
|
cns: realRec; {for converting reals to bytes}
|
|
cnv: record {for converting double, real to bytes}
|
|
case rkind of
|
|
k1: (rval: real;);
|
|
k2: (dval: double;);
|
|
k3: (ival1,ival2,ival3,ival4: integer;);
|
|
end;
|
|
count: integer; {number of constants to repeat}
|
|
i,j,k: integer; {loop variables}
|
|
lsegDisp: longint; {for backtracking while writting the }
|
|
{ debugger's symbol table }
|
|
lval: longint; {temp storage for long constant}
|
|
nptr: stringPtr; {pointer to a name}
|
|
sptr: longstringPtr; {pointer to a string constant}
|
|
|
|
|
|
procedure GenImmediate1;
|
|
|
|
{ generate a one byte immediate operand }
|
|
|
|
begin {GenImmediate1}
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235); Out(1); {one byte expression}
|
|
Out(128); {current location ctr}
|
|
Out(129); Out2(-16); Out2(-1); {-16}
|
|
Out(7); {bit shift}
|
|
Out(0); {end of expr}
|
|
pc := pc+1;
|
|
end {if}
|
|
else if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand)
|
|
else if (flags & shift16) <> 0 then
|
|
RefName(name, operand, 1, -16)
|
|
else
|
|
CnOut(operand);
|
|
end; {GenImmediate1}
|
|
|
|
|
|
procedure GenImmediate2;
|
|
|
|
{ generate a two byte immediate operand }
|
|
|
|
begin {GenImmediate2}
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235); Out(2);
|
|
LabelSearch(maxLabel, 2, 0, 0);
|
|
if operand <> 0 then begin
|
|
Out(129);
|
|
Out2(operand); if (operand < 0) then Out2(-1) else Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if (flags & shift16) <> 0 then begin
|
|
Out(129);
|
|
Out2(-16); Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else if (flags & shift8) <> 0 then
|
|
RefName(name, operand, 2, -8)
|
|
else if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand)
|
|
else if (flags & shift16) <> 0 then
|
|
RefName(name, operand, 2, -16)
|
|
else if name = nil then
|
|
CnOut2(operand)
|
|
else
|
|
RefName(name, operand, 2, 0);
|
|
end; {GenImmediate2}
|
|
|
|
|
|
procedure DefGlobal (private: integer);
|
|
|
|
{ define a global label }
|
|
{ }
|
|
{ parameters: }
|
|
{ private - private flag }
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
|
|
begin {DefGlobal}
|
|
Purge;
|
|
Out(230); {global label definition}
|
|
Out(ord(name^[0])); {write label name}
|
|
for i := 1 to ord(name^[0]) do
|
|
Out(ord(name^[i]));
|
|
Out2(0); {length attribute}
|
|
Out(ord('N')); {type attribute: other directive}
|
|
Out(private); {private or global?}
|
|
end; {DefGlobal}
|
|
|
|
|
|
begin {WriteNative}
|
|
{ writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1,
|
|
' operand=', operand:1); {debug}
|
|
case mode of
|
|
|
|
implied:
|
|
CnOut(opcode);
|
|
|
|
immediate: begin
|
|
if opcode = d_bmov then
|
|
GenImmediate1
|
|
else begin
|
|
if opcode = m_and_imm then
|
|
if not longA then
|
|
if operand = 255 then
|
|
goto 1;
|
|
CnOut(opcode);
|
|
if opcode = m_pea then
|
|
GenImmediate2
|
|
else if opcode in
|
|
[m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm,
|
|
m_sbc_imm,m_bit_imm] then
|
|
if longA then
|
|
GenImmediate2
|
|
else
|
|
GenImmediate1
|
|
else if opcode in [m_rep,m_sep,m_cop] then begin
|
|
GenImmediate1;
|
|
if opcode = m_rep then begin
|
|
if odd(operand div 32) then longA := true;
|
|
if odd(operand div 16) then longI := true;
|
|
end {if}
|
|
else if opcode = m_sep then begin
|
|
if odd(operand div 32) then longA := false;
|
|
if odd(operand div 16) then longI := false;
|
|
end; {else}
|
|
end {else}
|
|
else
|
|
if longI then
|
|
GenImmediate2
|
|
else
|
|
GenImmediate1;
|
|
end; {else}
|
|
end;
|
|
|
|
longabs: begin
|
|
CnOut(opcode);
|
|
isJSL := opcode = m_jsl; {allow for dynamic segs}
|
|
if name = nil then
|
|
if odd(flags div toolcall) then begin
|
|
CnOut2(0);
|
|
CnOut(225);
|
|
end {if}
|
|
else
|
|
LabelSearch(operand, 3, 0, 0)
|
|
else
|
|
if odd(flags div toolcall) then begin
|
|
CnOut2(long(name).lsw);
|
|
CnOut(long(name).msw);
|
|
end {if}
|
|
else
|
|
RefName(name, operand, 3, 0);
|
|
isJSL := false;
|
|
end;
|
|
|
|
longabsolute: begin
|
|
if opcode <> d_add then begin
|
|
CnOut(opcode);
|
|
i := 3;
|
|
end {if}
|
|
else
|
|
i := 4;
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, i, 0, operand)
|
|
else if (flags & constantOpnd) <> 0 then begin
|
|
lval := ord4(name);
|
|
CnOut2(long(lval).lsw);
|
|
if opcode = d_add then
|
|
CnOut2(long(lval).msw)
|
|
else
|
|
CnOut(long(lval).msw);
|
|
end {else if}
|
|
else if name <> nil then
|
|
RefName(name, operand, i, 0)
|
|
else begin
|
|
CnOut2(operand);
|
|
CnOut(0);
|
|
if opcode = d_add then
|
|
CnOut(0);
|
|
end; {else}
|
|
end;
|
|
|
|
absolute: begin
|
|
if opcode <> d_add then
|
|
CnOut(opcode);
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 2, 0, operand)
|
|
else if name <> nil then
|
|
RefName(name, operand, 2, 0)
|
|
else if (flags & constantOpnd) <> 0 then
|
|
CnOut2(operand)
|
|
else
|
|
LabelSearch(operand, 2, 0, 0);
|
|
end;
|
|
|
|
direct: begin
|
|
if opcode <> d_add then
|
|
CnOut(opcode);
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 1, 0, operand)
|
|
else if name <> nil then
|
|
RefName(name, operand, 1, 0)
|
|
else
|
|
CnOut(operand);
|
|
end;
|
|
|
|
longrelative: begin
|
|
CnOut(opcode);
|
|
LabelSearch(operand, -2, 0, 0);
|
|
end;
|
|
|
|
relative: begin
|
|
CnOut(opcode);
|
|
LabelSearch(operand, -1, 0, 0);
|
|
end;
|
|
|
|
gnrLabel:
|
|
if name = nil then
|
|
UpDate(operand, pc+cbufflen)
|
|
else begin
|
|
DefGlobal((flags >> 5) & 1);
|
|
if operand <> 0 then begin
|
|
Out(241);
|
|
Out2(operand);
|
|
Out2(0);
|
|
pc := pc+operand;
|
|
end; {if}
|
|
end; {else}
|
|
|
|
gnrSpace:
|
|
if operand <> 0 then begin
|
|
Out(241);
|
|
Out2(operand);
|
|
Out2(0);
|
|
pc := pc+operand;
|
|
end; {if}
|
|
|
|
gnrConstant: begin
|
|
if icptr(name)^.optype = cgString then
|
|
count := 1
|
|
else
|
|
count := icptr(name)^.q;
|
|
for i := 1 to count do
|
|
case icptr(name)^.optype of
|
|
cgByte,cgUByte : CnOut(icptr(name)^.r);
|
|
cgWord,cgUWord : CnOut2(icptr(name)^.r);
|
|
cgLong,cgULong : begin
|
|
lval := icptr(name)^.lval;
|
|
CnOut2(long(lval).lsw);
|
|
CnOut2(long(lval).msw);
|
|
end;
|
|
cgReal : begin
|
|
cnv.rval := icptr(name)^.rval;
|
|
CnOut2(cnv.ival1);
|
|
CnOut2(cnv.ival2);
|
|
end;
|
|
cgDouble : begin
|
|
cnv.dval := icptr(name)^.rval;
|
|
CnOut2(cnv.ival1);
|
|
CnOut2(cnv.ival2);
|
|
CnOut2(cnv.ival3);
|
|
CnOut2(cnv.ival4);
|
|
end;
|
|
cgComp : begin
|
|
cns.itsReal := icptr(name)^.rval;
|
|
CnvSC(cns);
|
|
for j := 1 to 8 do
|
|
CnOut(cns.inCOMP[j]);
|
|
end;
|
|
cgExtended : begin
|
|
cns.itsReal := icptr(name)^.rval;
|
|
CnvSX(cns);
|
|
for j := 1 to 10 do
|
|
CnOut(cns.inSANE[j]);
|
|
end;
|
|
cgString : begin
|
|
sptr := icptr(name)^.str;
|
|
for j := 1 to sptr^.length do
|
|
CnOut(ord(sPtr^.str[j]));
|
|
end;
|
|
ccPointer : begin
|
|
if icptr(name)^.lab <> nil then begin
|
|
Purge;
|
|
Out(235);
|
|
Out(4);
|
|
Out(131);
|
|
pc := pc+4;
|
|
nptr := icptr(name)^.lab;
|
|
for j := 0 to ord(nptr^[0]) do
|
|
Out(ord(nptr^[j]));
|
|
lval := icptr(name)^.pVal;
|
|
if lval <> 0 then begin
|
|
Out(129);
|
|
Out2(long(lval).lsw);
|
|
Out2(long(lval).msw);
|
|
Out(2-icptr(name)^.r);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else begin
|
|
lval := icptr(name)^.pVal;
|
|
if icptr(name)^.r = 1 then
|
|
operand := stringSize+long(lval).lsw
|
|
else
|
|
operand := stringSize-long(lval).lsw;
|
|
flags := stringReference;
|
|
GenImmediate2;
|
|
flags := stringReference+shift16;
|
|
GenImmediate2;
|
|
sptr := icptr(name)^.pStr;
|
|
j := sptr^.length;
|
|
if maxString-stringSize >= j+1 then begin
|
|
for k := 1 to j do
|
|
stringSpace[k+stringSize] :=
|
|
sptr^.str[k];
|
|
stringSpace[stringSize+j+1] := chr(0);
|
|
stringSize := stringSize+j+1;
|
|
end {if}
|
|
else
|
|
Error(cge3);
|
|
end; {else}
|
|
end;
|
|
otherwise : Error(cge1);
|
|
end; {case}
|
|
end;
|
|
|
|
genAddress: begin
|
|
if opcode < 256 then
|
|
CnOut(opcode);
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235);
|
|
Out(2);
|
|
LabelSearch(maxLabel,2,0,0);
|
|
if operand <> 0 then begin
|
|
Out(129);
|
|
Out2(operand);
|
|
Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if (flags & shift16) <> 0 then begin
|
|
Out(129);
|
|
Out2(-16);
|
|
Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else if operand = 0 then begin
|
|
CnOut(0);
|
|
CnOut(0);
|
|
end {else if}
|
|
else if (flags & shift16) <> 0 then
|
|
if longA then
|
|
LabelSearch(operand, 2, 16, 0)
|
|
else
|
|
LabelSearch(operand, 1, 16, 0)
|
|
else
|
|
LabelSearch(operand, 0, 0, 0);
|
|
end;
|
|
|
|
special:
|
|
if opcode = d_pin then begin
|
|
segDisp := 36;
|
|
out2(long(pc).lsw+cBuffLen);
|
|
blkCnt := blkCnt-2;
|
|
segDisp := blkCnt;
|
|
end {if}
|
|
else if opcode = d_sym then begin
|
|
CnOut(m_cop);
|
|
CnOut(5);
|
|
Purge;
|
|
lsegDisp := segDisp+1;
|
|
CnOut2(0);
|
|
symLength := 0;
|
|
GenSymbols(pointer(name), operand);
|
|
segDisp := lSegDisp;
|
|
out2(symLength);
|
|
blkCnt := blkCnt-2;
|
|
segDisp := blkCnt;
|
|
end {else if}
|
|
else {d_wrd}
|
|
CnOut2(operand);
|
|
|
|
otherwise: Error(cge1);
|
|
|
|
end; {case}
|
|
1:
|
|
end; {WriteNative}
|
|
|
|
|
|
procedure CheckRegisters(p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
label 1,2;
|
|
|
|
begin {CheckRegisters}
|
|
case p_opcode of
|
|
m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,m_and_imm,
|
|
m_and_s,m_asl_a,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_lda_absx,
|
|
m_lda_dirx,m_lda_indl,m_lda_indly,m_lda_longx,m_lda_s,m_lsr_a,m_ora_abs,
|
|
m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_long,m_ora_longX,m_ora_s,m_pla,
|
|
m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc,m_tsb_dir,m_tsb_abs:
|
|
aRegister.condition := regUnknown;
|
|
|
|
m_ldy_absX,m_ldy_dirX,m_ply:
|
|
yRegister.condition := regUnknown;
|
|
|
|
m_plx:
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_clc,m_cmp_abs,
|
|
m_cmp_dir,m_cmp_imm,m_cmp_s,m_cpx_imm,m_jml,m_pha,m_phb,m_phd,
|
|
m_phx,m_phy,m_plb,m_pld,m_rtl,m_rts,m_sec,m_sta_absX,
|
|
m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_longX,
|
|
m_sta_s,m_stx_dir,m_sty_dir,m_sty_dirX,m_stz_abs,m_stz_absX,
|
|
m_stz_dir,m_stz_dirX,m_tcs,m_tcd,d_add,d_pin,m_pei_dir,m_cpx_abs,
|
|
m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd: ;
|
|
|
|
m_pea: begin
|
|
if aRegister.condition = regImmediate then
|
|
if aRegister.value = p_operand then
|
|
if aRegister.lab = p_name then
|
|
if aRegister.flags = p_flags then
|
|
if longA then begin
|
|
p_opcode := m_pha;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
if longI then begin
|
|
if xRegister.condition = regImmediate then
|
|
if xRegister.value = p_operand then
|
|
if xRegister.lab = p_name then
|
|
if xRegister.flags = p_flags then begin
|
|
p_opcode := m_phx;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
if yRegister.condition = regImmediate then
|
|
if yRegister.value = p_operand then
|
|
if yRegister.lab = p_name then
|
|
if yRegister.flags = p_flags then begin
|
|
p_opcode := m_phy;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
end; {if}
|
|
end;
|
|
|
|
m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long: begin
|
|
if aRegister.condition = regAbsolute then
|
|
if aRegister.lab = p_name then
|
|
if aRegister.value = p_operand then
|
|
if not (p_opcode in [m_sta_abs,m_sta_long]) then
|
|
aRegister.condition := regUnknown;
|
|
if xRegister.condition = regAbsolute then
|
|
if xRegister.lab = p_name then
|
|
if xRegister.value = p_operand then
|
|
if p_opcode <> m_stx_abs then
|
|
xRegister.condition := regUnknown;
|
|
if yRegister.condition = regAbsolute then
|
|
if yRegister.lab = p_name then
|
|
if yRegister.value = p_operand then
|
|
if p_opcode <> m_sty_abs then
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_dec_dir,m_dec_dirX,m_inc_dir,m_inc_dirX: begin
|
|
if aRegister.condition = regLocal then
|
|
if aRegister.value = p_operand then
|
|
aRegister.condition := regUnknown;
|
|
if xRegister.condition = regLocal then
|
|
if xRegister.value = p_operand then
|
|
xRegister.condition := regUnknown;
|
|
if yRegister.condition = regLocal then
|
|
if yRegister.value = p_operand then
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_dex:
|
|
if xRegister.condition = regImmediate then
|
|
xRegister.value := xRegister.value-1
|
|
else
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_dey:
|
|
if yRegister.condition = regImmediate then
|
|
yRegister.value := yRegister.value-1
|
|
else
|
|
yRegister.condition := regUnknown;
|
|
|
|
m_ina:
|
|
if aRegister.condition = regImmediate then
|
|
aRegister.value := aRegister.value+1
|
|
else
|
|
aRegister.condition := regUnknown;
|
|
|
|
m_inx:
|
|
if xRegister.condition = regImmediate then
|
|
xRegister.value := xRegister.value+1
|
|
else
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_iny:
|
|
if yRegister.condition = regImmediate then
|
|
yRegister.value := yRegister.value+1
|
|
else
|
|
yRegister.condition := regUnknown;
|
|
|
|
otherwise,
|
|
m_jsl,m_mvn,m_rep,m_sep,d_lab,d_end,d_bmov,d_cns: begin
|
|
aRegister.condition := regUnknown;
|
|
xRegister.condition := regUnknown;
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_lda_abs,m_lda_long: begin
|
|
if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end;
|
|
aRegister.condition := regAbsolute;
|
|
aRegister.value := p_operand;
|
|
aRegister.lab := p_name;
|
|
aRegister.flags := p_flags;
|
|
end;
|
|
|
|
m_lda_dir: begin
|
|
if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end; {else if}
|
|
aRegister.condition := regLocal;
|
|
aRegister.value := p_operand;
|
|
aRegister.flags := p_flags;
|
|
end;
|
|
|
|
m_lda_imm: begin
|
|
if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end; {else if}
|
|
if (aRegister.condition = regImmediate) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then
|
|
if aRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dea;
|
|
p_mode := implied;
|
|
aRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if aRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_ina;
|
|
p_mode := implied;
|
|
aRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
aRegister.condition := regImmediate;
|
|
aRegister.value := p_operand;
|
|
aRegister.flags := p_flags;
|
|
aRegister.lab := p_name;
|
|
end;
|
|
|
|
m_ldx_abs: begin
|
|
if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then
|
|
goto 1
|
|
else if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else if}
|
|
else if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
xRegister.condition := regAbsolute;
|
|
xRegister.value := p_operand;
|
|
xRegister.lab := p_name;
|
|
xRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldx_dir: begin
|
|
if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then
|
|
goto 1
|
|
else if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else if}
|
|
else if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
xRegister.condition := regLocal;
|
|
xRegister.value := p_operand;
|
|
xRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldx_imm: begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then
|
|
goto 1
|
|
else if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else}
|
|
else if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then
|
|
if xRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dex;
|
|
p_mode := implied;
|
|
xRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if xRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_inx;
|
|
p_mode := implied;
|
|
xRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
xRegister.condition := regImmediate;
|
|
xRegister.value := p_operand;
|
|
xRegister.flags := p_flags;
|
|
xRegister.lab := p_name;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_abs: begin
|
|
if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then
|
|
goto 1
|
|
else if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
yRegister.condition := regAbsolute;
|
|
yRegister.value := p_operand;
|
|
yRegister.lab := p_name;
|
|
yRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_dir: begin
|
|
if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then
|
|
goto 1
|
|
else if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
yRegister.condition := regLocal;
|
|
yRegister.value := p_operand;
|
|
yRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_imm: begin
|
|
if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then
|
|
goto 1
|
|
else if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.flags = p_flags) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
if (yRegister.condition = regImmediate) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then
|
|
if yRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dey;
|
|
p_mode := implied;
|
|
yRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if yRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_iny;
|
|
p_mode := implied;
|
|
yRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
yRegister.condition := regImmediate;
|
|
yRegister.value := p_operand;
|
|
yRegister.flags := p_flags;
|
|
yRegister.lab := p_name;
|
|
end; {else}
|
|
end;
|
|
|
|
m_tax: begin
|
|
if aRegister.condition <> regUnknown then
|
|
if aRegister.condition = xRegister.condition then
|
|
if aRegister.value = xRegister.value then
|
|
if aRegister.flags = xRegister.flags then
|
|
if aRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if aRegister.lab = xRegister.lab then
|
|
goto 1;
|
|
xRegister := aRegister;
|
|
end;
|
|
|
|
m_tay: begin
|
|
if aRegister.condition <> regUnknown then
|
|
if aRegister.condition = yRegister.condition then
|
|
if aRegister.value = yRegister.value then
|
|
if aRegister.flags = yRegister.flags then
|
|
if aRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if aRegister.lab = yRegister.lab then
|
|
goto 1;
|
|
yRegister := aRegister;
|
|
end;
|
|
|
|
m_txa: begin
|
|
if xRegister.condition <> regUnknown then
|
|
if xRegister.condition = aRegister.condition then
|
|
if xRegister.value = aRegister.value then
|
|
if xRegister.flags = aRegister.flags then
|
|
if xRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if xRegister.lab = aRegister.lab then
|
|
goto 1;
|
|
aRegister := xRegister;
|
|
end;
|
|
|
|
m_txy: begin
|
|
if xRegister.condition <> regUnknown then
|
|
if xRegister.condition = yRegister.condition then
|
|
if xRegister.value = yRegister.value then
|
|
if xRegister.flags = yRegister.flags then
|
|
if xRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if xRegister.lab = yRegister.lab then
|
|
goto 1;
|
|
yRegister := xRegister;
|
|
end;
|
|
|
|
m_tya: begin
|
|
if yRegister.condition <> regUnknown then
|
|
if yRegister.condition = aRegister.condition then
|
|
if yRegister.value = aRegister.value then
|
|
if yRegister.flags = aRegister.flags then
|
|
if yRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if yRegister.lab = aRegister.lab then
|
|
goto 1;
|
|
aRegister := yRegister;
|
|
end;
|
|
|
|
m_tyx: begin
|
|
if yRegister.condition <> regUnknown then
|
|
if yRegister.condition = xRegister.condition then
|
|
if yRegister.value = xRegister.value then
|
|
if yRegister.flags = xRegister.flags then
|
|
if yRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if yRegister.lab = xRegister.lab then
|
|
goto 1;
|
|
xRegister := yRegister;
|
|
end;
|
|
end; {case}
|
|
2:
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
1:
|
|
end; {CheckRegisters}
|
|
|
|
|
|
procedure Remove (ns: integer); extern;
|
|
|
|
{ Remove the instruction ns from the peephole array }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - index of the instruction to remove }
|
|
|
|
|
|
function Short (n, lab: integer): boolean; extern;
|
|
|
|
{ see if a label is within range of a one-byte relative branch }
|
|
{ }
|
|
{ parameters: }
|
|
{ n - index to branch instruction }
|
|
{ lab - label number }
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
procedure EndSeg;
|
|
|
|
{ close out the current segment }
|
|
|
|
var
|
|
i: integer;
|
|
|
|
begin {EndSeg}
|
|
Purge; {dump constant buffer}
|
|
if stringsize <> 0 then begin {define string space}
|
|
UpDate(maxLabel, pc); {define the local label for the string space}
|
|
for i := 1 to stringsize do
|
|
CnOut(ord(stringspace[i]));
|
|
Purge;
|
|
end; {if}
|
|
Out(0); {end the segment}
|
|
segDisp := 8; {update header}
|
|
Out2(long(pc).lsw);
|
|
Out2(long(pc).msw);
|
|
if pc > $0000FFFF then
|
|
if currentSegment <> '~ARRAYS ' then
|
|
Error(112);
|
|
blkcnt := blkcnt-4; {purge the segment to disk}
|
|
segDisp := blkcnt;
|
|
CloseSeg;
|
|
end; {EndSeg}
|
|
|
|
|
|
procedure GenNative {p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer};
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
var
|
|
done: boolean; {loop termination}
|
|
llongA: boolean; {for tracking A size during opt.}
|
|
i: integer; {index}
|
|
op: integer; {temp storage for opcode}
|
|
|
|
|
|
procedure Purge;
|
|
|
|
{ Empty the peephole array }
|
|
|
|
begin {Purge}
|
|
while nnextSpot > 1 do begin
|
|
if registers then
|
|
CheckRegisters(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
|
|
npeep[1].name, npeep[1].flags)
|
|
else
|
|
WriteNative(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
|
|
npeep[1].name, npeep[1].flags);
|
|
Remove(1);
|
|
end; {while}
|
|
end; {Purge}
|
|
|
|
|
|
procedure Optimize(ns: integer; longA: boolean);
|
|
|
|
{ Optimize the instruction starting at ns }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - index of instruction to check for optimization }
|
|
{ longA - is the accumulator long? }
|
|
|
|
label 1;
|
|
|
|
var
|
|
tn: nativeType; {temp operation}
|
|
|
|
|
|
function ASafe (ns: integer): boolean;
|
|
|
|
{ See if it is safe to skip loading the A register }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - starting index }
|
|
|
|
label 1;
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
opcode: integer; {copy of current op code}
|
|
|
|
begin {ASafe}
|
|
ASafe := false;
|
|
for i := ns to nnextSpot-1 do begin
|
|
opcode := npeep[i].opcode;
|
|
if opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_jml,m_jsl,
|
|
m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,m_lda_indl,
|
|
m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_mvn,m_pla,m_rtl,
|
|
m_rts,m_tdc,m_txa,m_tya,m_tsc,d_end,d_bmov,d_add,d_pin,d_wrd,
|
|
d_sym,d_cns] then begin
|
|
ASafe := true;
|
|
goto 1;
|
|
end {if}
|
|
else if not (opcode in
|
|
[m_clc,m_cop,m_cpx_abs,m_cpx_dir,m_cpx_imm,m_dec_abs,m_dec_absX,
|
|
m_dec_dir,m_dec_dirX,m_dex,m_dey,m_inc_abs,m_inc_absX,m_inc_dir,
|
|
m_inc_dirX,m_inx,m_iny,m_ldx_abs,m_ldx_dir,m_ldx_imm,m_ldy_abs,
|
|
m_ldy_absX,m_ldy_dir,m_ldy_dirX,m_ldy_imm,m_pea,m_pei_dir,m_phb,
|
|
m_phd,m_phx,m_phy,m_php,m_plb,m_pld,m_plx,m_ply,m_plp,m_rep,
|
|
m_sec,m_sep,m_stx_dir,m_stx_abs,m_sty_abs,m_sty_dir,m_sty_dirX,
|
|
m_stz_abs,m_stz_absX,m_stz_dir,m_stz_dirX,m_tsx,m_txs,m_txy,
|
|
m_tyx,d_lab]) then
|
|
goto 1;
|
|
end; {for}
|
|
1:
|
|
end; {ASafe}
|
|
|
|
|
|
function SignExtension (ns: integer): boolean;
|
|
|
|
{ See if the pattern is a sugn extension }
|
|
{ }
|
|
{ Parameters: }
|
|
{ ns - start of suspected pattern }
|
|
{ }
|
|
{ Returns: true for a sign extension, else false }
|
|
|
|
begin {SignExtension}
|
|
SignExtension := false;
|
|
if npeep[ns].opcode = m_ldx_imm then
|
|
if npeep[ns].operand = 0 then
|
|
if npeep[ns+1].opcode = m_tay then
|
|
if npeep[ns+2].opcode = m_bpl then
|
|
if npeep[ns+3].opcode = m_dex then
|
|
SignExtension := true;
|
|
end; {SignExtension}
|
|
|
|
|
|
begin {Optimize}
|
|
with npeep[ns] do
|
|
case opcode of
|
|
|
|
m_and_imm:
|
|
if npeep[ns+1].opcode = m_and_imm then begin
|
|
operand := operand & npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_eor_imm:
|
|
if npeep[ns+1].opcode = m_eor_imm then begin
|
|
operand := operand ! npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_ora_imm:
|
|
if npeep[ns+1].opcode = m_ora_imm then begin
|
|
operand := operand | npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
|
|
m_asl_a:
|
|
if npeep[ns+1].opcode = m_tay then
|
|
if npeep[ns+2].opcode = m_iny then
|
|
if npeep[ns+3].opcode = m_iny then begin
|
|
opcode := m_ina;
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
npeep[ns+2].opcode := m_tay;
|
|
Remove(ns+3);
|
|
end; {if}
|
|
|
|
m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc:
|
|
if npeep[ns+2].opcode = d_lab then
|
|
if npeep[ns+2].operand = operand then
|
|
if npeep[ns+1].opcode = m_brl then begin
|
|
if Short(ns,npeep[ns+1].operand) then begin
|
|
operand := npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
if opcode = m_bcs then
|
|
opcode := m_bcc
|
|
else if opcode = m_beq then
|
|
opcode := m_bne
|
|
else if opcode = m_bne then
|
|
opcode := m_beq
|
|
else if opcode = m_bmi then
|
|
opcode := m_bpl
|
|
else if opcode = m_bcc then
|
|
opcode := m_bcs
|
|
else
|
|
opcode := m_bmi;
|
|
end; {if}
|
|
end {if m_brl}
|
|
else if npeep[ns+1].opcode = m_bra then begin
|
|
operand := npeep[ns+1].operand;
|
|
Remove(ns+1); Remove(ns+1);
|
|
if opcode = m_bcs then
|
|
opcode := m_bcc
|
|
else if opcode = m_beq then
|
|
opcode := m_bne
|
|
else if opcode = m_bne then
|
|
opcode := m_beq
|
|
else if opcode = m_bmi then
|
|
opcode := m_bpl
|
|
else if opcode = m_bcc then
|
|
opcode := m_bcs
|
|
else
|
|
opcode := m_bmi;
|
|
end; {else if m_bra}
|
|
|
|
m_brl:
|
|
if Short(ns,operand) then begin
|
|
opcode := m_bra;
|
|
mode := relative;
|
|
didOne := true;
|
|
end; {if}
|
|
|
|
m_bvs:
|
|
if npeep[ns+2].opcode = d_lab then
|
|
if npeep[ns+2].operand = operand then
|
|
if npeep[ns+1].opcode = m_bmi then
|
|
if npeep[ns+4].opcode = d_lab then
|
|
if npeep[ns+1].operand = npeep[ns+4].operand then
|
|
if npeep[ns+3].opcode = m_brl then
|
|
if Short(ns,npeep[ns+3].operand) then
|
|
if Short(ns+1,npeep[ns+3].operand) then begin
|
|
operand := npeep[ns+3].operand;
|
|
npeep[ns+1].operand := npeep[ns+3].operand;
|
|
npeep[ns+1].opcode := m_bpl;
|
|
Remove(ns+3);
|
|
end; {if}
|
|
|
|
m_dec_abs:
|
|
if npeep[ns+1].opcode = m_lda_abs then
|
|
if name^ = npeep[ns+1].name^ then
|
|
if npeep[ns+2].opcode = m_beq then
|
|
Remove(ns+1);
|
|
|
|
m_lda_abs:
|
|
if npeep[ns+1].opcode = m_clc then begin
|
|
if npeep[ns+2].opcode = m_adc_abs then
|
|
if operand = npeep[ns+2].operand then
|
|
if name = npeep[ns+2].name then
|
|
if not rangeCheck then begin
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_dea then begin
|
|
if npeep[ns+2].opcode = m_tax then begin
|
|
opcode := m_ldx_abs;
|
|
npeep[ns+1].opcode := m_dex;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+2].opcode = m_sta_abs then begin
|
|
if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
|
|
m_ora_imm,m_ora_longX,m_ora_s] then
|
|
if operand = npeep[ns+2].operand then
|
|
if name = npeep[ns+2].name then begin
|
|
npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
|
|
npeep[ns+2].opcode := m_tsb_abs;
|
|
Remove(ns);
|
|
end; {if}
|
|
end {else if}
|
|
else if SignExtension(ns+1) then begin
|
|
npeep[ns+2] := npeep[ns];
|
|
Remove(ns);
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_xba then
|
|
if npeep[ns+2].opcode = m_and_imm then
|
|
if npeep[ns+2].operand = $00FF then begin
|
|
operand := operand+1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_lda_dir:
|
|
if npeep[ns+1].opcode = m_clc then begin
|
|
if npeep[ns+2].opcode = m_adc_dir then
|
|
if operand = npeep[ns+2].operand then
|
|
if not rangeCheck then begin
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end
|
|
else if npeep[ns+1].opcode = m_dea then begin
|
|
if npeep[ns+2].opcode = m_tax then begin
|
|
opcode := m_ldx_dir;
|
|
npeep[ns+1].opcode := m_dex;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_pha then begin
|
|
if longA then begin
|
|
opcode := m_pei_dir;
|
|
Remove(ns+1);
|
|
end {if}
|
|
end {else if}
|
|
else if npeep[ns+2].opcode = m_sta_dir then begin
|
|
if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
|
|
m_ora_imm,m_ora_longX,m_ora_s] then
|
|
if operand = npeep[ns+2].operand then begin
|
|
npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
|
|
npeep[ns+2].opcode := m_tsb_dir;
|
|
Remove(ns);
|
|
end {if}
|
|
end {else if}
|
|
else if SignExtension(ns+1) then begin
|
|
npeep[ns+2] := npeep[ns];
|
|
Remove(ns);
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_xba then
|
|
if npeep[ns+2].opcode = m_and_imm then
|
|
if npeep[ns+2].operand = $00FF then begin
|
|
operand := operand+1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_pei_dir:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
opcode := m_lda_dir;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_lda_imm:
|
|
if npeep[ns+1].opcode = m_pha then
|
|
if ASafe(ns+2) then
|
|
if longA then begin
|
|
opcode := m_pea;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_ldx_imm:
|
|
if npeep[ns+1].opcode = m_lda_imm then
|
|
if npeep[ns+2].opcode = m_phx then
|
|
if npeep[ns+3].opcode = m_pha then begin
|
|
opcode := m_pea;
|
|
npeep[ns+1].opcode := m_pea;
|
|
Remove(ns+2);
|
|
Remove(ns+2);
|
|
end; {if}
|
|
|
|
m_ldy_imm:
|
|
if npeep[ns+1].opcode = m_sep then
|
|
if npeep[ns+1].operand = 32 then begin
|
|
didOne := true;
|
|
tn := npeep[ns];
|
|
npeep[ns] := npeep[ns+1];
|
|
npeep[ns+1] := tn;
|
|
end; {if}
|
|
|
|
m_ora_abs:
|
|
if npeep[ns+1].opcode = m_sta_abs then
|
|
if operand = npeep[ns+1].operand then
|
|
if name = npeep[ns+1].name then begin
|
|
opcode := m_tsb_abs;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_ora_dir:
|
|
if npeep[ns+1].opcode = m_sta_dir then
|
|
if operand = npeep[ns+1].operand then begin
|
|
opcode := m_tsb_dir;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_pea:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
opcode := m_lda_imm;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_sta_abs:
|
|
if npeep[ns+1].opcode = m_lda_abs then
|
|
if operand = npeep[ns+1].operand then
|
|
if name = npeep[ns+1].name then
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
|
|
Remove(ns+1);
|
|
|
|
m_sta_dir:
|
|
if npeep[ns+1].opcode = m_lda_dir then
|
|
if operand = npeep[ns+1].operand then
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
|
|
Remove(ns+1);
|
|
|
|
m_plb:
|
|
if npeep[ns+1].opcode = m_phb then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_plx:
|
|
if npeep[ns+1].opcode = m_pha then begin
|
|
opcode := m_sta_s;
|
|
mode := direct;
|
|
operand := 1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_tax:
|
|
if npeep[ns+1].opcode = m_phx then begin
|
|
Remove(ns+1);
|
|
opcode := m_pha;
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_txa then begin
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_dey then
|
|
if npeep[ns+2].opcode = m_dey then
|
|
if npeep[ns+3].opcode = m_lda_indly then
|
|
if npeep[ns+4].opcode = m_stx_dir then
|
|
if (npeep[ns+4].operand - npeep[ns+3].operand < -1)
|
|
or (npeep[ns+4].operand - npeep[ns+3].operand > 2)
|
|
then begin
|
|
npeep[ns] := npeep[ns+4];
|
|
opcode := m_sta_dir;
|
|
Remove(ns+4);
|
|
end; {if}
|
|
|
|
m_tya:
|
|
if npeep[ns+1].opcode = m_sta_dir then begin
|
|
npeep[ns+1].opcode := m_sty_dir;
|
|
Remove(ns);
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_sta_abs then begin
|
|
npeep[ns+1].opcode := m_sty_abs;
|
|
Remove(ns);
|
|
end; {else if}
|
|
|
|
m_tyx:
|
|
if npeep[ns+1].opcode = m_phx then begin
|
|
Remove(ns+1);
|
|
opcode := m_phy;
|
|
end; {if}
|
|
|
|
m_pha:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end {if}
|
|
else if npeep[ns+1].opcode in [m_ldx_abs,m_ldx_dir] then
|
|
if npeep[ns+2].opcode = m_pla then begin
|
|
Remove(ns+2);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_phy:
|
|
if npeep[ns+1].opcode = m_ply then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_rep:
|
|
if npeep[ns+1].opcode = m_sep then
|
|
if npeep[ns].operand = npeep[ns+1].operand then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
{ kws }
|
|
{ stz $xx, stz $xx }
|
|
m_stz_abs, m_stz_absX:
|
|
if npeep[ns].opcode = npeep[ns+1].opcode then
|
|
if npeep[ns].operand = npeep[ns+1].operand then
|
|
if npeep[ns].name = npeep[ns+1].name then
|
|
if not volatile then
|
|
Remove(ns+1);
|
|
|
|
m_stz_dir, m_stz_dirX:
|
|
if npeep[ns].opcode = npeep[ns+1].opcode then
|
|
if npeep[ns].operand = npeep[ns+1].operand then
|
|
if not volatile then
|
|
Remove(ns+1);
|
|
|
|
otherwise: ;
|
|
|
|
end; {case}
|
|
1:
|
|
end; {Optimize}
|
|
|
|
begin {GenNative}
|
|
{ writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1,
|
|
' operand=', p_operand:1); {debug}
|
|
if npeephole and not (strictVararg and hasVarargsCall) then begin
|
|
if (nnextspot = 1) and not (p_opcode in nleadOpcodes) then begin
|
|
if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end {if}
|
|
else if p_opcode in nstopOpcodes then begin
|
|
repeat
|
|
didOne := false;
|
|
i := 1;
|
|
llongA := longA;
|
|
while i < nnextSpot-nMaxPeep do begin
|
|
op := npeep[i].opcode;
|
|
if op = m_sep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := false;
|
|
end {if}
|
|
else if op = m_rep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := true;
|
|
end; {else}
|
|
Optimize(i,llongA);
|
|
i := i+1;
|
|
end; {while}
|
|
until not didone;
|
|
Purge;
|
|
if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end {else if}
|
|
else if nnextSpot = npeepSize then begin
|
|
repeat
|
|
didOne := false;
|
|
i := 1;
|
|
llongA := longA;
|
|
while i < nnextSpot-nMaxPeep do begin
|
|
op := npeep[i].opcode;
|
|
if op = m_sep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := false;
|
|
end {if}
|
|
else if op = m_rep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := true;
|
|
end; {else}
|
|
Optimize(i,llongA);
|
|
i := i+1;
|
|
end; {while}
|
|
until not didone;
|
|
done := false;
|
|
repeat
|
|
if nnextSpot = 1 then
|
|
done := true
|
|
else begin
|
|
if npeep[1].opcode in nleadOpcodes then
|
|
done := true
|
|
else begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode,
|
|
nPeep[1].operand, nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name,nPeep[1].flags);
|
|
Remove(1);
|
|
end; {else}
|
|
end; {else}
|
|
until done;
|
|
if nnextSpot = nPeepSize then begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags);
|
|
Remove(1);
|
|
end; {if}
|
|
with npeep[nnextSpot] do begin
|
|
opcode := p_opcode;
|
|
mode := p_mode;
|
|
operand := p_operand;
|
|
name := p_name;
|
|
flags := p_flags;
|
|
end; {with}
|
|
nnextSpot := nnextSpot+1;
|
|
if not (npeep[1].opcode in nleadOpcodes) then begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags);
|
|
Remove(1);
|
|
end; {if}
|
|
end {else if}
|
|
else begin
|
|
with npeep[nnextSpot] do begin
|
|
opcode := p_opcode;
|
|
mode := p_mode;
|
|
operand := p_operand;
|
|
name := p_name;
|
|
flags := p_flags;
|
|
end; {with}
|
|
nnextSpot := nnextSpot+1;
|
|
end; {else}
|
|
end {if}
|
|
else if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end; {GenNative}
|
|
|
|
|
|
procedure GenImplied {p_opcode: integer};
|
|
|
|
{ short form of GenNative - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_code - operation code }
|
|
|
|
begin {GenImplied}
|
|
GenNative(p_opcode, implied, 0, nil, 0);
|
|
end; {GenImplied}
|
|
|
|
|
|
procedure GenCall {callNum: integer};
|
|
|
|
{ short form of jsl to library subroutine - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ callNum - subroutine # to generate a call for }
|
|
|
|
var
|
|
sp: stringPtr; {work string}
|
|
|
|
begin {GenCall}
|
|
case callNum of
|
|
1: sp := @'~CHECKSTACK';
|
|
2: sp := @'~RESETNAME';
|
|
3: sp := @'~CREALRET';
|
|
4: sp := @'~CDOUBLERET';
|
|
5: sp := @'~SETNAME';
|
|
6: sp := @'~SETLINENUMBER';
|
|
7: sp := @'~REALFN';
|
|
8: sp := @'~DOUBLEFN';
|
|
9: sp := @'~SAVEREAL';
|
|
10: sp := @'~SAVEDOUBLE';
|
|
11: sp := @'~CNVINTREAL';
|
|
12: sp := @'~CNVLONGREAL';
|
|
13: sp := @'~CNVULONGREAL';
|
|
14: sp := @'~CNVREALINT';
|
|
15: sp := @'~CNVREALUINT';
|
|
16: sp := @'~CNVREALLONG';
|
|
17: sp := @'~CNVREALULONG';
|
|
18: sp := @'~CNVL2'; {PASCAL}
|
|
19: sp := @'~SAVESET';
|
|
20: sp := @'~LOADSET'; {PASCAL}
|
|
21: sp := @'~LOADREAL';
|
|
22: sp := @'~LOADDOUBLE';
|
|
23: sp := @'~SHIFTLEFT';
|
|
24: sp := @'~SSHIFTRIGHT';
|
|
25: sp := @'~INTCHKC';
|
|
26: sp := @'~DIV2';
|
|
27: sp := @'~MOD2';
|
|
28: sp := @'~MUL2';
|
|
29: sp := @'~GRTL';
|
|
30: sp := @'~GEQL';
|
|
31: sp := @'~GRTE';
|
|
32: sp := @'~GEQE';
|
|
33: sp := @'~SETINCLUSION';
|
|
34: sp := @'~GRTSTRING';
|
|
35: sp := @'~GEQSTRING';
|
|
36: sp := @'~EQUE';
|
|
37: sp := @'~SETEQU';
|
|
38: sp := @'~EQUSTRING';
|
|
39: sp := @'~UMUL2';
|
|
40: sp := @'~UDIV2';
|
|
41: sp := @'~USHIFTRIGHT';
|
|
42: sp := @'~MUL4';
|
|
43: sp := @'~PDIV4';
|
|
44: sp := @'~MOD4';
|
|
45: sp := @'~SHL4';
|
|
46: sp := @'~LSHR4';
|
|
47: sp := @'~ASHR4'; {CC}
|
|
48: sp := @'~UMUL4'; {CC}
|
|
49: sp := @'~UDIV4'; {CC}
|
|
50: sp := @'~UMOD4'; {CC}
|
|
51: sp := @'~COPYREAL';
|
|
52: sp := @'~COPYDOUBLE';
|
|
53: sp := @'~XJPERROR';
|
|
54: sp := @'~MOVE';
|
|
55: sp := @'~MOVE2';
|
|
56: sp := @'~ADDE';
|
|
57: sp := @'~DIVE';
|
|
58: sp := @'~MULE';
|
|
59: sp := @'~SUBE';
|
|
60: sp := @'~POWER';
|
|
61: sp := @'~ARCTAN2E';
|
|
62: sp := @'~LONGMOVE';
|
|
63: sp := @'~LONGMOVE2';
|
|
64: sp := @'~CCOMPRET';
|
|
65: sp := @'~CEXTENDEDRET';
|
|
66: sp := @'~SAVECOMP';
|
|
67: sp := @'~SAVEEXTENDED';
|
|
68: sp := @'~COPYCOMP';
|
|
69: sp := @'~COPYEXTENDED';
|
|
70: sp := @'~LOADCOMP';
|
|
71: sp := @'~LOADEXTENDED';
|
|
72: sp := @'~LOADUBF';
|
|
73: sp := @'~LOADBF';
|
|
74: sp := @'~SAVEBF';
|
|
75: sp := @'~COPYBF';
|
|
76: sp := @'~STACKERR'; {CC}
|
|
77: sp := @'~LOADSTRUCT'; {CC}
|
|
otherwise:
|
|
Error(cge1);
|
|
end; {case}
|
|
GenNative(m_jsl, longabs, 0, sp, 0);
|
|
end; {GenCall}
|
|
|
|
|
|
procedure GenLab {lnum: integer};
|
|
|
|
{ generate a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lnum - label number }
|
|
|
|
begin {GenLab}
|
|
GenNative(d_lab, gnrlabel, lnum, nil, 0);
|
|
end; {GenLab}
|
|
|
|
|
|
procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean};
|
|
|
|
{ Set up the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
|
|
procedure RootFile;
|
|
|
|
{ Create and write the initial entry segment }
|
|
|
|
const
|
|
dispToOpen = 21; {disps to glue routines for NDAs}
|
|
dispToClose = 38;
|
|
dispToAction = 50;
|
|
dispToInit = 65;
|
|
dispToCDAOpen = 9; {disps to glue routines for CDAs}
|
|
dispToCDAClose = 36;
|
|
|
|
var
|
|
i: integer; {loop index}
|
|
lab: stringPtr; {for holdling names var pointers}
|
|
menuLen: integer; {length of the menu name string}
|
|
|
|
|
|
procedure SetDataBank;
|
|
|
|
{ set up the data bank register }
|
|
|
|
begin {SetDataBank}
|
|
CnOut(m_pea);
|
|
RefName(@'~GLOBALS', 0, 2, -8);
|
|
CnOut(m_plb);
|
|
CnOut(m_plb);
|
|
end; {SetDataBank}
|
|
|
|
|
|
begin {RootFile}
|
|
{open the initial object module}
|
|
fname2.theString.theString := concat(fname1.theString.theString, '.root');
|
|
fname2.theString.size := length(fname2.theString.theString);
|
|
OpenObj(fname2);
|
|
|
|
{write the header}
|
|
InitNative;
|
|
Header(@'~_ROOT', $4000, 0);
|
|
|
|
{new desk accessory initialization}
|
|
if isNewDeskAcc then begin
|
|
|
|
{set up the initial jump table}
|
|
lab := @'~_ROOT';
|
|
menuLen := length(menuLine);
|
|
RefName(lab, menuLen + dispToOpen, 4, 0);
|
|
RefName(lab, menuLen + dispToClose, 4, 0);
|
|
RefName(lab, menuLen + dispToAction, 4, 0);
|
|
RefName(lab, menuLen + dispToInit, 4, 0);
|
|
CnOut2(refreshPeriod);
|
|
CnOut2(eventMask);
|
|
for i := 1 to menuLen do
|
|
CnOut(ord(menuLine[i]));
|
|
CnOut(0);
|
|
|
|
{glue code for calling open routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(openName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_sta_s); CnOut(4);
|
|
CnOut(m_txa);
|
|
CnOut(m_sta_s); CnOut(6);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling close routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(closeName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling action routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pha);
|
|
CnOut(m_phy);
|
|
CnOut(m_phx);
|
|
CnOut(m_jsl);
|
|
RefName(actionName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling init routine}
|
|
CnOut(m_pha);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pha);
|
|
CnOut(m_jsl);
|
|
RefName(initName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{classic desk accessory initialization}
|
|
else if isClassicDeskAcc then begin
|
|
|
|
{write the name}
|
|
menuLen := length(menuLine);
|
|
CnOut(menuLen);
|
|
for i := 1 to menuLen do
|
|
CnOut(ord(menuLine[i]));
|
|
|
|
{set up the initial jump table}
|
|
lab := @'~_ROOT';
|
|
RefName(lab, menuLen + dispToCDAOpen, 4, 0);
|
|
RefName(lab, menuLen + dispToCDAClose, 4, 0);
|
|
|
|
{glue code for calling open routine}
|
|
CnOut(m_pea);
|
|
CnOut2(1);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(@'~CDASTART', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~CDASHUTDOWN', 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling close routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(closeName, 0, 3, 0);
|
|
CnOut(m_pea);
|
|
CnOut2(0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{control panel device initialization}
|
|
else if isCDev then begin
|
|
CnOut(m_pea);
|
|
CnOut2(1);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pla);
|
|
CnOut(m_sta_s); CnOut(13);
|
|
CnOut(m_pla);
|
|
CnOut(m_sta_s); CnOut(13);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_tay);
|
|
CnOut(m_lda_s); CnOut(3);
|
|
CnOut(m_pha);
|
|
CnOut(m_lda_s); CnOut(3);
|
|
CnOut(m_pha);
|
|
CnOut(m_txa);
|
|
CnOut(m_sta_s); CnOut(7);
|
|
CnOut(m_tya);
|
|
CnOut(m_sta_s); CnOut(5);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{NBA initialization}
|
|
else if isNBA then begin
|
|
CnOut(m_jsl);
|
|
RefName(@'~NBASTARTUP', 0, 3, 0);
|
|
CnOut(m_phx);
|
|
CnOut(m_phy);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~NBASHUTDOWN', 0, 3, 0);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{XCMD initialization}
|
|
else if isXCMD then begin
|
|
CnOut(m_jsl);
|
|
RefName(@'~XCMDSTARTUP', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~XCMDSHUTDOWN', 0, 3, 0);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{normal program initialization}
|
|
else begin
|
|
|
|
{write the initial JSL}
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~_BWSTARTUP4', 0, 3, 0)
|
|
else
|
|
RefName(@'~_BWSTARTUP3', 0, 3, 0);
|
|
|
|
{set the data bank register}
|
|
SetDataBank;
|
|
|
|
{write JSL to main entry point}
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~C_STARTUP2', 0, 3, 0)
|
|
else
|
|
RefName(@'~C_STARTUP', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(@'main', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~C_SHUTDOWN2', 0, 3, 0)
|
|
else
|
|
RefName(@'~C_SHUTDOWN', 0, 3, 0);
|
|
end;
|
|
|
|
{finish the current segment}
|
|
EndSeg;
|
|
end; {RootFile}
|
|
|
|
|
|
procedure SetStack;
|
|
|
|
{ Set up a stack frame }
|
|
|
|
begin {SetStack}
|
|
if stackSize <> 0 then begin
|
|
currentSegment := '~_STACK '; {write the header}
|
|
Header(@'~_STACK', $4012, 0);
|
|
Out($F1); {write the DS record to reserve space}
|
|
Out2(stackSize);
|
|
Out2(0);
|
|
EndSeg; {finish the current segment}
|
|
end; {if}
|
|
end; {SetStack}
|
|
|
|
|
|
begin {InitFile}
|
|
fname1 := keepname^;
|
|
if partial or (keepFlag = 3) then
|
|
FindSuffix(fname1, nextSuffix)
|
|
else begin
|
|
if (keepFlag = 1) and (not noroot) then begin
|
|
RootFile;
|
|
SetStack;
|
|
CloseObj;
|
|
end; {if}
|
|
DestroySuffixes(fname1);
|
|
nextSuffix := 'a';
|
|
end; {else}
|
|
fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix);
|
|
fname2.theString.size := length(fname2.theString.theString);
|
|
OpenObj(fname2);
|
|
end; {InitFile}
|
|
|
|
|
|
procedure InitNative;
|
|
|
|
{ set up for a new segment }
|
|
|
|
begin {InitNative}
|
|
aRegister.condition := regUnknown; {set up the peephole optimizer}
|
|
xRegister.condition := regUnknown;
|
|
yRegister.condition := regUnknown;
|
|
nnextspot := 1;
|
|
nleadOpcodes := [m_asl_a,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,m_bvs,m_bcc,
|
|
m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
|
|
m_pha,m_plb,m_plx,m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep,
|
|
m_ora_dir,m_ora_abs,m_and_imm,m_pea];
|
|
nstopOpcodes := [d_end,d_pin];
|
|
|
|
stringSize := 0; {initialize scalars for a new segment}
|
|
pc := 0;
|
|
cbufflen := 0;
|
|
longA := true;
|
|
longI := true;
|
|
end; {InitNative}
|
|
|
|
|
|
procedure RefName {lab: stringPtr; disp, len, shift: integer};
|
|
|
|
{ handle a reference to a named label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label name }
|
|
{ disp - displacement past the label }
|
|
{ len - number of bytes in the reference }
|
|
{ shift - shift factor }
|
|
|
|
var
|
|
i: integer; {loop var}
|
|
slen: integer; {length of string}
|
|
|
|
begin {RefName}
|
|
Purge; {clear any constant bytes}
|
|
if isJSL then {expression header}
|
|
Out(243)
|
|
else
|
|
Out(235);
|
|
Out(len);
|
|
Out(131);
|
|
pc := pc+len;
|
|
slen := length(lab^);
|
|
Out(slen);
|
|
for i := 1 to slen do
|
|
Out(ord(lab^[i]));
|
|
if disp <> 0 then begin {if there is a disp, add it in}
|
|
Out(129);
|
|
Out2(disp);
|
|
Out2(0);
|
|
Out(1);
|
|
end; {end}
|
|
if shift <> 0 then begin {if there is a shift, add it in}
|
|
Out(129);
|
|
Out2(shift);
|
|
if shift < 0 then
|
|
Out2(-1)
|
|
else
|
|
Out2(0);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0); {end of expression}
|
|
end; {RefName}
|
|
|
|
end.
|
|
|
|
{$append 'native.asm'}
|