paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-02 23:33:41 +02:00
Code Issues Packages Projects Releases Wiki Activity
295d53cb69
fpc/compiler/cgi386.pas
florian b74af9c243 * some fixes to get -Or work: 
- inc/dec didn't take care of CREGISTER
    - register calculcation of inc/dec was wrong
    - var/const parameters get now assigned 32 bit register, but
      const parameters only if they are passed by reference !
1998-09-05 23:03:57 +00:00

753 lines
26 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
This unit generates i386 (or better) assembler from the parse tree
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.
****************************************************************************
}
{$ifdef TP}
{$E+,F+,N+,D+,L+,Y+}
{$endif}
unit cgi386;
interface
uses
tree;
{ produces assembler for the expression in variable p }
{ and produces an assembler node at the end }
procedure generatecode(var p : ptree);
{ produces the actual code }
function do_secondpass(var p : ptree) : boolean;
procedure secondpass(var p : ptree);
{$ifdef test_dest_loc}
const
{ used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var
dest_loc : tlocation;
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{$endif test_dest_loc}
implementation
uses
cobjects,verbose,comphook,systems,globals,files,
symtable,types,aasm,scanner,
pass_1,hcodegen,temp_gen
{$ifdef GDB}
,gdb
{$endif}
{$ifdef i386}
,i386,tgeni386,cgai386
,cg386con,cg386mat,cg386cnv,cg386set,cg386add
,cg386mem,cg386cal,cg386ld,cg386flw,cg386inl
{$endif}
;
{$ifdef test_dest_loc}
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
begin
if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
begin
emit_reg_reg(A_MOV,s,reg,dest_loc.register);
p^.location:=dest_loc;
in_dest_loc:=true;
end
else
if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,s,reg,newreference(dest_loc.reference))));
p^.location:=dest_loc;
in_dest_loc:=true;
end
else
internalerror(20080);
end;
{$endif test_dest_loc}
procedure message(const t : tmsgconst);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
verbose.Message(t);
codegenerror:=olderrorcount<>status.errorcount;
end;
end;
procedure message1(const t : tmsgconst;const s : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
verbose.Message1(t,s);
codegenerror:=olderrorcount<>status.errorcount;
end;
end;
procedure message2(const t : tmsgconst;const s1,s2 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
verbose.Message2(t,s1,s2);
codegenerror:=olderrorcount<>status.errorcount;
end;
end;
procedure message3(const t : tmsgconst;const s1,s2,s3 : string);
var
olderrorcount : longint;
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
verbose.Message3(t,s1,s2,s3);
codegenerror:=olderrorcount<>status.errorcount;
end;
end;
{*****************************************************************************
SecondPass
*****************************************************************************}
type
secondpassproc = procedure(var p : ptree);
procedure secondnothing(var p : ptree);
begin
end;
procedure seconderror(var p : ptree);
begin
p^.error:=true;
codegenerror:=true;
end;
procedure secondstatement(var p : ptree);
var
hp : ptree;
begin
hp:=p;
while assigned(hp) do
begin
if assigned(hp^.right) then
begin
cleartempgen;
secondpass(hp^.right);
end;
hp:=hp^.left;
end;
end;
procedure secondblockn(var p : ptree);
begin
{ do second pass on left node }
if assigned(p^.left) then
secondpass(p^.left);
end;
procedure secondasm(var p : ptree);
begin
exprasmlist^.concatlist(p^.p_asm);
if not p^.object_preserved then
maybe_loadesi;
end;
procedure secondpass(var p : ptree);
const
procedures : array[ttreetyp] of secondpassproc =
(secondadd,secondadd,secondadd,secondmoddiv,secondadd,
secondmoddiv,secondassignment,secondload,secondnothing,
secondadd,secondadd,secondadd,secondadd,
secondadd,secondadd,secondin,secondadd,
secondadd,secondshlshr,secondshlshr,secondadd,
secondadd,secondsubscriptn,secondderef,secondaddr,
seconddoubleaddr,
secondordconst,secondtypeconv,secondcalln,secondnothing,
secondrealconst,secondfixconst,secondumminus,
secondasm,secondvecn,
secondstringconst,secondfuncret,secondselfn,
secondnot,secondinline,secondniln,seconderror,
secondnothing,secondhnewn,secondhdisposen,secondnewn,
secondsimplenewdispose,secondsetelement,secondsetcons,secondblockn,
secondstatement,secondnothing,secondifn,secondbreakn,
secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
secondexitn,secondwith,secondcase,secondlabel,
secondgoto,secondsimplenewdispose,secondtryexcept,
secondraise,
secondnothing,secondtryfinally,secondon,secondis,
secondas,seconderror,
secondfail,secondadd,secondprocinline,
secondnothing,secondloadvmt);
var
oldcodegenerror : boolean;
oldlocalswitches : tlocalswitches;
oldpos : tfileposinfo;
begin
oldcodegenerror:=codegenerror;
oldlocalswitches:=aktlocalswitches;
oldpos:=aktfilepos;
aktfilepos:=p^.fileinfo;
aktlocalswitches:=p^.localswitches;
if not(p^.error) then
begin
codegenerror:=false;
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else
codegenerror:=true;
aktlocalswitches:=oldlocalswitches;
aktfilepos:=oldpos;
end;
function do_secondpass(var p : ptree) : boolean;
begin
codegenerror:=false;
if not(p^.error) then
secondpass(p);
do_secondpass:=codegenerror;
end;
var
regvars : array[1..maxvarregs] of pvarsym;
regvars_para : array[1..maxvarregs] of boolean;
regvars_refs : array[1..maxvarregs] of longint;
parasym : boolean;
procedure searchregvars(p : psym);
var
i,j,k : longint;
begin
if (p^.typ=varsym) and ((pvarsym(p)^.var_options and vo_regable)<>0) then
begin
{ walk through all momentary register variables }
for i:=1 to maxvarregs do
begin
{ free register ? }
if regvars[i]=nil then
begin
regvars[i]:=pvarsym(p);
regvars_para[i]:=parasym;
break;
end;
{ else throw out a variable ? }
j:=pvarsym(p)^.refs;
{ parameter get a less value }
if parasym then
begin
if cs_littlesize in aktglobalswitches then
dec(j,1)
else
dec(j,100);
end;
if (j>regvars_refs[i]) and (j>0) then
begin
for k:=maxvarregs-1 downto i do
begin
regvars[k+1]:=regvars[k];
regvars_para[k+1]:=regvars_para[k];
end;
{ calc the new refs
pvarsym(p)^.refs:=j; }
regvars[i]:=pvarsym(p);
regvars_para[i]:=parasym;
regvars_refs[i]:=j;
break;
end;
end;
end;
end;
procedure generatecode(var p : ptree);
var
i : longint;
regsize : topsize;
regi : tregister;
hr : preference;
label
nextreg;
begin
cleartempgen;
{ when size optimization only count occurrence }
if cs_littlesize in aktglobalswitches then
t_times:=1
else
{ reference for repetition is 100 }
t_times:=100;
{ clear register count }
{$ifdef SUPPORT_MMX}
for regi:=R_EAX to R_MM6 do
begin
reg_pushes[regi]:=0;
is_reg_var[regi]:=false;
end;
{$else SUPPORT_MMX}
for regi:=R_EAX to R_EDI do
begin
reg_pushes[regi]:=0;
is_reg_var[regi]:=false;
end;
{$endif SUPPORT_MMX}
use_esp_stackframe:=false;
if not(do_firstpass(p)) then
begin
{ max. optimizations }
{ only if no asm is used }
{ and no try statement }
if (cs_regalloc in aktglobalswitches) and
((procinfo.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
begin
{ can we omit the stack frame ? }
{ conditions:
1. procedure (not main block)
2. no constructor or destructor
3. no call to other procedures
4. no interrupt handler
}
if assigned(aktprocsym) then
begin
if (aktprocsym^.definition^.options and
(poconstructor+podestructor{+poinline}+pointerrupt)=0) and
((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then
begin
{ use ESP as frame pointer }
procinfo.framepointer:=R_ESP;
use_esp_stackframe:=true;
{ calc parameter distance new }
dec(procinfo.framepointer_offset,4);
dec(procinfo.ESI_offset,4);
{ is this correct ???}
{ retoffset can be negativ for results in eax !! }
{ the value should be decreased only if positive }
if procinfo.retoffset>=0 then
dec(procinfo.retoffset,4);
dec(procinfo.call_offset,4);
aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset;
end;
end;
if (p^.registers32<4) then
begin
for i:=1 to maxvarregs do
regvars[i]:=nil;
parasym:=false;
{$ifdef tp}
symtablestack^.foreach(searchregvars);
{$else}
symtablestack^.foreach(@searchregvars);
{$endif}
{ copy parameter into a register ? }
parasym:=true;
{$ifdef tp}
symtablestack^.next^.foreach(searchregvars);
{$else}
symtablestack^.next^.foreach(@searchregvars);
{$endif}
{ hold needed registers free }
for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
regvars[i]:=nil;
{ now assign register }
for i:=1 to maxvarregs-p^.registers32 do
begin
if assigned(regvars[i]) then
begin
{ it is nonsens, to copy the variable to }
{ a register because we need then much }
{ pushes ? }
if reg_pushes[varregs[i]]>=regvars[i]^.refs then
begin
regvars[i]:=nil;
goto nextreg;
end;
{ register is no longer available for }
{ expressions }
{ search the register which is the most }
{ unused }
usableregs:=usableregs-[varregs[i]];
is_reg_var[varregs[i]]:=true;
dec(c_usableregs);
{ possibly no 32 bit register are needed }
{ call by reference/const ? }
if (regvars[i]^.varspez=vs_var) or
((regvars[i]^.varspez=vs_const) and
dont_copy_const_param(regvars[i]^.definition)
) then
begin
regvars[i]^.reg:=varregs[i];
regsize:=S_L;
end
else if (regvars[i]^.definition^.deftype=orddef) and
(porddef(regvars[i]^.definition)^.typ in [bool8bit,uchar,u8bit,s8bit]) then
begin
regvars[i]^.reg:=reg32toreg8(varregs[i]);
regsize:=S_B;
end
else if (regvars[i]^.definition^.deftype=orddef) and
(porddef(regvars[i]^.definition)^.typ in [bool16bit,u16bit,s16bit]) then
begin
regvars[i]^.reg:=reg32toreg16(varregs[i]);
regsize:=S_W;
end
else
begin
regvars[i]^.reg:=varregs[i];
regsize:=S_L;
end;
{ parameter must be load }
if regvars_para[i] then
begin
{ procinfo is there actual, }
{ because we can't never be in a }
{ nested procedure }
{ when loading parameter to reg }
new(hr);
reset_reference(hr^);
hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset;
hr^.base:=procinfo.framepointer;
procinfo.aktentrycode^.concat(new(pai386,op_ref_reg(A_MOV,regsize,
hr,regvars[i]^.reg)));
unused:=unused - [regvars[i]^.reg];
end;
{ procedure uses this register }
usedinproc:=usedinproc or ($80 shr byte(varregs[i]));
end;
nextreg:
{ dummy }
regsize:=S_W;
end;
if (status.verbosity and v_debug)=v_debug then
begin
for i:=1 to maxvarregs do
begin
if assigned(regvars[i]) then
Message3(cg_d_register_weight,reg2str(regvars[i]^.reg),
tostr(regvars[i]^.refs),regvars[i]^.name);
end;
end;
end;
end;
if assigned(aktprocsym) and
((aktprocsym^.definition^.options and poinline)<>0) then
make_const_global:=true;
do_secondpass(p);
{$ifdef StoreFPULevel}
procinfo.def^.fpu_used:=p^.registersfpu;
{$endif StoreFPULevel}
{ all registers can be used again }
usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
{$ifdef SUPPORT_MMX}
usableregs:=usableregs+[R_MM0..R_MM6];
{$endif SUPPORT_MMX}
c_usableregs:=4;
end;
procinfo.aktproccode^.concatlist(exprasmlist);
make_const_global:=false;
end;
end.
{
$Log$
Revision 1.52 1998-09-05 23:03:58 florian
* some fixes to get -Or work:
- inc/dec didn't take care of CREGISTER
- register calculcation of inc/dec was wrong
- var/const parameters get now assigned 32 bit register, but
const parameters only if they are passed by reference !
Revision 1.51 1998/08/31 12:22:14 peter
* secondinline moved to cg386inl
Revision 1.50 1998/08/28 10:54:20 peter
* fixed smallset generation from elements, it has never worked before!
Revision 1.49 1998/08/19 16:07:42 jonas
* changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
Revision 1.48 1998/08/14 18:18:43 peter
+ dynamic set contruction
* smallsets are now working (always longint size)
Revision 1.47 1998/08/10 14:49:53 peter
+ localswitches, moduleswitches, globalswitches splitting
Revision 1.46 1998/08/10 10:18:23 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.45 1998/07/30 13:30:34 florian
* final implemenation of exception support, maybe it needs
some fixes :)
Revision 1.44 1998/07/30 11:18:15 florian
+ first implementation of try ... except on .. do end;
* limitiation of 65535 bytes parameters for cdecl removed
Revision 1.43 1998/07/28 21:52:50 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.42 1998/07/15 16:06:44 jonas
* fixed bug that caused the stackframe never to be omitted
Revision 1.41 1998/07/14 14:46:44 peter
* released NEWINPUT
Revision 1.40 1998/07/07 11:19:52 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.39 1998/06/12 10:32:23 pierre
* column problem hopefully solved
+ C vars declaration changed
Revision 1.38 1998/06/09 16:01:37 pierre
+ added procedure directive parsing for procvars
(accepted are popstack cdecl and pascal)
+ added C vars with the following syntax
var C calias 'true_c_name';(can be followed by external)
reason is that you must add the Cprefix
which is target dependent
Revision 1.37 1998/06/08 13:13:41 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.36 1998/06/05 17:49:54 peter
* cleanup of cgai386
Revision 1.35 1998/06/05 16:13:32 pierre
* fix for real and string consts inside inlined procs
Revision 1.34 1998/06/05 14:37:27 pierre
* fixes for inline for operators
* inline procedure more correctly restricted
Revision 1.33 1998/06/04 23:51:37 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32
Revision 1.32 1998/06/04 09:55:35 pierre
* demangled name of procsym reworked to become independant of the mangling scheme
Revision 1.31 1998/06/03 22:48:52 peter
+ wordbool,longbool
* rename bis,von -> high,low
* moved some systemunit loading/creating to psystem.pas
Revision 1.30 1998/06/02 17:03:00 pierre
* with node corrected for objects
* small bugs for SUPPORT_MMX fixed
Revision 1.29 1998/06/01 16:50:18 peter
+ boolean -> ord conversion
* fixed ord -> boolean conversion
Revision 1.28 1998/05/28 17:26:47 peter
* fixed -R switch, it didn't work after my previous akt/init patch
* fixed bugs 110,130,136
Revision 1.27 1998/05/25 17:11:38 pierre
* firstpasscount bug fixed
now all is already set correctly the first time
under EXTDEBUG try -gp to skip all other firstpasses
it works !!
* small bug fixes
- for smallsets with -dTESTSMALLSET
- some warnings removed (by correcting code !)
Revision 1.26 1998/05/23 01:21:03 peter
+ aktasmmode, aktoptprocessor, aktoutputformat
+ smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+ $LIBNAME to set the library name where the unit will be put in
* splitted cgi386 a bit (codeseg to large for bp7)
* nasm, tasm works again. nasm moved to ag386nsm.pas
Revision 1.25 1998/05/21 19:33:31 peter
+ better procedure directive handling and only one table
Revision 1.24 1998/05/20 09:42:33 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.23 1998/05/12 10:46:58 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default
* fixed some messages
* first time parameter scan is only for -v and -T
- removed old style messages
Revision 1.22 1998/05/07 00:17:00 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.21 1998/05/06 08:38:36 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.20 1998/05/01 16:38:44 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp
* break and continue are now symbols of the system unit
+ widestring, longstring and ansistring type released
Revision 1.19 1998/04/30 15:59:39 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position
* fixed one remaining bug in scanner for line counts
* several little fixes
Revision 1.18 1998/04/29 10:33:48 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.17 1998/04/27 23:10:27 peter
+ new scanner
* $makelib -> if smartlink
* small filename fixes pmodule.setfilename
* moved import from files.pas -> import.pas
Revision 1.16 1998/04/23 21:52:08 florian
* fixes of Jonas applied
Revision 1.15 1998/04/22 21:06:49 florian
* last fixes before the release:
- veryyyy slow firstcall fixed
Revision 1.14 1998/04/21 10:16:47 peter
* patches from strasbourg
* objects is not used anymore in the fpc compiled version
Revision 1.13 1998/04/14 23:27:02 florian
+ exclude/include with constant second parameter added
Revision 1.12 1998/04/13 21:15:41 florian
* error handling of pass_1 and cgi386 fixed
* the following bugs fixed: 0117, 0118, 0119 and 0129, 0122 was already
fixed, verified
Revision 1.11 1998/04/13 08:42:51 florian
* call by reference and call by value open arrays fixed
Revision 1.10 1998/04/12 22:39:43 florian
* problem with read access to properties solved
* correct handling of hidding methods via virtual (COM)
* correct result type of constructor calls (COM), the resulttype
depends now on the type of the class reference
Revision 1.9 1998/04/10 21:36:55 florian
+ some stuff to support method pointers (procedure of object) added
(declaration, parameter handling)
Revision 1.8 1998/04/09 22:16:33 florian
* problem with previous REGALLOC solved
* improved property support
Revision 1.7 1998/04/09 14:28:05 jonas
+ basic k6 and 6x86 optimizing support (-O7 and -O8)
Revision 1.6 1998/04/08 11:34:20 peter
* nasm works (linux only tested)
Revision 1.5 1998/04/07 22:45:04 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.4 1998/04/07 13:19:42 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation
support for rhgdb.exe (lowercase file names)
}
Reference in New Issue View Git Blame Copy Permalink