From 473c83961abe4e2fb52c8812e46bf19a41fe52cf Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 17 Jun 2020 21:50:25 +0200 Subject: src/ortho: add new_convert. --- src/ortho/debug/ortho_debug-disp.adb | 7 ++ src/ortho/debug/ortho_debug.adb | 24 +++++-- src/ortho/debug/ortho_debug.private.ads | 4 +- src/ortho/gcc/ortho-lang-49.c | 8 ++- src/ortho/gcc/ortho-lang-5.c | 8 ++- src/ortho/gcc/ortho-lang-6.c | 8 ++- src/ortho/gcc/ortho-lang-7.c | 8 ++- src/ortho/gcc/ortho-lang-8.c | 8 ++- src/ortho/gcc/ortho-lang-9.c | 8 ++- src/ortho/gcc/ortho_gcc.ads | 2 + src/ortho/gcc/ortho_gcc.private.ads | 1 + src/ortho/llvm-nodebug/ortho_llvm.adb | 9 ++- src/ortho/llvm35/ortho_llvm.adb | 9 ++- src/ortho/llvm35/ortho_llvm.ads | 1 + src/ortho/llvm4-nodebug/ortho_llvm.adb | 9 ++- src/ortho/llvm4-nodebug/ortho_llvm.ads | 1 + src/ortho/llvm6/llvm-cbindings.cpp | 8 ++- src/ortho/llvm6/ortho_llvm.private.ads | 1 + src/ortho/mcode/Makefile | 2 +- src/ortho/mcode/ortho_code-disps.adb | 2 +- src/ortho/mcode/ortho_code-exprs.adb | 13 +++- src/ortho/mcode/ortho_code-exprs.ads | 2 + src/ortho/mcode/ortho_code-x86-abi.adb | 2 +- src/ortho/mcode/ortho_code-x86-emits.adb | 114 +++++++++++++++++++------------ src/ortho/mcode/ortho_code-x86-insns.adb | 3 +- src/ortho/mcode/ortho_mcode.adb | 11 ++- src/ortho/mcode/ortho_mcode.ads | 3 +- src/ortho/oread/ortho_front.adb | 33 ++++++--- src/ortho/ortho_nodes.common.ads | 1 + 29 files changed, 228 insertions(+), 82 deletions(-) (limited to 'src/ortho') diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb index 465de8f7e..a7bbbe907 100644 --- a/src/ortho/debug/ortho_debug-disp.adb +++ b/src/ortho/debug/ortho_debug-disp.adb @@ -366,6 +366,8 @@ package body Ortho_Debug.Disp is return "function call"; when OE_Convert_Ov => return "convert_ov"; + when OE_Convert => + return "convert"; when OE_Address => return "address"; when OE_Unchecked_Address => @@ -754,6 +756,11 @@ package body Ortho_Debug.Disp is Disp_Lnode (E.Lvalue); Put (")"); when OE_Convert_Ov => + Disp_Tnode_Name (E.Rtype); + Put ("'conv# ("); + Disp_Enode (E.Conv, O_Tnode_Null); + Put (')'); + when OE_Convert => Disp_Tnode_Name (E.Rtype); Put ("'conv ("); Disp_Enode (E.Conv, O_Tnode_Null); diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb index 30a9478ef..a4c5bc578 100644 --- a/src/ortho/debug/ortho_debug.adb +++ b/src/ortho/debug/ortho_debug.adb @@ -1094,20 +1094,34 @@ package body Ortho_Debug is function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is - subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov); Res : O_Enode; begin Check_Ref (Val); if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then raise Type_Error; end if; - Res := new O_Enode_Convert'(Kind => OE_Convert_Ov, - Rtype => Rtype, - Ref => False, - Conv => Val); + Res := new O_Enode_Type'(Kind => OE_Convert_Ov, + Rtype => Rtype, + Ref => False, + Conv => Val); return Res; end New_Convert_Ov; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode + is + Res : O_Enode; + begin + Check_Ref (Val); + if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then + raise Type_Error; + end if; + Res := new O_Enode_Type'(Kind => OE_Convert, + Rtype => Rtype, + Ref => False, + Conv => Val); + return Res; + end New_Convert; + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads index 7586319ff..0bf91f106 100644 --- a/src/ortho/debug/ortho_debug.private.ads +++ b/src/ortho/debug/ortho_debug.private.ads @@ -227,6 +227,7 @@ private -- Misc. OE_Convert_Ov, + OE_Convert, OE_Address, OE_Unchecked_Address, OE_Alloca, @@ -261,7 +262,8 @@ private when OE_Address | OE_Unchecked_Address => Lvalue : O_Lnode; - when OE_Convert_Ov => + when OE_Convert_Ov + | OE_Convert => Conv : O_Enode; when OE_Function_Call => Func : O_Dnode; diff --git a/src/ortho/gcc/ortho-lang-49.c b/src/ortho/gcc/ortho-lang-49.c index 1c127fdb1..6be55dabe 100644 --- a/src/ortho/gcc/ortho-lang-49.c +++ b/src/ortho/gcc/ortho-lang-49.c @@ -946,7 +946,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -1008,6 +1008,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho-lang-5.c b/src/ortho/gcc/ortho-lang-5.c index 6f478b8d8..140a4a370 100644 --- a/src/ortho/gcc/ortho-lang-5.c +++ b/src/ortho/gcc/ortho-lang-5.c @@ -933,7 +933,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -995,6 +995,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho-lang-6.c b/src/ortho/gcc/ortho-lang-6.c index 2fd5be401..550006b66 100644 --- a/src/ortho/gcc/ortho-lang-6.c +++ b/src/ortho/gcc/ortho-lang-6.c @@ -933,7 +933,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -995,6 +995,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho-lang-7.c b/src/ortho/gcc/ortho-lang-7.c index f78bf0460..395edb617 100644 --- a/src/ortho/gcc/ortho-lang-7.c +++ b/src/ortho/gcc/ortho-lang-7.c @@ -945,7 +945,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -1007,6 +1007,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho-lang-8.c b/src/ortho/gcc/ortho-lang-8.c index 51b4a86f8..091565055 100644 --- a/src/ortho/gcc/ortho-lang-8.c +++ b/src/ortho/gcc/ortho-lang-8.c @@ -946,7 +946,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -1008,6 +1008,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho-lang-9.c b/src/ortho/gcc/ortho-lang-9.c index 80e793125..38bed3caa 100644 --- a/src/ortho/gcc/ortho-lang-9.c +++ b/src/ortho/gcc/ortho-lang-9.c @@ -946,7 +946,7 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) } tree -new_convert_ov (tree val, tree rtype) +new_convert (tree val, tree rtype) { tree val_type; enum tree_code val_code; @@ -1008,6 +1008,12 @@ new_convert_ov (tree val, tree rtype) return build1 (code, rtype, val); } +tree +new_convert_ov (tree val, tree rtype) +{ + return new_convert (val, rtype); +} + tree new_alloca (tree rtype, tree size) { diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads index d5cbf51c1..0c1ee81b6 100644 --- a/src/ortho/gcc/ortho_gcc.ads +++ b/src/ortho/gcc/ortho_gcc.ads @@ -313,6 +313,7 @@ package Ortho_Gcc is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. @@ -610,6 +611,7 @@ private pragma Import (C, New_Compare_Op); pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Convert); pragma Import (C, New_Alloca); pragma Import (C, New_Signed_Literal); diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads index 3bae8526e..f8f6cfb3c 100644 --- a/src/ortho/gcc/ortho_gcc.private.ads +++ b/src/ortho/gcc/ortho_gcc.private.ads @@ -165,6 +165,7 @@ private pragma Import (C, New_Compare_Op); pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Convert); pragma Import (C, New_Alloca); pragma Import (C, New_Signed_Literal); diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb index 56b22f092..054cd93ea 100644 --- a/src/ortho/llvm-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm-nodebug/ortho_llvm.adb @@ -1243,7 +1243,7 @@ package body Ortho_LLVM is -- New_Convert_Ov -- -------------------- - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is Res : ValueRef := Null_ValueRef; begin @@ -1334,11 +1334,16 @@ package body Ortho_LLVM is -- Set_Insn_Dbg (Res); return O_Enode'(LLVM => Res, Etype => Rtype); else - raise Program_Error with "New_Convert_Ov: not implemented for " + raise Program_Error with "New_Convert: not implemented for " & ON_Type_Kind'Image (Val.Etype.Kind) & " -> " & ON_Type_Kind'Image (Rtype.Kind); end if; + end New_Convert; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return New_Convert (Val, Rtype); end New_Convert_Ov; ----------------- diff --git a/src/ortho/llvm35/ortho_llvm.adb b/src/ortho/llvm35/ortho_llvm.adb index a4f4599e6..47509ee74 100644 --- a/src/ortho/llvm35/ortho_llvm.adb +++ b/src/ortho/llvm35/ortho_llvm.adb @@ -1586,7 +1586,7 @@ package body Ortho_LLVM is -- New_Convert_Ov -- -------------------- - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is Res : ValueRef := Null_ValueRef; begin @@ -1677,11 +1677,16 @@ package body Ortho_LLVM is -- Set_Insn_Dbg (Res); return O_Enode'(LLVM => Res, Etype => Rtype); else - raise Program_Error with "New_Convert_Ov: not implemented for " + raise Program_Error with "New_Convert: not implemented for " & ON_Type_Kind'Image (Val.Etype.Kind) & " -> " & ON_Type_Kind'Image (Rtype.Kind); end if; + end New_Convert; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return New_Convert (Val, Rtype); end New_Convert_Ov; ----------------- diff --git a/src/ortho/llvm35/ortho_llvm.ads b/src/ortho/llvm35/ortho_llvm.ads index 85f52b796..244b46e2e 100644 --- a/src/ortho/llvm35/ortho_llvm.ads +++ b/src/ortho/llvm35/ortho_llvm.ads @@ -336,6 +336,7 @@ package Ortho_LLVM is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb index e00e12aac..75d852428 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb @@ -1246,7 +1246,7 @@ package body Ortho_LLVM is -- New_Convert_Ov -- -------------------- - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is Res : ValueRef := Null_ValueRef; begin @@ -1337,11 +1337,16 @@ package body Ortho_LLVM is -- Set_Insn_Dbg (Res); return O_Enode'(LLVM => Res, Etype => Rtype); else - raise Program_Error with "New_Convert_Ov: not implemented for " + raise Program_Error with "New_Convert: not implemented for " & ON_Type_Kind'Image (Val.Etype.Kind) & " -> " & ON_Type_Kind'Image (Rtype.Kind); end if; + end New_Convert; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return New_Convert (Val, Rtype); end New_Convert_Ov; ----------------- diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads index df30a5d8d..029192790 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.ads +++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads @@ -329,6 +329,7 @@ package Ortho_LLVM is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. diff --git a/src/ortho/llvm6/llvm-cbindings.cpp b/src/ortho/llvm6/llvm-cbindings.cpp index 2b8c83e85..a6f78df62 100644 --- a/src/ortho/llvm6/llvm-cbindings.cpp +++ b/src/ortho/llvm6/llvm-cbindings.cpp @@ -1959,7 +1959,7 @@ new_dyadic_op (ONOpKind Kind, OEnode Left, OEnode Right) } extern "C" OEnode -new_convert_ov (OEnode Val, OTnode Rtype) +new_convert (OEnode Val, OTnode Rtype) { if (Unreach) { return {nullptr, Rtype}; @@ -2041,6 +2041,12 @@ new_convert_ov (OEnode Val, OTnode Rtype) return {Res, Rtype}; } +extern "C" OEnode +new_convert_ov (OEnode Val, OTnode Rtype) +{ + return new_convert(Val, Rtype); +} + extern "C" OEnode new_alloca (OTnode Rtype, OEnode Size) { diff --git a/src/ortho/llvm6/ortho_llvm.private.ads b/src/ortho/llvm6/ortho_llvm.private.ads index 6a4c80b98..173855912 100644 --- a/src/ortho/llvm6/ortho_llvm.private.ads +++ b/src/ortho/llvm6/ortho_llvm.private.ads @@ -326,6 +326,7 @@ private pragma Import (C, New_Compare_Op); pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Convert); pragma Import (C, New_Alloca); pragma Import (C, New_Signed_Literal); diff --git a/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile index 284d155a4..791d1f307 100644 --- a/src/ortho/mcode/Makefile +++ b/src/ortho/mcode/Makefile @@ -15,7 +15,7 @@ $(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c $(CC) -c $(CFLAGS) -o $@ $< -oread: force +oread: $(ortho_srcdir)/mcode/ortho_mcode.ads force $(GNATMAKE) -m -o $@ -g $(GNATFLAGS) -aI../oread ortho_code_main -aI.. -largs memsegs_c.o elfdump: force diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb index b0b9a353a..45507a52e 100644 --- a/src/ortho/mcode/ortho_code-disps.adb +++ b/src/ortho/mcode/ortho_code-disps.adb @@ -291,7 +291,7 @@ package body Ortho_Code.Disps is Put ("alloca ("); Disp_Expr (Get_Expr_Operand (Expr)); Put (")"); - when OE_Conv => + when OE_Conv_Ov => Disp_Type (Get_Conv_Type (Expr)); Put ("'conv ("); Disp_Expr (Get_Expr_Operand (Expr)); diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb index fd467e315..e580082c7 100644 --- a/src/ortho/mcode/ortho_code-exprs.adb +++ b/src/ortho/mcode/ortho_code-exprs.adb @@ -1034,9 +1034,18 @@ package body Ortho_Code.Exprs is Check_Ref (Val); end if; - return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype)); + return New_Enode (OE_Conv_Ov, Rtype, Val, O_Enode (Rtype)); end New_Convert_Ov; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + if Flag_Debug_Assert then + Check_Ref (Val); + end if; + + return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype)); + end New_Convert; + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is begin @@ -1194,7 +1203,7 @@ package body Ortho_Code.Exprs is raise Program_Error; end case; if N_Mode /= Mode and not Flag_Debug_Hli then - Res := New_Enode (OE_Conv, N_Mode, V_Type, Val, O_Enode (V_Type)); + Res := New_Enode (OE_Conv_Ov, N_Mode, V_Type, Val, O_Enode (V_Type)); else Res := Val; end if; diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads index 0bb5ec2bb..b1d95e45e 100644 --- a/src/ortho/mcode/ortho_code-exprs.ads +++ b/src/ortho/mcode/ortho_code-exprs.ads @@ -75,6 +75,7 @@ package Ortho_Code.Exprs is -- ARG1 is expression. -- ARG2: type OE_Conv_Ptr, + OE_Conv_Ov, OE_Conv, -- Typed expression. @@ -478,6 +479,7 @@ package Ortho_Code.Exprs is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb index ba9b437d9..a65a472ac 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.adb +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -550,7 +550,7 @@ package body Ortho_Code.X86.Abi is end case; --Disp_Decl_Name (Get_Call_Subprg (Stmt)); New_Line; - when OE_Conv => + when OE_Conv_Ov => Disp_Reg_Op_Name ("conv"); Disp_Irm_Code (Get_Expr_Operand (Stmt)); New_Line; diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb index a8696d19f..91db6b54d 100644 --- a/src/ortho/mcode/ortho_code-x86-emits.adb +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -1715,7 +1715,7 @@ package body Ortho_Code.X86.Emits is end Emit_Move_Xmm; -- Convert U32 to xx. - procedure Gen_Conv_U32 (Stmt : O_Enode) + procedure Gen_Conv_U32 (Stmt : O_Enode; Ov : Boolean) is Op : constant O_Enode := Get_Expr_Operand (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Op); @@ -1727,8 +1727,10 @@ package body Ortho_Code.X86.Emits is if Reg_Op /= Reg_Res then Emit_Load (Reg_Res, Op, Sz_32); end if; - Emit_Tst (Reg_Res, Sz_32); - Gen_Ov_Check (R_Sge); + if Ov then + Emit_Tst (Reg_Res, Sz_32); + Gen_Ov_Check (R_Sge); + end if; when Mode_I64 => if Flags.M64 then Emit_Move (Op, Sz_32, Reg_Res); @@ -1744,21 +1746,23 @@ package body Ortho_Code.X86.Emits is if Reg_Op /= Reg_Res then Emit_Load (Reg_Res, Op, Sz_32); end if; - -- cmpl VAL, 0xff - Start_Insn; - Init_Modrm_Expr (Op, Sz_32); - Gen_8 (Opc_Grp1v_Rm_Imm32); - Gen_Mod_Rm_Opc (Opc2_Grp1_Cmp); - Gen_32 (16#00_00_00_Ff#); - End_Insn; - Gen_Ov_Check (R_Ule); + if Ov then + -- cmpl VAL, 0xff + Start_Insn; + Init_Modrm_Expr (Op, Sz_32); + Gen_8 (Opc_Grp1v_Rm_Imm32); + Gen_Mod_Rm_Opc (Opc2_Grp1_Cmp); + Gen_32 (16#00_00_00_Ff#); + End_Insn; + Gen_Ov_Check (R_Ule); + end if; when others => Error_Emit ("gen_conv_u32", Stmt); end case; end Gen_Conv_U32; -- Convert I32 to xxx - procedure Gen_Conv_I32 (Stmt : O_Enode) + procedure Gen_Conv_I32 (Stmt : O_Enode; Ov : Boolean) is Op : constant O_Enode := Get_Expr_Operand (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Op); @@ -1778,20 +1782,26 @@ package body Ortho_Code.X86.Emits is if Reg_Op /= Reg_Res then Emit_Load (Reg_Res, Op, Sz_32); end if; - Emit_Tst (Reg_Res, Sz_32); - Gen_Ov_Check (R_Sge); + if Ov then + Emit_Tst (Reg_Res, Sz_32); + Gen_Ov_Check (R_Sge); + end if; when Mode_B2 => if Reg_Op /= Reg_Res then Emit_Load (Reg_Res, Op, Sz_32); end if; - Gen_Cmp_Imm (Reg_Res, 1, Sz_32); - Gen_Ov_Check (R_Ule); + if Ov then + Gen_Cmp_Imm (Reg_Res, 1, Sz_32); + Gen_Ov_Check (R_Ule); + end if; when Mode_U8 => if Reg_Op /= Reg_Res then Emit_Load (Reg_Res, Op, Sz_32); end if; - Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32); - Gen_Ov_Check (R_Ule); + if Ov then + Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32); + Gen_Ov_Check (R_Ule); + end if; when Mode_F64 => if Reg_Res in Regs_Xmm then -- cvtsi2sd @@ -1878,7 +1888,7 @@ package body Ortho_Code.X86.Emits is end Gen_Conv_B2; -- Convert I64 to xxx - procedure Gen_Conv_I64 (Stmt : O_Enode) + procedure Gen_Conv_I64 (Stmt : O_Enode; Ov : Boolean) is Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Op : constant O_Enode := Get_Expr_Operand (Stmt); @@ -1890,12 +1900,16 @@ package body Ortho_Code.X86.Emits is if Flags.M64 then -- movsxd src, dst Gen_Movsxd (Reg_Op, Reg_Res); - -- cmp src,dst - Start_Insn; - Init_Modrm_Reg (Reg_Op, Sz_64, Reg_Res, Sz_64); - Gen_8 (Opc_Cmpl_Rm_Reg); - Gen_Mod_Rm_Reg; - End_Insn; + if Ov then + -- cmp src,dst + Start_Insn; + Init_Modrm_Reg (Reg_Op, Sz_64, Reg_Res, Sz_64); + Gen_8 (Opc_Cmpl_Rm_Reg); + Gen_Mod_Rm_Reg; + End_Insn; + -- Overflow if extended value is different from initial one. + Gen_Ov_Check (R_Eq); + end if; else pragma Assert (Reg_Op = R_Edx_Eax); pragma Assert (Reg_Res = R_Ax); @@ -1906,14 +1920,16 @@ package body Ortho_Code.X86.Emits is End_Insn; -- Sign extend eax. Gen_Cdq (Sz_32); - -- cmp reg_helper, dx - Start_Insn; - Gen_8 (Opc_Cmpl_Rm_Reg); - Gen_8 (2#11_010_000# + To_Reg32 (Reg_Helper)); - End_Insn; + if Ov then + -- cmp reg_helper, dx + Start_Insn; + Gen_8 (Opc_Cmpl_Rm_Reg); + Gen_8 (2#11_010_000# + To_Reg32 (Reg_Helper)); + End_Insn; + -- Overflow if extended value is different from initial one. + Gen_Ov_Check (R_Eq); + end if; end if; - -- Overflow if extended value is different from initial value. - Gen_Ov_Check (R_Eq); when Mode_U8 | Mode_B2 => declare @@ -1927,15 +1943,20 @@ package body Ortho_Code.X86.Emits is if Flags.M64 then Emit_Load (Reg_Res, Op, Sz_64); - Start_Insn; - Init_Modrm_Reg (Reg_Res, Sz_64); - Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Ubound); - End_Insn; + if Ov then + Start_Insn; + Init_Modrm_Reg (Reg_Res, Sz_64); + Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Ubound); + End_Insn; + Gen_Ov_Check (R_Ule); + end if; else pragma Assert (Reg_Op in Regs_Pair); - -- Check MSB = 0 - Emit_Tst (Reg_Op, Sz_32h); - Gen_Ov_Check (R_Eq); + if Ov then + -- Check MSB = 0 + Emit_Tst (Reg_Op, Sz_32h); + Gen_Ov_Check (R_Eq); + end if; -- Check LSB <= 255 (U8) or LSB <= 1 (B2) if Reg_Op /= Reg_Res then -- Move reg_op -> reg_res @@ -1946,10 +1967,12 @@ package body Ortho_Code.X86.Emits is Gen_Mod_Rm_Reg; End_Insn; end if; - Gen_Cmp_Imm (Reg_Res, Ubound, Sz_32); + if Ov then + Gen_Cmp_Imm (Reg_Res, Ubound, Sz_32); + Gen_Ov_Check (R_Ule); + end if; end if; end; - Gen_Ov_Check (R_Ule); when Mode_F64 => if Flags.M64 then -- cvtsi2sd @@ -2586,19 +2609,20 @@ package body Ortho_Code.X86.Emits is Error_Emit ("emit_insn: indir", Stmt); end case; - when OE_Conv => + when OE_Conv_Ov + | OE_Conv => -- Call Gen_Conv_FROM case Get_Expr_Mode (Get_Expr_Operand (Stmt)) is when Mode_U32 => - Gen_Conv_U32 (Stmt); + Gen_Conv_U32 (Stmt, Kind = OE_Conv_Ov); when Mode_I32 => - Gen_Conv_I32 (Stmt); + Gen_Conv_I32 (Stmt, Kind = OE_Conv_Ov); when Mode_U8 => Gen_Conv_U8 (Stmt); when Mode_B2 => Gen_Conv_B2 (Stmt); when Mode_I64 => - Gen_Conv_I64 (Stmt); + Gen_Conv_I64 (Stmt, Kind = OE_Conv_Ov); when Mode_F32 | Mode_F64 => Gen_Conv_Fp (Stmt); diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb index 013a201e7..a7327ac2b 100644 --- a/src/ortho/mcode/ortho_code-x86-insns.adb +++ b/src/ortho/mcode/ortho_code-x86-insns.adb @@ -2056,7 +2056,8 @@ package body Ortho_Code.X86.Insns is Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum)); Link_Stmt (Stmt); return Stmt; - when OE_Conv => + when OE_Conv_Ov + | OE_Conv => Left := Get_Expr_Operand (Stmt); declare -- Operand mode diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb index 95f442c89..cd7131d73 100644 --- a/src/ortho/mcode/ortho_mcode.adb +++ b/src/ortho/mcode/ortho_mcode.adb @@ -284,12 +284,12 @@ package body Ortho_Mcode is end Finish_Record_Aggr; procedure Start_Array_Aggr - (List : out O_Array_Aggr_List; Arr_Type : O_Tnode; Len : Unsigned_32) + (List : out O_Array_Aggr_List; Atype : O_Tnode; Len : Unsigned_32) is begin Ortho_Code.Consts.Start_Array_Aggr (Ortho_Code.Consts.O_Array_Aggr_List (List), - Ortho_Code.O_Tnode (Arr_Type), + Ortho_Code.O_Tnode (Atype), Len); end Start_Array_Aggr; @@ -450,6 +450,13 @@ package body Ortho_Mcode is Ortho_Code.O_Tnode (Rtype))); end New_Convert_Ov; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Convert (Ortho_Code.O_Enode (Val), + Ortho_Code.O_Tnode (Rtype))); + end New_Convert; + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is begin diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads index 554b1ee19..ef24372e3 100644 --- a/src/ortho/mcode/ortho_mcode.ads +++ b/src/ortho/mcode/ortho_mcode.ads @@ -167,7 +167,7 @@ package Ortho_Mcode is Res : out O_Cnode); procedure Start_Array_Aggr - (List : out O_Array_Aggr_List; Arr_Type : O_Tnode; Len : Unsigned_32); + (List : out O_Array_Aggr_List; Atype : O_Tnode; Len : Unsigned_32); procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; Value : O_Cnode); procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; @@ -320,6 +320,7 @@ package Ortho_Mcode is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb index 9d2da4192..fecca6876 100644 --- a/src/ortho/oread/ortho_front.adb +++ b/src/ortho/oread/ortho_front.adb @@ -1689,15 +1689,30 @@ package body Ortho_Front is elsif Tok = Tok_Ident then -- Attribute. if Token_Sym = Id_Conv then - Next_Expect (Tok_Left_Paren); - Next_Token; - Parse_Expression (null, Res, Res_Type); - -- Discard Res_Type. - Expect (Tok_Right_Paren); - Next_Token; - Res_Type := Name.Decl_Dtype; - Res := New_Convert_Ov (Res, Res_Type.Type_Onode); - -- Fall-through. + declare + Ov : Boolean; + begin + Next_Token; + if Tok = Tok_Sharp then + Ov := True; + Next_Token; + else + Ov := False; + end if; + Expect (Tok_Left_Paren); + Next_Token; + Parse_Expression (null, Res, Res_Type); + -- Discard Res_Type. + Expect (Tok_Right_Paren); + Next_Token; + Res_Type := Name.Decl_Dtype; + if Ov then + Res := New_Convert_Ov (Res, Res_Type.Type_Onode); + else + Res := New_Convert (Res, Res_Type.Type_Onode); + end if; + -- Fall-through. + end; elsif Token_Sym = Id_Address or Token_Sym = Id_Unchecked_Address or Token_Sym = Id_Subprg_Addr diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads index e2dd1521b..e9c43aa46 100644 --- a/src/ortho/ortho_nodes.common.ads +++ b/src/ortho/ortho_nodes.common.ads @@ -307,6 +307,7 @@ package ORTHO_NODES is -- Allowed conversions are: -- FIXME: to write. function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- cgit v1.2.3