From 29263eb3430f8ad2066b849ae6baff691bbe2a11 Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Sun, 21 Oct 2012 17:56:33 +0000
Subject: [PATCH] + full support for overflow checking on the JVM target
(note: significantly increases code size, because not natively supported
by the JVM)
git-svn-id: trunk@22808 -
---
compiler/jvm/hlcgcpu.pas | 123 ++++++++++++++++++++++++++++++++++++++-
compiler/jvm/njvmmat.pas | 22 ++++++-
2 files changed, 143 insertions(+), 2 deletions(-)
diff --git a/compiler/jvm/hlcgcpu.pas b/compiler/jvm/hlcgcpu.pas
index 65c4962ba3..629ef845d9 100644
--- a/compiler/jvm/hlcgcpu.pas
+++ b/compiler/jvm/hlcgcpu.pas
@@ -69,6 +69,8 @@ uses
procedure a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override;
procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override;
procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override;
+ procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
+ procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
procedure a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel); override;
procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; reg: tregister; l: tasmlabel); override;
@@ -97,6 +99,9 @@ uses
procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
+ procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override;
+ procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation); override;
+
procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override;
procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override;
procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override;
@@ -170,7 +175,6 @@ uses
slots used for parameters and the provided resultdef }
procedure g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef);
-
property maxevalstackheight: longint read fmaxevalstackheight;
procedure gen_initialize_fields_code(list:TAsmList);
@@ -1164,6 +1168,105 @@ implementation
a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2);
end;
+ procedure thlcgjvm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister; setflags: boolean; var ovloc: tlocation);
+ var
+ tmpreg: tregister;
+ begin
+ if not setflags then
+ begin
+ inherited;
+ exit;
+ end;
+ tmpreg:=getintregister(list,size);
+ a_load_const_reg(list,size,a,tmpreg);
+ a_op_reg_reg_reg_checkoverflow(list,op,size,tmpreg,src,dst,true,ovloc);
+ end;
+
+ procedure thlcgjvm.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation);
+ var
+ orgsrc1, orgsrc2: tregister;
+ docheck: boolean;
+ lab: tasmlabel;
+ begin
+ if not setflags then
+ begin
+ inherited;
+ exit;
+ end;
+ { anything else cannot overflow }
+ docheck:=size.size in [4,8];
+ if docheck then
+ begin
+ orgsrc1:=src1;
+ orgsrc2:=src2;
+ if src1=dst then
+ begin
+ orgsrc1:=getintregister(list,size);
+ a_load_reg_reg(list,size,size,src1,orgsrc1);
+ end;
+ if src2=dst then
+ begin
+ orgsrc2:=getintregister(list,size);
+ a_load_reg_reg(list,size,size,src2,orgsrc2);
+ end;
+ end;
+ a_op_reg_reg_reg(list,op,size,src1,src2,dst);
+ if docheck then
+ begin
+ { * signed overflow for addition iff
+ - src1 and src2 are negative and result is positive (excep in case of
+ subtraction, then sign of src1 has to be inverted)
+ - src1 and src2 are positive and result is negative
+ -> Simplified boolean equivalent (in terms of sign bits):
+ not(src1 xor src2) and (src1 xor dst)
+
+ for subtraction, multiplication: invert src1 sign bit
+ for division: handle separately (div by zero, low(inttype) div -1),
+ not supported by this code
+
+ * unsigned overflow iff carry out, aka dst < src1 or dst < src2
+ }
+ location_reset(ovloc,LOC_REGISTER,OS_S32);
+ { not pasbool8, because then we'd still have to convert the integer to
+ a boolean via branches for Dalvik}
+ ovloc.register:=getintregister(list,s32inttype);
+ if not ((size.typ=pointerdef) or
+ ((size.typ=orddef) and
+ (torddef(size).ordtype in [u64bit,u16bit,u32bit,u8bit,uchar,
+ pasbool8,pasbool16,pasbool32,pasbool64]))) then
+ begin
+ a_load_reg_stack(list,size,src1);
+ if op in [OP_SUB,OP_IMUL] then
+ a_op_stack(list,OP_NOT,size,false);
+ a_op_reg_stack(list,OP_XOR,size,src2);
+ a_op_stack(list,OP_NOT,size,false);
+ a_load_reg_stack(list,size,src1);
+ a_op_reg_stack(list,OP_XOR,size,dst);
+ a_op_stack(list,OP_AND,size,false);
+ a_op_const_stack(list,OP_SHR,size,(size.size*8)-1);
+ if size.size=8 then
+ begin
+ list.concat(taicpu.op_none(a_l2i));
+ decstack(list,1);
+ end;
+ end
+ else
+ begin
+ a_load_const_stack(list,s32inttype,0,R_INTREGISTER);
+ current_asmdata.getjumplabel(lab);
+ { can be optimized by removing duplicate xor'ing to convert dst from
+ signed to unsigned quadrant }
+ a_cmp_reg_reg_label(list,size,OC_B,dst,src1,lab);
+ a_cmp_reg_reg_label(list,size,OC_B,dst,src2,lab);
+ a_op_const_stack(list,OP_XOR,s32inttype,1);
+ a_label(list,lab);
+ end;
+ a_load_stack_reg(list,s32inttype,ovloc.register);
+ end
+ else
+ ovloc.loc:=LOC_VOID;
+ end;
+
procedure thlcgjvm.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel);
begin
if ref.base<>NR_EVAL_STACK_BASE then
@@ -1619,6 +1722,24 @@ implementation
// do nothing
end;
+ procedure thlcgjvm.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef);
+ begin
+ { not possible, need the original operands }
+ internalerror(2012102101);
+ end;
+
+ procedure thlcgjvm.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation);
+ var
+ hl : tasmlabel;
+ begin
+ if not(cs_check_overflow in current_settings.localswitches) then
+ exit;
+ current_asmdata.getjumplabel(hl);
+ a_cmp_const_loc_label(list,s32inttype,OC_EQ,0,ovloc,hl);
+ g_call_system_proc(list,'fpc_overflow',nil);
+ a_label(list,hl);
+ end;
+
procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
var
tmploc: tlocation;
diff --git a/compiler/jvm/njvmmat.pas b/compiler/jvm/njvmmat.pas
index ca1de0acdf..faeb4c3b9f 100644
--- a/compiler/jvm/njvmmat.pas
+++ b/compiler/jvm/njvmmat.pas
@@ -78,6 +78,9 @@ implementation
procedure tjvmmoddivnode.pass_generate_code;
var
+ tmpreg: tregister;
+ lab: tasmlabel;
+ ovloc: tlocation;
op: topcg;
isu32int: boolean;
begin
@@ -89,7 +92,6 @@ implementation
if nodetype=divn then
begin
- { TODO: overflow checking in case of high(longint) or high(int64) div -1 }
thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
if is_signed(resultdef) then
op:=OP_IDIV
@@ -141,6 +143,24 @@ implementation
thlcgjvm(hlcg).resize_stack_int_val(current_asmdata.CurrAsmList,s64inttype,u32inttype,false);
end;
thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+ if (cs_check_overflow in current_settings.localswitches) and
+ is_signed(resultdef) then
+ begin
+ { the JVM raises an exception for integer div-iby-zero -> only
+ overflow in case left is low(inttype) and right is -1 ->
+ check by adding high(inttype) to left and and'ing with right
+ -> result is -1 only in case above conditions are fulfilled)
+ }
+ tmpreg:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+ hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,true);
+ hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_ADD,resultdef,torddef(resultdef).high,right.location.register,tmpreg);
+ hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,true);
+ hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_AND,resultdef,left.location.register,tmpreg);
+ current_asmdata.getjumplabel(lab);
+ hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,resultdef,OC_NE,-1,tmpreg,lab);
+ hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_overflow',nil);
+ hlcg.a_label(current_asmdata.CurrAsmList,lab);
+ end;
end;