paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-02 07:13:57 +02:00
Code Issues Packages Projects Releases Wiki Activity
95ea5d87dd
fpc/compiler/m68k/n68kadd.pas
Jonas Maebe 8349cde7db * changed byte/word/longbool to be Delphi-compatible (+ similar changes 
for qwordbool) + test:
    o assigning true to such a variable now sets them to $ff/$ffff/$ffffffff
    o these types are now all signed
    o converting an integer type to a byte/word/long/qwordbool using an
      explicit type cast keeps the integer's original value stored in the
      bool, instead of forcing it to ord(true)/ord(false)
    (mantis #10233 and #10613, implemented for all architectures, testsuite
     tested for ppc32, sparc and x86)
  * fixed some places where the rtl depended on longbool(true) having the
    value 1
  * extended several boolean tests (and adapted some to no longer assume
    that byte/word/long/qwordbool(true)=1)
  + support for converting to qwordbool in second_int_to_bool for x86, ppc
    and sparc

git-svn-id: trunk@9898 -
2008-01-24 21:30:55 +00:00

547 lines
20 KiB
ObjectPascal
Raw Blame History

{
Copyright (c) 2000-2002 by Florian Klaempfl and Jonas Maebe
Code generation for add nodes on the Motorola 680x0 family
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit n68kadd;
{$i fpcdefs.inc}
interface
uses
node,nadd,ncgadd,cpubase;
type
t68kaddnode = class(tcgaddnode)
private
function getresflags(unsigned: boolean) : tresflags;
protected
procedure second_addfloat;override;
procedure second_cmpfloat;override;
procedure second_cmpordinal;override;
procedure second_cmpsmallset;override;
procedure second_cmp64bit;override;
procedure second_cmpboolean;override;
end;
implementation
uses
globtype,systems,
cutils,verbose,globals,
symconst,symdef,paramgr,
aasmbase,aasmtai,aasmdata,aasmcpu,defutil,htypechk,
cgbase,cpuinfo,pass_1,pass_2,regvars,
cpupara,cgutils,procinfo,
ncon,nset,
ncgutil,tgobj,rgobj,rgcpu,cgobj,cg64f32;
{*****************************************************************************
Helpers
*****************************************************************************}
function t68kaddnode.getresflags(unsigned : boolean) : tresflags;
begin
case nodetype of
equaln : getresflags:=F_E;
unequaln : getresflags:=F_NE;
else
if not(unsigned) then
begin
if nf_swapped in flags then
case nodetype of
ltn : getresflags:=F_G;
lten : getresflags:=F_GE;
gtn : getresflags:=F_L;
gten : getresflags:=F_LE;
end
else
case nodetype of
ltn : getresflags:=F_L;
lten : getresflags:=F_LE;
gtn : getresflags:=F_G;
gten : getresflags:=F_GE;
end;
end
else
begin
if nf_swapped in flags then
case nodetype of
ltn : getresflags:=F_A;
lten : getresflags:=F_AE;
gtn : getresflags:=F_B;
gten : getresflags:=F_BE;
end
else
case nodetype of
ltn : getresflags:=F_B;
lten : getresflags:=F_BE;
gtn : getresflags:=F_A;
gten : getresflags:=F_AE;
end;
end;
end;
end;
{*****************************************************************************
AddFloat
*****************************************************************************}
procedure t68kaddnode.second_addfloat;
var
op : TAsmOp;
cmpop : boolean;
begin
pass_left_right;
cmpop:=false;
case nodetype of
addn :
op:=A_FADD;
muln :
op:=A_FMUL;
subn :
op:=A_FSUB;
slashn :
op:=A_FDIV;
ltn,lten,gtn,gten,
equaln,unequaln :
begin
// op:=A_FCMPO;
cmpop:=true;
end;
else
internalerror(200403182);
end;
// get the operands in the correct order, there are no special cases
// here, everything is register-based
if nf_swapped in flags then
swapleftright;
// put both operands in a register
location_force_fpureg(current_asmdata.CurrAsmList,right.location,true);
location_force_fpureg(current_asmdata.CurrAsmList,left.location,true);
// initialize de result
if not cmpop then
begin
location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
if left.location.loc = LOC_FPUREGISTER then
location.register := left.location.register
else if right.location.loc = LOC_FPUREGISTER then
location.register := right.location.register
else
location.register := cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
end
else
begin
location_reset(location,LOC_FLAGS,OS_NO);
// FIX ME!
// location.resflags := getresflags;
end;
// emit the actual operation
if not cmpop then
begin
{
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(op,
location.register,left.location.register,
right.location.register))
}
end
else
begin
{ current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(op,
newreg(R_SPECIALREGISTER,location.resflags.cr,R_SUBNONE),left.location.register,right.location.register))}
end;
end;
procedure t68kaddnode.second_cmpfloat;
begin
pass_left_right;
{
if (nf_swapped in flags) then
swapleftright;
}
{ force fpureg as location, left right doesn't matter
as both will be in a fpureg }
location_force_fpureg(current_asmdata.CurrAsmList,left.location,true);
location_force_fpureg(current_asmdata.CurrAsmList,right.location,true);
location_reset(location,LOC_FLAGS,OS_NO);
location.resflags:=getresflags(true);
{
if nodetype in [equaln,unequaln] then
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_CMF,
left.location.register,right.location.register),
cgsize2fpuoppostfix[def_cgsize(resultdef)]))
else
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_CMFE,
left.location.register,right.location.register),
cgsize2fpuoppostfix[def_cgsize(resultdef)]));
location_reset(location,LOC_FLAGS,OS_NO);
location.resflags:=getresflags(false);
}
end;
{*****************************************************************************
Smallsets
*****************************************************************************}
procedure t68kaddnode.second_cmpsmallset;
var
tmpreg : tregister;
begin
location_reset(location,LOC_FLAGS,OS_NO);
case nodetype of
equaln,
unequaln :
begin
{emit_compare(true);}
end;
lten,gten:
begin
If (not(nf_swapped in flags) and
(nodetype = lten)) or
((nf_swapped in flags) and
(nodetype = gten)) then
swapleftright;
// now we have to check whether left >= right
tmpreg := cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
if left.location.loc = LOC_CONSTANT then
begin
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_AND,OS_INT,
not(left.location.value),right.location.register,tmpreg);
current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_TST,S_L,tmpreg));
// the two instructions above should be folded together by
// the peepholeoptimizer
end
else
begin
if right.location.loc = LOC_CONSTANT then
begin
cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,
aword(right.location.value),tmpreg);
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_AND,S_L,
tmpreg,left.location.register));
end
else
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_AND,S_L,
right.location.register,left.location.register));
end;
// cg.ungetcpuregister(current_asmdata.CurrAsmList,tmpreg);
location.resflags := getresflags(true);
end;
else
internalerror(2002072701);
end;
end;
{*****************************************************************************
Ordinals
*****************************************************************************}
procedure t68kaddnode.second_cmpordinal;
var
unsigned : boolean;
useconst : boolean;
tmpreg : tregister;
op : tasmop;
begin
// writeln('second_cmpordinal');
pass_left_right;
{ set result location }
location_reset(location,LOC_JUMP,OS_NO);
{ load values into registers (except constants) }
force_reg_left_right(true, false);
{ determine if the comparison will be unsigned }
unsigned:=not(is_signed(left.resultdef)) or
not(is_signed(right.resultdef));
// get the constant on the right if there is one
if (left.location.loc = LOC_CONSTANT) then
swapleftright;
// can we use an immediate, or do we have to load the
// constant in a register first?
if (right.location.loc = LOC_CONSTANT) then
begin
{$ifdef extdebug}
if (right.location.size in [OS_64,OS_S64]) and (hi(right.location.value64)<>0) and ((hi(right.location.value64)<>-1) or unsigned) then
internalerror(2002080301);
{$endif extdebug}
if (nodetype in [equaln,unequaln]) then
if (unsigned and
(right.location.value > high(word))) or
(not unsigned and
(longint(right.location.value) < low(smallint)) or
(longint(right.location.value) > high(smallint))) then
{ we can then maybe use a constant in the 'othersigned' case
(the sign doesn't matter for // equal/unequal)}
unsigned := not unsigned;
if (unsigned and
((right.location.value) <= high(word))) or
(not(unsigned) and
(longint(right.location.value) >= low(smallint)) and
(longint(right.location.value) <= high(smallint))) then
useconst := true
else
begin
useconst := false;
tmpreg := cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,
aword(right.location.value),tmpreg);
end
end
else
useconst := false;
location.loc := LOC_FLAGS;
location.resflags := getresflags(unsigned);
op := A_CMP;
if (right.location.loc = LOC_CONSTANT) then
if useconst then
current_asmdata.CurrAsmList.concat(taicpu.op_reg_const(op,S_L,
left.location.register,longint(right.location.value)))
else
begin
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(op,S_L,
left.location.register,tmpreg));
// cg.ungetcpuregister(current_asmdata.CurrAsmList,tmpreg);
end
else
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(op,S_L,
left.location.register,right.location.register));
end;
{*****************************************************************************
Boolean
*****************************************************************************}
procedure t68kaddnode.second_cmpboolean;
var
cgop : TOpCg;
cgsize : TCgSize;
isjump : boolean;
otl,ofl : tasmlabel;
begin
// writeln('second_cmpboolean');
if (torddef(left.resultdef).ordtype in [pasbool,bool8bit]) or
(torddef(right.resultdef).ordtype in [pasbool,bool8bit]) then
cgsize:=OS_8
else
if (torddef(left.resultdef).ordtype=bool16bit) or
(torddef(right.resultdef).ordtype=bool16bit) then
cgsize:=OS_16
else
cgsize:=OS_32;
if (cs_full_boolean_eval in current_settings.localswitches) or
(nodetype in [unequaln,ltn,lten,gtn,gten,equaln,xorn]) then
begin
if left.nodetype in [ordconstn,realconstn] then
swapleftright;
isjump:=(left.location.loc=LOC_JUMP);
if isjump then
begin
otl:=current_procinfo.CurrTrueLabel;
current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
ofl:=current_procinfo.CurrFalseLabel;
current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
end;
secondpass(left);
if left.location.loc in [LOC_FLAGS,LOC_JUMP] then begin
// writeln('ajjaj');
location_force_reg(current_asmdata.CurrAsmList,left.location,cgsize,false);
// writeln('reccs?');
end;
if isjump then
begin
current_procinfo.CurrTrueLabel:=otl;
current_procinfo.CurrFalseLabel:=ofl;
end;
isjump:=(right.location.loc=LOC_JUMP);
if isjump then
begin
otl:=current_procinfo.CurrTrueLabel;
current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
ofl:=current_procinfo.CurrFalseLabel;
current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
end;
secondpass(right);
if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
location_force_reg(current_asmdata.CurrAsmList,right.location,cgsize,false);
if isjump then
begin
current_procinfo.CurrTrueLabel:=otl;
current_procinfo.CurrFalseLabel:=ofl;
end;
location_reset(location,LOC_FLAGS,OS_NO);
force_reg_left_right(true,false);
if (left.location.loc = LOC_CONSTANT) then
swapleftright;
if (right.location.loc <> LOC_CONSTANT) then
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,S_L,
left.location.register,right.location.register))
else
current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,
longint(right.location.value),left.location.register));
location.resflags := getresflags(true);
end;
//release_reg_left_right;
end;
{*****************************************************************************
64-bit
*****************************************************************************}
procedure t68kaddnode.second_cmp64bit;
begin
// writeln('second_cmp64bit');
pass_left_right;
// load_left_right(true,false);
(*
case nodetype of
ltn,lten,
gtn,gten:
begin
emit_cmp64_hi;
firstjmp64bitcmp;
emit_cmp64_lo;
secondjmp64bitcmp;
end;
equaln,unequaln:
begin
// instead of doing a complicated compare, do
// (left.hi xor right.hi) or (left.lo xor right.lo)
// (somewhate optimized so that no superfluous 'mr's are
// generated)
if (left.location.loc = LOC_CONSTANT) then
swapleftright;
if (right.location.loc = LOC_CONSTANT) then
begin
if left.location.loc = LOC_REGISTER then
begin
tempreg64.reglo := left.location.register64.reglo;
tempreg64.reghi := left.location.register64.reghi;
end
else
begin
if (aword(right.location.valueqword) <> 0) then
tempreg64.reglo := cg.getintregister(current_asmdata.CurrAsmList)
else
tempreg64.reglo := left.location.register64.reglo;
if ((right.location.valueqword shr 32) <> 0) then
tempreg64.reghi := cg.getintregister(current_asmdata.CurrAsmList)
else
tempreg64.reghi := left.location.register64.reghi;
end;
if (aword(right.location.valueqword) <> 0) then
{ negative values can be handled using SUB, }
{ positive values < 65535 using XOR. }
if (longint(right.location.valueqword) >= -32767) and
(longint(right.location.valueqword) < 0) then
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,OS_INT,
aword(right.location.valueqword),
left.location.register64.reglo,tempreg64.reglo)
else
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_INT,
aword(right.location.valueqword),
left.location.register64.reglo,tempreg64.reglo);
if ((right.location.valueqword shr 32) <> 0) then
if (longint(right.location.valueqword shr 32) >= -32767) and
(longint(right.location.valueqword shr 32) < 0) then
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,OS_INT,
aword(right.location.valueqword shr 32),
left.location.register64.reghi,tempreg64.reghi)
else
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_INT,
aword(right.location.valueqword shr 32),
left.location.register64.reghi,tempreg64.reghi);
end
else
begin
tempreg64.reglo := cg.getintregister(current_asmdata.CurrAsmList);
tempreg64.reghi := cg.getintregister(current_asmdata.CurrAsmList);
cg64.a_op64_reg_reg_reg(current_asmdata.CurrAsmList,OP_XOR,
left.location.register64,right.location.register64,
tempreg64);
end;
cg.a_reg_alloc(current_asmdata.CurrAsmList,R_0);
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_OR_,R_0,
tempreg64.reglo,tempreg64.reghi));
cg.a_reg_dealloc(current_asmdata.CurrAsmList,R_0);
if (tempreg64.reglo <> left.location.register64.reglo) then
cg.ungetregister(current_asmdata.CurrAsmList,tempreg64.reglo);
if (tempreg64.reghi <> left.location.register64.reghi) then
cg.ungetregister(current_asmdata.CurrAsmList,tempreg64.reghi);
location_reset(location,LOC_FLAGS,OS_NO);
location.resflags := getresflags;
end;
else
internalerror(2002072803);
end;
{ set result location }
{ (emit_compare sets it to LOC_FLAGS for compares, so set the }
{ real location only now) (JM) }
if cmpop and
not(nodetype in [equaln,unequaln]) then
location_reset(location,LOC_JUMP,OS_NO);
*)
location_reset(location,LOC_JUMP,OS_NO);
// writeln('second_cmp64_exit');
end;
begin
caddnode:=t68kaddnode;
end.
Reference in New Issue View Git Blame Copy Permalink