paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-10 10:09:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

* almost all second pass typeconvnode helpers are now processor independent

Browse Source 
* fixed converting boolean to int64/qword
  * fixed register allocation bugs which could cause internalerror 10
  * isnode and asnode are completely processor indepent now as well
  * fpc_do_as now returns its class argument (necessary to be able to use it
    properly with compilerproc)
This commit is contained in:
Jonas Maebe 2001-09-29 21:32:46 +00:00
parent fac1fb3d6c
commit fc6d300a95
6 changed files with 659 additions and 489 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
compiler/i386/cpunode.pas
View File

@ -29,7 +29,7 @@ unit cpunode;
implementation
uses
ncgbas,ncgflw,
ncgbas,ncgflw,ncgcnv,
n386ld,n386add,n386cal,n386con,n386flw,n386mat,n386mem,
n386set,n386inl,n386opt,
{ this not really a node }
@ -38,7 +38,15 @@ unit cpunode;
end.
{
$Log$
Revision 1.5 2001-09-28 20:39:33 jonas
Revision 1.6 2001-09-29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
Revision 1.5 2001/09/28 20:39:33 jonas
* changed all flow control structures (except for exception handling
related things) to processor independent code (in new ncgflw unit)
+ generic cgobj unit which contains lots of code generator helpers with

515
compiler/i386/n386cnv.pas
View File

@ -27,30 +27,30 @@ unit n386cnv;
interface
uses
node,ncnv,types;
node,ncnv,ncgcnv,types;
type
ti386typeconvnode = class(ttypeconvnode)
procedure second_int_to_int;virtual;
{ procedure second_string_to_string;virtual; }
procedure second_cstring_to_pchar;virtual;
procedure second_string_to_chararray;virtual;
procedure second_array_to_pointer;virtual;
procedure second_pointer_to_array;virtual;
{ procedure second_chararray_to_string;virtual; }
procedure second_char_to_string;virtual;
procedure second_int_to_real;virtual;
procedure second_real_to_real;virtual;
procedure second_cord_to_pointer;virtual;
procedure second_proc_to_procvar;virtual;
procedure second_bool_to_int;virtual;
procedure second_int_to_bool;virtual;
procedure second_load_smallset;virtual;
procedure second_ansistring_to_pchar;virtual;
{ procedure second_pchar_to_string;virtual; }
procedure second_class_to_intf;virtual;
procedure second_char_to_char;virtual;
procedure second_nothing;virtual;
ti386typeconvnode = class(tcgtypeconvnode)
protected
procedure second_int_to_int;override;
{ procedure second_string_to_string;override; }
{ procedure second_cstring_to_pchar;override; }
{ procedure second_string_to_chararray;override; }
{ procedure second_array_to_pointer;override; }
{ procedure second_pointer_to_array;override; }
{ procedure second_chararray_to_string;override; }
{ procedure second_char_to_string;override; }
procedure second_int_to_real;override;
{ procedure second_real_to_real;override; }
{ procedure second_cord_to_pointer;override; }
{ procedure second_proc_to_procvar;override; }
{ procedure second_bool_to_int;override; }
procedure second_int_to_bool;override;
{ procedure second_load_smallset;override; }
{ procedure second_ansistring_to_pchar;override; }
{ procedure second_pchar_to_string;override; }
{ procedure second_class_to_intf;override; }
{ procedure second_char_to_char;override; }
procedure pass_2;override;
procedure second_call_helper(c : tconverttype);
end;
@ -201,141 +201,6 @@ implementation
end;
procedure ti386typeconvnode.second_cstring_to_pchar;
var
hr : preference;
begin
clear_location(location);
location.loc:=LOC_REGISTER;
case tstringdef(left.resulttype.def).string_typ of
st_shortstring :
begin
inc(left.location.reference.offset);
del_reference(left.location.reference);
location.register:=getregister32;
emit_ref_reg(A_LEA,S_L,newreference(left.location.reference),
location.register);
end;
st_ansistring :
begin
if (left.nodetype=stringconstn) and
(str_length(left)=0) then
begin
new(hr);
reset_reference(hr^);
hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
location.register:=getregister32;
emit_ref_reg(A_LEA,S_L,hr,location.register);
end
else
begin
del_reference(left.location.reference);
location.register:=getregister32;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
location.register);
end;
end;
st_longstring:
begin
{!!!!!!!}
internalerror(8888);
end;
st_widestring:
begin
if (left.nodetype=stringconstn) and
(str_length(left)=0) then
begin
new(hr);
reset_reference(hr^);
hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
location.register:=getregister32;
emit_ref_reg(A_LEA,S_L,hr,location.register);
end
else
begin
del_reference(left.location.reference);
location.register:=getregister32;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
location.register);
end;
end;
end;
end;
procedure ti386typeconvnode.second_string_to_chararray;
var
arrsize: longint;
begin
with tarraydef(resulttype.def) do
arrsize := highrange-lowrange+1;
if (left.nodetype = stringconstn) and
{ left.length+1 since there's always a terminating #0 character (JM) }
(tstringconstnode(left).len+1 >= arrsize) and
(tstringdef(left.resulttype.def).string_typ=st_shortstring) then
begin
inc(location.reference.offset);
exit;
end
else
{ should be handled already in resulttype pass (JM) }
internalerror(200108292);
end;
procedure ti386typeconvnode.second_array_to_pointer;
begin
del_reference(left.location.reference);
clear_location(location);
location.loc:=LOC_REGISTER;
location.register:=getregister32;
emit_ref_reg(A_LEA,S_L,newreference(left.location.reference),
location.register);
end;
procedure ti386typeconvnode.second_pointer_to_array;
begin
clear_location(location);
location.loc:=LOC_REFERENCE;
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER :
location.reference.base:=left.location.register;
LOC_CREGISTER :
begin
location.reference.base:=getregister32;
emit_reg_reg(A_MOV,S_L,left.location.register,location.reference.base);
end
else
begin
del_reference(left.location.reference);
location.reference.base:=getregister32;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
location.reference.base);
end;
end;
end;
procedure ti386typeconvnode.second_char_to_string;
begin
clear_location(location);
location.loc:=LOC_MEM;
case tstringdef(resulttype.def).string_typ of
st_shortstring :
begin
gettempofsizereference(256,location.reference);
loadshortstring(left,self);
end;
{ the rest is removed in the resulttype pass and coverted to compilerprocs }
else
internalerror(4179);
end;
end;
procedure ti386typeconvnode.second_int_to_real;
var
@ -454,175 +319,6 @@ implementation
end;
procedure ti386typeconvnode.second_real_to_real;
begin
case left.location.loc of
LOC_FPU : ;
LOC_CFPUREGISTER:
begin
location:=left.location;
exit;
end;
LOC_MEM,
LOC_REFERENCE:
begin
floatload(tfloatdef(left.resulttype.def).typ,
left.location.reference);
{ we have to free the reference }
del_reference(left.location.reference);
end;
end;
clear_location(location);
location.loc:=LOC_FPU;
end;
procedure ti386typeconvnode.second_cord_to_pointer;
begin
{ this can't happend, because constants are already processed in
pass 1 }
internalerror(47423985);
end;
procedure ti386typeconvnode.second_proc_to_procvar;
begin
{ method pointer ? }
if assigned(tcallnode(left).left) then
begin
set_location(location,left.location);
end
else
begin
clear_location(location);
location.loc:=LOC_REGISTER;
location.register:=getregister32;
del_reference(left.location.reference);
emit_ref_reg(A_LEA,S_L,
newreference(left.location.reference),location.register);
end;
end;
procedure ti386typeconvnode.second_bool_to_int;
var
oldtruelabel,oldfalselabel,hlabel : tasmlabel;
hregister : tregister;
newsize,
opsize : topsize;
op : tasmop;
begin
oldtruelabel:=truelabel;
oldfalselabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(left);
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def.size=resulttype.def.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
begin
set_location(location,left.location);
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
exit;
end;
clear_location(location);
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
case left.resulttype.def.size of
1 : begin
case resulttype.def.size of
1 : opsize:=S_B;
2 : opsize:=S_BW;
4 : opsize:=S_BL;
end;
end;
2 : begin
case resulttype.def.size of
1 : begin
if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
left.location.register:=reg16toreg8(left.location.register);
opsize:=S_B;
end;
2 : opsize:=S_W;
4 : opsize:=S_WL;
end;
end;
4 : begin
case resulttype.def.size of
1 : begin
if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
left.location.register:=reg32toreg8(left.location.register);
opsize:=S_B;
end;
2 : begin
if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
left.location.register:=reg32toreg16(left.location.register);
opsize:=S_W;
end;
4 : opsize:=S_L;
end;
end;
end;
if opsize in [S_B,S_W,S_L] then
op:=A_MOV
else
if is_signed(resulttype.def) then
op:=A_MOVSX
else
op:=A_MOVZX;
hregister:=getregister32;
case resulttype.def.size of
1 : begin
location.register:=reg32toreg8(hregister);
newsize:=S_B;
end;
2 : begin
location.register:=reg32toreg16(hregister);
newsize:=S_W;
end;
4 : begin
location.register:=hregister;
newsize:=S_L;
end;
else
internalerror(10060);
end;
case left.location.loc of
LOC_MEM,
LOC_REFERENCE : emit_ref_reg(op,opsize,
newreference(left.location.reference),location.register);
LOC_REGISTER,
LOC_CREGISTER : begin
{ remove things like movb %al,%al }
if left.location.register<>location.register then
emit_reg_reg(op,opsize,
left.location.register,location.register);
end;
LOC_FLAGS : begin
emit_flag2reg(left.location.resflags,location.register);
end;
LOC_JUMP : begin
getlabel(hlabel);
emitlab(truelabel);
emit_const_reg(A_MOV,newsize,1,location.register);
emitjmp(C_None,hlabel);
emitlab(falselabel);
emit_reg_reg(A_XOR,newsize,location.register,
location.register);
emitlab(hlabel);
end;
else
internalerror(10061);
end;
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
end;
procedure ti386typeconvnode.second_int_to_bool;
var
hregister : tregister;
@ -630,8 +326,8 @@ implementation
opsize : topsize;
begin
clear_location(location);
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
{ byte(boolean) or word(wordbool) or longint(longbool) must }
{ be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def.size=resulttype.def.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
@ -640,7 +336,7 @@ implementation
exit;
end;
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
del_location(left.location);
opsize:=def_opsize(left.resulttype.def);
case left.location.loc of
LOC_MEM,LOC_REFERENCE :
@ -676,103 +372,6 @@ implementation
end;
procedure ti386typeconvnode.second_load_smallset;
var
href : treference;
pushedregs : tpushed;
begin
href.symbol:=nil;
pushusedregisters(pushedregs,$ff);
gettempofsizereference(32,href);
emit_push_mem_size(left.location.reference,4);
emitpushreferenceaddr(href);
saveregvars($ff);
emitcall('FPC_SET_LOAD_SMALL');
maybe_loadself;
popusedregisters(pushedregs);
clear_location(location);
location.loc:=LOC_MEM;
location.reference:=href;
end;
procedure ti386typeconvnode.second_ansistring_to_pchar;
var
l1 : tasmlabel;
hr : preference;
begin
clear_location(location);
location.loc:=LOC_REGISTER;
getlabel(l1);
case left.location.loc of
LOC_CREGISTER,LOC_REGISTER:
location.register:=left.location.register;
LOC_MEM,LOC_REFERENCE:
begin
location.register:=getregister32;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
location.register);
del_reference(left.location.reference);
end;
end;
emit_const_reg(A_CMP,S_L,0,location.register);
emitjmp(C_NZ,l1);
new(hr);
reset_reference(hr^);
hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
emit_ref_reg(A_LEA,S_L,hr,location.register);
emitlab(l1);
end;
procedure ti386typeconvnode.second_class_to_intf;
var
hreg : tregister;
l1 : tasmlabel;
begin
case left.location.loc of
LOC_MEM,
LOC_REFERENCE:
begin
del_reference(left.location.reference);
hreg:=getregister32;
exprasmList.concat(Taicpu.Op_ref_reg(
A_MOV,S_L,newreference(left.location.reference),hreg));
end;
LOC_CREGISTER:
begin
hreg:=getregister32;
exprasmList.concat(Taicpu.Op_reg_reg(
A_MOV,S_L,left.location.register,hreg));
end;
LOC_REGISTER:
hreg:=left.location.register;
else internalerror(121120001);
end;
emit_reg_reg(A_TEST,S_L,hreg,hreg);
getlabel(l1);
emitjmp(C_Z,l1);
emit_const_reg(A_ADD,S_L,tobjectdef(left.resulttype.def).implementedinterfaces.ioffsets(
tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(resulttype.def))^,hreg);
emitlab(l1);
location.loc:=LOC_REGISTER;
location.register:=hreg;
end;
procedure ti386typeconvnode.second_char_to_char;
begin
{$warning todo: add RTL routine for widechar-char conversion }
{ Quick hack to atleast generate 'working' code (PFV) }
second_int_to_int;
end;
procedure ti386typeconvnode.second_nothing;
begin
end;
{****************************************************************************
TI386TYPECONVNODE
****************************************************************************}
@ -781,33 +380,33 @@ implementation
const
secondconvert : array[tconverttype] of pointer = (
@ti386typeconvnode.second_nothing, {equal}
@ti386typeconvnode.second_nothing, {not_possible}
@ti386typeconvnode.second_nothing, {second_string_to_string, handled in resulttype pass }
@ti386typeconvnode.second_char_to_string,
@ti386typeconvnode.second_nothing, { pchar_to_string, handled in resulttype pass }
@ti386typeconvnode.second_nothing, {cchar_to_pchar}
@ti386typeconvnode.second_cstring_to_pchar,
@ti386typeconvnode.second_ansistring_to_pchar,
@ti386typeconvnode.second_string_to_chararray,
@ti386typeconvnode.second_nothing, { chararray_to_string, handled in resulttype pass }
@ti386typeconvnode.second_array_to_pointer,
@ti386typeconvnode.second_pointer_to_array,
@ti386typeconvnode.second_int_to_int,
@ti386typeconvnode.second_int_to_bool,
@ti386typeconvnode.second_bool_to_int, { bool_to_bool }
@ti386typeconvnode.second_bool_to_int,
@ti386typeconvnode.second_real_to_real,
@ti386typeconvnode.second_int_to_real,
@ti386typeconvnode.second_proc_to_procvar,
@ti386typeconvnode.second_nothing, {arrayconstructor_to_set}
@ti386typeconvnode.second_load_smallset,
@ti386typeconvnode.second_cord_to_pointer,
@ti386typeconvnode.second_nothing, { interface 2 string }
@ti386typeconvnode.second_nothing, { interface 2 guid }
@ti386typeconvnode.second_class_to_intf,
@ti386typeconvnode.second_char_to_char,
@ti386typeconvnode.second_nothing { normal_2_smallset }
@second_nothing, {equal}
@second_nothing, {not_possible}
@second_nothing, {second_string_to_string, handled in resulttype pass }
@second_char_to_string,
@second_nothing, { pchar_to_string, handled in resulttype pass }
@second_nothing, {cchar_to_pchar}
@second_cstring_to_pchar,
@second_ansistring_to_pchar,
@second_string_to_chararray,
@second_nothing, { chararray_to_string, handled in resulttype pass }
@second_array_to_pointer,
@second_pointer_to_array,
@second_int_to_int,
@second_int_to_bool,
@second_bool_to_int, { bool_to_bool }
@second_bool_to_int,
@second_real_to_real,
@second_int_to_real,
@second_proc_to_procvar,
@second_nothing, { arrayconstructor_to_set }
@second_nothing, { second_load_smallset, handled in first pass }
@second_cord_to_pointer,
@second_nothing, { interface 2 string }
@second_nothing, { interface 2 guid }
@second_class_to_intf,
@second_char_to_char,
@second_nothing { normal_2_smallset }
);
type
tprocedureofobject = procedure of object;
@ -1001,7 +600,15 @@ begin
end.
{
$Log$
Revision 1.23 2001-09-03 13:27:42 jonas
Revision 1.24 2001-09-29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
Revision 1.23 2001/09/03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change

436
compiler/ncgcnv.pas Normal file
View File

@ -0,0 +1,436 @@
{
$Id$
Copyright (c) 2000 by Florian Klaempfl
Generate assembler for nodes that handle type conversions which are
the same for all (most) processors
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 ncgcnv;
{$i defines.inc}
interface
uses
node,ncnv;
type
tcgtypeconvnode = class(ttypeconvnode)
procedure second_cstring_to_pchar;override;
procedure second_string_to_chararray;override;
procedure second_array_to_pointer;override;
procedure second_pointer_to_array;override;
procedure second_char_to_string;override;
procedure second_real_to_real;override;
procedure second_cord_to_pointer;override;
procedure second_proc_to_procvar;override;
procedure second_bool_to_int;override;
procedure second_ansistring_to_pchar;override;
procedure second_class_to_intf;override;
procedure second_char_to_char;override;
end;
implementation
uses
globtype,
cutils,cclasses,globals,verbose,
aasm,symconst,symsym,symtable,symdef,symtype,types,
ncon,ncal,
htypechk,
cpubase,cpuasm,
pass_2,
cgbase,
cga,cgobj,cgcpu,
{$ifdef i386}
n386util,
{$endif i386}
tgcpu,temp_gen
;
procedure tcgtypeconvnode.second_cstring_to_pchar;
var
hr : treference;
begin
clear_location(location);
location.loc:=LOC_REGISTER;
case tstringdef(left.resulttype.def).string_typ of
st_shortstring :
begin
inc(left.location.reference.offset);
del_reference(left.location.reference);
location.register:=getregister32;
cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference,
location.register);
end;
st_ansistring :
begin
if (left.nodetype=stringconstn) and
(str_length(left)=0) then
begin
reset_reference(hr);
hr.symbol:=newasmsymbol('FPC_EMPTYCHAR');
location.register:=getregister32;
cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register);
end
else
begin
del_reference(left.location.reference);
location.register:=getregister32;
cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,
location.register);
end;
end;
st_longstring:
begin
{!!!!!!!}
internalerror(8888);
end;
st_widestring:
begin
if (left.nodetype=stringconstn) and
(str_length(left)=0) then
begin
reset_reference(hr);
hr.symbol:=newasmsymbol('FPC_EMPTYCHAR');
location.register:=getregister32;
cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register);
end
else
begin
del_reference(left.location.reference);
location.register:=getregister32;
{$warning Todo: convert widestrings to ascii when typecasting them to pchars}
cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,
location.register);
end;
end;
end;
end;
procedure tcgtypeconvnode.second_string_to_chararray;
var
arrsize: longint;
begin
with tarraydef(resulttype.def) do
arrsize := highrange-lowrange+1;
if (left.nodetype = stringconstn) and
{ left.length+1 since there's always a terminating #0 character (JM) }
(tstringconstnode(left).len+1 >= arrsize) and
(tstringdef(left.resulttype.def).string_typ=st_shortstring) then
begin
inc(location.reference.offset);
exit;
end
else
{ should be handled already in resulttype pass (JM) }
internalerror(200108292);
end;
procedure tcgtypeconvnode.second_array_to_pointer;
begin
del_reference(left.location.reference);
clear_location(location);
location.loc:=LOC_REGISTER;
location.register:=getregister32;
cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference,
location.register);
end;
procedure tcgtypeconvnode.second_pointer_to_array;
begin
clear_location(location);
location.loc:=LOC_REFERENCE;
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER :
location.reference.base:=left.location.register;
LOC_CREGISTER :
begin
location.reference.base:=getregister32;
cg.a_load_reg_reg(exprasmlist,OS_32,left.location.register,
location.reference.base);
end
else
begin
del_reference(left.location.reference);
location.reference.base:=getregister32;
cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,
location.reference.base);
end;
end;
end;
procedure tcgtypeconvnode.second_char_to_string;
begin
clear_location(location);
location.loc:=LOC_MEM;
case tstringdef(resulttype.def).string_typ of
st_shortstring :
begin
gettempofsizereference(256,location.reference);
loadshortstring(left,self);
end;
{ the rest is removed in the resulttype pass and converted to compilerprocs }
else
internalerror(4179);
end;
end;
procedure tcgtypeconvnode.second_real_to_real;
begin
case left.location.loc of
LOC_FPU : ;
LOC_CFPUREGISTER:
begin
location:=left.location;
exit;
end;
LOC_MEM,
LOC_REFERENCE:
begin
floatload(tfloatdef(left.resulttype.def).typ,
left.location.reference);
{ we have to free the reference }
del_reference(left.location.reference);
end;
end;
clear_location(location);
location.loc:=LOC_FPU;
end;
procedure tcgtypeconvnode.second_cord_to_pointer;
begin
{ this can't happen because constants are already processed in
pass 1 }
internalerror(47423985);
end;
procedure tcgtypeconvnode.second_proc_to_procvar;
begin
{ method pointer ? }
if assigned(tcallnode(left).left) then
begin
set_location(location,left.location);
end
else
begin
clear_location(location);
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
location.register:=getregister32;
cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference,
location.register);
end;
end;
procedure tcgtypeconvnode.second_bool_to_int;
var
oldtruelabel,oldfalselabel,hlabel : tasmlabel;
newsize,
opsize : tcgsize;
begin
oldtruelabel:=truelabel;
oldfalselabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(left);
{ byte(boolean) or word(wordbool) or longint(longbool) must }
{ be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def.size=resulttype.def.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
begin
set_location(location,left.location);
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
exit;
end;
clear_location(location);
location.loc:=LOC_REGISTER;
del_location(left.location);
location.register:=getregister32;
{ size of the boolean we're converting }
opsize := def_cgsize(left.resulttype.def);
{ size of the destination }
newsize := def_cgsize(resulttype.def);
{ the the source size is bigger than the destination, we can }
{ simply decrease the sources size (since wordbool(true) = }
{ boolean(true) etc... (JM) }
case newsize of
OS_8,OS_S8:
begin
opsize := OS_8;
{$ifdef i386}
location.register := makereg8(location.register);
if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
makereg8(left.location.register);
{$endif i386}
end;
OS_16,OS_S16:
begin
{$ifdef i386}
location.register := makereg16(location.register);
{$endif i386}
if opsize in [OS_32,OS_S32] then
begin
opsize := OS_16;
{$ifdef i386}
if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
makereg16(left.location.register);
{$endif i386}
end
end;
end;
case left.location.loc of
LOC_MEM,
LOC_REFERENCE :
cg.a_load_ref_reg(exprasmlist,opsize,left.location.reference,
location.register);
LOC_REGISTER,
LOC_CREGISTER :
if left.location.register<>location.register then
cg.a_load_reg_reg(exprasmlist,opsize,left.location.register,
location.register);
LOC_FLAGS :
cg.g_flags2reg(exprasmlist,left.location.resflags,location.register);
LOC_JUMP :
begin
getlabel(hlabel);
cg.a_label(exprasmlist,truelabel);
cg.a_load_const_reg(exprasmlist,newsize,1,location.register);
cg.a_jmp_cond(exprasmlist,OC_NONE,hlabel);
cg.a_label(exprasmlist,falselabel);
cg.a_load_const_reg(exprasmlist,newsize,0,location.register);
cg.a_label(exprasmlist,hlabel);
end;
else
internalerror(10061);
end;
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
end;
procedure tcgtypeconvnode.second_ansistring_to_pchar;
var
l1 : tasmlabel;
hr : treference;
begin
clear_location(location);
location.loc:=LOC_REGISTER;
getlabel(l1);
case left.location.loc of
LOC_CREGISTER,LOC_REGISTER:
location.register:=left.location.register;
LOC_MEM,LOC_REFERENCE:
begin
del_reference(left.location.reference);
location.register:=getregister32;
cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,
location.register);
end;
end;
cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_NE,0,location.register,
l1);
reset_reference(hr);
hr.symbol:=newasmsymbol('FPC_EMPTYCHAR');
cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register);
cg.a_label(exprasmlist,l1);
end;
procedure tcgtypeconvnode.second_class_to_intf;
var
hreg : tregister;
l1 : tasmlabel;
begin
case left.location.loc of
LOC_MEM,
LOC_REFERENCE:
begin
del_reference(left.location.reference);
hreg:=getregister32;
cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference,
hreg);
end;
LOC_CREGISTER:
begin
hreg:=getregister32;
cg.a_load_reg_reg(exprasmlist,OS_32,left.location.register,
hreg);
end;
LOC_REGISTER:
hreg:=left.location.register;
else internalerror(121120001);
end;
getlabel(l1);
cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_EQ,0,hreg,l1);
cg.a_op_const_reg(exprasmlist,OP_ADD,
tobjectdef(left.resulttype.def).implementedinterfaces.ioffsets(
tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(
resulttype.def))^,hreg);
cg.a_label(exprasmlist,l1);
location.loc:=LOC_REGISTER;
location.register:=hreg;
end;
procedure tcgtypeconvnode.second_char_to_char;
begin
{$warning todo: add RTL routine for widechar-char conversion }
{ Quick hack to atleast generate 'working' code (PFV) }
second_int_to_int;
end;
begin
ctypeconvnode := tcgtypeconvnode;
end.
{
$Log$
Revision 1.1 2001-09-29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
}

156
compiler/ncnv.pas
View File

@ -76,6 +76,28 @@ interface
function first_class_to_intf : tnode;virtual;
function first_char_to_char : tnode;virtual;
function first_call_helper(c : tconverttype) : tnode;
procedure second_int_to_int;virtual;abstract;
procedure second_string_to_string;virtual;abstract;
procedure second_cstring_to_pchar;virtual;abstract;
procedure second_string_to_chararray;virtual;abstract;
procedure second_array_to_pointer;virtual;abstract;
procedure second_pointer_to_array;virtual;abstract;
procedure second_chararray_to_string;virtual;abstract;
procedure second_char_to_string;virtual;abstract;
procedure second_int_to_real;virtual;abstract;
procedure second_real_to_real;virtual;abstract;
procedure second_cord_to_pointer;virtual;abstract;
procedure second_proc_to_procvar;virtual;abstract;
procedure second_bool_to_int;virtual;abstract;
procedure second_int_to_bool;virtual;abstract;
procedure second_load_smallset;virtual;abstract;
procedure second_ansistring_to_pchar;virtual;abstract;
procedure second_pchar_to_string;virtual;abstract;
procedure second_class_to_intf;virtual;abstract;
procedure second_char_to_char;virtual;abstract;
procedure second_nothing; virtual;
end;
ttypeconvnodeclass = class of ttypeconvnode;
@ -117,6 +139,7 @@ implementation
*****************************************************************************}
procedure inserttypeconv(var p:tnode;const t:ttype);
begin
if not assigned(p.resulttype.def) then
begin
@ -397,8 +420,10 @@ implementation
function ttypeconvnode.resulttype_cord_to_pointer : tnode;
var
t : tnode;
begin
result:=nil;
if left.nodetype=ordconstn then
@ -427,6 +452,7 @@ implementation
end;
function ttypeconvnode.resulttype_chararray_to_string : tnode;
begin
result := ccallnode.createinternres(
'fpc_chararray_to_'+lower(tstringdef(resulttype.def).stringtypname),
@ -435,8 +461,10 @@ implementation
end;
function ttypeconvnode.resulttype_string_to_chararray : tnode;
var
arrsize: longint;
begin
with tarraydef(resulttype.def) do
begin
@ -460,12 +488,15 @@ implementation
left := nil;
end;
function ttypeconvnode.resulttype_string_to_string : tnode;
var
procname: string[31];
stringpara : tcallparanode;
pw : pcompilerwidestring;
pc : pchar;
begin
result:=nil;
if left.nodetype=stringconstn then
@ -520,11 +551,13 @@ implementation
function ttypeconvnode.resulttype_char_to_string : tnode;
var
procname: string[31];
para : tcallparanode;
hp : tstringconstnode;
ws : pcompilerwidestring;
begin
result:=nil;
if left.nodetype=ordconstn then
@ -559,8 +592,10 @@ implementation
function ttypeconvnode.resulttype_char_to_char : tnode;
var
hp : tordconstnode;
begin
result:=nil;
if left.nodetype=ordconstn then
@ -587,8 +622,10 @@ implementation
function ttypeconvnode.resulttype_int_to_real : tnode;
var
t : trealconstnode;
begin
result:=nil;
if left.nodetype=ordconstn then
@ -601,8 +638,10 @@ implementation
function ttypeconvnode.resulttype_real_to_real : tnode;
var
t : tnode;
begin
result:=nil;
if left.nodetype=realconstn then
@ -614,6 +653,7 @@ implementation
function ttypeconvnode.resulttype_cchar_to_pchar : tnode;
begin
result:=nil;
if is_pwidechar(resulttype.def) then
@ -628,6 +668,7 @@ implementation
function ttypeconvnode.resulttype_cstring_to_pchar : tnode;
begin
result:=nil;
if is_pwidechar(resulttype.def) then
@ -636,8 +677,10 @@ implementation
function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
var
hp : tnode;
begin
result:=nil;
if left.nodetype<>arrayconstructorn then
@ -652,6 +695,7 @@ implementation
function ttypeconvnode.resulttype_pchar_to_string : tnode;
begin
result := ccallnode.createinternres(
'fpc_pchar_to_'+lower(tstringdef(resulttype.def).stringtypname),
@ -711,9 +755,11 @@ implementation
function ttypeconvnode.det_resulttype:tnode;
var
hp : tnode;
aprocdef : tprocdef;
begin
result:=nil;
resulttype:=totype;
@ -1048,6 +1094,7 @@ implementation
function ttypeconvnode.first_cord_to_pointer : tnode;
begin
result:=nil;
internalerror(200104043);
@ -1055,6 +1102,7 @@ implementation
function ttypeconvnode.first_int_to_int : tnode;
begin
first_int_to_int:=nil;
if (left.location.loc<>LOC_REGISTER) and
@ -1068,6 +1116,7 @@ implementation
function ttypeconvnode.first_cstring_to_pchar : tnode;
begin
first_cstring_to_pchar:=nil;
registers32:=1;
@ -1076,6 +1125,7 @@ implementation
function ttypeconvnode.first_string_to_chararray : tnode;
begin
first_string_to_chararray:=nil;
registers32:=1;
@ -1084,6 +1134,7 @@ implementation
function ttypeconvnode.first_char_to_string : tnode;
begin
first_char_to_string:=nil;
location.loc:=LOC_MEM;
@ -1098,6 +1149,7 @@ implementation
function ttypeconvnode.first_array_to_pointer : tnode;
begin
first_array_to_pointer:=nil;
if registers32<1 then
@ -1107,6 +1159,7 @@ implementation
function ttypeconvnode.first_int_to_real : tnode;
begin
first_int_to_real:=nil;
{$ifdef m68k}
@ -1144,6 +1197,7 @@ implementation
function ttypeconvnode.first_pointer_to_array : tnode;
begin
first_pointer_to_array:=nil;
if registers32<1 then
@ -1153,6 +1207,7 @@ implementation
function ttypeconvnode.first_cchar_to_pchar : tnode;
begin
first_cchar_to_pchar:=nil;
internalerror(200104021);
@ -1160,6 +1215,7 @@ implementation
function ttypeconvnode.first_bool_to_int : tnode;
begin
first_bool_to_int:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
@ -1168,6 +1224,17 @@ implementation
(left.resulttype.def.size=resulttype.def.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit;
{ when converting to 64bit, first convert to a 32bit int and then }
{ convert to a 64bit int (only necessary for 32bit processors) (JM) }
if resulttype.def.size > sizeof(aword) then
begin
result := ctypeconvnode.create(left,u32bittype);
result.toggleflag(nf_explizit);
result := ctypeconvnode.create(result,resulttype);
left := nil;
firstpass(result);
exit;
end;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
@ -1175,6 +1242,7 @@ implementation
function ttypeconvnode.first_int_to_bool : tnode;
begin
first_int_to_bool:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
@ -1204,6 +1272,7 @@ implementation
function ttypeconvnode.first_char_to_char : tnode;
begin
first_char_to_char:=nil;
location.loc:=LOC_REGISTER;
@ -1225,12 +1294,29 @@ implementation
function ttypeconvnode.first_load_smallset : tnode;
var
srsym: ttypesym;
p: tcallparanode;
begin
first_load_smallset:=nil;
if not searchsystype('FPC_SMALL_SET',srsym) then
internalerror(200108313);
p := ccallparanode.create(left,nil);
{ reused }
left := nil;
{ convert parameter explicitely to fpc_small_set }
p.left := ctypeconvnode.create(p.left,srsym.restype);
p.left.toggleflag(nf_explizit);
{ create call, adjust resulttype }
result :=
ccallnode.createinternres('fpc_set_load_small',p,resulttype);
firstpass(result);
end;
function ttypeconvnode.first_ansistring_to_pchar : tnode;
begin
first_ansistring_to_pchar:=nil;
location.loc:=LOC_REGISTER;
@ -1254,6 +1340,7 @@ implementation
registers32:=1;
end;
function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
const
@ -1345,6 +1432,19 @@ implementation
end;
function ttypeconvnode.docompare(p: tnode) : boolean;
begin
docompare :=
inherited docompare(p) and
(convtype = ttypeconvnode(p).convtype);
end;
procedure ttypeconvnode.second_nothing;
begin
end;
{*****************************************************************************
TISNODE
*****************************************************************************}
@ -1391,16 +1491,16 @@ implementation
function tisnode.pass_1 : tnode;
var
paras: tcallparanode;
begin
result:=nil;
firstpass(left);
firstpass(right);
if codegenerror then
exit;
left_right_max;
location.loc:=LOC_FLAGS;
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createintern('fpc_do_is',paras);
firstpass(result);
end;
@ -1449,26 +1549,20 @@ implementation
function tasnode.pass_1 : tnode;
var
paras: tcallparanode;
begin
result:=nil;
firstpass(right);
firstpass(left);
if codegenerror then
exit;
left_right_max;
set_location(location,left.location);
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createinternres('fpc_do_as',paras,
resulttype);
firstpass(result);
end;
function ttypeconvnode.docompare(p: tnode) : boolean;
begin
docompare :=
inherited docompare(p) and
(convtype = ttypeconvnode(p).convtype);
end;
begin
ctypeconvnode:=ttypeconvnode;
casnode:=tasnode;
@ -1476,7 +1570,15 @@ begin
end.
{
$Log$
Revision 1.37 2001-09-03 13:27:42 jonas
Revision 1.38 2001-09-29 21:32:46 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
Revision 1.37 2001/09/03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change

14
rtl/inc/compproc.inc
View File

@ -99,7 +99,7 @@ Procedure fpc_widestr_Unique(Var S : WideString); compilerproc;
Function fpc_Val_Real_AnsiStr(Const S : AnsiString; Var Code : ValSInt): ValReal; compilerproc;
Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; Var Code : ValSInt): ValUInt; compilerproc;
Function fpc_Val_SInt_AnsiStr (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_qword_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword;compilerproc;
Function fpc_Val_qword_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword;compilerproc;
Function fpc_Val_int64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): Int64; compilerproc;
procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring); compilerproc;
Procedure fpc_AnsiStr_Cardinal(C : Cardinal;Len : Longint; Var S : AnsiString); compilerproc;
@ -165,7 +165,7 @@ function fpc_mul_qword(f1,f2 : qword;checkoverflow : longbool) : qword; compiler
function fpc_mul_int64(f1,f2 : int64;checkoverflow : longbool) : int64; compilerproc;
function fpc_do_is(aclass : tclass;aobject : tobject) : boolean; compilerproc;
procedure fpc_do_as(aclass : tclass;aobject : tobject); compilerproc;
function fpc_do_as(aclass : tclass;aobject : tobject): tobject; compilerproc;
procedure fpc_intf_decr_ref(var i: pointer); compilerproc;
procedure fpc_intf_incr_ref(const i: pointer); compilerproc;
procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc;
@ -247,7 +247,15 @@ Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;var Buf); compiler
{
$Log$
Revision 1.10 2001-09-05 15:22:09 jonas
Revision 1.11 2001-09-29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
Revision 1.10 2001/09/05 15:22:09 jonas
* made multiplying, dividing and mod'ing of int64 and qword processor
independent with compilerprocs (+ small optimizations by using shift/and
where possible)

15
rtl/inc/objpas.inc
View File

@ -27,10 +27,11 @@
{ the reverse order of the parameters make code generation easier }
procedure fpc_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
handleerror(219);
handleerrorframe(219,get_frame);
result := aobject;
end;
{$ifndef HASINTF}
@ -692,7 +693,15 @@
{
$Log$
Revision 1.16 2001-08-01 15:00:10 jonas
Revision 1.17 2001-09-29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10
* isnode and asnode are completely processor indepent now as well
* fpc_do_as now returns its class argument (necessary to be able to use it
properly with compilerproc)
Revision 1.16 2001/08/01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor