paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 04:11:35 +01:00
Code Issues Packages Projects Releases Wiki Activity
0ecb4adcc5
fpc/compiler/cg386mem.pas
florian 9af86a2bf0 + better support for switch $H 
+ index access to ansi strings added
 + assigment of data (records/arrays) containing ansi strings
1998-07-26 21:58:57 +00:00

634 lines
24 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Generate i386 assembler for in memory related nodes
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 cg386mem;
interface
uses
tree;
procedure secondloadvmt(var p : ptree);
procedure secondhnewn(var p : ptree);
procedure secondnewn(var p : ptree);
procedure secondhdisposen(var p : ptree);
procedure secondsimplenewdispose(var p : ptree);
procedure secondaddr(var p : ptree);
procedure seconddoubleaddr(var p : ptree);
procedure secondderef(var p : ptree);
procedure secondsubscriptn(var p : ptree);
procedure secondvecn(var p : ptree);
procedure secondselfn(var p : ptree);
procedure secondwith(var p : ptree);
implementation
uses
cobjects,verbose,globals,systems,
symtable,aasm,i386,types,
cgi386,cgai386,temp_gen,tgeni386,hcodegen;
{*****************************************************************************
SecondLoadVMT
*****************************************************************************}
procedure secondloadvmt(var p : ptree);
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,
S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
p^.location.register)));
end;
{*****************************************************************************
SecondHNewN
*****************************************************************************}
procedure secondhnewn(var p : ptree);
begin
end;
{*****************************************************************************
SecondNewN
*****************************************************************************}
procedure secondnewn(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
p^.location.register:=p^.left^.location.register;
end;
{*****************************************************************************
SecondDisposeN
*****************************************************************************}
procedure secondhdisposen(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.left^.location.register,
p^.location.reference.index)));
end;
LOC_MEM,LOC_REFERENCE :
begin
del_reference(p^.left^.location.reference);
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
p^.location.reference.index)));
end;
end;
end;
{*****************************************************************************
SecondNewDispose
*****************************************************************************}
procedure secondsimplenewdispose(var p : ptree);
var
pushed : tpushed;
begin
secondpass(p^.left);
if codegenerror then
exit;
pushusedregisters(pushed,$ff);
{ determines the size of the mem block }
push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
{ push pointer adress }
case p^.left^.location.loc of
LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
p^.left^.location.register)));
LOC_REFERENCE:
emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
end;
{ call the mem handling procedures }
case p^.treetype of
simpledisposen:
emitcall('FREEMEM',true);
simplenewn:
emitcall('GETMEM',true);
end;
popusedregisters(pushed);
{ may be load ESI }
maybe_loadesi;
end;
{*****************************************************************************
SecondAddr
*****************************************************************************}
procedure secondaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
{@ on a procvar means returning an address to the procedure that
is stored in it.}
{ yes but p^.left^.symtableentry can be nil
for example on @self !! }
{ symtableentry can be also invalid, if left is no tree node }
if (p^.left^.treetype=loadn) and
assigned(p^.left^.symtableentry) and
(p^.left^.symtableentry^.typ=varsym) and
(pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.register)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
{ for use of other segments }
if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
p^.location.segment:=p^.left^.location.reference.segment;
end;
{*****************************************************************************
SecondDoubleAddr
*****************************************************************************}
procedure seconddoubleaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
{*****************************************************************************
SecondDeRef
*****************************************************************************}
procedure secondderef(var p : ptree);
var
hr : tregister;
begin
secondpass(p^.left);
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER:
p^.location.reference.base:=p^.left^.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ...and reserve one for the pointer }
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOV,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end;
{*****************************************************************************
SecondSubScriptN
*****************************************************************************}
procedure secondsubscriptn(var p : ptree);
var
hr : tregister;
begin
secondpass(p^.left);
if codegenerror then
exit;
{ classes must be dereferenced implicit }
if (p^.left^.resulttype^.deftype=objectdef) and
pobjectdef(p^.left^.resulttype)^.isclass then
begin
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER:
p^.location.reference.base:=p^.left^.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ... and reserve one for the pointer }
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOV,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end
else
set_location(p^.location,p^.left^.location);
inc(p^.location.reference.offset,p^.vs^.address);
end;
{*****************************************************************************
SecondVecN
*****************************************************************************}
procedure secondvecn(var p : ptree);
var
pushed : boolean;
ind,hr : tregister;
_p : ptree;
function get_mul_size:longint;
begin
if p^.memindex then
get_mul_size:=1
else
get_mul_size:=p^.resulttype^.size;
end;
procedure calc_emit_mul;
var
l1,l2 : longint;
begin
l1:=get_mul_size;
case l1 of
1,2,4,8 : p^.location.reference.scalefactor:=l1;
else
begin
if ispowerof2(l1,l2) then
exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind)))
else
exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind)));
end;
end;
end;
var
extraoffset : longint;
t : ptree;
hp : preference;
tai : Pai386;
begin
secondpass(p^.left);
{ we load the array reference to p^.location }
{ an ansistring needs to be dereferenced }
if is_ansistring(p^.left^.resulttype) or
is_widestring(p^.left^.resulttype) then
begin
reset_reference(p^.location.reference);
p^.location.loc:=LOC_REFERENCE;
del_reference(p^.left^.location.reference);
p^.location.reference.base:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.reference.base)));
if is_ansistring(p^.left^.resulttype) then
begin
{ in ansistrings S[1] is pchar(S)[0] !! }
dec(p^.location.reference.offset);
{ this is necessary for ansistrings with constant index }
dec(p^.left^.location.reference.offset);
end
else
begin
{ in widestrings S[1] is pwchar(S)[0] !! }
dec(p^.location.reference.offset,2);
{ this is necessary for ansistrings with constant index }
dec(p^.left^.location.reference.offset,2);
exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,
2,p^.location.reference.base)));
end;
end
else
set_location(p^.location,p^.left^.location);
{ offset can only differ from 0 if arraydef }
if p^.left^.resulttype^.deftype=arraydef then
dec(p^.location.reference.offset,
get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
if p^.right^.treetype=ordconstn then
begin
{ offset can only differ from 0 if arraydef }
if (p^.left^.resulttype^.deftype=arraydef) then
begin
if not(is_open_array(p^.left^.resulttype)) then
begin
if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
(p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
Message(parser_e_range_check_error);
dec(p^.left^.location.reference.offset,
get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
end
else
begin
{ range checking for open arrays }
end;
end;
inc(p^.left^.location.reference.offset,
get_mul_size*p^.right^.value);
if p^.memseg then
p^.left^.location.reference.segment:=R_FS;
p^.left^.resulttype:=p^.resulttype;
disposetree(p^.right);
_p:=p^.left;
putnode(p);
p:=_p;
end
else
begin
{ quick hack, to overcome Delphi 2 }
if (cs_maxoptimieren in aktswitches) and
(p^.left^.resulttype^.deftype=arraydef) then
begin
extraoffset:=0;
if (p^.right^.treetype=addn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end
else if (p^.right^.treetype=subn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end;
inc(p^.location.reference.offset,
get_mul_size*extraoffset);
end;
{ calculate from left to right }
if (p^.location.loc<>LOC_REFERENCE) and
(p^.location.loc<>LOC_MEM) then
Message(cg_e_illegal_expression);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
case p^.right^.location.loc of
LOC_REGISTER:
begin
ind:=p^.right^.location.register;
case p^.right^.resulttype^.size of
1:
begin
hr:=reg8toreg32(ind);
emit_reg_reg(A_MOVZX,S_BL,ind,hr);
ind:=hr;
end;
2:
begin
hr:=reg16toreg32(ind);
emit_reg_reg(A_MOVZX,S_WL,ind,hr);
ind:=hr;
end;
end;
end;
LOC_CREGISTER:
begin
ind:=getregister32;
case p^.right^.resulttype^.size of
1:
emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
2:
emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
4:
emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
end;
end;
LOC_FLAGS:
begin
ind:=getregister32;
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,reg32toreg8(ind))));
emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
end
else
begin
del_reference(p^.right^.location.reference);
ind:=getregister32;
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case p^.right^.resulttype^.size of
1:
tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2:
tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4:
tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
end;
exprasmlist^.concat(tai);
end;
end;
{ produce possible range check code: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
hp:=new_reference(R_NO,0);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
end;
end;
if p^.location.reference.index=R_NO then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
stringdispose(p^.location.reference.symbol);
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
if p^.memseg then
p^.location.reference.segment:=R_FS;
end;
end;
{*****************************************************************************
SecondSelfN
*****************************************************************************}
procedure secondselfn(var p : ptree);
begin
clear_reference(p^.location.reference);
if (p^.resulttype^.deftype=classrefdef) or
((p^.resulttype^.deftype=objectdef)
and pobjectdef(p^.resulttype)^.isclass
) then
p^.location.register:=R_ESI
else
p^.location.reference.base:=R_ESI;
end;
{*****************************************************************************
SecondWithN
*****************************************************************************}
procedure secondwith(var p : ptree);
var
ref : treference;
symtable : psymtable;
i : longint;
begin
if assigned(p^.left) then
begin
secondpass(p^.left);
ref.symbol:=nil;
gettempofsizereference(4,ref);
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
del_reference(p^.left^.location.reference);
{ the offset relative to (%ebp) is only needed here! }
symtable:=p^.withsymtable;
for i:=1 to p^.tablecount do
begin
symtable^.datasize:=ref.offset;
symtable:=symtable^.next;
end;
{ p^.right can be optimize out !!! }
if p^.right<>nil then
secondpass(p^.right);
{ clear some stuff }
ungetiftemp(ref);
end;
end;
end.
{
$Log$
Revision 1.5 1998-07-26 21:58:58 florian
+ better support for switch $H
+ index access to ansi strings added
+ assigment of data (records/arrays) containing ansi strings
Revision 1.4 1998/07/24 22:16:55 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.3 1998/06/25 08:48:09 florian
* first version of rtti support
Revision 1.2 1998/06/08 13:13:35 pierre
+ temporary variables now in temp_gen.pas unit
because it is processor independent
* mppc68k.bat modified to undefine i386 and support_mmx
(which are defaults for i386)
Revision 1.1 1998/06/05 17:44:13 peter
* splitted cgi386
}
Reference in New Issue View Git Blame Copy Permalink