Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-11-17 05:06:10 +00:00
Code Issues Projects Releases Wiki Activity
3e5aa5b7b0
ORCA-C/Native.pas

2415 lines
80 KiB
ObjectPascal
Raw Normal View History

Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{$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;
Move some more code out of the blank segment to make space for static data.
2017-07-15 00:45:40 +00:00
{$segment 'CODEGEN'}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
type
labelptr = ^labelentry; {pointer to a forward ref node}
labelentry = record {forward ref node}
Expand the size of the object buffer from 64K to 128K, and use 32-bit values to track related sizes. This allows functions that require an OMF segment byte count of up to 128K to be compiled, although the length in memory at run time is still limited to 64K. (The OMF segment byte count is usually larger, due to the size of relocation records, etc.) This is useful for compiling large functions, e.g. the main interpreter loop in git. It also fixes the bug shown in the compca23 test case, where functions that require a segment of over 64K may appear to compile correctly but generate corrupted OMF segment headers. This related to tracking sizes with 16-bit values that could roll over. This patch increases the memory needed at run time by 64K. This shouldn’t generally be a problem on systems with sufficient memory, although it does increase the minimum memory requirement a bit. If behavior in low-memory configurations is a concern, buffSize could be made into a run-time option.
2016-11-28 01:11:12 +00:00
addr: longint;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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
Add support for emitting 64-bit constants in statically-initialized data.
2021-02-04 08:17:10 +00:00
rkind = (k1,k2,k3,k4); {cnv record types}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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;);
Add support for emitting 64-bit constants in statically-initialized data.
2021-02-04 08:17:10 +00:00
k3: (qval: longlong);
k4: (ival1,ival2,ival3,ival4: integer;);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end;
count: integer; {number of constants to repeat}
i,j,k: integer; {loop variables}
Spellcheck comments throughout the code. There are no non-comment changes.
2020-01-29 23:09:52 +00:00
lsegDisp: longint; {for backtracking while writing the }
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{ 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);
When pointer arithmetic is used to initialize a global or static variable to point before the beginning of a string constant, initialize it to the value indicated by the pointer arithmetic. Previously, such initializations would sometimes generate a garbage value pointing up to 65535 bytes beyond the start of the string constant. (This was due to a lack of sign-extension in the object code generation.) Computing a pointer to before the start of an object invokes undefined behavior, so the previous behavior wasn't technically wrong, but it was unintuitive and served no useful purpose. The new behavior should at least be easier to understand and debug.
2015-12-29 06:59:20 +00:00
Out2(operand); if (operand < 0) then Out2(-1) else Out2(0);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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;
Add support for emitting 64-bit constants in statically-initialized data.
2021-02-04 08:17:10 +00:00
cgQuad,cgUQuad : begin
cnv.qval := icptr(name)^.qval;
CnOut2(cnv.ival1);
CnOut2(cnv.ival2);
CnOut2(cnv.ival3);
CnOut2(cnv.ival4);
end;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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,
Fix bug where comparing 32-bit values in static arrays or structs against 0 may give wrong results with large memory model. The issue was that 16-bit absolute addressing (in the data bank) was being used to access the data to compare, but with the large memory model the static arrays or structs are not necessarily in the same bank, so absolute long addressing should be used. This was sometimes causing failures in the C4.6.4.1.CC and C4.6.6.1.CC conformance tests in the ORCA/C test suite. The following program often demonstrates the problem (depending on memory layout and contents): #pragma memorymodel 1 #pragma optimize 1 #include <stdio.h> int i; char ch1[32000]; long L1[1]; int main (void) { if (L1 [0] != 0) printf("%li\n", L1[0]); /* shouldn't print */ /* buggy behavior can happen if the bank bytes of these pointers differ */ printf("%p %p\n", &L1[0], &i); }
2016-11-23 06:56:20 +00:00
m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_long,m_ora_longX,m_ora_s,m_pla,
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc:
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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,
PLD/TCD should invalidate register==DP location correspondences. I don't think this ever comes up in code from the ORCA code generator, but it can in inline assembly.
2021-02-03 00:36:18 +00:00
m_phx,m_phy,m_plb,m_rtl,m_rts,m_sec,m_tcs,d_add,d_pin,
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
m_pei_dir,m_cpx_abs,m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd: ;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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;
PLD/TCD should invalidate register==DP location correspondences. I don't think this ever comes up in code from the ORCA code generator, but it can in inline assembly.
2021-02-03 00:36:18 +00:00
m_sta_s,m_pld,m_tcd: begin
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
if aRegister.condition = regLocal then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
yRegister.condition := regUnknown;
end;
m_sta_indl,m_sta_indlY: begin
if aRegister.condition <> regImmediate then
aRegister.condition := regUnknown;
if xRegister.condition <> regImmediate then
xRegister.condition := regUnknown;
if yRegister.condition <> regImmediate then
yRegister.condition := regUnknown;
end;
m_sta_absX,m_stz_absX,m_sta_longX: begin
if aRegister.condition = regAbsolute then
if aRegister.lab = p_name then
aRegister.condition := regUnknown;
if xRegister.condition = regAbsolute then
if xRegister.lab = p_name then
xRegister.condition := regUnknown;
if yRegister.condition = regAbsolute then
if yRegister.lab = p_name then
yRegister.condition := regUnknown;
end;
m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long,m_stz_abs,
m_tsb_abs: begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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;
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
m_dec_dir,m_inc_dir,m_tsb_dir,m_sta_dir,m_stx_dir,m_sty_dir,m_stz_dir: begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if aRegister.condition = regLocal then
if aRegister.value = p_operand then
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
if p_opcode <> m_sta_dir then
aRegister.condition := regUnknown;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if xRegister.condition = regLocal then
if xRegister.value = p_operand then
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
if p_opcode <> m_stx_dir then
xRegister.condition := regUnknown;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if yRegister.condition = regLocal then
if yRegister.value = p_operand then
Fix register optimizer bug that generated bad code in some cases. The register optimizer tracks when a register is known to contain the same value as a memory location (direct page or absolute) and does optimizations based on this. But it did not always recognize when this information had become invalid because of a subsequent store to the memory location, so it might perform invalid optimizations. This patch adds those checks. This fixes #66.
2020-01-28 18:54:18 +00:00
if p_opcode <> m_sty_dir then
yRegister.condition := regUnknown;
end;
m_dec_dirX,m_inc_dirX,m_sta_dirX,m_sty_dirX,m_stz_dirX: begin
if aRegister.condition = regLocal then
if aRegister.value >= p_operand-1 then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
if xRegister.value >= p_operand-1 then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
if yRegister.value >= p_operand-1 then
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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);
Expand the size of the object buffer from 64K to 128K, and use 32-bit values to track related sizes. This allows functions that require an OMF segment byte count of up to 128K to be compiled, although the length in memory at run time is still limited to 64K. (The OMF segment byte count is usually larger, due to the size of relocation records, etc.) This is useful for compiling large functions, e.g. the main interpreter loop in git. It also fixes the bug shown in the compca23 test case, where functions that require a segment of over 64K may appear to compile correctly but generate corrupted OMF segment headers. This related to tracking sizes with 16-bit values that could roll over. This patch increases the memory needed at run time by 64K. This shouldn’t generally be a problem on systems with sufficient memory, although it does increase the minimum memory requirement a bit. If behavior in low-memory configurations is a concern, buffSize could be made into a run-time option.
2016-11-28 01:11:12 +00:00
if pc > $0000FFFF then
if currentSegment <> '~ARRAYS ' then
Error(112);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Don’t erroneously optimize out lda instructions in certain cases involving instructions the native-code optimizer didn’t know about. This could cause problems when asm blocks contained instructions that the ORCA/C native code optimizer didn’t know about, as in the example below. It might also be possible to trigger this bug without asm blocks (particularly with the large memory model), but I haven’t run into a case that does. The new approach conservatively assumes that unknown instructions block the optimization. This should be equivalent to the old code with respect to the instructions defined in CGI.pas, except that m_bit_imm should have been treated as blocking the optimization but was not. There are still some other potential problem cases with applying this lda-elimination optimization to arbitrary assembly code, but fixing them might interfere with the optimization in useful cases, so I’m leaving those alone for now. Here is an example of a program with an asm block affected by this problem: #pragma optimize 74 int x,y; /* should print 2 when invoked with argc==1 */ int main(int argc, char **argv) { x = argc; y = argc + 6; asm { lda #1 pha eor >x bne done inc argc done: pla } printf("%i\n", argc); }
2016-11-22 07:27:38 +00:00
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,
Don't block the LDA elimination optimization if a native code label is encountered. This was an inadvertent change in commit 9d2bb600. This patch restores the old behavior with respect to d_lab.
2016-12-14 00:30:09 +00:00
m_tyx,d_lab]) then
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
goto 1;
end; {for}
1:
end; {ASafe}
function SignExtension (ns: integer): boolean;
Spellcheck comments throughout the code. There are no non-comment changes.
2020-01-29 23:09:52 +00:00
{ See if the pattern is a sign extension }
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{ }
{ 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}
Do a few more native code peephole optimizations. Patch from Kelvin Sherlock.
2017-09-10 01:17:42 +00:00
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}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Disable a native-code optimization that was generating bad code for %. Specifically, it converted PLX followed by PHA to STA 1,S. This is invalid if the x value is actually used, which is a case that can come up in the code now generated for the % operator. It might be possible to re-enable this optimization with tighter checks about where it's applied, but I don't think it's terribly important. The below program demonstrates an example that was being miscompiled: #pragma optimize -1 #include <stdio.h> int main(void) { int a = 100, b = 200, c = 3, d = 4; printf("%i\n", (a+b) % (c+d)); /* should be 6 */ }
2018-09-11 00:29:16 +00:00
{disabled - can generate bad code if the x value is used}
{m_plx:
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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
Don't do an optimization that would move a store to a DP location above an indirect load using that DP location. This generated invalid code in instances like the following. The code generated for "s = s->u.next" would update the most significant word of s first, then use an indirect load with the half-updated pointer value to update the least significant word of s. This would generally corrupt the result if the new and old pointers had different bank bytes. #pragma optimize 79 #include <stdio.h> struct S { int i; union { struct S * next; } u; } s1 = {0, 0}; int main (void) { struct S * s = &s1; s = s->u.next; if (s != 0) puts("compiler bug detected\n"); /* May not always be triggered, depending on memory contents. */ }
2016-10-19 23:49:37 +00:00
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}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Do a few more native code peephole optimizations. Patch from Kelvin Sherlock.
2017-09-10 01:17:42 +00:00
{ kws }
{ stz $xx, stz $xx }
Don't invalidly eliminate certain stores of 0 to global/static variables. This could happen in native-code peephole optimization if two stz instructions targeting different global/static locations occurred consecutively. This was a regression introduced by commit a3170ea7. The following program demonstrates the problem: #pragma optimize 1+2+8+64 int i,j=1; int main (void) { i = 0; j = 0; return j; /* should return 0 */ }
2017-12-14 02:03:48 +00:00
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
Don't optimize out certain volatile stores. This could occur due to the new native-code peephole optimizations for stz instructions, which can collapse consecutive identical ones down to one instruction. This is OK most of the time, but not when dealing with volatile variables, so disable it in that case. The following test case shows the issue (look at the generated code): #pragma optimize -1 volatile int a; int main(void) { a = 0; a = 0; }
2018-01-08 03:50:32 +00:00
if not volatile then
Remove(ns+1);
Don't invalidly eliminate certain stores of 0 to global/static variables. This could happen in native-code peephole optimization if two stz instructions targeting different global/static locations occurred consecutively. This was a regression introduced by commit a3170ea7. The following program demonstrates the problem: #pragma optimize 1+2+8+64 int i,j=1; int main (void) { i = 0; j = 0; return j; /* should return 0 */ }
2017-12-14 02:03:48 +00:00
m_stz_dir, m_stz_dirX:
if npeep[ns].opcode = npeep[ns+1].opcode then
if npeep[ns].operand = npeep[ns+1].operand then
Don't optimize out certain volatile stores. This could occur due to the new native-code peephole optimizations for stz instructions, which can collapse consecutive identical ones down to one instruction. This is OK most of the time, but not when dealing with volatile variables, so disable it in that case. The following test case shows the issue (look at the generated code): #pragma optimize -1 volatile int a; int main(void) { a = 0; a = 0; }
2018-01-08 03:50:32 +00:00
if not volatile then
Remove(ns+1);
Do a few more native code peephole optimizations. Patch from Kelvin Sherlock.
2017-09-10 01:17:42 +00:00
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
otherwise: ;
end; {case}
1:
end; {Optimize}
begin {GenNative}
{ writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1,
' operand=', p_operand:1); {debug}
When using varargs stack repair, only disable native-code peephole opt in functions containing varargs calls. There is no need to reduce the optimization in other functions, which will not contain any varargs stack repair code.
2018-01-14 03:37:28 +00:00
if npeephole and not (strictVararg and hasVarargsCall) then begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Make % operator give proper remainders even if one or both operands are negative. Per the C standards, the % operator should give a remainder after division, such that (a/b)*b + a%b equals a (provided that a/b is representable). As such, the operation of % is defined for cases where either or both of the operands are negative. Since division truncates toward 0, a%b should give a negative result (or 0) in cases where a is negative. Previously, the % operator was essentially behaving like the "mod" operator in Pascal, which is equivalent for positive operands but not if either operand is negative. It would generally give incorrect results in those cases, or in some cases give compile-time or run-time errors. This patch addresses both 16-bit and 32-bit signed computations at run time, and operations in constant expressions. The approach at run time is to call existing division routines, which return the correct remainder, except always as a positive number. The generated code checks the sign of the first operand, and if it is negative negates the remainder. The code generated is somewhat large (especially for the 32-bit case), so it might be sensible to put it in a library function and call that, but for now it's just generated in-line. This avoids introducing a dependency on a new library function, so the generated code remains compatible with older versions of ORCALib (e.g. the GNO one). Fixes #10.
2018-09-10 22:26:20 +00:00
78: sp := @'~DIV4'; {CC}
Implement 64-bit multiplication support. Signed multiplication uses the existing ~MUL8 routine in SysLib. Unsigned multiplication will use a new ~UMUL8 library routine.
2021-02-05 04:23:59 +00:00
79: sp := @'~MUL8';
80: sp := @'~UMUL8';
Implement 64-bit division and remainder, signed and unsigned. These operations rely on new library routines in ORCALib (~CDIV8 and ~UDIV8).
2021-02-05 18:42:48 +00:00
81: sp := @'~CDIV8';
82: sp := @'~UDIV8';
Generate code for long long to real conversions.
2021-02-11 18:41:58 +00:00
83: sp := @'~CNVLONGLONGREAL';
84: sp := @'~CNVULONGLONGREAL';
Implement 64-bit shifts.
2021-02-12 21:06:15 +00:00
85: sp := @'~SHL8';
86: sp := @'~ASHR8';
87: sp := @'~LSHR8';
Implement comparisons for signed long long. These use a library function to perform the comparison.
2021-02-16 00:10:10 +00:00
88: sp := @'~SCMP8';
Add support for real to long long conversions.
2021-02-17 00:47:28 +00:00
89: sp := @'~CNVREALLONGLONG';
90: sp := @'~CNVREALULONGLONG';
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Spellcheck comments throughout the code. There are no non-comment changes.
2020-01-29 23:09:52 +00:00
lab: stringPtr; {for holding names var pointers}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Don’t add the length of the last segment generated in the previous execution to that of the segment in the root file. This would occur if ORCA/C remained in memory and was restarted after a previous execution, because the 'pc' value was not reinitialized. The ORCA linker seems to ignore the too-long segment length value, but ORCA/C should generate a correct value that actually corresponds to the length of the segment.
2016-11-26 05:38:32 +00:00
InitNative;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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'}
Reference in New Issue Copy Permalink