paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-02-04 06:34:52 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ added generic exception support (still does not work!)

Browse Source 
+ more documentation
This commit is contained in:
carl 2002-08-04 19:06:41 +00:00
parent 8ff3e3e1b3
commit 32f3f65a26
7 changed files with 896 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
compiler/cgbase.pas
View File

@ -92,6 +92,31 @@ unit cgbase;
{# true, if we can not use fast exit code }
no_fast_exit : boolean;
{# Holds the environment reference for default exceptions
The exception reference is created when ansistrings
or classes are used. It holds buffer for exception
frames. It is allocted by g_new_exception.
}
exception_env_ref : treference;
{# Holds the environment reference for default exceptions
The exception reference is created when ansistrings
or classes are used. It holds buffer for setjmp
It is allocted by g_new_exception.
}
exception_jmp_ref :treference;
{# Holds the environment reference for default exceptions
The exception reference is created when ansistrings
or classes are used. It holds the location where
temporary storage of the setjmp result is stored.
This reference can be nil, if the result is instead
saved on the stack.
}
exception_result_ref :treference;
aktproccode,aktentrycode,
aktexitcode,aktlocaldata : taasmoutput;
@ -172,6 +197,7 @@ implementation
uses
systems,
cresstr,
rgobj,
defbase
{$ifdef fixLeaksOnError}
,comphook
@ -310,6 +336,9 @@ implementation
aktexitcode:=Taasmoutput.Create;
aktproccode:=Taasmoutput.Create;
aktlocaldata:=Taasmoutput.Create;
reference_reset(exception_env_ref);
reference_reset(exception_jmp_ref);
reference_reset(exception_result_ref);
end;
@ -525,7 +554,11 @@ begin
end.
{
$Log$
Revision 1.19 2002-07-20 11:57:53 florian
Revision 1.20 2002-08-04 19:06:41 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.19 2002/07/20 11:57:53 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added

11
compiler/cginfo.pas
View File

@ -30,7 +30,10 @@ interface
uses cpuinfo,symconst;
type
{# Generic opcodes, which must be supporrted by all processors }
{# Generic opcodes, which must be supported by all processors
The order of this table should not be changed, since table
lookups are used in the different CPU code generators!
}
TOpCg =
(
OP_NONE,
@ -106,7 +109,11 @@ implementation
end.
{
$Log$
Revision 1.13 2002-07-07 09:52:32 florian
Revision 1.14 2002-08-04 19:06:41 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.13 2002/07/07 09:52:32 florian
* powerpc target fixed, very simple units can be compiled
* some basic stuff for better callparanode handling, far from being finished

118
compiler/cgobj.pas
View File

@ -1,5 +1,6 @@
{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
Member of the Free Pascal development team
@ -240,13 +241,54 @@ unit cgobj;
procedure g_flags2reg(list: taasmoutput; size: TCgSize; const f: tresflags; reg: TRegister); virtual; abstract;
procedure g_flags2ref(list: taasmoutput; size: TCgSize; const f: tresflags; const ref:TReference); virtual;
{ some processors like the PPC doesn't allow to change the stack in }
{ a procedure, so we need to maintain an extra stack for the }
{ result values of setjmp in exception code }
{ this two procedures are for pushing an exception value, }
{ they can use the scratch registers }
procedure g_push_exception(list : taasmoutput;const exceptbuf:treference;l:AWord; exceptlabel:TAsmLabel);virtual;abstract;
procedure g_pop_exception(list : taasmoutput;endexceptlabel:tasmlabel);virtual;abstract;
{#
Allocate the buffers for exception management and setjmp environment.
Return a pointer to these buffers, send them to the utility routine
so they are registered, and then call setjmp.
Then compare the result of setjmp with 0, and if not equal
to zero, then jump to exceptlabel.
Also store the result of setjmp to a temporary space by calling g_save_exception_reason
It is to note that this routine may be called *after* the stackframe of a
routine has been called, therefore on machines where the stack cannot
be modified, all temps should be allocated on the heap instead of the
stack.
}
procedure g_new_exception(list : taasmoutput;var jmpbuf,envbuf, href : treference;
a : aword; exceptlabel : tasmlabel);virtual;
procedure g_free_exception(list : taasmoutput;var jmpbuf, envbuf, href : treference;
a : aword ; endexceptlabel : tasmlabel; onlyfree : boolean);virtual;
{#
This routine is used in exception management nodes. It should
save the exception reason currently in the accumulator. The
save should be done either to a temp (pointed to by href).
or on the stack (pushing the value on the stack).
The size of the value to save is OS_S32.
}
procedure g_exception_reason_save(list : taasmoutput; const href : treference);virtual;
{#
This routine is used in exception management nodes. It should
save the exception reason constant. The
save should be done either to a temp (pointed to by href).
or on the stack (pushing the value on the stack).
The size of the value to save is OS_S32
}
procedure g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aword);virtual;
{#
This routine is used in exception management nodes. It should
load the exception reason to the accumulator. The saved value
should either be in the temp. area (pointed to by href , href should
*NOT* be freed) or on the stack (the value should be popped).
The size of the value to restore is OS_S32.
}
procedure g_exception_reason_load(list : taasmoutput; const href : treference);virtual;
procedure g_maybe_loadself(list : taasmoutput);virtual;
{# This should emit the opcode to copy len bytes from the source
@ -372,6 +414,8 @@ unit cgobj;
procedure a_param64_const(list : taasmoutput;value : qword;const loc : tparalocation);virtual;abstract;
procedure a_param64_ref(list : taasmoutput;const r : treference;const loc : tparalocation);virtual;abstract;
procedure a_param64_loc(list : taasmoutput;const l : tlocation;const loc : tparalocation);virtual;abstract;
{ override to catch 64bit rangechecks }
procedure g_rangecheck64(list: taasmoutput; const p: tnode;
@ -1378,6 +1422,58 @@ unit cgobj;
procedure tcg.g_profilecode(list : taasmoutput);
begin
end;
procedure tcg.g_exception_reason_save(list : taasmoutput; const href : treference);
begin
a_load_reg_ref(exprasmlist, OS_S32, accumulator, href);
end;
procedure tcg.g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aword);
begin
a_load_const_ref(list, OS_S32, a, href);
end;
procedure tcg.g_exception_reason_load(list : taasmoutput; const href : treference);
begin
a_load_ref_reg(list, OS_S32, href, accumulator);
end;
procedure tcg.g_new_exception(list : taasmoutput;var jmpbuf,envbuf, href : treference;
a : aword; exceptlabel : tasmlabel);
begin
tg.gettempofsizereferencepersistant(exprasmlist,24,jmpbuf);
tg.gettempofsizereferencepersistant(exprasmlist,12,envbuf);
a_paramaddr_ref(exprasmlist,envbuf,paramanager.getintparaloc(3));
a_paramaddr_ref(exprasmlist,jmpbuf,paramanager.getintparaloc(2));
{ push type of exceptionframe }
a_param_const(exprasmlist,OS_S32,1,paramanager.getintparaloc(1));
a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
a_param_reg(exprasmlist,OS_ADDR,accumulator,paramanager.getintparaloc(1));
a_call_name(exprasmlist,'FPC_SETJMP');
tg.gettempofsizereferencepersistant(exprasmlist,sizeof(aword),href);
g_exception_reason_save(list, href);
a_cmp_const_reg_label(exprasmlist,OS_S32,OC_NE,0,accumulator,exceptlabel);
end;
procedure tcg.g_free_exception(list : taasmoutput;var jmpbuf, envbuf, href : treference;
a : aword ; endexceptlabel : tasmlabel; onlyfree : boolean);
begin
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
tg.ungetpersistanttempreference(exprasmlist,jmpbuf);
tg.ungetpersistanttempreference(exprasmlist,envbuf);
if not onlyfree then
begin
g_exception_reason_load(list, href);
cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,a,accumulator,endexceptlabel);
end;
end;
procedure tcg64.a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;value : qword;regsrc,regdst : tregister64);
@ -1392,6 +1488,8 @@ unit cgobj;
a_load64_reg_reg(list,regsrc2,regdst);
a_op64_reg_reg(list,op,regsrc1,regdst);
end;
finalization
@ -1400,7 +1498,11 @@ finalization
end.
{
$Log$
Revision 1.41 2002-07-30 20:50:43 florian
Revision 1.42 2002-08-04 19:08:21 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.41 2002/07/30 20:50:43 florian
* the code generator knows now if parameters are in registers
Revision 1.40 2002/07/29 21:16:02 florian

590
compiler/ncgflw.pas
View File

@ -66,6 +66,24 @@ interface
tcgfailnode = class(tfailnode)
procedure pass_2;override;
end;
tcgraisenode = class(traisenode)
procedure pass_2;override;
end;
tcgtryexceptnode = class(ttryexceptnode)
procedure pass_2;override;
end;
tcgtryfinallynode = class(ttryfinallynode)
procedure pass_2;override;
end;
tcgonnode = class(tonnode)
procedure pass_2;override;
end;
implementation
@ -77,7 +95,7 @@ implementation
nld,ncon,
ncgutil,
cga,
tgobj,rgobj,
tgobj,rgobj,paramgr,
regvars,cgobj,cgcpu,cg64f32;
{*****************************************************************************
@ -612,6 +630,566 @@ do_jmp:
end;
{*****************************************************************************
SecondRaise
*****************************************************************************}
procedure tcgraisenode.pass_2;
var
a : tasmlabel;
href : treference;
href2: treference;
begin
if assigned(left) then
begin
{ multiple parameters? }
if assigned(right) then
begin
{ push frame }
if assigned(frametree) then
begin
secondpass(frametree);
if codegenerror then
exit;
cg.a_param_loc(exprasmlist,frametree.location,paramanager.getintparaloc(2));
end
else
cg.a_param_const(exprasmlist,OS_INT,0,paramanager.getintparaloc(2));
{ push address }
secondpass(right);
if codegenerror then
exit;
cg.a_param_loc(exprasmlist,right.location,paramanager.getintparaloc(1));
end
else
begin
getaddrlabel(a);
cg.a_label(exprasmlist,a);
reference_reset_symbol(href2,a,0);
cg.a_paramaddr_ref(exprasmlist,href2,paramanager.getintparaloc(2));
cg.a_param_reg(exprasmlist,OS_ADDR,FRAME_POINTER_REG,paramanager.getintparaloc(3));
end;
{ push object }
secondpass(left);
if codegenerror then
exit;
cg.a_param_loc(exprasmlist,left.location,paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_RAISEEXCEPTION');
end
else
begin
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.a_call_name(exprasmlist,'FPC_RERAISE');
end;
end;
{*****************************************************************************
SecondTryExcept
*****************************************************************************}
var
endexceptlabel : tasmlabel;
{ does the necessary things to clean up the object stack }
{ in the except block }
procedure cleanupobjectstack;
begin
cg.a_call_name(exprasmlist,'FPC_POPOBJECTSTACK');
cg.a_param_reg(exprasmlist,OS_ADDR,accumulator,paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
cg.g_maybe_loadself(exprasmlist);
end;
procedure tcgtryexceptnode.pass_2;
var
exceptlabel,doexceptlabel,oldendexceptlabel,
lastonlabel,
exitexceptlabel,
continueexceptlabel,
breakexceptlabel,
exittrylabel,
continuetrylabel,
breaktrylabel,
doobjectdestroy,
doobjectdestroyandreraise,
oldaktexitlabel,
oldaktexit2label,
oldaktcontinuelabel,
oldaktbreaklabel : tasmlabel;
oldflowcontrol,tryflowcontrol,
exceptflowcontrol : tflowcontrol;
tempbuf,tempaddr : treference;
href : treference;
label
errorexit;
begin
oldflowcontrol:=flowcontrol;
flowcontrol:=[];
{ this can be called recursivly }
oldendexceptlabel:=endexceptlabel;
{ save the old labels for control flow statements }
oldaktexitlabel:=aktexitlabel;
oldaktexit2label:=aktexit2label;
if assigned(aktbreaklabel) then
begin
oldaktcontinuelabel:=aktcontinuelabel;
oldaktbreaklabel:=aktbreaklabel;
end;
{ get new labels for the control flow statements }
getlabel(exittrylabel);
getlabel(exitexceptlabel);
if assigned(aktbreaklabel) then
begin
getlabel(breaktrylabel);
getlabel(continuetrylabel);
getlabel(breakexceptlabel);
getlabel(continueexceptlabel);
end;
getlabel(exceptlabel);
getlabel(doexceptlabel);
getlabel(endexceptlabel);
getlabel(lastonlabel);
cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,exceptlabel);
{ try block }
{ set control flow labels for the try block }
aktexitlabel:=exittrylabel;
aktexit2label:=exittrylabel;
if assigned(oldaktbreaklabel) then
begin
aktcontinuelabel:=continuetrylabel;
aktbreaklabel:=breaktrylabel;
end;
flowcontrol:=[];
secondpass(left);
tryflowcontrol:=flowcontrol;
if codegenerror then
goto errorexit;
cg.a_label(exprasmlist,exceptlabel);
cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,endexceptlabel,false);
cg.a_label(exprasmlist,doexceptlabel);
{ set control flow labels for the except block }
{ and the on statements }
aktexitlabel:=exitexceptlabel;
aktexit2label:=exitexceptlabel;
if assigned(oldaktbreaklabel) then
begin
aktcontinuelabel:=continueexceptlabel;
aktbreaklabel:=breakexceptlabel;
end;
flowcontrol:=[];
{ on statements }
if assigned(right) then
secondpass(right);
cg.a_label(exprasmlist,lastonlabel);
{ default handling except handling }
if assigned(t1) then
begin
{ FPC_CATCHES must be called with
'default handler' flag (=-1)
}
cg.a_param_const(exprasmlist,OS_ADDR,aword(-1),paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_CATCHES');
cg.g_maybe_loadself(exprasmlist);
{ the destruction of the exception object must be also }
{ guarded by an exception frame }
getlabel(doobjectdestroy);
getlabel(doobjectdestroyandreraise);
cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,exceptlabel);
{ here we don't have to reset flowcontrol }
{ the default and on flowcontrols are handled equal }
secondpass(t1);
exceptflowcontrol:=flowcontrol;
cg.a_label(exprasmlist,doobjectdestroyandreraise);
cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,doobjectdestroy,false);
cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
cg.a_param_reg(exprasmlist, OS_ADDR, accumulator, paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
{ we don't need to restore esi here because reraise never }
{ returns }
cg.a_call_name(exprasmlist,'FPC_RERAISE');
cg.a_label(exprasmlist,doobjectdestroy);
cleanupobjectstack;
cg.a_jmp_always(exprasmlist,endexceptlabel);
end
else
begin
cg.a_call_name(exprasmlist,'FPC_RERAISE');
exceptflowcontrol:=flowcontrol;
end;
if fc_exit in exceptflowcontrol then
begin
{ do some magic for exit in the try block }
cg.a_label(exprasmlist,exitexceptlabel);
{ we must also destroy the address frame which guards }
{ exception object }
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cleanupobjectstack;
cg.a_jmp_always(exprasmlist,oldaktexitlabel);
end;
if fc_break in exceptflowcontrol then
begin
cg.a_label(exprasmlist,breakexceptlabel);
{ we must also destroy the address frame which guards }
{ exception object }
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cleanupobjectstack;
cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
end;
if fc_continue in exceptflowcontrol then
begin
cg.a_label(exprasmlist,continueexceptlabel);
{ we must also destroy the address frame which guards }
{ exception object }
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cleanupobjectstack;
cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
end;
if fc_exit in tryflowcontrol then
begin
{ do some magic for exit in the try block }
cg.a_label(exprasmlist,exittrylabel);
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cg.a_jmp_always(exprasmlist,oldaktexitlabel);
end;
if fc_break in tryflowcontrol then
begin
cg.a_label(exprasmlist,breaktrylabel);
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
end;
if fc_continue in tryflowcontrol then
begin
cg.a_label(exprasmlist,continuetrylabel);
cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
cg.g_exception_reason_load(exprasmlist,href);
cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
end;
cg.a_label(exprasmlist,endexceptlabel);
errorexit:
{ restore all saved labels }
endexceptlabel:=oldendexceptlabel;
{ restore the control flow labels }
aktexitlabel:=oldaktexitlabel;
aktexit2label:=oldaktexit2label;
if assigned(oldaktbreaklabel) then
begin
aktcontinuelabel:=oldaktcontinuelabel;
aktbreaklabel:=oldaktbreaklabel;
end;
{ return all used control flow statements }
flowcontrol:=oldflowcontrol+exceptflowcontrol+
tryflowcontrol;
end;
procedure tcgonnode.pass_2;
var
nextonlabel,
exitonlabel,
continueonlabel,
breakonlabel,
oldaktexitlabel,
oldaktexit2label,
oldaktcontinuelabel,
doobjectdestroyandreraise,
doobjectdestroy,
oldaktbreaklabel : tasmlabel;
ref : treference;
oldflowcontrol : tflowcontrol;
tempbuf,tempaddr : treference;
href : treference;
href2: treference;
begin
oldflowcontrol:=flowcontrol;
flowcontrol:=[];
getlabel(nextonlabel);
{ send the vmt parameter }
reference_reset_symbol(href2,newasmsymbol(excepttype.vmt_mangledname),0);
cg.a_paramaddr_ref(exprasmlist,href2,paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_CATCHES');
{ is it this catch? No. go to next onlabel }
cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,accumulator,nextonlabel);
ref.symbol:=nil;
tg.gettempofsizereference(exprasmlist,pointer_size,ref);
{ what a hack ! }
if assigned(exceptsymtable) then
tvarsym(exceptsymtable.symindex.first).address:=ref.offset;
cg.a_load_reg_ref(exprasmlist, OS_ADDR, accumulator, ref);
{ in the case that another exception is risen }
{ we've to destroy the old one }
getlabel(doobjectdestroyandreraise);
{ call setjmp, and jump to finally label on non-zero result }
cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,doobjectdestroyandreraise);
if assigned(right) then
begin
oldaktexitlabel:=aktexitlabel;
oldaktexit2label:=aktexit2label;
getlabel(exitonlabel);
aktexitlabel:=exitonlabel;
aktexit2label:=exitonlabel;
if assigned(aktbreaklabel) then
begin
oldaktcontinuelabel:=aktcontinuelabel;
oldaktbreaklabel:=aktbreaklabel;
getlabel(breakonlabel);
getlabel(continueonlabel);
aktcontinuelabel:=continueonlabel;
aktbreaklabel:=breakonlabel;
end;
{ esi is destroyed by FPC_CATCHES }
cg.g_maybe_loadself(exprasmlist);
secondpass(right);
end;
getlabel(doobjectdestroy);
cg.a_label(exprasmlist,doobjectdestroyandreraise);
cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,doobjectdestroy,false);
cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
cg.a_param_reg(exprasmlist, OS_ADDR, accumulator, paramanager.getintparaloc(1));
cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
{ we don't need to restore esi here because reraise never }
{ returns }
cg.a_call_name(exprasmlist,'FPC_RERAISE');
cg.a_label(exprasmlist,doobjectdestroy);
cleanupobjectstack;
{ clear some stuff }
tg.ungetiftemp(exprasmlist,ref);
cg.a_jmp_always(exprasmlist,endexceptlabel);
if assigned(right) then
begin
{ special handling for control flow instructions }
if fc_exit in flowcontrol then
begin
{ the address and object pop does secondtryexcept }
cg.a_label(exprasmlist,exitonlabel);
cg.a_jmp_always(exprasmlist,oldaktexitlabel);
end;
if fc_break in flowcontrol then
begin
{ the address and object pop does secondtryexcept }
cg.a_label(exprasmlist,breakonlabel);
cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
end;
if fc_continue in flowcontrol then
begin
{ the address and object pop does secondtryexcept }
cg.a_label(exprasmlist,continueonlabel);
cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
end;
aktexitlabel:=oldaktexitlabel;
aktexit2label:=oldaktexit2label;
if assigned(oldaktbreaklabel) then
begin
aktcontinuelabel:=oldaktcontinuelabel;
aktbreaklabel:=oldaktbreaklabel;
end;
end;
cg.a_label(exprasmlist,nextonlabel);
flowcontrol:=oldflowcontrol+flowcontrol;
{ next on node }
if assigned(left) then
begin
rg.cleartempgen;
secondpass(left);
end;
end;
{*****************************************************************************
SecondTryFinally
*****************************************************************************}
procedure tcgtryfinallynode.pass_2;
var
reraiselabel,
finallylabel,
endfinallylabel,
exitfinallylabel,
continuefinallylabel,
breakfinallylabel,
oldaktexitlabel,
oldaktexit2label,
oldaktcontinuelabel,
oldaktbreaklabel : tasmlabel;
oldflowcontrol,tryflowcontrol : tflowcontrol;
decconst : longint;
tempbuf,tempaddr : treference;
href : treference;
begin
{ check if child nodes do a break/continue/exit }
oldflowcontrol:=flowcontrol;
flowcontrol:=[];
getlabel(finallylabel);
getlabel(endfinallylabel);
getlabel(reraiselabel);
{ the finally block must catch break, continue and exit }
{ statements }
oldaktexitlabel:=aktexitlabel;
oldaktexit2label:=aktexit2label;
getlabel(exitfinallylabel);
aktexitlabel:=exitfinallylabel;
aktexit2label:=exitfinallylabel;
if assigned(aktbreaklabel) then
begin
oldaktcontinuelabel:=aktcontinuelabel;
oldaktbreaklabel:=aktbreaklabel;
getlabel(breakfinallylabel);
getlabel(continuefinallylabel);
aktcontinuelabel:=continuefinallylabel;
aktbreaklabel:=breakfinallylabel;
end;
{ call setjmp, and jump to finally label on non-zero result }
cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,finallylabel);
{ try code }
if assigned(left) then
begin
secondpass(left);
tryflowcontrol:=flowcontrol;
if codegenerror then
exit;
end;
cg.a_label(exprasmlist,finallylabel);
{ just free the frame information }
cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,1,finallylabel,true);
{ finally code }
flowcontrol:=[];
secondpass(right);
if flowcontrol<>[] then
CGMessage(cg_e_control_flow_outside_finally);
if codegenerror then
exit;
{ the value should now be in the exception handler }
cg.g_exception_reason_load(exprasmlist,href);
cg.a_cmp_reg_reg_label(exprasmlist,OS_S32,OC_NE,accumulator,accumulator,finallylabel);
cg.a_op_const_reg(exprasmlist,OP_SUB,1,accumulator);
cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,reraiselabel);
if fc_exit in tryflowcontrol then
begin
cg.a_op_const_reg(exprasmlist,OP_SUB,1,accumulator);
cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktexitlabel);
decconst:=1;
end
else
decconst:=2;
if fc_break in tryflowcontrol then
begin
cg.a_op_const_reg(exprasmlist,OP_SUB,decconst,accumulator);
cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktbreaklabel);
decconst:=1;
end
else
inc(decconst);
if fc_continue in tryflowcontrol then
begin
cg.a_op_const_reg(exprasmlist,OP_SUB,decconst,accumulator);
cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktcontinuelabel);
end;
cg.a_label(exprasmlist,reraiselabel);
cg.a_call_name(exprasmlist,'FPC_RERAISE');
{ do some magic for exit,break,continue in the try block }
if fc_exit in tryflowcontrol then
begin
cg.a_label(exprasmlist,exitfinallylabel);
cg.g_exception_reason_load(exprasmlist,href);
cg.g_exception_reason_save_const(exprasmlist,href,2);
cg.a_jmp_always(exprasmlist,finallylabel);
end;
if fc_break in tryflowcontrol then
begin
cg.a_label(exprasmlist,breakfinallylabel);
cg.g_exception_reason_load(exprasmlist,href);
cg.g_exception_reason_save_const(exprasmlist,href,3);
cg.a_jmp_always(exprasmlist,finallylabel);
end;
if fc_continue in tryflowcontrol then
begin
cg.a_label(exprasmlist,continuefinallylabel);
cg.g_exception_reason_load(exprasmlist,href);
cg.g_exception_reason_save_const(exprasmlist,href,4);
cg.a_jmp_always(exprasmlist,finallylabel);
end;
cg.a_label(exprasmlist,endfinallylabel);
aktexitlabel:=oldaktexitlabel;
aktexit2label:=oldaktexit2label;
if assigned(aktbreaklabel) then
begin
aktcontinuelabel:=oldaktcontinuelabel;
aktbreaklabel:=oldaktbreaklabel;
end;
flowcontrol:=oldflowcontrol+tryflowcontrol;
end;
begin
@ -624,10 +1202,18 @@ begin
cgotonode:=tcggotonode;
clabelnode:=tcglabelnode;
cfailnode:=tcgfailnode;
craisenode:=tcgraisenode;
ctryexceptnode:=tcgtryexceptnode;
ctryfinallynode:=tcgtryfinallynode;
connode:=tcgonnode;
end.
{
$Log$
Revision 1.30 2002-07-27 19:53:51 jonas
Revision 1.31 2002-08-04 19:06:41 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.30 2002/07/27 19:53:51 jonas
+ generic implementation of tcg.g_flags2ref()
* tcg.flags2xxx() now also needs a size parameter

130
compiler/ncginl.pas
View File

@ -272,9 +272,9 @@ implementation
getlabel(lengthlab);
cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,hregister,lengthlab);
reference_reset_base(href,hregister,-8);
cg.a_load_ref_reg(exprasmlist,OS_INT,href,hregister);
cg.a_load_ref_reg(exprasmlist,OS_32,href,hregister);
cg.a_label(exprasmlist,lengthlab);
location_reset(location,LOC_REGISTER,OS_INT);
location_reset(location,LOC_REGISTER,OS_32);
location.register:=hregister;
end
else
@ -441,10 +441,11 @@ implementation
WriteLn('Exiting assigned node!');
end;
*)
{*****************************************************************************
INCLUDE/EXCLUDE GENERIC HANDLING
*****************************************************************************}
(*
procedure tcginlinenode.second_IncludeExclude;
var
scratch_reg : boolean;
@ -453,6 +454,7 @@ implementation
L : longint;
pushedregs : TMaybesave;
cgop : topcg;
addrreg, hregister2: tregister;
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
begin
location_copy(location,left.location);
@ -485,48 +487,100 @@ implementation
end
else
begin
use_small:=
{ set type }
(tsetdef(tcallparanode(left).left.resulttype.def).settype=smallset)
and
{ elemenut number between 1 and 32 }
((tcallparanode(tcallparanode(left).right).left.resulttype.def.deftype=orddef) and
(torddef(tcallparanode(tcallparanode(left).right).left.resulttype.def).high<=32) or
(tcallparanode(tcallparanode(left).right).left.resulttype.def.deftype=enumdef) and
(tenumdef(tcallparanode(tcallparanode(left).right).left.resulttype.def).max<=32));
{ generate code for the element to set }
maybe_save(exprasmlist,tcallparanode(tcallparanode(left).right).left.registers32,
tcallparanode(left).left.location,pushedregs);
secondpass(tcallparanode(tcallparanode(left).right).left);
maybe_restore(exprasmlist,tcallparanode(left).left.location,pushedregs);
{ determine asm operator }
if inlinenumber=in_include_x_y then
asmop:=A_BTS
else
asmop:=A_BTR;
if tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
{ we don't need a mod 32 because this is done automatically }
{ by the bts instruction. For proper checking we would }
{ note: bts doesn't do any mod'ing, that's why we can also use }
{ it for normalsets! (JM) }
{ need a cmp and jmp, but this should be done by the }
{ type cast code which does range checking if necessary (FK) }
{ bitnumber - which must be loaded into register }
hregister := cg.get_scratch_reg_int(exprasmlist);
hregister2 := rg.getregisterint(exprasmlist);
case tcallparanode(tcallparanode(left).right).left.location.loc of
LOC_CREGISTER,
LOC_REGISTER
begin
cg.a_load_reg_reg(exprasmlist,OS_INT,
tcallparanode(tcallparanode(left).right).left.location.loc.register),hregister);
end;
LOC_REFERENCE:
begin
cgsize := def_cgsize(tcallparanode(tcallparanode(left).right).left.resulttype.def);
cg.a_load_ref_reg(exprasmlist,cgsize,
tcallparanode(tcallparanode(left).right).left.location.loc.reference),hregister);
end;
else
internalerror(20020727);
end;
{ hregister contains the bitnumber to add }
cg.a_load_const_reg(exprasmlist, OS_INT, 1, hregister2);
cg.a_op_reg_reg(exprasmlist, OP_SHL, OS_INT, hregister, hregister2);
if use_small then
begin
scratch_reg := FALSE;
WriteLn('HELLO!');
hregister := rg.makeregsize(tcallparanode(tcallparanode(left).right).left.location.register,OS_INT);
{ possiblities :
bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
set value : LOC_REFERENCE, LOC_REGISTER
}
{ location of set }
if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
begin
if inlinenumber=in_include_x_y then
begin
cg.a_op_reg_ref(exprasmlist, OP_OR, OS_32, hregister2,
tcallparanode(left).left.location.loc.reference);
end
else
begin
cg.a_op_reg_reg(exprasmlist, OP_NOT, OS_32, hregister2,
hregister2);
cg.a_op_reg_ref(exprasmlist, OP_AND, OS_32, hregister2,
tcallparanode(left).left.location.loc.reference);
end;
end
else
internalerror(20020728);
end
else
begin
scratch_reg := TRUE;
hregister:=cg.get_scratch_reg_int(exprasmlist);
end;
cg.a_load_loc_reg(exprasmlist,tcallparanode(tcallparanode(left).right).left.location,hregister);
if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
emit_reg_ref(asmop,S_L,hregister,tcallparanode(left).left.location.reference)
else
emit_reg_reg(asmop,S_L,hregister,tcallparanode(left).left.location.register);
if scratch_reg then
cg.free_scratch_reg(exprasmlist,hregister);
end;
location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def));
location.register := rg.makeregsize(hreg,def_cgsize(resulttype.def));
{ possiblities :
bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
set value : LOC_REFERENCE
}
{ hregister contains the bitnumber (div 32 to get the correct offset) }
cg.a_op_const_reg(exprasmlist, OP_SHR, OS_INT, 5, hregister);
{ calculate the correct address of the operand }
cg.a_loadaddr_ref_reg(exprasmlist, tcallparanode(left).left.location.loc.reference,addrreg);
cg.a_op_reg_reg(exprasmlist, OP_ADD, OS_INT, hregister, addrreg);
reference_reset_base(href,addrreg,0);
if inlinenumber=in_include_x_y then
begin
cg.a_op_reg_ref(exprasmlist, OP_OR, OS_32, hregister2, href);
end
else
begin
cg.a_op_reg_reg(exprasmlist, OP_NOT, OS_32, hregister2,
hregister2);
cg.a_op_reg_ref(exprasmlist, OP_AND, OS_32, hregister2, href);
end;
end;
end;
*)
{*****************************************************************************
FLOAT GENERIC HANDLING
@ -583,7 +637,11 @@ end.
{
$Log$
Revision 1.8 2002-07-31 07:54:59 jonas
Revision 1.9 2002-08-04 19:06:41 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.8 2002/07/31 07:54:59 jonas
* re-enabled second_assigned()
Revision 1.7 2002/07/30 20:50:43 florian

44
compiler/ncgutil.pas
View File

@ -1071,29 +1071,6 @@ implementation
end;
procedure gen_exception_frame(list : taasmoutput);
var
tempbuf : treference;
tmpreg : tregister;
begin
include(rg.usedinproc,accumulator);
{ allocate exception frame buffer }
{ this isn't generic, several APIs doesn't }
{ allow to change the stack pointer inside }
{ a procedure }
{ we should allocate a persistent temp. }
{ instead }
cg.a_op_const_reg(list,OP_SUB,36,STACK_POINTER_REG);
tmpreg:=rg.getaddressregister(list);
cg.a_load_reg_reg(list,OS_ADDR,STACK_POINTER_REG,tmpreg);
reference_reset_base(tempbuf,tmpreg,0);
cg.g_push_exception(list,tempbuf,1,aktexitlabel);
reference_release(list,tempbuf);
{ probably we've to reload self here }
cg.g_maybe_loadself(list);
end;
procedure genentrycode(list : TAAsmoutput;
make_global:boolean;
@ -1276,7 +1253,14 @@ implementation
if ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
{ but it's useless in init/final code of units }
not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
gen_exception_frame(list);
begin
include(rg.usedinproc,accumulator);
cg.g_new_exception(list,procinfo^.exception_jmp_ref,
procinfo^.exception_env_ref,
procinfo^.exception_result_ref,1,aktexitlabel);
{ probably we've to reload self here }
cg.g_maybe_loadself(list);
end;
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
@ -1355,7 +1339,11 @@ implementation
{ the exception helper routines modify all registers }
aktprocdef.usedregisters:=all_registers;
getlabel(noreraiselabel);
cg.g_pop_exception(list,noreraiselabel);
cg.g_free_exception(list,
procinfo^.exception_jmp_ref,
procinfo^.exception_env_ref,
procinfo^.exception_result_ref,0
,noreraiselabel,false);
if (aktprocdef.proctypeoption=potype_constructor) then
begin
@ -1638,7 +1626,11 @@ implementation
end.
{
$Log$
Revision 1.28 2002-07-29 21:23:42 florian
Revision 1.29 2002-08-04 19:09:22 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.28 2002/07/29 21:23:42 florian
* more fixes for the ppc
+ wrappers for the tcnvnode.first_* stuff introduced

46
compiler/rgobj.pas
View File

@ -46,6 +46,15 @@ unit rgobj;
tpushedsaved = array[firstreg..lastreg] of tpushedsavedloc;
{#
This class implements the abstract register allocator
It is used by the code generator to allocate and free
registers which might be valid across nodes. It also
contains utility routines related to registers.
Some of the methods in this class should be overriden
by cpu-specific implementations.
}
trgobj = class
{ The "usableregsxxx" contain all registers of type "xxx" that }
{ aren't currently allocated to a regvar. The "unusedregsxxx" }
@ -75,15 +84,37 @@ unit rgobj;
constructor create;
{# Allocate a general purpose register
An internalerror will be generated if there
is no more free registers which can be allocated
}
function getregisterint(list: taasmoutput) : tregister; virtual;
{# Free a general purpose register }
procedure ungetregisterint(list: taasmoutput; r : tregister); virtual;
{# Allocate a floating point register
An internalerror will be generated if there
is no more free registers which can be allocated
}
function getregisterfpu(list: taasmoutput) : tregister; virtual;
{# Free a floating point register }
procedure ungetregisterfpu(list: taasmoutput; r : tregister); virtual;
function getregistermm(list: taasmoutput) : tregister; virtual;
procedure ungetregistermm(list: taasmoutput; r : tregister); virtual;
{# Allocate an address register.
Address registers are the only registers which can
be used as a base register in references (treference).
On most cpu's this is the same as a general purpose
register.
An internalerror will be generated if there
is no more free registers which can be allocated
}
function getaddressregister(list: taasmoutput): tregister; virtual;
procedure ungetaddressregister(list: taasmoutput; r: tregister); virtual;
{ the following must only be called for address and integer }
@ -106,10 +137,10 @@ unit rgobj;
function makeregsize(reg: tregister; size: tcgsize): tregister; virtual;
{ saves register variables (restoring happens automatically) }
{# saves register variables (restoring happens automatically) }
procedure saveregvars(list: taasmoutput; const s: tregisterset);
{ saves and restores used registers }
{# saves and restores used registers }
procedure saveusedregisters(list: taasmoutput;
var saved : tpushedsaved;const s: tregisterset);virtual;
procedure restoreusedregisters(list: taasmoutput;
@ -152,7 +183,12 @@ unit rgobj;
rg: trgobj;
{ trerefence handling }
{# Clear to zero a treference }
procedure reference_reset(var ref : treference);
{# Clear to zero a treference, and set is base address
to base register.
}
procedure reference_reset_base(var ref : treference;base : tregister;offset : longint);
procedure reference_reset_symbol(var ref : treference;sym : tasmsymbol;offset : longint);
procedure reference_release(list: taasmoutput; const ref : treference);
@ -856,7 +892,11 @@ end.
{
$Log$
Revision 1.13 2002-07-07 09:52:32 florian
Revision 1.14 2002-08-04 19:06:41 carl
+ added generic exception support (still does not work!)
+ more documentation
Revision 1.13 2002/07/07 09:52:32 florian
* powerpc target fixed, very simple units can be compiled
* some basic stuff for better callparanode handling, far from being finished