diff options
Diffstat (limited to 'ortho')
129 files changed, 0 insertions, 42281 deletions
diff --git a/ortho/Makefile.inc b/ortho/Makefile.inc deleted file mode 100644 index 597aaeff1..000000000 --- a/ortho/Makefile.inc +++ /dev/null @@ -1,38 +0,0 @@ -# Common -*- Makefile -*- for ortho implementations. -# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -# -# GHDL 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, or (at your option) any later -# version. -# -# GHDL 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 GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. - -# Variable to be defined: -# SED: sed the stream editor -# ORTHO_BASENAME - -$(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).ads: \ - $(ortho_srcdir)/ortho_nodes.common.ads \ - $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads - $(RM) -f $@ - echo "-- DO NOT MODIFY - this file was generated from:" > $@ - echo "-- ortho_nodes.common.ads and $(ORTHO_BASENAME).private.ads" \ - >> $@ - echo "--" >> $@ - $(SED) -e '/^private/,$$d' \ - < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@ - echo "-- Start of common part" >> $@ - $(SED) -e '1,/^package/d' -e '/^private/,$$d' < $< >> $@ - echo "-- End of common part" >> $@ - $(SED) -n -e '/^private/,$$p' \ - < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@ - chmod a-w $@ diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile deleted file mode 100644 index 0c15111ef..000000000 --- a/ortho/debug/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# -*- Makefile -*- for the ortho-code back-end -# Copyright (C) 2005 Tristan Gingold -# -# GHDL 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, or (at your option) any later -# version. -# -# GHDL 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 GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. -BE=debug -ortho_srcdir=.. - -orthobe_srcdir=$(ortho_srcdir)/$(BE) - -GNATMAKE=gnatmake -CC=gcc -CFLAGS=-g -ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwl -gnatf -gnaty3befhkmr -gnatwu -GNATMAKE_FLAGS=-m $(ALL_GNAT_FLAGS) $(GNAT_FLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI. -#LARGS=-largs -static -SED=sed - -all: $(ortho_exec) - - -$(ortho_exec): force $(ortho_srcdir)/$(BE)/ortho_debug.ads - gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS) - -clean: - $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main - $(RM) ortho_debug.ads - -force: - -ORTHO_BASENAME=ortho_debug - -# Automatically build ortho_debug.ads from ortho_node.common.ads and -# ortho_debug.private.ads -include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb deleted file mode 100644 index 2725668bb..000000000 --- a/ortho/debug/ortho_debug-disp.adb +++ /dev/null @@ -1,1064 +0,0 @@ --- Display the code from the ortho debug tree. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Debug.Disp is - Disp_All_Types : constant Boolean := False; - - package Formated_Output is - use Interfaces.C_Streams; - - type Disp_Context is limited private; - - procedure Init_Context (File : FILEs); - - -- Save the current context, and create a new one. - procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context); - - -- Restore a previous context, saved by Push_Context. - procedure Pop_Context (Prev_Ctx : Disp_Context); - - procedure Put (Str : String); - - procedure Put_Line (Str : String); - - -- Add a tabulation. - -- Every new line will start at this tabulation. - procedure Add_Tab; - - -- Removed a tabulation. - -- The next new line will start at the previous tabulation. - procedure Rem_Tab; - - -- Flush the current output. - procedure Flush; - - -- Return TRUE if the ident level is nul. - function Is_Top return Boolean; - - procedure Put_Tab; - - procedure New_Line; - - procedure Put (C : Character); - - procedure Put_Trim (Str : String); - - procedure Set_Mark; - - -- Flush to disk. Only for debugging in case of crash. - procedure Flush_File; - pragma Unreferenced (Flush_File); - private - type Disp_Context is record - -- File where the info are written to. - File : FILEs; - -- Line number of the line to be written. - Lineno : Natural; - -- Buffer for the current line. - Line : String (1 .. 256); - -- Number of characters currently in the line. - Line_Len : Natural; - - -- Current tabulation. - Tab : Natural; - -- Tabulation to be used for the next line. - Next_Tab : Natural; - - Mark : Natural; - end record; - end Formated_Output; - - package body Formated_Output is - -- The current context. - Ctx : Disp_Context; - - procedure Init_Context (File : FILEs) is - begin - Ctx.File := File; - Ctx.Lineno := 1; - Ctx.Line_Len := 0; - Ctx.Tab := 0; - Ctx.Next_Tab := 0; - Ctx.Mark := 0; - end Init_Context; - - procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context) - is - begin - Prev_Ctx := Ctx; - Init_Context (File); - end Push_Context; - - -- Restore a previous context, saved by Push_Context. - procedure Pop_Context (Prev_Ctx : Disp_Context) is - begin - Flush; - Ctx := Prev_Ctx; - end Pop_Context; - - procedure Flush - is - Status : size_t; - Res : int; - pragma Unreferenced (Status, Res); - begin - if Ctx.Line_Len > 0 then - Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1, - Ctx.File); - Res := fputc (Character'Pos (ASCII.Lf), Ctx.File); - Ctx.Line_Len := 0; - end if; - Ctx.Mark := 0; - end Flush; - - function Is_Top return Boolean is - begin - return Ctx.Tab = 0; - end Is_Top; - - procedure Put_Tab - is - Tab : Natural := Ctx.Next_Tab; - Max_Tab : constant Natural := 40; - begin - if Tab > Max_Tab then - -- Limit indentation length, to limit line length. - Tab := Max_Tab; - end if; - - Ctx.Line (1 .. Tab) := (others => ' '); - Ctx.Line_Len := Tab; - Ctx.Next_Tab := Ctx.Tab + 2; - end Put_Tab; - - procedure Put (Str : String) is - Saved : String (1 .. 80); - Len : Natural; - begin - if Ctx.Line_Len + Str'Length >= 80 then - if Ctx.Mark > 0 then - Len := Ctx.Line_Len - Ctx.Mark + 1; - Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len); - Ctx.Line_Len := Ctx.Mark - 1; - Flush; - Put_Tab; - Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) := - Saved (1 .. Len); - Ctx.Line_Len := Ctx.Line_Len + Len; - else - Flush; - end if; - end if; - if Ctx.Line_Len = 0 then - Put_Tab; - end if; - Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str; - Ctx.Line_Len := Ctx.Line_Len + Str'Length; - end Put; - - procedure Put_Trim (Str : String) is - begin - for I in Str'Range loop - if Str (I) /= ' ' then - Put (Str (I .. Str'Last)); - return; - end if; - end loop; - end Put_Trim; - - procedure Put_Line (Str : String) is - begin - Put (Str); - Flush; - Ctx.Next_Tab := Ctx.Tab; - end Put_Line; - - procedure New_Line - is - Status : int; - pragma Unreferenced (Status); - begin - if Ctx.Line_Len > 0 then - Flush; - else - Status := fputc (Character'Pos (ASCII.LF), Ctx.File); - end if; - Ctx.Next_Tab := Ctx.Tab; - end New_Line; - - procedure Put (C : Character) - is - S : constant String (1 .. 1) := (1 => C); - begin - Put (S); - end Put; - - -- Add a tabulation. - -- Every new line will start at this tabulation. - procedure Add_Tab is - begin - Ctx.Tab := Ctx.Tab + 2; - Ctx.Next_Tab := Ctx.Tab; - end Add_Tab; - - -- Removed a tabulation. - -- The next new line will start at the previous tabulation. - procedure Rem_Tab is - begin - Ctx.Tab := Ctx.Tab - 2; - Ctx.Next_Tab := Ctx.Tab; - end Rem_Tab; - - procedure Set_Mark is - begin - Ctx.Mark := Ctx.Line_Len; - end Set_Mark; - - procedure Flush_File is - Status : int; - pragma Unreferenced (Status); - begin - Flush; - Status := fflush (Ctx.File); - end Flush_File; - end Formated_Output; - - use Formated_Output; - - procedure Init_Context (File : Interfaces.C_Streams.FILEs) is - begin - Formated_Output.Init_Context (File); - end Init_Context; - - procedure Disp_Enode (E : O_Enode; Etype : O_Tnode); - procedure Disp_Lnode (Node : O_Lnode); - procedure Disp_Snode (First, Last : O_Snode); - procedure Disp_Dnode (Decl : O_Dnode); - procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); - - procedure Disp_Ident (Id : O_Ident) is - begin - Put (Get_String (Id)); - end Disp_Ident; - - procedure Disp_Tnode_Name (Atype : O_Tnode) is - begin - Disp_Tnode (Atype, False); - end Disp_Tnode_Name; - - procedure Disp_Dnode_Name (Decl : O_Dnode) is - begin - Disp_Ident (Decl.Name); - end Disp_Dnode_Name; - - procedure Disp_Loop_Name (Stmt : O_Snode) is - begin - Put ("loop" & Natural'Image (Stmt.Loop_Level)); - end Disp_Loop_Name; - - function Get_Enode_Name (Kind : OE_Kind) return String - is - begin - case Kind is --- when OE_Boolean_Lit => --- return "boolean_lit"; --- when OE_Unsigned_Lit => --- return "unsigned_lit"; --- when OE_Signed_Lit => --- return "signed lit"; --- when OE_Float_Lit => --- return "float lit"; --- when OE_Null_Lit => --- return "null lit"; --- when OE_Enum_Lit => --- return "enum lit"; - --- when OE_Sizeof_Lit => --- return "sizeof lit"; --- when OE_Offsetof_Lit => --- return "offsetof lit"; --- when OE_Aggregate => --- return "aggregate"; --- when OE_Aggr_Element => --- return "aggr_element"; --- when OE_Union_Aggr => --- return "union aggr"; - - when OE_Lit => - return "lit"; - when OE_Add_Ov => - return "+#"; - when OE_Sub_Ov => - return "-#"; - when OE_Mul_Ov => - return "*#"; - when OE_Div_Ov => - return "/#"; - when OE_Rem_Ov => - return "rem#"; - when OE_Mod_Ov => - return "mod#"; - when OE_Exp_Ov => - return "**#"; - - when OE_And => - return "and"; - when OE_Or => - return "or"; - when OE_Xor => - return "xor"; - when OE_And_Then => - return "and_then"; - when OE_Or_Else => - return "or_else"; - - when OE_Not => - return "not"; - when OE_Neg_Ov => - return "-"; - when OE_Abs_Ov => - return "abs"; - - when OE_Eq => - return "="; - when OE_Neq => - return "/="; - when OE_Le => - return "<="; - when OE_Lt => - return "<"; - when OE_Ge => - return ">="; - when OE_Gt => - return ">"; - - when OE_Function_Call => - return "function call"; - when OE_Convert_Ov => - return "convert_ov"; - when OE_Address => - return "address"; - when OE_Unchecked_Address => - return "unchecked_address"; --- when OE_Subprogram_Address => --- return "subprg_address"; - when OE_Alloca => - return "alloca"; - when OE_Value => - return "value"; - when OE_Nil => - return "??"; - end case; - end Get_Enode_Name; - - function Get_Lnode_Name (Kind : OL_Kind) return String - is - begin - case Kind is - when OL_Obj => - return "obj"; - when OL_Indexed_Element => - return "indexed_element"; - when OL_Slice => - return "slice"; - when OL_Selected_Element => - return "selected_element"; - when OL_Access_Element => - return "access_element"; --- when OL_Param_Ref => --- return "param_ref"; --- when OL_Var_Ref => --- return "var_ref"; --- when OL_Const_Ref => --- return "const_ref"; - end case; - end Get_Lnode_Name; - - pragma Unreferenced (Get_Lnode_Name); - - procedure Disp_Enode_Name (Kind : OE_Kind) is - begin - Put (Get_Enode_Name (Kind)); - end Disp_Enode_Name; - - procedure Disp_Assoc_List (Head : O_Anode) - is - El : O_Anode; - begin - El := Head; - Put ("("); - if El /= null then - loop - Disp_Enode (El.Actual, El.Formal.Dtype); - El := El.Next; - exit when El = null; - Put (", "); - end loop; - end if; - Put (")"); - end Disp_Assoc_List; - - function Image (Lit : Integer) return String - is - S : constant String := Integer'Image (Lit); - begin - if S (1) = ' ' then - return S (2 .. S'Length); - else - return S; - end if; - end Image; - - -- Disp STR as a literal for scalar type LIT_TYPE. - procedure Disp_Lit (Lit_Type : O_Tnode; Known : Boolean; Str : String) is - begin - if Known and not Disp_All_Types then - Put_Trim (Str); - else - Disp_Tnode_Name (Lit_Type); - Put ("'["); - Put_Trim (Str); - Put (']'); - end if; - end Disp_Lit; - - -- Display C. If CTYPE is set, this is the known type of C. - procedure Disp_Cnode (C : O_Cnode; Ctype : O_Tnode) - is - Known : constant Boolean := Ctype /= O_Tnode_Null; - begin - -- Sanity check. - if Known then - if Ctype /= C.Ctype then - raise Program_Error; - end if; - end if; - - case C.Kind is - when OC_Unsigned_Lit => - if False and then (C.U_Val >= Character'Pos(' ') - and C.U_Val <= Character'Pos ('~')) - then - Put ('''); - Put (Character'Val (C.U_Val)); - Put ('''); - else - Disp_Lit (C.Ctype, Known, Unsigned_64'Image (C.U_Val)); - end if; - when OC_Signed_Lit => - Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val)); - when OC_Float_Lit => - Disp_Lit (C.Ctype, Known, IEEE_Float_64'Image (C.F_Val)); - when OC_Boolean_Lit => - -- Always disp the type of boolean literals. - Disp_Lit (C.Ctype, False, Get_String (C.B_Id)); - when OC_Null_Lit => - -- Always disp the type of null literals. - Disp_Lit (C.Ctype, False, "null"); - when OC_Enum_Lit => - -- Always disp the type of enum literals. - Disp_Lit (C.Ctype, False, Get_String (C.E_Name)); - when OC_Sizeof_Lit => - Disp_Tnode_Name (C.Ctype); - Put ("'sizeof ("); - Disp_Tnode_Name (C.S_Type); - Put (")"); - when OC_Alignof_Lit => - Disp_Tnode_Name (C.Ctype); - Put ("'alignof ("); - Disp_Tnode_Name (C.S_Type); - Put (")"); - when OC_Offsetof_Lit => - Disp_Tnode_Name (C.Ctype); - Put ("'offsetof ("); - Disp_Tnode_Name (C.Off_Field.Parent); - Put ("."); - Disp_Ident (C.Off_Field.Ident); - Put (")"); - when OC_Aggregate => - declare - El : O_Cnode; - El_Type : O_Tnode; - Field : O_Fnode; - begin - Put ('{'); - El := C.Aggr_Els; - case C.Ctype.Kind is - when ON_Record_Type => - Field := C.Ctype.Elements; - El_Type := Field.Ftype; - when ON_Array_Sub_Type => - Field := null; - El_Type := C.Ctype.Base_Type.El_Type; - when others => - raise Program_Error; - end case; - if El /= null then - loop - Set_Mark; - if Field /= null then - if Disp_All_Types then - Put ('.'); - Disp_Ident (Field.Ident); - Put (" = "); - end if; - El_Type := Field.Ftype; - Field := Field.Next; - end if; - Disp_Cnode (El.Aggr_Value, El_Type); - El := El.Aggr_Next; - exit when El = null; - Put (", "); - end loop; - end if; - Put ('}'); - end; - when OC_Aggr_Element => - Disp_Cnode (C.Aggr_Value, Ctype); - when OC_Union_Aggr => - Put ('{'); - Put ('.'); - Disp_Ident (C.Uaggr_Field.Ident); - Put (" = "); - Disp_Cnode (C.Uaggr_Value, C.Uaggr_Field.Ftype); - Put ('}'); - when OC_Address => - Disp_Tnode_Name (C.Ctype); - Put ("'address ("); - Disp_Dnode_Name (C.Decl); - Put (")"); - when OC_Unchecked_Address => - Disp_Tnode_Name (C.Ctype); - Put ("'unchecked_address ("); - Disp_Dnode_Name (C.Decl); - Put (")"); - when OC_Subprogram_Address => - Disp_Tnode_Name (C.Ctype); - Put ("'subprg_addr ("); - Disp_Dnode_Name (C.Decl); - Put (")"); - end case; - end Disp_Cnode; - - -- Disp E whose expected type is ETYPE (may not be set). - procedure Disp_Enode (E : O_Enode; Etype : O_Tnode) - is - begin - case E.Kind is - when OE_Lit => - Disp_Cnode (E.Lit, Etype); - when OE_Dyadic_Expr_Kind => - Put ("("); - Disp_Enode (E.Left, O_Tnode_Null); - Put (' '); - Disp_Enode_Name (E.Kind); - Put (' '); - Disp_Enode (E.Right, E.Left.Rtype); - Put (')'); - when OE_Compare_Expr_Kind => - Disp_Tnode_Name (E.Rtype); - Put ("'("); - Disp_Enode (E.Left, O_Tnode_Null); - Put (' '); - Disp_Enode_Name (E.Kind); - Put (' '); - Disp_Enode (E.Right, E.Left.Rtype); - Put (')'); - when OE_Monadic_Expr_Kind => - Disp_Enode_Name (E.Kind); - if E.Kind /= OE_Neg_Ov then - Put (' '); - end if; - Disp_Enode (E.Operand, Etype); - when OE_Address => - Disp_Tnode_Name (E.Rtype); - Put ("'address ("); - Disp_Lnode (E.Lvalue); - Put (")"); - when OE_Unchecked_Address => - Disp_Tnode_Name (E.Rtype); - Put ("'unchecked_address ("); - 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_Function_Call => - Disp_Dnode_Name (E.Func); - Put (' '); - Disp_Assoc_List (E.Assoc); - when OE_Alloca => - Disp_Tnode_Name (E.Rtype); - Put ("'alloca ("); - Disp_Enode (E.A_Size, O_Tnode_Null); - Put (')'); - when OE_Value => - Disp_Lnode (E.Value); - when OE_Nil => - null; - end case; - end Disp_Enode; - - procedure Disp_Lnode (Node : O_Lnode) is - begin - case Node.Kind is - when OL_Obj => - Disp_Dnode_Name (Node.Obj); - when OL_Access_Element => - Disp_Enode (Node.Acc_Base, O_Tnode_Null); - Put (".all"); - when OL_Indexed_Element => - Disp_Lnode (Node.Array_Base); - Put ('['); - Disp_Enode (Node.Index, O_Tnode_Null); - Put (']'); - when OL_Slice => - Disp_Lnode (Node.Slice_Base); - Put ('['); - Disp_Enode (Node.Slice_Index, O_Tnode_Null); - Put ("...]"); - when OL_Selected_Element => - Disp_Lnode (Node.Rec_Base); - Put ('.'); - Disp_Ident (Node.Rec_El.Ident); --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Disp_Dnode_Name (Node.Decl); - end case; - end Disp_Lnode; - - procedure Disp_Fnodes (First : O_Fnode) - is - El : O_Fnode; - begin - Add_Tab; - El := First; - while El /= null loop - Disp_Ident (El.Ident); - Put (": "); - Disp_Tnode (El.Ftype, False); - Put_Line ("; "); - El := El.Next; - end loop; - Rem_Tab; - end Disp_Fnodes; - - procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is - begin - if not Full and Atype.Decl /= null then - Disp_Ident (Atype.Decl.Name); - return; - end if; - case Atype.Kind is - when ON_Boolean_Type => - Put ("boolean {"); - Disp_Ident (Atype.False_N.B_Id); - Put (", "); - Disp_Ident (Atype.True_N.B_Id); - Put ("}"); - when ON_Unsigned_Type => - Put ("unsigned ("); - Put_Trim (Natural'Image (Atype.Int_Size)); - Put (")"); - when ON_Signed_Type => - Put ("signed ("); - Put_Trim (Natural'Image (Atype.Int_Size)); - Put (")"); - when ON_Float_Type => - Put ("float"); - when ON_Enum_Type => - declare - El : O_Cnode; - begin - Put ("enum {"); - El := Atype.Literals; - while El /= O_Cnode_Null loop - Set_Mark; - Disp_Ident (El.E_Name); - Put (" = "); - Put (Image (El.E_Val)); - El := El.E_Next; - exit when El = O_Cnode_Null; - Put (", "); - end loop; - Put ("}"); - end; - when ON_Array_Type => - Put ("array ["); - Disp_Tnode (Atype.Index_Type, False); - Put ("] of "); - Disp_Tnode (Atype.El_Type, False); - when ON_Access_Type => - Put ("access "); - if Atype.D_Type /= O_Tnode_Null then - Disp_Tnode (Atype.D_Type, False); - end if; - when ON_Record_Type => - Put_Line ("record "); - Disp_Fnodes (Atype.Elements); - Put ("end record"); - when ON_Union_Type => - Put_Line ("union "); - Disp_Fnodes (Atype.Elements); - Put ("end union"); - when ON_Array_Sub_Type => - Put ("subarray "); - Disp_Tnode_Name (Atype.Base_Type); - Put ("["); - Disp_Cnode (Atype.Length, Atype.Base_Type.Index_Type); - Put ("]"); - end case; - end Disp_Tnode; - - procedure Disp_Storage_Name (Storage : O_Storage) is - begin - case Storage is - when O_Storage_External => - Put ("external"); - when O_Storage_Public => - Put ("public"); - when O_Storage_Private => - Put ("private"); - when O_Storage_Local => - Put ("local"); - end case; - end Disp_Storage_Name; - - procedure Disp_Decls (Decls : O_Dnode) - is - El : O_Dnode; - begin - El := Decls; - while El /= null loop - Disp_Dnode (El); - El := El.Next; - if Is_Top then - -- NOTE: some declaration does not disp anything, so there may be - -- double new line. - New_Line; - end if; - end loop; - end Disp_Decls; - - procedure Disp_Function_Decl (Decl : O_Dnode) is - begin - Disp_Storage_Name (Decl.Storage); - Put (" "); - if Decl.Dtype = null then - Put ("procedure "); - else - Put ("function "); - end if; - Disp_Ident (Decl.Name); - Put_Line (" ("); - Add_Tab; - declare - El : O_Dnode; - begin - El := Decl.Interfaces; - if El /= null then - loop - Disp_Dnode (El); - El := El.Next; - exit when El = null; - Put_Line (";"); - end loop; - end if; - Put (")"); - end; - if Decl.Dtype /= null then - New_Line; - Put ("return "); - Disp_Tnode (Decl.Dtype, False); - end if; - Rem_Tab; - end Disp_Function_Decl; - - procedure Disp_Dnode (Decl : O_Dnode) is - begin - case Decl.Kind is - when ON_Type_Decl => - Put ("type "); - Disp_Ident (Decl.Name); - Put (" is "); - if not Decl.Dtype.Uncomplete then - Disp_Tnode (Decl.Dtype, True); - else - case Decl.Dtype.Kind is - when ON_Record_Type => - Put ("record"); - when ON_Access_Type => - Put ("access"); - when others => - raise Program_Error; - end case; - end if; - Put_Line (";"); - when ON_Completed_Type_Decl => - Put ("type "); - Disp_Ident (Decl.Name); - Put (" is "); - Disp_Tnode (Decl.Dtype, True); - Put_Line (";"); - when ON_Const_Decl => - Disp_Storage_Name (Decl.Storage); - Put (" "); - Put ("constant "); - Disp_Ident (Decl.Name); - Put (" : "); - Disp_Tnode_Name (Decl.Dtype); - Put_Line (";"); - when ON_Const_Value => - Put ("constant "); - Disp_Ident (Decl.Name); - Put (" := "); - Disp_Cnode (Decl.Value, Decl.Dtype); - Put_Line (";"); - when ON_Var_Decl => - Disp_Storage_Name (Decl.Storage); - Put (" "); - Put ("var "); - Disp_Ident (Decl.Name); - Put (" : "); - Disp_Tnode_Name (Decl.Dtype); - Put_Line (";"); - when ON_Function_Decl => - if Decl.Next = null or Decl.Next /= Decl.Func_Body then - -- This is a forward/external declaration. - Disp_Function_Decl (Decl); - Put_Line (";"); - end if; - when ON_Function_Body => - Disp_Function_Decl (Decl.Func_Decl); - New_Line; - Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt); - when ON_Interface_Decl => - Disp_Ident (Decl.Name); - Put (": "); - Disp_Tnode (Decl.Dtype, False); - when ON_Debug_Line_Decl => - Put_Line ("--#" & Natural'Image (Decl.Line)); - when ON_Debug_Comment_Decl => - Put_Line ("-- " & Decl.Comment.all); - when ON_Debug_Filename_Decl => - Put_Line ("--F " & Decl.Filename.all); - end case; - end Disp_Dnode; - - procedure Disp_Snode (First : O_Snode; Last : O_Snode) is - Stmt : O_Snode; - begin - Stmt := First; - loop - --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then - -- Put_Indent (Tab - 1); - --else - -- Put_Indent (Tab); - --end if; - case Stmt.Kind is - when ON_Declare_Stmt => - Put_Line ("declare"); - Add_Tab; - Disp_Decls (Stmt.Decls); - Rem_Tab; - Put_Line ("begin"); - Add_Tab; - if Stmt.Stmts /= null then - Disp_Snode (Stmt.Stmts, null); - end if; - Rem_Tab; - Put_Line ("end;"); - when ON_Assign_Stmt => - Disp_Lnode (Stmt.Target); - Put (" := "); - Disp_Enode (Stmt.Value, Stmt.Target.Rtype); - Put_Line (";"); - when ON_Return_Stmt => - Put ("return "); - if Stmt.Ret_Val /= null then - Disp_Enode (Stmt.Ret_Val, O_Tnode_Null); - end if; - Put_Line (";"); - when ON_If_Stmt => - Add_Tab; - Disp_Snode (Stmt.Next, Stmt.If_Last); - Stmt := Stmt.If_Last; - Rem_Tab; - Put_Line ("end if;"); - when ON_Elsif_Stmt => - Rem_Tab; - if Stmt.Cond = null then - Put_Line ("else"); - else - if First = Stmt then - Put ("if "); - else - Put ("elsif "); - end if; - Disp_Enode (Stmt.Cond, O_Tnode_Null); - Put_Line (" then"); - end if; - Add_Tab; - when ON_Loop_Stmt => - Disp_Loop_Name (Stmt); - Put_Line (":"); - Add_Tab; - Disp_Snode (Stmt.Next, Stmt.Loop_Last); - Stmt := Stmt.Loop_Last; - Rem_Tab; - Put_Line ("end loop;"); - when ON_Exit_Stmt => - Put ("exit "); - Disp_Loop_Name (Stmt.Loop_Id); - Put_Line (";"); - when ON_Next_Stmt => - Put ("next "); - Disp_Loop_Name (Stmt.Loop_Id); - Put_Line (";"); - when ON_Case_Stmt => - Put ("case "); - Disp_Enode (Stmt.Selector, O_Tnode_Null); - Put_Line (" is"); - Add_Tab; - Disp_Snode (Stmt.Next, Stmt.Case_Last); - Stmt := Stmt.Case_Last; - Rem_Tab; - Put_Line ("end case;"); - when ON_When_Stmt => - declare - Choice: O_Choice; - Choice_Type : constant O_Tnode := - Stmt.Branch_Parent.Selector.Rtype; - begin - Rem_Tab; - Choice := Stmt.Choice_List; - Put ("when "); - loop - case Choice.Kind is - when ON_Choice_Expr => - Disp_Cnode (Choice.Expr, Choice_Type); - when ON_Choice_Range => - Disp_Cnode (Choice.Low, Choice_Type); - Put (" ... "); - Disp_Cnode (Choice.High, Choice_Type); - when ON_Choice_Default => - Put ("default"); - end case; - Choice := Choice.Next; - exit when Choice = null; - Put_Line (","); - Put (" "); - end loop; - Put_Line (" =>"); - Add_Tab; - end; - when ON_Call_Stmt => - Disp_Dnode_Name (Stmt.Proc); - Put (' '); - Disp_Assoc_List (Stmt.Assoc); - Put_Line (";"); - when ON_Debug_Line_Stmt => - Put_Line ("--#" & Natural'Image (Stmt.Line)); - when ON_Debug_Comment_Stmt => - Put_Line ("-- " & Stmt.Comment.all); - end case; - exit when Stmt = Last; - Stmt := Stmt.Next; - exit when Stmt = null and Last = null; - end loop; - end Disp_Snode; - - procedure Disp_Ortho (Decls : O_Snode) is - begin - Disp_Decls (Decls.Decls); - Flush; - end Disp_Ortho; - - procedure Disp_Tnode_Decl (N : O_Tnode) is - begin - Disp_Ident (N.Decl.Name); - Put (" : "); - Disp_Tnode (N, True); - end Disp_Tnode_Decl; - - procedure Debug_Tnode (N : O_Tnode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Tnode_Decl (N); - Pop_Context (Ctx); - end Debug_Tnode; - - procedure Debug_Enode (N : O_Enode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Enode (N, O_Tnode_Null); - Put (" : "); - Disp_Tnode_Decl (N.Rtype); - Pop_Context (Ctx); - end Debug_Enode; - - procedure Debug_Fnode (N : O_Fnode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Ident (N.Ident); - Put (": "); - Disp_Tnode (N.Ftype, False); - Pop_Context (Ctx); - end Debug_Fnode; - - procedure Debug_Dnode (N : O_Dnode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Dnode (N); - Pop_Context (Ctx); - end Debug_Dnode; - - procedure Debug_Lnode (N : O_Lnode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Lnode (N); - Put (" : "); - Disp_Tnode_Decl (N.Rtype); - Pop_Context (Ctx); - end Debug_Lnode; - - procedure Debug_Snode (N : O_Snode) - is - Ctx : Disp_Context; - begin - Push_Context (Interfaces.C_Streams.stdout, Ctx); - Disp_Snode (N, null); - Pop_Context (Ctx); - end Debug_Snode; - - pragma Unreferenced (Debug_Tnode, Debug_Enode, Debug_Fnode, - Debug_Dnode, Debug_Lnode, Debug_Snode); -end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-disp.ads b/ortho/debug/ortho_debug-disp.ads deleted file mode 100644 index c365a3530..000000000 --- a/ortho/debug/ortho_debug-disp.ads +++ /dev/null @@ -1,29 +0,0 @@ --- Display the ortho codes from a tree. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces.C_Streams; - -package Ortho_Debug.Disp is - -- Initialize the current context. - -- Must be called before any use of the DISP_* subprograms. - procedure Init_Context (File : Interfaces.C_Streams.FILEs); - - -- Disp nodes in a pseudo-language. - procedure Disp_Ortho (Decls : O_Snode); - -private -end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-main.adb b/ortho/debug/ortho_debug-main.adb deleted file mode 100644 index b470deaab..000000000 --- a/ortho/debug/ortho_debug-main.adb +++ /dev/null @@ -1,151 +0,0 @@ --- Main procedure of ortho debug back-end. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Unchecked_Deallocation; -with Ada.Text_IO; use Ada.Text_IO; -with Ortho_Debug; use Ortho_Debug; -with Ortho_Debug_Front; use Ortho_Debug_Front; -with Ortho_Debug.Disp; -with System; use System; -with Interfaces.C_Streams; use Interfaces.C_Streams; - -procedure Ortho_Debug.Main is - -- Do not output the ortho code. - Flag_Silent : Boolean := False; - - -- Force output, even in case of crash. - Flag_Force : Boolean := False; - - I : Natural; - Argc : Natural; - Arg : String_Acc; - Opt : String_Acc; - Res : Natural; - File : String_Acc; - Output : FILEs; - R : Boolean; - - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); -begin - Ortho_Debug_Front.Init; - Output := NULL_Stream; - - Set_Exit_Status (Failure); - - -- Decode options. - Argc := Argument_Count; - I := 1; - loop - exit when I > Argc; - exit when Argument (I) (1) /= '-'; - if Argument (I) = "--silent" or else Argument (I) = "-quiet" then - Flag_Silent := True; - I := I + 1; - elsif Argument (I) = "--force" then - Flag_Force := True; - I := I + 1; - elsif Argument (I)'Length >= 2 and then Argument (I)(2) = 'g' then - -- Skip -g[XXX] flags. - I := I + 1; - elsif Argument (I) = "-o" and then I + 1 <= Argc then - -- TODO: write the output to the file ? - if Output /= NULL_Stream then - Put_Line (Command_Name & ": only one output allowed"); - return; - end if; - declare - Name : String := Argument (I + 1) & ASCII.Nul; - Mode : String := 'w' & ASCII.Nul; - begin - Output := fopen (Name'Address, Mode'Address); - if Output = NULL_Stream then - Put_Line (Command_Name & ": cannot open " & Argument (I + 1)); - return; - end if; - end; - I := I + 2; - else - Opt := new String'(Argument (I)); - if I < Argc then - Arg := new String'(Argument (I + 1)); - else - Arg := null; - end if; - Res := Ortho_Debug_Front.Decode_Option (Opt, Arg); - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Arg); - if Res = 0 then - Put_Line (Argument (I) & ": unknown option"); - return; - else - I := I + Res; - end if; - end if; - end loop; - - -- Initialize tree. - begin - Ortho_Debug.Init; - - if I <= Argc then - R := True; - for J in I .. Argc loop - File := new String'(Argument (J)); - R := R and Ortho_Debug_Front.Parse (File); - Unchecked_Deallocation (File); - end loop; - else - R := Ortho_Debug_Front.Parse (null); - end if; - Ortho_Debug.Finish; - exception - when others => - if not Flag_Force then - raise; - else - R := False; - end if; - end; - - -- Write down the result. - if (R and (Output /= NULL_Stream or not Flag_Silent)) - or Flag_Force - then - if Output = NULL_Stream then - Ortho_Debug.Disp.Init_Context (stdout); - else - Ortho_Debug.Disp.Init_Context (Output); - end if; - Ortho_Debug.Disp.Disp_Ortho (Ortho_Debug.Top); - if Output /= NULL_Stream then - declare - Status : int; - pragma Unreferenced (Status); - begin - Status := fclose (Output); - end; - end if; - end if; - - if R then - Set_Exit_Status (Success); - else - Set_Exit_Status (Failure); - end if; -end Ortho_Debug.Main; diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb deleted file mode 100644 index 8285a6473..000000000 --- a/ortho/debug/ortho_debug.adb +++ /dev/null @@ -1,1931 +0,0 @@ --- Ortho debug back-end. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Unchecked_Deallocation; - -package body Ortho_Debug is - -- If True, disable some checks so that the output can be generated. - Disable_Checks : constant Boolean := False; - - type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind; - ON_Op_To_OE : constant ON_Op_To_OE_Type := - ( - ON_Nil => OE_Nil, - - -- Dyadic operations. - ON_Add_Ov => OE_Add_Ov, - ON_Sub_Ov => OE_Sub_Ov, - ON_Mul_Ov => OE_Mul_Ov, - ON_Div_Ov => OE_Div_Ov, - ON_Rem_Ov => OE_Rem_Ov, - ON_Mod_Ov => OE_Mod_Ov, - - -- Binary operations. - ON_And => OE_And, - ON_Or => OE_Or, - ON_Xor => OE_Xor, - - -- Monadic operations. - ON_Not => OE_Not, - ON_Neg_Ov => OE_Neg_Ov, - ON_Abs_Ov => OE_Abs_Ov, - - -- Comparaisons - ON_Eq => OE_Eq, - ON_Neq => OE_Neq, - ON_Le => OE_Le, - ON_Lt => OE_Lt, - ON_Ge => OE_Ge, - ON_Gt => OE_Gt - ); - - type Decl_Scope_Type is record - -- Declarations are chained. - Parent : O_Snode; - Last_Decl : O_Dnode; - Last_Stmt : O_Snode; - - -- If this scope corresponds to a function, PREV_FUNCTION contains - -- the previous function. - Prev_Function : O_Dnode; - - -- Declaration scopes are chained. - Prev : Decl_Scope_Acc; - end record; - - type Stmt_Kind is - (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case); - type Stmt_Scope_Type (Kind : Stmt_Kind); - type Stmt_Scope_Acc is access Stmt_Scope_Type; - type Stmt_Scope_Type (Kind : Stmt_Kind) is record - -- Statement which created this scope. - Parent : O_Snode; - -- Previous (parent) scope. - Prev : Stmt_Scope_Acc; - case Kind is - when Stmt_Function => - Prev_Function : Stmt_Scope_Acc; - -- Declaration for the function. - Decl : O_Dnode; - when Stmt_Declare => - null; - when Stmt_If => - Last_Elsif : O_Snode; - when Stmt_Loop => - null; - when Stmt_Case => - Last_Branch : O_Snode; - Last_Choice : O_Choice; - Case_Type : O_Tnode; - end case; - end record; - subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function); - subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare); - subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If); - subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop); - subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case); - - Current_Stmt_Scope : Stmt_Scope_Acc := null; - Current_Function : Stmt_Scope_Acc := null; - Current_Decl_Scope : Decl_Scope_Acc := null; - Current_Loop_Level : Natural := 0; - - procedure Push_Decl_Scope (Parent : O_Snode) - is - Res : Decl_Scope_Acc; - begin - Res := new Decl_Scope_Type'(Parent => Parent, - Last_Decl => null, - Last_Stmt => null, - Prev_Function => null, - Prev => Current_Decl_Scope); - Parent.Alive := True; - Current_Decl_Scope := Res; - end Push_Decl_Scope; - - procedure Pop_Decl_Scope - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Object => Decl_Scope_Type, Name => Decl_Scope_Acc); - Old : Decl_Scope_Acc; - begin - Old := Current_Decl_Scope; - Old.Parent.Alive := False; - Current_Decl_Scope := Old.Prev; - Unchecked_Deallocation (Old); - end Pop_Decl_Scope; - - procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is - begin - if Current_Decl_Scope = null then - -- Not yet initialized, or after compilation. - raise Program_Error; - end if; - - -- Note: this requires an hashed ident table. - -- Use ortho_ident_hash. - if False and then Check_Dup - and then not Is_Nul (El.Name) - then - -- Check the name is not already defined. - declare - E : O_Dnode; - begin - E := Current_Decl_Scope.Parent.Decls; - while E /= O_Dnode_Null loop - if Is_Equal (E.Name, El.Name) then - raise Syntax_Error; - end if; - E := E.Next; - end loop; - end; - end if; - - if Current_Decl_Scope.Last_Decl = null then - if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then - Current_Decl_Scope.Parent.Decls := El; - else - raise Type_Error; - end if; - else - Current_Decl_Scope.Last_Decl.Next := El; - end if; - El.Next := null; - Current_Decl_Scope.Last_Decl := El; - end Add_Decl; - - procedure Add_Stmt (Stmt : O_Snode) - is - begin - if Current_Decl_Scope = null or Current_Function = null then - -- You are adding a statement at the global level, ie not inside - -- a function. - raise Syntax_Error; - end if; - - Stmt.Next := null; - if Current_Decl_Scope.Last_Stmt = null then - if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then - Current_Decl_Scope.Parent.Stmts := Stmt; - else - raise Syntax_Error; - end if; - else - Current_Decl_Scope.Last_Stmt.Next := Stmt; - end if; - Current_Decl_Scope.Last_Stmt := Stmt; - end Add_Stmt; - - procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc) - is - begin - if Scope.Prev /= Current_Stmt_Scope then - -- SCOPE was badly initialized. - raise Program_Error; - end if; - Current_Stmt_Scope := Scope; - end Push_Stmt_Scope; - - procedure Pop_Stmt_Scope (Kind : Stmt_Kind) - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc); - Old : Stmt_Scope_Acc; - begin - Old := Current_Stmt_Scope; - if Old.Kind /= Kind then - raise Syntax_Error; - end if; - --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt; - Current_Stmt_Scope := Old.Prev; - Unchecked_Deallocation (Old); - end Pop_Stmt_Scope; - - -- Check declaration DECL is reachable, ie its scope is in the current - -- stack of scopes. - procedure Check_Scope (Decl : O_Dnode) - is - Res : Boolean; - begin - case Decl.Kind is - when ON_Interface_Decl => - Res := Decl.Func_Scope.Alive; - when others => - Res := Decl.Scope.Alive; - end case; - if not Res then - raise Syntax_Error; - end if; - end Check_Scope; - - -- Raise SYNTAX_ERROR if OBJ is not at a constant address. --- procedure Check_Const_Address (Obj : O_Lnode) is --- begin --- case Obj.Kind is --- when OL_Const_Ref --- | OL_Var_Ref => --- case Obj.Decl.Storage is --- when O_Storage_External --- | O_Storage_Public --- | O_Storage_Private => --- null; --- when O_Storage_Local => --- raise Syntax_Error; --- end case; --- when others => --- -- FIXME: constant indexed element, selected element maybe --- -- of const address. --- raise Syntax_Error; --- end case; --- end Check_Const_Address; - - procedure Check_Type (T1, T2 : O_Tnode) is - begin - if T1 = T2 then - return; - end if; - if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type - and then T1.Base_Type = T2.Base_Type - and then T1.Length.all = T2.Length.all - then - return; - end if; - raise Type_Error; - end Check_Type; - - procedure Check_Ref (N : O_Enode) is - begin - if N.Ref then - -- Already referenced. - raise Syntax_Error; - end if; - N.Ref := True; - end Check_Ref; - - procedure Check_Ref (N : O_Lnode) is - begin - if N.Ref then - raise Syntax_Error; - end if; - N.Ref := True; - end Check_Ref; - - procedure Check_Complete_Type (T : O_Tnode) is - begin - if not T.Complete then - -- Uncomplete type cannot be used here (since its size is required, - -- for example). - raise Syntax_Error; - end if; - end Check_Complete_Type; - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - K : constant OE_Kind := ON_Op_To_OE (Kind); - Res : O_Enode; - begin - Check_Type (Left.Rtype, Right.Rtype); - Check_Ref (Left); - Check_Ref (Right); - Res := new O_Enode_Type (K); - Res.Rtype := Left.Rtype; - Res.Ref := False; - Res.Left := Left; - Res.Right := Right; - return Res; - end New_Dyadic_Op; - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode - is - Res : O_Enode; - begin - Check_Ref (Operand); - Res := new O_Enode_Type (ON_Op_To_OE (Kind)); - Res.Ref := False; - Res.Operand := Operand; - Res.Rtype := Operand.Rtype; - return Res; - end New_Monadic_Op; - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode - is - Res : O_Enode; - begin - if Ntype.Kind /= ON_Boolean_Type then - raise Type_Error; - end if; - if Left.Rtype /= Right.Rtype then - raise Type_Error; - end if; - Check_Ref (Left); - Check_Ref (Right); - Res := new O_Enode_Type (ON_Op_To_OE (Kind)); - Res.Ref := False; - Res.Left := Left; - Res.Right := Right; - Res.Rtype := Ntype; - return Res; - end New_Compare_Op; - - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - is - subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit); - begin - if Ltype.Kind = ON_Signed_Type then - return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit, - Ctype => Ltype, - Ref => False, - S_Val => Value); - else - raise Type_Error; - end if; - end New_Signed_Literal; - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode - is - subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit); - begin - if Ltype.Kind = ON_Unsigned_Type then - return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit, - Ctype => Ltype, - Ref => False, - U_Val => Value); - else - raise Type_Error; - end if; - end New_Unsigned_Literal; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode - is - subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit); - begin - if Ltype.Kind = ON_Float_Type then - return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit, - Ctype => Ltype, - Ref => False, - F_Val => Value); - else - raise Type_Error; - end if; - end New_Float_Literal; - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit); - begin - if Ltype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit, - Ctype => Ltype, - Ref => False); - end New_Null_Access; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit); - begin - if Rtype.Kind /= ON_Unsigned_Type - and then Rtype.Kind /= ON_Access_Type - then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - if Atype.Kind = ON_Array_Type then - raise Type_Error; - end if; - return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit, - Ctype => Rtype, - Ref => False, - S_Type => Atype); - end New_Sizeof; - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Alignof_Type is O_Cnode_Type (OC_Alignof_Lit); - begin - if Rtype.Kind /= ON_Unsigned_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - return new O_Cnode_Alignof_Type'(Kind => OC_Alignof_Lit, - Ctype => Rtype, - Ref => False, - S_Type => Atype); - end New_Alignof; - - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit); - begin - if Rtype.Kind /= ON_Unsigned_Type - and then Rtype.Kind /= ON_Access_Type - then - raise Type_Error; - end if; - if Field.Parent /= Atype then - raise Type_Error; - end if; - return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit, - Ctype => Rtype, - Ref => False, - Off_Field => Field); - end New_Offsetof; - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca); - Res : O_Enode; - begin - if Rtype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - if Size.Rtype.Kind /= ON_Unsigned_Type then - raise Type_Error; - end if; - Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca, - Rtype => Rtype, - Ref => False, - A_Size => Size); - return Res; - end New_Alloca; - - procedure Check_Constrained_Type (Atype : O_Tnode) is - begin - case Atype.Kind is - when ON_Array_Type => - raise Type_Error; - when ON_Unsigned_Type - | ON_Signed_Type - | ON_Boolean_Type - | ON_Record_Type - | ON_Union_Type - | ON_Access_Type - | ON_Float_Type - | ON_Array_Sub_Type - | ON_Enum_Type => - null; - end case; - end Check_Constrained_Type; - - procedure New_Completed_Type_Decl (Atype : O_Tnode) - is - N : O_Dnode; - begin - if Atype.Decl = null then - -- The uncompleted type must have been declared. - raise Type_Error; - end if; - N := new O_Dnode_Type (ON_Completed_Type_Decl); - N.Name := Atype.Decl.Name; - N.Dtype := Atype; - Add_Decl (N, False); - end New_Completed_Type_Decl; - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) - is - subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type); - begin - Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type, - Decl => O_Dnode_Null, - Uncomplete => True, - Complete => False, - Elements => O_Fnode_Null); - end New_Uncomplete_Record_Type; - - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) is - begin - if not Res.Uncomplete then - -- RES record type is not an uncomplete record type. - raise Syntax_Error; - end if; - if Res.Elements /= O_Fnode_Null then - -- RES record type already has elements... - raise Syntax_Error; - end if; - Elements.Res := Res; - Elements.Last := null; - end Start_Uncomplete_Record_Type; - - procedure Start_Record_Type (Elements : out O_Element_List) - is - subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type); - begin - Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => False, - Elements => O_Fnode_Null); - Elements.Last := null; - end Start_Record_Type; - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - is - begin - Check_Complete_Type (Etype); - Check_Constrained_Type (Etype); - El := new O_Fnode_Type'(Parent => Elements.Res, - Next => null, - Ident => Ident, - Ftype => Etype, - Offset => 0); - -- Append EL. - if Elements.Last = null then - Elements.Res.Elements := El; - else - Elements.Last.Next := El; - end if; - Elements.Last := El; - end New_Record_Field; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - -- Align the structure. - Res := Elements.Res; - if Res.Uncomplete then - New_Completed_Type_Decl (Res); - end if; - Res.Complete := True; - end Finish_Record_Type; - - procedure Start_Union_Type (Elements : out O_Element_List) - is - subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type); - begin - Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => False, - Elements => O_Fnode_Null); - Elements.Last := null; - end Start_Union_Type; - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - is - begin - New_Record_Field (Elements, El, Ident, Etype); - end New_Union_Field; - - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Res := Elements.Res; - Res.Complete := True; - end Finish_Union_Type; - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode - is - subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type); - Res : O_Tnode; - begin - if Dtype /= O_Tnode_Null - and then Dtype.Kind = ON_Array_Sub_Type - then - -- Access to sub array are not allowed, use access to array. - raise Type_Error; - end if; - Res := new O_Tnode_Access'(Kind => ON_Access_Type, - Decl => O_Dnode_Null, - Uncomplete => Dtype = O_Tnode_Null, - Complete => True, - D_Type => Dtype); - return Res; - end New_Access_Type; - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) - is - begin - if Dtype.Kind = ON_Array_Sub_Type then - -- Access to sub array are not allowed, use access to array. - raise Type_Error; - end if; - if Atype.D_Type /= O_Tnode_Null - or Atype.Uncomplete = False - then - -- Type already completed. - raise Syntax_Error; - end if; - Atype.D_Type := Dtype; - New_Completed_Type_Decl (Atype); - end Finish_Access_Type; - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode - is - subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type); - begin - Check_Constrained_Type (El_Type); - Check_Complete_Type (El_Type); - return new O_Tnode_Array'(Kind => ON_Array_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - El_Type => El_Type, - Index_Type => Index_Type); - end New_Array_Type; - - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode - is - subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type); - begin - if Atype.Kind /= ON_Array_Type then - raise Type_Error; - end if; - return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Base_Type => Atype, - Length => Length); - end New_Constrained_Array_Type; - - function New_Unsigned_Type (Size : Natural) return O_Tnode - is - subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type); - begin - return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Int_Size => Size); - end New_Unsigned_Type; - - function New_Signed_Type (Size : Natural) return O_Tnode - is - subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type); - begin - return new O_Tnode_Signed'(Kind => ON_Signed_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Int_Size => Size); - end New_Signed_Type; - - function New_Float_Type return O_Tnode - is - subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type); - begin - return new O_Tnode_Float'(Kind => ON_Float_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True); - end New_Float_Type; - - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode) - is - subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type); - subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit); - begin - Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - True_N => O_Cnode_Null, - False_N => O_Cnode_Null); - True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, - Ctype => Res, - Ref => False, - B_Val => True, - B_Id => True_Id); - False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, - Ctype => Res, - Ref => False, - B_Val => False, - B_Id => False_Id); - Res.True_N := True_E; - Res.False_N := False_E; - end New_Boolean_Type; - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) - is - pragma Unreferenced (Size); - subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type); - Res : O_Tnode; - begin - Res := new O_Tnode_Enum'(Kind => ON_Enum_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => False, - Nbr => 0, - Literals => O_Cnode_Null); - List.Res := Res; - List.Last := O_Cnode_Null; - end Start_Enum_Type; - - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; - Res : out O_Cnode) - is - subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit); - begin - Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit, - Ctype => List.Res, - Ref => False, - E_Val => List.Res.Nbr, - E_Name => Ident, - E_Next => O_Cnode_Null); - -- Link it. - if List.Last = O_Cnode_Null then - List.Res.Literals := Res; - else - List.Last.E_Next := Res; - end if; - List.Last := Res; - - List.Res.Nbr := List.Res.Nbr + 1; - end New_Enum_Literal; - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Res := List.Res; - Res.Complete := True; - end Finish_Enum_Type; - - function Get_Base_Type (Atype : O_Tnode) return O_Tnode - is - begin - case Atype.Kind is - when ON_Array_Sub_Type => - return Atype.Base_Type; - when others => - return Atype; - end case; - end Get_Base_Type; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) - is - subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Record_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, - Ctype => Atype, - Ref => False, - Aggr_Els => null); - List.Res := Res; - List.Last := null; - List.Field := Atype.Elements; - end Start_Record_Aggr; - - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode) - is - subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); - El : O_Cnode; - begin - if List.Field = O_Fnode_Null then - -- No more element in the aggregate. - raise Syntax_Error; - end if; - Check_Type (Value.Ctype, List.Field.Ftype); - El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, - Ctype => Value.Ctype, - Ref => False, - Aggr_Value => Value, - Aggr_Next => null); - if List.Last = null then - List.Res.Aggr_Els := El; - else - List.Last.Aggr_Next := El; - end if; - List.Last := El; - List.Field := List.Field.Next; - end New_Record_Aggr_El; - - procedure Finish_Record_Aggr - (List : in out O_Record_Aggr_List; Res : out O_Cnode) - is - begin - if List.Field /= null then - -- Not enough elements in aggregate. - raise Type_Error; - end if; - Res := List.Res; - end Finish_Record_Aggr; - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - is - subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Array_Sub_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, - Ctype => Atype, - Ref => False, - Aggr_Els => null); - List.Res := Res; - List.Last := null; - List.El_Type := Atype.Base_Type.El_Type; - end Start_Array_Aggr; - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - is - subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); - El : O_Cnode; - begin - Check_Type (Value.Ctype, List.El_Type); - El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, - Ctype => Value.Ctype, - Ref => False, - Aggr_Value => Value, - Aggr_Next => null); - if List.Last = null then - List.Res.Aggr_Els := El; - else - List.Last.Aggr_Next := El; - end if; - List.Last := El; - end New_Array_Aggr_El; - - procedure Finish_Array_Aggr - (List : in out O_Array_Aggr_List; Res : out O_Cnode) is - begin - Res := List.Res; - end Finish_Array_Aggr; - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Union_Type then - raise Type_Error; - end if; - Check_Type (Value.Ctype, Field.Ftype); - - Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr, - Ctype => Atype, - Ref => False, - Uaggr_Field => Field, - Uaggr_Value => Value); - return Res; - end New_Union_Aggr; - - function New_Obj (Obj : O_Dnode) return O_Lnode - is - subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj); - begin - case Obj.Kind is - when ON_Const_Decl - | ON_Var_Decl - | ON_Interface_Decl => - null; - when others => - raise Program_Error; - end case; - Check_Scope (Obj); - return new O_Lnode_Obj'(Kind => OL_Obj, - Rtype => Obj.Dtype, - Ref => False, - Obj => Obj); - end New_Obj; - - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode - is - subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); - Res : O_Lnode; - begin - Check_Ref (Arr); - Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element, - Rtype => Get_Base_Type (Arr.Rtype).El_Type, - Ref => False, - Array_Base => Arr, - Index => Index); - return Res; - end New_Indexed_Element; - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - is - subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice); - Res : O_Lnode; - begin - if Res_Type.Kind /= ON_Array_Type - and then Res_Type.Kind /= ON_Array_Sub_Type - then - raise Type_Error; - end if; - Check_Ref (Arr); - Check_Ref (Index); - -- FIXME: check type. - Res := new O_Lnode_Slice'(Kind => OL_Slice, - Rtype => Res_Type, - Ref => False, - Slice_Base => Arr, - Slice_Index => Index); - return Res; - end New_Slice; - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element); - begin - if Rec.Rtype.Kind /= ON_Record_Type then - raise Type_Error; - end if; - if Rec.Rtype /= El.Parent then - raise Type_Error; - end if; - Check_Ref (Rec); - return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element, - Rtype => El.Ftype, - Ref => False, - Rec_Base => Rec, - Rec_El => El); - end New_Selected_Element; - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); - begin - if Acc.Rtype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - Check_Ref (Acc); - return new O_Lnode_Access_Element'(Kind => OL_Access_Element, - Rtype => Acc.Rtype.D_Type, - Ref => False, - Acc_Base => Acc); - end New_Access_Element; - - function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind) - return Boolean - is - type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean; - T : constant Boolean := True; - F : constant Boolean := False; - Conv_Allowed : constant Conv_Array := - (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F), - ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F), - ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F), - ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F), - ON_Float_Type => (F, F, F, T, T, F, F, F, F, F), - ON_Array_Type => (F, F, F, F, F, F, T, F, F, F), - ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F), - ON_Record_Type => (F, F, F, F, F, F, F, F, F, F), - ON_Union_Type => (F, F, F, F, F, F, F, F, F, F), - ON_Access_Type => (F, F, F, F, F, F, F, F, F, T)); - begin - if Source = Target then - return True; - else - return Conv_Allowed (Source, Target); - end if; - end Check_Conv; - - 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); - return Res; - end New_Convert_Ov; - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address); - begin - Check_Ref (Lvalue); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Enode_Address'(Kind => OE_Unchecked_Address, - Rtype => Atype, - Ref => False, - Lvalue => Lvalue); - end New_Unchecked_Address; - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode - is - subtype O_Enode_Address is O_Enode_Type (OE_Address); - begin - Check_Ref (Lvalue); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then - if not Disable_Checks then - raise Type_Error; - end if; - end if; - return new O_Enode_Address'(Kind => OE_Address, - Rtype => Atype, - Ref => False, - Lvalue => Lvalue); - end New_Address; - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); - begin - Check_Scope (Decl); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Cnode_Address'(Kind => OC_Unchecked_Address, - Ctype => Atype, - Ref => False, - Decl => Decl); - end New_Global_Unchecked_Address; - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Address is O_Cnode_Type (OC_Address); - begin - Check_Scope (Decl); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then - raise Type_Error; - end if; - return new O_Cnode_Address'(Kind => OC_Address, - Ctype => Atype, - Ref => False, - Decl => Decl); - end New_Global_Address; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address); - begin - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, - Ctype => Atype, - Ref => False, - Decl => Subprg); - end New_Subprogram_Address; - - -- Raise TYPE_ERROR is ATYPE is a composite type. - procedure Check_Not_Composite (Atype : O_Tnode) is - begin - case Atype.Kind is - when ON_Boolean_Type - | ON_Unsigned_Type - | ON_Signed_Type - | ON_Float_Type - | ON_Enum_Type - | ON_Access_Type=> - return; - when ON_Array_Type - | ON_Record_Type - | ON_Union_Type - | ON_Array_Sub_Type => - raise Type_Error; - end case; - end Check_Not_Composite; - - function New_Value (Lvalue : O_Lnode) return O_Enode is - subtype O_Enode_Value is O_Enode_Type (OE_Value); - begin - Check_Not_Composite (Lvalue.Rtype); - Check_Ref (Lvalue); - return new O_Enode_Value'(Kind => OE_Value, - Rtype => Lvalue.Rtype, - Ref => False, - Value => Lvalue); - end New_Value; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return New_Value (New_Obj (Obj)); - end New_Obj_Value; - - function New_Lit (Lit : O_Cnode) return O_Enode is - subtype O_Enode_Lit is O_Enode_Type (OE_Lit); - begin - Check_Not_Composite (Lit.Ctype); - return new O_Enode_Lit'(Kind => OE_Lit, - Rtype => Lit.Ctype, - Ref => False, - Lit => Lit); - end New_Lit; - - --------------------- - -- Declarations. -- - --------------------- - - procedure New_Debug_Filename_Decl (Filename : String) - is - subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Filename_Decl; - N.Filename := new String'(Filename); - Add_Decl (N, False); - end New_Debug_Filename_Decl; - - procedure New_Debug_Line_Decl (Line : Natural) - is - subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Line_Decl; - N.Line := Line; - Add_Decl (N, False); - end New_Debug_Line_Decl; - - procedure New_Debug_Comment_Decl (Comment : String) - is - subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Comment_Decl; - N.Comment := new String'(Comment); - Add_Decl (N, False); - end New_Debug_Comment_Decl; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) - is - N : O_Dnode; - begin - if Atype.Decl /= null then - -- Type was already declared. - raise Type_Error; - end if; - N := new O_Dnode_Type (ON_Type_Decl); - N.Name := Ident; - N.Dtype := Atype; - Atype.Decl := N; - Add_Decl (N); - end New_Type_Decl; - - procedure Check_Object_Storage (Storage : O_Storage) is - begin - if Current_Function /= null then - -- Inside a subprogram. - case Storage is - when O_Storage_Public => - -- Cannot create public variables inside a subprogram. - raise Syntax_Error; - when O_Storage_Private - | O_Storage_Local - | O_Storage_External => - null; - end case; - else - -- Global scope. - case Storage is - when O_Storage_Public - | O_Storage_Private - | O_Storage_External => - null; - when O_Storage_Local => - -- Cannot create a local variables outside a subprogram. - raise Syntax_Error; - end case; - end if; - end Check_Object_Storage; - - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl); - begin - Check_Complete_Type (Atype); - if Storage = O_Storage_Local then - -- A constant cannot be local. - raise Syntax_Error; - end if; - Check_Object_Storage (Storage); - Res := new O_Dnode_Const'(Kind => ON_Const_Decl, - Name => Ident, - Next => null, - Dtype => Atype, - Storage => Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Const_Value => O_Dnode_Null); - Add_Decl (Res); - end New_Const_Decl; - - procedure Start_Const_Value (Const : in out O_Dnode) - is - subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); - N : O_Dnode; - begin - if Const.Const_Value /= O_Dnode_Null then - -- Constant already has a value. - raise Syntax_Error; - end if; - - if Const.Storage = O_Storage_External then - -- An external constant must not have a value. - raise Syntax_Error; - end if; - - -- FIXME: check scope is the same. - - N := new O_Dnode_Const_Value'(Kind => ON_Const_Value, - Name => Const.Name, - Next => null, - Dtype => Const.Dtype, - Storage => Const.Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Const_Decl => Const, - Value => O_Cnode_Null); - Const.Const_Value := N; - Add_Decl (N, False); - end Start_Const_Value; - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) - is - begin - if Const.Const_Value = O_Dnode_Null then - -- Start_Const_Value not called. - raise Syntax_Error; - end if; - if Const.Const_Value.Value /= O_Cnode_Null then - -- Finish_Const_Value already called. - raise Syntax_Error; - end if; - if Val = O_Cnode_Null then - -- No value or bad type. - raise Type_Error; - end if; - Check_Type (Val.Ctype, Const.Dtype); - Const.Const_Value.Value := Val; - end Finish_Const_Value; - - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl); - begin - Check_Complete_Type (Atype); - Check_Object_Storage (Storage); - Res := new O_Dnode_Var'(Kind => ON_Var_Decl, - Name => Ident, - Next => null, - Dtype => Atype, - Storage => Storage, - Lineno => 0, - Scope => Current_Decl_Scope.Parent); - Add_Decl (Res); - end New_Var_Decl; - - procedure Start_Subprogram_Decl_1 - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Function'(Kind => ON_Function_Decl, - Next => null, - Name => Ident, - Dtype => Rtype, - Storage => Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Interfaces => null, - Func_Body => null, - Alive => False); - Add_Decl (N); - Interfaces.Func := N; - Interfaces.Last := null; - end Start_Subprogram_Decl_1; - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - begin - Check_Not_Composite (Rtype); - Check_Complete_Type (Rtype); - Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype); - end Start_Function_Decl; - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage) is - begin - Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null); - end Start_Procedure_Decl; - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) - is - subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl); - begin - Check_Not_Composite (Atype); - Check_Complete_Type (Atype); - Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl, - Next => null, - Name => Ident, - Dtype => Atype, - Storage => O_Storage_Private, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Func_Scope => Interfaces.Func); - if Interfaces.Last = null then - Interfaces.Func.Interfaces := Res; - else - Interfaces.Last.Next := Res; - end if; - Interfaces.Last := Res; - end New_Interface_Decl; - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode) - is - begin - Res := Interfaces.Func; - end Finish_Subprogram_Decl; - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - B : O_Dnode; - S : O_Snode; - begin - if Func.Func_Body /= null then - -- Function was already declared. - raise Syntax_Error; - end if; - S := new O_Snode_Type (ON_Declare_Stmt); - S.all := O_Snode_Type'(Kind => ON_Declare_Stmt, - Next => null, - Decls => null, - Stmts => null, - Lineno => 0, - Alive => True); - B := new O_Dnode_Type (ON_Function_Body); - B.all := O_Dnode_Type'(ON_Function_Body, - Name => Func.Name, - Dtype => Func.Dtype, - Storage => Func.Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Func_Decl => Func, - Func_Stmt => S, - Next => null); - Add_Decl (B, False); - Func.Func_Body := B; - Push_Decl_Scope (S); - Push_Stmt_Scope - (new Stmt_Function_Scope_Type'(Kind => Stmt_Function, - Parent => S, - Prev => Current_Stmt_Scope, - Prev_Function => Current_Function, - Decl => Func)); - Current_Function := Current_Stmt_Scope; - Func.Alive := True; - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body is - begin - Pop_Decl_Scope; - if Current_Function.Kind /= Stmt_Function then - -- Internal error. - raise Syntax_Error; - end if; - Current_Function.Decl.Alive := False; - Current_Function := Current_Function.Prev_Function; - Pop_Stmt_Scope (Stmt_Function); - end Finish_Subprogram_Body; - - ------------------- - -- Statements. -- - ------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) - is - subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt); - begin - Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt, - Next => null, - Lineno => 0, - Line => Line)); - end New_Debug_Line_Stmt; - - procedure New_Debug_Comment_Stmt (Comment : String) - is - subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt); - begin - Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt, - Next => null, - Lineno => 0, - Comment => new String'(Comment))); - end New_Debug_Comment_Stmt; - - procedure Start_Declare_Stmt - is - N : O_Snode; - begin - N := new O_Snode_Type (ON_Declare_Stmt); - Add_Stmt (N); - Push_Decl_Scope (N); - Push_Stmt_Scope - (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare, - Parent => N, - Prev => Current_Stmt_Scope)); - end Start_Declare_Stmt; - - procedure Finish_Declare_Stmt is - begin - Pop_Decl_Scope; - Pop_Stmt_Scope (Stmt_Declare); - end Finish_Declare_Stmt; - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) - is - N : O_Snode; - begin - Check_Type (Target.Rtype, Value.Rtype); - Check_Not_Composite (Target.Rtype); - Check_Ref (Target); - Check_Ref (Value); - N := new O_Snode_Type (ON_Assign_Stmt); - N.all := O_Snode_Type'(Kind => ON_Assign_Stmt, - Next => null, - Lineno => 0, - Target => Target, - Value => Value); - Add_Stmt (N); - end New_Assign_Stmt; - - procedure New_Return_Stmt_1 (Value : O_Enode) - is - subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt); - N : O_Snode; - begin - N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt, - Next => null, - Lineno => 0, - Ret_Val => Value); - Add_Stmt (N); - end New_Return_Stmt_1; - - procedure New_Return_Stmt (Value : O_Enode) - is - begin - if Current_Function = null - or else Current_Function.Decl.Dtype = O_Tnode_Null - then - -- Either not in a function or in a procedure. - raise Syntax_Error; - end if; - Check_Type (Value.Rtype, Current_Function.Decl.Dtype); - Check_Ref (Value); - New_Return_Stmt_1 (Value); - end New_Return_Stmt; - - procedure New_Return_Stmt is - begin - if Current_Function = null - or else Current_Function.Decl.Dtype /= O_Tnode_Null - then - -- Not in a procedure. - raise Syntax_Error; - end if; - New_Return_Stmt_1 (null); - end New_Return_Stmt; - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - begin - Check_Scope (Subprg); - Assocs.Subprg := Subprg; - Assocs.Interfaces := Subprg.Interfaces; - Assocs.First := null; - Assocs.Last := null; - end Start_Association; - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) - is - N : O_Anode; - begin - Check_Type (Assocs.Interfaces.Dtype, Val.Rtype); - Check_Ref (Val); - N := new O_Anode_Type'(Next => null, - Formal => Assocs.Interfaces, Actual => Val); - Assocs.Interfaces := Assocs.Interfaces.Next; - if Assocs.Last = null then - Assocs.First := N; - else - Assocs.Last.Next := N; - end if; - Assocs.Last := N; - end New_Association; - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - subtype O_Enode_Call is O_Enode_Type (OE_Function_Call); - Res : O_Enode; - begin - if Assocs.Interfaces /= null then - -- Not enough arguments. - raise Syntax_Error; - end if; - if Assocs.Subprg.Dtype = null then - -- This is a procedure. - raise Syntax_Error; - end if; - - Res := new O_Enode_Call'(Kind => OE_Function_Call, - Rtype => Assocs.Subprg.Dtype, - Ref => False, - Func => Assocs.Subprg, - Assoc => Assocs.First); - return Res; - end New_Function_Call; - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - is - N : O_Snode; - begin - if Assocs.Interfaces /= null then - -- Not enough arguments. - raise Syntax_Error; - end if; - if Assocs.Subprg.Dtype /= null then - -- This is a function. - raise Syntax_Error; - end if; - N := new O_Snode_Type (ON_Call_Stmt); - N.Proc := Assocs.Subprg; - N.Assoc := Assocs.First; - Add_Stmt (N); - end New_Procedure_Call; - - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); - - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - subtype O_Snode_If is O_Snode_Type (ON_If_Stmt); - N : O_Snode; - begin - -- Note: no checks are performed here, since they are done in - -- new_elsif_stmt. - N := new O_Snode_If'(Kind => ON_If_Stmt, - Next => null, - Lineno => 0, - Elsifs => null, - If_Last => null); - Add_Stmt (N); - Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If, - Parent => N, - Prev => Current_Stmt_Scope, - Last_Elsif => null)); - New_Elsif_Stmt (Block, Cond); - end Start_If_Stmt; - - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - pragma Unreferenced (Block); - N : O_Snode; - begin - if Cond /= null then - if Cond.Rtype.Kind /= ON_Boolean_Type then - raise Type_Error; - end if; - Check_Ref (Cond); - end if; - N := new O_Snode_Type (ON_Elsif_Stmt); - N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt, - Next => null, - Lineno => 0, - Cond => Cond, - Next_Elsif => null); - if Current_Stmt_Scope.Kind /= Stmt_If then - raise Syntax_Error; - end if; - Add_Stmt (N); - if Current_Stmt_Scope.Last_Elsif = null then - Current_Stmt_Scope.Parent.Elsifs := N; - else - -- Check for double 'else' - if Current_Stmt_Scope.Last_Elsif.Cond = null then - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Elsif.Next_Elsif := N; - end if; - Current_Stmt_Scope.Last_Elsif := N; - end New_Elsif_Stmt; - - procedure New_Else_Stmt (Block : in out O_If_Block) is - begin - New_Elsif_Stmt (Block, null); - end New_Else_Stmt; - - procedure Finish_If_Stmt (Block : in out O_If_Block) - is - pragma Unreferenced (Block); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_If); - Parent.If_Last := Current_Decl_Scope.Last_Stmt; - end Finish_If_Stmt; - - procedure Start_Loop_Stmt (Label : out O_Snode) - is - subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt); - begin - Current_Loop_Level := Current_Loop_Level + 1; - Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt, - Next => null, - Lineno => 0, - Loop_Last => null, - Loop_Level => Current_Loop_Level); - Add_Stmt (Label); - Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop, - Parent => Label, - Prev => Current_Stmt_Scope)); - end Start_Loop_Stmt; - - procedure Finish_Loop_Stmt (Label : in out O_Snode) - is - pragma Unreferenced (Label); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_Loop); - Parent.Loop_Last := Current_Decl_Scope.Last_Stmt; - Current_Loop_Level := Current_Loop_Level - 1; - end Finish_Loop_Stmt; - - procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode) - is - N : O_Snode; - begin - N := new O_Snode_Type (Kind); - N.Next := null; - N.Loop_Id := L; - Add_Stmt (N); - end New_Exit_Next_Stmt; - - procedure New_Exit_Stmt (L : O_Snode) is - begin - New_Exit_Next_Stmt (ON_Exit_Stmt, L); - end New_Exit_Stmt; - - procedure New_Next_Stmt (L : O_Snode) is - begin - New_Exit_Next_Stmt (ON_Next_Stmt, L); - end New_Next_Stmt; - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) - is - subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt); - N : O_Snode; - begin - case Value.Rtype.Kind is - when ON_Boolean_Type - | ON_Unsigned_Type - | ON_Signed_Type - | ON_Enum_Type => - null; - when others => - raise Type_Error; - end case; - Check_Ref (Value); - N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt, - Next => null, - Lineno => 0, - Case_Last => null, - Selector => Value, - Branches => null); - Block.Case_Stmt := N; - Add_Stmt (N); - Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case, - Parent => N, - Prev => Current_Stmt_Scope, - Last_Branch => null, - Last_Choice => null, - Case_Type => Value.Rtype)); - end Start_Case_Stmt; - - procedure Start_Choice (Block : in out O_Case_Block) - is - N : O_Snode; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a branch outside a case statment. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice /= null then - -- You are creating branch while the previous one was not finished. - raise Syntax_Error; - end if; - - N := new O_Snode_Type (ON_When_Stmt); - N.all := O_Snode_Type'(Kind => ON_When_Stmt, - Next => null, - Lineno => 0, - Branch_Parent => Block.Case_Stmt, - Choice_List => null, - Next_Branch => null); - if Current_Stmt_Scope.Last_Branch = null then - Current_Stmt_Scope.Parent.Branches := N; - else - Current_Stmt_Scope.Last_Branch.Next_Branch := N; - end if; - Current_Stmt_Scope.Last_Branch := N; - Current_Stmt_Scope.Last_Choice := null; - Add_Stmt (N); - end Start_Choice; - - procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice) - is - pragma Unreferenced (Block); - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Branch = null then - -- You are not inside a branch. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice = null then - if Current_Stmt_Scope.Last_Branch.Choice_List /= null then - -- The branch was already closed. - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Branch.Choice_List := Choice; - else - Current_Stmt_Scope.Last_Choice.Next := Choice; - end if; - Current_Stmt_Scope.Last_Choice := Choice; - end Add_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Case_Type /= Expr.Ctype then - -- Expr type is not the same as choice type. - raise Type_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Expr); - N.all := O_Choice_Type'(Kind => ON_Choice_Expr, - Next => null, - Expr => Expr); - Add_Choice (Block, N); - end New_Expr_Choice; - - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Case_Type /= Low.Ctype - or Current_Stmt_Scope.Case_Type /= High.Ctype - then - -- Low/High type is not the same as choice type. - raise Type_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Range); - N.all := O_Choice_Type'(Kind => ON_Choice_Range, - Next => null, - Low => Low, - High => High); - Add_Choice (Block, N); - end New_Range_Choice; - - procedure New_Default_Choice (Block : in out O_Case_Block) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Default); - N.all := O_Choice_Type'(Kind => ON_Choice_Default, - Next => null); - Add_Choice (Block, N); - end New_Default_Choice; - - procedure Finish_Choice (Block : in out O_Case_Block) - is - pragma Unreferenced (Block); - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Branch = null then - -- You are not inside a branch. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice = null then - -- The branch is empty or you are not inside a branch. - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Choice := null; - end Finish_Choice; - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) - is - pragma Unreferenced (Block); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_Case); - Parent.Case_Last := Current_Decl_Scope.Last_Stmt; - end Finish_Case_Stmt; - - procedure Init is - begin - Top := new O_Snode_Type (ON_Declare_Stmt); - Push_Decl_Scope (Top); - end Init; - - procedure Finish is - begin - Pop_Decl_Scope; - end Finish; -end Ortho_Debug; diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads deleted file mode 100644 index 69ee16cf7..000000000 --- a/ortho/debug/ortho_debug.private.ads +++ /dev/null @@ -1,467 +0,0 @@ --- Ortho debug back-end declarations. --- Copyright (C) 2005-2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; - --- Interface to create nodes. -package Ortho_Debug is - procedure Init; - procedure Finish; - -private - -- This back-end supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - -- A node for a type. - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - - -- A node for a statement. - type O_Snode_Type (<>); - type O_Snode is access O_Snode_Type; - - Top : O_Snode; - - type Str_Acc is access String; - - type Decl_Scope_Type; - type Decl_Scope_Acc is access Decl_Scope_Type; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, ON_Var_Decl, ON_Interface_Decl, - ON_Function_Decl, ON_Function_Body, - ON_Const_Value, - ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl); - - type O_Dnode_Type (<>); - type O_Dnode is access O_Dnode_Type; - - O_Dnode_Null : constant O_Dnode := null; - - type O_Dnode_Type (Kind : On_Decl_Kind) is record - Next : O_Dnode; - Name : O_Ident; - Dtype : O_Tnode; - Storage : O_Storage; - -- Declare statement in which the declaration appears. - Scope : O_Snode; - -- Line number, for regen. - Lineno : Natural; - case Kind is - when ON_Type_Decl => - null; - when ON_Completed_Type_Decl => - null; - when ON_Const_Decl => - Const_Value : O_Dnode; - when ON_Const_Value => - Const_Decl : O_Dnode; - Value : O_Cnode; - when ON_Var_Decl => - null; - when ON_Function_Decl => - Interfaces : O_Dnode; - Func_Body : O_Dnode; - Alive : Boolean; - when ON_Function_Body => - Func_Decl : O_Dnode; - Func_Stmt : O_Snode; - when ON_Interface_Decl => - Func_Scope : O_Dnode; - when ON_Debug_Line_Decl => - Line : Natural; - when ON_Debug_Comment_Decl => - Comment : Str_Acc; - when ON_Debug_Filename_Decl => - Filename : Str_Acc; - end case; - end record; - - -- A node for a record element. - type O_Fnode_Type; - type O_Fnode is access O_Fnode_Type; - - O_Fnode_Null : constant O_Fnode := null; - - type O_Fnode_Type is record - -- Record type. - Parent : O_Tnode; - -- Next field in the record. - Next : O_Fnode; - -- Name of the record field. - Ident : O_Ident; - -- Type of the record field. - Ftype : O_Tnode; - -- Offset in the field. - Offset : Unsigned_32; - end record; - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type OC_Kind is - ( - OC_Boolean_Lit, - OC_Unsigned_Lit, - OC_Signed_Lit, - OC_Float_Lit, - OC_Enum_Lit, - OC_Null_Lit, - OC_Sizeof_Lit, - OC_Alignof_Lit, - OC_Offsetof_Lit, - OC_Aggregate, - OC_Aggr_Element, - OC_Union_Aggr, - OC_Address, - OC_Unchecked_Address, - OC_Subprogram_Address - ); - type O_Cnode_Type (Kind : OC_Kind) is record - -- Type of the constant. - Ctype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OC_Unsigned_Lit => - U_Val : Unsigned_64; - when OC_Signed_Lit => - S_Val : Integer_64; - when OC_Float_Lit => - F_Val : IEEE_Float_64; - when OC_Boolean_Lit => - B_Val : Boolean; - B_Id : O_Ident; - when OC_Enum_Lit => - E_Val : Integer; - E_Next : O_Cnode; - E_Name : O_Ident; - when OC_Null_Lit => - null; - when OC_Sizeof_Lit - | OC_Alignof_Lit => - S_Type : O_Tnode; - when OC_Offsetof_Lit => - Off_Field : O_Fnode; - when OC_Aggregate => - Aggr_Els : O_Cnode; - when OC_Union_Aggr => - Uaggr_Field : O_Fnode; - Uaggr_Value : O_Cnode; - when OC_Aggr_Element => - Aggr_Value : O_Cnode; - Aggr_Next : O_Cnode; - when OC_Address - | OC_Unchecked_Address - | OC_Subprogram_Address => - Decl : O_Dnode; - end case; - end record; - - type O_Cnode is access O_Cnode_Type; - O_Cnode_Null : constant O_Cnode := null; - - type OE_Kind is - ( - -- Literals. - OE_Lit, - - -- Dyadic operations. - OE_Add_Ov, -- OE_Dyadic_Op_Kind - OE_Sub_Ov, -- OE_Dyadic_Op_Kind - OE_Mul_Ov, -- OE_Dyadic_Op_Kind - OE_Div_Ov, -- OE_Dyadic_Op_Kind - OE_Rem_Ov, -- OE_Dyadic_Op_Kind - OE_Mod_Ov, -- OE_Dyadic_Op_Kind - OE_Exp_Ov, -- OE_Dyadic_Op_Kind - - -- Binary operations. - OE_And, -- OE_Dyadic_Op_Kind - OE_Or, -- OE_Dyadic_Op_Kind - OE_Xor, -- OE_Dyadic_Op_Kind - OE_And_Then, -- OE_Dyadic_Op_Kind - OE_Or_Else, -- OE_Dyadic_Op_Kind - - -- Monadic operations. - OE_Not, -- OE_Monadic_Op_Kind - OE_Neg_Ov, -- OE_Monadic_Op_Kind - OE_Abs_Ov, -- OE_Monadic_Op_Kind - - -- Comparaisons - OE_Eq, -- OE_Compare_Op_Kind - OE_Neq, -- OE_Compare_Op_Kind - OE_Le, -- OE_Compare_Op_Kind - OE_Lt, -- OE_Compare_Op_Kind - OE_Ge, -- OE_Compare_Op_Kind - OE_Gt, -- OE_Compare_Op_Kind - - -- Misc. - OE_Convert_Ov, - OE_Address, - OE_Unchecked_Address, - OE_Alloca, - OE_Function_Call, - - OE_Value, - OE_Nil - ); - - subtype OE_Dyadic_Expr_Kind is OE_Kind range OE_Add_Ov .. OE_Or_Else; - subtype OE_Monadic_Expr_Kind is OE_Kind range OE_Not .. OE_Abs_Ov; - subtype OE_Compare_Expr_Kind is OE_Kind range OE_Eq .. OE_Gt; - - type O_Enode_Type (Kind : OE_Kind); - type O_Enode is access O_Enode_Type; - O_Enode_Null : constant O_Enode := null; - - type O_Enode_Type (Kind : OE_Kind) is record - -- Type of the result. - Rtype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OE_Dyadic_Expr_Kind - | OE_Compare_Expr_Kind => - Left : O_Enode; - Right : O_Enode; - when OE_Monadic_Expr_Kind => - Operand : O_Enode; - when OE_Lit => - Lit : O_Cnode; - when OE_Address - | OE_Unchecked_Address => - Lvalue : O_Lnode; - when OE_Convert_Ov => - Conv : O_Enode; - when OE_Function_Call => - Func : O_Dnode; - Assoc : O_Anode; - when OE_Value => - Value : O_Lnode; - when OE_Alloca => - A_Size : O_Enode; - when OE_Nil => - null; - end case; - end record; - type O_Enode_Array is array (Natural range <>) of O_Enode; - type O_Enode_Array_Acc is access O_Enode_Array; - - type OL_Kind is - ( - -- Name. - OL_Obj, - OL_Indexed_Element, - OL_Slice, - OL_Selected_Element, - OL_Access_Element - - -- Variable, constant, parameter reference. - -- This allows to read/write a declaration. - --OL_Var_Ref, - --OL_Const_Ref, - --OL_Param_Ref - ); - - type O_Lnode_Type (Kind : OL_Kind); - type O_Lnode is access O_Lnode_Type; - O_Lnode_Null : constant O_Lnode := null; - - type O_Lnode_Type (Kind : OL_Kind) is record - -- Type of the result. - Rtype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OL_Obj => - Obj : O_Dnode; - when OL_Indexed_Element => - Array_Base : O_Lnode; - Index : O_Enode; - when OL_Slice => - Slice_Base : O_Lnode; - Slice_Index : O_Enode; - when OL_Selected_Element => - Rec_Base : O_Lnode; - Rec_El : O_Fnode; - when OL_Access_Element => - Acc_Base : O_Enode; --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Decl : O_Dnode; - end case; - end record; - - O_Tnode_Null : constant O_Tnode := null; - type ON_Type_Kind is - (ON_Boolean_Type, ON_Enum_Type, - ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type, ON_Array_Type, - ON_Array_Sub_Type, ON_Record_Type, ON_Union_Type, ON_Access_Type); - type O_Tnode_Type (Kind : ON_Type_Kind) is record - Decl : O_Dnode; - -- True if the type was first created as an uncomplete type. - Uncomplete : Boolean; - -- True if the type is complete. - Complete : Boolean; - case Kind is - when ON_Boolean_Type => - True_N : O_Cnode; - False_N : O_Cnode; - when ON_Unsigned_Type - | ON_Signed_Type => - Int_Size : Natural; - when ON_Float_Type => - null; - when ON_Enum_Type => - Nbr : Natural; - Literals: O_Cnode; - when ON_Array_Type => - El_Type : O_Tnode; - Index_Type : O_Tnode; - when ON_Access_Type => - D_Type : O_Tnode; - when ON_Record_Type - | ON_Union_Type => - Elements : O_Fnode; - when ON_Array_Sub_Type => - Length : O_Cnode; - Base_Type : O_Tnode; - end case; - end record; - - type ON_Choice_Kind is (ON_Choice_Expr, ON_Choice_Range, ON_Choice_Default); - type O_Choice_Type (Kind : ON_Choice_Kind); - type O_Choice is access O_Choice_Type; - type O_Choice_Type (Kind : ON_Choice_Kind) is record - Next : O_Choice; - case Kind is - when ON_Choice_Expr => - Expr : O_Cnode; - when ON_Choice_Range => - Low, High : O_Cnode; - when ON_Choice_Default => - null; - end case; - end record; - - O_Snode_Null : constant O_Snode := null; - type ON_Stmt_Kind is - (ON_Declare_Stmt, ON_Assign_Stmt, ON_Return_Stmt, ON_If_Stmt, - ON_Elsif_Stmt, ON_Loop_Stmt, ON_Exit_Stmt, ON_Next_Stmt, - ON_Case_Stmt, ON_When_Stmt, ON_Call_Stmt, - ON_Debug_Line_Stmt, ON_Debug_Comment_Stmt); - type O_Snode_Type (Kind : ON_Stmt_Kind) is record - Next : O_Snode; - Lineno : Natural; - case Kind is - when ON_Declare_Stmt => - Decls : O_Dnode; - Stmts : O_Snode; - -- True if the statement is currently open. - Alive : Boolean; - when ON_Assign_Stmt => - Target : O_Lnode; - Value : O_Enode; - when ON_Return_Stmt => - Ret_Val : O_Enode; - when ON_If_Stmt => - Elsifs : O_Snode; - If_Last : O_Snode; - when ON_Elsif_Stmt => - Cond : O_Enode; - Next_Elsif : O_Snode; - when ON_Loop_Stmt => - Loop_Last : O_Snode; - Loop_Level : Natural; - when ON_Exit_Stmt - | ON_Next_Stmt => - Loop_Id : O_Snode; - when ON_Case_Stmt => - Selector : O_Enode; - -- Simply linked list of branches - Branches : O_Snode; - Case_Last : O_Snode; - when ON_When_Stmt => - -- The corresponding 'case' - Branch_Parent : O_Snode; - Choice_List : O_Choice; - Next_Branch : O_Snode; - when ON_Call_Stmt => - Proc : O_Dnode; - Assoc : O_Anode; - when ON_Debug_Line_Stmt => - Line : Natural; - when ON_Debug_Comment_Stmt => - Comment : Str_Acc; - end case; - end record; - - type O_Inter_List is record - Func : O_Dnode; - Last : O_Dnode; - end record; - - type O_Element_List is record - -- The type definition. - Res : O_Tnode; - -- The last element added. - Last : O_Fnode; - end record; - - type O_Record_Aggr_List is record - Res : O_Cnode; - Last : O_Cnode; - Field : O_Fnode; - end record; - - type O_Array_Aggr_List is record - Res : O_Cnode; - Last : O_Cnode; - El_Type : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Interfaces : O_Dnode; - First, Last : O_Anode; - end record; - - type O_Enum_List is record - -- The type built. - Res : O_Tnode; - - -- the chain of declarations. - Last : O_Cnode; - end record; - type O_Case_Block is record - Case_Stmt : O_Snode; - end record; - - type O_If_Block is record - null; - end record; -end Ortho_Debug; diff --git a/ortho/debug/ortho_debug_front.ads b/ortho/debug/ortho_debug_front.ads deleted file mode 100644 index 17e32c9ed..000000000 --- a/ortho/debug/ortho_debug_front.ads +++ /dev/null @@ -1,20 +0,0 @@ --- Ortho debug interface with front-end. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ortho_Front; -package Ortho_Debug_Front renames Ortho_Front; diff --git a/ortho/debug/ortho_ident.ads b/ortho/debug/ortho_ident.ads deleted file mode 100644 index 46aa8854d..000000000 --- a/ortho/debug/ortho_ident.ads +++ /dev/null @@ -1,20 +0,0 @@ --- Ortho debug back-end interface with identifiers package. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ortho_Ident_Simple; -package Ortho_Ident renames Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_hash.adb b/ortho/debug/ortho_ident_hash.adb deleted file mode 100644 index 60ab89586..000000000 --- a/ortho/debug/ortho_ident_hash.adb +++ /dev/null @@ -1,72 +0,0 @@ --- Ortho debug hashed identifiers implementation. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Ident_Hash is - type O_Ident_Array is array (Hash_Type range <>) of O_Ident; - Hash_Max : constant Hash_Type := 511; - Symtable : O_Ident_Array (0 .. Hash_Max - 1) := (others => null); - - function Get_Identifier (Str : String) return O_Ident - is - Hash : Hash_Type; - Ent : Hash_Type; - Res : O_Ident; - begin - -- 1. Compute Hash. - Hash := 0; - for I in Str'Range loop - Hash := Hash * 31 + Character'Pos (Str (I)); - end loop; - - -- 2. Search. - Ent := Hash mod Hash_Max; - Res := Symtable (Ent); - while Res /= null loop - if Res.Hash = Hash and then Res.Ident.all = Str then - return Res; - end if; - Res := Res.Next; - end loop; - - -- Not found: add. - Res := new Ident_Type'(Hash => Hash, - Ident => new String'(Str), - Next => Symtable (Ent)); - Symtable (Ent) := Res; - return Res; - end Get_Identifier; - - function Get_String (Id : O_Ident) return String is - begin - if Id = null then - return "?ANON?"; - else - return Id.Ident.all; - end if; - end Get_String; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = null; - end Is_Nul; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Id.Ident.all = Str; - end Is_Equal; -end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_hash.ads b/ortho/debug/ortho_ident_hash.ads deleted file mode 100644 index a6e4a56cc..000000000 --- a/ortho/debug/ortho_ident_hash.ads +++ /dev/null @@ -1,46 +0,0 @@ --- Ortho debug hashed identifiers implementation. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package Ortho_Ident_Hash is - type O_Ident is private; - O_Ident_Nul : constant O_Ident; - - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames "="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; -private - type Hash_Type is mod 2**32; - - type String_Acc is access constant String; - - -- Symbol table. - type Ident_Type; - type O_Ident is access Ident_Type; - type Ident_type is record - -- The hash for the symbol. - Hash : Hash_Type; - -- Identification of the symbol. - Ident : String_Acc; - -- Next symbol with the same collision. - Next : O_Ident; - end record; - - O_Ident_Nul : constant O_Ident := null; -end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_simple.adb b/ortho/debug/ortho_ident_simple.adb deleted file mode 100644 index 83b9756f8..000000000 --- a/ortho/debug/ortho_ident_simple.adb +++ /dev/null @@ -1,44 +0,0 @@ --- Ortho debug identifiers simple implementation. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Ident_Simple is - function Get_Identifier (Str : String) return O_Ident - is - begin - return new String'(Str); - end Get_Identifier; - - function Get_String (Id : O_Ident) return String is - begin - if Id = null then - return "?ANON?"; - else - return Id.all; - end if; - end Get_String; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = null; - end Is_Nul; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Id.all = Str; - end Is_Equal; -end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_simple.ads b/ortho/debug/ortho_ident_simple.ads deleted file mode 100644 index f94fe1938..000000000 --- a/ortho/debug/ortho_ident_simple.ads +++ /dev/null @@ -1,31 +0,0 @@ --- Ortho debug identifiers simple implementation. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package Ortho_Ident_Simple is - type O_Ident is private; - O_Ident_Nul : constant O_Ident; - - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames "="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; -private - type O_Ident is access String; - O_Ident_Nul : constant O_Ident := null; -end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_nodes.ads b/ortho/debug/ortho_nodes.ads deleted file mode 100644 index 8ade66722..000000000 --- a/ortho/debug/ortho_nodes.ads +++ /dev/null @@ -1,21 +0,0 @@ --- Ortho debug back-end interface with front-end. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ortho_Debug; - -package Ortho_Nodes renames Ortho_Debug; diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile deleted file mode 100644 index 5aafb31c7..000000000 --- a/ortho/gcc/Makefile +++ /dev/null @@ -1,86 +0,0 @@ -ortho_srcdir=.. -orthobe_srcdir=$(ortho_srcdir)/gcc -agcc_objdir=. -agcc_srcdir=$(ortho_srcdir)/gcc -SED=sed -BE=gcc -GNATMAKE=gnatmake -CC=gcc -CXX=g++ -COMPILER=$(CXX) -LINKER=$(CXX) - -# Modify AGCC_GCCSRC_DIR and AGCC_GCCOBJ_DIR for your environment -AGCC_GCCSRC_DIR:=$(HOME)/Projects/gcc4.9.2/source/gcc-4.9.2/ -AGCC_GCCOBJ_DIR:=$(HOME)/Projects/gcc4.9.2/build/ - -# Supplied by main GCC Makefile, copied here for compatibility with same -GMPLIBS = -L$(AGCC_GCCOBJ_DIR)./gmp/.libs -L$(AGCC_GCCOBJ_DIR)./mpfr/.libs \ - -L$(AGCC_GCCOBJ_DIR)./mpc/src/.libs -lmpc -lmpfr -lgmp -GMPINC = -I$(AGCC_GCCOBJ_DIR)./gmp -I$(AGCC_GCCSRC_DIR)/gmp \ - -I$(AGCC_GCCOBJ_DIR)./mpfr -I$(AGCC_GCCSRC_DIR)/mpfr \ - -I$(AGCC_GCCSRC_DIR)/mpc/src - -HOST_LIBS = -ZLIB=-lz - -# Override variables in Makefile.conf for your environment --include $(orthobe_srcdir)/Makefile.conf - -all: $(ortho_exec) - -ORTHO_BASENAME=ortho_gcc -include $(ortho_srcdir)/Makefile.inc - -AGCC_INC_FLAGS=-I$(AGCC_GCCOBJ_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/include \ - -I$(AGCC_GCCSRC_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/gcc/config \ - -I$(AGCC_GCCSRC_DIR)/libcpp/include $(GMPINC) -AGCC_CFLAGS=-g -Wall -DIN_GCC $(AGCC_INC_FLAGS) - -ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \ - $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \ - $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h - $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES) - -AGCC_LOCAL_OBJS=ortho-lang.o - -AGCC_DEPS := $(AGCC_LOCAL_OBJS) -AGCC_OBJS := $(AGCC_LOCAL_OBJS) \ - $(AGCC_GCCOBJ_DIR)gcc/attribs.o \ - $(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \ - $(AGCC_GCCOBJ_DIR)libiberty/libiberty.a - -LIBBACKTRACE = $(AGCC_GCCOBJ_DIR)/libbacktrace/.libs/libbacktrace.a -LIBDECNUMBER = $(AGCC_GCCOBJ_DIR)/libdecnumber/libdecnumber.a -LIBIBERTY = $(AGCC_GCCOBJ_DIR)/libiberty/libiberty.a -CPPLIB= # Not needed for GHDL - -BACKEND = $(AGCC_GCCOBJ_DIR)/gcc/libbackend.a \ - $(AGCC_GCCOBJ_DIR)/gcc/libcommon-target.a - -BACKENDLIBS = $(CLOOGLIBS) $(GMPLIBS) $(PLUGINLIBS) $(HOST_LIBS) \ - $(ZLIB) -LIBS = $(AGCC_GCCOBJ_DIR)/gcc/libcommon.a \ - $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) \ - $(LIBIBERTY) $(LIBDECNUMBER) $(HOST_LIBS) - -$(ortho_exec): $(AGCC_DEPS) $(orthobe_srcdir)/ortho_gcc.ads force - $(GNATMAKE) -m -o $@ -g -aI$(ortho_srcdir) \ - -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \ - -bargs -E -largs --LINK=$(LINKER) $(AGCC_OBJS) \ - $(BACKEND) $(LIBS) $(BACKENDLIBS) - -agcc-clean: force - $(RM) -f $(agcc_objdir)/*.o - $(RM) -f $(agcc_srcdir)/*~ - -clean: agcc-clean - $(RM) -f *.o *.ali ortho_nodes-main - $(RM) b~*.ad? *~ - -distclean: clean agcc-clean - - -force: - -.PHONY: force all clean agcc-clean diff --git a/ortho/gcc/Makefile.conf.linux b/ortho/gcc/Makefile.conf.linux deleted file mode 100644 index 00ea91728..000000000 --- a/ortho/gcc/Makefile.conf.linux +++ /dev/null @@ -1,4 +0,0 @@ -# Example Makefile.conf -# Copy this file to Makefile.conf and edit as necessary for your platform - -HOST_LIBS = -ldl -lstdc++ diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt deleted file mode 100644 index 562fbe08d..000000000 --- a/ortho/gcc/lang.opt +++ /dev/null @@ -1,96 +0,0 @@ -Language -vhdl - --std= -vhdl Joined -Select the vhdl standard - --compile-standard -vhdl -Used during compiler build to compile the std.standard package - --bootstrap -vhdl -Used during compiler build to compile std packages - --work= -vhdl Joined -Set the name of the work library - --workdir= -vhdl Joined -Set the directory of the work library - -P -vhdl JoinedOrMissing -;-P<dir> Add <dir> to the end of the vhdl library path - --elab -vhdl Separate ---elab <name> Used internally during elaboration of <name> - --anaelab -vhdl Separate ---anaelab <name> Used internally during elaboration of <name> - -; -c is a driver option for gcc. --ghdl-source is used instead. -;c -;vhdl Separate -;-c <filename> Analyze <filename> for --anaelab - -;v -;vhdl -;Verbose - --warn- -vhdl Joined ---warn-<name> Warn about <name> - --ghdl -vhdl Joined ---ghdl-<option> Pass <option> to vhdl front-end - --expect-failure -vhdl -Expect a compiler error (used for testsuite) - --no-vital-checks -vhdl -Disable VITAL checks - --vital-checks -vhdl -Enable VITAL checks - -fexplicit -vhdl -Explicit function declarations override implicit one in use - -frelaxed-rules -vhdl -Relax some LRM rules to compile vendor libraries - -fpsl -vhdl -Allow PSL asserts in comments - --no-direct-drivers -vhdl -Disable direct drivers optimization - --syn-binding -vhdl -Use synthetizer rules for default bindings - -l -vhdl Joined Separate --l<filename> Put list of files for link in <filename> - -; -C was commented out, as it is already defined for C/C++. -;C -;vhdl -;Allow any character in comments - --mb-comments -vhdl -Allow any character in comments diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c deleted file mode 100644 index c19012e6e..000000000 --- a/ortho/gcc/ortho-lang.c +++ /dev/null @@ -1,2191 +0,0 @@ -/* GCC back-end for ortho - Copyright (C) 2002-1014 Tristan Gingold and al. - - GHDL 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, or (at your option) any later - version. - - GHDL 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 GCC; see the file COPYING. If not, write to the Free - Software Foundation, 59 Temple Place - Suite 330, Boston, MA - 02111-1307, USA. */ - -#include <stddef.h> -#include <math.h> -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "tm_p.h" -#include "defaults.h" -#include "ggc.h" -#include "diagnostic.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "toplev.h" -#include "opts.h" -#include "options.h" -#include "real.h" -#include "tree-iterator.h" -#include "function.h" -#include "cgraph.h" -#include "target.h" -#include "convert.h" -#include "tree-pass.h" -#include "tree-dump.h" - -/* Undefine for gcc-4.8 */ -#define GCC49 - -#ifdef GCC49 - -#include "print-tree.h" -#include "stringpool.h" -#include "stor-layout.h" -#include "varasm.h" - -/* Returns the number of FIELD_DECLs in TYPE. - Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ - -static int -fields_length (const_tree type) -{ - tree t = TYPE_FIELDS (type); - int count = 0; - - for (; t; t = DECL_CHAIN (t)) - if (TREE_CODE (t) == FIELD_DECL) - ++count; - - return count; -} - -#else - -// adapt gcc4.9 practice to gcc4.8 functions -bool -tree_fits_uhwi_p (const_tree t) -{ - return host_integerp (t, 1); -} - -unsigned HOST_WIDE_INT -tree_to_uhwi (const_tree t) -{ - return tree_low_cst (t, 1); -} - -#endif - -/* TODO: - * remove stmt_list_stack, save in if/case/loop block - * Re-add -v (if necessary) - */ - -static tree type_for_size (unsigned int precision, int unsignedp); - -const int tree_identifier_size = sizeof (struct tree_identifier); - -struct GTY(()) binding_level -{ - /* The BIND_EXPR node for this binding. */ - tree bind; - - /* The BLOCK node for this binding. */ - tree block; - - /* If true, stack must be saved (alloca is used). */ - int save_stack; - - /* Parent binding level. */ - struct binding_level *prev; - - /* Decls in this binding. */ - tree first_decl; - tree last_decl; - - /* Blocks in this binding. */ - tree first_block; - tree last_block; -}; - -/* The current binding level. */ -static GTY(()) struct binding_level *cur_binding_level = NULL; - -/* Chain of unused binding levels. */ -static GTY(()) struct binding_level *old_binding_levels = NULL; - -/* Chain of statements currently generated. */ -static GTY(()) tree cur_stmts = NULL_TREE; - -static void -push_binding (void) -{ - struct binding_level *res; - - if (old_binding_levels == NULL) - res = ggc_alloc_binding_level (); - else - { - res = old_binding_levels; - old_binding_levels = res->prev; - } - - /* Init. */ - res->first_decl = NULL_TREE; - res->last_decl = NULL_TREE; - - res->first_block = NULL_TREE; - res->last_block = NULL_TREE; - - res->save_stack = 0; - - res->bind = make_node (BIND_EXPR); - res->block = make_node (BLOCK); - BIND_EXPR_BLOCK (res->bind) = res->block; - TREE_SIDE_EFFECTS (res->bind) = true; - TREE_TYPE (res->bind) = void_type_node; - TREE_USED (res->block) = true; - - if (cur_binding_level != NULL) - { - /* Append the block created. */ - if (cur_binding_level->first_block == NULL) - cur_binding_level->first_block = res->block; - else - BLOCK_CHAIN (cur_binding_level->last_block) = res->block; - cur_binding_level->last_block = res->block; - - BLOCK_SUPERCONTEXT (res->block) = cur_binding_level->block; - } - - res->prev = cur_binding_level; - cur_binding_level = res; -} - -static void -push_decl (tree decl) -{ - DECL_CONTEXT (decl) = current_function_decl; - - if (cur_binding_level->first_decl == NULL) - cur_binding_level->first_decl = decl; - else - TREE_CHAIN (cur_binding_level->last_decl) = decl; - cur_binding_level->last_decl = decl; -} - -static tree -pop_binding (void) -{ - tree res; - struct binding_level *cur; - - cur = cur_binding_level; - res = cur->bind; - - if (cur->save_stack) - { - tree tmp_var; - tree save; - tree save_call; - tree restore; - tree t; - - /* Create an artificial var to save the stack pointer. */ - tmp_var = build_decl (input_location, VAR_DECL, NULL, ptr_type_node); - DECL_ARTIFICIAL (tmp_var) = true; - DECL_IGNORED_P (tmp_var) = true; - TREE_USED (tmp_var) = true; - push_decl (tmp_var); - - /* Create the save stmt. */ - save_call = build_call_expr - (builtin_decl_implicit (BUILT_IN_STACK_SAVE), 0); - save = build2 (MODIFY_EXPR, ptr_type_node, tmp_var, save_call); - TREE_SIDE_EFFECTS (save) = true; - - /* Create the restore stmt. */ - restore = build_call_expr - (builtin_decl_implicit (BUILT_IN_STACK_RESTORE), 1, tmp_var); - - /* Build a try-finally block. - The statement list is the block of current statements. */ - t = build2 (TRY_FINALLY_EXPR, void_type_node, cur_stmts, NULL_TREE); - TREE_SIDE_EFFECTS (t) = true; - - /* The finally block is the restore stmt. */ - append_to_statement_list (restore, &TREE_OPERAND (t, 1)); - - /* The body of the BIND_BLOCK is the save stmt, followed by the - try block. */ - BIND_EXPR_BODY (res) = NULL_TREE; - append_to_statement_list (save, &BIND_EXPR_BODY (res)); - append_to_statement_list (t, &BIND_EXPR_BODY (res)); - } - else - { - /* The body of the BIND_BLOCK is the statement block. */ - BIND_EXPR_BODY (res) = cur_stmts; - } - BIND_EXPR_VARS (res) = cur->first_decl; - - BLOCK_SUBBLOCKS (cur->block) = cur->first_block; - BLOCK_VARS (cur->block) = cur->first_decl; - - cur_binding_level = cur->prev; - cur->prev = old_binding_levels; - old_binding_levels = cur; - - return res; -} - -// naive conversion to new vec API following the wiki at -// http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec -// see also push_stmts, pop_stmts -static vec <tree> stmt_list_stack = vec<tree>(); - -static void -push_stmts (tree stmts) -{ - stmt_list_stack.safe_push(cur_stmts); - cur_stmts = stmts; -} - -static void -pop_stmts (void) -{ - cur_stmts = stmt_list_stack.pop(); -} - -static void -append_stmt (tree stmt) -{ - if (!EXPR_HAS_LOCATION (stmt)) - SET_EXPR_LOCATION (stmt, input_location); - TREE_SIDE_EFFECTS (stmt) = true; - append_to_statement_list (stmt, &cur_stmts); -} - -static GTY(()) tree top; - -static GTY(()) tree stack_alloc_function_ptr; - -static bool -global_bindings_p (void) -{ - return cur_binding_level->prev == NULL; -} - -static tree -pushdecl (tree t) -{ - //gcc_unreachable (); - // gcc4.8.2 we get here from build_common_builtin_nodes () call in ortho_init - return t; -} - -static tree -builtin_function (const char *name, - tree type, - int function_code, - enum built_in_class decl_class, - const char *library_name, - tree attrs ATTRIBUTE_UNUSED); - -REAL_VALUE_TYPE fp_const_p5; /* 0.5 */ -REAL_VALUE_TYPE fp_const_m_p5; /* -0.5 */ -REAL_VALUE_TYPE fp_const_zero; /* 0.0 */ - -static bool -ortho_init (void) -{ - tree n; - - input_location = BUILTINS_LOCATION; - - /* Create a global binding. */ - push_binding (); - - build_common_tree_nodes (0, 0); - - n = build_decl (input_location, - TYPE_DECL, get_identifier ("int"), integer_type_node); - push_decl (n); - n = build_decl (input_location, - TYPE_DECL, get_identifier ("char"), char_type_node); - push_decl (n); - - /* Create alloca builtin. */ - { - tree args_type = tree_cons (NULL_TREE, size_type_node, void_list_node); - tree func_type = build_function_type (ptr_type_node, args_type); - - set_builtin_decl - (BUILT_IN_ALLOCA, - builtin_function - ("__builtin_alloca", func_type, - BUILT_IN_ALLOCA, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - - stack_alloc_function_ptr = build1 - (ADDR_EXPR, - build_pointer_type (func_type), - builtin_decl_implicit (BUILT_IN_ALLOCA)); - } - - { - tree ptr_ftype = build_function_type (ptr_type_node, NULL_TREE); - - set_builtin_decl - (BUILT_IN_STACK_SAVE, - builtin_function - ("__builtin_stack_save", ptr_ftype, - BUILT_IN_STACK_SAVE, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - } - - { - tree ftype_ptr; - - ftype_ptr = build_function_type - (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, NULL_TREE)); - - set_builtin_decl - (BUILT_IN_STACK_RESTORE, - builtin_function - ("__builtin_stack_restore", ftype_ptr, - BUILT_IN_STACK_RESTORE, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - } - { - REAL_VALUE_TYPE v; - - REAL_VALUE_FROM_INT (v, 1, 0, DFmode); - real_ldexp (&fp_const_p5, &v, -1); - - REAL_VALUE_FROM_INT (v, -1, -1, DFmode); - real_ldexp (&fp_const_m_p5, &v, -1); - - REAL_VALUE_FROM_INT (fp_const_zero, 0, 0, DFmode); - } - - build_common_builtin_nodes (); - // FIXME: this MAY remove the need for creating the builtins above... - // Evaluate tree.c / build_common_builtin_nodes (); for each in turn. - - return true; -} - -static void -ortho_finish (void) -{ -} - -static unsigned int -ortho_option_lang_mask (void) -{ - return CL_vhdl; -} - -static bool -ortho_post_options (const char **pfilename) -{ - if (*pfilename == NULL || strcmp (*pfilename, "-") == 0) - *pfilename = "*stdin*"; - - /* Default hook. */ - lhd_post_options (pfilename); - - // This stops compile failures writing debug information when both -g and -O2 - // (or -O1, -O3 or -Os) options are present. - // Should really make it conditional on specific options - // FIXME : re-evaluate if this is still necessary with newer gccrevisions - dwarf_strict = 1; - - /* Run the back-end. */ - return false; -} - -extern "C" int lang_handle_option (const char *opt, const char *arg); - -static bool -ortho_handle_option (size_t code, const char *arg, - int value ATTRIBUTE_UNUSED, - int kind ATTRIBUTE_UNUSED, - location_t loc ATTRIBUTE_UNUSED, - const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) -{ - const char *opt; - - opt = cl_options[code].opt_text; - - switch (code) - { - case OPT__elab: - case OPT_l: - case OPT_c: - case OPT__anaelab: - /* Only a few options have a real arguments. */ - return lang_handle_option (opt, arg) != 0; - default: - /* The other options must have a joint argument. */ - if (arg != NULL) - { - size_t len1; - size_t len2; - char *nopt; - - len1 = strlen (opt); - len2 = strlen (arg); - nopt = (char *) alloca (len1 + len2 + 1); - memcpy (nopt, opt, len1); - memcpy (nopt + len1, arg, len2); - nopt[len1 + len2] = 0; - opt = nopt; - } - return lang_handle_option (opt, NULL) != 0; - } -} - -extern "C" int lang_parse_file (const char *filename); - -static void -ortho_parse_file (void) -{ - const char *filename; - - if (num_in_fnames == 0) - filename = NULL; - else - filename = in_fnames[0]; - - linemap_add (line_table, LC_ENTER, 0, filename ? filename :"*no-file*", 1); - input_location = linemap_line_start (line_table, 1, 252); - - if (!lang_parse_file (filename)) - errorcount++; - linemap_add (line_table, LC_LEAVE, 0, NULL, 1); -} - -/* Called by the back-end or by the front-end when the address of EXP - must be taken. - This function should found the base object (if any), and mark it as - addressable (via TREE_ADDRESSABLE). It may emit a warning if this - object cannot be addressable (front-end restriction). - Returns TRUE in case of success, FALSE in case of failure. - Note that the status is never checked by the back-end. */ -static bool -ortho_mark_addressable (tree exp) -{ - tree n; - - n = exp; - - while (1) - switch (TREE_CODE (n)) - { - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - TREE_ADDRESSABLE (n) = true; - return true; - - case COMPONENT_REF: - case ARRAY_REF: - case ARRAY_RANGE_REF: - n = TREE_OPERAND (n, 0); - break; - - case FUNCTION_DECL: - case CONSTRUCTOR: - TREE_ADDRESSABLE (n) = true; - return true; - - case INDIRECT_REF: - return true; - - default: - gcc_unreachable (); - } -} - -static tree -ortho_truthvalue_conversion (tree expr) -{ - tree expr_type; - tree t; - tree f; - - expr_type = TREE_TYPE (expr); - if (TREE_CODE (expr_type) != BOOLEAN_TYPE) - { - t = integer_one_node; - f = integer_zero_node; - } - else - { - f = TYPE_MIN_VALUE (expr_type); - t = TYPE_MAX_VALUE (expr_type); - } - - - switch (TREE_CODE (expr)) - { - case EQ_EXPR: - case NE_EXPR: - case LE_EXPR: - case GE_EXPR: - case LT_EXPR: - case GT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case ERROR_MARK: - return expr; - - case INTEGER_CST: - /* Not 0 is true. */ - return integer_zerop (expr) ? f : t; - - case REAL_CST: - return real_zerop (expr) ? f : t; - - default: - gcc_unreachable (); - } -} - -/* The following function has been copied and modified from c-convert.c. */ - -/* Change of width--truncation and extension of integers or reals-- - is represented with NOP_EXPR. Proper functioning of many things - assumes that no other conversions can be NOP_EXPRs. - - Conversion between integer and pointer is represented with CONVERT_EXPR. - Converting integer to real uses FLOAT_EXPR - and real to integer uses FIX_TRUNC_EXPR. - - Here is a list of all the functions that assume that widening and - narrowing is always done with a NOP_EXPR: - In convert.c, convert_to_integer. - In c-typeck.c, build_binary_op (boolean ops), and - c_common_truthvalue_conversion. - In expr.c: expand_expr, for operands of a MULT_EXPR. - In fold-const.c: fold. - In tree.c: get_narrower and get_unwidened. */ - -/* Subroutines of `convert'. */ - - - -/* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. */ - -tree -convert (tree type, tree expr) -{ - tree e = expr; - enum tree_code code = TREE_CODE (type); - const char *invalid_conv_diag; - - if (type == error_mark_node - || expr == error_mark_node - || TREE_TYPE (expr) == error_mark_node) - return error_mark_node; - - if ((invalid_conv_diag - = targetm.invalid_conversion (TREE_TYPE (expr), type))) - { - error (invalid_conv_diag); - return error_mark_node; - } - - if (type == TREE_TYPE (expr)) - return expr; - - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) - return fold_build1 (NOP_EXPR, type, expr); - if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) - return error_mark_node; - if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE || code == VOID_TYPE) - { - gcc_unreachable (); - } - if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) - return fold (convert_to_integer (type, e)); - if (code == BOOLEAN_TYPE) - { - tree t = ortho_truthvalue_conversion (expr); - if (TREE_CODE (t) == ERROR_MARK) - return t; - - /* If it returns a NOP_EXPR, we must fold it here to avoid - infinite recursion between fold () and convert (). */ - if (TREE_CODE (t) == NOP_EXPR) - return fold_build1 (NOP_EXPR, type, TREE_OPERAND (t, 0)); - else - return fold_build1 (NOP_EXPR, type, t); - } - if (code == POINTER_TYPE || code == REFERENCE_TYPE) - return fold (convert_to_pointer (type, e)); - if (code == REAL_TYPE) - return fold (convert_to_real (type, e)); - - gcc_unreachable (); -} - -/* Return a definition for a builtin function named NAME and whose data type - is TYPE. TYPE should be a function type with argument types. - FUNCTION_CODE tells later passes how to compile calls to this function. - See tree.h for its possible values. - - If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, - the name to be called if we can't opencode the function. If - ATTRS is nonzero, use that for the function's attribute list. */ -static tree -builtin_function (const char *name, - tree type, - int function_code, - enum built_in_class decl_class, - const char *library_name, - tree attrs ATTRIBUTE_UNUSED) -{ - tree decl = build_decl (input_location, - FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - if (library_name) - SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); - make_decl_rtl (decl); - DECL_BUILT_IN_CLASS (decl) = decl_class; - DECL_FUNCTION_CODE (decl) = (built_in_function) function_code; - DECL_SOURCE_LOCATION (decl) = input_location; - return decl; -} - -#ifndef MAX_BITS_PER_WORD -#define MAX_BITS_PER_WORD BITS_PER_WORD -#endif - -/* This variable keeps a table for types for each precision so that we only - allocate each of them once. Signed and unsigned types are kept separate. - */ -static GTY(()) tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2]; - -/* Return an integer type with the number of bits of precision given by - PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise - it is a signed type. */ -static tree -type_for_size (unsigned int precision, int unsignedp) -{ - tree t; - - if (precision <= MAX_BITS_PER_WORD - && signed_and_unsigned_types[precision][unsignedp] != NULL_TREE) - return signed_and_unsigned_types[precision][unsignedp]; - - if (unsignedp) - t = make_unsigned_type (precision); - else - t = make_signed_type (precision); - - if (precision <= MAX_BITS_PER_WORD) - signed_and_unsigned_types[precision][unsignedp] = t; - - return t; -} - -/* Return a data type that has machine mode MODE. UNSIGNEDP selects - an unsigned type; otherwise a signed type is returned. */ -static tree -type_for_mode (enum machine_mode mode, int unsignedp) -{ - if (SCALAR_INT_MODE_P (mode)) - return type_for_size (GET_MODE_BITSIZE (mode), unsignedp); - - if (mode == TYPE_MODE (void_type_node)) - return void_type_node; - - if (mode == TYPE_MODE (float_type_node)) - return float_type_node; - - if (mode == TYPE_MODE (double_type_node)) - return double_type_node; - - if (mode == TYPE_MODE (long_double_type_node)) - return long_double_type_node; - - return NULL_TREE; -} - -#undef LANG_HOOKS_NAME -#define LANG_HOOKS_NAME "vhdl" -#undef LANG_HOOKS_IDENTIFIER_SIZE -#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) -#undef LANG_HOOKS_INIT -#define LANG_HOOKS_INIT ortho_init -#undef LANG_HOOKS_FINISH -#define LANG_HOOKS_FINISH ortho_finish -#undef LANG_HOOKS_OPTION_LANG_MASK -#define LANG_HOOKS_OPTION_LANG_MASK ortho_option_lang_mask -#undef LANG_HOOKS_HANDLE_OPTION -#define LANG_HOOKS_HANDLE_OPTION ortho_handle_option -#undef LANG_HOOKS_POST_OPTIONS -#define LANG_HOOKS_POST_OPTIONS ortho_post_options -#undef LANG_HOOKS_HONOR_READONLY -#define LANG_HOOKS_HONOR_READONLY true -#undef LANG_HOOKS_MARK_ADDRESSABLE -#define LANG_HOOKS_MARK_ADDRESSABLE ortho_mark_addressable -#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION -#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION ortho_expand_function - -#undef LANG_HOOKS_TYPE_FOR_MODE -#define LANG_HOOKS_TYPE_FOR_MODE type_for_mode -#undef LANG_HOOKS_TYPE_FOR_SIZE -#define LANG_HOOKS_TYPE_FOR_SIZE type_for_size -#undef LANG_HOOKS_SIGNED_TYPE -#define LANG_HOOKS_SIGNED_TYPE signed_type -#undef LANG_HOOKS_UNSIGNED_TYPE -#define LANG_HOOKS_UNSIGNED_TYPE unsigned_type -#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE -#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE signed_or_unsigned_type -#undef LANG_HOOKS_PARSE_FILE -#define LANG_HOOKS_PARSE_FILE ortho_parse_file - -#define pushlevel lhd_do_nothing_i -#define poplevel lhd_do_nothing_iii_return_null_tree -#define set_block lhd_do_nothing_t -#undef LANG_HOOKS_GETDECLS -#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v - -struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - -union GTY((desc ("0"), - chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL"))) - lang_tree_node -{ - union tree_node GTY((tag ("0"), - desc ("tree_node_structure (&%h)"))) generic; -}; - -/* GHDL does not use the lang_decl and lang_type. - - FIXME: the variable_size annotation here is needed because these types are - variable-sized in some other front-ends. Due to gengtype deficiency, the - GTY options of such types have to agree across all front-ends. */ - -struct GTY((variable_size)) lang_type { char dummy; }; -struct GTY((variable_size)) lang_decl { char dummy; }; - -struct GTY(()) language_function -{ - char dummy; -}; - - -extern "C" { - -struct GTY(()) chain_constr_type -{ - tree first; - tree last; -}; - -static void -chain_init (struct chain_constr_type *constr) -{ - constr->first = NULL_TREE; - constr->last = NULL_TREE; -} - -static void -chain_append (struct chain_constr_type *constr, tree el) -{ - if (constr->first == NULL_TREE) - { - gcc_assert (constr->last == NULL_TREE); - constr->first = el; - } - else - TREE_CHAIN (constr->last) = el; - constr->last = el; -} - -struct GTY(()) list_constr_type -{ - tree first; - tree last; -}; - -static void -list_init (struct list_constr_type *constr) -{ - constr->first = NULL_TREE; - constr->last = NULL_TREE; -} - -static void -ortho_list_append (struct list_constr_type *constr, tree el) -{ - tree res; - - res = tree_cons (NULL_TREE, el, NULL_TREE); - if (constr->first == NULL_TREE) - constr->first = res; - else - TREE_CHAIN (constr->last) = res; - constr->last = res; -} - -enum ON_op_kind { - /* Not an operation; invalid. */ - ON_Nil, - - /* Dyadic operations. */ - ON_Add_Ov, - ON_Sub_Ov, - ON_Mul_Ov, - ON_Div_Ov, - ON_Rem_Ov, - ON_Mod_Ov, - - /* Binary operations. */ - ON_And, - ON_Or, - ON_Xor, - - /* Monadic operations. */ - ON_Not, - ON_Neg_Ov, - ON_Abs_Ov, - - /* Comparaisons */ - ON_Eq, - ON_Neq, - ON_Le, - ON_Lt, - ON_Ge, - ON_Gt, - - ON_LAST -}; - -static enum tree_code ON_op_to_TREE_CODE[ON_LAST] = { - ERROR_MARK, - - PLUS_EXPR, - MINUS_EXPR, - MULT_EXPR, - ERROR_MARK, - TRUNC_MOD_EXPR, - FLOOR_MOD_EXPR, - - BIT_AND_EXPR, - BIT_IOR_EXPR, - BIT_XOR_EXPR, - - BIT_NOT_EXPR, - NEGATE_EXPR, - ABS_EXPR, - - EQ_EXPR, - NE_EXPR, - LE_EXPR, - LT_EXPR, - GE_EXPR, - GT_EXPR, -}; - -tree -new_dyadic_op (enum ON_op_kind kind, tree left, tree right) -{ - tree left_type; - enum tree_code code; - - /* Truncate to avoid representations issue. */ - kind = (enum ON_op_kind)((unsigned)kind & 0xff); - - left_type = TREE_TYPE (left); - gcc_assert (left_type == TREE_TYPE (right)); - - switch (kind) - { - case ON_Div_Ov: - if (TREE_CODE (left_type) == REAL_TYPE) - code = RDIV_EXPR; - else - code = TRUNC_DIV_EXPR; - break; - default: - code = ON_op_to_TREE_CODE[kind]; - break; - } - return build2 (code, left_type, left, right); -} - -tree -new_monadic_op (enum ON_op_kind kind, tree operand) -{ - /* Truncate to avoid representations issue. */ - kind = (enum ON_op_kind)((unsigned)kind & 0xff); - - return build1 (ON_op_to_TREE_CODE[kind], TREE_TYPE (operand), operand); -} - -tree -new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) -{ - gcc_assert (TREE_CODE (ntype) == BOOLEAN_TYPE); - gcc_assert (TREE_TYPE (left) == TREE_TYPE (right)); - - /* Truncate to avoid representations issue. */ - kind = (enum ON_op_kind)((unsigned)kind & 0xff); - - return build2 (ON_op_to_TREE_CODE[kind], ntype, left, right); -} - -tree -new_convert_ov (tree val, tree rtype) -{ - tree val_type; - enum tree_code val_code; - enum tree_code rtype_code; - enum tree_code code; - - val_type = TREE_TYPE (val); - if (val_type == rtype) - return val; - - /* FIXME: check conversions. */ - val_code = TREE_CODE (val_type); - rtype_code = TREE_CODE (rtype); - if (val_code == POINTER_TYPE && rtype_code == POINTER_TYPE) - code = NOP_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == REAL_TYPE && rtype_code == INTEGER_TYPE) - { - /* REAL to INTEGER - Gcc only handles FIX_TRUNC_EXPR, but we need rounding. */ - tree m_p5; - tree p5; - tree zero; - tree saved; - tree comp; - tree adj; - tree res; - - m_p5 = build_real (val_type, fp_const_m_p5); - p5 = build_real (val_type, fp_const_p5); - zero = build_real (val_type, fp_const_zero); - saved = save_expr (val); - comp = build2 (GE_EXPR, integer_type_node, saved, zero); - /* FIXME: instead of res = res + (comp ? .5 : -.5) - do: res = res (comp ? + : -) .5 */ - adj = build3 (COND_EXPR, val_type, comp, p5, m_p5); - res = build2 (PLUS_EXPR, val_type, saved, adj); - res = build1 (FIX_TRUNC_EXPR, rtype, res); - return res; - } - else if (val_code == INTEGER_TYPE && rtype_code == ENUMERAL_TYPE) - code = CONVERT_EXPR; - else if (val_code == ENUMERAL_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == REAL_TYPE) - code = FLOAT_EXPR; - else if (val_code == BOOLEAN_TYPE && rtype_code == BOOLEAN_TYPE) - code = NOP_EXPR; - else if (val_code == BOOLEAN_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == BOOLEAN_TYPE) - code = NOP_EXPR; - else if (val_code == REAL_TYPE && rtype_code == REAL_TYPE) - code = NOP_EXPR; - else - gcc_unreachable (); - - return build1 (code, rtype, val); -} - -tree -new_alloca (tree rtype, tree size) -{ - tree res; - - /* Must save stack except when at function level. */ - if (cur_binding_level->prev != NULL - && cur_binding_level->prev->prev != NULL) - cur_binding_level->save_stack = 1; - - res = build_call_nary (ptr_type_node, stack_alloc_function_ptr, - 1, fold_convert (size_type_node, size)); - return fold_convert (rtype, res); -} - -tree -new_signed_literal (tree ltype, long long value) -{ - tree res; - HOST_WIDE_INT lo; - HOST_WIDE_INT hi; - - lo = value; - hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (ltype, lo, hi); - return res; -} - -tree -new_unsigned_literal (tree ltype, unsigned long long value) -{ - tree res; - unsigned HOST_WIDE_INT lo; - unsigned HOST_WIDE_INT hi; - - lo = value; - hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (ltype, lo, hi); - return res; -} - -tree -new_null_access (tree ltype) -{ - tree res; - - res = build_int_cst_wide (ltype, 0, 0); - return res; -} - -tree -new_float_literal (tree ltype, double value) -{ - signed long long s; - double frac; - int ex; - REAL_VALUE_TYPE r_sign; - REAL_VALUE_TYPE r_exp; - REAL_VALUE_TYPE r; - tree res; - HOST_WIDE_INT lo; - HOST_WIDE_INT hi; - - frac = frexp (value, &ex); - - s = ldexp (frac, 60); - lo = s; - hi = (s >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (long_integer_type_node, lo, hi); - REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode); - real_2expN (&r_exp, ex - 60, DFmode); - real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp); - res = build_real (ltype, r); - return res; -} - -struct GTY(()) o_element_list -{ - tree res; - struct chain_constr_type chain; -}; - -void -new_uncomplete_record_type (tree *res) -{ - *res = make_node (RECORD_TYPE); -} - -void -start_record_type (struct o_element_list *elements) -{ - elements->res = make_node (RECORD_TYPE); - chain_init (&elements->chain); -} - -void -start_uncomplete_record_type (tree res, struct o_element_list *elements) -{ - elements->res = res; - chain_init (&elements->chain); -} - -static void -new_record_union_field (struct o_element_list *list, - tree *el, - tree ident, - tree etype) -{ - tree res; - - res = build_decl (input_location, - FIELD_DECL, ident, etype); - DECL_CONTEXT (res) = list->res; - chain_append (&list->chain, res); - *el = res; -} - -void -new_record_field (struct o_element_list *list, - tree *el, - tree ident, - tree etype) -{ - return new_record_union_field (list, el, ident, etype); -} - -void -finish_record_type (struct o_element_list *elements, tree *res) -{ - TYPE_FIELDS (elements->res) = elements->chain.first; - layout_type (elements->res); - *res = elements->res; - - if (TYPE_NAME (elements->res) != NULL_TREE) - { - /* The type was completed. */ - rest_of_type_compilation (elements->res, 1); - } -} - -void -start_union_type (struct o_element_list *elements) -{ - elements->res = make_node (UNION_TYPE); - chain_init (&elements->chain); -} - -void -new_union_field (struct o_element_list *elements, - tree *el, - tree ident, - tree etype) -{ - return new_record_union_field (elements, el, ident, etype); -} - -void -finish_union_type (struct o_element_list *elements, tree *res) -{ - TYPE_FIELDS (elements->res) = elements->chain.first; - layout_type (elements->res); - *res = elements->res; -} - -tree -new_unsigned_type (int size) -{ - return make_unsigned_type (size); -} - -tree -new_signed_type (int size) -{ - return make_signed_type (size); -} - -tree -new_float_type (void) -{ - tree res; - - res = make_node (REAL_TYPE); - TYPE_PRECISION (res) = DOUBLE_TYPE_SIZE; - layout_type (res); - return res; -} - -tree -new_access_type (tree dtype) -{ - tree res; - - if (dtype == NULL_TREE) - { - res = make_node (POINTER_TYPE); - TREE_TYPE (res) = NULL_TREE; - /* Seems necessary. */ - SET_TYPE_MODE (res, Pmode); - layout_type (res); - return res; - } - else - return build_pointer_type (dtype); -} - -void -finish_access_type (tree atype, tree dtype) -{ - gcc_assert (TREE_CODE (atype) == POINTER_TYPE - && TREE_TYPE (atype) == NULL_TREE); - - TREE_TYPE (atype) = dtype; -} - -tree -new_array_type (tree el_type, tree index_type) -{ - return build_array_type (el_type, index_type); -} - - -tree -new_constrained_array_type (tree atype, tree length) -{ - tree range_type; - tree index_type; - tree len; - tree one; - tree res; - - index_type = TYPE_DOMAIN (atype); - if (integer_zerop (length)) - { - /* Handle null array, by creating a one-length array... */ - len = size_zero_node; - } - else - { - one = build_int_cstu (index_type, 1); - len = build2 (MINUS_EXPR, index_type, length, one); - len = fold (len); - } - - range_type = build_range_type (index_type, size_zero_node, len); - res = build_array_type (TREE_TYPE (atype), range_type); - - /* Constrained arrays are *always* a subtype of its array type. - Just copy alias set. */ - TYPE_ALIAS_SET (res) = get_alias_set (atype); - return res; -} - -void -new_boolean_type (tree *res, - tree false_id ATTRIBUTE_UNUSED, tree *false_e, - tree true_id ATTRIBUTE_UNUSED, tree *true_e) -{ - *res = make_node (BOOLEAN_TYPE); - TYPE_PRECISION (*res) = 1; - fixup_unsigned_type (*res); - *false_e = TYPE_MIN_VALUE (*res); - *true_e = TYPE_MAX_VALUE (*res); -} - -struct o_enum_list -{ - tree res; - struct chain_constr_type chain; - int num; - int size; -}; - -void -start_enum_type (struct o_enum_list *list, int size) -{ - list->res = make_node (ENUMERAL_TYPE); - // as of gcc4.8, TYPE_PRECISION of 0 is rigorously enforced! - TYPE_PRECISION(list->res) = size; - chain_init (&list->chain); - list->num = 0; - list->size = size; -} - -void -new_enum_literal (struct o_enum_list *list, tree ident, tree *res) -{ - *res = build_int_cstu (list->res, (HOST_WIDE_INT)(list->num)); - chain_append (&list->chain, tree_cons (ident, *res, NULL_TREE)); - list->num++; -} - -void -finish_enum_type (struct o_enum_list *list, tree *res) -{ - *res = list->res; - TYPE_VALUES (*res) = list->chain.first; - TYPE_UNSIGNED (*res) = 1; - TYPE_PRECISION (*res) = list->size; - set_min_and_max_values_for_integral_type (*res, list->size, 1); - layout_type (*res); -} - -struct GTY(()) o_record_aggr_list -{ - /* Type of the record. */ - tree atype; - /* Type of the next field to be added. */ - tree field; - /* Vector of elements. */ - // VEC(constructor_elt,gc) *elts; - vec<constructor_elt,va_gc> *elts; -}; - -void -start_record_aggr (struct o_record_aggr_list *list, tree atype) -{ - list->atype = atype; - list->field = TYPE_FIELDS (atype); - //list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype)); - vec_alloc(list->elts, fields_length (atype)); -} - -void -new_record_aggr_el (struct o_record_aggr_list *list, tree value) -{ - CONSTRUCTOR_APPEND_ELT (list->elts, list->field, value); - list->field = TREE_CHAIN (list->field); -} - -void -finish_record_aggr (struct o_record_aggr_list *list, tree *res) -{ - *res = build_constructor (list->atype, list->elts); -} - -struct GTY(()) o_array_aggr_list -{ - tree atype; - /* Vector of elements. */ - vec<constructor_elt,va_gc> *elts; -}; - -void -start_array_aggr (struct o_array_aggr_list *list, tree atype) -{ - tree nelts; - unsigned HOST_WIDE_INT n; - - list->atype = atype; - list->elts = NULL; - - nelts = array_type_nelts (atype); - gcc_assert (nelts != NULL_TREE && tree_fits_uhwi_p (nelts)); - - n = tree_to_uhwi (nelts) + 1; - vec_alloc(list->elts, n); -} - -void -new_array_aggr_el (struct o_array_aggr_list *list, tree value) -{ - CONSTRUCTOR_APPEND_ELT (list->elts, NULL_TREE, value); -} - -void -finish_array_aggr (struct o_array_aggr_list *list, tree *res) -{ - *res = build_constructor (list->atype, list->elts); -} - - -tree -new_union_aggr (tree atype, tree field, tree value) -{ - tree res; - - res = build_constructor_single (atype, field, value); - TREE_CONSTANT (res) = 1; - return res; -} - -tree -new_indexed_element (tree arr, tree index) -{ - ortho_mark_addressable (arr); - return build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (arr)), - arr, index, NULL_TREE, NULL_TREE); -} - -tree -new_slice (tree arr, tree res_type, tree index) -{ -#if 0 - tree res; - tree el_ptr_type; - tree el_type; - tree res_ptr_type; -#endif - - /* *((RES_TYPE *)(&ARR[INDEX])) - convert ARR to a pointer, add index, and reconvert to array ? */ - gcc_assert (TREE_CODE (res_type) == ARRAY_TYPE); - - ortho_mark_addressable (arr); - return build4 (ARRAY_RANGE_REF, res_type, arr, index, NULL_TREE, NULL_TREE); -#if 0 - el_type = TREE_TYPE (TREE_TYPE (arr)); - el_ptr_type = build_pointer_type (el_type); - - res = build4 (ARRAY_REF, el_type, arr, index, NULL_TREE, NULL_TREE); - res = build1 (ADDR_EXPR, el_ptr_type, res); - res_ptr_type = build_pointer_type (res_type); - res = build1 (NOP_EXPR, res_ptr_type, res); - res = build1 (INDIRECT_REF, res_type, res); - return res; -#endif -} - -tree -new_selected_element (tree rec, tree el) -{ - tree res; - - gcc_assert (TREE_CODE (TREE_TYPE (rec)) == RECORD_TYPE); - - res = build3 (COMPONENT_REF, TREE_TYPE (el), rec, el, NULL_TREE); - return res; -} - -tree -new_access_element (tree acc) -{ - tree acc_type; - - acc_type = TREE_TYPE (acc); - gcc_assert (TREE_CODE (acc_type) == POINTER_TYPE); - - return build1 (INDIRECT_REF, TREE_TYPE (acc_type), acc); -} - -tree -new_offsetof (tree rec_type, tree field, tree rtype) -{ - tree off; - tree bit_off; - HOST_WIDE_INT pos; - tree res; - - gcc_assert (DECL_CONTEXT (field) == rec_type); - - off = DECL_FIELD_OFFSET (field); - - /* The offset must be a constant. */ - gcc_assert (tree_fits_uhwi_p (off)); - - bit_off = DECL_FIELD_BIT_OFFSET (field); - - /* The offset must be a constant. */ - gcc_assert (tree_fits_uhwi_p (bit_off)); - - pos = TREE_INT_CST_LOW (off) - + (TREE_INT_CST_LOW (bit_off) / BITS_PER_UNIT); - res = build_int_cstu (rtype, pos); - return res; -} - -tree -new_sizeof (tree atype, tree rtype) -{ - tree size; - - size = TYPE_SIZE_UNIT (atype); - - return fold (build1 (NOP_EXPR, rtype, size)); -} - -tree -new_alignof (tree atype, tree rtype) -{ - return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); -} - -static tree -ortho_build_addr (tree lvalue, tree atype) -{ - tree res; - - if (TREE_CODE (lvalue) == INDIRECT_REF) - { - /* ADDR_REF(INDIRECT_REF(x)) -> x. */ - res = TREE_OPERAND (lvalue, 0); - } - else - { - tree ptr_type; - - /* &base[off] -> base+off. */ - ortho_mark_addressable (lvalue); - - if (TREE_TYPE (lvalue) != TREE_TYPE (atype)) - ptr_type = build_pointer_type (TREE_TYPE (lvalue)); - else - ptr_type = atype; - res = fold_build1 (ADDR_EXPR, ptr_type, lvalue); - } - - if (TREE_TYPE (res) != atype) - res = fold_build1 (NOP_EXPR, atype, res); - - return res; -} - -tree -new_unchecked_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_global_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_global_unchecked_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -/* Return a pointer to function FUNC. */ -static tree -build_function_ptr (tree func) -{ - return build1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (func)), func); -} - -tree -new_subprogram_address (tree subprg, tree atype) -{ - return fold (build1 (NOP_EXPR, atype, build_function_ptr (subprg))); -} - -tree -new_value (tree lvalue) -{ - return lvalue; -} - -void -new_debug_line_decl (int line) -{ - input_location = linemap_line_start (line_table, line, 252); -} - -void -new_type_decl (tree ident, tree atype) -{ - tree decl; - - TYPE_NAME (atype) = ident; - decl = build_decl (input_location, TYPE_DECL, ident, atype); - TYPE_STUB_DECL (atype) = decl; - push_decl (decl); - /* - if Get_TYPE_SIZE (Ttype) /= NULL_TREE then - -- Do not generate debug info for uncompleted types. - Rest_Of_Type_Compilation (Ttype, C_True); - end if; - */ -} - -enum o_storage { o_storage_external, - o_storage_public, - o_storage_private, - o_storage_local }; - -static void -set_storage (tree Node, enum o_storage storage) -{ - switch (storage) - { - case o_storage_external: - DECL_EXTERNAL (Node) = 1; - TREE_PUBLIC (Node) = 1; - TREE_STATIC (Node) = 0; - break; - case o_storage_public: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 1; - TREE_STATIC (Node) = 1; - break; - case o_storage_private: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 0; - TREE_STATIC (Node) = 1; - break; - case o_storage_local: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 0; - TREE_STATIC (Node) = 0; - break; - } -} - -void -new_const_decl (tree *res, tree ident, enum o_storage storage, tree atype) -{ - tree cst; - - cst = build_decl (input_location, VAR_DECL, ident, atype); - set_storage (cst, storage); - TREE_READONLY (cst) = 1; - push_decl (cst); - switch (storage) - { - case o_storage_local: - gcc_unreachable (); - case o_storage_external: - /* We are at top level if Current_Function_Decl is null. */ - rest_of_decl_compilation - (cst, current_function_decl == NULL_TREE, 0); - break; - case o_storage_public: - case o_storage_private: - break; - } - *res = cst; -} - -void -start_const_value (tree *cst ATTRIBUTE_UNUSED) -{ -} - -void -finish_const_value (tree *cst, tree val) -{ - DECL_INITIAL (*cst) = val; - TREE_CONSTANT (val) = 1; - TREE_STATIC (*cst) = 1; - rest_of_decl_compilation - (*cst, current_function_decl == NULL_TREE, 0); -} - -void -new_var_decl (tree *res, tree ident, enum o_storage storage, tree atype) -{ - tree var; - - var = build_decl (input_location, VAR_DECL, ident, atype); - if (current_function_decl != NULL_TREE) - { - /* Local variable. */ - TREE_STATIC (var) = 0; - DECL_EXTERNAL (var) = 0; - TREE_PUBLIC (var) = 0; - } - else - set_storage (var, storage); - - push_decl (var); - - if (current_function_decl == NULL_TREE) - rest_of_decl_compilation (var, 1, 0); - - *res = var; -} - -struct GTY(()) o_inter_list -{ - tree ident; - enum o_storage storage; - - /* Return type. */ - tree rtype; - - /* List of parameter types. */ - struct list_constr_type param_list; - - /* Chain of parameters declarations. */ - struct chain_constr_type param_chain; -}; - -void -start_function_decl (struct o_inter_list *interfaces, - tree ident, - enum o_storage storage, - tree rtype) -{ - interfaces->ident = ident; - interfaces->storage = storage; - interfaces->rtype = rtype; - chain_init (&interfaces->param_chain); - list_init (&interfaces->param_list); -} - -void -start_procedure_decl (struct o_inter_list *interfaces, - tree ident, - enum o_storage storage) -{ - start_function_decl (interfaces, ident, storage, void_type_node); -} - -void -new_interface_decl (struct o_inter_list *interfaces, - tree *res, - tree ident, - tree atype) -{ - tree r; - - r = build_decl (input_location, PARM_DECL, ident, atype); - /* DECL_CONTEXT (Res, Xxx); */ - - /* Do type conversion: convert boolean and enums to int */ - switch (TREE_CODE (atype)) - { - case ENUMERAL_TYPE: - case BOOLEAN_TYPE: - DECL_ARG_TYPE (r) = integer_type_node; - default: - DECL_ARG_TYPE (r) = atype; - } - - layout_decl (r, 0); - - chain_append (&interfaces->param_chain, r); - ortho_list_append (&interfaces->param_list, atype); - *res = r; -} - -void -finish_subprogram_decl (struct o_inter_list *interfaces, tree *res) -{ - tree decl; - tree result; - tree parm; - int is_global; - - /* Append a void type in the parameter types chain, so that the function - is known not be have variables arguments. */ - ortho_list_append (&interfaces->param_list, void_type_node); - - decl = build_decl (input_location, FUNCTION_DECL, interfaces->ident, - build_function_type (interfaces->rtype, - interfaces->param_list.first)); - DECL_SOURCE_LOCATION (decl) = input_location; - - is_global = current_function_decl == NULL_TREE - || interfaces->storage == o_storage_external; - if (is_global) - set_storage (decl, interfaces->storage); - else - { - /* A nested subprogram. */ - DECL_EXTERNAL (decl) = 0; - TREE_PUBLIC (decl) = 0; - } - /* The function exist in static storage. */ - TREE_STATIC (decl) = 1; - DECL_INITIAL (decl) = error_mark_node; - TREE_ADDRESSABLE (decl) = 1; - - /* Declare the result. - FIXME: should be moved in start_function_body. */ - result = build_decl (input_location, - RESULT_DECL, NULL_TREE, interfaces->rtype); - DECL_RESULT (decl) = result; - DECL_CONTEXT (result) = decl; - - DECL_ARGUMENTS (decl) = interfaces->param_chain.first; - /* Set DECL_CONTEXT of parameters. */ - for (parm = interfaces->param_chain.first; - parm != NULL_TREE; - parm = TREE_CHAIN (parm)) - DECL_CONTEXT (parm) = decl; - - push_decl (decl); - - /* External functions are never nested. - Remove their context, which is set by push_decl. */ - if (interfaces->storage == o_storage_external) - DECL_CONTEXT (decl) = NULL_TREE; - - if (is_global) - rest_of_decl_compilation (decl, 1, 0); - - *res = decl; -} - -void -start_subprogram_body (tree func) -{ - gcc_assert (current_function_decl == DECL_CONTEXT (func)); - current_function_decl = func; - - /* The function is not anymore external. */ - DECL_EXTERNAL (func) = 0; - - push_stmts (alloc_stmt_list ()); - push_binding (); -} - -void -finish_subprogram_body (void) -{ - tree bind; - tree func; - tree parent; - - bind = pop_binding (); - pop_stmts (); - - func = current_function_decl; - DECL_INITIAL (func) = BIND_EXPR_BLOCK (bind); - DECL_SAVED_TREE (func) = bind; - - /* Initialize the RTL code for the function. */ - allocate_struct_function (func, false); - - /* Store the end of the function. */ - cfun->function_end_locus = input_location; - - parent = DECL_CONTEXT (func); - - if (parent != NULL) - cgraph_get_create_node (func); - else - cgraph_finalize_function (func, false); - - current_function_decl = parent; - set_cfun (NULL); -} - - -void -new_debug_line_stmt (int line) -{ - input_location = linemap_line_start (line_table, line, 252); -} - -void -start_declare_stmt (void) -{ - push_stmts (alloc_stmt_list ()); - push_binding (); -} - -void -finish_declare_stmt (void) -{ - tree bind; - - bind = pop_binding (); - pop_stmts (); - append_stmt (bind); -} - - -struct GTY(()) o_assoc_list -{ - tree subprg; - vec<tree, va_gc> *vecptr; -}; - -void -start_association (struct o_assoc_list *assocs, tree subprg) -{ - assocs->subprg = subprg; - assocs->vecptr = NULL; -} - -void -new_association (struct o_assoc_list *assocs, tree val) -{ - vec_safe_push(assocs->vecptr, val); -} - -tree -new_function_call (struct o_assoc_list *assocs) -{ - return build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->vecptr); -} - -void -new_procedure_call (struct o_assoc_list *assocs) -{ - tree res; - - res = build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->vecptr); - TREE_SIDE_EFFECTS (res) = 1; - append_stmt (res); -} - -void -new_assign_stmt (tree target, tree value) -{ - tree n; - - n = build2 (MODIFY_EXPR, TREE_TYPE (target), target, value); - TREE_SIDE_EFFECTS (n) = 1; - append_stmt (n); -} - -void -new_func_return_stmt (tree value) -{ - tree assign; - tree stmt; - tree res; - - res = DECL_RESULT (current_function_decl); - assign = build2 (MODIFY_EXPR, TREE_TYPE (value), res, value); - TREE_SIDE_EFFECTS (assign) = 1; - stmt = build1 (RETURN_EXPR, void_type_node, assign); - TREE_SIDE_EFFECTS (stmt) = 1; - append_stmt (stmt); -} - -void -new_proc_return_stmt (void) -{ - tree stmt; - - stmt = build1 (RETURN_EXPR, void_type_node, NULL_TREE); - TREE_SIDE_EFFECTS (stmt) = 1; - append_stmt (stmt); -} - - -struct GTY(()) o_if_block -{ - tree stmt; -}; - -void -start_if_stmt (struct o_if_block *block, tree cond) -{ - tree stmt; - tree stmts; - - stmts = alloc_stmt_list (); - stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE); - block->stmt = stmt; - append_stmt (stmt); - push_stmts (stmts); -} - -void -new_else_stmt (struct o_if_block *block) -{ - tree stmts; - - pop_stmts (); - stmts = alloc_stmt_list (); - COND_EXPR_ELSE (block->stmt) = stmts; - push_stmts (stmts); -} - -void -finish_if_stmt (struct o_if_block *block ATTRIBUTE_UNUSED) -{ - pop_stmts (); -} - - -struct GTY(()) o_snode -{ - tree beg_label; - tree end_label; -}; - -/* Create an artificial label. */ -static tree -build_label (void) -{ - tree res; - - res = build_decl (input_location, LABEL_DECL, NULL_TREE, void_type_node); - DECL_CONTEXT (res) = current_function_decl; - DECL_ARTIFICIAL (res) = 1; - return res; -} - -void -start_loop_stmt (struct o_snode *label) -{ - tree stmt; - - label->beg_label = build_label (); - - stmt = build1 (LABEL_EXPR, void_type_node, label->beg_label); - append_stmt (stmt); - - label->end_label = build_label (); -} - -void -finish_loop_stmt (struct o_snode *label) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, label->beg_label); - TREE_USED (label->beg_label) = 1; - append_stmt (stmt); - /* Emit the end label only if there is a goto to it. - (Return may be used to exit from the loop). */ - if (TREE_USED (label->end_label)) - { - stmt = build1 (LABEL_EXPR, void_type_node, label->end_label); - append_stmt (stmt); - } -} - -void -new_exit_stmt (struct o_snode *l) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, l->end_label); - append_stmt (stmt); - TREE_USED (l->end_label) = 1; -} - -void -new_next_stmt (struct o_snode *l) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, l->beg_label); - TREE_USED (l->beg_label) = 1; - append_stmt (stmt); -} - -struct GTY(()) o_case_block -{ - tree case_type; - tree end_label; - int add_break; -}; - -void -start_case_stmt (struct o_case_block *block, tree value) -{ - tree stmt; - tree stmts; - - block->case_type = TREE_TYPE (value); - block->end_label = build_label (); - block->add_break = 0; - stmts = alloc_stmt_list (); - stmt = build3 (SWITCH_EXPR, block->case_type, value, stmts, NULL_TREE); - append_stmt (stmt); - push_stmts (stmts); -} - -void -start_choice (struct o_case_block *block) -{ - tree stmt; - if (block->add_break) - { - stmt = build1 (GOTO_EXPR, block->case_type, block->end_label); - append_stmt (stmt); - - block->add_break = 0; - } -} - -void -new_expr_choice (struct o_case_block *block ATTRIBUTE_UNUSED, tree expr) -{ - tree stmt; - - stmt = build_case_label - (expr, NULL_TREE, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -new_range_choice (struct o_case_block *block ATTRIBUTE_UNUSED, - tree low, tree high) -{ - tree stmt; - - stmt = build_case_label - (low, high, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -new_default_choice (struct o_case_block *block ATTRIBUTE_UNUSED) -{ - tree stmt; - - stmt = build_case_label - (NULL_TREE, NULL_TREE, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -finish_choice (struct o_case_block *block) -{ - block->add_break = 1; -} - -void -finish_case_stmt (struct o_case_block *block) -{ - tree stmt; - - pop_stmts (); - stmt = build1 (LABEL_EXPR, void_type_node, block->end_label); - append_stmt (stmt); -} - -bool -compare_identifier_string (tree id, const char *str, size_t len) -{ - if (IDENTIFIER_LENGTH (id) != len) - return false; - if (!memcmp (IDENTIFIER_POINTER (id), str, len)) - return true; - else - return false; -} - -void -get_identifier_string (tree id, const char **str, int *len) -{ - *len = IDENTIFIER_LENGTH (id); - *str = IDENTIFIER_POINTER (id); -} - -// C linkage wrappers for two (now C++) functions so that -// Ada code can call them without name mangling -tree get_identifier_with_length_c (const char *c, size_t s) -{ - return get_identifier_with_length(c, s); -} - -int toplev_main_c (int argc, char **argv) -{ - return toplev_main(argc, argv); -} - -void -debug_tree_c (tree expr) -{ - warning (OPT_Wall, "Debug tree"); - debug_tree (expr); -} - -} // end extern "C" - -#include "debug.h" -#include "gt-vhdl-ortho-lang.h" -#include "gtype-vhdl.h" diff --git a/ortho/gcc/ortho_gcc-main.adb b/ortho/gcc/ortho_gcc-main.adb deleted file mode 100644 index 70c8a7f79..000000000 --- a/ortho/gcc/ortho_gcc-main.adb +++ /dev/null @@ -1,42 +0,0 @@ --- GCC back-end for ortho --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; -with Ortho_Gcc_Front; -with Ada.Command_Line; use Ada.Command_Line; - -procedure Ortho_Gcc.Main -is - gnat_argc : Integer; - gnat_argv : System.Address; - - pragma Import (C, gnat_argc); - pragma Import (C, gnat_argv); - - function Toplev_Main (Argc : Integer; Argv : System.Address) - return Integer; - pragma Import (C, Toplev_Main, "toplev_main_c"); - - Status : Exit_Status; -begin - Ortho_Gcc_Front.Init; - - -- Note: GCC set signal handlers... - Status := Exit_Status (Toplev_Main (gnat_argc, gnat_argv)); - Set_Exit_Status (Status); -end Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc-main.ads b/ortho/gcc/ortho_gcc-main.ads deleted file mode 100644 index 4bd73a1b6..000000000 --- a/ortho/gcc/ortho_gcc-main.ads +++ /dev/null @@ -1 +0,0 @@ -procedure Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc.adb b/ortho/gcc/ortho_gcc.adb deleted file mode 100644 index ae7b4f53b..000000000 --- a/ortho/gcc/ortho_gcc.adb +++ /dev/null @@ -1,121 +0,0 @@ --- GCC back-end for ortho. --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Deallocation; -with Ortho_Gcc_Front; use Ortho_Gcc_Front; - -package body Ortho_Gcc is - - function New_Lit (Lit : O_Cnode) return O_Enode is - begin - return O_Enode (Lit); - end New_Lit; - - function New_Obj (Obj : O_Dnode) return O_Lnode is - begin - return O_Lnode (Obj); - end New_Obj; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return O_Enode (Obj); - end New_Obj_Value; - - procedure New_Debug_Filename_Decl (Filename : String) is - begin - null; - end New_Debug_Filename_Decl; - - procedure New_Debug_Comment_Decl (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Decl; - - procedure New_Debug_Comment_Stmt (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Stmt; - - -- Representation of a C String: this is an access to a bounded string. - -- Therefore, with GNAT, such an access is a thin pointer. - subtype Fat_C_String is String (Positive); - type C_String is access all Fat_C_String; - pragma Convention (C, C_String); - - C_String_Null : constant C_String := null; - - -- Return the length of a C String (ie, the number of characters before - -- the Nul). - function C_String_Len (Str : C_String) return Natural; - pragma Import (C, C_String_Len, "strlen"); - - function Lang_Handle_Option (Opt : C_String; Arg : C_String) - return Integer; - pragma Export (C, Lang_Handle_Option); - - function Lang_Parse_File (Filename : C_String) return Integer; - pragma Export (C, Lang_Parse_File); - - function Lang_Handle_Option (Opt : C_String; Arg : C_String) - return Integer - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - - Res : Natural; - Ada_Opt : String_Acc; - Ada_Arg : String_Acc; - Len : Natural; - begin - Len := C_String_Len (Opt); - Ada_Opt := new String'(Opt (1 .. Len)); - if Arg /= C_String_Null then - Len := C_String_Len (Arg); - Ada_Arg := new String'(Arg (1 .. Len)); - else - Ada_Arg := null; - end if; - Res := Ortho_Gcc_Front.Decode_Option (Ada_Opt, Ada_Arg); - Unchecked_Deallocation (Ada_Opt); - Unchecked_Deallocation (Ada_Arg); - return Res; - end Lang_Handle_Option; - - function Lang_Parse_File (Filename : C_String) return Integer - is - Len : Natural; - File : String_Acc; - begin - if Filename = C_String_Null then - File := null; - else - Len := C_String_Len (Filename); - File := new String'(Filename.all (1 .. Len)); - end if; - - if Ortho_Gcc_Front.Parse (File) then - return 1; - else - return 0; - end if; - end Lang_Parse_File; - -end Ortho_Gcc; diff --git a/ortho/gcc/ortho_gcc.ads b/ortho/gcc/ortho_gcc.ads deleted file mode 100644 index 0afdc0887..000000000 --- a/ortho/gcc/ortho_gcc.ads +++ /dev/null @@ -1,701 +0,0 @@ --- DO NOT MODIFY - this file was generated from: --- ortho_nodes.common.ads and ortho_gcc.private.ads --- --- GCC back-end for ortho. --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; - --- Interface to create nodes. -package Ortho_Gcc is - --- Start of common part - - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - type O_Dnode is private; - type O_Fnode is private; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- Type definitions -- - ------------------------ - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - 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; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record ATYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - ------------------- - -- Expressions -- - ------------------- - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (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. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - --- End of common part -private - -- GCC supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - pragma Convention (C, O_Storage); - -- pragma Convention (C, ON_Op_Kind); - - subtype Tree is System.Address; - NULL_TREE : constant Tree := System.Null_Address; - - subtype Vec_Ptr is System.Address; - - type O_Cnode is new Tree; - type O_Enode is new Tree; - type O_Lnode is new Tree; - type O_Tnode is new Tree; - type O_Fnode is new Tree; - type O_Dnode is new Tree; - type O_Snode is record - Beg_Label : Tree; - End_Label : Tree; - end record; - pragma Convention (C, O_Snode); - - O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); - O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); - O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); - O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); - O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); - O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); - O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); - - pragma Inline (New_Lit); - pragma Inline (New_Obj); - pragma Inline (New_Obj_Value); - - -- Efficiently append element EL to a chain. - -- FIRST is the first element of the chain (must NULL_TREE if the chain - -- is empty), - -- LAST is the last element of the chain (idem). - type Chain_Constr_Type is record - First : Tree; - Last : Tree; - end record; - pragma Convention (C, Chain_Constr_Type); - procedure Chain_Init (Constr : out Chain_Constr_Type); - pragma Import (C, Chain_Init); - procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); - pragma Import (C, Chain_Append); - - -- Efficiently append element EL to a list. - type List_Constr_Type is record - First : Tree; - Last : Tree; - end record; - pragma Convention (C, List_Constr_Type); - procedure List_Init (Constr : out List_Constr_Type); - pragma Import (C, List_Init); - procedure List_Append (Constr : in out List_Constr_Type; El : Tree); - pragma Import (C, List_Append, "ortho_list_append"); - - type O_Loop_Block is record - Beg_Label : Tree; - End_Label : Tree; - end record; - pragma Convention (C, O_Loop_Block); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - -- Return type. - Rtype : O_Tnode; - -- List of parameter types. - Param_List : List_Constr_Type; - -- Chain of parameters declarations. - Param_Chain : Chain_Constr_Type; - end record; - pragma Convention (C, O_Inter_List); - - type O_Element_List is record - Res : Tree; - Chain : Chain_Constr_Type; - end record; - pragma Convention (C, O_Element_List); - - type O_Case_Block is record - Case_Type : Tree; - End_Label : Tree; - Add_Break : Integer; - end record; - pragma Convention (C, O_Case_Block); - - type O_If_Block is record - Stmt : Tree; - end record; - pragma Convention (C, O_If_Block); - - type O_Aggr_List is record - Atype : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Record_Aggr_List is record - Atype : Tree; - Afield : Tree; - Vec : Vec_Ptr; - end record; - pragma Convention (C, O_Record_Aggr_List); - - type O_Array_Aggr_List is record - Atype : Tree; - Vec : Vec_Ptr; - end record; - pragma Convention (C, O_Array_Aggr_List); - - type O_Assoc_List is record - Subprg : Tree; - List : List_Constr_Type; - end record; - pragma Convention (C, O_Assoc_List); - - type O_Enum_List is record - -- The enumeral_type node. - Res : Tree; - -- Chain of literals. - Chain : Chain_Constr_Type; - -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. - Num : Natural; - -- Size of the enumeration type. - Size : Natural; - end record; - pragma Convention (C, O_Enum_List); - - pragma Import (C, New_Dyadic_Op); - pragma Import (C, New_Monadic_Op); - pragma Import (C, New_Compare_Op); - - pragma Import (C, New_Convert_Ov); - pragma Import (C, New_Alloca); - - pragma Import (C, New_Signed_Literal); - pragma Import (C, New_Unsigned_Literal); - pragma Import (C, New_Float_Literal); - pragma Import (C, New_Null_Access); - - pragma Import (C, Start_Record_Type); - pragma Import (C, New_Record_Field); - pragma Import (C, Finish_Record_Type); - pragma Import (C, New_Uncomplete_Record_Type); - pragma Import (C, Start_Uncomplete_Record_Type); - - pragma Import (C, Start_Union_Type); - pragma Import (C, New_Union_Field); - pragma Import (C, Finish_Union_Type); - - pragma Import (C, New_Unsigned_Type); - pragma Import (C, New_Signed_Type); - pragma Import (C, New_Float_Type); - - pragma Import (C, New_Access_Type); - pragma Import (C, Finish_Access_Type); - - pragma Import (C, New_Array_Type); - pragma Import (C, New_Constrained_Array_Type); - - pragma Import (C, New_Boolean_Type); - pragma Import (C, Start_Enum_Type); - pragma Import (C, New_Enum_Literal); - pragma Import (C, Finish_Enum_Type); - - pragma Import (C, Start_Record_Aggr); - pragma Import (C, New_Record_Aggr_El); - pragma Import (C, Finish_Record_Aggr); - pragma Import (C, Start_Array_Aggr); - pragma Import (C, New_Array_Aggr_El); - pragma Import (C, Finish_Array_Aggr); - pragma Import (C, New_Union_Aggr); - - pragma Import (C, New_Indexed_Element); - pragma Import (C, New_Slice); - pragma Import (C, New_Selected_Element); - pragma Import (C, New_Access_Element); - - pragma Import (C, New_Sizeof); - pragma Import (C, New_Alignof); - pragma Import (C, New_Offsetof); - - pragma Import (C, New_Address); - pragma Import (C, New_Global_Address); - pragma Import (C, New_Unchecked_Address); - pragma Import (C, New_Global_Unchecked_Address); - pragma Import (C, New_Subprogram_Address); - - pragma Import (C, New_Value); - - pragma Import (C, New_Type_Decl); - pragma Import (C, New_Debug_Line_Decl); - pragma Import (C, New_Const_Decl); - pragma Import (C, New_Var_Decl); - - pragma Import (C, Start_Const_Value); - pragma Import (C, Finish_Const_Value); - - pragma Import (C, Start_Function_Decl); - pragma Import (C, Start_Procedure_Decl); - pragma Import (C, New_Interface_Decl); - pragma Import (C, Finish_Subprogram_Decl); - - pragma Import (C, Start_Subprogram_Body); - pragma Import (C, Finish_Subprogram_Body); - - pragma Import (C, New_Debug_Line_Stmt); - pragma Import (C, Start_Declare_Stmt); - pragma Import (C, Finish_Declare_Stmt); - pragma Import (C, Start_Association); - pragma Import (C, New_Association); - pragma Import (C, New_Function_Call); - pragma Import (C, New_Procedure_Call); - - pragma Import (C, New_Assign_Stmt); - - pragma Import (C, Start_If_Stmt); - pragma Import (C, New_Else_Stmt); - pragma Import (C, Finish_If_Stmt); - - pragma Import (C, New_Return_Stmt); - pragma Import_Procedure (New_Return_Stmt, - "new_func_return_stmt", (O_Enode)); - pragma Import_Procedure (New_Return_Stmt, - "new_proc_return_stmt", null); - - pragma Import (C, Start_Loop_Stmt); - pragma Import (C, Finish_Loop_Stmt); - pragma Import (C, New_Exit_Stmt); - pragma Import (C, New_Next_Stmt); - - pragma Import (C, Start_Case_Stmt); - pragma Import (C, Start_Choice); - pragma Import (C, New_Expr_Choice); - pragma Import (C, New_Range_Choice); - pragma Import (C, New_Default_Choice); - pragma Import (C, Finish_Choice); - pragma Import (C, Finish_Case_Stmt); -end Ortho_Gcc; diff --git a/ortho/gcc/ortho_gcc.private.ads b/ortho/gcc/ortho_gcc.private.ads deleted file mode 100644 index cc2f556f0..000000000 --- a/ortho/gcc/ortho_gcc.private.ads +++ /dev/null @@ -1,269 +0,0 @@ --- GCC back-end for ortho. --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; - --- Interface to create nodes. -package Ortho_Gcc is - -private - -- GCC supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - pragma Convention (C, O_Storage); - -- pragma Convention (C, ON_Op_Kind); - - subtype Tree is System.Address; - NULL_TREE : constant Tree := System.Null_Address; - - subtype Vec_Ptr is System.Address; - - type O_Cnode is new Tree; - type O_Enode is new Tree; - type O_Lnode is new Tree; - type O_Tnode is new Tree; - type O_Fnode is new Tree; - type O_Dnode is new Tree; - type O_Snode is record - Beg_Label : Tree; - End_Label : Tree; - end record; - pragma Convention (C, O_Snode); - - O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); - O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); - O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); - O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); - O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); - O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); - O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); - - pragma Inline (New_Lit); - pragma Inline (New_Obj); - pragma Inline (New_Obj_Value); - - -- Efficiently append element EL to a chain. - -- FIRST is the first element of the chain (must NULL_TREE if the chain - -- is empty), - -- LAST is the last element of the chain (idem). - type Chain_Constr_Type is record - First : Tree; - Last : Tree; - end record; - pragma Convention (C, Chain_Constr_Type); - procedure Chain_Init (Constr : out Chain_Constr_Type); - pragma Import (C, Chain_Init); - procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); - pragma Import (C, Chain_Append); - - -- Efficiently append element EL to a list. - type List_Constr_Type is record - First : Tree; - Last : Tree; - end record; - pragma Convention (C, List_Constr_Type); - procedure List_Init (Constr : out List_Constr_Type); - pragma Import (C, List_Init); - procedure List_Append (Constr : in out List_Constr_Type; El : Tree); - pragma Import (C, List_Append, "ortho_list_append"); - - type O_Loop_Block is record - Beg_Label : Tree; - End_Label : Tree; - end record; - pragma Convention (C, O_Loop_Block); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - -- Return type. - Rtype : O_Tnode; - -- List of parameter types. - Param_List : List_Constr_Type; - -- Chain of parameters declarations. - Param_Chain : Chain_Constr_Type; - end record; - pragma Convention (C, O_Inter_List); - - type O_Element_List is record - Res : Tree; - Chain : Chain_Constr_Type; - end record; - pragma Convention (C, O_Element_List); - - type O_Case_Block is record - Case_Type : Tree; - End_Label : Tree; - Add_Break : Integer; - end record; - pragma Convention (C, O_Case_Block); - - type O_If_Block is record - Stmt : Tree; - end record; - pragma Convention (C, O_If_Block); - - type O_Aggr_List is record - Atype : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Record_Aggr_List is record - Atype : Tree; - Afield : Tree; - Vec : Vec_Ptr; - end record; - pragma Convention (C, O_Record_Aggr_List); - - type O_Array_Aggr_List is record - Atype : Tree; - Vec : Vec_Ptr; - end record; - pragma Convention (C, O_Array_Aggr_List); - - type O_Assoc_List is record - Subprg : Tree; - List : List_Constr_Type; - end record; - pragma Convention (C, O_Assoc_List); - - type O_Enum_List is record - -- The enumeral_type node. - Res : Tree; - -- Chain of literals. - Chain : Chain_Constr_Type; - -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. - Num : Natural; - -- Size of the enumeration type. - Size : Natural; - end record; - pragma Convention (C, O_Enum_List); - - pragma Import (C, New_Dyadic_Op); - pragma Import (C, New_Monadic_Op); - pragma Import (C, New_Compare_Op); - - pragma Import (C, New_Convert_Ov); - pragma Import (C, New_Alloca); - - pragma Import (C, New_Signed_Literal); - pragma Import (C, New_Unsigned_Literal); - pragma Import (C, New_Float_Literal); - pragma Import (C, New_Null_Access); - - pragma Import (C, Start_Record_Type); - pragma Import (C, New_Record_Field); - pragma Import (C, Finish_Record_Type); - pragma Import (C, New_Uncomplete_Record_Type); - pragma Import (C, Start_Uncomplete_Record_Type); - - pragma Import (C, Start_Union_Type); - pragma Import (C, New_Union_Field); - pragma Import (C, Finish_Union_Type); - - pragma Import (C, New_Unsigned_Type); - pragma Import (C, New_Signed_Type); - pragma Import (C, New_Float_Type); - - pragma Import (C, New_Access_Type); - pragma Import (C, Finish_Access_Type); - - pragma Import (C, New_Array_Type); - pragma Import (C, New_Constrained_Array_Type); - - pragma Import (C, New_Boolean_Type); - pragma Import (C, Start_Enum_Type); - pragma Import (C, New_Enum_Literal); - pragma Import (C, Finish_Enum_Type); - - pragma Import (C, Start_Record_Aggr); - pragma Import (C, New_Record_Aggr_El); - pragma Import (C, Finish_Record_Aggr); - pragma Import (C, Start_Array_Aggr); - pragma Import (C, New_Array_Aggr_El); - pragma Import (C, Finish_Array_Aggr); - pragma Import (C, New_Union_Aggr); - - pragma Import (C, New_Indexed_Element); - pragma Import (C, New_Slice); - pragma Import (C, New_Selected_Element); - pragma Import (C, New_Access_Element); - - pragma Import (C, New_Sizeof); - pragma Import (C, New_Alignof); - pragma Import (C, New_Offsetof); - - pragma Import (C, New_Address); - pragma Import (C, New_Global_Address); - pragma Import (C, New_Unchecked_Address); - pragma Import (C, New_Global_Unchecked_Address); - pragma Import (C, New_Subprogram_Address); - - pragma Import (C, New_Value); - - pragma Import (C, New_Type_Decl); - pragma Import (C, New_Debug_Line_Decl); - pragma Import (C, New_Const_Decl); - pragma Import (C, New_Var_Decl); - - pragma Import (C, Start_Const_Value); - pragma Import (C, Finish_Const_Value); - - pragma Import (C, Start_Function_Decl); - pragma Import (C, Start_Procedure_Decl); - pragma Import (C, New_Interface_Decl); - pragma Import (C, Finish_Subprogram_Decl); - - pragma Import (C, Start_Subprogram_Body); - pragma Import (C, Finish_Subprogram_Body); - - pragma Import (C, New_Debug_Line_Stmt); - pragma Import (C, Start_Declare_Stmt); - pragma Import (C, Finish_Declare_Stmt); - pragma Import (C, Start_Association); - pragma Import (C, New_Association); - pragma Import (C, New_Function_Call); - pragma Import (C, New_Procedure_Call); - - pragma Import (C, New_Assign_Stmt); - - pragma Import (C, Start_If_Stmt); - pragma Import (C, New_Else_Stmt); - pragma Import (C, Finish_If_Stmt); - - pragma Import (C, New_Return_Stmt); - pragma Import_Procedure (New_Return_Stmt, - "new_func_return_stmt", (O_Enode)); - pragma Import_Procedure (New_Return_Stmt, - "new_proc_return_stmt", null); - - pragma Import (C, Start_Loop_Stmt); - pragma Import (C, Finish_Loop_Stmt); - pragma Import (C, New_Exit_Stmt); - pragma Import (C, New_Next_Stmt); - - pragma Import (C, Start_Case_Stmt); - pragma Import (C, Start_Choice); - pragma Import (C, New_Expr_Choice); - pragma Import (C, New_Range_Choice); - pragma Import (C, New_Default_Choice); - pragma Import (C, Finish_Choice); - pragma Import (C, Finish_Case_Stmt); -end Ortho_Gcc; diff --git a/ortho/gcc/ortho_gcc_front.ads b/ortho/gcc/ortho_gcc_front.ads deleted file mode 100644 index 553057b20..000000000 --- a/ortho/gcc/ortho_gcc_front.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Ortho_Front; -package Ortho_Gcc_Front renames Ortho_Front; diff --git a/ortho/gcc/ortho_ident.adb b/ortho/gcc/ortho_ident.adb deleted file mode 100644 index 770fece2b..000000000 --- a/ortho/gcc/ortho_ident.adb +++ /dev/null @@ -1,56 +0,0 @@ --- GCC back-end for ortho (identifiers) --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Ident is - function Get_Identifier_With_Length (Str : Address; Size : Integer) - return O_Ident; - pragma Import (C, Get_Identifier_With_Length, - "get_identifier_with_length_c"); - - function Compare_Identifier_String - (Id : O_Ident; Str : Address; Size : Integer) - return Boolean; - pragma Import (C, Compare_Identifier_String); - pragma Warnings (Off, Compare_Identifier_String); - - function Get_Identifier (Str : String) return O_Ident is - begin - return Get_Identifier_With_Length (Str'Address, Str'Length); - end Get_Identifier; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Compare_Identifier_String (Id, Str'Address, Str'Length); - end Is_Equal; - - function Get_String (Id : O_Ident) return String - is - procedure Get_Identifier_String - (Id : O_Ident; Str_Ptr : Address; Len_Ptr : Address); - pragma Import (C, Get_Identifier_String); - - Len : Natural; - type Str_Acc is access String (Positive); - Str : Str_Acc; - begin - Get_Identifier_String (Id, Str'Address, Len'Address); - return Str (1 .. Len); - end Get_String; - -end Ortho_Ident; - diff --git a/ortho/gcc/ortho_ident.ads b/ortho/gcc/ortho_ident.ads deleted file mode 100644 index 76c09ceb9..000000000 --- a/ortho/gcc/ortho_ident.ads +++ /dev/null @@ -1,30 +0,0 @@ --- GCC back-end for ortho (identifiers) --- Copyright (C) 2002-1014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; use System; - -package Ortho_Ident is - subtype O_Ident is Address; - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames System."="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - O_Ident_Nul : constant O_Ident; -private - O_Ident_Nul : constant O_Ident := Null_Address; -end Ortho_Ident; diff --git a/ortho/gcc/ortho_nodes.ads b/ortho/gcc/ortho_nodes.ads deleted file mode 100644 index 7c6c4a076..000000000 --- a/ortho/gcc/ortho_nodes.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Ortho_Gcc; - -package Ortho_Nodes renames Ortho_Gcc; diff --git a/ortho/llvm/Makefile b/ortho/llvm/Makefile deleted file mode 100644 index 135dbdf4b..000000000 --- a/ortho/llvm/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -ortho_srcdir=.. -GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05 -CXX=clang++ --std=c++11 -LLVM_CONFIG=llvm-config -SED=sed -BE=llvm - -all: $(ortho_exec) - -$(ortho_exec): $(ortho_srcdir)/llvm/ortho_llvm.ads force llvm-cbindings.o - gnatmake -m -o $@ -g -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \ - $(GNAT_FLAGS) ortho_code_main -bargs -E \ - -largs llvm-cbindings.o `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ #-static - -llvm-cbindings.o: $(ortho_srcdir)/llvm/llvm-cbindings.cpp - $(CXX) -c -I`$(LLVM_CONFIG) --includedir --cflags` -g -o $@ $< - -clean: - $(RM) -f *.o *.ali ortho_code_main - $(RM) b~*.ad? *~ - -distclean: clean - - -force: - -.PHONY: force all clean - -ORTHO_BASENAME=ortho_llvm -include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/llvm/llvm-analysis.ads b/ortho/llvm/llvm-analysis.ads deleted file mode 100644 index bfecec579..000000000 --- a/ortho/llvm/llvm-analysis.ads +++ /dev/null @@ -1,53 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; - -package LLVM.Analysis is - type VerifierFailureAction is - ( - AbortProcessAction, -- verifier will print to stderr and abort() - PrintMessageAction, -- verifier will print to stderr and return 1 - ReturnStatusAction -- verifier will just return 1 - ); - pragma Convention (C, VerifierFailureAction); - - -- Verifies that a module is valid, taking the specified action if not. - -- Optionally returns a human-readable description of any invalid - -- constructs. - -- OutMessage must be disposed with DisposeMessage. */ - function VerifyModule(M : ModuleRef; - Action : VerifierFailureAction; - OutMessage : access Cstring) - return Integer; - - -- Verifies that a single function is valid, taking the specified - -- action. Useful for debugging. - function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction) - return Integer; - - -- Open up a ghostview window that displays the CFG of the current function. - -- Useful for debugging. - procedure ViewFunctionCFG(Fn : ValueRef); - procedure ViewFunctionCFGOnly(Fn : ValueRef); -private - pragma Import (C, VerifyModule, "LLVMVerifyModule"); - pragma Import (C, VerifyFunction, "LLVMVerifyFunction"); - pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG"); - pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly"); -end LLVM.Analysis; - diff --git a/ortho/llvm/llvm-bitwriter.ads b/ortho/llvm/llvm-bitwriter.ads deleted file mode 100644 index 3f9c518e4..000000000 --- a/ortho/llvm/llvm-bitwriter.ads +++ /dev/null @@ -1,34 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Interfaces.C; use Interfaces.C; - -package LLVM.BitWriter is - -- Writes a module to an open file descriptor. Returns 0 on success. - -- Closes the Handle. Use dup first if this is not what you want. - function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor) - return int; - - -- Writes a module to the specified path. Returns 0 on success. - function WriteBitcodeToFile(M : ModuleRef; Path : Cstring) - return int; -private - pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle"); - pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile"); -end LLVM.BitWriter; diff --git a/ortho/llvm/llvm-cbindings.cpp b/ortho/llvm/llvm-cbindings.cpp deleted file mode 100644 index e4d666ade..000000000 --- a/ortho/llvm/llvm-cbindings.cpp +++ /dev/null @@ -1,61 +0,0 @@ -/* LLVM binding - Copyright (C) 2014 Tristan Gingold - - GHDL 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, or (at your option) any later - version. - - GHDL 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 GHDL; see the file COPYING. If not, write to the Free - Software Foundation, 59 Temple Place - Suite 330, Boston, MA - 02111-1307, USA. */ -#include "llvm-c/Target.h" -#include "llvm-c/Core.h" -#include "llvm-c/ExecutionEngine.h" -#include "llvm/IR/Type.h" -#include "llvm/IR/LLVMContext.h" -#include "llvm/IR/Metadata.h" -#include "llvm/ExecutionEngine/ExecutionEngine.h" - -using namespace llvm; - -extern "C" { - -void -LLVMInitializeNativeTarget_noinline (void) -{ - LLVMInitializeNativeTarget (); -} - -void -LLVMInitializeNativeAsmPrinter_noinline (void) -{ - LLVMInitializeNativeAsmPrinter(); -} - -LLVMTypeRef LLVMMetadataTypeInContext(LLVMContextRef C) { - return (LLVMTypeRef) Type::getMetadataTy(*unwrap(C)); -} - -LLVMTypeRef LLVMMetadataType_extra(void) { - return LLVMMetadataTypeInContext(LLVMGetGlobalContext()); -} - -void -LLVMMDNodeReplaceOperandWith_extra (LLVMValueRef N, unsigned i, LLVMValueRef V) { - MDNode *MD = cast<MDNode>(unwrap(N)); - MD->replaceOperandWith (i, unwrap(V)); -} - -void *LLVMGetPointerToFunction(LLVMExecutionEngineRef EE, LLVMValueRef Func) -{ - return unwrap(EE)->getPointerToFunction(unwrap<Function>(Func)); -} - -} diff --git a/ortho/llvm/llvm-core.ads b/ortho/llvm/llvm-core.ads deleted file mode 100644 index 74a47484f..000000000 --- a/ortho/llvm/llvm-core.ads +++ /dev/null @@ -1,1279 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces.C; use Interfaces.C; -use Interfaces; - -package LLVM.Core is - - subtype Cstring is System.Address; - function "=" (L, R : Cstring) return Boolean renames System."="; - -- Null_Cstring : constant Cstring := Null_Address; - Nul : constant String := (1 => Character'Val (0)); - Empty_Cstring : constant Cstring := Nul'Address; - - -- The top-level container for all LLVM global data. See the LLVMContext - -- class. - type ContextRef is new System.Address; - - -- The top-level container for all other LLVM Intermediate - -- Representation (IR) objects. See the llvm::Module class. - type ModuleRef is new System.Address; - - subtype Bool is int; - - -- Each value in the LLVM IR has a type, an LLVMTypeRef. See the llvm::Type - -- class. - type TypeRef is new System.Address; - Null_TypeRef : constant TypeRef := TypeRef (System.Null_Address); - type TypeRefArray is array (unsigned range <>) of TypeRef; - pragma Convention (C, TypeRefArray); - - type ValueRef is new System.Address; - Null_ValueRef : constant ValueRef := ValueRef (System.Null_Address); - type ValueRefArray is array (unsigned range <>) of ValueRef; -- Ada - pragma Convention (C, ValueRefArray); - - type BasicBlockRef is new System.Address; - Null_BasicBlockRef : constant BasicBlockRef := - BasicBlockRef (System.Null_Address); - type BasicBlockRefArray is - array (unsigned range <>) of BasicBlockRef; -- Ada - pragma Convention (C, BasicBlockRefArray); - - type BuilderRef is new System.Address; - - -- Used to provide a module to JIT or interpreter. - -- See the llvm::MemoryBuffer class. - type MemoryBufferRef is new System.Address; - - -- See the llvm::PassManagerBase class. - type PassManagerRef is new System.Address; - - type Attribute is new unsigned; - ZExtAttribute : constant Attribute := 2**0; - SExtAttribute : constant Attribute := 2**1; - NoReturnAttribute : constant Attribute := 2**2; - InRegAttribute : constant Attribute := 2**3; - StructRetAttribute : constant Attribute := 2**4; - NoUnwindAttribute : constant Attribute := 2**5; - NoAliasAttribute : constant Attribute := 2**6; - ByValAttribute : constant Attribute := 2**7; - NestAttribute : constant Attribute := 2**8; - ReadNoneAttribute : constant Attribute := 2**9; - ReadOnlyAttribute : constant Attribute := 2**10; - NoInlineAttribute : constant Attribute := 1**11; - AlwaysInlineAttribute : constant Attribute := 1**12; - OptimizeForSizeAttribute : constant Attribute := 1**13; - StackProtectAttribute : constant Attribute := 1**14; - StackProtectReqAttribute : constant Attribute := 1**15; - Alignment : constant Attribute := 31**16; - NoCaptureAttribute : constant Attribute := 1**21; - NoRedZoneAttribute : constant Attribute := 1**22; - NoImplicitFloatAttribute : constant Attribute := 1**23; - NakedAttribute : constant Attribute := 1**24; - InlineHintAttribute : constant Attribute := 1**25; - StackAlignment : constant Attribute := 7**26; - ReturnsTwice : constant Attribute := 1**29; - UWTable : constant Attribute := 1**30; - NonLazyBind : constant Attribute := 1**31; - - type TypeKind is - ( - VoidTypeKind, -- type with no size - HalfTypeKind, -- 16 bit floating point type - FloatTypeKind, -- 32 bit floating point type - DoubleTypeKind, -- 64 bit floating point type - X86_FP80TypeKind, -- 80 bit floating point type (X87) - FP128TypeKind, -- 128 bit floating point type (112-bit mantissa) - PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits) - LabelTypeKind, -- Labels - IntegerTypeKind, -- Arbitrary bit width integers - FunctionTypeKind, -- Functions - StructTypeKind, -- Structures - ArrayTypeKind, -- Arrays - PointerTypeKind, -- Pointers - VectorTypeKind, -- SIMD 'packed' format, or other vector type - MetadataTypeKind, -- Metadata - X86_MMXTypeKind -- X86 MMX - ); - pragma Convention (C, TypeKind); - - type Linkage is - ( - ExternalLinkage, -- Externally visible function - AvailableExternallyLinkage, - LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline) - LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent. - LinkOnceODRAutoHideLinkage, -- Obsolete - WeakAnyLinkage, -- Keep one copy of function when linking (weak) - WeakODRLinkage, -- Same, but only replaced by someth equivalent. - AppendingLinkage, -- Special purpose, only applies to global arrays - InternalLinkage, -- Rename collisions when linking (static func) - PrivateLinkage, -- Like Internal, but omit from symbol table - DLLImportLinkage, -- Obsolete - DLLExportLinkage, -- Obsolete - ExternalWeakLinkage,-- ExternalWeak linkage description - GhostLinkage, -- Obsolete - CommonLinkage, -- Tentative definitions - LinkerPrivateLinkage, -- Like Private, but linker removes. - LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak. - ); - pragma Convention (C, Linkage); - - type Visibility is - ( - DefaultVisibility, -- The GV is visible - HiddenVisibility, -- The GV is hidden - ProtectedVisibility -- The GV is protected - ); - pragma Convention (C, Visibility); - - type CallConv is new unsigned; - CCallConv : constant CallConv := 0; - FastCallConv : constant CallConv := 8; - ColdCallConv : constant CallConv := 9; - X86StdcallCallConv : constant CallConv := 64; - X86FastcallCallConv : constant CallConv := 6; - - type IntPredicate is new unsigned; - IntEQ : constant IntPredicate := 32; -- equal - IntNE : constant IntPredicate := 33; -- not equal - IntUGT : constant IntPredicate := 34; -- unsigned greater than - IntUGE : constant IntPredicate := 35; -- unsigned greater or equal - IntULT : constant IntPredicate := 36; -- unsigned less than - IntULE : constant IntPredicate := 37; -- unsigned less or equal - IntSGT : constant IntPredicate := 38; -- signed greater than - IntSGE : constant IntPredicate := 39; -- signed greater or equal - IntSLT : constant IntPredicate := 40; -- signed less than - IntSLE : constant IntPredicate := 41; -- signed less or equal - - type RealPredicate is - ( - RealPredicateFalse, -- Always false (always folded) - RealOEQ, -- True if ordered and equal - RealOGT, -- True if ordered and greater than - RealOGE, -- True if ordered and greater than or equal - RealOLT, -- True if ordered and less than - RealOLE, -- True if ordered and less than or equal - RealONE, -- True if ordered and operands are unequal - RealORD, -- True if ordered (no nans) - RealUNO, -- True if unordered: isnan(X) | isnan(Y) - RealUEQ, -- True if unordered or equal - RealUGT, -- True if unordered or greater than - RealUGE, -- True if unordered, greater than, or equal - RealULT, -- True if unordered or less than - RealULE, -- True if unordered, less than, or equal - RealUNE, -- True if unordered or not equal - RealPredicateTrue -- Always true (always folded) - ); - - -- Error handling ---------------------------------------------------- - - procedure DisposeMessage (Message : Cstring); - - - -- Context - - -- Create a new context. - -- Every call to this function should be paired with a call to - -- LLVMContextDispose() or the context will leak memory. - function ContextCreate return ContextRef; - - -- Obtain the global context instance. - function GetGlobalContext return ContextRef; - - -- Destroy a context instance. - -- This should be called for every call to LLVMContextCreate() or memory - -- will be leaked. - procedure ContextDispose (C : ContextRef); - - function GetMDKindIDInContext - (C : ContextRef; Name : Cstring; Slen : unsigned) - return unsigned; - - function GetMDKindID(Name : String; Slen : unsigned) return unsigned; - - -- Modules ----------------------------------------------------------- - - -- Create and destroy modules. - -- See llvm::Module::Module. - function ModuleCreateWithName (ModuleID : Cstring) return ModuleRef; - - -- See llvm::Module::~Module. - procedure DisposeModule (M : ModuleRef); - - -- Data layout. See Module::getDataLayout. - function GetDataLayout(M : ModuleRef) return Cstring; - procedure SetDataLayout(M : ModuleRef; Triple : Cstring); - - -- Target triple. See Module::getTargetTriple. - function GetTarget (M : ModuleRef) return Cstring; - procedure SetTarget (M : ModuleRef; Triple : Cstring); - - -- See Module::dump. - procedure DumpModule(M : ModuleRef); - - -- Print a representation of a module to a file. The ErrorMessage needs to - -- be disposed with LLVMDisposeMessage. Returns 0 on success, 1 otherwise. - -- - -- @see Module::print() - function PrintModuleToFile(M : ModuleRef; - Filename : Cstring; - ErrorMessage : access Cstring) return Bool; - - - -- Types ------------------------------------------------------------- - - -- LLVM types conform to the following hierarchy: - -- - -- types: - -- integer type - -- real type - -- function type - -- sequence types: - -- array type - -- pointer type - -- vector type - -- void type - -- label type - -- opaque type - - -- See llvm::LLVMTypeKind::getTypeID. - function GetTypeKind (Ty : TypeRef) return TypeKind; - - -- Operations on integer types - function Int1Type return TypeRef; - function Int8Type return TypeRef; - function Int16Type return TypeRef; - function Int32Type return TypeRef; - function Int64Type return TypeRef; - function IntType(NumBits : unsigned) return TypeRef; - function GetIntTypeWidth(IntegerTy : TypeRef) return unsigned; - - function MetadataType return TypeRef; - - -- Operations on real types - function FloatType return TypeRef; - function DoubleType return TypeRef; - function X86FP80Type return TypeRef; - function FP128Type return TypeRef; - function PPCFP128Type return TypeRef; - - -- Operations on function types - function FunctionType(ReturnType : TypeRef; - ParamTypes : TypeRefArray; - ParamCount : unsigned; - IsVarArg : int) return TypeRef; - - function IsFunctionVarArg(FunctionTy : TypeRef) return int; - function GetReturnType(FunctionTy : TypeRef) return TypeRef; - function CountParamTypes(FunctionTy : TypeRef) return unsigned; - procedure GetParamTypes(FunctionTy : TypeRef; Dest : out TypeRefArray); - - -- Operations on struct types - function StructType(ElementTypes : TypeRefArray; - ElementCount : unsigned; - Packed : Bool) return TypeRef; - function StructCreateNamed(C : ContextRef; Name : Cstring) return TypeRef; - procedure StructSetBody(StructTy : TypeRef; - ElementTypes : TypeRefArray; - ElementCount : unsigned; - Packed : Bool); - function CountStructElementTypes(StructTy : TypeRef) return unsigned; - procedure GetStructElementTypes(StructTy : TypeRef; - Dest : out TypeRefArray); - function IsPackedStruct(StructTy : TypeRef) return Bool; - - - -- Operations on array, pointer, and vector types (sequence types) - function ArrayType(ElementType : TypeRef; ElementCount : unsigned) - return TypeRef; - function PointerType(ElementType : TypeRef; AddressSpace : unsigned := 0) - return TypeRef; - function VectorType(ElementType : TypeRef; ElementCount : unsigned) - return TypeRef; - - function GetElementType(Ty : TypeRef) return TypeRef; - function GetArrayLength(ArrayTy : TypeRef) return unsigned; - function GetPointerAddressSpace(PointerTy : TypeRef) return unsigned; - function GetVectorSize(VectorTy : TypeRef) return unsigned; - - -- Operations on other types. - function VoidType return TypeRef; - function LabelType return TypeRef; - - -- Values ------------------------------------------------------------ - -- The bulk of LLVM's object model consists of values, which comprise a very - -- rich type hierarchy. - -- - -- values: - -- constants: - -- scalar constants - -- composite contants - -- globals: - -- global variable - -- function - -- alias - -- basic blocks - - -- Operations on all values - function TypeOf(Val : ValueRef) return TypeRef; - function GetValueName(Val : ValueRef) return Cstring; - procedure SetValueName(Val : ValueRef; Name : Cstring); - procedure DumpValue(Val : ValueRef); - - -- Operations on constants of any type - function ConstNull(Ty : TypeRef) return ValueRef; -- All zero - function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec - function GetUndef(Ty : TypeRef) return ValueRef; - function IsConstant(Val : ValueRef) return int; - function IsNull(Val : ValueRef) return int; - function IsUndef(Val : ValueRef) return int; - - -- Convert value instances between types. - -- - -- Internally, an LLVMValueRef is "pinned" to a specific type. This - -- series of functions allows you to cast an instance to a specific - -- type. - -- - -- If the cast is not valid for the specified type, NULL is returned. - -- - -- @see llvm::dyn_cast_or_null<> - function IsAInstruction (Val : ValueRef) return ValueRef; - - -- Operations on scalar constants - function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int) - return ValueRef; - function ConstReal(RealTy : TypeRef; N : double) return ValueRef; - function ConstRealOfString(RealTy : TypeRef; Text : Cstring) - return ValueRef; - - - -- Obtain the zero extended value for an integer constant value. - -- @see llvm::ConstantInt::getZExtValue() - function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64; - - -- Operations on composite constants - function ConstString(Str : Cstring; - Length : unsigned; DontNullTerminate : int) - return ValueRef; - function ConstArray(ElementTy : TypeRef; - ConstantVals : ValueRefArray; Length : unsigned) - return ValueRef; - function ConstStruct(ConstantVals : ValueRefArray; - Count : unsigned; packed : int) return ValueRef; - - -- Create a non-anonymous ConstantStruct from values. - -- @see llvm::ConstantStruct::get() - function ConstNamedStruct(StructTy : TypeRef; - ConstantVals : ValueRefArray; - Count : unsigned) return ValueRef; - - function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned) - return ValueRef; - - -- Constant expressions - function SizeOf(Ty : TypeRef) return ValueRef; - function AlignOf(Ty : TypeRef) return ValueRef; - - function ConstNeg(ConstantVal : ValueRef) return ValueRef; - function ConstNot(ConstantVal : ValueRef) return ValueRef; - function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstICmp(Predicate : IntPredicate; - LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFCmp(Predicate : RealPredicate; - LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstGEP(ConstantVal : ValueRef; - ConstantIndices : ValueRefArray; NumIndices : unsigned) - return ValueRef; - function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - - function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - - function ConstSelect(ConstantCondition : ValueRef; - ConstantIfTrue : ValueRef; - ConstantIfFalse : ValueRef) return ValueRef; - function ConstExtractElement(VectorConstant : ValueRef; - IndexConstant : ValueRef) return ValueRef; - function ConstInsertElement(VectorConstant : ValueRef; - ElementValueConstant : ValueRef; - IndexConstant : ValueRef) return ValueRef; - function ConstShuffleVector(VectorAConstant : ValueRef; - VectorBConstant : ValueRef; - MaskConstant : ValueRef) return ValueRef; - - -- Operations on global variables, functions, and aliases (globals) - function GetGlobalParent(Global : ValueRef) return ModuleRef; - function IsDeclaration(Global : ValueRef) return int; - function GetLinkage(Global : ValueRef) return Linkage; - procedure SetLinkage(Global : ValueRef; Link : Linkage); - function GetSection(Global : ValueRef) return Cstring; - procedure SetSection(Global : ValueRef; Section : Cstring); - function GetVisibility(Global : ValueRef) return Visibility; - procedure SetVisibility(Global : ValueRef; Viz : Visibility); - function GetAlignment(Global : ValueRef) return unsigned; - procedure SetAlignment(Global : ValueRef; Bytes : unsigned); - - -- Operations on global variables - function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef; - function GetFirstGlobal(M : ModuleRef) return ValueRef; - function GetLastGlobal(M : ModuleRef) return ValueRef; - function GetNextGlobal(GlobalVar : ValueRef) return ValueRef; - function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef; - procedure DeleteGlobal(GlobalVar : ValueRef); - function GetInitializer(GlobalVar : ValueRef) return ValueRef; - procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef); - function IsThreadLocal(GlobalVar : ValueRef) return int; - procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int); - function IsGlobalConstant(GlobalVar : ValueRef) return int; - procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int); - - -- Obtain the number of operands for named metadata in a module. - -- @see llvm::Module::getNamedMetadata() - function GetNamedMetadataNumOperands(M : ModuleRef; Name : Cstring) - return unsigned; - - -- Obtain the named metadata operands for a module. - -- The passed LLVMValueRef pointer should refer to an array of - -- LLVMValueRef at least LLVMGetNamedMetadataNumOperands long. This - -- array will be populated with the LLVMValueRef instances. Each - -- instance corresponds to a llvm::MDNode. - -- @see llvm::Module::getNamedMetadata() - -- @see llvm::MDNode::getOperand() - procedure GetNamedMetadataOperands - (M : ModuleRef; Name : Cstring; Dest : ValueRefArray); - - -- Add an operand to named metadata. - -- @see llvm::Module::getNamedMetadata() - -- @see llvm::MDNode::addOperand() - procedure AddNamedMetadataOperand - (M : ModuleRef; Name : Cstring; Val : ValueRef); - - -- Operations on functions - function AddFunction(M : ModuleRef; Name : Cstring; FunctionTy : TypeRef) - return ValueRef; - function GetNamedFunction(M : ModuleRef; Name : Cstring) return ValueRef; - function GetFirstFunction(M : ModuleRef) return ValueRef; - function GetLastFunction(M : ModuleRef) return ValueRef; - function GetNextFunction(Fn : ValueRef) return ValueRef; - function GetPreviousFunction(Fn : ValueRef) return ValueRef; - procedure DeleteFunction(Fn : ValueRef); - function GetIntrinsicID(Fn : ValueRef) return unsigned; - function GetFunctionCallConv(Fn : ValueRef) return CallConv; - procedure SetFunctionCallConv(Fn : ValueRef; CC : CallConv); - function GetGC(Fn : ValueRef) return Cstring; - procedure SetGC(Fn : ValueRef; Name : Cstring); - - -- Add an attribute to a function. - -- @see llvm::Function::addAttribute() - procedure AddFunctionAttr (Fn : ValueRef; PA : Attribute); - - -- Add a target-dependent attribute to a fuction - -- @see llvm::AttrBuilder::addAttribute() - procedure AddTargetDependentFunctionAttr - (Fn : ValueRef; A : Cstring; V : Cstring); - - -- Obtain an attribute from a function. - -- @see llvm::Function::getAttributes() - function GetFunctionAttr (Fn : ValueRef) return Attribute; - - -- Remove an attribute from a function. - procedure RemoveFunctionAttr (Fn : ValueRef; PA : Attribute); - - -- Operations on parameters - function CountParams(Fn : ValueRef) return unsigned; - procedure GetParams(Fn : ValueRef; Params : ValueRefArray); - function GetParam(Fn : ValueRef; Index : unsigned) return ValueRef; - function GetParamParent(Inst : ValueRef) return ValueRef; - function GetFirstParam(Fn : ValueRef) return ValueRef; - function GetLastParam(Fn : ValueRef) return ValueRef; - function GetNextParam(Arg : ValueRef) return ValueRef; - function GetPreviousParam(Arg : ValueRef) return ValueRef; - procedure AddAttribute(Arg : ValueRef; PA : Attribute); - procedure RemoveAttribute(Arg : ValueRef; PA : Attribute); - procedure SetParamAlignment(Arg : ValueRef; align : unsigned); - - -- Metadata - - -- Obtain a MDString value from a context. - -- The returned instance corresponds to the llvm::MDString class. - -- The instance is specified by string data of a specified length. The - -- string content is copied, so the backing memory can be freed after - -- this function returns. - function MDStringInContext(C : ContextRef; Str : Cstring; Len : unsigned) - return ValueRef; - - -- Obtain a MDString value from the global context. - function MDString(Str : Cstring; Len : unsigned) return ValueRef; - - -- Obtain a MDNode value from a context. - -- The returned value corresponds to the llvm::MDNode class. - function MDNodeInContext - (C : ContextRef; Vals : ValueRefArray; Count : unsigned) - return ValueRef; - - -- Obtain a MDNode value from the global context. - function MDNode(Vals : ValueRefArray; Count : unsigned) return ValueRef; - - -- Obtain the underlying string from a MDString value. - -- @param V Instance to obtain string from. - -- @param Len Memory address which will hold length of returned string. - -- @return String data in MDString. - function GetMDString(V : ValueRef; Len : access unsigned) return Cstring; - - -- Obtain the number of operands from an MDNode value. - -- @param V MDNode to get number of operands from. - -- @return Number of operands of the MDNode. - function GetMDNodeNumOperands(V : ValueRef) return unsigned; - - -- Obtain the given MDNode's operands. - -- The passed LLVMValueRef pointer should point to enough memory to hold - -- all of the operands of the given MDNode (see LLVMGetMDNodeNumOperands) - -- as LLVMValueRefs. This memory will be populated with the LLVMValueRefs - -- of the MDNode's operands. - -- @param V MDNode to get the operands from. - -- @param Dest Destination array for operands. - procedure GetMDNodeOperands(V : ValueRef; Dest : ValueRefArray); - - procedure MDNodeReplaceOperandWith - (N : ValueRef; I : unsigned; V : ValueRef); - - -- Operations on basic blocks - function BasicBlockAsValue(BB : BasicBlockRef) return ValueRef; - function ValueIsBasicBlock(Val : ValueRef) return int; - function ValueAsBasicBlock(Val : ValueRef) return BasicBlockRef; - function GetBasicBlockParent(BB : BasicBlockRef) return ValueRef; - function CountBasicBlocks(Fn : ValueRef) return unsigned; - procedure GetBasicBlocks(Fn : ValueRef; BasicBlocks : BasicBlockRefArray); - function GetFirstBasicBlock(Fn : ValueRef) return BasicBlockRef; - function GetLastBasicBlock(Fn : ValueRef) return BasicBlockRef; - function GetNextBasicBlock(BB : BasicBlockRef) return BasicBlockRef; - function GetPreviousBasicBlock(BB : BasicBlockRef) return BasicBlockRef; - function GetEntryBasicBlock(Fn : ValueRef) return BasicBlockRef; - function AppendBasicBlock(Fn : ValueRef; Name : Cstring) - return BasicBlockRef; - function InsertBasicBlock(InsertBeforeBB : BasicBlockRef; - Name : Cstring) return BasicBlockRef; - procedure DeleteBasicBlock(BB : BasicBlockRef); - - -- Operations on instructions - - -- Determine whether an instruction has any metadata attached. - function HasMetadata(Val: ValueRef) return Bool; - - -- Return metadata associated with an instruction value. - function GetMetadata(Val : ValueRef; KindID : unsigned) return ValueRef; - - -- Set metadata associated with an instruction value. - procedure SetMetadata(Val : ValueRef; KindID : unsigned; Node : ValueRef); - - function GetInstructionParent(Inst : ValueRef) return BasicBlockRef; - function GetFirstInstruction(BB : BasicBlockRef) return ValueRef; - function GetLastInstruction(BB : BasicBlockRef) return ValueRef; - function GetNextInstruction(Inst : ValueRef) return ValueRef; - function GetPreviousInstruction(Inst : ValueRef) return ValueRef; - - -- Operations on call sites - procedure SetInstructionCallConv(Instr : ValueRef; CC : unsigned); - function GetInstructionCallConv(Instr : ValueRef) return unsigned; - procedure AddInstrAttribute(Instr : ValueRef; - index : unsigned; Attr : Attribute); - procedure RemoveInstrAttribute(Instr : ValueRef; - index : unsigned; Attr : Attribute); - procedure SetInstrParamAlignment(Instr : ValueRef; - index : unsigned; align : unsigned); - - -- Operations on call instructions (only) - function IsTailCall(CallInst : ValueRef) return int; - procedure SetTailCall(CallInst : ValueRef; IsTailCall : int); - - -- Operations on phi nodes - procedure AddIncoming(PhiNode : ValueRef; IncomingValues : ValueRefArray; - IncomingBlocks : BasicBlockRefArray; Count : unsigned); - function CountIncoming(PhiNode : ValueRef) return unsigned; - function GetIncomingValue(PhiNode : ValueRef; Index : unsigned) - return ValueRef; - function GetIncomingBlock(PhiNode : ValueRef; Index : unsigned) - return BasicBlockRef; - - -- Instruction builders ---------------------------------------------- - -- An instruction builder represents a point within a basic block, - -- and is the exclusive means of building instructions using the C - -- interface. - - function CreateBuilder return BuilderRef; - procedure PositionBuilder(Builder : BuilderRef; - Block : BasicBlockRef; Instr : ValueRef); - procedure PositionBuilderBefore(Builder : BuilderRef; Instr : ValueRef); - procedure PositionBuilderAtEnd(Builder : BuilderRef; Block : BasicBlockRef); - function GetInsertBlock(Builder : BuilderRef) return BasicBlockRef; - procedure DisposeBuilder(Builder : BuilderRef); - - -- Terminators - function BuildRetVoid(Builder : BuilderRef) return ValueRef; - function BuildRet(Builder : BuilderRef; V : ValueRef) return ValueRef; - function BuildBr(Builder : BuilderRef; Dest : BasicBlockRef) - return ValueRef; - function BuildCondBr(Builder : BuilderRef; - If_Br : ValueRef; - Then_Br : BasicBlockRef; Else_Br : BasicBlockRef) - return ValueRef; - function BuildSwitch(Builder : BuilderRef; - V : ValueRef; - Else_Br : BasicBlockRef; NumCases : unsigned) - return ValueRef; - function BuildInvoke(Builder : BuilderRef; - Fn : ValueRef; - Args : ValueRefArray; - NumArgs : unsigned; - Then_Br : BasicBlockRef; - Catch : BasicBlockRef; - Name : Cstring) return ValueRef; - function BuildUnwind(Builder : BuilderRef) return ValueRef; - function BuildUnreachable(Builder : BuilderRef) return ValueRef; - - -- Add a case to the switch instruction - procedure AddCase(Switch : ValueRef; - OnVal : ValueRef; Dest : BasicBlockRef); - - -- Arithmetic - function BuildAdd(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildNSWAdd(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildNUWAdd(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFAdd(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - - function BuildSub(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildNSWSub(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildNUWSub(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFSub(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - - function BuildMul(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFMul(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - - function BuildUDiv(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildSDiv(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFDiv(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildURem(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildSRem(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFRem(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildShl(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildLShr(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildAShr(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildAnd(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildOr(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildXor(Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring) - return ValueRef; - function BuildFNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring) - return ValueRef; - function BuildNot(Builder : BuilderRef; V : ValueRef; Name : Cstring) - return ValueRef; - - -- Memory - function BuildMalloc(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function BuildArrayMalloc(Builder : BuilderRef; - Ty : TypeRef; Val : ValueRef; Name : Cstring) - return ValueRef; - function BuildAlloca(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function BuildArrayAlloca(Builder : BuilderRef; - Ty : TypeRef; Val : ValueRef; Name : Cstring) - return ValueRef; - function BuildFree(Builder : BuilderRef; PointerVal : ValueRef) - return ValueRef; - function BuildLoad(Builder : BuilderRef; PointerVal : ValueRef; - Name : Cstring) return ValueRef; - function BuildStore(Builder : BuilderRef; Val : ValueRef; Ptr : ValueRef) - return ValueRef; - function BuildGEP(Builder : BuilderRef; - Pointer : ValueRef; - Indices : ValueRefArray; - NumIndices : unsigned; Name : Cstring) return ValueRef; - - -- Casts - function BuildTrunc(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildZExt(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildSExt(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildFPToUI(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildFPToSI(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildUIToFP(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildSIToFP(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildFPTrunc(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildFPExt(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildPtrToInt(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildIntToPtr(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - function BuildBitCast(Builder : BuilderRef; - Val : ValueRef; DestTy : TypeRef; Name : Cstring) - return ValueRef; - - -- Comparisons - function BuildICmp(Builder : BuilderRef; - Op : IntPredicate; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - function BuildFCmp(Builder : BuilderRef; - Op : RealPredicate; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - - -- Miscellaneous instructions - function BuildPhi(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function BuildCall(Builder : BuilderRef; - Fn : ValueRef; - Args : ValueRefArray; NumArgs : unsigned; Name : Cstring) - return ValueRef; - function BuildSelect(Builder : BuilderRef; - If_Sel : ValueRef; - Then_Sel : ValueRef; - Else_Sel : ValueRef; - Name : Cstring) return ValueRef; - function BuildVAArg(Builder : BuilderRef; - List : ValueRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function BuildExtractElement(Builder : BuilderRef; - VecVal : ValueRef; - Index : ValueRef; - Name : Cstring) return ValueRef; - function BuildInsertElement(Builder : BuilderRef; - VecVal : ValueRef; - EltVal : ValueRef; - Index : ValueRef; - Name : Cstring) return ValueRef; - function BuildShuffleVector(Builder : BuilderRef; - V1 : ValueRef; - V2 : ValueRef; - Mask : ValueRef; - Name : Cstring) return ValueRef; - - -- Memory buffers ---------------------------------------------------- - - function CreateMemoryBufferWithContentsOfFile - (Path : Cstring; - OutMemBuf : access MemoryBufferRef; - OutMessage : access Cstring) return int; - function CreateMemoryBufferWithSTDIN - (OutMemBuf : access MemoryBufferRef; - OutMessage : access Cstring) return int; - procedure DisposeMemoryBuffer(MemBuf : MemoryBufferRef); - - - -- Pass Managers ----------------------------------------------------- - - -- Constructs a new whole-module pass pipeline. This type of pipeline is - -- suitable for link-time optimization and whole-module transformations. - -- See llvm::PassManager::PassManager. - function CreatePassManager return PassManagerRef; - - -- Constructs a new function-by-function pass pipeline over the module - -- provider. It does not take ownership of the module provider. This type of - -- pipeline is suitable for code generation and JIT compilation tasks. - -- See llvm::FunctionPassManager::FunctionPassManager. - function CreateFunctionPassManagerForModule(M : ModuleRef) - return PassManagerRef; - - -- Initializes, executes on the provided module, and finalizes all of the - -- passes scheduled in the pass manager. Returns 1 if any of the passes - -- modified the module, 0 otherwise. See llvm::PassManager::run(Module&). - function RunPassManager(PM : PassManagerRef; M : ModuleRef) - return int; - - -- Initializes all of the function passes scheduled in the function pass - -- manager. Returns 1 if any of the passes modified the module, 0 otherwise. - -- See llvm::FunctionPassManager::doInitialization. - function InitializeFunctionPassManager(FPM : PassManagerRef) - return int; - - -- Executes all of the function passes scheduled in the function - -- pass manager on the provided function. Returns 1 if any of the - -- passes modified the function, false otherwise. - -- See llvm::FunctionPassManager::run(Function&). - function RunFunctionPassManager (FPM : PassManagerRef; F : ValueRef) - return int; - - -- Finalizes all of the function passes scheduled in in the function pass - -- manager. Returns 1 if any of the passes modified the module, 0 otherwise. - -- See llvm::FunctionPassManager::doFinalization. - function FinalizeFunctionPassManager(FPM : PassManagerRef) - return int; - - -- Frees the memory of a pass pipeline. For function pipelines, - -- does not free the module provider. - -- See llvm::PassManagerBase::~PassManagerBase. - procedure DisposePassManager(PM : PassManagerRef); - -private - pragma Import (C, ContextCreate, "LLVMContextCreate"); - pragma Import (C, GetGlobalContext, "LLVMGetGlobalContext"); - pragma Import (C, ContextDispose, "LLVMContextDispose"); - - pragma Import (C, GetMDKindIDInContext, "LLVMGetMDKindIDInContext"); - pragma Import (C, GetMDKindID, "LLVMGetMDKindID"); - - pragma Import (C, DisposeMessage, "LLVMDisposeMessage"); - pragma Import (C, ModuleCreateWithName, "LLVMModuleCreateWithName"); - pragma Import (C, DisposeModule, "LLVMDisposeModule"); - pragma Import (C, GetDataLayout, "LLVMGetDataLayout"); - pragma Import (C, SetDataLayout, "LLVMSetDataLayout"); - pragma Import (C, GetTarget, "LLVMGetTarget"); - pragma Import (C, SetTarget, "LLVMSetTarget"); - pragma Import (C, DumpModule, "LLVMDumpModule"); - pragma Import (C, PrintModuleToFile, "LLVMPrintModuleToFile"); - pragma Import (C, GetTypeKind, "LLVMGetTypeKind"); - pragma Import (C, Int1Type, "LLVMInt1Type"); - pragma Import (C, Int8Type, "LLVMInt8Type"); - pragma Import (C, Int16Type, "LLVMInt16Type"); - pragma Import (C, Int32Type, "LLVMInt32Type"); - pragma Import (C, Int64Type, "LLVMInt64Type"); - pragma Import (C, IntType, "LLVMIntType"); - pragma Import (C, GetIntTypeWidth, "LLVMGetIntTypeWidth"); - pragma Import (C, MetadataType, "LLVMMetadataType_extra"); - - pragma Import (C, FloatType, "LLVMFloatType"); - pragma Import (C, DoubleType, "LLVMDoubleType"); - pragma Import (C, X86FP80Type, "LLVMX86FP80Type"); - pragma Import (C, FP128Type, "LLVMFP128Type"); - pragma Import (C, PPCFP128Type, "LLVMPPCFP128Type"); - - pragma Import (C, FunctionType, "LLVMFunctionType"); - pragma Import (C, IsFunctionVarArg, "LLVMIsFunctionVarArg"); - pragma Import (C, GetReturnType, "LLVMGetReturnType"); - pragma Import (C, CountParamTypes, "LLVMCountParamTypes"); - pragma Import (C, GetParamTypes, "LLVMGetParamTypes"); - - pragma Import (C, StructType, "LLVMStructType"); - pragma Import (C, StructCreateNamed, "LLVMStructCreateNamed"); - pragma Import (C, StructSetBody, "LLVMStructSetBody"); - pragma Import (C, CountStructElementTypes, "LLVMCountStructElementTypes"); - pragma Import (C, GetStructElementTypes, "LLVMGetStructElementTypes"); - pragma Import (C, IsPackedStruct, "LLVMIsPackedStruct"); - - pragma Import (C, ArrayType, "LLVMArrayType"); - pragma Import (C, PointerType, "LLVMPointerType"); - pragma Import (C, VectorType, "LLVMVectorType"); - pragma Import (C, GetElementType, "LLVMGetElementType"); - pragma Import (C, GetArrayLength, "LLVMGetArrayLength"); - pragma Import (C, GetPointerAddressSpace, "LLVMGetPointerAddressSpace"); - pragma Import (C, GetVectorSize, "LLVMGetVectorSize"); - - pragma Import (C, VoidType, "LLVMVoidType"); - pragma Import (C, LabelType, "LLVMLabelType"); - - pragma Import (C, TypeOf, "LLVMTypeOf"); - pragma Import (C, GetValueName, "LLVMGetValueName"); - pragma Import (C, SetValueName, "LLVMSetValueName"); - pragma Import (C, DumpValue, "LLVMDumpValue"); - - pragma Import (C, ConstNull, "LLVMConstNull"); - pragma Import (C, ConstAllOnes, "LLVMConstAllOnes"); - pragma Import (C, GetUndef, "LLVMGetUndef"); - pragma Import (C, IsConstant, "LLVMIsConstant"); - pragma Import (C, IsNull, "LLVMIsNull"); - pragma Import (C, IsUndef, "LLVMIsUndef"); - pragma Import (C, IsAInstruction, "LLVMIsAInstruction"); - - pragma Import (C, ConstInt, "LLVMConstInt"); - pragma Import (C, ConstReal, "LLVMConstReal"); - pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue"); - pragma Import (C, ConstRealOfString, "LLVMConstRealOfString"); - pragma Import (C, ConstString, "LLVMConstString"); - pragma Import (C, ConstArray, "LLVMConstArray"); - pragma Import (C, ConstStruct, "LLVMConstStruct"); - pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct"); - pragma Import (C, ConstVector, "LLVMConstVector"); - - pragma Import (C, SizeOf, "LLVMSizeOf"); - pragma Import (C, AlignOf, "LLVMAlignOf"); - pragma Import (C, ConstNeg, "LLVMConstNeg"); - pragma Import (C, ConstNot, "LLVMConstNot"); - pragma Import (C, ConstAdd, "LLVMConstAdd"); - pragma Import (C, ConstSub, "LLVMConstSub"); - pragma Import (C, ConstMul, "LLVMConstMul"); - pragma Import (C, ConstUDiv, "LLVMConstUDiv"); - pragma Import (C, ConstSDiv, "LLVMConstSDiv"); - pragma Import (C, ConstFDiv, "LLVMConstFDiv"); - pragma Import (C, ConstURem, "LLVMConstURem"); - pragma Import (C, ConstSRem, "LLVMConstSRem"); - pragma Import (C, ConstFRem, "LLVMConstFRem"); - pragma Import (C, ConstAnd, "LLVMConstAnd"); - pragma Import (C, ConstOr, "LLVMConstOr"); - pragma Import (C, ConstXor, "LLVMConstXor"); - pragma Import (C, ConstICmp, "LLVMConstICmp"); - pragma Import (C, ConstFCmp, "LLVMConstFCmp"); - pragma Import (C, ConstShl, "LLVMConstShl"); - pragma Import (C, ConstLShr, "LLVMConstLShr"); - pragma Import (C, ConstAShr, "LLVMConstAShr"); - pragma Import (C, ConstGEP, "LLVMConstGEP"); - pragma Import (C, ConstTrunc, "LLVMConstTrunc"); - pragma Import (C, ConstSExt, "LLVMConstSExt"); - pragma Import (C, ConstZExt, "LLVMConstZExt"); - pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc"); - pragma Import (C, ConstFPExt, "LLVMConstFPExt"); - pragma Import (C, ConstUIToFP, "LLVMConstUIToFP"); - pragma Import (C, ConstSIToFP, "LLVMConstSIToFP"); - pragma Import (C, ConstFPToUI, "LLVMConstFPToUI"); - pragma Import (C, ConstFPToSI, "LLVMConstFPToSI"); - pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt"); - pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr"); - pragma Import (C, ConstBitCast, "LLVMConstBitCast"); - pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast"); - pragma Import (C, ConstSelect, "LLVMConstSelect"); - pragma Import (C, ConstExtractElement, "LLVMConstExtractElement"); - pragma Import (C, ConstInsertElement, "LLVMConstInsertElement"); - pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector"); - - pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent"); - pragma Import (C, IsDeclaration, "LLVMIsDeclaration"); - pragma Import (C, GetLinkage, "LLVMGetLinkage"); - pragma Import (C, SetLinkage, "LLVMSetLinkage"); - pragma Import (C, GetSection, "LLVMGetSection"); - pragma Import (C, SetSection, "LLVMSetSection"); - pragma Import (C, GetVisibility, "LLVMGetVisibility"); - pragma Import (C, SetVisibility, "LLVMSetVisibility"); - pragma Import (C, GetAlignment, "LLVMGetAlignment"); - pragma Import (C, SetAlignment, "LLVMSetAlignment"); - - pragma Import (C, AddGlobal, "LLVMAddGlobal"); - pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal"); - pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal"); - pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal"); - pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal"); - pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal"); - pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal"); - pragma Import (C, GetInitializer, "LLVMGetInitializer"); - pragma Import (C, SetInitializer, "LLVMSetInitializer"); - pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal"); - pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal"); - pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant"); - pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant"); - - pragma Import (C, GetNamedMetadataNumOperands, - "LLVMGetNamedMetadataNumOperands"); - pragma Import (C, GetNamedMetadataOperands, "LLVMGetNamedMetadataOperands"); - pragma Import (C, AddNamedMetadataOperand, "LLVMAddNamedMetadataOperand"); - - pragma Import (C, AddFunction, "LLVMAddFunction"); - pragma Import (C, GetNamedFunction, "LLVMGetNamedFunction"); - pragma Import (C, GetFirstFunction, "LLVMGetFirstFunction"); - pragma Import (C, GetLastFunction, "LLVMGetLastFunction"); - pragma Import (C, GetNextFunction, "LLVMGetNextFunction"); - pragma Import (C, GetPreviousFunction, "LLVMGetPreviousFunction"); - pragma Import (C, DeleteFunction, "LLVMDeleteFunction"); - pragma Import (C, GetIntrinsicID, "LLVMGetIntrinsicID"); - pragma Import (C, GetFunctionCallConv, "LLVMGetFunctionCallConv"); - pragma Import (C, SetFunctionCallConv, "LLVMSetFunctionCallConv"); - pragma Import (C, GetGC, "LLVMGetGC"); - pragma Import (C, SetGC, "LLVMSetGC"); - - pragma Import (C, AddFunctionAttr, "LLVMAddFunctionAttr"); - pragma import (C, AddTargetDependentFunctionAttr, - "LLVMAddTargetDependentFunctionAttr"); - pragma Import (C, GetFunctionAttr, "LLVMGetFunctionAttr"); - pragma Import (C, RemoveFunctionAttr, "LLVMRemoveFunctionAttr"); - - pragma Import (C, CountParams, "LLVMCountParams"); - pragma Import (C, GetParams, "LLVMGetParams"); - pragma Import (C, GetParam, "LLVMGetParam"); - pragma Import (C, GetParamParent, "LLVMGetParamParent"); - pragma Import (C, GetFirstParam, "LLVMGetFirstParam"); - pragma Import (C, GetLastParam, "LLVMGetLastParam"); - pragma Import (C, GetNextParam, "LLVMGetNextParam"); - pragma Import (C, GetPreviousParam, "LLVMGetPreviousParam"); - pragma Import (C, AddAttribute, "LLVMAddAttribute"); - pragma Import (C, RemoveAttribute, "LLVMRemoveAttribute"); - pragma Import (C, SetParamAlignment, "LLVMSetParamAlignment"); - - pragma Import (C, MDStringInContext, "LLVMMDStringInContext"); - pragma Import (C, MDString, "LLVMMDString"); - pragma Import (C, MDNodeInContext, "LLVMMDNodeInContext"); - pragma Import (C, MDNode, "LLVMMDNode"); - pragma Import (C, GetMDString, "LLVMGetMDString"); - pragma Import (C, GetMDNodeNumOperands, "LLVMGetMDNodeNumOperands"); - pragma Import (C, GetMDNodeOperands, "LLVMGetMDNodeOperands"); - pragma Import (C, MDNodeReplaceOperandWith, - "LLVMMDNodeReplaceOperandWith_extra"); - - pragma Import (C, BasicBlockAsValue, "LLVMBasicBlockAsValue"); - pragma Import (C, ValueIsBasicBlock, "LLVMValueIsBasicBlock"); - pragma Import (C, ValueAsBasicBlock, "LLVMValueAsBasicBlock"); - pragma Import (C, GetBasicBlockParent, "LLVMGetBasicBlockParent"); - pragma Import (C, CountBasicBlocks, "LLVMCountBasicBlocks"); - pragma Import (C, GetBasicBlocks, "LLVMGetBasicBlocks"); - pragma Import (C, GetFirstBasicBlock, "LLVMGetFirstBasicBlock"); - pragma Import (C, GetLastBasicBlock, "LLVMGetLastBasicBlock"); - pragma Import (C, GetNextBasicBlock, "LLVMGetNextBasicBlock"); - pragma Import (C, GetPreviousBasicBlock, "LLVMGetPreviousBasicBlock"); - pragma Import (C, GetEntryBasicBlock, "LLVMGetEntryBasicBlock"); - pragma Import (C, AppendBasicBlock, "LLVMAppendBasicBlock"); - pragma Import (C, InsertBasicBlock, "LLVMInsertBasicBlock"); - pragma Import (C, DeleteBasicBlock, "LLVMDeleteBasicBlock"); - - pragma Import (C, HasMetadata, "LLVMHasMetadata"); - pragma Import (C, GetMetadata, "LLVMGetMetadata"); - pragma Import (C, SetMetadata, "LLVMSetMetadata"); - - pragma Import (C, GetInstructionParent, "LLVMGetInstructionParent"); - pragma Import (C, GetFirstInstruction, "LLVMGetFirstInstruction"); - pragma Import (C, GetLastInstruction, "LLVMGetLastInstruction"); - pragma Import (C, GetNextInstruction, "LLVMGetNextInstruction"); - pragma Import (C, GetPreviousInstruction, "LLVMGetPreviousInstruction"); - - pragma Import (C, SetInstructionCallConv, "LLVMSetInstructionCallConv"); - pragma Import (C, GetInstructionCallConv, "LLVMGetInstructionCallConv"); - pragma Import (C, AddInstrAttribute, "LLVMAddInstrAttribute"); - pragma Import (C, RemoveInstrAttribute, "LLVMRemoveInstrAttribute"); - pragma Import (C, SetInstrParamAlignment, "LLVMSetInstrParamAlignment"); - - pragma Import (C, IsTailCall, "LLVMIsTailCall"); - pragma Import (C, SetTailCall, "LLVMSetTailCall"); - - pragma Import (C, AddIncoming, "LLVMAddIncoming"); - pragma Import (C, CountIncoming, "LLVMCountIncoming"); - pragma Import (C, GetIncomingValue, "LLVMGetIncomingValue"); - pragma Import (C, GetIncomingBlock, "LLVMGetIncomingBlock"); - - pragma Import (C, CreateBuilder, "LLVMCreateBuilder"); - pragma Import (C, PositionBuilder, "LLVMPositionBuilder"); - pragma Import (C, PositionBuilderBefore, "LLVMPositionBuilderBefore"); - pragma Import (C, PositionBuilderAtEnd, "LLVMPositionBuilderAtEnd"); - pragma Import (C, GetInsertBlock, "LLVMGetInsertBlock"); - pragma Import (C, DisposeBuilder, "LLVMDisposeBuilder"); - - -- Terminators - pragma Import (C, BuildRetVoid, "LLVMBuildRetVoid"); - pragma Import (C, BuildRet, "LLVMBuildRet"); - pragma Import (C, BuildBr, "LLVMBuildBr"); - pragma Import (C, BuildCondBr, "LLVMBuildCondBr"); - pragma Import (C, BuildSwitch, "LLVMBuildSwitch"); - pragma Import (C, BuildInvoke, "LLVMBuildInvoke"); - pragma Import (C, BuildUnwind, "LLVMBuildUnwind"); - pragma Import (C, BuildUnreachable, "LLVMBuildUnreachable"); - - -- Add a case to the switch instruction - pragma Import (C, AddCase, "LLVMAddCase"); - - -- Arithmetic - pragma Import (C, BuildAdd, "LLVMBuildAdd"); - pragma Import (C, BuildNSWAdd, "LLVMBuildNSWAdd"); - pragma Import (C, BuildNUWAdd, "LLVMBuildNUWAdd"); - pragma Import (C, BuildFAdd, "LLVMBuildFAdd"); - pragma Import (C, BuildSub, "LLVMBuildSub"); - pragma Import (C, BuildNSWSub, "LLVMBuildNSWSub"); - pragma Import (C, BuildNUWSub, "LLVMBuildNUWSub"); - pragma Import (C, BuildFSub, "LLVMBuildFSub"); - pragma Import (C, BuildMul, "LLVMBuildMul"); - pragma Import (C, BuildFMul, "LLVMBuildFMul"); - pragma Import (C, BuildUDiv, "LLVMBuildUDiv"); - pragma Import (C, BuildSDiv, "LLVMBuildSDiv"); - pragma Import (C, BuildFDiv, "LLVMBuildFDiv"); - pragma Import (C, BuildURem, "LLVMBuildURem"); - pragma Import (C, BuildSRem, "LLVMBuildSRem"); - pragma Import (C, BuildFRem, "LLVMBuildFRem"); - pragma Import (C, BuildShl, "LLVMBuildShl"); - pragma Import (C, BuildLShr, "LLVMBuildLShr"); - pragma Import (C, BuildAShr, "LLVMBuildAShr"); - pragma Import (C, BuildAnd, "LLVMBuildAnd"); - pragma Import (C, BuildOr, "LLVMBuildOr"); - pragma Import (C, BuildXor, "LLVMBuildXor"); - pragma Import (C, BuildNeg, "LLVMBuildNeg"); - pragma Import (C, BuildFNeg, "LLVMBuildFNeg"); - pragma Import (C, BuildNot, "LLVMBuildNot"); - - -- Memory - pragma Import (C, BuildMalloc, "LLVMBuildMalloc"); - pragma Import (C, BuildArrayMalloc, "LLVMBuildArrayMalloc"); - pragma Import (C, BuildAlloca, "LLVMBuildAlloca"); - pragma Import (C, BuildArrayAlloca, "LLVMBuildArrayAlloca"); - pragma Import (C, BuildFree, "LLVMBuildFree"); - pragma Import (C, BuildLoad, "LLVMBuildLoad"); - pragma Import (C, BuildStore, "LLVMBuildStore"); - pragma Import (C, BuildGEP, "LLVMBuildGEP"); - - -- Casts - pragma Import (C, BuildTrunc, "LLVMBuildTrunc"); - pragma Import (C, BuildZExt, "LLVMBuildZExt"); - pragma Import (C, BuildSExt, "LLVMBuildSExt"); - pragma Import (C, BuildFPToUI, "LLVMBuildFPToUI"); - pragma Import (C, BuildFPToSI, "LLVMBuildFPToSI"); - pragma Import (C, BuildUIToFP, "LLVMBuildUIToFP"); - pragma Import (C, BuildSIToFP, "LLVMBuildSIToFP"); - pragma Import (C, BuildFPTrunc, "LLVMBuildFPTrunc"); - pragma Import (C, BuildFPExt, "LLVMBuildFPExt"); - pragma Import (C, BuildPtrToInt, "LLVMBuildPtrToInt"); - pragma Import (C, BuildIntToPtr, "LLVMBuildIntToPtr"); - pragma Import (C, BuildBitCast, "LLVMBuildBitCast"); - - -- Comparisons - pragma Import (C, BuildICmp, "LLVMBuildICmp"); - pragma Import (C, BuildFCmp, "LLVMBuildFCmp"); - - -- Miscellaneous instructions - pragma Import (C, BuildPhi, "LLVMBuildPhi"); - pragma Import (C, BuildCall, "LLVMBuildCall"); - pragma Import (C, BuildSelect, "LLVMBuildSelect"); - pragma Import (C, BuildVAArg, "LLVMBuildVAArg"); - pragma Import (C, BuildExtractElement, "LLVMBuildExtractElement"); - pragma Import (C, BuildInsertElement, "LLVMBuildInsertElement"); - pragma Import (C, BuildShuffleVector, "LLVMBuildShuffleVector"); - - -- Memory buffers ---------------------------------------------------- - pragma Import (C, CreateMemoryBufferWithContentsOfFile, - "LLVMCreateMemoryBufferWithContentsOfFile"); - pragma Import (C, CreateMemoryBufferWithSTDIN, - "LLVMCreateMemoryBufferWithSTDIN"); - pragma Import (C, DisposeMemoryBuffer, "LLVMDisposeMemoryBuffer"); - - -- Pass Managers ----------------------------------------------------- - pragma Import (C, CreatePassManager, "LLVMCreatePassManager"); - pragma Import (C, CreateFunctionPassManagerForModule, - "LLVMCreateFunctionPassManagerForModule"); - pragma Import (C, RunPassManager, "LLVMRunPassManager"); - pragma Import (C, InitializeFunctionPassManager, - "LLVMInitializeFunctionPassManager"); - pragma Import (C, RunFunctionPassManager, - "LLVMRunFunctionPassManager"); - pragma Import (C, FinalizeFunctionPassManager, - "LLVMFinalizeFunctionPassManager"); - pragma Import (C, DisposePassManager, "LLVMDisposePassManager"); - -end LLVM.Core; diff --git a/ortho/llvm/llvm-executionengine.ads b/ortho/llvm/llvm-executionengine.ads deleted file mode 100644 index 72d4cda2f..000000000 --- a/ortho/llvm/llvm-executionengine.ads +++ /dev/null @@ -1,163 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; use System; -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with LLVM.Core; use LLVM.Core; -with LLVM.Target; use LLVM.Target; - -package LLVM.ExecutionEngine is - type GenericValueRef is new Address; - type GenericValueRefArray is array (unsigned range <>) of GenericValueRef; - pragma Convention (C, GenericValueRefArray); - type ExecutionEngineRef is new Address; - - procedure LinkInJIT; - procedure LinkInMCJIT; - procedure LinkInInterpreter; - - -- Operations on generic values -------------------------------------- - - function CreateGenericValueOfInt(Ty : TypeRef; - N : Unsigned_64; - IsSigned : Integer) - return GenericValueRef; - - function CreateGenericValueOfPointer(P : System.Address) - return GenericValueRef; - - function CreateGenericValueOfFloat(Ty : TypeRef; N : double) - return GenericValueRef; - - function GenericValueIntWidth(GenValRef : GenericValueRef) - return unsigned; - - function GenericValueToInt(GenVal : GenericValueRef; - IsSigned : Integer) return Unsigned_64; - - function GenericValueToPointer(GenVal : GenericValueRef) - return System.Address; - - function GenericValueToFloat(TyRef : TypeRef; GenVal : GenericValueRef) - return double; - - procedure DisposeGenericValue(GenVal : GenericValueRef); - - -- Operations on execution engines ----------------------------------- - - function CreateExecutionEngineForModule - (EE : access ExecutionEngineRef; M : ModuleRef; Error : access Cstring) - return Bool; - - function CreateInterpreterForModule (Interp : access ExecutionEngineRef; - M : ModuleRef; - Error : access Cstring) - return Bool; - - function CreateJITCompilerForModule (JIT : access ExecutionEngineRef; - M : ModuleRef; - OptLevel : unsigned; - Error : access Cstring) - return Bool; - - - procedure DisposeExecutionEngine(EE : ExecutionEngineRef); - - procedure RunStaticConstructors(EE : ExecutionEngineRef); - - procedure RunStaticDestructors(EE : ExecutionEngineRef); - - function RunFunctionAsMain(EE : ExecutionEngineRef; - F : ValueRef; - ArgC : unsigned; Argv : Address; EnvP : Address) - return Integer; - - function RunFunction(EE : ExecutionEngineRef; - F : ValueRef; - NumArgs : unsigned; - Args : GenericValueRefArray) - return GenericValueRef; - - procedure FreeMachineCodeForFunction(EE : ExecutionEngineRef; F : ValueRef); - - procedure AddModule(EE : ExecutionEngineRef; M : ModuleRef); - - function RemoveModule(EE : ExecutionEngineRef; - M : ModuleRef; - OutMod : access ModuleRef; - OutError : access Cstring) return Bool; - - function FindFunction(EE : ExecutionEngineRef; Name : Cstring; - OutFn : access ValueRef) - return Integer; - - function GetExecutionEngineTargetData(EE : ExecutionEngineRef) - return TargetDataRef; - - procedure AddGlobalMapping(EE : ExecutionEngineRef; Global : ValueRef; - Addr : Address); - - function GetPointerToGlobal (EE : ExecutionEngineRef; GV : ValueRef) - return Address; - function GetPointerToFunctionOrStub (EE : ExecutionEngineRef; - Func : ValueRef) - return Address; - -private - pragma Import (C, LinkInJIT, "LLVMLinkInJIT"); - pragma Import (C, LinkInMCJIT, "LLVMLinkInMCJIT"); - pragma Import (C, LinkInInterpreter, "LLVMLinkInInterpreter"); - - pragma Import (C, CreateGenericValueOfInt, "LLVMCreateGenericValueOfInt"); - pragma Import (C, CreateGenericValueOfPointer, - "LLVMCreateGenericValueOfPointer"); - pragma Import (C, CreateGenericValueOfFloat, - "LLVMCreateGenericValueOfFloat"); - pragma Import (C, GenericValueIntWidth, "LLVMGenericValueIntWidth"); - pragma Import (C, GenericValueToInt, "LLVMGenericValueToInt"); - pragma Import (C, GenericValueToPointer, "LLVMGenericValueToPointer"); - pragma Import (C, GenericValueToFloat, "LLVMGenericValueToFloat"); - pragma Import (C, DisposeGenericValue, "LLVMDisposeGenericValue"); - - -- Operations on execution engines ----------------------------------- - - pragma Import (C, CreateExecutionEngineForModule, - "LLVMCreateExecutionEngineForModule"); - pragma Import (C, CreateInterpreterForModule, - "LLVMCreateInterpreterForModule"); - pragma Import (C, CreateJITCompilerForModule, - "LLVMCreateJITCompilerForModule"); - pragma Import (C, DisposeExecutionEngine, "LLVMDisposeExecutionEngine"); - pragma Import (C, RunStaticConstructors, "LLVMRunStaticConstructors"); - pragma Import (C, RunStaticDestructors, "LLVMRunStaticDestructors"); - pragma Import (C, RunFunctionAsMain, "LLVMRunFunctionAsMain"); - pragma Import (C, RunFunction, "LLVMRunFunction"); - pragma Import (C, FreeMachineCodeForFunction, - "LLVMFreeMachineCodeForFunction"); - pragma Import (C, AddModule, "LLVMAddModule"); - pragma Import (C, RemoveModule, "LLVMRemoveModule"); - pragma Import (C, FindFunction, "LLVMFindFunction"); - pragma Import (C, GetExecutionEngineTargetData, - "LLVMGetExecutionEngineTargetData"); - pragma Import (C, AddGlobalMapping, "LLVMAddGlobalMapping"); - - pragma Import (C, GetPointerToFunctionOrStub, - "LLVMGetPointerToFunctionOrStub"); - pragma Import (C, GetPointerToGlobal, - "LLVMGetPointerToGlobal"); -end LLVM.ExecutionEngine; diff --git a/ortho/llvm/llvm-target.ads b/ortho/llvm/llvm-target.ads deleted file mode 100644 index b7c35848a..000000000 --- a/ortho/llvm/llvm-target.ads +++ /dev/null @@ -1,84 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with LLVM.Core; use LLVM.Core; - -package LLVM.Target is - - type TargetDataRef is new System.Address; - - -- LLVMInitializeNativeTarget - The main program should call this function - -- to initialize the native target corresponding to the host. This is - -- useful for JIT applications to ensure that the target gets linked in - -- correctly. - procedure InitializeNativeTarget; - pragma Import (C, InitializeNativeTarget, - "LLVMInitializeNativeTarget_noinline"); - - -- LLVMInitializeNativeTargetAsmPrinter - The main program should call this - -- function to initialize the printer for the native target corresponding - -- to the host. - procedure InitializeNativeAsmPrinter; - pragma Import (C, InitializeNativeAsmPrinter, - "LLVMInitializeNativeAsmPrinter_noinline"); - - -- Creates target data from a target layout string. - -- See the constructor llvm::DataLayout::DataLayout. - function CreateTargetData (StringRep : Cstring) return TargetDataRef; - pragma Import (C, CreateTargetData, "LLVMCreateTargetData"); - - -- Adds target data information to a pass manager. This does not take - -- ownership of the target data. - -- See the method llvm::PassManagerBase::add. - procedure AddTargetData(TD : TargetDataRef; PM : PassManagerRef); - pragma Import (C, AddTargetData, "LLVMAddTargetData"); - - -- Converts target data to a target layout string. The string must be - -- disposed with LLVMDisposeMessage. - -- See the constructor llvm::DataLayout::DataLayout. */ - function CopyStringRepOfTargetData(TD :TargetDataRef) return Cstring; - pragma Import (C, CopyStringRepOfTargetData, - "LLVMCopyStringRepOfTargetData"); - - -- Returns the pointer size in bytes for a target. - -- See the method llvm::DataLayout::getPointerSize. - function PointerSize(TD : TargetDataRef) return unsigned; - pragma Import (C, PointerSize, "LLVMPointerSize"); - - -- Computes the ABI size of a type in bytes for a target. - -- See the method llvm::DataLayout::getTypeAllocSize. - function ABISizeOfType (TD : TargetDataRef; Ty: TypeRef) return Unsigned_64; - pragma Import (C, ABISizeOfType, "LLVMABISizeOfType"); - - -- Computes the ABI alignment of a type in bytes for a target. - -- See the method llvm::DataLayout::getTypeABISize. - function ABIAlignmentOfType (TD : TargetDataRef; Ty: TypeRef) - return Unsigned_32; - pragma Import (C, ABIAlignmentOfType, "LLVMABIAlignmentOfType"); - - -- Computes the byte offset of the indexed struct element for a target. - -- See the method llvm::StructLayout::getElementContainingOffset. - function OffsetOfElement(TD : TargetDataRef; - StructTy : TypeRef; - Element : Unsigned_32) - return Unsigned_64; - pragma Import (C, OffsetOfElement, "LLVMOffsetOfElement"); - -end LLVM.Target; diff --git a/ortho/llvm/llvm-targetmachine.ads b/ortho/llvm/llvm-targetmachine.ads deleted file mode 100644 index cbf074940..000000000 --- a/ortho/llvm/llvm-targetmachine.ads +++ /dev/null @@ -1,122 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with LLVM.Core; use LLVM.Core; -with LLVM.Target; use LLVM.Target; - -package LLVM.TargetMachine is - - type TargetMachineRef is new System.Address; - Null_TargetMachineRef : constant TargetMachineRef := - TargetMachineRef (System.Null_Address); - - type TargetRef is new System.Address; - Null_TargetRef : constant TargetRef := TargetRef (System.Null_Address); - - type CodeGenOptLevel is (CodeGenLevelNone, - CodeGenLevelLess, - CodeGenLevelDefault, - CodeGenLevelAggressive); - pragma Convention (C, CodeGenOptLevel); - - type RelocMode is (RelocDefault, - RelocStatic, - RelocPIC, - RelocDynamicNoPic); - pragma Convention (C, RelocMode); - - type CodeModel is (CodeModelDefault, - CodeModelJITDefault, - CodeModelSmall, - CodeModelKernel, - CodeModelMedium, - CodeModelLarge); - pragma Convention (C, CodeModel); - - type CodeGenFileType is (AssemblyFile, - ObjectFile); - pragma Convention (C, CodeGenFileType); - - -- Returns the first llvm::Target in the registered targets list. - function GetFirstTarget return TargetRef; - pragma Import (C, GetFirstTarget, "LLVMGetFirstTarget"); - - -- Returns the next llvm::Target given a previous one (or null if there's - -- none) */ - function GetNextTarget(T : TargetRef) return TargetRef; - pragma Import (C, GetNextTarget, "LLVMGetNextTarget"); - - -- Target - - -- Finds the target corresponding to the given name and stores it in T. - -- Returns 0 on success. - function GetTargetFromName (Name : Cstring) return TargetRef; - pragma Import (C, GetTargetFromName, "LLVMGetTargetFromName"); - - -- Finds the target corresponding to the given triple and stores it in T. - -- Returns 0 on success. Optionally returns any error in ErrorMessage. - -- Use LLVMDisposeMessage to dispose the message. - -- Ada: ErrorMessage is the address of a Cstring. - function GetTargetFromTriple - (Triple : Cstring; T : access TargetRef; ErrorMessage : access Cstring) - return Bool; - pragma Import (C, GetTargetFromTriple, "LLVMGetTargetFromTriple"); - - -- Returns the name of a target. See llvm::Target::getName - function GetTargetName (T: TargetRef) return Cstring; - pragma Import (C, GetTargetName, "LLVMGetTargetName"); - - -- Returns the description of a target. See llvm::Target::getDescription - function GetTargetDescription (T : TargetRef) return Cstring; - pragma Import (C, GetTargetDescription, "LLVMGetTargetDescription"); - - -- Target Machine ---------------------------------------------------- - - -- Creates a new llvm::TargetMachine. See llvm::Target::createTargetMachine - - function CreateTargetMachine(T : TargetRef; - Triple : Cstring; - CPU : Cstring; - Features : Cstring; - Level : CodeGenOptLevel; - Reloc : RelocMode; - CM : CodeModel) - return TargetMachineRef; - pragma Import (C, CreateTargetMachine, "LLVMCreateTargetMachine"); - - -- Returns the llvm::DataLayout used for this llvm:TargetMachine. - function GetTargetMachineData(T : TargetMachineRef) return TargetDataRef; - pragma Import (C, GetTargetMachineData, "LLVMGetTargetMachineData"); - - -- Emits an asm or object file for the given module to the filename. This - -- wraps several c++ only classes (among them a file stream). Returns any - -- error in ErrorMessage. Use LLVMDisposeMessage to dispose the message. - function TargetMachineEmitToFile(T : TargetMachineRef; - M : ModuleRef; - Filename : Cstring; - Codegen : CodeGenFileType; - ErrorMessage : access Cstring) - return Bool; - pragma Import (C, TargetMachineEmitToFile, - "LLVMTargetMachineEmitToFile"); - - -- Get a triple for the host machine as a string. The result needs to be - -- disposed with LLVMDisposeMessage. - function GetDefaultTargetTriple return Cstring; - pragma Import (C, GetDefaultTargetTriple, "LLVMGetDefaultTargetTriple"); -end LLVM.TargetMachine; diff --git a/ortho/llvm/llvm-transforms-scalar.ads b/ortho/llvm/llvm-transforms-scalar.ads deleted file mode 100644 index 0f23ce87e..000000000 --- a/ortho/llvm/llvm-transforms-scalar.ads +++ /dev/null @@ -1,169 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; - -package LLVM.Transforms.Scalar is - -- See llvm::createAggressiveDCEPass function. - procedure AddAggressiveDCEPass(PM : PassManagerRef); - pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass"); - - -- See llvm::createCFGSimplificationPass function. - procedure AddCFGSimplificationPass(PM : PassManagerRef); - pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass"); - - -- See llvm::createDeadStoreEliminationPass function. - procedure AddDeadStoreEliminationPass(PM : PassManagerRef); - pragma Import (C, AddDeadStoreEliminationPass, - "LLVMAddDeadStoreEliminationPass"); - - -- See llvm::createScalarizerPass function. - procedure AddScalarizerPass(PM : PassManagerRef); - pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass"); - - -- See llvm::createGVNPass function. - procedure AddGVNPass(PM : PassManagerRef); - pragma Import (C, AddGVNPass, "LLVMAddGVNPass"); - - -- See llvm::createIndVarSimplifyPass function. - procedure AddIndVarSimplifyPass(PM : PassManagerRef); - pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass"); - - -- See llvm::createInstructionCombiningPass function. - procedure AddInstructionCombiningPass(PM : PassManagerRef); - pragma Import (C, AddInstructionCombiningPass, - "LLVMAddInstructionCombiningPass"); - - -- See llvm::createJumpThreadingPass function. - procedure AddJumpThreadingPass(PM : PassManagerRef); - pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass"); - - -- See llvm::createLICMPass function. - procedure AddLICMPass(PM : PassManagerRef); - pragma Import (C, AddLICMPass, "LLVMAddLICMPass"); - - -- See llvm::createLoopDeletionPass function. - procedure AddLoopDeletionPass(PM : PassManagerRef); - pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass"); - - -- See llvm::createLoopIdiomPass function - procedure AddLoopIdiomPass(PM : PassManagerRef); - pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass"); - - -- See llvm::createLoopRotatePass function. - procedure AddLoopRotatePass(PM : PassManagerRef); - pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass"); - - -- See llvm::createLoopRerollPass function. - procedure AddLoopRerollPass(PM : PassManagerRef); - pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass"); - - -- See llvm::createLoopUnrollPass function. - procedure AddLoopUnrollPass(PM : PassManagerRef); - pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass"); - - -- See llvm::createLoopUnswitchPass function. - procedure AddLoopUnswitchPass(PM : PassManagerRef); - pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass"); - - -- See llvm::createMemCpyOptPass function. - procedure AddMemCpyOptPass(PM : PassManagerRef); - pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass"); - - -- See llvm::createPartiallyInlineLibCallsPass function. - procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef); - pragma Import (C, AddPartiallyInlineLibCallsPass, - "LLVMAddPartiallyInlineLibCallsPass"); - - -- See llvm::createPromoteMemoryToRegisterPass function. - procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef); - pragma Import (C, AddPromoteMemoryToRegisterPass, - "LLVMAddPromoteMemoryToRegisterPass"); - - -- See llvm::createReassociatePass function. - procedure AddReassociatePass(PM : PassManagerRef); - pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass"); - - -- See llvm::createSCCPPass function. - procedure AddSCCPPass(PM : PassManagerRef); - pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPass(PM : PassManagerRef); - pragma Import (C, AddScalarReplAggregatesPass, - "LLVMAddScalarReplAggregatesPass"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef); - pragma Import (C, AddScalarReplAggregatesPassSSA, - "LLVMAddScalarReplAggregatesPassSSA"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPassWithThreshold - (PM : PassManagerRef; Threshold : Integer); - pragma Import (C, AddScalarReplAggregatesPassWithThreshold, - "LLVMAddScalarReplAggregatesPassWithThreshold"); - - -- See llvm::createSimplifyLibCallsPass function. - procedure AddSimplifyLibCallsPass(PM : PassManagerRef); - pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass"); - - -- See llvm::createTailCallEliminationPass function. - procedure AddTailCallEliminationPass(PM : PassManagerRef); - pragma Import (C, AddTailCallEliminationPass, - "LLVMAddTailCallEliminationPass"); - - -- See llvm::createConstantPropagationPass function. - procedure AddConstantPropagationPass(PM : PassManagerRef); - pragma Import (C, AddConstantPropagationPass, - "LLVMAddConstantPropagationPass"); - - -- See llvm::demotePromoteMemoryToRegisterPass function. - procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef); - pragma Import (C, AddDemoteMemoryToRegisterPass, - "LLVMAddDemoteMemoryToRegisterPass"); - - -- See llvm::createVerifierPass function. - procedure AddVerifierPass(PM : PassManagerRef); - pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass"); - - -- See llvm::createCorrelatedValuePropagationPass function - procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef); - pragma Import (C, AddCorrelatedValuePropagationPass, - "LLVMAddCorrelatedValuePropagationPass"); - - -- See llvm::createEarlyCSEPass function - procedure AddEarlyCSEPass(PM : PassManagerRef); - pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass"); - - -- See llvm::createLowerExpectIntrinsicPass function - procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef); - pragma Import (C, AddLowerExpectIntrinsicPass, - "LLVMAddLowerExpectIntrinsicPass"); - - -- See llvm::createTypeBasedAliasAnalysisPass function - procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef); - pragma Import (C, AddTypeBasedAliasAnalysisPass, - "LLVMAddTypeBasedAliasAnalysisPass"); - - -- See llvm::createBasicAliasAnalysisPass function - procedure AddBasicAliasAnalysisPass(PM : PassManagerRef); - pragma Import (C, AddBasicAliasAnalysisPass, - "LLVMAddBasicAliasAnalysisPass"); -end LLVM.Transforms.Scalar; - - diff --git a/ortho/llvm/llvm-transforms.ads b/ortho/llvm/llvm-transforms.ads deleted file mode 100644 index d5a8011ce..000000000 --- a/ortho/llvm/llvm-transforms.ads +++ /dev/null @@ -1,21 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package LLVM.Transforms is - pragma Pure (LLVM.Transforms); -end LLVM.Transforms; diff --git a/ortho/llvm/llvm.ads b/ortho/llvm/llvm.ads deleted file mode 100644 index 80d036b84..000000000 --- a/ortho/llvm/llvm.ads +++ /dev/null @@ -1,21 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package LLVM is - pragma Pure (LLVM); -end LLVM; diff --git a/ortho/llvm/ortho_code_main.adb b/ortho/llvm/ortho_code_main.adb deleted file mode 100644 index 300bb32d1..000000000 --- a/ortho/llvm/ortho_code_main.adb +++ /dev/null @@ -1,391 +0,0 @@ --- LLVM back-end for ortho - Main subprogram. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; -with Ada.Text_IO; use Ada.Text_IO; - -with Ortho_Front; use Ortho_Front; -with LLVM.BitWriter; -with LLVM.Core; use LLVM.Core; -with LLVM.ExecutionEngine; use LLVM.ExecutionEngine; -with LLVM.Target; use LLVM.Target; -with LLVM.TargetMachine; use LLVM.TargetMachine; -with LLVM.Analysis; -with LLVM.Transforms.Scalar; -with Ortho_LLVM; use Ortho_LLVM; -with Interfaces; -with Interfaces.C; use Interfaces.C; - -procedure Ortho_Code_Main is - -- Name of the output filename (given by option '-o'). - Output : String_Acc := null; - - type Output_Kind_Type is (Output_Llvm, Output_Bytecode, - Output_Assembly, Output_Object); - Output_Kind : Output_Kind_Type := Output_Llvm; - - -- True if the LLVM output must be displayed (set by '--dump-llvm') - Flag_Dump_Llvm : Boolean := False; - - -- Index of the first file argument. - First_File : Natural; - - -- Set by '--exec': function to call and its argument (an integer) - Exec_Func : String_Acc := null; - Exec_Val : Integer := 0; - - -- Current option index. - Optind : Natural; - - -- Number of arguments. - Argc : constant Natural := Argument_Count; - - -- Name of the module. - Module_Name : String := "ortho" & Ascii.Nul; - - -- Target triple. - Triple : Cstring := Empty_Cstring; - - -- Execution engine - Engine : aliased ExecutionEngineRef; - - Target : aliased TargetRef; - - CPU : constant Cstring := Empty_Cstring; - Features : constant Cstring := Empty_Cstring; - Reloc : constant RelocMode := RelocDefault; - - procedure Dump_Llvm - is - use LLVM.Analysis; - Msg : aliased Cstring; - begin - DumpModule (Module); - if LLVM.Analysis.VerifyModule - (Module, PrintMessageAction, Msg'Access) /= 0 - then - null; - end if; - end Dump_Llvm; - - function To_String (C : Cstring) return String is - function Strlen (C : Cstring) return Natural; - pragma Import (C, Strlen); - - subtype Fat_String is String (Positive); - type Fat_String_Acc is access Fat_String; - - function To_Fat_String_Acc is new - Ada.Unchecked_Conversion (Cstring, Fat_String_Acc); - begin - return To_Fat_String_Acc (C)(1 .. Strlen (C)); - end To_String; - - Codegen : CodeGenFileType := ObjectFile; - - Msg : aliased Cstring; -begin - Ortho_Front.Init; - - -- Decode options. - First_File := Natural'Last; - Optind := 1; - while Optind <= Argc loop - declare - Arg : constant String := Argument (Optind); - begin - if Arg (1) = '-' then - if Arg = "--dump-llvm" then - Flag_Dump_Llvm := True; - elsif Arg = "-o" then - if Optind = Argc then - Put_Line (Standard_Error, "error: missing filename to '-o'"); - return; - end if; - Output := new String'(Argument (Optind + 1) & ASCII.Nul); - Optind := Optind + 1; - elsif Arg = "-quiet" then - -- Skip silently. - null; - elsif Arg = "-S" then - Output_Kind := Output_Assembly; - Codegen := AssemblyFile; - elsif Arg = "-c" then - Output_Kind := Output_Object; - Codegen := ObjectFile; - elsif Arg = "-O0" then - Optimization := CodeGenLevelNone; - elsif Arg = "-O1" then - Optimization := CodeGenLevelLess; - elsif Arg = "-O2" then - Optimization := CodeGenLevelDefault; - elsif Arg = "-O3" then - Optimization := CodeGenLevelAggressive; - elsif Arg = "--emit-llvm" then - Output_Kind := Output_Llvm; - elsif Arg = "--emit-bc" then - Output_Kind := Output_Bytecode; - elsif Arg = "--exec" then - if Optind + 1 >= Argc then - Put_Line (Standard_Error, - "error: missing function name to '--exec'"); - return; - end if; - Exec_Func := new String'(Argument (Optind + 1)); - Exec_Val := Integer'Value (Argument (Optind + 2)); - Optind := Optind + 2; - elsif Arg = "-g" then - Flag_Debug := True; - else - -- This is really an argument. - declare - procedure Unchecked_Deallocation is - new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - - Opt : String_Acc := new String'(Arg); - Opt_Arg : String_Acc; - Res : Natural; - begin - if Optind < Argument_Count then - Opt_Arg := new String'(Argument (Optind + 1)); - else - Opt_Arg := null; - end if; - Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); - case Res is - when 0 => - Put_Line (Standard_Error, - "unknown option '" & Arg & "'"); - return; - when 1 => - null; - when 2 => - Optind := Optind + 1; - when others => - raise Program_Error; - end case; - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Opt_Arg); - end; - end if; - else - First_File := Optind; - exit; - end if; - end; - Optind := Optind + 1; - end loop; - - -- Link with LLVM libraries. - InitializeNativeTarget; - InitializeNativeAsmPrinter; - - LinkInJIT; - - Module := ModuleCreateWithName (Module_Name'Address); - - if Output = null and then Exec_Func /= null then - -- Now we going to create JIT - if CreateExecutionEngineForModule - (Engine'Access, Module, Msg'Access) /= 0 - then - Put_Line (Standard_Error, - "cannot create execute: " & To_String (Msg)); - raise Program_Error; - end if; - - Target_Data := GetExecutionEngineTargetData (Engine); - else - -- Extract target triple - Triple := GetDefaultTargetTriple; - SetTarget (Module, Triple); - - -- Get Target - if GetTargetFromTriple (Triple, Target'Access, Msg'Access) /= 0 then - raise Program_Error; - end if; - - -- Create a target machine - Target_Machine := CreateTargetMachine - (Target, Triple, CPU, Features, Optimization, Reloc, CodeModelDefault); - - Target_Data := GetTargetMachineData (Target_Machine); - end if; - - SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data)); - - if False then - declare - Targ : TargetRef; - begin - Put_Line ("Triple: " & To_String (Triple)); - New_Line; - Put_Line ("Targets:"); - Targ := GetFirstTarget; - while Targ /= Null_TargetRef loop - Put_Line (" " & To_String (GetTargetName (Targ)) - & ": " & To_String (GetTargetDescription (Targ))); - Targ := GetNextTarget (Targ); - end loop; - end; - -- Target_Data := CreateTargetData (Triple); - end if; - - Ortho_LLVM.Init; - - Set_Exit_Status (Failure); - - if First_File > Argument_Count then - begin - if not Parse (null) then - return; - end if; - exception - when others => - return; - end; - else - for I in First_File .. Argument_Count loop - declare - Filename : constant String_Acc := - new String'(Argument (First_File)); - begin - if not Parse (Filename) then - return; - end if; - exception - when others => - return; - end; - end loop; - end if; - - if Flag_Debug then - Ortho_LLVM.Finish_Debug; - end if; - - -- Ortho_Mcode.Finish; - - if Flag_Dump_Llvm then - Dump_Llvm; - end if; - - -- Verify module. - if LLVM.Analysis.VerifyModule - (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0 - then - DisposeMessage (Msg); - raise Program_Error; - end if; - - if Optimization > CodeGenLevelNone then - declare - use LLVM.Transforms.Scalar; - Global_Manager : constant Boolean := False; - Pass_Manager : PassManagerRef; - Res : Bool; - pragma Unreferenced (Res); - A_Func : ValueRef; - begin - if Global_Manager then - Pass_Manager := CreatePassManager; - else - Pass_Manager := CreateFunctionPassManagerForModule (Module); - end if; - - LLVM.Target.AddTargetData (Target_Data, Pass_Manager); - AddPromoteMemoryToRegisterPass (Pass_Manager); - AddCFGSimplificationPass (Pass_Manager); - - if Global_Manager then - Res := RunPassManager (Pass_Manager, Module); - else - A_Func := GetFirstFunction (Module); - while A_Func /= Null_ValueRef loop - Res := RunFunctionPassManager (Pass_Manager, A_Func); - A_Func := GetNextFunction (A_Func); - end loop; - end if; - end; - end if; - - if Output /= null then - declare - Error : Boolean; - begin - Msg := Empty_Cstring; - - case Output_Kind is - when Output_Assembly - | Output_Object => - Error := LLVM.TargetMachine.TargetMachineEmitToFile - (Target_Machine, Module, - Output.all'Address, Codegen, Msg'Access) /= 0; - when Output_Bytecode => - Error := LLVM.BitWriter.WriteBitcodeToFile - (Module, Output.all'Address) /= 0; - when Output_Llvm => - Error := PrintModuleToFile - (Module, Output.all'Address, Msg'Access) /= 0; - end case; - if Error then - Put_Line (Standard_Error, - "error while writing to " & Output.all); - if Msg /= Empty_Cstring then - Put_Line (Standard_Error, - "message: " & To_String (Msg)); - DisposeMessage (Msg); - end if; - Set_Exit_Status (2); - return; - end if; - end; - elsif Exec_Func /= null then - declare - use Interfaces; - Res : GenericValueRef; - Vals : GenericValueRefArray (0 .. 0); - Func : aliased ValueRef; - begin - if FindFunction (Engine, Exec_Func.all'Address, Func'Access) /= 0 then - raise Program_Error; - end if; - - -- Call the function with argument n: - Vals (0) := CreateGenericValueOfInt - (Int32Type, Unsigned_64 (Exec_Val), 0); - Res := RunFunction (Engine, Func, 1, Vals); - - -- import result of execution - Put_Line ("Result is " - & Unsigned_64'Image (GenericValueToInt (Res, 0))); - - end; - else - Dump_Llvm; - end if; - - Set_Exit_Status (Success); -exception - when others => - Set_Exit_Status (2); - raise; -end Ortho_Code_Main; diff --git a/ortho/llvm/ortho_ident.adb b/ortho/llvm/ortho_ident.adb deleted file mode 100644 index e7b650539..000000000 --- a/ortho/llvm/ortho_ident.adb +++ /dev/null @@ -1,134 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Ident is - type Chunk (Max : Positive); - type Chunk_Acc is access Chunk; - - type Chunk (Max : Positive) is record - Prev : Chunk_Acc; - Len : Natural := 0; - S : String (1 .. Max); - end record; - - Cur_Chunk : Chunk_Acc := null; - - subtype Fat_String is String (Positive); - - function Get_Identifier (Str : String) return O_Ident - is - Len : constant Natural := Str'Length; - Max : Positive; - Org : Positive; - begin - if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then - if Cur_Chunk = null then - Max := 32 * 1024; - else - Max := 2 * Cur_Chunk.Max; - end if; - if Len + 2 > Max then - Max := 2 * (Len + 2); - end if; - declare - New_Chunk : Chunk_Acc; - begin - -- Do not use allocator by expression, as we don't want to - -- initialize S. - New_Chunk := new Chunk (Max); - New_Chunk.Len := 0; - New_Chunk.Prev := Cur_Chunk; - Cur_Chunk := New_Chunk; - end; - end if; - - Org := Cur_Chunk.Len + 1; - Cur_Chunk.S (Org .. Org + Len - 1) := Str; - Cur_Chunk.S (Org + Len) := ASCII.NUL; - Cur_Chunk.Len := Org + Len; - - return (Addr => Cur_Chunk.S (Org)'Address); - end Get_Identifier; - - function Is_Equal (L, R : O_Ident) return Boolean - is - begin - return L = R; - end Is_Equal; - - function Get_String_Length (Id : O_Ident) return Natural - is - Str : Fat_String; - pragma Import (Ada, Str); - for Str'Address use Id.Addr; - begin - for I in Str'Range loop - if Str (I) = ASCII.NUL then - return I - 1; - end if; - end loop; - raise Program_Error; - end Get_String_Length; - - function Get_String (Id : O_Ident) return String - is - Str : Fat_String; - pragma Import (Ada, Str); - for Str'Address use Id.Addr; - begin - for I in Str'Range loop - if Str (I) = ASCII.NUL then - return Str (1 .. I - 1); - end if; - end loop; - raise Program_Error; - end Get_String; - - function Get_Cstring (Id : O_Ident) return System.Address is - begin - return Id.Addr; - end Get_Cstring; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean - is - Istr : Fat_String; - pragma Import (Ada, Istr); - for Istr'Address use Id.Addr; - - Str_Len : constant Natural := Str'Length; - begin - for I in Istr'Range loop - if Istr (I) = ASCII.NUL then - return I - 1 = Str_Len; - end if; - if I > Str_Len then - return False; - end if; - if Istr (I) /= Str (Str'First + I - 1) then - return False; - end if; - end loop; - raise Program_Error; - end Is_Equal; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = O_Ident_Nul; - end Is_Nul; - -end Ortho_Ident; diff --git a/ortho/llvm/ortho_ident.ads b/ortho/llvm/ortho_ident.ads deleted file mode 100644 index 7d3955c02..000000000 --- a/ortho/llvm/ortho_ident.ads +++ /dev/null @@ -1,42 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; - -package Ortho_Ident is - type O_Ident is private; - - function Get_Identifier (Str : String) return O_Ident; - function Is_Equal (L, R : O_Ident) return Boolean; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; - function Get_String (Id : O_Ident) return String; - function Get_String_Length (Id : O_Ident) return Natural; - - -- Note: the address is always valid. - function Get_Cstring (Id : O_Ident) return System.Address; - - O_Ident_Nul : constant O_Ident; - -private - type O_Ident is record - Addr : System.Address; - end record; - O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address); - - pragma Inline (Get_Cstring); -end Ortho_Ident; diff --git a/ortho/llvm/ortho_jit.adb b/ortho/llvm/ortho_jit.adb deleted file mode 100644 index fdda667d9..000000000 --- a/ortho/llvm/ortho_jit.adb +++ /dev/null @@ -1,151 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ada.Text_IO; use Ada.Text_IO; - -with Ortho_LLVM; use Ortho_LLVM; -with Ortho_LLVM.Jit; - -with LLVM.Core; use LLVM.Core; -with LLVM.Target; use LLVM.Target; --- with LLVM.TargetMachine; use LLVM.TargetMachine; -with LLVM.ExecutionEngine; use LLVM.ExecutionEngine; -with LLVM.Analysis; --- with Interfaces; -with Interfaces.C; use Interfaces.C; - -package body Ortho_Jit is - -- Snap_Filename : GNAT.OS_Lib.String_Access := null; - - Flag_Dump_Llvm : Boolean := False; - - -- Name of the module. - Module_Name : String := "ortho" & Ascii.Nul; - - -- procedure DisableLazyCompilation (EE : ExecutionEngineRef; - -- Disable : int); - -- pragma Import (C, DisableLazyCompilation, - -- "LLVMDisableLazyCompilation"); - - -- Initialize the whole engine. - procedure Init - is - Msg : aliased Cstring; - begin - InitializeNativeTarget; - InitializeNativeAsmPrinter; - - LinkInJIT; - - Module := ModuleCreateWithName (Module_Name'Address); - - -- Now we going to create JIT - if CreateExecutionEngineForModule - (Ortho_LLVM.Jit.Engine'Access, Module, Msg'Access) /= 0 - then - Put_Line (Standard_Error, "cannot create execution engine"); - raise Program_Error; - end if; - - Target_Data := GetExecutionEngineTargetData (Ortho_LLVM.Jit.Engine); - SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data)); - - Ortho_LLVM.Init; - end Init; - - procedure Set_Address (Decl : O_Dnode; Addr : Address) - renames Ortho_LLVM.Jit.Set_Address; - - function Get_Address (Decl : O_Dnode) return Address - renames Ortho_LLVM.Jit.Get_Address; - - -- procedure InstallLazyFunctionCreator (EE : ExecutionEngineRef; - -- Func : Address); - -- pragma Import (C, InstallLazyFunctionCreator, - -- "LLVMInstallLazyFunctionCreator"); - - -- Do link. - procedure Link (Status : out Boolean) - is - use LLVM.Analysis; - Msg : aliased Cstring; - begin - if Flag_Debug then - Ortho_LLVM.Finish_Debug; - end if; - - if Flag_Dump_Llvm then - DumpModule (Module); - end if; - - -- Verify module. - if LLVM.Analysis.VerifyModule - (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0 - then - DisposeMessage (Msg); - Status := False; - return; - end if; - - -- FIXME: optim - end Link; - - procedure Finish - is - -- F : ValueRef; - -- Addr : Address; - -- pragma Unreferenced (Addr); - begin - null; - - -- if No_Lazy then - -- -- Be sure all functions code has been generated. - -- F := GetFirstFunction (Module); - -- while F /= Null_ValueRef loop - -- if GetFirstBasicBlock (F) /= Null_BasicBlockRef then - -- -- Only care about defined functions. - -- Addr := GetPointerToFunction (EE, F); - -- end if; - -- F := GetNextFunction (F); - -- end loop; - -- end if; - end Finish; - - function Decode_Option (Option : String) return Boolean - is - Opt : constant String (1 .. Option'Length) := Option; - begin - if Opt = "--llvm-dump" then - Flag_Dump_Llvm := True; - return True; - end if; - return False; - end Decode_Option; - - procedure Disp_Help is - begin - null; - end Disp_Help; - - function Get_Jit_Name return String is - begin - return "LLVM"; - end Get_Jit_Name; - -end Ortho_Jit; diff --git a/ortho/llvm/ortho_llvm-jit.adb b/ortho/llvm/ortho_llvm-jit.adb deleted file mode 100644 index 9155a02c7..000000000 --- a/ortho/llvm/ortho_llvm-jit.adb +++ /dev/null @@ -1,55 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_LLVM.Jit is - -- procedure AddExternalFunction (Name : Cstring; Val : Address); - -- pragma Import (C, AddExternalFunction, "ortho_AddExternalFunction"); - - function GetPointerToFunction (EE : ExecutionEngineRef; Func : ValueRef) - return Address; - pragma Import (C, GetPointerToFunction, "LLVMGetPointerToFunction"); - - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address) is - begin - case Decl.Kind is - when ON_Var_Decl | ON_Const_Decl => - AddGlobalMapping (Engine, Decl.LLVM, Addr); - when ON_Subprg_Decl => - null; - -- AddExternalFunction (GetValueName (Decl.LLVM), Addr); - when others => - raise Program_Error; - end case; - end Set_Address; - - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address - is - begin - case Decl.Kind is - when ON_Var_Decl | ON_Const_Decl => - return GetPointerToGlobal (Engine, Decl.LLVM); - when ON_Subprg_Decl => - return GetPointerToFunction (Engine, Decl.LLVM); - when others => - raise Program_Error; - end case; - end Get_Address; - -end Ortho_LLVM.Jit; diff --git a/ortho/llvm/ortho_llvm-jit.ads b/ortho/llvm/ortho_llvm-jit.ads deleted file mode 100644 index 5296e2ed8..000000000 --- a/ortho/llvm/ortho_llvm-jit.ads +++ /dev/null @@ -1,31 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; use System; -with LLVM.ExecutionEngine; use LLVM.ExecutionEngine; - -package Ortho_LLVM.Jit is - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address); - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address; - - -- Execution engine - Engine : aliased ExecutionEngineRef; - -end Ortho_LLVM.Jit; diff --git a/ortho/llvm/ortho_llvm.adb b/ortho/llvm/ortho_llvm.adb deleted file mode 100644 index dd8e64971..000000000 --- a/ortho/llvm/ortho_llvm.adb +++ /dev/null @@ -1,2881 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with LLVM.Target; use LLVM.Target; -with GNAT.Directory_Operations; - -package body Ortho_LLVM is - -- The current function for LLVM (needed to add new basic blocks). - Cur_Func : ValueRef; - - -- The current function node (needed for return type). - Cur_Func_Decl : O_Dnode; - - -- Wether the code is currently unreachable. LLVM doesn't accept basic - -- blocks that cannot be reached (using trivial rules). So we need to - -- discard instructions after a return, a next or an exit statement. - Unreach : Boolean; - - -- Builder for statements. - Builder : BuilderRef; - - -- Builder for declarations (local variables). - Decl_Builder : BuilderRef; - - -- Temporary builder. - Extra_Builder : BuilderRef; - - -- Declaration of llvm.dbg.declare - Llvm_Dbg_Declare : ValueRef; - - Debug_ID : unsigned; - - Current_Directory : constant String := - GNAT.Directory_Operations.Get_Current_Dir; - - -- Additional data for declare blocks. - type Declare_Block_Type; - type Declare_Block_Acc is access Declare_Block_Type; - - type Declare_Block_Type is record - -- First basic block of the declare. - Stmt_Bb : BasicBlockRef; - - -- Stack pointer at entry of the block. This value has to be restore - -- when leaving the block (either normally or via exit/next). Set only - -- if New_Alloca was used. - -- FIXME: TODO: restore stack pointer on exit/next stmts. - Stack_Value : ValueRef; - - -- Debug data for the scope of the declare block. - Dbg_Scope : ValueRef; - - -- Previous element in the stack. - Prev : Declare_Block_Acc; - end record; - - -- Current declare block. - Cur_Declare_Block : Declare_Block_Acc; - - -- Chain of unused blocks to be recycled. - Old_Declare_Block : Declare_Block_Acc; - - Stacksave_Fun : ValueRef; - Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; - Stackrestore_Fun : ValueRef; - Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; - - -- For debugging - - DW_Version : constant := 16#c_0000#; - DW_TAG_Array_Type : constant := DW_Version + 16#01#; - DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#; - DW_TAG_Lexical_Block : constant := DW_Version + 16#0b#; - DW_TAG_Member : constant := DW_Version + 16#0d#; - DW_TAG_Pointer_Type : constant := DW_Version + 16#0f#; - DW_TAG_Compile_Unit : constant := DW_Version + 16#11#; - DW_TAG_Structure_Type : constant := DW_Version + 16#13#; - DW_TAG_Subroutine_Type : constant := DW_Version + 16#15#; - DW_TAG_Subrange_Type : constant := DW_Version + 16#21#; - DW_TAG_Base_Type : constant := DW_Version + 16#24#; - DW_TAG_Enumerator : constant := DW_Version + 16#28#; - DW_TAG_File_Type : constant := DW_Version + 16#29#; - DW_TAG_Subprogram : constant := DW_Version + 16#2e#; - DW_TAG_Variable : constant := DW_Version + 16#34#; - - DW_TAG_Auto_Variable : constant := DW_Version + 16#100#; - DW_TAG_Arg_Variable : constant := DW_Version + 16#101#; - - DW_ATE_address : constant := 16#01#; - DW_ATE_boolean : constant := 16#02#; - DW_ATE_float : constant := 16#04#; - DW_ATE_signed : constant := 16#05#; - DW_ATE_unsigned : constant := 16#07#; - pragma Unreferenced (DW_ATE_address, DW_ATE_boolean); - - -- File + Dir metadata - Dbg_Current_Filedir : ValueRef; - Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type - - Dbg_Current_Line : unsigned := 0; - - Dbg_Current_Scope : ValueRef; - Scope_Uniq_Id : Unsigned_64 := 0; - - -- Metadata for the instruction - Dbg_Insn_MD : ValueRef; - Dbg_Insn_MD_Line : unsigned := 0; - - procedure Free is new Ada.Unchecked_Deallocation - (ValueRefArray, ValueRefArray_Acc); - - package Dbg_Utils is - type Dyn_MDNode is private; - - procedure Append (D : in out Dyn_MDNode; Val : ValueRef); - function Get_Value (D : Dyn_MDNode) return ValueRef; - - -- Reset D. FIXME: should be done automatically within Get_Value. - procedure Clear (D : out Dyn_MDNode); - private - Chunk_Length : constant unsigned := 32; - type MD_Chunk; - type MD_Chunk_Acc is access MD_Chunk; - - type MD_Chunk is record - Vals : ValueRefArray (1 .. Chunk_Length); - Next : MD_Chunk_Acc; - end record; - - type Dyn_MDNode is record - First : MD_Chunk_Acc; - Last : MD_Chunk_Acc; - Nbr : unsigned := 0; - end record; - end Dbg_Utils; - - package body Dbg_Utils is - procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is - Chunk : MD_Chunk_Acc; - Pos : constant unsigned := D.Nbr rem Chunk_Length; - begin - if Pos = 0 then - Chunk := new MD_Chunk; - if D.First = null then - D.First := Chunk; - else - D.Last.Next := Chunk; - end if; - D.Last := Chunk; - else - Chunk := D.Last; - end if; - Chunk.Vals (Pos + 1) := Val; - D.Nbr := D.Nbr + 1; - end Append; - - procedure Free is new Ada.Unchecked_Deallocation - (MD_Chunk, MD_Chunk_Acc); - - function Get_Value (D : Dyn_MDNode) return ValueRef - is - Vals : ValueRefArray (1 .. D.Nbr); - Pos : unsigned; - Chunk : MD_Chunk_Acc := D.First; - Next_Chunk : MD_Chunk_Acc; - Nbr : constant unsigned := D.Nbr; - begin - Pos := 0; - -- Copy by chunks - while Pos + Chunk_Length < Nbr loop - Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals; - Pos := Pos + Chunk_Length; - Next_Chunk := Chunk.Next; - Free (Chunk); - Chunk := Next_Chunk; - end loop; - -- Last chunk - if Pos < Nbr then - Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos); - Free (Chunk); - end if; - return MDNode (Vals, Vals'Length); - end Get_Value; - - procedure Clear (D : out Dyn_MDNode) is - begin - D := (null, null, 0); - end Clear; - end Dbg_Utils; - - use Dbg_Utils; - - -- List of debug info for subprograms. - Subprg_Nodes: Dyn_MDNode; - - -- List of literals for enumerated type - Enum_Nodes : Dyn_MDNode; - - -- List of global variables - Global_Nodes : Dyn_MDNode; - - -- Create a MDString from an Ada string. - function MDString (Str : String) return ValueRef is - begin - return MDString (Str'Address, Str'Length); - end MDString; - - function MDString (Id : O_Ident) return ValueRef is - begin - return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id))); - end MDString; - - function Dbg_Size (Atype : TypeRef) return ValueRef is - begin - return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0); - end Dbg_Size; - - function Dbg_Align (Atype : TypeRef) return ValueRef is - begin - return ConstInt - (Int64Type, - Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0); - end Dbg_Align; - - function Dbg_Line return ValueRef is - begin - return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0); - end Dbg_Line; - - -- Set debug metadata on instruction INSN. - -- FIXME: check if INSN is really an instruction - procedure Set_Insn_Dbg (Insn : ValueRef) is - begin - if Flag_Debug then - if Dbg_Current_Line /= Dbg_Insn_MD_Line then - declare - Vals : ValueRefArray (0 .. 3); - begin - Vals := (Dbg_Line, - ConstInt (Int32Type, 0, 0), -- col - Dbg_Current_Scope, -- context - Null_ValueRef); -- inline - Dbg_Insn_MD := MDNode (Vals, Vals'Length); - Dbg_Insn_MD_Line := Dbg_Current_Line; - end; - end if; - SetMetadata (Insn, Debug_ID, Dbg_Insn_MD); - end if; - end Set_Insn_Dbg; - - procedure Dbg_Create_Variable (Tag : Unsigned_32; - Ident : O_Ident; - Vtype : O_Tnode; - Argno : Natural; - Addr : ValueRef) - is - Vals : ValueRefArray (0 .. 7); - Str : constant ValueRef := MDString (Ident); - Call_Vals : ValueRefArray (0 .. 1); - Call : ValueRef; - begin - Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0), - Dbg_Current_Scope, - Str, - Dbg_Current_File, - ConstInt (Int32Type, - Unsigned_64 (Dbg_Current_Line) - + Unsigned_64 (Argno) * 2 ** 24, 0), - Vtype.Dbg, - ConstInt (Int32Type, 0, 0), -- flags - ConstInt (Int32Type, 0, 0)); - - Call_Vals := (MDNode ((0 => Addr), 1), - MDNode (Vals, Vals'Length)); - Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare, - Call_Vals, Call_Vals'Length, Empty_Cstring); - Set_Insn_Dbg (Call); - end Dbg_Create_Variable; - - procedure Create_Declare_Block - is - Res : Declare_Block_Acc; - begin - -- Try to recycle an unused record. - if Old_Declare_Block /= null then - Res := Old_Declare_Block; - Old_Declare_Block := Res.Prev; - else - -- Create a new one if no unused records. - Res := new Declare_Block_Type; - end if; - - -- Chain. - Res.all := (Stmt_Bb => Null_BasicBlockRef, - Stack_Value => Null_ValueRef, - Dbg_Scope => Null_ValueRef, - Prev => Cur_Declare_Block); - Cur_Declare_Block := Res; - - if not Unreach then - Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); - end if; - end Create_Declare_Block; - - procedure Destroy_Declare_Block - is - Blk : constant Declare_Block_Acc := Cur_Declare_Block; - begin - -- Unchain. - Cur_Declare_Block := Blk.Prev; - - -- Put on the recyle list. - Blk.Prev := Old_Declare_Block; - Old_Declare_Block := Blk; - end Destroy_Declare_Block; - - ----------------------- - -- Start_Record_Type -- - ----------------------- - - procedure Start_Record_Type (Elements : out O_Element_List) is - begin - Elements := (Nbr_Elements => 0, - Rec_Type => O_Tnode_Null, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Record_Type; - - ---------------------- - -- New_Record_Field -- - ---------------------- - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - O_El : O_Element_Acc; - begin - El := (Kind => OF_Record, - Index => Elements.Nbr_Elements, - Ftype => Etype); - Elements.Nbr_Elements := Elements.Nbr_Elements + 1; - O_El := new O_Element'(Next => null, - Etype => Etype, - Ident => Ident); - if Elements.First_Elem = null then - Elements.First_Elem := O_El; - else - Elements.Last_Elem.Next := O_El; - end if; - Elements.Last_Elem := O_El; - end New_Record_Field; - - ------------------------ - -- Finish_Record_Type -- - ------------------------ - - procedure Finish_Record_Type - (Elements : in out O_Element_List; - Res : out O_Tnode) - is - procedure Free is new Ada.Unchecked_Deallocation - (O_Element, O_Element_Acc); - - Count : constant unsigned := unsigned (Elements.Nbr_Elements); - El : O_Element_Acc; - Next_El : O_Element_Acc; - Types : TypeRefArray (1 .. Count); - begin - El := Elements.First_Elem; - for I in Types'Range loop - Types (I) := Get_LLVM_Type (El.Etype); - El := El.Next; - end loop; - - if Elements.Rec_Type /= null then - -- Completion - StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); - Res := Elements.Rec_Type; - else - Res := new O_Tnode_Type'(Kind => ON_Record_Type, - LLVM => StructType (Types, Count, 0), - Dbg => Null_ValueRef); - end if; - - if Flag_Debug then - declare - Fields : ValueRefArray (1 .. Count); - Vals : ValueRefArray (0 .. 9); - Ftype : TypeRef; - Fields_Arr : ValueRef; - begin - El := Elements.First_Elem; - for I in Fields'Range loop - Ftype := Get_LLVM_Type (El.Etype); - Vals := - (ConstInt (Int32Type, DW_TAG_Member, 0), - Dbg_Current_File, - Null_ValueRef, - MDString (El.Ident), - ConstInt (Int32Type, 0, 0), -- linenum - Dbg_Size (Ftype), - Dbg_Align (Ftype), - ConstInt - (Int32Type, - 8 * OffsetOfElement (Target_Data, - Res.LLVM, Unsigned_32 (I - 1)), 0), - ConstInt (Int32Type, 0, 0), -- Flags - El.Etype.Dbg); - Fields (I) := MDNode (Vals, Vals'Length); - El := El.Next; - end loop; - Fields_Arr := MDNode (Fields, Fields'Length); - if Elements.Rec_Type /= null then - -- Completion - MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr); - MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM)); - MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM)); - else - -- Temporary borrowed. - Res.Dbg := Fields_Arr; - end if; - end; - end if; - - -- Free elements - El := Elements.First_Elem; - for I in Types'Range loop - Next_El := El.Next; - Free (El); - El := Next_El; - end loop; - end Finish_Record_Type; - - -------------------------------- - -- New_Uncomplete_Record_Type -- - -------------------------------- - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is - begin - -- LLVM type will be created when the type is declared. - Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, - LLVM => Null_TypeRef, - Dbg => Null_ValueRef); - end New_Uncomplete_Record_Type; - - ---------------------------------- - -- Start_Uncomplete_Record_Type -- - ---------------------------------- - - procedure Start_Uncomplete_Record_Type - (Res : O_Tnode; - Elements : out O_Element_List) - is - begin - if Res.Kind /= ON_Incomplete_Record_Type then - raise Program_Error; - end if; - Elements := (Nbr_Elements => 0, - Rec_Type => Res, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Uncomplete_Record_Type; - - ---------------------- - -- Start_Union_Type -- - ---------------------- - - procedure Start_Union_Type (Elements : out O_Element_List) is - begin - Elements := (Nbr_Elements => 0, - Rec_Type => O_Tnode_Null, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Union_Type; - - --------------------- - -- New_Union_Field -- - --------------------- - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - pragma Unreferenced (Ident); - - El_Type : constant TypeRef := Get_LLVM_Type (Etype); - Size : constant unsigned := - unsigned (ABISizeOfType (Target_Data, El_Type)); - Align : constant Unsigned_32 := - ABIAlignmentOfType (Target_Data, El_Type); - begin - El := (Kind => OF_Union, Utype => El_Type, Ftype => Etype); - if Size > Elements.Size then - Elements.Size := Size; - end if; - if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then - Elements.Align := Align; - Elements.Align_Type := El_Type; - end if; - end New_Union_Field; - - ----------------------- - -- Finish_Union_Type -- - ----------------------- - - procedure Finish_Union_Type - (Elements : in out O_Element_List; - Res : out O_Tnode) - is - Count : unsigned; - Types : TypeRefArray (1 .. 2); - Pad : unsigned; - begin - if Elements.Align_Type = Null_TypeRef then - -- An empty union. Is it allowed ? - Count := 0; - else - -- The first element is the field with the biggest alignment - Types (1) := Elements.Align_Type; - -- Possibly complete with an array of bytes. - Pad := Elements.Size - - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); - if Pad /= 0 then - Types (2) := ArrayType (Int8Type, Pad); - Count := 2; - else - Count := 1; - end if; - end if; - Res := new O_Tnode_Type'(Kind => ON_Union_Type, - LLVM => StructType (Types, Count, 0), - Dbg => Null_ValueRef, - Un_Size => Elements.Size, - Un_Main_Field => Elements.Align_Type); - end Finish_Union_Type; - - --------------------- - -- New_Access_Type -- - --------------------- - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode is - begin - if Dtype = O_Tnode_Null then - -- LLVM type will be built by New_Type_Decl, so that the name - -- can be used for the structure. - return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, - LLVM => Null_TypeRef, - Dbg => Null_ValueRef, - Acc_Type => O_Tnode_Null); - else - return new O_Tnode_Type'(Kind => ON_Access_Type, - LLVM => PointerType (Get_LLVM_Type (Dtype)), - Dbg => Null_ValueRef, - Acc_Type => Dtype); - end if; - end New_Access_Type; - - ------------------------ - -- Finish_Access_Type -- - ------------------------ - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) - is - Types : TypeRefArray (1 .. 1); - begin - if Atype.Kind /= ON_Incomplete_Access_Type then - -- Not an incomplete access type. - raise Program_Error; - end if; - if Atype.Acc_Type /= O_Tnode_Null then - -- Already completed. - raise Program_Error; - end if; - -- Completion - Types (1) := Get_LLVM_Type (Dtype); - StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); - Atype.Acc_Type := Dtype; - - -- Debug. - -- FIXME. - end Finish_Access_Type; - - -------------------- - -- New_Array_Type -- - -------------------- - - function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode) - return ValueRef - is - Rng : ValueRefArray (0 .. 2); - Rng_Arr : ValueRefArray (0 .. 0); - Vals : ValueRefArray (0 .. 14); - begin - Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0), - ConstInt (Int64Type, 0, 0), -- Lo - Len); -- Count - Rng_Arr := (0 => MDNode (Rng, Rng'Length)); - Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0), - Null_ValueRef, - Null_ValueRef, -- context - Null_ValueRef, - ConstInt (Int32Type, 0, 0), -- line - Dbg_Size (Atype.LLVM), - Dbg_Align (Atype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - El_Type.Dbg, -- element type - MDNode (Rng_Arr, Rng_Arr'Length), -- subscript - ConstInt (Int32Type, 0, 0), - Null_ValueRef, - Null_ValueRef, - Null_ValueRef); -- Runtime lang - return MDNode (Vals, Vals'Length); - end Dbg_Array; - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode - is - pragma Unreferenced (Index_Type); - Res : O_Tnode; - begin - Res := new O_Tnode_Type' - (Kind => ON_Array_Type, - LLVM => ArrayType (Get_LLVM_Type (El_Type), 0), - Dbg => Null_ValueRef, - Arr_El_Type => El_Type); - - if Flag_Debug then - Res.Dbg := Dbg_Array - (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res); - end if; - - return Res; - end New_Array_Type; - - -------------------------------- - -- New_Constrained_Array_Type -- - -------------------------------- - - function New_Constrained_Array_Type - (Atype : O_Tnode; Length : O_Cnode) return O_Tnode - is - Res : O_Tnode; - Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM)); - begin - Res := new O_Tnode_Type' - (Kind => ON_Array_Sub_Type, - LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len), - Dbg => Null_ValueRef, - Arr_El_Type => Atype.Arr_El_Type); - - if Flag_Debug then - Res.Dbg := Dbg_Array - (Atype.Arr_El_Type, - ConstInt (Int64Type, Unsigned_64 (Len), 0), Res); - end if; - - return Res; - end New_Constrained_Array_Type; - - ----------------------- - -- New_Unsigned_Type -- - ----------------------- - - function Size_To_Llvm (Size : Natural) return TypeRef is - Llvm : TypeRef; - begin - case Size is - when 8 => - Llvm := Int8Type; - when 32 => - Llvm := Int32Type; - when 64 => - Llvm := Int64Type; - when others => - raise Program_Error; - end case; - return Llvm; - end Size_To_Llvm; - - function New_Unsigned_Type (Size : Natural) return O_Tnode is - begin - return new O_Tnode_Type'(Kind => ON_Unsigned_Type, - LLVM => Size_To_Llvm (Size), - Dbg => Null_ValueRef, - Scal_Size => Size); - end New_Unsigned_Type; - - --------------------- - -- New_Signed_Type -- - --------------------- - - function New_Signed_Type (Size : Natural) return O_Tnode is - begin - return new O_Tnode_Type'(Kind => ON_Signed_Type, - LLVM => Size_To_Llvm (Size), - Dbg => Null_ValueRef, - Scal_Size => Size); - end New_Signed_Type; - - -------------------- - -- New_Float_Type -- - -------------------- - - function New_Float_Type return O_Tnode is - begin - return new O_Tnode_Type'(Kind => ON_Float_Type, - LLVM => DoubleType, - Dbg => Null_ValueRef, - Scal_Size => 64); - end New_Float_Type; - - procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is - Vals : ValueRefArray (0 .. 2); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0), - MDString (Id), - ConstInt (Int64Type, Val, 0)); - -- FIXME: make it local to List ? - Append (Enum_Nodes, MDNode (Vals, Vals'Length)); - end Dbg_Add_Enumeration; - - ---------------------- - -- New_Boolean_Type -- - ---------------------- - - procedure New_Boolean_Type - (Res : out O_Tnode; - False_Id : O_Ident; False_E : out O_Cnode; - True_Id : O_Ident; True_E : out O_Cnode) - is - begin - Res := new O_Tnode_Type'(Kind => ON_Boolean_Type, - LLVM => Int1Type, - Dbg => Null_ValueRef, - Scal_Size => 1); - False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0), - Ctype => Res); - True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0), - Ctype => Res); - if Flag_Debug then - Dbg_Add_Enumeration (False_Id, 0); - Dbg_Add_Enumeration (True_Id, 1); - end if; - end New_Boolean_Type; - - --------------------- - -- Start_Enum_Type -- - --------------------- - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) - is - LLVM : constant TypeRef := Size_To_Llvm (Size); - begin - List := (LLVM => LLVM, - Num => 0, - Etype => new O_Tnode_Type'(Kind => ON_Enum_Type, - LLVM => LLVM, - Scal_Size => Size, - Dbg => Null_ValueRef)); - - end Start_Enum_Type; - - ---------------------- - -- New_Enum_Literal -- - ---------------------- - - procedure New_Enum_Literal - (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) - is - begin - Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0), - Ctype => List.Etype); - if Flag_Debug then - Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num)); - end if; - - List.Num := List.Num + 1; - end New_Enum_Literal; - - ---------------------- - -- Finish_Enum_Type -- - ---------------------- - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Res := List.Etype; - end Finish_Enum_Type; - - ------------------------ - -- New_Signed_Literal -- - ------------------------ - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - is - function To_Unsigned_64 is new Ada.Unchecked_Conversion - (Integer_64, Unsigned_64); - begin - return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), - To_Unsigned_64 (Value), 1), - Ctype => Ltype); - end New_Signed_Literal; - - -------------------------- - -- New_Unsigned_Literal -- - -------------------------- - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode is - begin - return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0), - Ctype => Ltype); - end New_Unsigned_Literal; - - ----------------------- - -- New_Float_Literal -- - ----------------------- - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode is - begin - return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype), - Interfaces.C.double (Value)), - Ctype => Ltype); - end New_Float_Literal; - - --------------------- - -- New_Null_Access -- - --------------------- - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode is - begin - return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)), - Ctype => Ltype); - end New_Null_Access; - - ----------------------- - -- Start_Record_Aggr -- - ----------------------- - - procedure Start_Record_Aggr - (List : out O_Record_Aggr_List; - Atype : O_Tnode) - is - Llvm : constant TypeRef := Get_LLVM_Type (Atype); - begin - List := - (Len => 0, - Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)), - Atype => Atype); - end Start_Record_Aggr; - - ------------------------ - -- New_Record_Aggr_El -- - ------------------------ - - procedure New_Record_Aggr_El - (List : in out O_Record_Aggr_List; Value : O_Cnode) - is - begin - List.Len := List.Len + 1; - List.Vals (List.Len) := Value.LLVM; - end New_Record_Aggr_El; - - ------------------------ - -- Finish_Record_Aggr -- - ------------------------ - - procedure Finish_Record_Aggr - (List : in out O_Record_Aggr_List; - Res : out O_Cnode) - is - begin - Res := (LLVM => ConstStruct (List.Vals.all, List.Len, 0), - Ctype => List.Atype); - Free (List.Vals); - end Finish_Record_Aggr; - - ---------------------- - -- Start_Array_Aggr -- - ---------------------- - - procedure Start_Array_Aggr - (List : out O_Array_Aggr_List; - Atype : O_Tnode) - is - Llvm : constant TypeRef := Get_LLVM_Type (Atype); - begin - List := (Len => 0, - Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)), - El_Type => GetElementType (Llvm), - Atype => Atype); - end Start_Array_Aggr; - - ----------------------- - -- New_Array_Aggr_El -- - ----------------------- - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - is - begin - List.Len := List.Len + 1; - List.Vals (List.Len) := Value.LLVM; - end New_Array_Aggr_El; - - ----------------------- - -- Finish_Array_Aggr -- - ----------------------- - - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode) - is - begin - Res := (LLVM => ConstArray (List.El_Type, - List.Vals.all, List.Len), - Ctype => List.Atype); - Free (List.Vals); - end Finish_Array_Aggr; - - -------------------- - -- New_Union_Aggr -- - -------------------- - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - Values : ValueRefArray (1 .. 2); - Count : unsigned; - Size : constant unsigned := - unsigned (ABISizeOfType (Target_Data, Field.Utype)); - - begin - Values (1) := Value.LLVM; - if Size < Atype.Un_Size then - Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); - Count := 2; - else - Count := 1; - end if; - - -- If `FIELD` is the main field of the union, create a struct using - -- the same type as the union (and possibly pad). - if Field.Utype = Atype.Un_Main_Field then - return O_Cnode' - (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), - Ctype => Atype); - else - -- Create an on-the-fly record. - return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), - Ctype => Atype); - end if; - end New_Union_Aggr; - - ---------------- - -- New_Sizeof -- - ---------------- - - -- Return VAL with type RTYPE (either unsigned or access) - function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode - is - Tmp : ValueRef; - begin - case Rtype.Kind is - when ON_Scalar_Types => - -- Well, unsigned in fact. - return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), - Ctype => Rtype); - when ON_Access_Type => - Tmp := ConstInt (Int64Type, Val, 0); - return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), - Ctype => Rtype); - when others => - raise Program_Error; - end case; - end Const_To_Cnode; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return Const_To_Cnode - (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); - end New_Sizeof; - - ----------------- - -- New_Alignof -- - ----------------- - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return Const_To_Cnode - (Rtype, - Unsigned_64 - (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); - end New_Alignof; - - ------------------ - -- New_Offsetof -- - ------------------ - - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode is - begin - return Const_To_Cnode - (Rtype, - OffsetOfElement (Target_Data, - Get_LLVM_Type (Atype), - Unsigned_32 (Field.Index))); - end New_Offsetof; - - ---------------------------- - -- New_Subprogram_Address -- - ---------------------------- - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode' - (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); - end New_Subprogram_Address; - - ------------------------ - -- New_Global_Address -- - ------------------------ - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); - end New_Global_Address; - - ---------------------------------- - -- New_Global_Unchecked_Address -- - ---------------------------------- - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); - end New_Global_Unchecked_Address; - - ------------- - -- New_Lit -- - ------------- - - function New_Lit (Lit : O_Cnode) return O_Enode is - begin - return O_Enode'(LLVM => Lit.LLVM, - Etype => Lit.Ctype); - end New_Lit; - - ------------------- - -- New_Dyadic_Op -- - ------------------- - - function New_Smod (L, R : ValueRef; Res_Type : TypeRef) - return ValueRef - is - Cond : ValueRef; - Br : ValueRef; - pragma Unreferenced (Br); - - -- The result of 'L rem R'. - Rm : ValueRef; - - -- Rm + R - Rm_Plus_R : ValueRef; - - -- The result of 'L xor R'. - R_Xor : ValueRef; - - Adj : ValueRef; - Phi : ValueRef; - - -- Basic basic for the non-overflow branch - Normal_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - Adjust_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - -- Basic block after the result - Next_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - Vals : ValueRefArray (1 .. 3); - BBs : BasicBlockRefArray (1 .. 3); - begin - -- Avoid overflow with -1: - -- if R = -1 then - -- result := 0; - -- else - -- ... - Cond := BuildICmp - (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); - Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); - Vals (1) := ConstNull (Res_Type); - BBs (1) := GetInsertBlock (Builder); - - -- Rm := Left rem Right - PositionBuilderAtEnd (Builder, Normal_Bb); - Rm := BuildSRem (Builder, L, R, Empty_Cstring); - - -- if R = 0 then - -- result := 0 - -- else - Cond := BuildICmp - (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); - Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); - Vals (2) := ConstNull (Res_Type); - BBs (2) := Normal_Bb; - - -- if L xor R < 0 then - -- result := Rm + R - -- else - -- result := Rm; - -- end if; - PositionBuilderAtEnd (Builder, Adjust_Bb); - R_Xor := BuildXor (Builder, L, R, Empty_Cstring); - Cond := BuildICmp - (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); - Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); - Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); - Br := BuildBr (Builder, Next_Bb); - Vals (3) := Adj; - BBs (3) := Adjust_Bb; - - -- The Phi node - PositionBuilderAtEnd (Builder, Next_Bb); - Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); - AddIncoming (Phi, Vals, BBs, Vals'Length); - - return Phi; - end New_Smod; - - type Dyadic_Builder_Acc is access - function (Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - pragma Convention (C, Dyadic_Builder_Acc); - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - Build : Dyadic_Builder_Acc := null; - Res : ValueRef := Null_ValueRef; - begin - if Unreach then - return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); - end if; - - case Left.Etype.Kind is - when ON_Integer_Types => - case Kind is - when ON_And => - Build := BuildAnd'Access; - when ON_Or => - Build := BuildOr'Access; - when ON_Xor => - Build := BuildXor'Access; - - when ON_Add_Ov => - Build := BuildAdd'Access; - when ON_Sub_Ov => - Build := BuildSub'Access; - when ON_Mul_Ov => - Build := BuildMul'Access; - - when ON_Div_Ov => - case Left.Etype.Kind is - when ON_Unsigned_Type => - Build := BuildUDiv'Access; - when ON_Signed_Type => - Build := BuildSDiv'Access; - when others => - null; - end case; - - when ON_Mod_Ov - | ON_Rem_Ov => -- FIXME... - case Left.Etype.Kind is - when ON_Unsigned_Type => - Build := BuildURem'Access; - when ON_Signed_Type => - if Kind = ON_Rem_Ov then - Build := BuildSRem'Access; - else - Res := New_Smod - (Left.LLVM, Right.LLVM, Left.Etype.LLVM); - end if; - when others => - null; - end case; - end case; - - when ON_Float_Type => - case Kind is - when ON_Add_Ov => - Build := BuildFAdd'Access; - when ON_Sub_Ov => - Build := BuildFSub'Access; - when ON_Mul_Ov => - Build := BuildFMul'Access; - when ON_Div_Ov => - Build := BuildFDiv'Access; - - when others => - null; - end case; - - when others => - null; - end case; - - if Build /= null then - pragma Assert (Res = Null_ValueRef); - Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); - end if; - - if Res = Null_ValueRef then - raise Program_Error with "Unimplemented New_Dyadic_Op " - & ON_Dyadic_Op_Kind'Image (Kind) - & " for type " - & ON_Type_Kind'Image (Left.Etype.Kind); - end if; - - Set_Insn_Dbg (Res); - - return O_Enode'(LLVM => Res, Etype => Left.Etype); - end New_Dyadic_Op; - - -------------------- - -- New_Monadic_Op -- - -------------------- - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode - is - Res : ValueRef; - begin - case Operand.Etype.Kind is - when ON_Integer_Types => - case Kind is - when ON_Not => - Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); - when ON_Neg_Ov => - Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); - when ON_Abs_Ov => - Res := BuildSelect - (Builder, - BuildICmp (Builder, IntSLT, - Operand.LLVM, - ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), - Empty_Cstring), - BuildNeg (Builder, Operand.LLVM, Empty_Cstring), - Operand.LLVM, - Empty_Cstring); - end case; - when ON_Float_Type => - case Kind is - when ON_Not => - raise Program_Error; - when ON_Neg_Ov => - Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); - when ON_Abs_Ov => - Res := BuildSelect - (Builder, - BuildFCmp (Builder, RealOLT, - Operand.LLVM, - ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), - Empty_Cstring), - BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), - Operand.LLVM, - Empty_Cstring); - end case; - when others => - raise Program_Error; - end case; - - if IsAInstruction (Res) /= Null_ValueRef then - Set_Insn_Dbg (Res); - end if; - - return O_Enode'(LLVM => Res, Etype => Operand.Etype); - end New_Monadic_Op; - - -------------------- - -- New_Compare_Op -- - -------------------- - - type Compare_Op_Entry is record - Signed_Pred : IntPredicate; - Unsigned_Pred : IntPredicate; - Real_Pred : RealPredicate; - end record; - - type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of - Compare_Op_Entry; - - Compare_Op_Table : constant Compare_Op_Table_Type := - (ON_Eq => (IntEQ, IntEQ, RealOEQ), - ON_Neq => (IntNE, IntNE, RealONE), - ON_Le => (IntSLE, IntULE, RealOLE), - ON_Lt => (IntSLT, IntULT, RealOLT), - ON_Ge => (IntSGE, IntUGE, RealOGE), - ON_Gt => (IntSGT, IntUGT, RealOGT)); - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; - Left, Right : O_Enode; - Ntype : O_Tnode) - return O_Enode - is - Res : ValueRef; - begin - case Left.Etype.Kind is - when ON_Unsigned_Type - | ON_Boolean_Type - | ON_Enum_Type - | ON_Access_Type - | ON_Incomplete_Access_Type => - Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Signed_Type => - Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Float_Type => - Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Array_Type - | ON_Array_Sub_Type - | ON_Record_Type - | ON_Incomplete_Record_Type - | ON_Union_Type - | ON_No_Type => - raise Program_Error; - end case; - Set_Insn_Dbg (Res); - return O_Enode'(LLVM => Res, Etype => Ntype); - end New_Compare_Op; - - ------------------------- - -- New_Indexed_Element -- - ------------------------- - - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode - is - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - Index.LLVM); - begin - return O_Lnode' - (Direct => False, - LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring), - Ltype => Arr.Ltype.Arr_El_Type); - end New_Indexed_Element; - - --------------- - -- New_Slice -- - --------------- - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - is - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - Index.LLVM); - Tmp : ValueRef; - begin - Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); - Tmp := BuildBitCast - (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring); - return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); - end New_Slice; - - -------------------------- - -- New_Selected_Element -- - -------------------------- - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - declare - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); - begin - Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); - end; - end if; - return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); - end New_Selected_Element; - - ------------------------ - -- New_Access_Element -- - ------------------------ - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - Res : ValueRef; - begin - case Acc.Etype.Kind is - when ON_Access_Type => - Res := Acc.LLVM; - when ON_Incomplete_Access_Type => - -- Unwrap the structure - declare - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); - begin - Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); - end; - when others => - raise Program_Error; - end case; - return O_Lnode'(Direct => False, - LLVM => Res, - Ltype => Acc.Etype.Acc_Type); - end New_Access_Element; - - -------------------- - -- New_Convert_Ov -- - -------------------- - - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode - is - Res : ValueRef := Null_ValueRef; - begin - if Rtype = Val.Etype then - -- Convertion to itself: nothing to do. - return Val; - end if; - if Rtype.LLVM = Val.Etype.LLVM then - -- Same underlying LLVM type: nothing to do. - return Val; - end if; - - case Rtype.Kind is - when ON_Integer_Types => - case Val.Etype.Kind is - when ON_Integer_Types => - -- Int to Int - if Val.Etype.Scal_Size > Rtype.Scal_Size then - -- Truncate - Res := BuildTrunc - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - elsif Val.Etype.Scal_Size < Rtype.Scal_Size then - if Val.Etype.Kind = ON_Signed_Type then - Res := BuildSExt - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - else - -- Unsigned, enum - Res := BuildZExt - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - else - Res := BuildBitCast - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - - when ON_Float_Type => - -- Float to Int - if Rtype.Kind = ON_Signed_Type then - Res := BuildFPToSI - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - - when others => - null; - end case; - - when ON_Float_Type => - if Val.Etype.Kind = ON_Signed_Type then - Res := BuildSIToFP - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - elsif Val.Etype.Kind = ON_Unsigned_Type then - Res := BuildUIToFP - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - - when ON_Access_Type - | ON_Incomplete_Access_Type => - if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then - raise Program_Error; - end if; - Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - - when others => - null; - end case; - if Res /= Null_ValueRef then - -- FIXME: only if insn was generated - -- Set_Insn_Dbg (Res); - return O_Enode'(LLVM => Res, Etype => Rtype); - else - raise Program_Error with "New_Convert_Ov: not implemented for " - & ON_Type_Kind'Image (Val.Etype.Kind) - & " -> " - & ON_Type_Kind'Image (Rtype.Kind); - end if; - end New_Convert_Ov; - - ----------------- - -- New_Address -- - ----------------- - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is - begin - return O_Enode' - (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), - Empty_Cstring), - Etype => Atype); - end New_Address; - - --------------------------- - -- New_Unchecked_Address -- - --------------------------- - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - begin - return O_Enode' - (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), - Empty_Cstring), - Etype => Atype); - end New_Unchecked_Address; - - --------------- - -- New_Value -- - --------------- - - function New_Value (Lvalue : O_Lnode) return O_Enode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - Res := Lvalue.LLVM; - if not Lvalue.Direct then - Res := BuildLoad (Builder, Res, Empty_Cstring); - Set_Insn_Dbg (Res); - end if; - end if; - return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype); - end New_Value; - - ------------------- - -- New_Obj_Value -- - ------------------- - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return New_Value (New_Obj (Obj)); - end New_Obj_Value; - - ------------- - -- New_Obj -- - ------------- - - function New_Obj (Obj : O_Dnode) return O_Lnode is - begin - case Obj.Kind is - when ON_Const_Decl - | ON_Var_Decl - | ON_Local_Decl => - return O_Lnode'(Direct => False, - LLVM => Obj.LLVM, - Ltype => Obj.Dtype); - - when ON_Interface_Decl => - if Flag_Debug then - -- The argument was allocated. - return O_Lnode'(Direct => False, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - else - return O_Lnode'(Direct => True, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - end if; - - when ON_Type_Decl - | ON_Completed_Type_Decl - | ON_Subprg_Decl - | ON_No_Decl => - raise Program_Error; - end case; - end New_Obj; - - ---------------- - -- New_Alloca -- - ---------------- - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - if Cur_Declare_Block.Stack_Value = Null_ValueRef - and then Cur_Declare_Block.Prev /= null - then - -- Save stack pointer at entry of block - PositionBuilderBefore - (Extra_Builder, GetFirstInstruction (Cur_Declare_Block.Stmt_Bb)); - Cur_Declare_Block.Stack_Value := - BuildCall (Extra_Builder, Stacksave_Fun, - (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); - end if; - - Res := BuildArrayAlloca - (Builder, Int8Type, Size.LLVM, Empty_Cstring); - Set_Insn_Dbg (Res); - - Res := BuildBitCast - (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); - Set_Insn_Dbg (Res); - end if; - - return O_Enode'(LLVM => Res, Etype => Rtype); - end New_Alloca; - - ------------------- - -- New_Type_Decl -- - ------------------- - - function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0), - Null_ValueRef, - Null_ValueRef, - MDString (Id), - ConstInt (Int32Type, 0, 0), -- linenum - Dbg_Size (Btype.LLVM), - Dbg_Align (Btype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding - return MDNode (Vals, Vals'Length); - end Add_Dbg_Basic_Type; - - function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Dbg_Size (Etype.LLVM), - Dbg_Align (Etype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - Null_ValueRef, - Get_Value (Enum_Nodes), - ConstInt (Int32Type, 0, 0), - Null_ValueRef, - Null_ValueRef, - Null_ValueRef); -- Runtime lang - Clear (Enum_Nodes); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Enum_Type; - - function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef); - - Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Dbg_Size (Ptype.LLVM), - Dbg_Align (Ptype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 1024, 0), -- Flags - Ptype.Acc_Type.Dbg); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Pointer_Type; - - function Add_Dbg_Record_Type (Id : O_Ident; Rtype : O_Tnode) - return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Structure_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Null_ValueRef, -- 5: Size - Null_ValueRef, -- 6: Align - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 1024, 0), -- Flags - Null_ValueRef, - Null_ValueRef, -- 10 - ConstInt (Int32Type, 0, 0), -- Runtime lang - Null_ValueRef, -- Vtable Holder - Null_ValueRef, -- ? - Null_ValueRef); -- Uniq Id - if Rtype /= O_Tnode_Null then - Vals (5) := Dbg_Size (Rtype.LLVM); - Vals (6) := Dbg_Align (Rtype.LLVM); - Vals (10) := Rtype.Dbg; - end if; - - return MDNode (Vals, Vals'Length); - end Add_Dbg_Record_Type; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is - begin - case Atype.Kind is - when ON_Incomplete_Record_Type => - Atype.LLVM := - StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); - when ON_Incomplete_Access_Type => - Atype.LLVM := PointerType - (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); - when others => - null; - end case; - - -- Emit debug info - if Flag_Debug then - case Atype.Kind is - when ON_Unsigned_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned); - when ON_Signed_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed); - when ON_Float_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float); - when ON_Enum_Type => - Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); - when ON_Boolean_Type => - Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); - when ON_Access_Type => - Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype); - when ON_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type (Ident, Atype); - when ON_Incomplete_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type (Ident, O_Tnode_Null); - when ON_Array_Type - | ON_Array_Sub_Type => - -- FIXME: typedef - null; - when ON_Incomplete_Access_Type => - -- FIXME: todo - null; - when ON_Union_Type => - -- FIXME: todo - null; - when ON_No_Type => - raise Program_Error; - end case; - end if; - end New_Type_Decl; - - ----------------------------- - -- New_Debug_Filename_Decl -- - ----------------------------- - - procedure New_Debug_Filename_Decl (Filename : String) is - Vals : ValueRefArray (1 .. 2); - begin - if Flag_Debug then - Vals := (MDString (Filename), - MDString (Current_Directory)); - Dbg_Current_Filedir := MDNode (Vals, 2); - - Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0), - Dbg_Current_Filedir); - Dbg_Current_File := MDNode (Vals, 2); - end if; - end New_Debug_Filename_Decl; - - ------------------------- - -- New_Debug_Line_Decl -- - ------------------------- - - procedure New_Debug_Line_Decl (Line : Natural) is - begin - Dbg_Current_Line := unsigned (Line); - end New_Debug_Line_Decl; - - ---------------------------- - -- New_Debug_Comment_Decl -- - ---------------------------- - - procedure New_Debug_Comment_Decl (Comment : String) is - begin - null; - end New_Debug_Comment_Decl; - - -------------------- - -- New_Const_Decl -- - -------------------- - - procedure Dbg_Add_Global_Var (Id : O_Ident; - Atype : O_Tnode; - Storage : O_Storage; - Decl : O_Dnode) - is - pragma Assert (Atype.Dbg /= Null_ValueRef); - Vals : ValueRefArray (0 .. 12); - Name : constant ValueRef := MDString (Id); - Is_Local : constant Boolean := Storage = O_Storage_Private; - Is_Def : constant Boolean := Storage /= O_Storage_External; - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Variable, 0), - Null_ValueRef, - Null_ValueRef, -- context - Name, - Name, - Null_ValueRef, -- linkageName - Dbg_Current_File, - Dbg_Line, - Atype.Dbg, - ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal - ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef - Decl.LLVM, - Null_ValueRef); - Append (Global_Nodes, MDNode (Vals, Vals'Length)); - end Dbg_Add_Global_Var; - - procedure New_Const_Decl - (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) - is - Decl : ValueRef; - begin - if Storage = O_Storage_External then - Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); - else - Decl := Null_ValueRef; - end if; - if Decl = Null_ValueRef then - Decl := AddGlobal - (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); - end if; - - Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype); - SetGlobalConstant (Res.LLVM, 1); - if Storage = O_Storage_Private then - SetLinkage (Res.LLVM, InternalLinkage); - end if; - if Flag_Debug then - Dbg_Add_Global_Var (Ident, Atype, Storage, Res); - end if; - end New_Const_Decl; - - ----------------------- - -- Start_Const_Value -- - ----------------------- - - procedure Start_Const_Value (Const : in out O_Dnode) is - begin - null; - end Start_Const_Value; - - ------------------------ - -- Finish_Const_Value -- - ------------------------ - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is - begin - SetInitializer (Const.LLVM, Val.LLVM); - end Finish_Const_Value; - - ------------------ - -- New_Var_Decl -- - ------------------ - - procedure New_Var_Decl - (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) - is - Decl : ValueRef; - begin - if Storage = O_Storage_Local then - Res := (Kind => ON_Local_Decl, - LLVM => BuildAlloca - (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), - Dtype => Atype); - if Flag_Debug then - Dbg_Create_Variable (DW_TAG_Auto_Variable, - Ident, Atype, 0, Res.LLVM); - end if; - else - if Storage = O_Storage_External then - Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); - else - Decl := Null_ValueRef; - end if; - if Decl = Null_ValueRef then - Decl := AddGlobal - (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); - end if; - - Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype); - - -- Set linkage. - case Storage is - when O_Storage_Private => - SetLinkage (Res.LLVM, InternalLinkage); - when O_Storage_Public - | O_Storage_External => - null; - when O_Storage_Local => - raise Program_Error; - end case; - - -- Set initializer. - case Storage is - when O_Storage_Private - | O_Storage_Public => - SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype))); - when O_Storage_External => - null; - when O_Storage_Local => - raise Program_Error; - end case; - - if Flag_Debug then - Dbg_Add_Global_Var (Ident, Atype, Storage, Res); - end if; - end if; - end New_Var_Decl; - - ------------------------- - -- Start_Function_Decl -- - ------------------------- - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - begin - Interfaces := (Ident => Ident, - Storage => Storage, - Res_Type => Rtype, - Nbr_Inter => 0, - First_Inter => null, - Last_Inter => null); - end Start_Function_Decl; - - -------------------------- - -- Start_Procedure_Decl -- - -------------------------- - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage) - is - begin - Interfaces := (Ident => Ident, - Storage => Storage, - Res_Type => O_Tnode_Null, - Nbr_Inter => 0, - First_Inter => null, - Last_Inter => null); - end Start_Procedure_Decl; - - ------------------------ - -- New_Interface_Decl -- - ------------------------ - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) - is - Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype, - Ival => Null_ValueRef, - Ident => Ident, - Next => null); - begin - Res := (Kind => ON_Interface_Decl, - Dtype => Atype, - LLVM => Null_ValueRef, - Inter => Inter); - Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1; - if Interfaces.First_Inter = null then - Interfaces.First_Inter := Inter; - else - Interfaces.Last_Inter.Next := Inter; - end if; - Interfaces.Last_Inter := Inter; - end New_Interface_Decl; - - ---------------------------- - -- Finish_Subprogram_Decl -- - ---------------------------- - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode) - is - Count : constant unsigned := unsigned (Interfaces.Nbr_Inter); - Inter : O_Inter_Acc; - Types : TypeRefArray (1 .. Count); - Ftype : TypeRef; - Rtype : TypeRef; - Decl : ValueRef; - Id : constant Cstring := Get_Cstring (Interfaces.Ident); - begin - -- Fill Types (from interfaces list) - Inter := Interfaces.First_Inter; - for I in 1 .. Count loop - Types (I) := Inter.Itype.LLVM; - Inter := Inter.Next; - end loop; - - -- Build function type. - if Interfaces.Res_Type = O_Tnode_Null then - Rtype := VoidType; - else - Rtype := Interfaces.Res_Type.LLVM; - end if; - Ftype := FunctionType (Rtype, Types, Count, 0); - - if Interfaces.Storage = O_Storage_External then - Decl := GetNamedFunction (Module, Id); - else - Decl := Null_ValueRef; - end if; - if Decl = Null_ValueRef then - Decl := AddFunction (Module, Id, Ftype); - end if; - - Res := (Kind => ON_Subprg_Decl, - Dtype => Interfaces.Res_Type, - Subprg_Id => Interfaces.Ident, - Nbr_Args => Count, - Subprg_Inters => Interfaces.First_Inter, - LLVM => Decl); - SetFunctionCallConv (Res.LLVM, CCallConv); - - -- Translate interfaces. - Inter := Interfaces.First_Inter; - for I in 1 .. Count loop - Inter.Ival := GetParam (Res.LLVM, I - 1); - SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); - Inter := Inter.Next; - end loop; - end Finish_Subprogram_Decl; - - --------------------------- - -- Start_Subprogram_Body -- - --------------------------- - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - -- Basic block at function entry that contains all the declarations. - Decl_BB : BasicBlockRef; - begin - if Cur_Func /= Null_ValueRef then - -- No support for nested subprograms. - raise Program_Error; - end if; - - Cur_Func := Func.LLVM; - Cur_Func_Decl := Func; - Unreach := False; - - Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); - PositionBuilderAtEnd (Decl_Builder, Decl_BB); - - Create_Declare_Block; - - PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); - - if Flag_Debug then - declare - Type_Vals : ValueRefArray (0 .. Func.Nbr_Args); - Vals : ValueRefArray (0 .. 14); - Arg : O_Inter_Acc; - Subprg_Type : ValueRef; - - Subprg_Vals : ValueRefArray (0 .. 19); - Name : ValueRef; - begin - Arg := Func.Subprg_Inters; - if Func.Dtype /= O_Tnode_Null then - Type_Vals (0) := Func.Dtype.Dbg; - else - -- Void - Type_Vals (0) := Null_ValueRef; - end if; - for I in 1 .. Type_Vals'Last loop - Type_Vals (I) := Arg.Itype.Dbg; - Arg := Arg.Next; - end loop; - Vals := - (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0), - ConstInt (Int32Type, 0, 0), -- 1 ?? - Null_ValueRef, -- 2 Context - MDString (Empty_Cstring, 0), -- 3 name - ConstInt (Int32Type, 0, 0), -- 4 linenum - ConstInt (Int64Type, 0, 0), -- 5 size - ConstInt (Int64Type, 0, 0), -- 6 align - ConstInt (Int64Type, 0, 0), -- 7 offset - ConstInt (Int32Type, 0, 0), -- 8 flags - Null_ValueRef, -- 9 derived from - MDNode (Type_Vals, Type_Vals'Length), -- 10 type - ConstInt (Int32Type, 0, 0), -- 11 runtime lang - Null_ValueRef, -- 12 containing type - Null_ValueRef, -- 13 template params - Null_ValueRef); -- 14 ?? - Subprg_Type := MDNode (Vals, Vals'Length); - - -- Create TAG_subprogram. - Name := MDString (Func.Subprg_Id); - - Subprg_Vals := - (ConstInt (Int32Type, DW_TAG_Subprogram, 0), - Dbg_Current_Filedir, -- 1 loc - Dbg_Current_File, -- 2 context - Name, -- 3 name - Name, -- 4 display name - Null_ValueRef, -- 5 linkage name - Dbg_Line, -- 6 line num - Subprg_Type, -- 7 type - ConstInt (Int1Type, 0, 0), -- 8 islocal (FIXME) - ConstInt (Int1Type, 1, 0), -- 9 isdef (FIXME) - ConstInt (Int32Type, 0, 0), -- 10 virtuality - ConstInt (Int32Type, 0, 0), -- 11 virtual index - Null_ValueRef, -- 12 containing type - ConstInt (Int32Type, 256, 0), -- 13 flags: prototyped - ConstInt (Int1Type, 0, 0), -- 14 isOpt (FIXME) - Cur_Func, -- 15 function - Null_ValueRef, -- 16 template param - Null_ValueRef, -- 17 function decl - Null_ValueRef, -- 18 variables ??? - Dbg_Line); -- 19 scope ln - Cur_Declare_Block.Dbg_Scope := - MDNode (Subprg_Vals, Subprg_Vals'Length); - Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope); - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - end; - - -- Create local variables for arguments. - declare - Arg : O_Inter_Acc; - Tmp : ValueRef; - St : ValueRef; - pragma Unreferenced (St); - Argno : Natural; - begin - Arg := Func.Subprg_Inters; - Argno := 1; - while Arg /= null loop - Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype), - Empty_Cstring); - Dbg_Create_Variable (DW_TAG_Arg_Variable, - Arg.Ident, Arg.Itype, Argno, Tmp); - St := BuildStore (Decl_Builder, Arg.Ival, Tmp); - Arg.Ival := Tmp; - - Arg := Arg.Next; - Argno := Argno + 1; - end loop; - end; - end if; - end Start_Subprogram_Body; - - ---------------------------- - -- Finish_Subprogram_Body -- - ---------------------------- - - procedure Finish_Subprogram_Body is - Ret : ValueRef; - pragma Unreferenced (Ret); - begin - -- Add a jump from the declare basic block to the first statement BB. - Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb); - - -- Terminate the statement BB. - if not Unreach then - if Cur_Func_Decl.Dtype = O_Tnode_Null then - Ret := BuildRetVoid (Builder); - else - Ret := BuildUnreachable (Builder); - end if; - end if; - - Destroy_Declare_Block; - - Cur_Func := Null_ValueRef; - Dbg_Current_Scope := Null_ValueRef; - end Finish_Subprogram_Body; - - ------------------------- - -- New_Debug_Line_Stmt -- - ------------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) is - begin - Dbg_Current_Line := unsigned (Line); - end New_Debug_Line_Stmt; - - ---------------------------- - -- New_Debug_Comment_Stmt -- - ---------------------------- - - procedure New_Debug_Comment_Stmt (Comment : String) is - begin - null; - end New_Debug_Comment_Stmt; - - ------------------------ - -- Start_Declare_Stmt -- - ------------------------ - - procedure Start_Declare_Stmt - is - Br : ValueRef; - pragma Unreferenced (Br); - begin - Create_Declare_Block; - - if Unreach then - return; - end if; - - -- Add a jump to the new BB. - Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); - - PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); - - if Flag_Debug then - declare - Vals : ValueRefArray (0 .. 5); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0), - Dbg_Current_Filedir, -- 1 loc - Dbg_Current_Scope, -- 2 context - Dbg_Line, -- 3 line num - ConstInt (Int32Type, 0, 0), -- 4 col - ConstInt (Int32Type, Scope_Uniq_Id, 0)); - Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length); - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - Scope_Uniq_Id := Scope_Uniq_Id + 1; - end; - end if; - end Start_Declare_Stmt; - - ------------------------- - -- Finish_Declare_Stmt -- - ------------------------- - - procedure Finish_Declare_Stmt - is - Bb : BasicBlockRef; - Br : ValueRef; - Tmp : ValueRef; - pragma Unreferenced (Br, Tmp); - begin - if not Unreach then - -- Create a basic block for the statements after the declare. - Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); - - if Cur_Declare_Block.Stack_Value /= Null_ValueRef then - -- Restore stack pointer. - Tmp := BuildCall (Builder, Stackrestore_Fun, - (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, - Empty_Cstring); - end if; - - -- Execution will continue on the next statement - Br := BuildBr (Builder, Bb); - - PositionBuilderAtEnd (Builder, Bb); - end if; - - -- Do not reset Unread. - - Destroy_Declare_Block; - - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - end Finish_Declare_Stmt; - - ----------------------- - -- Start_Association -- - ----------------------- - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - begin - Assocs := (Subprg => Subprg, - Idx => 0, - Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); - end Start_Association; - - --------------------- - -- New_Association -- - --------------------- - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is - begin - Assocs.Idx := Assocs.Idx + 1; - Assocs.Vals (Assocs.Idx) := Val.LLVM; - end New_Association; - - ----------------------- - -- New_Function_Call -- - ----------------------- - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - Res : ValueRef; - Old_Vals : ValueRefArray_Acc; - begin - Res := BuildCall (Builder, Assocs.Subprg.LLVM, - Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); - Old_Vals := Assocs.Vals; - Free (Old_Vals); - Set_Insn_Dbg (Res); - return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); - end New_Function_Call; - - ------------------------ - -- New_Procedure_Call -- - ------------------------ - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - is - Res : ValueRef; - begin - if not Unreach then - Res := BuildCall (Builder, Assocs.Subprg.LLVM, - Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); - Set_Insn_Dbg (Res); - end if; - Free (Assocs.Vals); - end New_Procedure_Call; - - --------------------- - -- New_Assign_Stmt -- - --------------------- - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) - is - Res : ValueRef; - begin - if Target.Direct then - raise Program_Error; - end if; - if not Unreach then - Res := BuildStore (Builder, Value.LLVM, Target.LLVM); - Set_Insn_Dbg (Res); - end if; - end New_Assign_Stmt; - - --------------------- - -- New_Return_Stmt -- - --------------------- - - procedure New_Return_Stmt (Value : O_Enode) is - Res : ValueRef; - begin - if Unreach then - return; - end if; - Res := BuildRet (Builder, Value.LLVM); - Set_Insn_Dbg (Res); - Unreach := True; - end New_Return_Stmt; - - --------------------- - -- New_Return_Stmt -- - --------------------- - - procedure New_Return_Stmt is - Res : ValueRef; - begin - if Unreach then - return; - end if; - Res := BuildRetVoid (Builder); - Set_Insn_Dbg (Res); - Unreach := True; - end New_Return_Stmt; - - ------------------- - -- Start_If_Stmt -- - ------------------- - - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is - Res : ValueRef; - Bb_Then : BasicBlockRef; - begin - -- FIXME: check Unreach - Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); - Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); - Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); - Set_Insn_Dbg (Res); - - PositionBuilderAtEnd (Builder, Bb_Then); - end Start_If_Stmt; - - ------------------- - -- New_Else_Stmt -- - ------------------- - - procedure New_Else_Stmt (Block : in out O_If_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - Bb_Next : BasicBlockRef; - begin - if not Unreach then - Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); - Res := BuildBr (Builder, Bb_Next); - else - Bb_Next := Null_BasicBlockRef; - end if; - - PositionBuilderAtEnd (Builder, Block.Bb); - - Block := (Bb => Bb_Next); - Unreach := False; - end New_Else_Stmt; - - -------------------- - -- Finish_If_Stmt -- - -------------------- - - procedure Finish_If_Stmt (Block : in out O_If_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - Bb_Next : BasicBlockRef; - begin - if not Unreach then - -- The branch can continue. - if Block.Bb = Null_BasicBlockRef then - Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); - else - Bb_Next := Block.Bb; - end if; - Res := BuildBr (Builder, Bb_Next); - PositionBuilderAtEnd (Builder, Bb_Next); - else - -- The branch doesn't continue. - if Block.Bb /= Null_BasicBlockRef then - -- There is a fall-through (either from the then branch, or - -- there is no else). - Unreach := False; - PositionBuilderAtEnd (Builder, Block.Bb); - else - Unreach := True; - end if; - end if; - end Finish_If_Stmt; - - --------------------- - -- Start_Loop_Stmt -- - --------------------- - - procedure Start_Loop_Stmt (Label : out O_Snode) - is - Res : ValueRef; - pragma Unreferenced (Res); - begin - -- FIXME: check Unreach - Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring), - Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring)); - Res := BuildBr (Builder, Label.Bb_Entry); - PositionBuilderAtEnd (Builder, Label.Bb_Entry); - end Start_Loop_Stmt; - - ---------------------- - -- Finish_Loop_Stmt -- - ---------------------- - - procedure Finish_Loop_Stmt (Label : in out O_Snode) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - if not Unreach then - Res := BuildBr (Builder, Label.Bb_Entry); - end if; - if Label.Bb_Exit /= Null_BasicBlockRef then - -- FIXME: always true... - PositionBuilderAtEnd (Builder, Label.Bb_Exit); - Unreach := False; - else - Unreach := True; - end if; - end Finish_Loop_Stmt; - - ------------------- - -- New_Exit_Stmt -- - ------------------- - - procedure New_Exit_Stmt (L : O_Snode) is - Res : ValueRef; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Exit); - Set_Insn_Dbg (Res); - Unreach := True; - end if; - end New_Exit_Stmt; - - ------------------- - -- New_Next_Stmt -- - ------------------- - - procedure New_Next_Stmt (L : O_Snode) is - Res : ValueRef; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Entry); - Set_Insn_Dbg (Res); - Unreach := True; - end if; - end New_Next_Stmt; - - --------------------- - -- Start_Case_Stmt -- - --------------------- - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is - begin - Block := (BB_Prev => GetInsertBlock (Builder), - Value => Value.LLVM, - Vtype => Value.Etype, - BB_Next => Null_BasicBlockRef, - BB_Others => Null_BasicBlockRef, - BB_Choice => Null_BasicBlockRef, - Nbr_Choices => 0, - Choices => new O_Choice_Array (1 .. 8)); - end Start_Case_Stmt; - - ------------------ - -- Start_Choice -- - ------------------ - - procedure Finish_Branch (Block : in out O_Case_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - -- Close previous branch. - if not Unreach then - if Block.BB_Next = Null_BasicBlockRef then - Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); - end if; - Res := BuildBr (Builder, Block.BB_Next); - end if; - end Finish_Branch; - - procedure Start_Choice (Block : in out O_Case_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - if Block.BB_Choice /= Null_BasicBlockRef then - -- Close previous branch. - Finish_Branch (Block); - end if; - - Unreach := False; - Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); - PositionBuilderAtEnd (Builder, Block.BB_Choice); - end Start_Choice; - - --------------------- - -- New_Expr_Choice -- - --------------------- - - procedure Free is new Ada.Unchecked_Deallocation - (O_Choice_Array, O_Choice_Array_Acc); - - procedure New_Choice (Block : in out O_Case_Block; - Low, High : ValueRef) - is - Choices : O_Choice_Array_Acc; - begin - if Block.Nbr_Choices = Block.Choices'Last then - Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); - Choices (1 .. Block.Choices'Last) := Block.Choices.all; - Free (Block.Choices); - Block.Choices := Choices; - end if; - Block.Nbr_Choices := Block.Nbr_Choices + 1; - Block.Choices (Block.Nbr_Choices) := (Low => Low, - High => High, - Bb => Block.BB_Choice); - end New_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is - begin - New_Choice (Block, Expr.LLVM, Null_ValueRef); - end New_Expr_Choice; - - ---------------------- - -- New_Range_Choice -- - ---------------------- - - procedure New_Range_Choice - (Block : in out O_Case_Block; Low, High : O_Cnode) - is - begin - New_Choice (Block, Low.LLVM, High.LLVM); - end New_Range_Choice; - - ------------------------ - -- New_Default_Choice -- - ------------------------ - - procedure New_Default_Choice (Block : in out O_Case_Block) is - begin - Block.BB_Others := Block.BB_Choice; - end New_Default_Choice; - - ------------------- - -- Finish_Choice -- - ------------------- - - procedure Finish_Choice (Block : in out O_Case_Block) is - begin - null; - end Finish_Choice; - - ---------------------- - -- Finish_Case_Stmt -- - ---------------------- - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) - is - Bb_Default : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - Bb_Default_Last : BasicBlockRef; - Nbr_Cases : unsigned := 0; - GE, LE : IntPredicate; - Res : ValueRef; - begin - if Block.BB_Choice /= Null_BasicBlockRef then - -- Close previous branch. - Finish_Branch (Block); - end if; - - -- Strategy: use a switch instruction for simple choices, put range - -- choices in the default using if statements. - case Block.Vtype.Kind is - when ON_Unsigned_Type - | ON_Enum_Type - | ON_Boolean_Type => - GE := IntUGE; - LE := IntULE; - when ON_Signed_Type => - GE := IntSGE; - LE := IntSLE; - when others => - raise Program_Error; - end case; - - -- BB for the default case of the LLVM switch. - PositionBuilderAtEnd (Builder, Bb_Default); - Bb_Default_Last := Bb_Default; - - for I in 1 .. Block.Nbr_Choices loop - declare - C : O_Choice_Type renames Block.Choices (I); - begin - if C.High /= Null_ValueRef then - Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); - Res := BuildCondBr (Builder, - BuildAnd (Builder, - BuildICmp (Builder, GE, - Block.Value, C.Low, - Empty_Cstring), - BuildICmp (Builder, LE, - Block.Value, C.High, - Empty_Cstring), - Empty_Cstring), - C.Bb, Bb_Default_Last); - PositionBuilderAtEnd (Builder, Bb_Default_Last); - else - Nbr_Cases := Nbr_Cases + 1; - end if; - end; - end loop; - - -- Insert the switch - PositionBuilderAtEnd (Builder, Block.BB_Prev); - Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); - for I in 1 .. Block.Nbr_Choices loop - declare - C : O_Choice_Type renames Block.Choices (I); - begin - if C.High = Null_ValueRef then - AddCase (Res, C.Low, C.Bb); - end if; - end; - end loop; - - -- Insert the others. - PositionBuilderAtEnd (Builder, Bb_Default_Last); - if Block.BB_Others /= Null_BasicBlockRef then - Res := BuildBr (Builder, Block.BB_Others); - else - Res := BuildUnreachable (Builder); - end if; - - if Block.BB_Next /= Null_BasicBlockRef then - Unreach := False; - PositionBuilderAtEnd (Builder, Block.BB_Next); - else - Unreach := True; - end if; - - Free (Block.Choices); - end Finish_Case_Stmt; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is - begin - case Atype.Kind is - when ON_Incomplete_Record_Type - | ON_Incomplete_Access_Type => - if Atype.LLVM = Null_TypeRef then - raise Program_Error with "early use of incomplete type"; - end if; - return Atype.LLVM; - when ON_Union_Type - | ON_Scalar_Types - | ON_Access_Type - | ON_Array_Type - | ON_Array_Sub_Type - | ON_Record_Type => - return Atype.LLVM; - when others => - raise Program_Error; - end case; - end Get_LLVM_Type; - - procedure Finish_Debug is - begin - declare - Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL; - Producer : constant String := "ortho llvm"; - Vals : ValueRefArray (0 .. 12); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0), - Dbg_Current_Filedir, -- 1 file+dir - ConstInt (Int32Type, 1, 0), -- 2 language (C) - MDString (Producer), -- 3 producer - ConstInt (Int1Type, 0, 0), -- 4 isOpt - MDString (""), -- 5 flags - ConstInt (Int32Type, 0, 0), -- 6 runtime version - Null_ValueRef, -- 7 enum types - Null_ValueRef, -- 8 retained types - Get_Value (Subprg_Nodes), -- 9 subprograms - Get_Value (Global_Nodes), -- 10 global var - Null_ValueRef, -- 11 imported entities - Null_ValueRef); -- 12 split debug - - AddNamedMetadataOperand - (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length)); - end; - - declare - Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL; - Flags1 : ValueRefArray (0 .. 2); - Flags2 : ValueRefArray (0 .. 2); - begin - Flags1 := (ConstInt (Int32Type, 1, 0), - MDString ("Debug Info Version"), - ConstInt (Int32Type, 1, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length)); - Flags2 := (ConstInt (Int32Type, 2, 0), - MDString ("Dwarf Version"), - ConstInt (Int32Type, 2, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length)); - end; - end Finish_Debug; - - Dbg_Str : constant String := "dbg"; - - procedure Init is - -- Some predefined types and functions. - I8_Ptr_Type : TypeRef; - begin - Builder := CreateBuilder; - Decl_Builder := CreateBuilder; - Extra_Builder := CreateBuilder; - - -- Create type i8 *. - I8_Ptr_Type := PointerType (Int8Type); - - -- Create intrinsic 'i8 *stacksave (void)'. - Stacksave_Fun := AddFunction - (Module, Stacksave_Name'Address, - FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0)); - - -- Create intrinsic 'void stackrestore (i8 *)'. - Stackrestore_Fun := AddFunction - (Module, Stackrestore_Name'Address, - FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0)); - - if Flag_Debug then - Debug_ID := GetMDKindID (Dbg_Str, Dbg_Str'Length); - - declare - Atypes : TypeRefArray (1 .. 2); - Ftype : TypeRef; - Name : String := "llvm.dbg.declare" & ASCII.NUL; - begin - Atypes := (MetadataType, MetadataType); - Ftype := FunctionType (VoidType, Atypes, Atypes'Length, 0); - Llvm_Dbg_Declare := AddFunction (Module, Name'Address, Ftype); - AddFunctionAttr (Llvm_Dbg_Declare, - NoUnwindAttribute + ReadNoneAttribute); - end; - end if; - end Init; - -end Ortho_LLVM; diff --git a/ortho/llvm/ortho_llvm.ads b/ortho/llvm/ortho_llvm.ads deleted file mode 100644 index 8e68eb139..000000000 --- a/ortho/llvm/ortho_llvm.ads +++ /dev/null @@ -1,737 +0,0 @@ --- DO NOT MODIFY - this file was generated from: --- ortho_nodes.common.ads and ortho_llvm.private.ads --- --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with Ortho_Ident; use Ortho_Ident; -with LLVM.Core; use LLVM.Core; -with LLVM.TargetMachine; -with LLVM.Target; - --- Interface to create nodes. -package Ortho_LLVM is - procedure Init; - procedure Finish_Debug; - - -- LLVM specific: the module. - Module : ModuleRef; - - -- Descriptor for the layout. - Target_Data : LLVM.Target.TargetDataRef; - - Target_Machine : LLVM.TargetMachine.TargetMachineRef; - - -- Optimization level - Optimization : LLVM.TargetMachine.CodeGenOptLevel := - LLVM.TargetMachine.CodeGenLevelDefault; - - -- Set by -g to generate debug info. - Flag_Debug : Boolean := False; - --- Start of common part - - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - type O_Dnode is private; - type O_Fnode is private; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- Type definitions -- - ------------------------ - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - 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; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record ATYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - ------------------- - -- Expressions -- - ------------------- - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (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. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - --- End of common part -private - -- No support for nested subprograms in LLVM. - Has_Nested_Subprograms : constant Boolean := False; - - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - O_Tnode_Null : constant O_Tnode := null; - - type ON_Type_Kind is - (ON_No_Type, - ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, - ON_Float_Type, - ON_Array_Type, ON_Array_Sub_Type, - ON_Incomplete_Record_Type, - ON_Record_Type, ON_Union_Type, - ON_Incomplete_Access_Type, ON_Access_Type); - - subtype ON_Scalar_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Float_Type; - - subtype ON_Integer_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Boolean_Type; - - type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record - LLVM : TypeRef; - Dbg : ValueRef; - case Kind is - when ON_No_Type => - null; - when ON_Union_Type => - Un_Size : unsigned; - Un_Main_Field : TypeRef; - when ON_Access_Type - | ON_Incomplete_Access_Type => - Acc_Type : O_Tnode; - when ON_Scalar_Types => - Scal_Size : Natural; - when ON_Array_Type - | ON_Array_Sub_Type => - -- Type of the element - Arr_El_Type : O_Tnode; - when ON_Record_Type - | ON_Incomplete_Record_Type => - null; - end case; - end record; - - type O_Inter; - type O_Inter_Acc is access O_Inter; - type O_Inter is record - Itype : O_Tnode; - Ival : ValueRef; - Ident : O_Ident; - Next : O_Inter_Acc; - end record; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, - ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, - ON_Subprg_Decl, - ON_No_Decl); - - type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record - Dtype : O_Tnode; - LLVM : ValueRef; - case Kind is - when ON_Var_Decl - | ON_Const_Decl - | ON_Local_Decl => - null; - when ON_Subprg_Decl => - Subprg_Id : O_Ident; - Nbr_Args : unsigned; - Subprg_Inters : O_Inter_Acc; - when ON_Interface_Decl => - Inter : O_Inter_Acc; - when others => - null; - end case; - end record; - - O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, - Dtype => O_Tnode_Null, - LLVM => Null_ValueRef); - - type OF_Kind is (OF_None, OF_Record, OF_Union); - type O_Fnode (Kind : OF_Kind := OF_None) is record - Ftype : O_Tnode; - case Kind is - when OF_None => - null; - when OF_Record => - Index : Natural; - when OF_Union => - Utype : TypeRef; - end case; - end record; - - O_Fnode_Null : constant O_Fnode := (Kind => OF_None, - Ftype => O_Tnode_Null); - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type O_Cnode is record - LLVM : ValueRef; - Ctype : O_Tnode; - end record; - O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, - Ctype => O_Tnode_Null); - - type O_Enode is record - LLVM : ValueRef; - Etype : O_Tnode; - end record; - O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, - Etype => O_Tnode_Null); - - - type O_Lnode is record - -- If True, the LLVM component is the value (used for arguments). - -- If False, the LLVM component is the address of the value (used - -- for everything else). - Direct : Boolean; - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); - - type O_Snode is record - -- First BB in the loop body. - Bb_Entry : BasicBlockRef; - - -- BB after the loop. - Bb_Exit : BasicBlockRef; - end record; - - O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, - Null_BasicBlockRef); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - Res_Type : O_Tnode; - Nbr_Inter : Natural; - First_Inter, Last_Inter : O_Inter_Acc; - end record; - - type O_Element; - type O_Element_Acc is access O_Element; - type O_Element is record - -- Identifier for the element - Ident : O_Ident; - - -- Type of the element - Etype : O_Tnode; - - -- Next element (in the linked list) - Next : O_Element_Acc; - end record; - - -- Record and union builder. - type O_Element_List is record - Nbr_Elements : Natural; - - -- For record: the access to the incomplete (but named) type. - Rec_Type : O_Tnode; - - -- For unions: biggest for size and alignment - Size : unsigned; - Align : Unsigned_32; - Align_Type : TypeRef; - - First_Elem, Last_Elem : O_Element_Acc; - end record; - - type ValueRefArray_Acc is access ValueRefArray; - - type O_Record_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Array_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - El_Type : TypeRef; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Idx : unsigned; - Vals : ValueRefArray_Acc; - end record; - - type O_Enum_List is record - LLVM : TypeRef; - Num : Natural; - Etype : O_Tnode; - end record; - - type O_Choice_Type is record - Low, High : ValueRef; - Bb : BasicBlockRef; - end record; - - type O_Choice_Array is array (Natural range <>) of O_Choice_Type; - type O_Choice_Array_Acc is access O_Choice_Array; - - type O_Case_Block is record - -- BB before the case. - BB_Prev : BasicBlockRef; - - -- Select expression - Value : ValueRef; - Vtype : O_Tnode; - - -- BB after the case statement. - BB_Next : BasicBlockRef; - - -- BB for others - BB_Others : BasicBlockRef; - - -- BB for the current choice - BB_Choice : BasicBlockRef; - - -- List of choices. - Nbr_Choices : Natural; - Choices : O_Choice_Array_Acc; - end record; - - type O_If_Block is record - -- The next basic block. - -- After the 'If', this is the BB for the else part. If there is no - -- else part, this is the BB for statements after the if. - -- After the 'else', this is the BB for statements after the if. - Bb : BasicBlockRef; - end record; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; -end Ortho_LLVM; diff --git a/ortho/llvm/ortho_llvm.private.ads b/ortho/llvm/ortho_llvm.private.ads deleted file mode 100644 index 842a119b5..000000000 --- a/ortho/llvm/ortho_llvm.private.ads +++ /dev/null @@ -1,305 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with Ortho_Ident; use Ortho_Ident; -with LLVM.Core; use LLVM.Core; -with LLVM.TargetMachine; -with LLVM.Target; - --- Interface to create nodes. -package Ortho_LLVM is - procedure Init; - procedure Finish_Debug; - - -- LLVM specific: the module. - Module : ModuleRef; - - -- Descriptor for the layout. - Target_Data : LLVM.Target.TargetDataRef; - - Target_Machine : LLVM.TargetMachine.TargetMachineRef; - - -- Optimization level - Optimization : LLVM.TargetMachine.CodeGenOptLevel := - LLVM.TargetMachine.CodeGenLevelDefault; - - -- Set by -g to generate debug info. - Flag_Debug : Boolean := False; - -private - -- No support for nested subprograms in LLVM. - Has_Nested_Subprograms : constant Boolean := False; - - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - O_Tnode_Null : constant O_Tnode := null; - - type ON_Type_Kind is - (ON_No_Type, - ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, - ON_Float_Type, - ON_Array_Type, ON_Array_Sub_Type, - ON_Incomplete_Record_Type, - ON_Record_Type, ON_Union_Type, - ON_Incomplete_Access_Type, ON_Access_Type); - - subtype ON_Scalar_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Float_Type; - - subtype ON_Integer_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Boolean_Type; - - type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record - LLVM : TypeRef; - Dbg : ValueRef; - case Kind is - when ON_No_Type => - null; - when ON_Union_Type => - Un_Size : unsigned; - Un_Main_Field : TypeRef; - when ON_Access_Type - | ON_Incomplete_Access_Type => - Acc_Type : O_Tnode; - when ON_Scalar_Types => - Scal_Size : Natural; - when ON_Array_Type - | ON_Array_Sub_Type => - -- Type of the element - Arr_El_Type : O_Tnode; - when ON_Record_Type - | ON_Incomplete_Record_Type => - null; - end case; - end record; - - type O_Inter; - type O_Inter_Acc is access O_Inter; - type O_Inter is record - Itype : O_Tnode; - Ival : ValueRef; - Ident : O_Ident; - Next : O_Inter_Acc; - end record; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, - ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, - ON_Subprg_Decl, - ON_No_Decl); - - type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record - Dtype : O_Tnode; - LLVM : ValueRef; - case Kind is - when ON_Var_Decl - | ON_Const_Decl - | ON_Local_Decl => - null; - when ON_Subprg_Decl => - Subprg_Id : O_Ident; - Nbr_Args : unsigned; - Subprg_Inters : O_Inter_Acc; - when ON_Interface_Decl => - Inter : O_Inter_Acc; - when others => - null; - end case; - end record; - - O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, - Dtype => O_Tnode_Null, - LLVM => Null_ValueRef); - - type OF_Kind is (OF_None, OF_Record, OF_Union); - type O_Fnode (Kind : OF_Kind := OF_None) is record - Ftype : O_Tnode; - case Kind is - when OF_None => - null; - when OF_Record => - Index : Natural; - when OF_Union => - Utype : TypeRef; - end case; - end record; - - O_Fnode_Null : constant O_Fnode := (Kind => OF_None, - Ftype => O_Tnode_Null); - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type O_Cnode is record - LLVM : ValueRef; - Ctype : O_Tnode; - end record; - O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, - Ctype => O_Tnode_Null); - - type O_Enode is record - LLVM : ValueRef; - Etype : O_Tnode; - end record; - O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, - Etype => O_Tnode_Null); - - - type O_Lnode is record - -- If True, the LLVM component is the value (used for arguments). - -- If False, the LLVM component is the address of the value (used - -- for everything else). - Direct : Boolean; - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); - - type O_Snode is record - -- First BB in the loop body. - Bb_Entry : BasicBlockRef; - - -- BB after the loop. - Bb_Exit : BasicBlockRef; - end record; - - O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, - Null_BasicBlockRef); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - Res_Type : O_Tnode; - Nbr_Inter : Natural; - First_Inter, Last_Inter : O_Inter_Acc; - end record; - - type O_Element; - type O_Element_Acc is access O_Element; - type O_Element is record - -- Identifier for the element - Ident : O_Ident; - - -- Type of the element - Etype : O_Tnode; - - -- Next element (in the linked list) - Next : O_Element_Acc; - end record; - - -- Record and union builder. - type O_Element_List is record - Nbr_Elements : Natural; - - -- For record: the access to the incomplete (but named) type. - Rec_Type : O_Tnode; - - -- For unions: biggest for size and alignment - Size : unsigned; - Align : Unsigned_32; - Align_Type : TypeRef; - - First_Elem, Last_Elem : O_Element_Acc; - end record; - - type ValueRefArray_Acc is access ValueRefArray; - - type O_Record_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Array_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - El_Type : TypeRef; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Idx : unsigned; - Vals : ValueRefArray_Acc; - end record; - - type O_Enum_List is record - LLVM : TypeRef; - Num : Natural; - Etype : O_Tnode; - end record; - - type O_Choice_Type is record - Low, High : ValueRef; - Bb : BasicBlockRef; - end record; - - type O_Choice_Array is array (Natural range <>) of O_Choice_Type; - type O_Choice_Array_Acc is access O_Choice_Array; - - type O_Case_Block is record - -- BB before the case. - BB_Prev : BasicBlockRef; - - -- Select expression - Value : ValueRef; - Vtype : O_Tnode; - - -- BB after the case statement. - BB_Next : BasicBlockRef; - - -- BB for others - BB_Others : BasicBlockRef; - - -- BB for the current choice - BB_Choice : BasicBlockRef; - - -- List of choices. - Nbr_Choices : Natural; - Choices : O_Choice_Array_Acc; - end record; - - type O_If_Block is record - -- The next basic block. - -- After the 'If', this is the BB for the else part. If there is no - -- else part, this is the BB for statements after the if. - -- After the 'else', this is the BB for statements after the if. - Bb : BasicBlockRef; - end record; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; -end Ortho_LLVM; diff --git a/ortho/llvm/ortho_nodes.ads b/ortho/llvm/ortho_nodes.ads deleted file mode 100644 index 34d1dbbc9..000000000 --- a/ortho/llvm/ortho_nodes.ads +++ /dev/null @@ -1,20 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ortho_LLVM; -package Ortho_Nodes renames Ortho_LLVM; diff --git a/ortho/mcode/Makefile b/ortho/mcode/Makefile deleted file mode 100644 index 19d5d26aa..000000000 --- a/ortho/mcode/Makefile +++ /dev/null @@ -1,37 +0,0 @@ -ortho_srcdir=.. -GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru -gnat05 -CC=gcc -BE=mcode -SED=sed - -all: $(ortho_exec) - -$(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force - gnatmake -m -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \ - $(GNAT_FLAGS) ortho_code_main -bargs -E -largs memsegs_c.o #-static - -memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c - $(CC) -c $(CFLAGS) -o $@ $< - -oread: force - gnatmake -m -o $@ -g $(GNAT_FLAGS) -aI../oread ortho_code_main -aI.. -largs memsegs_c.o - -elfdump: force - gnatmake -m -g $(GNAT_FLAGS) $@ - -coffdump: force - gnatmake -m $(GNAT_FLAGS) $@ - -clean: - $(RM) -f *.o *.ali ortho_code_main elfdump - $(RM) b~*.ad? *~ - -distclean: clean - - -force: - -.PHONY: force all clean - -ORTHO_BASENAME=ortho_mcode -include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/mcode/binary_file-coff.adb b/ortho/mcode/binary_file-coff.adb deleted file mode 100644 index cf3cba3f4..000000000 --- a/ortho/mcode/binary_file-coff.adb +++ /dev/null @@ -1,407 +0,0 @@ --- Binary file COFF writer. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Characters.Latin_1; -with Coff; use Coff; - -package body Binary_File.Coff is - NUL : Character renames Ada.Characters.Latin_1.NUL; - - procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor) - is - use GNAT.OS_Lib; - - procedure Xwrite (Data : System.Address; Len : Natural) is - begin - if Write (Fd, Data, Len) /= Len then - raise Write_Error; - end if; - end Xwrite; - - type Section_Info_Type is record - Sect : Section_Acc; - -- File offset for the data. - Data_Offset : Natural; - -- File offset for the relocs. - Reloc_Offset : Natural; - -- Number of relocs to write. - Nbr_Relocs : Natural; - end record; - type Section_Info_Array is array (Natural range <>) of Section_Info_Type; - Sections : Section_Info_Array (1 .. Nbr_Sections + 3); - Nbr_Sect : Natural; - Sect_Text : constant Natural := 1; - Sect_Data : constant Natural := 2; - Sect_Bss : constant Natural := 3; - Sect : Section_Acc; - - --Section_Align : constant Natural := 2; - - Offset : Natural; - Symtab_Offset : Natural; - -- Number of symtab entries. - Nbr_Symbols : Natural; - Strtab_Offset : Natural; - - function Gen_String (Str : String) return Sym_Name - is - Res : Sym_Name; - begin - if Str'Length <= 8 then - Res.E_Name := (others => NUL); - Res.E_Name (1 .. Str'Length) := Str; - else - Res.E := (E_Zeroes => 0, E_Offset => Unsigned_32 (Offset)); - Offset := Offset + Str'Length + 1; - end if; - return Res; - end Gen_String; - - -- Well known sections name. - type String_Array is array (Sect_Text .. Sect_Bss) of String (1 .. 8); - Sect_Name : constant String_Array := - (Sect_Text => ".text" & NUL & NUL & NUL, - Sect_Data => ".data" & NUL & NUL & NUL, - Sect_Bss => ".bss" & NUL & NUL & NUL & NUL); - type Unsigned32_Array is array (Sect_Text .. Sect_Bss) of Unsigned_32; - Sect_Flags : constant Unsigned32_Array := - (Sect_Text => STYP_TEXT, - Sect_Data => STYP_DATA, - Sect_Bss => STYP_BSS); - - -- If true, do local relocs. - Flag_Reloc : constant Boolean := True; - -- If true, discard local symbols; - Flag_Discard_Local : Boolean := True; - begin - -- If relocations are not performs, then local symbols cannot be - -- discarded. - if not Flag_Reloc then - Flag_Discard_Local := False; - end if; - - -- Fill sections. - Sect := Section_Chain; - Nbr_Sect := 3; - declare - N : Natural; - begin - while Sect /= null loop - if Sect.Name.all = ".text" then - N := Sect_Text; - elsif Sect.Name.all = ".data" then - N := Sect_Data; - elsif Sect.Name.all = ".bss" then - N := Sect_Bss; - else - Nbr_Sect := Nbr_Sect + 1; - N := Nbr_Sect; - end if; - Sections (N).Sect := Sect; - Sect.Number := N; - Sect := Sect.Next; - end loop; - end; - - -- Set data offset. - Offset := Filehdr_Size + Nbr_Sect * Scnhdr_Size; - for I in 1 .. Nbr_Sect loop - if Sections (I).Sect /= null - and then Sections (I).Sect.Data /= null - then - Sections (I).Data_Offset := Offset; - Offset := Offset + Natural (Sections (I).Sect.Pc); - else - Sections (I).Data_Offset := 0; - end if; - end loop; - - -- Set relocs offset. - declare - Rel : Reloc_Acc; - begin - for I in 1 .. Nbr_Sect loop - Sections (I).Nbr_Relocs := 0; - if Sections (I).Sect /= null then - Sections (I).Reloc_Offset := Offset; - if not Flag_Reloc then - -- Do local relocations. - Rel := Sections (I).Sect.First_Reloc; - while Rel /= null loop - if S_Local (Rel.Sym) then - if Get_Section (Rel.Sym) = Sections (I).Sect - then - -- Intra section local reloc. - Apply_Reloc (Sections (I).Sect, Rel); - else - -- Inter section local reloc. - -- A relocation is still required. - Sections (I).Nbr_Relocs := - Sections (I).Nbr_Relocs + 1; - -- FIXME: todo. - raise Program_Error; - end if; - else - Sections (I).Nbr_Relocs := Sections (I).Nbr_Relocs + 1; - end if; - Rel := Rel.Sect_Next; - end loop; - else - Sections (I).Nbr_Relocs := Sections (I).Sect.Nbr_Relocs; - end if; - Offset := Offset + Sections (I).Nbr_Relocs * Relsz; - else - Sections (I).Reloc_Offset := 0; - end if; - end loop; - end; - - Symtab_Offset := Offset; - Nbr_Symbols := 2 + Nbr_Sect * 2; -- 2 for file. - for I in Symbols.First .. Symbols.Last loop - Set_Number (I, Nbr_Symbols); - Nbr_Symbols := Nbr_Symbols + 1; - end loop; - Offset := Offset + Nbr_Symbols * Symesz; - Strtab_Offset := Offset; - Offset := Offset + 4; - - -- Write file header. - declare - Hdr : Filehdr; - begin - Hdr.F_Magic := I386magic; - Hdr.F_Nscns := Unsigned_16 (Nbr_Sect); - Hdr.F_Timdat := 0; - Hdr.F_Symptr := Unsigned_32 (Symtab_Offset); - Hdr.F_Nsyms := Unsigned_32 (Nbr_Symbols); - Hdr.F_Opthdr := 0; - Hdr.F_Flags := F_Lnno; - Xwrite (Hdr'Address, Filehdr_Size); - end; - - -- Write sections header. - for I in 1 .. Nbr_Sect loop - declare - Hdr : Scnhdr; - L : Natural; - begin - case I is - when Sect_Text - | Sect_Data - | Sect_Bss => - Hdr.S_Name := Sect_Name (I); - Hdr.S_Flags := Sect_Flags (I); - when others => - Hdr.S_Flags := 0; - L := Sections (I).Sect.Name'Length; - if L > Hdr.S_Name'Length then - Hdr.S_Name := Sections (I).Sect.Name - (Sections (I).Sect.Name'First .. - Sections (I).Sect.Name'First + Hdr.S_Name'Length - 1); - else - Hdr.S_Name (1 .. L) := Sections (I).Sect.Name.all; - Hdr.S_Name (L + 1 .. Hdr.S_Name'Last) := (others => NUL); - end if; - end case; - Hdr.S_Paddr := 0; - Hdr.S_Vaddr := 0; - Hdr.S_Scnptr := Unsigned_32 (Sections (I).Data_Offset); - Hdr.S_Relptr := Unsigned_32 (Sections (I).Reloc_Offset); - Hdr.S_Lnnoptr := 0; - Hdr.S_Nreloc := Unsigned_16 (Sections (I).Nbr_Relocs); - if Sections (I).Sect /= null then - Hdr.S_Size := Unsigned_32 (Sections (I).Sect.Pc); - else - Hdr.S_Size := 0; - end if; - Hdr.S_Nlnno := 0; - Xwrite (Hdr'Address, Scnhdr_Size); - end; - end loop; - - -- Write sections content. - for I in 1 .. Nbr_Sect loop - if Sections (I).Sect /= null - and then Sections (I).Sect.Data /= null - then - Xwrite (Sections (I).Sect.Data (0)'Address, - Natural (Sections (I).Sect.Pc)); - end if; - end loop; - - -- Write sections reloc. - for I in 1 .. Nbr_Sect loop - if Sections (I).Sect /= null then - declare - R : Reloc_Acc; - Rel : Reloc; - begin - R := Sections (I).Sect.First_Reloc; - while R /= null loop - case R.Kind is - when Reloc_32 => - Rel.R_Type := Reloc_Addr32; - when Reloc_Pc32 => - Rel.R_Type := Reloc_Rel32; - when others => - raise Program_Error; - end case; - Rel.R_Vaddr := Unsigned_32 (R.Addr); - Rel.R_Symndx := Unsigned_32 (Get_Number (R.Sym)); - Xwrite (Rel'Address, Relsz); - R := R.Sect_Next; - end loop; - end; - end if; - end loop; - - -- Write symtab. - -- Write file symbol + aux - declare - Sym : Syment; - A_File : Auxent_File; - begin - Sym := (E => (Inline => True, - E_Name => ".file" & NUL & NUL & NUL), - E_Value => 0, - E_Scnum => N_DEBUG, - E_Type => 0, - E_Sclass => C_FILE, - E_Numaux => 1); - Xwrite (Sym'Address, Symesz); - A_File := (Inline => True, - X_Fname => "testfile.xxxxx"); - Xwrite (A_File'Address, Symesz); - end; - -- Write sections symbol + aux - for I in 1 .. Nbr_Sect loop - declare - A_Scn : Auxent_Scn; - Sym : Syment; - begin - Sym := (E => (Inline => True, E_Name => (others => NUL)), - E_Value => 0, - E_Scnum => Unsigned_16 (I), - E_Type => 0, - E_Sclass => C_STAT, - E_Numaux => 1); - if I <= Sect_Bss then - Sym.E.E_Name := Sect_Name (I); - else - Sym.E := Gen_String (Sections (I).Sect.Name.all); - end if; - Xwrite (Sym'Address, Symesz); - if Sections (I).Sect /= null - and then Sections (I).Sect.Data /= null - then - A_Scn := - (X_Scnlen => Unsigned_32 (Sections (I).Sect.Pc), - X_Nreloc => Unsigned_16 (Sections (I).Nbr_Relocs), - X_Nlinno => 0); - else - A_Scn := (X_Scnlen => 0, X_Nreloc => 0, X_Nlinno => 0); - end if; - Xwrite (A_Scn'Address, Symesz); - end; - end loop; - - -- Write symbols. - declare - procedure Write_Symbol (S : Symbol) - is - Sym : Syment; - begin - Sym := (E => Gen_String (Get_Symbol_Name (S)), - E_Value => Unsigned_32 (Get_Symbol_Value (S)), - E_Scnum => 0, - E_Type => 0, - E_Sclass => C_EXT, - E_Numaux => 0); - case Get_Scope (S) is - when Sym_Local - | Sym_Private => - Sym.E_Sclass := C_STAT; - when Sym_Undef - | Sym_Global => - Sym.E_Sclass := C_EXT; - end case; - if Get_Section (S) /= null then - Sym.E_Scnum := Unsigned_16 (Get_Section (S).Number); - end if; - Xwrite (Sym'Address, Symesz); - end Write_Symbol; - begin - -- First the non-local symbols (1). - for I in Symbols.First .. Symbols.Last loop - if Get_Scope (I) in Symbol_Scope_External then - Write_Symbol (I); - end if; - end loop; - -- Then the local symbols (2). - if not Flag_Discard_Local then - for I in Symbols.First .. Symbols.Last loop - if Get_Scope (I) not in Symbol_Scope_External then - Write_Symbol (I); - end if; - end loop; - end if; - end; - - -- Write strtab. - -- Write strtab length. - declare - L : Unsigned_32; - - procedure Write_String (Str : String) is - begin - if Str (Str'Last) /= NUL then - raise Program_Error; - end if; - if Str'Length <= 9 then - return; - end if; - Xwrite (Str'Address, Str'Length); - Strtab_Offset := Strtab_Offset + Str'Length; - end Write_String; - begin - L := Unsigned_32 (Offset - Strtab_Offset); - Xwrite (L'Address, 4); - - -- Write section name string. - for I in Sect_Bss + 1 .. Nbr_Sect loop - if Sections (I).Sect /= null - and then Sections (I).Sect.Name'Length > 8 - then - Write_String (Sections (I).Sect.Name.all & NUL); - end if; - end loop; - - for I in Symbols.First .. Symbols.Last loop - declare - Str : constant String := Get_Symbol_Name (I); - begin - Write_String (Str & NUL); - end; - end loop; - if Strtab_Offset + 4 /= Offset then - raise Program_Error; - end if; - end; - end Write_Coff; - -end Binary_File.Coff; diff --git a/ortho/mcode/binary_file-coff.ads b/ortho/mcode/binary_file-coff.ads deleted file mode 100644 index e671555ea..000000000 --- a/ortho/mcode/binary_file-coff.ads +++ /dev/null @@ -1,23 +0,0 @@ --- Binary file COFF writer. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.OS_Lib; - -package Binary_File.Coff is - procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor); -end Binary_File.Coff; - diff --git a/ortho/mcode/binary_file-elf.adb b/ortho/mcode/binary_file-elf.adb deleted file mode 100644 index 329dbacd3..000000000 --- a/ortho/mcode/binary_file-elf.adb +++ /dev/null @@ -1,679 +0,0 @@ --- Binary file ELF writer. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Characters.Latin_1; -with Elf_Common; -with Elf32; - -package body Binary_File.Elf is - NUL : Character renames Ada.Characters.Latin_1.NUL; - - type Arch_Bool is array (Arch_Kind) of Boolean; - Is_Rela : constant Arch_Bool := (Arch_Unknown => False, - Arch_X86 => False, - Arch_Sparc => True, - Arch_Ppc => True); - - procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor) - is - use Elf_Common; - use Elf32; - use GNAT.OS_Lib; - - procedure Xwrite (Data : System.Address; Len : Natural) is - begin - if Write (Fd, Data, Len) /= Len then - raise Write_Error; - end if; - end Xwrite; - - procedure Check_File_Pos (Off : Elf32_Off) - is - L : Long_Integer; - begin - L := File_Length (Fd); - if L /= Long_Integer (Off) then - Put_Line (Standard_Error, "check_file_pos error: expect " - & Elf32_Off'Image (Off) & ", found " - & Long_Integer'Image (L)); - raise Write_Error; - end if; - end Check_File_Pos; - - function Sect_Align (V : Elf32_Off) return Elf32_Off - is - Tmp : Elf32_Off; - begin - Tmp := V + 2 ** 2 - 1; - return Tmp - (Tmp mod 2 ** 2); - end Sect_Align; - - type Section_Info_Type is record - Sect : Section_Acc; - -- Index of the section symbol (in symtab). - Sym : Elf32_Word; - -- Number of relocs to write. - --Nbr_Relocs : Natural; - end record; - type Section_Info_Array is array (Natural range <>) of Section_Info_Type; - Sections : Section_Info_Array (0 .. 3 + 2 * Nbr_Sections); - type Elf32_Shdr_Array is array (Natural range <>) of Elf32_Shdr; - Shdr : Elf32_Shdr_Array (0 .. 3 + 2 * Nbr_Sections); - Nbr_Sect : Natural; - Sect : Section_Acc; - - -- The first 4 sections are always present. - Sect_Null : constant Natural := 0; - Sect_Shstrtab : constant Natural := 1; - Sect_Symtab : constant Natural := 2; - Sect_Strtab : constant Natural := 3; - Sect_First : constant Natural := 4; - - Offset : Elf32_Off; - - -- Size of a relocation entry. - Rel_Size : Natural; - - -- If true, do local relocs. - Flag_Reloc : constant Boolean := True; - -- If true, discard local symbols; - Flag_Discard_Local : Boolean := True; - - -- Number of symbols. - Nbr_Symbols : Natural := 0; - begin - -- If relocations are not performs, then local symbols cannot be - -- discarded. - if not Flag_Reloc then - Flag_Discard_Local := False; - end if; - - -- Set size of a relocation entry. This avoids severals conditionnal. - if Is_Rela (Arch) then - Rel_Size := Elf32_Rela_Size; - else - Rel_Size := Elf32_Rel_Size; - end if; - - -- Set section header. - - -- SHT_NULL. - Shdr (Sect_Null) := - Elf32_Shdr'(Sh_Name => 0, - Sh_Type => SHT_NULL, - Sh_Flags => 0, - Sh_Addr => 0, - Sh_Offset => 0, - Sh_Size => 0, - Sh_Link => 0, - Sh_Info => 0, - Sh_Addralign => 0, - Sh_Entsize => 0); - - -- shstrtab. - Shdr (Sect_Shstrtab) := - Elf32_Shdr'(Sh_Name => 1, - Sh_Type => SHT_STRTAB, - Sh_Flags => 0, - Sh_Addr => 0, - Sh_Offset => 0, -- Filled latter. - -- NUL: 1, .symtab: 8, .strtab: 8 and .shstrtab: 10. - Sh_Size => 1 + 10 + 8 + 8, - Sh_Link => 0, - Sh_Info => 0, - Sh_Addralign => 1, - Sh_Entsize => 0); - - -- Symtab - Shdr (Sect_Symtab) := - Elf32_Shdr'(Sh_Name => 11, - Sh_Type => SHT_SYMTAB, - Sh_Flags => 0, - Sh_Addr => 0, - Sh_Offset => 0, - Sh_Size => 0, - Sh_Link => Elf32_Word (Sect_Strtab), - Sh_Info => 0, -- FIXME - Sh_Addralign => 4, - Sh_Entsize => Elf32_Word (Elf32_Sym_Size)); - - -- strtab. - Shdr (Sect_Strtab) := - Elf32_Shdr'(Sh_Name => 19, - Sh_Type => SHT_STRTAB, - Sh_Flags => 0, - Sh_Addr => 0, - Sh_Offset => 0, - Sh_Size => 0, - Sh_Link => 0, - Sh_Info => 0, - Sh_Addralign => 1, - Sh_Entsize => 0); - - -- Fill sections. - Sect := Section_Chain; - Nbr_Sect := Sect_First; - Nbr_Symbols := 1; - while Sect /= null loop - Sections (Nbr_Sect) := (Sect => Sect, - Sym => Elf32_Word (Nbr_Symbols)); - Nbr_Symbols := Nbr_Symbols + 1; - Sect.Number := Nbr_Sect; - - Shdr (Nbr_Sect) := - Elf32_Shdr'(Sh_Name => Shdr (Sect_Shstrtab).Sh_Size, - Sh_Type => SHT_PROGBITS, - Sh_Flags => 0, - Sh_Addr => Elf32_Addr (Sect.Vaddr), - Sh_Offset => 0, - Sh_Size => 0, - Sh_Link => 0, - Sh_Info => 0, - Sh_Addralign => 2 ** Sect.Align, - Sh_Entsize => Elf32_Word (Sect.Esize)); - if Sect.Data = null then - Shdr (Nbr_Sect).Sh_Type := SHT_NOBITS; - end if; - if (Sect.Flags and Section_Read) /= 0 then - Shdr (Nbr_Sect).Sh_Flags := - Shdr (Nbr_Sect).Sh_Flags or SHF_ALLOC; - end if; - if (Sect.Flags and Section_Exec) /= 0 then - Shdr (Nbr_Sect).Sh_Flags := - Shdr (Nbr_Sect).Sh_Flags or SHF_EXECINSTR; - end if; - if (Sect.Flags and Section_Write) /= 0 then - Shdr (Nbr_Sect).Sh_Flags := - Shdr (Nbr_Sect).Sh_Flags or SHF_WRITE; - end if; - if Sect.Flags = Section_Strtab then - Shdr (Nbr_Sect).Sh_Type := SHT_STRTAB; - Shdr (Nbr_Sect).Sh_Addralign := 1; - Shdr (Nbr_Sect).Sh_Entsize := 0; - end if; - - Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size - + Sect.Name'Length + 1; -- 1 for Nul. - - Nbr_Sect := Nbr_Sect + 1; - if Flag_Reloc then - if Sect.First_Reloc /= null then - Do_Intra_Section_Reloc (Sect); - end if; - end if; - if Sect.First_Reloc /= null then - -- Add a section for the relocs. - Shdr (Nbr_Sect) := Elf32_Shdr' - (Sh_Name => Shdr (Sect_Shstrtab).Sh_Size, - Sh_Type => SHT_NULL, - Sh_Flags => 0, - Sh_Addr => 0, - Sh_Offset => 0, - Sh_Size => 0, - Sh_Link => Elf32_Word (Sect_Symtab), - Sh_Info => Elf32_Word (Nbr_Sect - 1), - Sh_Addralign => 4, - Sh_Entsize => Elf32_Word (Rel_Size)); - - if Is_Rela (Arch) then - Shdr (Nbr_Sect).Sh_Type := SHT_RELA; - else - Shdr (Nbr_Sect).Sh_Type := SHT_REL; - end if; - Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size - + Sect.Name'Length + 4 -- 4 for ".rel" - + Boolean'Pos (Is_Rela (Arch)) + 1; -- 1 for 'a', 1 for Nul. - - Nbr_Sect := Nbr_Sect + 1; - end if; - Sect := Sect.Next; - end loop; - - -- Lay-out sections. - Offset := Elf32_Off (Elf32_Ehdr_Size); - - -- Section table - Offset := Offset + Elf32_Off (Nbr_Sect * Elf32_Shdr_Size); - - -- shstrtab. - Shdr (Sect_Shstrtab).Sh_Offset := Offset; - - Offset := Sect_Align (Offset + Shdr (Sect_Shstrtab).Sh_Size); - - -- user-sections and relocation. - for I in Sect_First .. Nbr_Sect - 1 loop - Sect := Sections (I).Sect; - if Sect /= null then - Sect.Pc := Pow_Align (Sect.Pc, Sect.Align); - Shdr (Sect.Number).Sh_Size := Elf32_Word (Sect.Pc); - if Sect.Data /= null then - -- Set data offset. - Shdr (Sect.Number).Sh_Offset := Offset; - Offset := Offset + Shdr (Sect.Number).Sh_Size; - - -- Set relocs offset. - if Sect.First_Reloc /= null then - Shdr (Sect.Number + 1).Sh_Offset := Offset; - Shdr (Sect.Number + 1).Sh_Size := - Elf32_Word (Sect.Nbr_Relocs * Rel_Size); - Offset := Offset + Shdr (Sect.Number + 1).Sh_Size; - end if; - end if; - -- Set link. - if Sect.Link /= null then - Shdr (Sect.Number).Sh_Link := Elf32_Word (Sect.Link.Number); - end if; - end if; - end loop; - - -- Number symbols, put local before globals. - Nbr_Symbols := 1 + Nbr_Sections; - - -- First local symbols. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Private => - Set_Number (I, Nbr_Symbols); - Nbr_Symbols := Nbr_Symbols + 1; - when Sym_Local => - if not Flag_Discard_Local then - Set_Number (I, Nbr_Symbols); - Nbr_Symbols := Nbr_Symbols + 1; - end if; - when Sym_Undef - | Sym_Global => - null; - end case; - end loop; - - Shdr (Sect_Symtab).Sh_Info := Elf32_Word (Nbr_Symbols); - - -- Then globals. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Private - | Sym_Local => - null; - when Sym_Undef => - if Get_Used (I) then - Set_Number (I, Nbr_Symbols); - Nbr_Symbols := Nbr_Symbols + 1; - end if; - when Sym_Global => - Set_Number (I, Nbr_Symbols); - Nbr_Symbols := Nbr_Symbols + 1; - end case; - end loop; - - -- Symtab. - Shdr (Sect_Symtab).Sh_Offset := Offset; - -- 1 for nul. - Shdr (Sect_Symtab).Sh_Size := Elf32_Word (Nbr_Symbols * Elf32_Sym_Size); - - Offset := Offset + Shdr (Sect_Symtab).Sh_Size; - - -- Strtab offset. - Shdr (Sect_Strtab).Sh_Offset := Offset; - Shdr (Sect_Strtab).Sh_Size := 1; - - -- Compute length of strtab. - -- First, sections names. - Sect := Section_Chain; --- while Sect /= null loop --- Shdr (Sect_Strtab).Sh_Size := --- Shdr (Sect_Strtab).Sh_Size + Sect.Name'Length + 1; --- Sect := Sect.Prev; --- end loop; - -- Then symbols. - declare - Len : Natural; - L : Natural; - begin - Len := 0; - for I in Symbols.First .. Symbols.Last loop - L := Get_Symbol_Name_Length (I) + 1; - case Get_Scope (I) is - when Sym_Local => - if Flag_Discard_Local then - L := 0; - end if; - when Sym_Private => - null; - when Sym_Global => - null; - when Sym_Undef => - if not Get_Used (I) then - L := 0; - end if; - end case; - Len := Len + L; - end loop; - - Shdr (Sect_Strtab).Sh_Size := - Shdr (Sect_Strtab).Sh_Size + Elf32_Word (Len); - end; - - -- Write file header. - declare - Ehdr : Elf32_Ehdr; - begin - Ehdr := (E_Ident => (EI_MAG0 => ELFMAG0, - EI_MAG1 => ELFMAG1, - EI_MAG2 => ELFMAG2, - EI_MAG3 => ELFMAG3, - EI_CLASS => ELFCLASS32, - EI_DATA => ELFDATANONE, - EI_VERSION => EV_CURRENT, - EI_PAD .. 15 => 0), - E_Type => ET_REL, - E_Machine => EM_NONE, - E_Version => Elf32_Word (EV_CURRENT), - E_Entry => 0, - E_Phoff => 0, - E_Shoff => Elf32_Off (Elf32_Ehdr_Size), - E_Flags => 0, - E_Ehsize => Elf32_Half (Elf32_Ehdr_Size), - E_Phentsize => 0, - E_Phnum => 0, - E_Shentsize => Elf32_Half (Elf32_Shdr_Size), - E_Shnum => Elf32_Half (Nbr_Sect), - E_Shstrndx => 1); - case Arch is - when Arch_X86 => - Ehdr.E_Ident (EI_DATA) := ELFDATA2LSB; - Ehdr.E_Machine := EM_386; - when Arch_Sparc => - Ehdr.E_Ident (EI_DATA) := ELFDATA2MSB; - Ehdr.E_Machine := EM_SPARC; - when others => - raise Program_Error; - end case; - Xwrite (Ehdr'Address, Elf32_Ehdr_Size); - end; - - -- Write shdr. - Xwrite (Shdr'Address, Nbr_Sect * Elf32_Shdr_Size); - - -- Write shstrtab - Check_File_Pos (Shdr (Sect_Shstrtab).Sh_Offset); - declare - Str : String := - NUL & ".shstrtab" & NUL & ".symtab" & NUL & ".strtab" & NUL; - Rela : String := NUL & ".rela"; - begin - Xwrite (Str'Address, Str'Length); - Sect := Section_Chain; - while Sect /= null loop - Xwrite (Sect.Name.all'Address, Sect.Name'Length); - if Sect.First_Reloc /= null then - if Is_Rela (Arch) then - Xwrite (Rela'Address, Rela'Length); - else - Xwrite (Rela'Address, Rela'Length - 1); - end if; - Xwrite (Sect.Name.all'Address, Sect.Name'Length); - end if; - Xwrite (NUL'Address, 1); - Sect := Sect.Next; - end loop; - end; - -- Pad. - declare - Delt : Elf32_Word; - Nul_Str : String (1 .. 4) := (others => NUL); - begin - Delt := Shdr (Sect_Shstrtab).Sh_Size and 3; - if Delt /= 0 then - Xwrite (Nul_Str'Address, Natural (4 - Delt)); - end if; - end; - - -- Write sections content and reloc. - for I in 1 .. Nbr_Sect loop - Sect := Sections (I).Sect; - if Sect /= null then - if Sect.Data /= null then - Check_File_Pos (Shdr (Sect.Number).Sh_Offset); - Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc)); - end if; - declare - R : Reloc_Acc; - Rel : Elf32_Rel; - Rela : Elf32_Rela; - S : Elf32_Word; - Nbr_Reloc : Natural; - begin - R := Sect.First_Reloc; - Nbr_Reloc := 0; - while R /= null loop - if R.Done then - S := Sections (Get_Section (R.Sym).Number).Sym; - else - S := Elf32_Word (Get_Number (R.Sym)); - end if; - - if Is_Rela (Arch) then - case R.Kind is - when Reloc_Disp22 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP22); - when Reloc_Disp30 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP30); - when Reloc_Hi22 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_HI22); - when Reloc_Lo10 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_LO10); - when Reloc_32 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_32); - when Reloc_Ua_32 => - Rela.R_Info := Elf32_R_Info (S, R_SPARC_UA32); - when others => - raise Program_Error; - end case; - Rela.R_Addend := 0; - Rela.R_Offset := Elf32_Addr (R.Addr); - Xwrite (Rela'Address, Elf32_Rela_Size); - else - case R.Kind is - when Reloc_32 => - Rel.R_Info := Elf32_R_Info (S, R_386_32); - when Reloc_Pc32 => - Rel.R_Info := Elf32_R_Info (S, R_386_PC32); - when others => - raise Program_Error; - end case; - Rel.R_Offset := Elf32_Addr (R.Addr); - Xwrite (Rel'Address, Elf32_Rel_Size); - end if; - Nbr_Reloc := Nbr_Reloc + 1; - R := R.Sect_Next; - end loop; - if Nbr_Reloc /= Sect.Nbr_Relocs then - raise Program_Error; - end if; - end; - end if; - end loop; - - -- Write symbol table. - Check_File_Pos (Shdr (Sect_Symtab).Sh_Offset); - declare - Str_Off : Elf32_Word; - - procedure Gen_Sym (S : Symbol) - is - Sym : Elf32_Sym; - Bind : Elf32_Uchar; - Typ : Elf32_Uchar; - begin - Sym := Elf32_Sym'(St_Name => Str_Off, - St_Value => Elf32_Addr (Get_Symbol_Value (S)), - St_Size => 0, - St_Info => 0, - St_Other => 0, - St_Shndx => SHN_UNDEF); - if Get_Section (S) /= null then - Sym.St_Shndx := Elf32_Half (Get_Section (S).Number); - end if; - case Get_Scope (S) is - when Sym_Private - | Sym_Local => - Bind := STB_LOCAL; - Typ := STT_NOTYPE; - when Sym_Global => - Bind := STB_GLOBAL; - if Get_Section (S) /= null - and then (Get_Section (S).Flags and Section_Exec) /= 0 - then - Typ := STT_FUNC; - else - Typ := STT_OBJECT; - end if; - when Sym_Undef => - Bind := STB_GLOBAL; - Typ := STT_NOTYPE; - end case; - Sym.St_Info := Elf32_St_Info (Bind, Typ); - - Xwrite (Sym'Address, Elf32_Sym_Size); - - Str_Off := Str_Off + Elf32_Off (Get_Symbol_Name_Length (S) + 1); - end Gen_Sym; - - Sym : Elf32_Sym; - begin - - Str_Off := 1; - - -- write null entry - Sym := Elf32_Sym'(St_Name => 0, - St_Value => 0, - St_Size => 0, - St_Info => 0, - St_Other => 0, - St_Shndx => SHN_UNDEF); - Xwrite (Sym'Address, Elf32_Sym_Size); - - -- write section entries - Sect := Section_Chain; - while Sect /= null loop --- Sym := Elf32_Sym'(St_Name => Str_Off, --- St_Value => 0, --- St_Size => 0, --- St_Info => Elf32_St_Info (STB_LOCAL, --- STT_NOTYPE), --- St_Other => 0, --- St_Shndx => Elf32_Half (Sect.Number)); --- Xwrite (Sym'Address, Elf32_Sym_Size); --- Str_Off := Str_Off + Sect.Name'Length + 1; - - Sym := Elf32_Sym'(St_Name => 0, - St_Value => 0, - St_Size => 0, - St_Info => Elf32_St_Info (STB_LOCAL, - STT_SECTION), - St_Other => 0, - St_Shndx => Elf32_Half (Sect.Number)); - Xwrite (Sym'Address, Elf32_Sym_Size); - Sect := Sect.Next; - end loop; - - -- First local symbols. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Private => - Gen_Sym (I); - when Sym_Local => - if not Flag_Discard_Local then - Gen_Sym (I); - end if; - when Sym_Global - | Sym_Undef => - null; - end case; - end loop; - - -- Then global symbols. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Global => - Gen_Sym (I); - when Sym_Undef => - if Get_Used (I) then - Gen_Sym (I); - end if; - when Sym_Private - | Sym_Local => - null; - end case; - end loop; - end; - - -- Write strtab. - Check_File_Pos (Shdr (Sect_Strtab).Sh_Offset); - -- First is NUL. - Xwrite (NUL'Address, 1); - -- Then the sections name. --- Sect := Section_List; --- while Sect /= null loop --- Xwrite (Sect.Name.all'Address, Sect.Name'Length); --- Xwrite (NUL'Address, 1); --- Sect := Sect.Prev; --- end loop; - - -- Then the symbols name. - declare - procedure Write_Sym_Name (S : Symbol) - is - Str : String := Get_Symbol_Name (S) & NUL; - begin - Xwrite (Str'Address, Str'Length); - end Write_Sym_Name; - begin - -- First locals. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Private => - Write_Sym_Name (I); - when Sym_Local => - if not Flag_Discard_Local then - Write_Sym_Name (I); - end if; - when Sym_Global - | Sym_Undef => - null; - end case; - end loop; - - -- Then global symbols. - for I in Symbols.First .. Symbols.Last loop - case Get_Scope (I) is - when Sym_Global => - Write_Sym_Name (I); - when Sym_Undef => - if Get_Used (I) then - Write_Sym_Name (I); - end if; - when Sym_Private - | Sym_Local => - null; - end case; - end loop; - end; - end Write_Elf; - -end Binary_File.Elf; diff --git a/ortho/mcode/binary_file-elf.ads b/ortho/mcode/binary_file-elf.ads deleted file mode 100644 index e0d3a4d2a..000000000 --- a/ortho/mcode/binary_file-elf.ads +++ /dev/null @@ -1,22 +0,0 @@ --- Binary file ELF writer. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.OS_Lib; - -package Binary_File.Elf is - procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor); -end Binary_File.Elf; diff --git a/ortho/mcode/binary_file-memory.adb b/ortho/mcode/binary_file-memory.adb deleted file mode 100644 index a37af9cb7..000000000 --- a/ortho/mcode/binary_file-memory.adb +++ /dev/null @@ -1,101 +0,0 @@ --- Binary file execute in memory handler. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Conversion; - -package body Binary_File.Memory is - -- Absolute section. - Sect_Abs : Section_Acc; - - function To_Pc_Type is new Ada.Unchecked_Conversion - (Source => System.Address, Target => Pc_Type); - - procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address) - is - begin - Set_Symbol_Value (Sym, To_Pc_Type (Addr)); - Set_Scope (Sym, Sym_Global); - Set_Section (Sym, Sect_Abs); - end Set_Symbol_Address; - - procedure Write_Memory_Init is - begin - Create_Section (Sect_Abs, "*ABS*", Section_Exec); - Sect_Abs.Vaddr := 0; - end Write_Memory_Init; - - procedure Write_Memory_Relocate (Error : out Boolean) - is - Sect : Section_Acc; - Rel : Reloc_Acc; - N_Rel : Reloc_Acc; - begin - -- Relocate section in memory. - Sect := Section_Chain; - while Sect /= null loop - if Sect.Data = null then - if Sect.Pc > 0 then - Resize (Sect, Sect.Pc); - Sect.Data (0 .. Sect.Pc - 1) := (others => 0); - else - null; - --Sect.Data := new Byte_Array (1 .. 0); - end if; - end if; - if Sect.Data_Max > 0 - and (Sect /= Sect_Abs and Sect.Flags /= Section_Debug) - then - Sect.Vaddr := To_Pc_Type (Sect.Data (0)'Address); - end if; - Sect := Sect.Next; - end loop; - - -- Do all relocations. - Sect := Section_Chain; - Error := False; - while Sect /= null loop --- Put_Line ("Section: " & Sect.Name.all & ", Flags:" --- & Section_Flags'Image (Sect.Flags)); - Rel := Sect.First_Reloc; - while Rel /= null loop - N_Rel := Rel.Sect_Next; - if Get_Scope (Rel.Sym) = Sym_Undef then - Put_Line ("symbol " & Get_Symbol_Name (Rel.Sym) - & " is undefined"); - Error := True; - else - Apply_Reloc (Sect, Rel); - end if; - Free (Rel); - Rel := N_Rel; - end loop; - - Sect.First_Reloc := null; - Sect.Last_Reloc := null; - Sect.Nbr_Relocs := 0; - - if (Sect.Flags and Section_Exec) /= 0 - and (Sect.Flags and Section_Write) = 0 - then - Memsegs.Set_Rx (Sect.Seg); - end if; - - Sect := Sect.Next; - end loop; - end Write_Memory_Relocate; -end Binary_File.Memory; diff --git a/ortho/mcode/binary_file-memory.ads b/ortho/mcode/binary_file-memory.ads deleted file mode 100644 index a205da527..000000000 --- a/ortho/mcode/binary_file-memory.ads +++ /dev/null @@ -1,25 +0,0 @@ --- Binary file execute in memory handler. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Binary_File.Memory is - - -- Must be called before set_symbol_address. - procedure Write_Memory_Init; - procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address); - - procedure Write_Memory_Relocate (Error : out Boolean); -end Binary_File.Memory; diff --git a/ortho/mcode/binary_file.adb b/ortho/mcode/binary_file.adb deleted file mode 100644 index 6043d7319..000000000 --- a/ortho/mcode/binary_file.adb +++ /dev/null @@ -1,977 +0,0 @@ --- Binary file handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System.Storage_Elements; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Characters.Latin_1; -with Ada.Unchecked_Conversion; -with Hex_Images; use Hex_Images; -with Disassemble; - -package body Binary_File is - Cur_Sect : Section_Acc := null; - - HT : Character renames Ada.Characters.Latin_1.HT; - - function To_Byte_Array_Acc is new Ada.Unchecked_Conversion - (Source => System.Address, Target => Byte_Array_Acc); - - -- Resize a section to SIZE bytes. - procedure Resize (Sect : Section_Acc; Size : Pc_Type) - is - begin - Sect.Data_Max := Size; - Memsegs.Resize (Sect.Seg, Natural (Size)); - Sect.Data := To_Byte_Array_Acc (Memsegs.Get_Address (Sect.Seg)); - end Resize; - - function Get_Scope (Sym : Symbol) return Symbol_Scope is - begin - return Symbols.Table (Sym).Scope; - end Get_Scope; - - procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope) is - begin - Symbols.Table (Sym).Scope := Scope; - end Set_Scope; - - function Get_Section (Sym : Symbol) return Section_Acc is - begin - return Symbols.Table (Sym).Section; - end Get_Section; - - procedure Set_Section (Sym : Symbol; Sect : Section_Acc) is - begin - Symbols.Table (Sym).Section := Sect; - end Set_Section; - - function Get_Number (Sym : Symbol) return Natural is - begin - return Symbols.Table (Sym).Number; - end Get_Number; - - procedure Set_Number (Sym : Symbol; Num : Natural) is - begin - Symbols.Table (Sym).Number := Num; - end Set_Number; - - function Get_Relocs (Sym : Symbol) return Reloc_Acc is - begin - return Symbols.Table (Sym).Relocs; - end Get_Relocs; - - procedure Set_Relocs (Sym : Symbol; Reloc : Reloc_Acc) is - begin - Symbols.Table (Sym).Relocs := Reloc; - end Set_Relocs; - - function Get_Name (Sym : Symbol) return O_Ident is - begin - return Symbols.Table (Sym).Name; - end Get_Name; - - function Get_Used (Sym : Symbol) return Boolean is - begin - return Symbols.Table (Sym).Used; - end Get_Used; - - procedure Set_Used (Sym : Symbol; Val : Boolean) is - begin - Symbols.Table (Sym).Used := Val; - end Set_Used; - - function Get_Symbol_Value (Sym : Symbol) return Pc_Type is - begin - return Symbols.Table (Sym).Value; - end Get_Symbol_Value; - - procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type) is - begin - Symbols.Table (Sym).Value := Val; - end Set_Symbol_Value; - - function S_Defined (Sym : Symbol) return Boolean is - begin - return Get_Scope (Sym) /= Sym_Undef; - end S_Defined; - pragma Unreferenced (S_Defined); - - function S_Local (Sym : Symbol) return Boolean is - begin - return Get_Scope (Sym) = Sym_Local; - end S_Local; - - procedure Create_Section (Sect : out Section_Acc; - Name : String; Flags : Section_Flags) - is - begin - Sect := new Section_Type'(Next => null, - Flags => Flags, - Name => new String'(Name), - Link => null, - Align => 2, - Esize => 0, - Pc => 0, - Insn_Pc => 0, - Data => null, - Data_Max => 0, - First_Reloc => null, - Last_Reloc => null, - Nbr_Relocs => 0, - Number => 0, - Seg => Memsegs.Create, - Vaddr => 0); - if (Flags and Section_Zero) = 0 then - -- Allocate memory for the segment, unless BSS. - Resize (Sect, 8192); - end if; - if (Flags and Section_Strtab) /= 0 then - Sect.Align := 0; - end if; - if Section_Chain = null then - Section_Chain := Sect; - else - Section_Last.Next := Sect; - end if; - Section_Last := Sect; - Nbr_Sections := Nbr_Sections + 1; - end Create_Section; - - procedure Sect_Prealloc (Sect : Section_Acc; L : Pc_Type) - is - New_Max : Pc_Type; - begin - if Sect.Pc + L < Sect.Data_Max then - return; - end if; - New_Max := Sect.Data_Max; - loop - New_Max := New_Max * 2; - exit when Sect.Pc + L < New_Max; - end loop; - Resize (Sect, New_Max); - end Sect_Prealloc; - - procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc) - is - Rel : Reloc_Acc; - begin - -- Sanity checks. - if Src = null or else Dest = Src then - raise Program_Error; - end if; - - Rel := Src.First_Reloc; - - if Rel /= null then - -- Move relocs. - if Dest.Last_Reloc = null then - Dest.First_Reloc := Rel; - Dest.Last_Reloc := Rel; - else - Dest.Last_Reloc.Sect_Next := Rel; - Dest.Last_Reloc := Rel; - end if; - Dest.Nbr_Relocs := Dest.Nbr_Relocs + Src.Nbr_Relocs; - - - -- Reloc reloc, since the pc has changed. - while Rel /= null loop - Rel.Addr := Rel.Addr + Dest.Pc; - Rel := Rel.Sect_Next; - end loop; - end if; - - if Src.Pc > 0 then - Sect_Prealloc (Dest, Src.Pc); - Dest.Data (Dest.Pc .. Dest.Pc + Src.Pc - 1) := - Src.Data (0 .. Src.Pc - 1); - Dest.Pc := Dest.Pc + Src.Pc; - end if; - - Memsegs.Delete (Src.Seg); - Src.Pc := 0; - Src.Data_Max := 0; - Src.Data := null; - Src.First_Reloc := null; - Src.Last_Reloc := null; - Src.Nbr_Relocs := 0; - - -- Remove from section_chain. - if Section_Chain = Src then - Section_Chain := Src.Next; - else - declare - Sect : Section_Acc; - begin - Sect := Section_Chain; - while Sect.Next /= Src loop - Sect := Sect.Next; - end loop; - Sect.Next := Src.Next; - if Section_Last = Src then - Section_Last := Sect; - end if; - end; - end if; - Nbr_Sections := Nbr_Sections - 1; - end Merge_Section; - - procedure Set_Section_Info (Sect : Section_Acc; - Link : Section_Acc; - Align : Natural; - Esize : Natural) - is - begin - Sect.Link := Link; - Sect.Align := Align; - Sect.Esize := Esize; - end Set_Section_Info; - - procedure Set_Current_Section (Sect : Section_Acc) is - begin - -- If the current section does not change, this is a no-op. - if Cur_Sect = Sect then - return; - end if; - - if Dump_Asm then - Put_Line (HT & ".section """ & Sect.Name.all & """"); - end if; - Cur_Sect := Sect; - end Set_Current_Section; - - function Get_Current_Pc return Pc_Type is - begin - return Cur_Sect.Pc; - end Get_Current_Pc; - - function Get_Pc (Sect : Section_Acc) return Pc_Type is - begin - return Sect.Pc; - end Get_Pc; - - - procedure Prealloc (L : Pc_Type) is - begin - Sect_Prealloc (Cur_Sect, L); - end Prealloc; - - procedure Start_Insn is - begin - -- Check there is enough memory for the next instruction. - Sect_Prealloc (Cur_Sect, 16); - if Cur_Sect.Insn_Pc /= 0 then - -- end_insn was not called. - raise Program_Error; - end if; - Cur_Sect.Insn_Pc := Cur_Sect.Pc; - end Start_Insn; - - procedure Get_Symbol_At_Addr (Addr : System.Address; - Line : in out String; - Line_Len : in out Natural) - is - use System; - use System.Storage_Elements; - Off : Pc_Type; - Reloc : Reloc_Acc; - begin - -- Check if addr is in the current section. - if Addr < Cur_Sect.Data (0)'Address - or else Addr > Cur_Sect.Data (Cur_Sect.Pc)'Address - then - raise Program_Error; - --return; - end if; - Off := Pc_Type - (To_Integer (Addr) - To_Integer (Cur_Sect.Data (0)'Address)); - - -- Find a relocation at OFF. - Reloc := Cur_Sect.First_Reloc; - while Reloc /= null loop - if Reloc.Addr = Off then - declare - Str : constant String := Get_Symbol_Name (Reloc.Sym); - begin - Line (Line'First .. Line'First + Str'Length - 1) := Str; - Line_Len := Line_Len + Str'Length; - return; - end; - end if; - Reloc := Reloc.Sect_Next; - end loop; - end Get_Symbol_At_Addr; - - procedure End_Insn - is - Str : String (1 .. 256); - Len : Natural; - Insn_Len : Natural; - begin - --if Insn_Pc = 0 then - -- -- start_insn was not called. - -- raise Program_Error; - --end if; - if Debug_Hex then - Put (HT); - Put ('#'); - for I in Cur_Sect.Insn_Pc .. Cur_Sect.Pc - 1 loop - Put (' '); - Put (Hex_Image (Unsigned_8 (Cur_Sect.Data (I)))); - end loop; - New_Line; - end if; - - if Dump_Asm then - Disassemble.Disassemble_Insn - (Cur_Sect.Data (Cur_Sect.Insn_Pc)'Address, - Unsigned_32 (Cur_Sect.Insn_Pc), - Str, Len, Insn_Len, - Get_Symbol_At_Addr'Access); - Put (HT); - Put_Line (Str (1 .. Len)); - end if; - --if Natural (Cur_Pc - Insn_Pc) /= Insn_Len then - -- raise Program_Error; - --end if; - Cur_Sect.Insn_Pc := 0; - end End_Insn; - - procedure Gen_B8 (B : Byte) is - begin - Cur_Sect.Data (Cur_Sect.Pc) := B; - Cur_Sect.Pc := Cur_Sect.Pc + 1; - end Gen_B8; - - procedure Gen_B16 (B0, B1 : Byte) is - begin - Cur_Sect.Data (Cur_Sect.Pc + 0) := B0; - Cur_Sect.Data (Cur_Sect.Pc + 1) := B1; - Cur_Sect.Pc := Cur_Sect.Pc + 2; - end Gen_B16; - - procedure Gen_Le8 (B : Unsigned_32) is - begin - Cur_Sect.Data (Cur_Sect.Pc) := Byte (B and 16#Ff#); - Cur_Sect.Pc := Cur_Sect.Pc + 1; - end Gen_Le8; - - procedure Gen_Le16 (B : Unsigned_32) is - begin - Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 0) and 16#Ff#); - Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 8) and 16#Ff#); - Cur_Sect.Pc := Cur_Sect.Pc + 2; - end Gen_Le16; - - procedure Gen_Be16 (B : Unsigned_32) is - begin - Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 8) and 16#Ff#); - Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 0) and 16#Ff#); - Cur_Sect.Pc := Cur_Sect.Pc + 2; - end Gen_Be16; - - procedure Write_B8 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_8) is - begin - Sect.Data (Pc) := Byte (V); - end Write_B8; - - procedure Write_Be16 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is - begin - Sect.Data (Pc + 0) := Byte (Shift_Right (V, 8) and 16#Ff#); - Sect.Data (Pc + 1) := Byte (Shift_Right (V, 0) and 16#Ff#); - end Write_Be16; - - procedure Write_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is - begin - Sect.Data (Pc + 0) := Byte (Shift_Right (V, 0) and 16#Ff#); - Sect.Data (Pc + 1) := Byte (Shift_Right (V, 8) and 16#Ff#); - Sect.Data (Pc + 2) := Byte (Shift_Right (V, 16) and 16#Ff#); - Sect.Data (Pc + 3) := Byte (Shift_Right (V, 24) and 16#Ff#); - end Write_Le32; - - procedure Write_Be32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is - begin - Sect.Data (Pc + 0) := Byte (Shift_Right (V, 24) and 16#Ff#); - Sect.Data (Pc + 1) := Byte (Shift_Right (V, 16) and 16#Ff#); - Sect.Data (Pc + 2) := Byte (Shift_Right (V, 8) and 16#Ff#); - Sect.Data (Pc + 3) := Byte (Shift_Right (V, 0) and 16#Ff#); - end Write_Be32; - - procedure Write_16 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) - is - subtype B2 is Byte_Array_Base (0 .. 1); - function To_B2 is new Ada.Unchecked_Conversion - (Source => Unsigned_16, Target => B2); - begin - Sect.Data (Pc + 0 .. Pc + 1) := To_B2 (Unsigned_16 (B)); - end Write_16; - - procedure Write_32 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) - is - subtype B4 is Byte_Array_Base (0 .. 3); - function To_B4 is new Ada.Unchecked_Conversion - (Source => Unsigned_32, Target => B4); - begin - Sect.Data (Pc + 0 .. Pc + 3) := To_B4 (B); - end Write_32; - - procedure Gen_16 (B : Unsigned_32) is - begin - Write_16 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 2; - end Gen_16; - - procedure Gen_32 (B : Unsigned_32) is - begin - Write_32 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 4; - end Gen_32; - - function Read_Le32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is - begin - return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 0) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 8) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 16) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 24); - end Read_Le32; - - function Read_Be32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is - begin - return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 24) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 16) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 8) - or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 0); - end Read_Be32; - - procedure Add_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is - begin - Write_Le32 (Sect, Pc, V + Read_Le32 (Sect, Pc)); - end Add_Le32; - - procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32) is - begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; - Write_Le32 (Cur_Sect, Pc, V); - end Patch_Le32; - - procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32) is - begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; - Write_Be32 (Cur_Sect, Pc, V); - end Patch_Be32; - - procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32) is - begin - if Pc + 2 > Get_Current_Pc then - raise Program_Error; - end if; - Write_Be16 (Cur_Sect, Pc, V); - end Patch_Be16; - - procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8) is - begin - if Pc >= Get_Current_Pc then - raise Program_Error; - end if; - Write_B8 (Cur_Sect, Pc, V); - end Patch_B8; - - procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32) is - begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; - Write_32 (Cur_Sect, Pc, V); - end Patch_32; - - procedure Gen_Le32 (B : Unsigned_32) is - begin - Write_Le32 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 4; - end Gen_Le32; - - procedure Gen_Be32 (B : Unsigned_32) is - begin - Write_Be32 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 4; - end Gen_Be32; - - procedure Gen_Data_Le8 (B : Unsigned_32) is - begin - if Dump_Asm then - Put_Line (HT & ".byte 0x" & Hex_Image (Unsigned_8 (B))); - end if; - Gen_Le8 (B); - end Gen_Data_Le8; - - procedure Gen_Data_Le16 (B : Unsigned_32) is - begin - if Dump_Asm then - Put_Line (HT & ".half 0x" & Hex_Image (Unsigned_16 (B))); - end if; - Gen_Le16 (B); - end Gen_Data_Le16; - - procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32) is - begin - if Dump_Asm then - if Sym = Null_Symbol then - Put_Line (HT & ".word 0x" & Hex_Image (Offset)); - else - if Offset = 0 then - Put_Line (HT & ".word " & Get_Symbol_Name (Sym)); - else - Put_Line (HT & ".word " & Get_Symbol_Name (Sym) & " + " - & Hex_Image (Offset)); - end if; - end if; - end if; - case Arch is - when Arch_X86 => - Gen_X86_32 (Sym, Offset); - when Arch_Sparc => - Gen_Sparc_32 (Sym, Offset); - when others => - raise Program_Error; - end case; - end Gen_Data_32; - - function Create_Symbol (Name : O_Ident) return Symbol - is - begin - Symbols.Append (Symbol_Type'(Section => null, - Value => 0, - Scope => Sym_Undef, - Used => False, - Name => Name, - Relocs => null, - Number => 0)); - return Symbols.Last; - end Create_Symbol; - - Last_Label : Natural := 1; - - function Create_Local_Symbol return Symbol is - begin - Symbols.Append (Symbol_Type'(Section => Cur_Sect, - Value => 0, - Scope => Sym_Local, - Used => False, - Name => O_Ident_Nul, - Relocs => null, - Number => Last_Label)); - - Last_Label := Last_Label + 1; - - return Symbols.Last; - end Create_Local_Symbol; - - function Get_Symbol_Name (Sym : Symbol) return String - is - Res : String (1 .. 10); - N : Natural; - P : Natural; - begin - if S_Local (Sym) then - N := Get_Number (Sym); - P := Res'Last; - loop - Res (P) := Character'Val ((N mod 10) + Character'Pos ('0')); - N := N / 10; - P := P - 1; - exit when N = 0; - end loop; - Res (P) := 'L'; - Res (P - 1) := '.'; - return Res (P - 1 .. Res'Last); - else - if Is_Nul (Get_Name (Sym)) then - return "ANON"; - else - return Get_String (Get_Name (Sym)); - end if; - end if; - end Get_Symbol_Name; - - function Get_Symbol_Name_Length (Sym : Symbol) return Natural - is - N : Natural; - begin - if S_Local (Sym) then - N := 10; - for I in 3 .. 8 loop - if Get_Number (Sym) < N then - return I; - end if; - N := N * 10; - end loop; - raise Program_Error; - else - return Get_String_Length (Get_Name (Sym)); - end if; - end Get_Symbol_Name_Length; - - function Get_Symbol (Name : String) return Symbol is - begin - for I in Symbols.First .. Symbols.Last loop - if Get_Symbol_Name (I) = Name then - return I; - end if; - end loop; - return Null_Symbol; - end Get_Symbol; - - function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type - is - Tmp : Pc_Type; - begin - Tmp := V + 2 ** Align - 1; - return Tmp - (Tmp mod Pc_Type (2 ** Align)); - end Pow_Align; - - procedure Gen_Pow_Align (Align : Natural) is - begin - if Align = 0 then - return; - end if; - if Dump_Asm then - Put_Line (HT & ".align" & Natural'Image (Align)); - end if; - Cur_Sect.Pc := Pow_Align (Cur_Sect.Pc, Align); - end Gen_Pow_Align; - - -- Generate LENGTH bytes set to 0. - procedure Gen_Space (Length : Integer_32) is - begin - if Dump_Asm then - Put_Line (HT & ".space" & Integer_32'Image (Length)); - end if; - Cur_Sect.Pc := Cur_Sect.Pc + Pc_Type (Length); - end Gen_Space; - - procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) is - begin - case Get_Scope (Sym) is - when Sym_Local => - if Export then - raise Program_Error; - end if; - when Sym_Private - | Sym_Global => - raise Program_Error; - when Sym_Undef => - if Export then - Set_Scope (Sym, Sym_Global); - else - Set_Scope (Sym, Sym_Private); - end if; - end case; - -- Set value/section. - Set_Symbol_Value (Sym, Cur_Sect.Pc); - Set_Section (Sym, Cur_Sect); - - if Dump_Asm then - if Export then - Put_Line (HT & ".globl " & Get_Symbol_Name (Sym)); - end if; - Put (Get_Symbol_Name (Sym)); - Put_Line (":"); - end if; - end Set_Symbol_Pc; - - procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) - is - Reloc : Reloc_Acc; - begin - Reloc := new Reloc_Type'(Kind => Kind, - Done => False, - Sym_Next => Get_Relocs (Sym), - Sect_Next => null, - Addr => Cur_Sect.Pc, - Sym => Sym); - Set_Relocs (Sym, Reloc); - if Cur_Sect.First_Reloc = null then - Cur_Sect.First_Reloc := Reloc; - else - Cur_Sect.Last_Reloc.Sect_Next := Reloc; - end if; - Cur_Sect.Last_Reloc := Reloc; - Cur_Sect.Nbr_Relocs := Cur_Sect.Nbr_Relocs + 1; - end Add_Reloc; - - procedure Gen_X86_Pc32 (Sym : Symbol) - is - begin - Add_Reloc (Sym, Reloc_Pc32); - Gen_Le32 (16#ff_ff_ff_fc#); - end Gen_X86_Pc32; - - procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol) - is - begin - Add_Reloc (Sym, Reloc_Disp22); - Gen_Be32 (W); - end Gen_Sparc_Disp22; - - procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol) - is - begin - Add_Reloc (Sym, Reloc_Disp30); - Gen_Be32 (W); - end Gen_Sparc_Disp30; - - procedure Gen_Sparc_Hi22 (W : Unsigned_32; - Sym : Symbol; Off : Unsigned_32) - is - pragma Unreferenced (Off); - begin - Add_Reloc (Sym, Reloc_Hi22); - Gen_Be32 (W); - end Gen_Sparc_Hi22; - - procedure Gen_Sparc_Lo10 (W : Unsigned_32; - Sym : Symbol; Off : Unsigned_32) - is - pragma Unreferenced (Off); - begin - Add_Reloc (Sym, Reloc_Lo10); - Gen_Be32 (W); - end Gen_Sparc_Lo10; - - function Conv is new Ada.Unchecked_Conversion - (Source => Integer_32, Target => Unsigned_32); - - procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32) is - begin - if Sym /= Null_Symbol then - Add_Reloc (Sym, Reloc_32); - end if; - Gen_Le32 (Conv (Offset)); - end Gen_X86_32; - - procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32) is - begin - if Sym /= Null_Symbol then - Add_Reloc (Sym, Reloc_32); - end if; - Gen_Be32 (Conv (Offset)); - end Gen_Sparc_32; - - procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32) - is - pragma Unreferenced (Offset); - begin - if Sym /= Null_Symbol then - Add_Reloc (Sym, Reloc_Ua_32); - end if; - Gen_Be32 (0); - end Gen_Sparc_Ua_32; - - procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32) is - begin - case Arch is - when Arch_X86 => - Gen_X86_32 (Sym, Offset); - when Arch_Sparc => - Gen_Sparc_Ua_32 (Sym, Offset); - when others => - raise Program_Error; - end case; - end Gen_Ua_32; - - procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol) - is - begin - Add_Reloc (Sym, Reloc_Ppc_Addr24); - Gen_32 (V); - end Gen_Ppc_24; - - function Get_Symbol_Vaddr (Sym : Symbol) return Pc_Type is - begin - return Get_Section (Sym).Vaddr + Get_Symbol_Value (Sym); - end Get_Symbol_Vaddr; - - procedure Write_Left_Be32 (Sect : Section_Acc; - Addr : Pc_Type; - Size : Natural; - Val : Unsigned_32) - is - W : Unsigned_32; - Mask : Unsigned_32; - begin - -- Write value. - Mask := Shift_Left (1, Size) - 1; - W := Read_Be32 (Sect, Addr); - Write_Be32 (Sect, Addr, (W and not Mask) or (Val and Mask)); - end Write_Left_Be32; - - procedure Set_Wdisp (Sect : Section_Acc; - Addr : Pc_Type; - Sym : Symbol; - Size : Natural) - is - D : Unsigned_32; - Mask : Unsigned_32; - begin - D := Unsigned_32 (Get_Symbol_Vaddr (Sym) - (Sect.Vaddr + Addr)); - -- Check overflow. - Mask := Shift_Left (1, Size + 2) - 1; - if (D and Shift_Left (1, Size + 1)) = 0 then - if (D and not Mask) /= 0 then - raise Program_Error; - end if; - else - if (D and not Mask) /= not Mask then - raise Program_Error; - end if; - end if; - -- Write value. - Write_Left_Be32 (Sect, Addr, Size, D / 4); - end Set_Wdisp; - - procedure Do_Reloc (Kind : Reloc_Kind; - Sect : Section_Acc; Addr : Pc_Type; Sym : Symbol) - is - begin - if Get_Scope (Sym) = Sym_Undef then - raise Program_Error; - end if; - - case Kind is - when Reloc_32 => - Add_Le32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); - - when Reloc_Pc32 => - Add_Le32 (Sect, Addr, - Unsigned_32 (Get_Symbol_Vaddr (Sym) - - (Sect.Vaddr + Addr))); - when Reloc_Disp22 => - Set_Wdisp (Sect, Addr, Sym, 22); - when Reloc_Disp30 => - Set_Wdisp (Sect, Addr, Sym, 30); - when Reloc_Hi22 => - Write_Left_Be32 (Sect, Addr, 22, - Unsigned_32 (Get_Symbol_Vaddr (Sym) / 1024)); - when Reloc_Lo10 => - Write_Left_Be32 (Sect, Addr, 10, - Unsigned_32 (Get_Symbol_Vaddr (Sym))); - when Reloc_Ua_32 => - Write_Be32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); - when Reloc_Ppc_Addr24 => - raise Program_Error; - end case; - end Do_Reloc; - - function Is_Reloc_Relative (Reloc : Reloc_Acc) return Boolean is - begin - case Reloc.Kind is - when Reloc_Pc32 - | Reloc_Disp22 - | Reloc_Disp30 => - return True; - when others => - return False; - end case; - end Is_Reloc_Relative; - - procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc) is - begin - Do_Reloc (Reloc.Kind, Sect, Reloc.Addr, Reloc.Sym); - end Apply_Reloc; - - procedure Do_Intra_Section_Reloc (Sect : Section_Acc) - is - Prev : Reloc_Acc; - Rel : Reloc_Acc; - Next : Reloc_Acc; - begin - Rel := Sect.First_Reloc; - Prev := null; - while Rel /= null loop - Next := Rel.Sect_Next; - if Get_Scope (Rel.Sym) /= Sym_Undef then - Do_Reloc (Rel.Kind, Sect, Rel.Addr, Rel.Sym); - Rel.Done := True; - - if Get_Section (Rel.Sym) = Sect - and then Is_Reloc_Relative (Rel) - then - -- Remove reloc. - Sect.Nbr_Relocs := Sect.Nbr_Relocs - 1; - if Prev = null then - Sect.First_Reloc := Next; - else - Prev.Sect_Next := Next; - end if; - if Next = null then - Sect.Last_Reloc := Prev; - end if; - Free (Rel); - else - Prev := Rel; - end if; - else - Set_Used (Rel.Sym, True); - Prev := Rel; - end if; - Rel := Next; - end loop; - end Do_Intra_Section_Reloc; - - -- Return VAL rounded up to 2 ^ POW. --- function Align_Pow (Val : Integer; Pow : Natural) return Integer --- is --- N : Integer; --- Tmp : Integer; --- begin --- N := 2 ** Pow; --- Tmp := Val + N - 1; --- return Tmp - (Tmp mod N); --- end Align_Pow; - - procedure Disp_Stats is - begin - Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last)); - end Disp_Stats; - - procedure Finish - is - Sect : Section_Acc; - Rel, N_Rel : Reloc_Acc; - begin - Symbols.Free; - Sect := Section_Chain; - while Sect /= null loop - -- Free relocs. - Rel := Sect.First_Reloc; - while Rel /= null loop - N_Rel := Rel.Sect_Next; - Free (Rel); - Rel := N_Rel; - end loop; - Sect.First_Reloc := null; - Sect.Last_Reloc := null; - - Sect := Sect.Next; - end loop; - end Finish; -end Binary_File; diff --git a/ortho/mcode/binary_file.ads b/ortho/mcode/binary_file.ads deleted file mode 100644 index 1a2bf588d..000000000 --- a/ortho/mcode/binary_file.ads +++ /dev/null @@ -1,305 +0,0 @@ --- Binary file handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; -with Ada.Unchecked_Deallocation; -with Ortho_Ident; use Ortho_Ident; -with GNAT.Table; -with Memsegs; - -package Binary_File is - type Section_Type is limited private; - type Section_Acc is access Section_Type; - - type Section_Flags is new Unsigned_32; - Section_None : constant Section_Flags; - Section_Exec : constant Section_Flags; - Section_Read : constant Section_Flags; - Section_Write : constant Section_Flags; - Section_Zero : constant Section_Flags; - Section_Strtab : constant Section_Flags; - Section_Debug : constant Section_Flags; - - type Byte is new Unsigned_8; - - type Symbol is range -2 ** 31 .. 2 ** 31 - 1; - for Symbol'Size use 32; - Null_Symbol : constant Symbol := 0; - - type Pc_Type is mod System.Memory_Size; - Null_Pc : constant Pc_Type := 0; - - type Arch_Kind is (Arch_Unknown, Arch_X86, Arch_Sparc, Arch_Ppc); - Arch : Arch_Kind := Arch_Unknown; - - -- Dump assembly when generated. - Dump_Asm : Boolean := False; - - Debug_Hex : Boolean := False; - - -- Create a section. - procedure Create_Section (Sect : out Section_Acc; - Name : String; Flags : Section_Flags); - procedure Set_Section_Info (Sect : Section_Acc; - Link : Section_Acc; - Align : Natural; - Esize : Natural); - - procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc); - - -- Set the current section. - procedure Set_Current_Section (Sect : Section_Acc); - - -- Create an undefined local (anonymous) symbol in the current section. - function Create_Local_Symbol return Symbol; - function Create_Symbol (Name : O_Ident) return Symbol; - - -- Research symbol NAME, very expansive call. - -- Return NULL_Symbol if not found. - function Get_Symbol (Name : String) return Symbol; - - -- Get the virtual address of a symbol. - function Get_Symbol_Vaddr (Sym : Symbol) return Pc_Type; - pragma Inline (Get_Symbol_Vaddr); - - -- Set the value of a symbol. - procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean); - function Get_Symbol_Value (Sym : Symbol) return Pc_Type; - - -- Get the current PC. - function Get_Current_Pc return Pc_Type; - pragma Inline (Get_Current_Pc); - - function Get_Pc (Sect : Section_Acc) return Pc_Type; - pragma Inline (Get_Pc); - - -- Align the current section of 2 ** ALIGN. - procedure Gen_Pow_Align (Align : Natural); - - -- Generate LENGTH times 0. - procedure Gen_Space (Length : Integer_32); - - -- Add a reloc in the current section at the current address. - procedure Gen_X86_Pc32 (Sym : Symbol); - procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol); - procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol); - procedure Gen_Sparc_Hi22 (W : Unsigned_32; - Sym : Symbol; Off : Unsigned_32); - procedure Gen_Sparc_Lo10 (W : Unsigned_32; - Sym : Symbol; Off : Unsigned_32); - - -- Add a 32 bits value with a symbol relocation in the current section at - -- the current address. - procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32); - procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32); - procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32); - - procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol); - - procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32); - - -- Start/finish an instruction in the current section. - procedure Start_Insn; - procedure End_Insn; - -- Pre allocate L bytes. - procedure Prealloc (L : Pc_Type); - - -- Add bits in the current section. - procedure Gen_B8 (B : Byte); - procedure Gen_B16 (B0, B1 : Byte); - procedure Gen_Le8 (B : Unsigned_32); - procedure Gen_Le16 (B : Unsigned_32); - procedure Gen_Be16 (B : Unsigned_32); - procedure Gen_Le32 (B : Unsigned_32); - procedure Gen_Be32 (B : Unsigned_32); - - procedure Gen_16 (B : Unsigned_32); - procedure Gen_32 (B : Unsigned_32); - - -- Add bits in the current section, but as stand-alone data. - procedure Gen_Data_Le8 (B : Unsigned_32); - procedure Gen_Data_Le16 (B : Unsigned_32); - procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32); - - -- Modify already generated code. - procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8); - procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32); - procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32); - procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32); - procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32); - - -- Binary writers: - - -- Set ERROR in case of error (undefined symbol). - --procedure Write_Memory (Error : out Boolean); - - procedure Disp_Stats; - procedure Finish; -private - type Byte_Array_Base is array (Pc_Type range <>) of Byte; - subtype Byte_Array is Byte_Array_Base (Pc_Type); - type Byte_Array_Acc is access Byte_Array; - type String_Acc is access String; - --type Section_Flags is new Unsigned_32; - - -- Relocations. - type Reloc_Kind is (Reloc_32, Reloc_Pc32, - Reloc_Ua_32, - Reloc_Disp22, Reloc_Disp30, - Reloc_Hi22, Reloc_Lo10, - Reloc_Ppc_Addr24); - type Reloc_Type; - type Reloc_Acc is access Reloc_Type; - type Reloc_Type is record - Kind : Reloc_Kind; - -- If true, the reloc was already applied. - Done : Boolean; - -- Next in simply linked list. - -- next reloc in the section. - Sect_Next : Reloc_Acc; - -- next reloc for the symbol. - Sym_Next : Reloc_Acc; - -- Address that must be relocated. - Addr : Pc_Type; - -- Symbol. - Sym : Symbol; - end record; - - type Section_Type is record - -- Simply linked list of sections. - Next : Section_Acc; - -- Flags. - Flags : Section_Flags; - -- Name of the section. - Name : String_Acc; - -- Link to another section (used by ELF). - Link : Section_Acc; - -- Alignment (in power of 2). - Align : Natural; - -- Entry size (if any). - Esize : Natural; - -- Offset of the next data in DATA. - Pc : Pc_Type; - -- Offset of the current instruction. - Insn_Pc : Pc_Type; - -- Data for this section. - Data : Byte_Array_Acc; - -- Max address for data (before extending the area). - Data_Max : Pc_Type; - -- Chain of relocs defined in this section. - First_Reloc : Reloc_Acc; - Last_Reloc : Reloc_Acc; - -- Number of relocs in this section. - Nbr_Relocs : Natural; - -- Section number (set and used by binary writer). - Number : Natural; - -- Virtual address, if set. - Vaddr : Pc_Type; -- SSE.Integer_Address; - -- Memory for this segment. - Seg : Memsegs.Memseg_Type; - end record; - - Section_Exec : constant Section_Flags := 2#0000_0001#; - Section_Read : constant Section_Flags := 2#0000_0010#; - Section_Write : constant Section_Flags := 2#0000_0100#; - Section_Zero : constant Section_Flags := 2#0000_1000#; - Section_Strtab : constant Section_Flags := 2#0001_0000#; - Section_Debug : constant Section_Flags := 2#0010_0000#; - Section_None : constant Section_Flags := 2#0000_0000#; - - -- Scope of a symbol: - -- SYM_PRIVATE: not visible outside of the file. - -- SYM_UNDEF: not (yet) defined, unresolved. - -- SYM_GLOBAL: visible to all files. - -- SYM_LOCAL: locally generated symbol. - type Symbol_Scope is (Sym_Undef, Sym_Global, Sym_Private, Sym_Local); - subtype Symbol_Scope_External is Symbol_Scope range Sym_Undef .. Sym_Global; - type Symbol_Type is record - Section : Section_Acc; - Value : Pc_Type; - Scope : Symbol_Scope; - -- True if the symbol is referenced/used. - Used : Boolean; - -- Name of the symbol. - Name : O_Ident; - -- List of relocation made with this symbol. - Relocs : Reloc_Acc; - -- Symbol number, from 0. - Number : Natural; - end record; - - -- Number of sections. - Nbr_Sections : Natural := 0; - -- Simply linked list of sections. - Section_Chain : Section_Acc := null; - Section_Last : Section_Acc := null; - - package Symbols is new GNAT.Table - (Table_Component_Type => Symbol_Type, - Table_Index_Type => Symbol, - Table_Low_Bound => 2, - Table_Initial => 1024, - Table_Increment => 100); - - function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type; - - function Get_Symbol_Name (Sym : Symbol) return String; - function Get_Symbol_Name_Length (Sym : Symbol) return Natural; - - procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type); - pragma Inline (Set_Symbol_Value); - - procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope); - pragma Inline (Set_Scope); - - function Get_Scope (Sym : Symbol) return Symbol_Scope; - pragma Inline (Get_Scope); - - function Get_Section (Sym : Symbol) return Section_Acc; - pragma Inline (Get_Section); - - procedure Set_Section (Sym : Symbol; Sect : Section_Acc); - pragma Inline (Set_Section); - - function Get_Name (Sym : Symbol) return O_Ident; - pragma Inline (Get_Name); - - procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc); - pragma Inline (Apply_Reloc); - - procedure Set_Number (Sym : Symbol; Num : Natural); - pragma Inline (Set_Number); - - function Get_Number (Sym : Symbol) return Natural; - pragma Inline (Get_Number); - - function Get_Used (Sym : Symbol) return Boolean; - pragma Inline (Get_Used); - - procedure Do_Intra_Section_Reloc (Sect : Section_Acc); - - function S_Local (Sym : Symbol) return Boolean; - pragma Inline (S_Local); - - procedure Resize (Sect : Section_Acc; Size : Pc_Type); - - procedure Free is new Ada.Unchecked_Deallocation - (Name => Reloc_Acc, Object => Reloc_Type); - - Write_Error : exception; -end Binary_File; diff --git a/ortho/mcode/coff.ads b/ortho/mcode/coff.ads deleted file mode 100644 index 6ef9cdde9..000000000 --- a/ortho/mcode/coff.ads +++ /dev/null @@ -1,208 +0,0 @@ --- COFF definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with System; use System; - -package Coff is - type Filehdr is record - F_Magic : Unsigned_16; -- Magic number. - F_Nscns : Unsigned_16; -- Number of sections. - F_Timdat : Unsigned_32; -- Time and date stamp. - F_Symptr : Unsigned_32; -- File pointer to symtab. - F_Nsyms : Unsigned_32; -- Number of symtab entries. - F_Opthdr : Unsigned_16; -- Size of optionnal header. - F_Flags : Unsigned_16; -- Flags; - end record; - - -- Size of Filehdr. - Filehdr_Size : constant Natural := Filehdr'Size / Storage_Unit; - - -- Magic numbers. - I386magic : constant Unsigned_16 := 16#014c#; - - -- Flags of file header. - -- Relocation info stripped from file. - F_Relflg : constant Unsigned_16 := 16#0001#; - - -- File is executable (no unresolved symbols). - F_Exec : constant Unsigned_16 := 16#0002#; - - -- Line numbers stripped from file. - F_Lnno : constant Unsigned_16 := 16#0004#; - - -- Local symbols stripped from file. - F_Lsyms : constant Unsigned_16 := 16#0008#; - - type Scnhdr is record - S_Name : String (1 .. 8); -- Section name. - S_Paddr : Unsigned_32; -- Physical address. - S_Vaddr : Unsigned_32; -- Virtual address. - S_Size : Unsigned_32; -- Section size. - S_Scnptr : Unsigned_32; -- File pointer to raw section data. - S_Relptr : Unsigned_32; -- File pointer to relocation data. - S_Lnnoptr : Unsigned_32; -- File pointer to line number data. - S_Nreloc : Unsigned_16; -- Number of relocation entries. - S_Nlnno : Unsigned_16; -- Number of line number entries. - S_Flags : Unsigned_32; -- Flags. - end record; - Scnhdr_Size : constant Natural := Scnhdr'Size / Storage_Unit; - - -- section contains text only. - STYP_TEXT : constant Unsigned_32 := 16#0020#; - -- section contains data only. - STYP_DATA : constant Unsigned_32 := 16#0040#; - -- section contains bss only. - STYP_BSS : constant Unsigned_32 := 16#0080#; - - type Strent_Type is record - E_Zeroes : Unsigned_32; - E_Offset : Unsigned_32; - end record; - - type Sym_Name (Inline : Boolean := True) is record - case Inline is - when True => - E_Name : String (1 .. 8); - when False => - E : Strent_Type; - end case; - end record; - pragma Unchecked_Union (Sym_Name); - for Sym_Name'Size use 64; - - type Syment is record - E : Sym_Name; -- Name of the symbol - E_Value : Unsigned_32; -- Value - E_Scnum : Unsigned_16; -- Section - E_Type : Unsigned_16; - E_Sclass : Unsigned_8; - E_Numaux : Unsigned_8; - end record; - Symesz : constant Natural := 18; - for Syment'Size use Symesz * Storage_Unit; - - -- An undefined (extern) symbol. - N_UNDEF : constant Unsigned_16 := 16#00_00#; - -- An absolute symbol (e_value is a constant, not an address). - N_ABS : constant Unsigned_16 := 16#Ff_Ff#; - -- A debugging symbol. - N_DEBUG : constant Unsigned_16 := 16#Ff_Fe#; - - C_NULL : constant Unsigned_8 := 0; - C_AUTO : constant Unsigned_8 := 1; - C_EXT : constant Unsigned_8 := 2; - C_STAT : constant Unsigned_8 := 3; - C_REG : constant Unsigned_8 := 4; - C_EXTDEF : constant Unsigned_8 := 5; - C_LABEL : constant Unsigned_8 := 6; - C_ULABEL : constant Unsigned_8 := 7; - C_MOS : constant Unsigned_8 := 8; - C_ARG : constant Unsigned_8 := 9; - C_STRTAG : constant Unsigned_8 := 10; - C_MOU : constant Unsigned_8 := 11; - C_UNTAG : constant Unsigned_8 := 12; - C_TPDEF : constant Unsigned_8 := 13; - C_USTATIC : constant Unsigned_8 := 14; - C_ENTAG : constant Unsigned_8 := 15; - C_MOE : constant Unsigned_8 := 16; - C_REGPARM : constant Unsigned_8 := 17; - C_FIELD : constant Unsigned_8 := 18; - C_AUTOARG : constant Unsigned_8 := 19; - C_LASTENT : constant Unsigned_8 := 20; - C_BLOCK : constant Unsigned_8 := 100; - C_FCN : constant Unsigned_8 := 101; - C_EOS : constant Unsigned_8 := 102; - C_FILE : constant Unsigned_8 := 103; - C_LINE : constant Unsigned_8 := 104; - C_ALIAS : constant Unsigned_8 := 105; - C_HIDDEN : constant Unsigned_8 := 106; - C_EFCN : constant Unsigned_8 := 255; - - -- Textual description of sclass. - type Const_String_Acc is access constant String; - type Sclass_Desc_Type is record - Name : Const_String_Acc; - Meaning : Const_String_Acc; - end record; - type Sclass_Desc_Array_Type is array (Unsigned_8) of Sclass_Desc_Type; - Sclass_Desc : constant Sclass_Desc_Array_Type; - - type Auxent_File (Inline : Boolean := True) is record - case Inline is - when True => - X_Fname : String (1 .. 14); - when False => - X_N : Strent_Type; - end case; - end record; - pragma Unchecked_Union (Auxent_File); - - type Auxent_Scn is record - X_Scnlen : Unsigned_32; - X_Nreloc : Unsigned_16; - X_Nlinno : Unsigned_16; - end record; - - -- Relocation. - type Reloc is record - R_Vaddr : Unsigned_32; - R_Symndx : Unsigned_32; - R_Type : Unsigned_16; - end record; - Relsz : constant Natural := Reloc'Size / Storage_Unit; - - Reloc_Rel32 : constant Unsigned_16 := 20; - Reloc_Addr32 : constant Unsigned_16 := 6; - -private - subtype S is String; - Sclass_Desc : constant Sclass_Desc_Array_Type := - (C_NULL => (new S'("C_NULL"), new S'("No entry")), - C_AUTO => (new S'("C_AUTO"), new S'("Automatic variable")), - C_EXT => (new S'("C_EXT"), new S'("External/public symbol")), - C_STAT => (new S'("C_STAT"), new S'("static (private) symbol")), - C_REG => (new S'("C_REG"), new S'("register variable")), - C_EXTDEF => (new S'("C_EXTDEF"), new S'("External definition")), - C_LABEL => (new S'("C_LABEL"), new S'("label")), - C_ULABEL => (new S'("C_ULABEL"), new S'("undefined label")), - C_MOS => (new S'("C_MOS"), new S'("member of structure")), - C_ARG => (new S'("C_ARG"), new S'("function argument")), - C_STRTAG => (new S'("C_STRTAG"), new S'("structure tag")), - C_MOU => (new S'("C_MOU"), new S'("member of union")), - C_UNTAG => (new S'("C_UNTAG"), new S'("union tag")), - C_TPDEF => (new S'("C_TPDEF"), new S'("type definition")), - C_USTATIC => (new S'("C_USTATIC"), new S'("undefined static")), - C_ENTAG => (new S'("C_ENTAG"), new S'("enumaration tag")), - C_MOE => (new S'("C_MOE"), new S'("member of enumeration")), - C_REGPARM => (new S'("C_REGPARM"), new S'("register parameter")), - C_FIELD => (new S'("C_FIELD"), new S'("bit field")), - C_AUTOARG => (new S'("C_AUTOARG"), new S'("auto argument")), - C_LASTENT => (new S'("C_LASTENT"), new S'("dummy entry (end of block)")), - C_BLOCK => (new S'("C_BLOCK"), new S'("beginning or end of block")), - C_FCN => (new S'("C_FCN"), new S'("beginning or end of function")), - C_EOS => (new S'("C_EOS"), new S'("end of structure")), - C_FILE => (new S'("C_FILE"), new S'("file name")), - C_LINE => (new S'("C_LINE"), - new S'("line number, reformatted as symbol")), - C_ALIAS => (new S'("C_ALIAS"), new S'("duplicate tag")), - C_HIDDEN => (new S'("C_HIDDEN"), - new S'("ext symbol in dmert public lib")), - C_EFCN => (new S'("C_EFCN"), new S'("physical end of function")), - others => (null, null)); - -end Coff; diff --git a/ortho/mcode/coffdump.adb b/ortho/mcode/coffdump.adb deleted file mode 100644 index 6384b6c27..000000000 --- a/ortho/mcode/coffdump.adb +++ /dev/null @@ -1,274 +0,0 @@ --- COFF dumper. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Coff; use Coff; -with Interfaces; use Interfaces; -with System; -with Ada.Unchecked_Conversion; -with Ada.Command_Line; use Ada.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ada.Text_IO; use Ada.Text_IO; -with Hex_Images; use Hex_Images; - -procedure Coffdump is - type Cstring is array (Unsigned_32 range <>) of Character; - type Cstring_Acc is access Cstring; - type Section_Array is array (Unsigned_16 range <>) of Scnhdr; - type Section_Array_Acc is access Section_Array; - -- Array of sections. - Sections : Section_Array_Acc; - - type External_Symbol is array (0 .. Symesz - 1) of Character; - type External_Symbol_Array is array (Unsigned_32 range <>) - of External_Symbol; - type Symbol_Array_Acc is access External_Symbol_Array; - -- Symbols table. - External_Symbols : Symbol_Array_Acc; - - -- String table. - Str : Cstring_Acc; - Str_Size : Natural; - - Hdr : Filehdr; - --Sym : Syment; - Fd : File_Descriptor; - Skip : Natural; - Skip_Kind : Unsigned_8; - Aux_File : Auxent_File; - Aux_Scn : Auxent_Scn; - Rel : Reloc; - Len : Natural; - - Nul : constant Character := Character'Val (0); - - function Find_Nul (S : String) return String is - begin - for I in S'Range loop - if S (I) = Nul then - return S (S'First .. I - 1); - end if; - end loop; - return S; - end Find_Nul; - - function Get_String (N : Strent_Type; S : String) return String - is - begin - if N.E_Zeroes /= 0 then - return Find_Nul (S); - else - for I in N.E_Offset .. Str'Last loop - if Str (I) = Nul then - return String (Str (N.E_Offset .. I - 1)); - end if; - end loop; - raise Program_Error; - end if; - end Get_String; - - procedure Memcpy - (Dst : System.Address; Src : System.Address; Size : Natural); - pragma Import (C, Memcpy); - - function Get_Section_Name (N : Unsigned_16) return String is - begin - if N = N_UNDEF then - return "UNDEF"; - elsif N = N_ABS then - return "ABS"; - elsif N = N_DEBUG then - return "DEBUG"; - elsif N > Hdr.F_Nscns then - return "???"; - else - return Find_Nul (Sections (N).S_Name); - end if; - end Get_Section_Name; - - function Get_Symbol (N : Unsigned_32) return Syment is - function Unchecked_Conv is new Ada.Unchecked_Conversion - (Source => External_Symbol, Target => Syment); - begin - if N > Hdr.F_Nsyms then - raise Constraint_Error; - end if; - return Unchecked_Conv (External_Symbols (N)); - end Get_Symbol; - - function Get_Symbol_Name (N : Unsigned_32) return String - is - S : Syment := Get_Symbol (N); - begin - return Get_String (S.E.E, S.E.E_Name); - end Get_Symbol_Name; -begin - for I in 1 .. Argument_Count loop - Fd := Open_Read (Argument (I), Binary); - if Fd = Invalid_FD then - Put_Line ("cannot open " & Argument (I)); - return; - end if; - -- Read file header. - if Read (Fd, Hdr'Address, Filehdr_Size) /= Filehdr_Size then - Put_Line ("cannot read header"); - return; - end if; - Put_Line ("File: " & Argument (I)); - Put_Line ("magic: " & Hex_Image (Hdr.F_Magic)); - Put_Line ("number of sections: " & Hex_Image (Hdr.F_Nscns)); - Put_Line ("time and date stamp: " & Hex_Image (Hdr.F_Timdat)); - Put_Line ("symtab file pointer: " & Hex_Image (Hdr.F_Symptr)); - Put_Line ("nbr symtab entries: " & Hex_Image (Hdr.F_Nsyms)); - Put_Line ("opt header size: " & Hex_Image (Hdr.F_Opthdr)); - Put_Line ("flags: " & Hex_Image (Hdr.F_Flags)); - - -- Read sections header. - Lseek (Fd, Long_Integer (Hdr.F_Opthdr), Seek_Cur); - Sections := new Section_Array (1 .. Hdr.F_Nscns); - Len := Scnhdr_Size * Natural (Hdr.F_Nscns); - if Read (Fd, Sections (1)'Address, Len) /= Len then - Put_Line ("cannot read section header"); - return; - end if; - for I in 1 .. Hdr.F_Nscns loop - declare - S: Scnhdr renames Sections (I); - begin - Put_Line ("Section " & Find_Nul (S.S_Name)); - Put_Line ("Physical address : " & Hex_Image (S.S_Paddr)); - Put_Line ("Virtual address : " & Hex_Image (S.S_Vaddr)); - Put_Line ("section size : " & Hex_Image (S.S_Size)); - Put_Line ("section pointer : " & Hex_Image (S.S_Scnptr)); - Put_Line ("relocation pointer : " & Hex_Image (S.S_Relptr)); - Put_Line ("line num pointer : " & Hex_Image (S.S_Lnnoptr)); - Put_Line ("Nbr reloc entries : " & Hex_Image (S.S_Nreloc)); - Put_Line ("Nbr line num entries : " & Hex_Image (S.S_Nlnno)); - Put_Line ("Flags : " & Hex_Image (S.S_Flags)); - end; - end loop; - - -- Read string table. - Lseek (Fd, - Long_Integer (Hdr.F_Symptr + Hdr.F_Nsyms * Unsigned_32 (Symesz)), - Seek_Set); - if Read (Fd, Str_Size'Address, 4) /= 4 then - Put_Line ("cannot read string table size"); - return; - end if; - Str := new Cstring (0 .. Unsigned_32 (Str_Size)); - if Read (Fd, Str (4)'Address, Str_Size - 4) /= Str_Size - 4 then - Put_Line ("cannot read string table"); - return; - end if; - - -- Read symbol table. - Lseek (Fd, Long_Integer (Hdr.F_Symptr), Seek_Set); - External_Symbols := new External_Symbol_Array (0 .. Hdr.F_Nsyms - 1); - Len := Natural (Hdr.F_Nsyms) * Symesz; - if Read (Fd, External_Symbols (0)'Address, Len) /= Len then - Put_Line ("cannot read symbol"); - return; - end if; - - Skip := 0; - Skip_Kind := C_NULL; - for I in External_Symbols'range loop - if Skip > 0 then - case Skip_Kind is - when C_FILE => - Memcpy (Aux_File'Address, External_Symbols (I)'Address, - Aux_File'Size / 8); - Put_Line ("aux file : " & Get_String (Aux_File.X_N, - Aux_File.X_Fname)); - Skip_Kind := C_NULL; - when C_STAT => - Memcpy (Aux_Scn'Address, External_Symbols (I)'Address, - Aux_Scn'Size / 8); - Put_Line ("section len: " & Hex_Image (Aux_Scn.X_Scnlen)); - Put_Line ("nbr reloc ent: " & Hex_Image (Aux_Scn.X_Nreloc)); - Put_Line ("nbr line num: " & Hex_Image (Aux_Scn.X_Nlinno)); - when others => - Put_Line ("skip"); - end case; - Skip := Skip - 1; - else - declare - S : Syment := Get_Symbol (I); - begin - Put_Line ("Symbol #" & Hex_Image (I)); - Put_Line ("symbol name : " & Get_Symbol_Name (I)); - Put_Line ("symbol value: " & Hex_Image (S.E_Value)); - Put_Line ("section num : " & Hex_Image (S.E_Scnum) - & " " & Get_Section_Name (S.E_Scnum)); - Put_Line ("type : " & Hex_Image (S.E_Type)); - Put ("sclass : " & Hex_Image (S.E_Sclass)); - if Sclass_Desc (S.E_Sclass).Name /= null then - Put (" ("); - Put (Sclass_Desc (S.E_Sclass).Name.all); - Put (" - "); - Put (Sclass_Desc (S.E_Sclass).Meaning.all); - Put (")"); - end if; - New_Line; - Put_Line ("numaux : " & Hex_Image (S.E_Numaux)); - if S.E_Numaux > 0 then - case S.E_Sclass is - when C_FILE => - Skip_Kind := C_FILE; - when C_STAT => - Skip_Kind := C_STAT; - when others => - Skip_Kind := C_NULL; - end case; - end if; - Skip := Natural (S.E_Numaux); - end; - end if; - end loop; - - -- Disp relocs. - for I in 1 .. Hdr.F_Nscns loop - if Sections (I).S_Nreloc > 0 then - -- Read relocations. - Put_Line ("Relocations for section " & Get_Section_Name (I)); - Lseek (Fd, Long_Integer (Sections (I).S_Relptr), Seek_Set); - for J in 1 .. Sections (I).S_Nreloc loop - if Read (Fd, Rel'Address, Relsz) /= Relsz then - Put_Line ("cannot read reloc"); - return; - end if; - Put_Line ("reloc virtual addr: " & Hex_Image (Rel.R_Vaddr)); - Put_Line ("symbol index : " & Hex_Image (Rel.R_Symndx) - & " " & Get_Symbol_Name (Rel.R_Symndx)); - Put ("type of relocation: " & Hex_Image (Rel.R_Type)); - case Rel.R_Type is - when Reloc_Rel32 => - Put (" RELOC_REL32"); - when Reloc_Addr32 => - Put (" RELOC_ADDR32"); - when others => - null; - end case; - New_Line; - end loop; - end if; - end loop; - - Close (Fd); - end loop; -end Coffdump; - diff --git a/ortho/mcode/disa_sparc.adb b/ortho/mcode/disa_sparc.adb deleted file mode 100644 index 8c9176ff8..000000000 --- a/ortho/mcode/disa_sparc.adb +++ /dev/null @@ -1,274 +0,0 @@ -with System; use System; -with Interfaces; use Interfaces; -with Ada.Unchecked_Conversion; -with Hex_Images; use Hex_Images; - -package body Disa_Sparc is - subtype Reg_Type is Unsigned_32 range 0 .. 31; - - type Hex_Map_Type is array (Unsigned_32 range 0 .. 15) of Character; - Hex_Digit : constant Hex_Map_Type := "0123456789abcdef"; - - type Cstring_Acc is access constant String; - type Cond_Map_Type is array (Unsigned_32 range 0 .. 15) of Cstring_Acc; - subtype S is String; - Bicc_Map : constant Cond_Map_Type := - (0 => new S'("n"), - 1 => new S'("e"), - 2 => new S'("le"), - 3 => new S'("l"), - 4 => new S'("leu"), - 5 => new S'("cs"), - 6 => new S'("neg"), - 7 => new S'("vs"), - 8 => new S'("a"), - 9 => new S'("ne"), - 10 => new S'("g"), - 11 => new S'("ge"), - 12 => new S'("gu"), - 13 => new S'("cc"), - 14 => new S'("pos"), - 15 => new S'("vc") - ); - - - type Format_Type is - ( - Format_Bad, - Format_Regimm, -- format 3, rd, rs1, rs2 or imm13 - Format_Rd, -- format 3, rd only. - Format_Copro, -- format 3, fpu or coprocessor - Format_Asi -- format 3, rd, rs1, asi and rs2. - ); - - type Insn_Desc_Type is record - Name : Cstring_Acc; - Format : Format_Type; - end record; - - type Insn_Desc_Array is array (Unsigned_32 range 0 .. 63) of Insn_Desc_Type; - Insn_Desc_10 : constant Insn_Desc_Array := - ( - 2#000_000# => (new S'("add"), Format_Regimm), - 2#000_001# => (new S'("and"), Format_Regimm), - 2#000_010# => (new S'("or"), Format_Regimm), - 2#000_011# => (new S'("xor"), Format_Regimm), - 2#000_100# => (new S'("sub"), Format_Regimm), - 2#000_101# => (new S'("andn"), Format_Regimm), - 2#000_110# => (new S'("orn"), Format_Regimm), - 2#000_111# => (new S'("xnor"), Format_Regimm), - 2#001_000# => (new S'("addx"), Format_Regimm), - - 2#001_100# => (new S'("subx"), Format_Regimm), - - 2#010_000# => (new S'("addcc"), Format_Regimm), - 2#010_001# => (new S'("andcc"), Format_Regimm), - 2#010_010# => (new S'("orcc"), Format_Regimm), - 2#010_011# => (new S'("xorcc"), Format_Regimm), - 2#010_100# => (new S'("subcc"), Format_Regimm), - 2#010_101# => (new S'("andncc"), Format_Regimm), - 2#010_110# => (new S'("orncc"), Format_Regimm), - 2#010_111# => (new S'("xnorcc"), Format_Regimm), - 2#011_000# => (new S'("addxcc"), Format_Regimm), - - 2#011_100# => (new S'("subxcc"), Format_Regimm), - - 2#111_000# => (new S'("jmpl"), Format_Regimm), - - 2#111_100# => (new S'("save"), Format_Regimm), - 2#111_101# => (new S'("restore"), Format_Regimm), - - others => (null, Format_Bad) - ); - - Insn_Desc_11 : constant Insn_Desc_Array := - ( - 2#000_000# => (new S'("ld"), Format_Regimm), - 2#000_001# => (new S'("ldub"), Format_Regimm), - 2#000_010# => (new S'("lduh"), Format_Regimm), - 2#000_011# => (new S'("ldd"), Format_Regimm), - 2#000_100# => (new S'("st"), Format_Regimm), - 2#000_101# => (new S'("stb"), Format_Regimm), - - 2#010_000# => (new S'("lda"), Format_Asi), - 2#010_011# => (new S'("ldda"), Format_Asi), - - 2#110_000# => (new S'("ldc"), Format_Regimm), - 2#110_001# => (new S'("ldcsr"), Format_Regimm), - - others => (null, Format_Bad) - ); - - -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. - procedure Disassemble_Insn (Addr : Address; - Line : in out String; - Line_Len : out Natural; - Insn_Len : out Natural; - Proc_Cb : Symbol_Proc_Type) - is - type Unsigned_32_Acc is access Unsigned_32; - function To_Unsigned_32_Acc is new Ada.Unchecked_Conversion - (Source => Address, Target => Unsigned_32_Acc); - - W : Unsigned_32; - Lo : Natural; - - -- Add CHAR to the line. - procedure Add_Char (C : Character); - pragma Inline (Add_Char); - - procedure Add_Char (C : Character) is - begin - Line (Lo) := C; - Lo := Lo + 1; - end Add_Char; - - -- Add STR to the line. - procedure Add_String (Str : String) is - begin - Line (Lo .. Lo + Str'Length - 1) := Str; - Lo := Lo + Str'Length; - end Add_String; - - -- Add BYTE to the line. --- procedure Add_Byte (V : Byte) is --- type My_Str is array (Natural range 0 .. 15) of Character; --- Hex_Digit : constant My_Str := "0123456789abcdef"; --- begin --- Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#))); --- Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#))); --- end Add_Byte; - - procedure Disp_Const (Mask : Unsigned_32) - is - L : Natural; - V : Unsigned_32; - begin - L := Lo; - Proc_Cb.all (Addr, Line (Lo .. Line'Last), Lo); - V := W and Mask; - - -- Extend sign. - if (W and ((Mask + 1) / 2)) /= 0 then - V := V or not Mask; - end if; - if L /= Lo then - if V = 0 then - return; - end if; - Add_String (" + "); - end if; - Add_String ("0x"); - Add_String (Hex_Image (V)); - end Disp_Const; - - procedure Add_Cond (Str : String) - is - begin - Add_String (Str); - Add_String (Bicc_Map (Shift_Right (W, 25) and 2#1111#).all); - if (W and 16#2000_0000#) /= 0 then - Add_String (",a"); - end if; - Add_Char (' '); - Disp_Const (16#3f_Ffff#); - end Add_Cond; - - - procedure Add_Ireg (R : Reg_Type) - is - begin - Add_Char ('%'); - if R <= 7 then - Add_Char ('g'); - elsif R <= 15 then - if R = 14 then - Add_String ("sp"); - return; - else - Add_Char ('o'); - end if; - elsif R <= 23 then - Add_Char ('l'); - else - if R = 30 then - Add_String ("fp"); - return; - else - Add_Char ('i'); - end if; - end if; - Add_Char (Hex_Digit (R and 7)); - end Add_Ireg; - - procedure Disp_Unknown is - begin - Add_String ("unknown "); - Add_String (Hex_Image (W)); - end Disp_Unknown; - - procedure Disp_Format3 (Map : Insn_Desc_Array) - is - Op2 : Unsigned_32 range 0 .. 63; - begin - Op2 := Shift_Right (W, 19) and 2#111_111#; - - case Map (Op2).Format is - when Format_Regimm => - Add_String (Map (Op2).Name.all); - Add_Char (' '); - Add_Ireg (Shift_Right (W, 25) and 31); - Add_Char (','); - Add_Ireg (Shift_Right (W, 14) and 31); - Add_Char (','); - if (W and 16#2000#) /= 0 then - Disp_Const (16#1fff#); - else - Add_Ireg (W and 31); - end if; - when others => - Add_String ("unknown3, op2="); - Add_String (Hex_Image (Op2)); - end case; - end Disp_Format3; - - - begin - W := To_Unsigned_32_Acc (Addr).all; - Insn_Len := 4; - Lo := Line'First; - - case Shift_Right (W, 30) is - when 2#00# => - -- BIcc, SETHI - case Shift_Right (W, 22) and 2#111# is - when 2#000# => - Add_String ("unimp "); - Disp_Const (16#3f_Ffff#); - when 2#010# => - Add_Cond ("b"); - when 2#100# => - Add_String ("sethi "); - Add_Ireg (Shift_Right (W, 25)); - Add_String (", "); - Disp_Const (16#3f_Ffff#); - when others => - Disp_Unknown; - end case; - when 2#01# => - -- Call - Add_String ("call "); - Disp_Const (16#3fff_Ffff#); - when 2#10# => - Disp_Format3 (Insn_Desc_10); - when 2#11# => - Disp_Format3 (Insn_Desc_11); - when others => - -- Misc. - Disp_Unknown; - end case; - - Line_Len := Lo - Line'First; - end Disassemble_Insn; - -end Disa_Sparc; diff --git a/ortho/mcode/disa_sparc.ads b/ortho/mcode/disa_sparc.ads deleted file mode 100644 index 486dff977..000000000 --- a/ortho/mcode/disa_sparc.ads +++ /dev/null @@ -1,15 +0,0 @@ -with System; - -package Disa_Sparc is - -- Call-back used to find a relocation symbol. - type Symbol_Proc_Type is access procedure (Addr : System.Address; - Line : in out String; - Line_Len : in out Natural); - - -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. - procedure Disassemble_Insn (Addr : System.Address; - Line : in out String; - Line_Len : out Natural; - Insn_Len : out Natural; - Proc_Cb : Symbol_Proc_Type); -end Disa_Sparc; diff --git a/ortho/mcode/disa_x86.adb b/ortho/mcode/disa_x86.adb deleted file mode 100644 index 1d2d48565..000000000 --- a/ortho/mcode/disa_x86.adb +++ /dev/null @@ -1,997 +0,0 @@ --- X86 disassembler. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System.Address_To_Access_Conversions; - -package body Disa_X86 is - type Byte is new Interfaces.Unsigned_8; - type Bf_2 is mod 2 ** 2; - type Bf_3 is mod 2 ** 3; - type Byte_Vector is array (Natural) of Byte; - package Bv_Addr2acc is new System.Address_To_Access_Conversions - (Object => Byte_Vector); - use Bv_Addr2acc; - - type Cstring_Acc is access constant String; - type Index_Type is - ( - N_None, - N_Push, - N_Pop, - N_Ret, - N_Mov, - N_Add, - N_Or, - N_Adc, - N_Sbb, - N_And, - N_Sub, - N_Xor, - N_Cmp, - N_Into, - N_Jmp, - N_Jcc, - N_Setcc, - N_Call, - N_Int, - N_Cdq, - N_Imul, - N_Mul, - N_Leave, - N_Test, - N_Lea, - N_O, - N_No, - N_B, - N_AE, - N_E, - N_Ne, - N_Be, - N_A, - N_S, - N_Ns, - N_P, - N_Np, - N_L, - N_Ge, - N_Le, - N_G, - N_Not, - N_Neg, - N_Cbw, - N_Div, - N_Idiv, - N_Movsx, - N_Movzx, - N_Nop, - N_Hlt, - N_Inc, - N_Dec, - N_Rol, - N_Ror, - N_Rcl, - N_Rcr, - N_Shl, - N_Shr, - N_Sar, - N_Fadd, - N_Fmul, - N_Fcom, - N_Fcomp, - N_Fsub, - N_Fsubr, - N_Fdiv, - N_Fdivr, - - G_1, - G_2, - G_3, - G_5 - ); - - type Names_Type is array (Index_Type range <>) of Cstring_Acc; - subtype S is String; - Names : constant Names_Type := - (N_None => new S'("none"), - N_Push => new S'("push"), - N_Pop => new S'("pop"), - N_Ret => new S'("ret"), - N_Mov => new S'("mov"), - N_Add => new S'("add"), - N_Or => new S'("or"), - N_Adc => new S'("adc"), - N_Sbb => new S'("sbb"), - N_And => new S'("and"), - N_Sub => new S'("sub"), - N_Xor => new S'("xor"), - N_Cmp => new S'("cmp"), - N_Into => new S'("into"), - N_Jmp => new S'("jmp"), - N_Jcc => new S'("j"), - N_Int => new S'("int"), - N_Cdq => new S'("cdq"), - N_Call => new S'("call"), - N_Imul => new S'("imul"), - N_Mul => new S'("mul"), - N_Leave => new S'("leave"), - N_Test => new S'("test"), - N_Setcc => new S'("set"), - N_Lea => new S'("lea"), - N_O => new S'("o"), - N_No => new S'("no"), - N_B => new S'("b"), - N_AE => new S'("ae"), - N_E => new S'("e"), - N_Ne => new S'("ne"), - N_Be => new S'("be"), - N_A => new S'("a"), - N_S => new S'("s"), - N_Ns => new S'("ns"), - N_P => new S'("p"), - N_Np => new S'("np"), - N_L => new S'("l"), - N_Ge => new S'("ge"), - N_Le => new S'("le"), - N_G => new S'("g"), - N_Not => new S'("not"), - N_Neg => new S'("neg"), - N_Cbw => new S'("cbw"), - N_Div => new S'("div"), - N_Idiv => new S'("idiv"), - N_Movsx => new S'("movsx"), - N_Movzx => new S'("movzx"), - N_Nop => new S'("nop"), - N_Hlt => new S'("hlt"), - N_Inc => new S'("inc"), - N_Dec => new S'("dec"), - N_Rol => new S'("rol"), - N_Ror => new S'("ror"), - N_Rcl => new S'("rcl"), - N_Rcr => new S'("rcr"), - N_Shl => new S'("shl"), - N_Shr => new S'("shr"), - N_Sar => new S'("sar"), - N_Fadd => new S'("fadd"), - N_Fmul => new S'("fmul"), - N_Fcom => new S'("fcom"), - N_Fcomp => new S'("fcomp"), - N_Fsub => new S'("fsub"), - N_Fsubr => new S'("fsubr"), - N_Fdiv => new S'("fdiv"), - N_Fdivr => new S'("fdivr") - ); - - - - -- Format of an instruction. - -- MODRM_SRC_8 : modrm byte follow, and modrm is source, witdh = 8bits - -- MODRM_DST_8 : modrm byte follow, and modrm is dest, width = 8 bits. - -- MODRM_SRC_W : modrm byte follow, and modrm is source, width = 16/32 bits - -- MODRM_DST_W : modrm byte follow, and modrm is dest, width =16/32 bits. - -- MODRM_IMM_W : modrm byte follow, with an opcode in the reg field, - -- followed by an immediat, width = 16/32 bits. - -- MODRM_IMM_8 : modrm byte follow, with an opcode in the reg field, - -- followed by an immediat, width = 8 bits. - -- IMM : the opcode is followed by an immediate value. - -- PREFIX : the opcode is a prefix (1 byte). - -- OPCODE : inherent addressing. - -- OPCODE2 : a second byte specify the instruction. - -- REG_IMP : register is in the 3 LSB of the opcode. - -- REG_IMM_W : register is in the 3 LSB of the opcode, followed by an - -- immediat, width = 16/32 bits. - -- DISP_W : a wide displacement (16/32 bits). - -- DISP_8 : short displacement (8 bits). - -- INVALID : bad opcode. - type Format_Type is (Modrm_Src, Modrm_Dst, - Modrm_Imm, Modrm_Imm_S, - Modrm, - Modrm_Ax, - Modrm_Imm8, - Imm, Imm_S, Imm_8, - Eax_Imm, - Prefix, Opcode, Opcode2, Reg_Imp, - Reg_Imm, - Imp, - Disp_W, Disp_8, - Cond_Disp_W, Cond_Disp_8, - Cond_Modrm, - Ax_Off_Src, Ax_Off_Dst, - Invalid); - - type Width_Type is (W_None, W_8, W_16, W_32, W_Data); - - -- Description for one instruction. - type Insn_Desc_Type is record - -- Name of the operation. - Name : Index_Type; - - -- Width of the instruction. - -- This is used to add a suffix (b,w,l) to the instruction. - -- This may also be the size of a data. - Width : Width_Type; - - -- Format of the instruction. - Format : Format_Type; - end record; - - Desc_Invalid : constant Insn_Desc_Type := (N_None, W_None, Invalid); - - type Insn_Desc_Array_Type is array (Byte) of Insn_Desc_Type; - type Group_Desc_Array_Type is array (Bf_3) of Insn_Desc_Type; - Insn_Desc : constant Insn_Desc_Array_Type := - ( - 2#00_000_000# => (N_Add, W_8, Modrm_Dst), - 2#00_000_001# => (N_Add, W_Data, Modrm_Dst), - 2#00_000_010# => (N_Add, W_8, Modrm_Src), - 2#00_000_011# => (N_Add, W_Data, Modrm_Src), - - 2#00_001_000# => (N_Or, W_8, Modrm_Dst), - 2#00_001_001# => (N_Or, W_Data, Modrm_Dst), - 2#00_001_010# => (N_Or, W_8, Modrm_Src), - 2#00_001_011# => (N_Or, W_Data, Modrm_Src), - - 2#00_011_000# => (N_Sbb, W_8, Modrm_Dst), - 2#00_011_001# => (N_Sbb, W_Data, Modrm_Dst), - 2#00_011_010# => (N_Sbb, W_8, Modrm_Src), - 2#00_011_011# => (N_Sbb, W_Data, Modrm_Src), - - 2#00_100_000# => (N_And, W_8, Modrm_Dst), - 2#00_100_001# => (N_And, W_Data, Modrm_Dst), - 2#00_100_010# => (N_And, W_8, Modrm_Src), - 2#00_100_011# => (N_And, W_Data, Modrm_Src), - - 2#00_101_000# => (N_Sub, W_8, Modrm_Dst), - 2#00_101_001# => (N_Sub, W_Data, Modrm_Dst), - 2#00_101_010# => (N_Sub, W_8, Modrm_Src), - 2#00_101_011# => (N_Sub, W_Data, Modrm_Src), - - 2#00_110_000# => (N_Xor, W_8, Modrm_Dst), - 2#00_110_001# => (N_Xor, W_Data, Modrm_Dst), - 2#00_110_010# => (N_Xor, W_8, Modrm_Src), - 2#00_110_011# => (N_Xor, W_Data, Modrm_Src), - - 2#00_111_000# => (N_Cmp, W_8, Modrm_Dst), - 2#00_111_001# => (N_Cmp, W_Data, Modrm_Dst), - 2#00_111_010# => (N_Cmp, W_8, Modrm_Src), - 2#00_111_011# => (N_Cmp, W_Data, Modrm_Src), - - 2#00_111_100# => (N_Cmp, W_8, Eax_Imm), - 2#00_111_101# => (N_Cmp, W_Data, Eax_Imm), - - 2#0101_0_000# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_001# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_010# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_011# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_100# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_101# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_110# => (N_Push, W_Data, Reg_Imp), - 2#0101_0_111# => (N_Push, W_Data, Reg_Imp), - - 2#0101_1_000# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_001# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_010# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_011# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_100# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_101# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_110# => (N_Pop, W_Data, Reg_Imp), - 2#0101_1_111# => (N_Pop, W_Data, Reg_Imp), - - 2#0110_1000# => (N_Push, W_Data, Imm), - 2#0110_1010# => (N_Push, W_Data, Imm_S), - - 2#0111_0000# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0001# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0010# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0011# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0100# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0101# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0110# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_0111# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1000# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1001# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1010# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1011# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1100# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1101# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1110# => (N_Jcc, W_None, Cond_Disp_8), - 2#0111_1111# => (N_Jcc, W_None, Cond_Disp_8), - - 2#1000_0000# => (G_1, W_8, Modrm_Imm), - 2#1000_0001# => (G_1, W_Data, Modrm_Imm), - 2#1000_0011# => (G_1, W_Data, Modrm_Imm_S), - - 2#1000_0101# => (N_Test, W_Data, Modrm_Src), - 2#1000_1101# => (N_Lea, W_Data, Modrm_Src), - - 2#1000_1010# => (N_Mov, W_8, Modrm_Src), - 2#1000_1011# => (N_Mov, W_Data, Modrm_Src), - 2#1000_1000# => (N_Mov, W_8, Modrm_Dst), - 2#1000_1001# => (N_Mov, W_Data, Modrm_Dst), - - 2#1001_0000# => (N_Nop, W_None, Opcode), - 2#1001_1001# => (N_Cdq, W_Data, Imp), - - 2#1010_0000# => (N_Mov, W_8, Ax_Off_Src), - 2#1010_0001# => (N_Mov, W_Data, Ax_Off_Src), - 2#1010_0010# => (N_Mov, W_8, Ax_Off_Dst), - 2#1010_0011# => (N_Mov, W_Data, Ax_Off_Dst), - - 2#1011_0000# => (N_Mov, W_8, Reg_Imm), - - 2#1011_1000# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1001# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1010# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1011# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1100# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1101# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1110# => (N_Mov, W_Data, Reg_Imm), - 2#1011_1111# => (N_Mov, W_Data, Reg_Imm), - - 2#1100_0000# => (G_2, W_8, Modrm_Imm8), - 2#1100_0001# => (G_2, W_Data, Modrm_Imm8), - - 2#1100_0011# => (N_Ret, W_None, Opcode), - 2#1100_0110# => (N_Mov, W_8, Modrm_Imm), - 2#1100_0111# => (N_Mov, W_Data, Modrm_Imm), - 2#1100_1001# => (N_Leave, W_None, Opcode), - 2#1100_1101# => (N_Int, W_None, Imm_8), - 2#1100_1110# => (N_Into, W_None, Opcode), - - 2#1110_1000# => (N_Call, W_None, Disp_W), - 2#1110_1001# => (N_Jmp, W_None, Disp_W), - 2#1110_1011# => (N_Jmp, W_None, Disp_8), - - 2#1111_0100# => (N_Hlt, W_None, Opcode), - - 2#1111_0110# => (G_3, W_None, Invalid), - 2#1111_0111# => (G_3, W_None, Invalid), - - 2#1111_1111# => (G_5, W_None, Invalid), - --2#1111_1111# => (N_Push, W_Data, Modrm), - others => (N_None, W_None, Invalid)); - - Insn_Desc_0F : constant Insn_Desc_Array_Type := - (2#1000_0000# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0001# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0010# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0011# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0100# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0101# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0110# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_0111# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1000# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1001# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1010# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1011# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1100# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1101# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1110# => (N_Jcc, W_None, Cond_Disp_W), - 2#1000_1111# => (N_Jcc, W_None, Cond_Disp_W), - - 2#1001_0000# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0001# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0010# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0011# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0100# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0101# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0110# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_0111# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1000# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1001# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1010# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1011# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1100# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1101# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1110# => (N_Setcc, W_8, Cond_Modrm), - 2#1001_1111# => (N_Setcc, W_8, Cond_Modrm), - - 2#1011_0110# => (N_Movzx, W_Data, Modrm_Dst), - 2#1011_1110# => (N_Movsx, W_Data, Modrm_Dst), - others => (N_None, W_None, Invalid)); - - -- 16#F7# - Insn_Desc_G3 : constant Group_Desc_Array_Type := - (2#000# => (N_Test, W_Data, Reg_Imm), - 2#010# => (N_Not, W_Data, Modrm_Dst), - 2#011# => (N_Neg, W_Data, Modrm_Dst), - 2#100# => (N_Mul, W_Data, Modrm_Ax), - 2#101# => (N_Imul, W_Data, Modrm_Ax), - 2#110# => (N_Div, W_Data, Modrm_Ax), - 2#111# => (N_Idiv, W_Data, Modrm_Ax), - others => (N_None, W_None, Invalid)); - - Insn_Desc_G5 : constant Group_Desc_Array_Type := - (2#000# => (N_Inc, W_Data, Modrm), - 2#001# => (N_Dec, W_Data, Modrm), - 2#010# => (N_Call, W_Data, Modrm), - --2#011# => (N_Call, W_Data, Modrm_Ax), - 2#100# => (N_Jmp, W_Data, Modrm), - --2#101# => (N_Jmp, W_Data, Modrm_Ax), - 2#110# => (N_Push, W_Data, Modrm_Ax), - others => (N_None, W_None, Invalid)); - - type Group_Name_Array_Type is array (Index_Type range G_1 .. G_2, Bf_3) - of Index_Type; - Group_Name : constant Group_Name_Array_Type := - ( - G_1 => (N_Add, N_Or, N_Adc, N_Sbb, N_And, N_Sub, N_Xor, N_Cmp), - G_2 => (N_Rol, N_Ror, N_Rcl, N_Rcr, N_Shl, N_Shr, N_None, N_Sar) - ); - - -- Standard widths of operations. - type Width_Array_Type is array (Width_Type) of Character; - Width_Char : constant Width_Array_Type := - (W_None => '-', W_8 => 'b', W_16 => 'w', W_32 => 'l', W_Data => '?'); - type Width_Len_Type is array (Width_Type) of Natural; - Width_Len : constant Width_Len_Type := - (W_None => 0, W_8 => 1, W_16 => 2, W_32 => 4, W_Data => 0); - - -- Registers. --- type Reg_Type is (Reg_Ax, Reg_Bx, Reg_Cx, Reg_Dx, --- Reg_Bp, Reg_Sp, Reg_Si, Reg_Di, --- Reg_Al, Reg_Ah, Reg_Bl, Reg_Bh, --- Reg_Cl, Reg_Ch, Reg_Dl, Reg_Dh); - - -- Bits extraction from byte functions. - -- For a byte, MSB (most significant bit) is bit 7 while - -- LSB (least significant bit) is bit 0. - - -- Extract bits 2, 1 and 0. - function Ext_210 (B : Byte) return Bf_3; - pragma Inline (Ext_210); - - -- Extract bits 5-3 of byte B. - function Ext_543 (B : Byte) return Bf_3; - pragma Inline (Ext_543); - - -- Extract bits 7-6 of byte B. - function Ext_76 (B : Byte) return Bf_2; - pragma Inline (Ext_76); - - function Ext_210 (B : Byte) return Bf_3 is - begin - return Bf_3 (B and 2#111#); - end Ext_210; - - function Ext_543 (B : Byte) return Bf_3 is - begin - return Bf_3 (Shift_Right (B, 3) and 2#111#); - end Ext_543; - - function Ext_76 (B : Byte) return Bf_2 is - begin - return Bf_2 (Shift_Right (B, 6) and 2#11#); - end Ext_76; - - function Ext_Modrm_Mod (B : Byte) return Bf_2 renames Ext_76; - function Ext_Modrm_Rm (B : Byte) return Bf_3 renames Ext_210; - function Ext_Modrm_Reg (B : Byte) return Bf_3 renames Ext_543; - function Ext_Sib_Base (B : Byte) return Bf_3 renames Ext_210; - function Ext_Sib_Index (B : Byte) return Bf_3 renames Ext_543; - function Ext_Sib_Scale (B : Byte) return Bf_2 renames Ext_76; - - procedure Disassemble_Insn (Addr : System.Address; - Pc : Unsigned_32; - Line : in out String; - Line_Len : out Natural; - Insn_Len : out Natural; - Proc_Cb : Symbol_Proc_Type) - is - -- Index in LINE of the next character to be written. - Lo : Natural; - - -- Default width. - W_Default : constant Width_Type := W_32; - - -- The instruction memory, 0 based. - Mem : Bv_Addr2acc.Object_Pointer; - - -- Add NAME to the line. - procedure Add_Name (Name : Index_Type); - pragma Inline (Add_Name); - - -- Add CHAR to the line. - procedure Add_Char (C : Character); - pragma Inline (Add_Char); - - -- Add STR to the line. - procedure Add_String (Str : String) is - begin - Line (Lo .. Lo + Str'Length - 1) := Str; - Lo := Lo + Str'Length; - end Add_String; - - -- Add BYTE to the line. - procedure Add_Byte (V : Byte) is - type My_Str is array (Natural range 0 .. 15) of Character; - Hex_Digit : constant My_Str := "0123456789abcdef"; - begin - Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#))); - Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#))); - end Add_Byte; - - procedure Add_Name (Name : Index_Type) is - begin - Add_String (Names (Name).all); - end Add_Name; - - procedure Add_Char (C : Character) is - begin - Line (Lo) := C; - Lo := Lo + 1; - end Add_Char; - - procedure Add_Comma is - begin - Add_String (", "); - end Add_Comma; - - procedure Name_Align (Orig : Natural) is - begin - Add_Char (' '); - while Lo - Orig < 8 loop - Add_Char (' '); - end loop; - end Name_Align; - - procedure Add_Opcode (Name : Index_Type; Width : Width_Type) - is - L : constant Natural := Lo; - begin - Add_Name (Name); - if False and Width /= W_None then - Add_Char (Width_Char (Width)); - end if; - Name_Align (L); - end Add_Opcode; - - procedure Add_Cond_Opcode (Name : Index_Type; B : Byte) - is - L : constant Natural := Lo; - begin - Add_Name (Name); - Add_Name (Index_Type'Val (Index_Type'Pos (N_O) - + Byte'Pos (B and 16#0f#))); - Name_Align (L); - end Add_Cond_Opcode; - - procedure Decode_Reg_Field (F : Bf_3; W : Width_Type) is - type Reg_Name2_Array is array (Bf_3) of String (1 .. 2); - type Reg_Name3_Array is array (Bf_3) of String (1 .. 3); - Regs_8 : constant Reg_Name2_Array := - ("al", "cl", "dl", "bl", "ah", "ch", "dh", "bh"); - Regs_16 : constant Reg_Name2_Array := - ("ax", "cx", "dx", "bx", "sp", "bp", "si", "di"); - Regs_32 : constant Reg_Name3_Array := - ("eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi"); - begin - Add_Char ('%'); - case W is - when W_8 => - Add_String (Regs_8 (F)); - when W_16 => - Add_String (Regs_16 (F)); - when W_32 => - Add_String (Regs_32 (F)); - when W_None - | W_Data => - raise Program_Error; - end case; - end Decode_Reg_Field; - - procedure Decode_Val (Off : Natural; Width : Width_Type) - is - begin - case Width is - when W_8 => - Add_Byte (Mem (Off)); - when W_16 => - Add_Byte (Mem (Off + 1)); - Add_Byte (Mem (Off)); - when W_32 => - Add_Byte (Mem (Off + 3)); - Add_Byte (Mem (Off + 2)); - Add_Byte (Mem (Off + 1)); - Add_Byte (Mem (Off + 0)); - when W_None - | W_Data => - raise Program_Error; - end case; - end Decode_Val; - - function Decode_Val (Off : Natural; Width : Width_Type) - return Unsigned_32 - is - V : Unsigned_32; - begin - case Width is - when W_8 => - V := Unsigned_32 (Mem (Off)); - -- Sign extension. - if V >= 16#80# then - V := 16#Ffff_Ff00# or V; - end if; - return V; - when W_16 => - return Shift_Left (Unsigned_32 (Mem (Off + 1)), 8) - or Unsigned_32 (Mem (Off)); - when W_32 => - return Shift_Left (Unsigned_32 (Mem (Off + 3)), 24) - or Shift_Left (Unsigned_32 (Mem (Off + 2)), 16) - or Shift_Left (Unsigned_32 (Mem (Off + 1)), 8) - or Shift_Left (Unsigned_32 (Mem (Off + 0)), 0); - when W_None - | W_Data => - raise Program_Error; - end case; - end Decode_Val; - - procedure Decode_Imm (Off : in out Natural; Width : Width_Type) - is - begin - Add_String ("$0x"); - Decode_Val (Off, Width); - Off := Off + Width_Len (Width); - end Decode_Imm; - - procedure Decode_Disp (Off : in out Natural; - Width : Width_Type; - Offset : Unsigned_32 := 0) - is - L : Natural; - V : Unsigned_32; - Off_Orig : constant Natural := Off; - begin - L := Lo; - V := Decode_Val (Off, Width) + Offset; - Off := Off + Width_Len (Width); - if Proc_Cb /= null then - Proc_Cb.all (Mem (Off)'Address, - Line (Lo .. Line'Last), Lo); - end if; - if L /= Lo then - if V = 0 then - return; - end if; - Add_String (" + "); - end if; - Add_String ("0x"); - if Offset = 0 then - Decode_Val (Off_Orig, Width); - else - Add_Byte (Byte (Shift_Right (V, 24) and 16#Ff#)); - Add_Byte (Byte (Shift_Right (V, 16) and 16#Ff#)); - Add_Byte (Byte (Shift_Right (V, 8) and 16#Ff#)); - Add_Byte (Byte (Shift_Right (V, 0) and 16#Ff#)); - end if; - end Decode_Disp; - - procedure Decode_Modrm_Reg (B : Byte; Width : Width_Type) is - begin - Decode_Reg_Field (Ext_Modrm_Reg (B), Width); - end Decode_Modrm_Reg; - - procedure Decode_Sib (Sib : Byte; B_Mod : Bf_2) - is - S : Bf_2; - I : Bf_3; - B : Bf_3; - begin - S := Ext_Sib_Scale (Sib); - B := Ext_Sib_Base (Sib); - I := Ext_Sib_Index (Sib); - Add_Char ('('); - if B = 2#101# and then B_Mod /= 0 then - Decode_Reg_Field (B, W_32); - Add_Char (','); - end if; - if I /= 2#100# then - Decode_Reg_Field (I, W_32); - case S is - when 2#00# => - null; - when 2#01# => - Add_String (",2"); - when 2#10# => - Add_String (",4"); - when 2#11# => - Add_String (",8"); - end case; - end if; - Add_Char (')'); - end Decode_Sib; - - procedure Decode_Modrm_Mem (Off : in out Natural; Width : Width_Type) - is - B : Byte; - B_Mod : Bf_2; - B_Rm : Bf_3; - Off_Orig : Natural; - begin - B := Mem (Off); - B_Mod := Ext_Modrm_Mod (B); - B_Rm := Ext_Modrm_Rm (B); - Off_Orig := Off; - case B_Mod is - when 2#11# => - Decode_Reg_Field (B_Rm, Width); - Off := Off + 1; - when 2#10# => - if B_Rm = 2#100# then - Off := Off + 2; - Decode_Disp (Off, W_32); - Decode_Sib (Mem (Off_Orig + 1), B_Mod); - else - Off := Off + 1; - Decode_Disp (Off, W_32); - Add_Char ('('); - Decode_Reg_Field (B_Rm, W_32); - Add_Char (')'); - end if; - when 2#01# => - if B_Rm = 2#100# then - Off := Off + 2; - Decode_Disp (Off, W_8); - Decode_Sib (Mem (Off_Orig + 1), B_Mod); - else - Off := Off + 1; - Decode_Disp (Off, W_8); - Add_Char ('('); - Decode_Reg_Field (B_Rm, W_32); - Add_Char (')'); - end if; - when 2#00# => - if B_Rm = 2#100# then - Off := Off + 2; - Decode_Sib (Mem (Off_Orig + 1), B_Mod); - elsif B_Rm = 2#101# then - Off := Off + 1; - Decode_Disp (Off, W_32); - else - Add_Char ('('); - Decode_Reg_Field (B_Rm, W_32); - Add_Char (')'); - Off := Off + 1; - end if; - end case; - end Decode_Modrm_Mem; - - -- Return the length of the modrm bytes. - -- At least 1 (mod/rm), at most 6 (mod/rm + SUB + disp32). - function Decode_Modrm_Len (Off : Natural) return Natural - is - B : Byte; - M_Mod : Bf_2; - M_Rm : Bf_3; - begin - B := Mem (Off); - M_Mod := Ext_Modrm_Mod (B); - M_Rm := Ext_Modrm_Rm (B); - case M_Mod is - when 2#11# => - return 1; - when 2#10# => - if M_Rm = 2#100# then - return 1 + 1 + 4; - else - return 1 + 4; - end if; - when 2#01# => - if M_Rm = 2#100# then - return 1 + 1 + 1; - else - return 1 + 1; - end if; - when 2#00# => - if M_Rm = 2#101# then - -- disp32. - return 1 + 4; - elsif M_Rm = 2#100# then - -- SIB - return 1 + 1; - else - return 1; - end if; - end case; - end Decode_Modrm_Len; - - - Off : Natural; - B : Byte; - B1 : Byte; - Desc : Insn_Desc_Type; - Name : Index_Type; - W : Width_Type; - begin - Mem := To_Pointer (Addr); - Off := 0; - Lo := Line'First; - - B := Mem (0); - if B = 2#0000_1111# then - B := Mem (1); - Off := 2; - Insn_Len := 2; - Desc := Insn_Desc_0F (B); - else - Off := 1; - Insn_Len := 1; - Desc := Insn_Desc (B); - end if; - - if Desc.Name >= G_1 then - B1 := Mem (Off); - case Desc.Name is - when G_1 - | G_2 => - Name := Group_Name (Desc.Name, Ext_543 (B1)); - when G_3 => - Desc := Insn_Desc_G3 (Ext_543 (B1)); - Name := Desc.Name; - when G_5 => - Desc := Insn_Desc_G5 (Ext_543 (B1)); - Name := Desc.Name; - when others => - Desc := Desc_Invalid; - end case; - else - Name := Desc.Name; - end if; - - case Desc.Width is - when W_Data => - W := W_Default; - when W_8 - | W_16 - | W_32 => - W := Desc.Width; - when W_None => - case Desc.Format is - when Disp_8 - | Cond_Disp_8 - | Imm_8 => - W := W_8; - when Disp_W - | Cond_Disp_W => - W := W_Default; - when Invalid - | Opcode => - W := W_None; - when others => - raise Program_Error; - end case; - end case; - - case Desc.Format is - when Reg_Imp => - Add_Opcode (Desc.Name, W_Default); - Decode_Reg_Field (Ext_210 (B), W_Default); - when Opcode => - Add_Opcode (Desc.Name, W_None); - when Modrm => - Add_Opcode (Desc.Name, W); - Decode_Modrm_Mem (Insn_Len, W); - when Modrm_Src => - Add_Opcode (Desc.Name, W); - -- Disp source first. - Decode_Modrm_Mem (Insn_Len, W); - Add_Comma; - B := Mem (Off); - Decode_Modrm_Reg (Mem (Off), W); - when Modrm_Dst => - Add_Opcode (Desc.Name, W); - -- Disp source first. - B := Mem (Off); - Decode_Modrm_Reg (B, W); - Add_Comma; - Decode_Modrm_Mem (Insn_Len, W); - when Modrm_Imm => - Add_Opcode (Name, W); - Insn_Len := Off + Decode_Modrm_Len (Off); - Decode_Imm (Insn_Len, W); - Add_Comma; - Decode_Modrm_Mem (Off, W); - when Modrm_Imm_S => - Add_Opcode (Name, W); - Insn_Len := Off + Decode_Modrm_Len (Off); - Decode_Imm (Insn_Len, W_8); - Add_Comma; - Decode_Modrm_Mem (Off, W); - when Modrm_Imm8 => - Add_Opcode (Name, W); - Decode_Modrm_Mem (Off, W); - Add_Comma; - Decode_Imm (Off, W_8); - - when Reg_Imm => - Add_Opcode (Desc.Name, W); - Decode_Imm (Insn_Len, W); - Add_Comma; - Decode_Reg_Field (Ext_210 (B), W); - when Eax_Imm => - Add_Opcode (Desc.Name, W); - Decode_Imm (Insn_Len, W); - Add_Comma; - Decode_Reg_Field (2#000#, W); - - when Disp_W - | Disp_8 => - Add_Opcode (Desc.Name, W_None); - Decode_Disp (Insn_Len, W, - Pc + Unsigned_32 (Insn_Len + Width_Len (W))); - - when Cond_Disp_8 - | Cond_Disp_W => - Add_Cond_Opcode (Desc.Name, B); - Decode_Disp (Insn_Len, W, - Pc + Unsigned_32 (Insn_Len + Width_Len (W))); - - when Cond_Modrm => - Add_Cond_Opcode (Desc.Name, B); - Decode_Modrm_Mem (Insn_Len, W); - - when Imm => - Add_Opcode (Desc.Name, W); - Decode_Imm (Insn_Len, W); - - when Imm_S - | Imm_8 => - Add_Opcode (Desc.Name, W); - Decode_Imm (Insn_Len, W_8); - - when Modrm_Ax => - if (B and 2#1#) = 2#0# then - W := W_8; - else - W := W_Default; - end if; - Add_Opcode (Desc.Name, W); - Decode_Reg_Field (0, W); - Add_Comma; - Decode_Modrm_Mem (Off, W); - - when Ax_Off_Src => - Add_Opcode (Desc.Name, W); - Decode_Disp (Insn_Len, W); - Add_Comma; - Decode_Reg_Field (0, W); - - when Ax_Off_Dst => - Add_Opcode (Desc.Name, W); - Decode_Reg_Field (0, W); - Add_Comma; - Decode_Disp (Insn_Len, W); - - when Imp => - Add_Opcode (Desc.Name, W_Default); - - when Invalid - | Prefix - | Opcode2 => - Add_String ("invalid "); - if Insn_Len = 2 then - Add_Byte (Mem (0)); - end if; - Add_Byte (B); - Insn_Len := 1; - end case; - - Line_Len := Lo - Line'First; - end Disassemble_Insn; -end Disa_X86; - - diff --git a/ortho/mcode/disa_x86.ads b/ortho/mcode/disa_x86.ads deleted file mode 100644 index c215cf0a3..000000000 --- a/ortho/mcode/disa_x86.ads +++ /dev/null @@ -1,34 +0,0 @@ --- X86 disassembler. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; - -package Disa_X86 is - -- Call-back used to find a relocation symbol. - type Symbol_Proc_Type is access procedure (Addr : System.Address; - Line : in out String; - Line_Len : in out Natural); - - -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. - procedure Disassemble_Insn (Addr : System.Address; - Pc : Unsigned_32; - Line : in out String; - Line_Len : out Natural; - Insn_Len : out Natural; - Proc_Cb : Symbol_Proc_Type); -end Disa_X86; diff --git a/ortho/mcode/disassemble.ads b/ortho/mcode/disassemble.ads deleted file mode 100644 index 5c9811fed..000000000 --- a/ortho/mcode/disassemble.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Disa_X86; - -package Disassemble renames Disa_X86; diff --git a/ortho/mcode/dwarf.ads b/ortho/mcode/dwarf.ads deleted file mode 100644 index 40ee94f10..000000000 --- a/ortho/mcode/dwarf.ads +++ /dev/null @@ -1,446 +0,0 @@ --- DWARF definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Dwarf is - DW_TAG_Array_Type : constant := 16#01#; - DW_TAG_Class_Type : constant := 16#02#; - DW_TAG_Entry_Point : constant := 16#03#; - DW_TAG_Enumeration_Type : constant := 16#04#; - DW_TAG_Formal_Parameter : constant := 16#05#; - DW_TAG_Imported_Declaration : constant := 16#08#; - DW_TAG_Label : constant := 16#0a#; - DW_TAG_Lexical_Block : constant := 16#0b#; - DW_TAG_Member : constant := 16#0d#; - DW_TAG_Pointer_Type : constant := 16#0f#; - DW_TAG_Reference_Type : constant := 16#10#; - DW_TAG_Compile_Unit : constant := 16#11#; - DW_TAG_String_Type : constant := 16#12#; - DW_TAG_Structure_Type : constant := 16#13#; - DW_TAG_Subroutine_Type : constant := 16#15#; - DW_TAG_Typedef : constant := 16#16#; - DW_TAG_Union_Type : constant := 16#17#; - DW_TAG_Unspecified_Parameters : constant := 16#18#; - DW_TAG_Variant : constant := 16#19#; - DW_TAG_Common_Block : constant := 16#1a#; - DW_TAG_Common_Inclusion : constant := 16#1b#; - DW_TAG_Inheritance : constant := 16#1c#; - DW_TAG_Inlined_Subroutine : constant := 16#1d#; - DW_TAG_Module : constant := 16#1e#; - DW_TAG_Ptr_To_Member_Type : constant := 16#1f#; - DW_TAG_Set_Type : constant := 16#20#; - DW_TAG_Subrange_Type : constant := 16#21#; - DW_TAG_With_Stmt : constant := 16#22#; - DW_TAG_Access_Declaration : constant := 16#23#; - DW_TAG_Base_Type : constant := 16#24#; - DW_TAG_Catch_Block : constant := 16#25#; - DW_TAG_Const_Type : constant := 16#26#; - DW_TAG_Constant : constant := 16#27#; - DW_TAG_Enumerator : constant := 16#28#; - DW_TAG_File_Type : constant := 16#29#; - DW_TAG_Friend : constant := 16#2a#; - DW_TAG_Namelist : constant := 16#2b#; - DW_TAG_Namelist_Item : constant := 16#2c#; - DW_TAG_Packed_Type : constant := 16#2d#; - DW_TAG_Subprogram : constant := 16#2e#; - DW_TAG_Template_Type_Parameter : constant := 16#2f#; - DW_TAG_Template_Value_Parameter : constant := 16#30#; - DW_TAG_Thrown_Type : constant := 16#31#; - DW_TAG_Try_Block : constant := 16#32#; - DW_TAG_Variant_Part : constant := 16#33#; - DW_TAG_Variable : constant := 16#34#; - DW_TAG_Volatile_Type : constant := 16#35#; - DW_TAG_Dwarf_Procedure : constant := 16#36#; - DW_TAG_Restrict_Type : constant := 16#37#; - DW_TAG_Interface_Type : constant := 16#38#; - DW_TAG_Namespace : constant := 16#39#; - DW_TAG_Imported_Module : constant := 16#3a#; - DW_TAG_Unspecified_Type : constant := 16#3b#; - DW_TAG_Partial_Unit : constant := 16#3c#; - DW_TAG_Imported_Unit : constant := 16#3d#; - DW_TAG_Mutable_Type : constant := 16#3e#; - DW_TAG_Lo_User : constant := 16#4080#; - DW_TAG_Hi_User : constant := 16#Ffff#; - - DW_CHILDREN_No : constant := 16#0#; - DW_CHILDREN_Yes : constant := 16#1#; - - DW_AT_Sibling : constant := 16#01#; -- reference - DW_AT_Location : constant := 16#02#; -- block, loclistptr - DW_AT_Name : constant := 16#03#; -- string - DW_AT_Ordering : constant := 16#09#; -- constant - DW_AT_Byte_Size : constant := 16#0b#; -- block, constant, ref - DW_AT_Bit_Offset : constant := 16#0c#; -- block, constant, ref - DW_AT_Bit_Size : constant := 16#0d#; -- block, constant, ref - DW_AT_Stmt_List : constant := 16#10#; -- lineptr - DW_AT_Low_Pc : constant := 16#11#; -- address - DW_AT_High_Pc : constant := 16#12#; -- address - DW_AT_Language : constant := 16#13#; -- constant - DW_AT_Discr : constant := 16#15#; -- reference - DW_AT_Discr_Value : constant := 16#16#; -- constant - DW_AT_Visibility : constant := 16#17#; -- constant - DW_AT_Import : constant := 16#18#; -- reference - DW_AT_String_Length : constant := 16#19#; -- block, loclistptr - DW_AT_Common_Reference : constant := 16#1a#; -- reference - DW_AT_Comp_Dir : constant := 16#1b#; -- string - DW_AT_Const_Value : constant := 16#1c#; -- block, constant, string - DW_AT_Containing_Type : constant := 16#1d#; -- reference - DW_AT_Default_Value : constant := 16#1e#; -- reference - DW_AT_Inline : constant := 16#20#; -- constant - DW_AT_Is_Optional : constant := 16#21#; -- flag - DW_AT_Lower_Bound : constant := 16#22#; -- block, constant, ref - DW_AT_Producer : constant := 16#25#; -- string - DW_AT_Prototyped : constant := 16#27#; -- flag - DW_AT_Return_Addr : constant := 16#2a#; -- block, loclistptr - DW_AT_Start_Scope : constant := 16#2c#; -- constant - DW_AT_Stride_Size : constant := 16#2e#; -- constant - DW_AT_Upper_Bound : constant := 16#2f#; -- block, constant, ref - DW_AT_Abstract_Origin : constant := 16#31#; -- reference - DW_AT_Accessibility : constant := 16#32#; -- constant - DW_AT_Address_Class : constant := 16#33#; -- constant - DW_AT_Artificial : constant := 16#34#; -- flag - DW_AT_Base_Types : constant := 16#35#; -- reference - DW_AT_Calling_Convention : constant := 16#36#; -- constant - DW_AT_Count : constant := 16#37#; -- block, constant, ref - DW_AT_Data_Member_Location : constant := 16#38#; -- block, const, loclistptr - DW_AT_Decl_Column : constant := 16#39#; -- constant - DW_AT_Decl_File : constant := 16#3a#; -- constant - DW_AT_Decl_Line : constant := 16#3b#; -- constant - DW_AT_Declaration : constant := 16#3c#; -- flag - DW_AT_Discr_List : constant := 16#3d#; -- block - DW_AT_Encoding : constant := 16#3e#; -- constant - DW_AT_External : constant := 16#3f#; -- flag - DW_AT_Frame_Base : constant := 16#40#; -- block, loclistptr - DW_AT_Friend : constant := 16#41#; -- reference - DW_AT_Identifier_Case : constant := 16#42#; -- constant - DW_AT_Macro_Info : constant := 16#43#; -- macptr - DW_AT_Namelist_Item : constant := 16#44#; -- block - DW_AT_Priority : constant := 16#45#; -- reference - DW_AT_Segment : constant := 16#46#; -- block, constant - DW_AT_Specification : constant := 16#47#; -- reference - DW_AT_Static_Link : constant := 16#48#; -- block, loclistptr - DW_AT_Type : constant := 16#49#; -- reference - DW_AT_Use_Location : constant := 16#4a#; -- block, loclistptr - DW_AT_Variable_Parameter : constant := 16#4b#; -- flag - DW_AT_Virtuality : constant := 16#4c#; -- constant - DW_AT_Vtable_Elem_Location : constant := 16#4d#; -- block, loclistptr - DW_AT_Allocated : constant := 16#4e#; -- block, constant, ref - DW_AT_Associated : constant := 16#4f#; -- block, constant, ref - DW_AT_Data_Location : constant := 16#50#; -- x50block - DW_AT_Stride : constant := 16#51#; -- block, constant, ref - DW_AT_Entry_Pc : constant := 16#52#; -- address - DW_AT_Use_UTF8 : constant := 16#53#; -- flag - DW_AT_Extension : constant := 16#04#; -- reference - DW_AT_Ranges : constant := 16#55#; -- rangelistptr - DW_AT_Trampoline : constant := 16#56#; -- address, flag, ref, str - DW_AT_Call_Column : constant := 16#57#; -- constant - DW_AT_Call_File : constant := 16#58#; -- constant - DW_AT_Call_Line : constant := 16#59#; -- constant - DW_AT_Description : constant := 16#5a#; -- string - DW_AT_Lo_User : constant := 16#2000#; -- --- - DW_AT_Hi_User : constant := 16#3fff#; -- --- - - DW_FORM_Addr : constant := 16#01#; -- address - DW_FORM_Block2 : constant := 16#03#; -- block - DW_FORM_Block4 : constant := 16#04#; -- block - DW_FORM_Data2 : constant := 16#05#; -- constant - DW_FORM_Data4 : constant := 16#06#; -- constant, lineptr, loclistptr... - DW_FORM_Data8 : constant := 16#07#; -- ... macptr, rangelistptr - DW_FORM_String : constant := 16#08#; -- string - DW_FORM_Block : constant := 16#09#; -- block - DW_FORM_Block1 : constant := 16#0a#; -- block - DW_FORM_Data1 : constant := 16#0b#; -- constant - DW_FORM_Flag : constant := 16#0c#; -- flag - DW_FORM_Sdata : constant := 16#0d#; -- constant - DW_FORM_Strp : constant := 16#0e#; -- string - DW_FORM_Udata : constant := 16#0f#; -- constant - DW_FORM_Ref_Addr : constant := 16#10#; -- reference - DW_FORM_Ref1 : constant := 16#11#; -- reference - DW_FORM_Ref2 : constant := 16#12#; -- reference - DW_FORM_Ref4 : constant := 16#13#; -- reference - DW_FORM_Ref8 : constant := 16#14#; -- reference - DW_FORM_Ref_Udata : constant := 16#15#; -- reference - DW_FORM_Indirect : constant := 16#16#; -- (see Section 7.5.3) - - - DW_OP_Addr : constant := 16#03#; -- 1 constant address (target spec) - DW_OP_Deref : constant := 16#06#; -- 0 - DW_OP_Const1u : constant := 16#08#; -- 1 1-byte constant - DW_OP_Const1s : constant := 16#09#; -- 1 1-byte constant - DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant - DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant - DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant - DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant - DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant - DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant - DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant - DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant - DW_OP_Dup : constant := 16#12#; -- 0 - DW_OP_Drop : constant := 16#13#; -- 0 - DW_OP_Over : constant := 16#14#; -- 0 - DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index - DW_OP_Swap : constant := 16#16#; -- 0 - DW_OP_Rot : constant := 16#17#; -- 0 - DW_OP_Xderef : constant := 16#18#; -- 0 - DW_OP_Abs : constant := 16#19#; -- 0 - DW_OP_And : constant := 16#1a#; -- 0 - DW_OP_Div : constant := 16#1b#; -- 0 - DW_OP_Minus : constant := 16#1c#; -- 0 - DW_OP_Mod : constant := 16#1d#; -- 0 - DW_OP_Mul : constant := 16#1e#; -- 0 - DW_OP_Neg : constant := 16#1f#; -- 0 - DW_OP_Not : constant := 16#20#; -- 0 - DW_OP_Or : constant := 16#21#; -- 0 - DW_OP_Plus : constant := 16#22#; -- 0 - DW_OP_Plus_Uconst : constant := 16#23#; -- 1 ULEB128 addend - DW_OP_Shl : constant := 16#24#; -- 0 - DW_OP_Shr : constant := 16#25#; -- 0 - DW_OP_Shra : constant := 16#26#; -- 0 - DW_OP_Xor : constant := 16#27#; -- 0 - DW_OP_Skip : constant := 16#2f#; -- 1 signed 2-byte constant - DW_OP_Bra : constant := 16#28#; -- 1 signed 2-byte constant - DW_OP_Eq : constant := 16#29#; -- 0 - DW_OP_Ge : constant := 16#2a#; -- 0 - DW_OP_Gt : constant := 16#2b#; -- 0 - DW_OP_Le : constant := 16#2c#; -- 0 - DW_OP_Lt : constant := 16#2d#; -- 0 - DW_OP_Ne : constant := 16#2e#; -- 0 - DW_OP_Lit0 : constant := 16#30#; -- 0 - DW_OP_Lit1 : constant := 16#31#; -- 0 - DW_OP_Lit2 : constant := 16#32#; -- 0 - DW_OP_Lit3 : constant := 16#33#; -- 0 - DW_OP_Lit4 : constant := 16#34#; -- 0 - DW_OP_Lit5 : constant := 16#35#; -- 0 - DW_OP_Lit6 : constant := 16#36#; -- 0 - DW_OP_Lit7 : constant := 16#37#; -- 0 - DW_OP_Lit8 : constant := 16#38#; -- 0 - DW_OP_Lit9 : constant := 16#39#; -- 0 - DW_OP_Lit10 : constant := 16#3a#; -- 0 - DW_OP_Lit11 : constant := 16#3b#; -- 0 - DW_OP_Lit12 : constant := 16#3c#; -- 0 - DW_OP_Lit13 : constant := 16#3d#; -- 0 - DW_OP_Lit14 : constant := 16#3e#; -- 0 - DW_OP_Lit15 : constant := 16#3f#; -- 0 - DW_OP_Lit16 : constant := 16#40#; -- 0 - DW_OP_Lit17 : constant := 16#41#; -- 0 - DW_OP_Lit18 : constant := 16#42#; -- 0 - DW_OP_Lit19 : constant := 16#43#; -- 0 - DW_OP_Lit20 : constant := 16#44#; -- 0 - DW_OP_Lit21 : constant := 16#45#; -- 0 - DW_OP_Lit22 : constant := 16#46#; -- 0 - DW_OP_Lit23 : constant := 16#47#; -- 0 - DW_OP_Lit24 : constant := 16#48#; -- 0 - DW_OP_Lit25 : constant := 16#49#; -- 0 - DW_OP_Lit26 : constant := 16#4a#; -- 0 - DW_OP_Lit27 : constant := 16#4b#; -- 0 - DW_OP_Lit28 : constant := 16#4c#; -- 0 - DW_OP_Lit29 : constant := 16#4d#; -- 0 - DW_OP_Lit30 : constant := 16#4e#; -- 0 - DW_OP_Lit31 : constant := 16#4f#; -- 0 - DW_OP_Reg0 : constant := 16#50#; -- 0 - DW_OP_Reg1 : constant := 16#51#; -- 0 - DW_OP_Reg2 : constant := 16#52#; -- 0 - DW_OP_Reg3 : constant := 16#53#; -- 0 - DW_OP_Reg4 : constant := 16#54#; -- 0 - DW_OP_Reg5 : constant := 16#55#; -- 0 - DW_OP_Reg6 : constant := 16#56#; -- 0 - DW_OP_Reg7 : constant := 16#57#; -- 0 - DW_OP_Reg8 : constant := 16#58#; -- 0 - DW_OP_Reg9 : constant := 16#59#; -- 0 - DW_OP_Reg10 : constant := 16#5a#; -- 0 - DW_OP_Reg11 : constant := 16#5b#; -- 0 - DW_OP_Reg12 : constant := 16#5c#; -- 0 - DW_OP_Reg13 : constant := 16#5d#; -- 0 - DW_OP_Reg14 : constant := 16#5e#; -- 0 - DW_OP_Reg15 : constant := 16#5f#; -- 0 - DW_OP_Reg16 : constant := 16#60#; -- 0 - DW_OP_Reg17 : constant := 16#61#; -- 0 - DW_OP_Reg18 : constant := 16#62#; -- 0 - DW_OP_Reg19 : constant := 16#63#; -- 0 - DW_OP_Reg20 : constant := 16#64#; -- 0 - DW_OP_Reg21 : constant := 16#65#; -- 0 - DW_OP_Reg22 : constant := 16#66#; -- 0 - DW_OP_Reg23 : constant := 16#67#; -- 0 - DW_OP_Reg24 : constant := 16#68#; -- 0 - DW_OP_Reg25 : constant := 16#69#; -- 0 - DW_OP_Reg26 : constant := 16#6a#; -- 0 - DW_OP_Reg27 : constant := 16#6b#; -- 0 - DW_OP_Reg28 : constant := 16#6c#; -- 0 - DW_OP_Reg29 : constant := 16#6d#; -- 0 - DW_OP_Reg30 : constant := 16#6e#; -- 0 - DW_OP_Reg31 : constant := 16#6f#; -- 0 reg 0..31 - DW_OP_Breg0 : constant := 16#70#; -- 1 SLEB128 offset base reg - DW_OP_Breg1 : constant := 16#71#; -- 1 SLEB128 offset base reg - DW_OP_Breg2 : constant := 16#72#; -- 1 SLEB128 offset base reg - DW_OP_Breg3 : constant := 16#73#; -- 1 SLEB128 offset base reg - DW_OP_Breg4 : constant := 16#74#; -- 1 SLEB128 offset base reg - DW_OP_Breg5 : constant := 16#75#; -- 1 SLEB128 offset base reg - DW_OP_Breg6 : constant := 16#76#; -- 1 SLEB128 offset base reg - DW_OP_Breg7 : constant := 16#77#; -- 1 SLEB128 offset base reg - DW_OP_Breg8 : constant := 16#78#; -- 1 SLEB128 offset base reg - DW_OP_Breg9 : constant := 16#79#; -- 1 SLEB128 offset base reg - DW_OP_Breg10 : constant := 16#7a#; -- 1 SLEB128 offset base reg - DW_OP_Breg11 : constant := 16#7b#; -- 1 SLEB128 offset base reg - DW_OP_Breg12 : constant := 16#7c#; -- 1 SLEB128 offset base reg - DW_OP_Breg13 : constant := 16#7d#; -- 1 SLEB128 offset base reg - DW_OP_Breg14 : constant := 16#7e#; -- 1 SLEB128 offset base reg - DW_OP_Breg15 : constant := 16#7f#; -- 1 SLEB128 offset base reg - DW_OP_Breg16 : constant := 16#80#; -- 1 SLEB128 offset base reg - DW_OP_Breg17 : constant := 16#81#; -- 1 SLEB128 offset base reg - DW_OP_Breg18 : constant := 16#82#; -- 1 SLEB128 offset base reg - DW_OP_Breg19 : constant := 16#83#; -- 1 SLEB128 offset base reg - DW_OP_Breg20 : constant := 16#84#; -- 1 SLEB128 offset base reg - DW_OP_Breg21 : constant := 16#85#; -- 1 SLEB128 offset base reg - DW_OP_Breg22 : constant := 16#86#; -- 1 SLEB128 offset base reg - DW_OP_Breg23 : constant := 16#87#; -- 1 SLEB128 offset base reg - DW_OP_Breg24 : constant := 16#88#; -- 1 SLEB128 offset base reg - DW_OP_Breg25 : constant := 16#89#; -- 1 SLEB128 offset base reg - DW_OP_Breg26 : constant := 16#8a#; -- 1 SLEB128 offset base reg - DW_OP_Breg27 : constant := 16#8b#; -- 1 SLEB128 offset base reg - DW_OP_Breg28 : constant := 16#8c#; -- 1 SLEB128 offset base reg - DW_OP_Breg29 : constant := 16#8d#; -- 1 SLEB128 offset base reg - DW_OP_Breg30 : constant := 16#8e#; -- 1 SLEB128 offset base reg - DW_OP_Breg31 : constant := 16#8f#; -- 1 SLEB128 offset base reg 0..31 - DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register - DW_OP_Fbreg : constant := 16#91#; -- 1 SLEB128 offset - DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset - DW_OP_Piece : constant := 16#93#; -- 1 ULEB128 size of piece addressed - DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved - DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved - DW_OP_Nop : constant := 16#96#; -- 0 - DW_OP_Push_Object_Address : constant := 16#97#; -- 0 - DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE - DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE - DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE - DW_OP_Lo_User : constant := 16#E0#; -- - DW_OP_Hi_User : constant := 16#ff#; -- - - DW_ATE_Address : constant := 16#1#; - DW_ATE_Boolean : constant := 16#2#; - DW_ATE_Complex_Float : constant := 16#3#; - DW_ATE_Float : constant := 16#4#; - DW_ATE_Signed : constant := 16#5#; - DW_ATE_Signed_Char : constant := 16#6#; - DW_ATE_Unsigned : constant := 16#7#; - DW_ATE_Unsigned_Char : constant := 16#8#; - DW_ATE_Imaginary_Float : constant := 16#9#; - DW_ATE_Lo_User : constant := 16#80#; - DW_ATE_Hi_User : constant := 16#ff#; - - DW_ACCESS_Public : constant := 1; - DW_ACCESS_Protected : constant := 2; - DW_ACCESS_Private : constant := 3; - - DW_LANG_C89 : constant := 16#0001#; - DW_LANG_C : constant := 16#0002#; - DW_LANG_Ada83 : constant := 16#0003#; - DW_LANG_C_Plus_Plus : constant := 16#0004#; - DW_LANG_Cobol74 : constant := 16#0005#; - DW_LANG_Cobol85 : constant := 16#0006#; - DW_LANG_Fortran77 : constant := 16#0007#; - DW_LANG_Fortran90 : constant := 16#0008#; - DW_LANG_Pascal83 : constant := 16#0009#; - DW_LANG_Modula2 : constant := 16#000a#; - DW_LANG_Java : constant := 16#000b#; - DW_LANG_C99 : constant := 16#000c#; - DW_LANG_Ada95 : constant := 16#000d#; - DW_LANG_Fortran95 : constant := 16#000e#; - DW_LANG_PLI : constant := 16#000f#; - DW_LANG_Lo_User : constant := 16#8000#; - DW_LANG_Hi_User : constant := 16#ffff#; - - DW_ID_Case_Sensitive : constant := 0; - DW_ID_Up_Case : constant := 1; - DW_ID_Down_Case : constant := 2; - DW_ID_Case_Insensitive : constant := 3; - - DW_CC_Normal : constant := 16#1#; - DW_CC_Program : constant := 16#2#; - DW_CC_Nocall : constant := 16#3#; - DW_CC_Lo_User : constant := 16#40#; - DW_CC_Hi_User : constant := 16#Ff#; - - DW_INL_Not_Inlined : constant := 0; - DW_INL_Inlined : constant := 1; - DW_INL_Declared_Not_Inlined : constant := 2; - DW_INL_Declared_Inlined : constant := 3; - - -- Line number information. - -- Line number standard opcode. - DW_LNS_Copy : constant Unsigned_8 := 1; - DW_LNS_Advance_Pc : constant Unsigned_8 := 2; - DW_LNS_Advance_Line : constant Unsigned_8 := 3; - DW_LNS_Set_File : constant Unsigned_8 := 4; - DW_LNS_Set_Column : constant Unsigned_8 := 5; - DW_LNS_Negate_Stmt : constant Unsigned_8 := 6; - DW_LNS_Set_Basic_Block : constant Unsigned_8 := 7; - DW_LNS_Const_Add_Pc : constant Unsigned_8 := 8; - DW_LNS_Fixed_Advance_Pc : constant Unsigned_8 := 9; - DW_LNS_Set_Prologue_End : constant Unsigned_8 := 10; - DW_LNS_Set_Epilogue_Begin : constant Unsigned_8 := 11; - DW_LNS_Set_Isa : constant Unsigned_8 := 12; - - -- Line number extended opcode. - DW_LNE_End_Sequence : constant Unsigned_8 := 1; - DW_LNE_Set_Address : constant Unsigned_8 := 2; - DW_LNE_Define_File : constant Unsigned_8 := 3; - DW_LNE_Lo_User : constant Unsigned_8 := 128; - DW_LNE_Hi_User : constant Unsigned_8 := 255; - - DW_CFA_Advance_Loc : constant Unsigned_8 := 16#40#; - DW_CFA_Advance_Loc_Min : constant Unsigned_8 := 16#40#; - DW_CFA_Advance_Loc_Max : constant Unsigned_8 := 16#7f#; - DW_CFA_Offset : constant Unsigned_8 := 16#80#; - DW_CFA_Offset_Min : constant Unsigned_8 := 16#80#; - DW_CFA_Offset_Max : constant Unsigned_8 := 16#Bf#; - DW_CFA_Restore : constant Unsigned_8 := 16#C0#; - DW_CFA_Restore_Min : constant Unsigned_8 := 16#C0#; - DW_CFA_Restore_Max : constant Unsigned_8 := 16#FF#; - DW_CFA_Nop : constant Unsigned_8 := 16#00#; - DW_CFA_Set_Loc : constant Unsigned_8 := 16#01#; - DW_CFA_Advance_Loc1 : constant Unsigned_8 := 16#02#; - DW_CFA_Advance_Loc2 : constant Unsigned_8 := 16#03#; - DW_CFA_Advance_Loc4 : constant Unsigned_8 := 16#04#; - DW_CFA_Offset_Extended : constant Unsigned_8 := 16#05#; - DW_CFA_Restore_Extended : constant Unsigned_8 := 16#06#; - DW_CFA_Undefined : constant Unsigned_8 := 16#07#; - DW_CFA_Same_Value : constant Unsigned_8 := 16#08#; - DW_CFA_Register : constant Unsigned_8 := 16#09#; - DW_CFA_Remember_State : constant Unsigned_8 := 16#0a#; - DW_CFA_Restore_State : constant Unsigned_8 := 16#0b#; - DW_CFA_Def_Cfa : constant Unsigned_8 := 16#0c#; - DW_CFA_Def_Cfa_Register : constant Unsigned_8 := 16#0d#; - DW_CFA_Def_Cfa_Offset : constant Unsigned_8 := 16#0e#; - DW_CFA_Def_Cfa_Expression : constant Unsigned_8 := 16#0f#; - - DW_EH_PE_Omit : constant Unsigned_8 := 16#Ff#; - DW_EH_PE_Uleb128 : constant Unsigned_8 := 16#01#; - DW_EH_PE_Udata2 : constant Unsigned_8 := 16#02#; - DW_EH_PE_Udata4 : constant Unsigned_8 := 16#03#; - DW_EH_PE_Udata8 : constant Unsigned_8 := 16#04#; - DW_EH_PE_Sleb128 : constant Unsigned_8 := 16#09#; - DW_EH_PE_Sdata2 : constant Unsigned_8 := 16#0A#; - DW_EH_PE_Sdata4 : constant Unsigned_8 := 16#0B#; - DW_EH_PE_Sdata8 : constant Unsigned_8 := 16#0C#; - DW_EH_PE_Absptr : constant Unsigned_8 := 16#00#; - DW_EH_PE_Pcrel : constant Unsigned_8 := 16#10#; - DW_EH_PE_Datarel : constant Unsigned_8 := 16#30#; - DW_EH_PE_Format_Mask : constant Unsigned_8 := 16#0f#; -end Dwarf; - - diff --git a/ortho/mcode/elf32.adb b/ortho/mcode/elf32.adb deleted file mode 100644 index ef58fe64b..000000000 --- a/ortho/mcode/elf32.adb +++ /dev/null @@ -1,48 +0,0 @@ --- ELF32 definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package body Elf32 is - function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar is - begin - return Shift_Right (Info, 4); - end Elf32_St_Bind; - - function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar is - begin - return Info and 16#0F#; - end Elf32_St_Type; - - function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar is - begin - return Shift_Left (B, 4) or T; - end Elf32_St_Info; - - function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is - begin - return Shift_Right (I, 8); - end Elf32_R_Sym; - - function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is - begin - return I and 16#Ff#; - end Elf32_R_Type; - - function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is - begin - return Shift_Left (S, 8) or T; - end Elf32_R_Info; -end Elf32; diff --git a/ortho/mcode/elf32.ads b/ortho/mcode/elf32.ads deleted file mode 100644 index 5afd317f6..000000000 --- a/ortho/mcode/elf32.ads +++ /dev/null @@ -1,124 +0,0 @@ --- ELF32 definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with System; -with Elf_Common; use Elf_Common; - -package Elf32 is - subtype Elf32_Addr is Unsigned_32; - subtype Elf32_Half is Unsigned_16; - subtype Elf32_Off is Unsigned_32; - subtype Elf32_Sword is Integer_32; - subtype Elf32_Word is Unsigned_32; - subtype Elf32_Uchar is Unsigned_8; - - type Elf32_Ehdr is record - E_Ident : E_Ident_Type; - E_Type : Elf32_Half; - E_Machine : Elf32_Half; - E_Version : Elf32_Word; - E_Entry : Elf32_Addr; - E_Phoff : Elf32_Off; - E_Shoff : Elf32_Off; - E_Flags : Elf32_Word; - E_Ehsize : Elf32_Half; - E_Phentsize : Elf32_Half; - E_Phnum : Elf32_Half; - E_Shentsize : Elf32_Half; - E_Shnum : Elf32_Half; - E_Shstrndx : Elf32_Half; - end record; - - Elf32_Ehdr_Size : constant Natural := Elf32_Ehdr'Size / System.Storage_Unit; - - type Elf32_Shdr is record - Sh_Name : Elf32_Word; - Sh_Type : Elf32_Word; - Sh_Flags : Elf32_Word; - Sh_Addr : Elf32_Addr; - Sh_Offset : Elf32_Off; - Sh_Size : Elf32_Word; - Sh_Link : Elf32_Word; - Sh_Info : Elf32_Word; - Sh_Addralign : Elf32_Word; - Sh_Entsize : Elf32_Word; - end record; - Elf32_Shdr_Size : constant Natural := Elf32_Shdr'Size / System.Storage_Unit; - - -- Symbol table. - type Elf32_Sym is record - St_Name : Elf32_Word; - St_Value : Elf32_Addr; - St_Size : Elf32_Word; - St_Info : Elf32_Uchar; - St_Other : Elf32_Uchar; - St_Shndx : Elf32_Half; - end record; - Elf32_Sym_Size : constant Natural := Elf32_Sym'Size / System.Storage_Unit; - - function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar; - function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar; - function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar; - pragma Inline (Elf32_St_Bind); - pragma Inline (Elf32_St_Type); - pragma Inline (Elf32_St_Info); - - -- Relocation. - type Elf32_Rel is record - R_Offset : Elf32_Addr; - R_Info : Elf32_Word; - end record; - Elf32_Rel_Size : constant Natural := Elf32_Rel'Size / System.Storage_Unit; - - type Elf32_Rela is record - R_Offset : Elf32_Addr; - R_Info : Elf32_Word; - R_Addend : Elf32_Sword; - end record; - Elf32_Rela_Size : constant Natural := Elf32_Rela'Size / System.Storage_Unit; - - function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word; - function Elf32_R_Type (I : Elf32_Word) return Elf32_Word; - function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word; - - -- For i386 - R_386_NONE : constant Elf32_Word := 0; -- none none - R_386_32 : constant Elf32_Word := 1; -- word32 S+A - R_386_PC32 : constant Elf32_Word := 2; -- word32 S+A-P - - -- For sparc - R_SPARC_NONE : constant Elf32_Word := 0; -- none - R_SPARC_32 : constant Elf32_Word := 3; -- (S + A) - R_SPARC_WDISP30 : constant Elf32_Word := 7; -- (S + A - P) >> 2 - R_SPARC_WDISP22 : constant Elf32_Word := 8; -- (S + A - P) >> 2 - R_SPARC_HI22 : constant Elf32_Word := 9; -- (S + A) >> 10 - R_SPARC_LO10 : constant Elf32_Word := 12; -- (S + A) & 0x3ff - R_SPARC_UA32 : constant Elf32_Word := 23; -- (S + A) - - type Elf32_Phdr is record - P_Type : Elf32_Word; - P_Offset : Elf32_Off; - P_Vaddr : Elf32_Addr; - P_Paddr : Elf32_Addr; - P_Filesz : Elf32_Word; - P_Memsz : Elf32_Word; - P_Flags : Elf32_Word; - P_Align : Elf32_Word; - end record; - Elf32_Phdr_Size : constant Natural := Elf32_Phdr'Size / System.Storage_Unit; -end Elf32; diff --git a/ortho/mcode/elf64.ads b/ortho/mcode/elf64.ads deleted file mode 100644 index 217e5557a..000000000 --- a/ortho/mcode/elf64.ads +++ /dev/null @@ -1,105 +0,0 @@ --- ELF64 definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with System; -with Elf_Common; use Elf_Common; - -package Elf64 is - subtype Elf64_Addr is Unsigned_64; - subtype Elf64_Off is Unsigned_64; - subtype Elf64_Uchar is Unsigned_8; - subtype Elf64_Half is Unsigned_16; - subtype Elf64_Sword is Integer_32; - subtype Elf64_Word is Unsigned_32; - subtype Elf64_Xword is Unsigned_64; - subtype Elf64_Sxword is Integer_64; - - type Elf64_Ehdr is record - E_Ident : E_Ident_Type; - E_Type : Elf64_Half; - E_Machine : Elf64_Half; - E_Version : Elf64_Word; - E_Entry : Elf64_Addr; - E_Phoff : Elf64_Off; - E_Shoff : Elf64_Off; - E_Flags : Elf64_Word; - E_Ehsize : Elf64_Half; - E_Phentsize : Elf64_Half; - E_Phnum : Elf64_Half; - E_Shentsize : Elf64_Half; - E_Shnum : Elf64_Half; - E_Shstrndx : Elf64_Half; - end record; - - Elf64_Ehdr_Size : constant Natural := Elf64_Ehdr'Size / System.Storage_Unit; - - type Elf64_Shdr is record - Sh_Name : Elf64_Word; - Sh_Type : Elf64_Word; - Sh_Flags : Elf64_Xword; - Sh_Addr : Elf64_Addr; - Sh_Offset : Elf64_Off; - Sh_Size : Elf64_Xword; - Sh_Link : Elf64_Word; - Sh_Info : Elf64_Word; - Sh_Addralign : Elf64_Xword; - Sh_Entsize : Elf64_Xword; - end record; - Elf64_Shdr_Size : constant Natural := Elf64_Shdr'Size / System.Storage_Unit; - - -- Symbol table. - type Elf64_Sym is record - St_Name : Elf64_Word; - St_Info : Elf64_Uchar; - St_Other : Elf64_Uchar; - St_Shndx : Elf64_Half; - St_Value : Elf64_Addr; - St_Size : Elf64_Xword; - end record; - Elf64_Sym_Size : constant Natural := Elf64_Sym'Size / System.Storage_Unit; - - -- Relocation. - type Elf64_Rel is record - R_Offset : Elf64_Addr; - R_Info : Elf64_Xword; - end record; - Elf64_Rel_Size : constant Natural := Elf64_Rel'Size / System.Storage_Unit; - - type Elf64_Rela is record - R_Offset : Elf64_Addr; - R_Info : Elf64_Xword; - R_Addend : Elf64_Sxword; - end record; - Elf64_Rela_Size : constant Natural := Elf64_Rela'Size / System.Storage_Unit; - --- function Elf64_R_Sym (I : Elf64_Word) return Elf64_Word; --- function Elf64_R_Type (I : Elf64_Word) return Elf64_Word; --- function Elf64_R_Info (S, T : Elf64_Word) return Elf64_Word; - - type Elf64_Phdr is record - P_Type : Elf64_Word; - P_Flags : Elf64_Word; - P_Offset : Elf64_Off; - P_Vaddr : Elf64_Addr; - P_Paddr : Elf64_Addr; - P_Filesz : Elf64_Xword; - P_Memsz : Elf64_Xword; - P_Align : Elf64_Xword; - end record; - Elf64_Phdr_Size : constant Natural := Elf64_Phdr'Size / System.Storage_Unit; -end Elf64; diff --git a/ortho/mcode/elf_arch.ads b/ortho/mcode/elf_arch.ads deleted file mode 100644 index 325c4e5e3..000000000 --- a/ortho/mcode/elf_arch.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Elf_Arch32; -package Elf_Arch renames Elf_Arch32; diff --git a/ortho/mcode/elf_arch32.ads b/ortho/mcode/elf_arch32.ads deleted file mode 100644 index 5e987b1e6..000000000 --- a/ortho/mcode/elf_arch32.ads +++ /dev/null @@ -1,37 +0,0 @@ --- ELF32 view of ELF. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Elf_Common; use Elf_Common; -with Elf32; use Elf32; - -package Elf_Arch32 is - subtype Elf_Ehdr is Elf32_Ehdr; - subtype Elf_Shdr is Elf32_Shdr; - subtype Elf_Sym is Elf32_Sym; - subtype Elf_Rel is Elf32_Rel; - subtype Elf_Rela is Elf32_Rela; - subtype Elf_Phdr is Elf32_Phdr; - - subtype Elf_Off is Elf32_Off; - subtype Elf_Size is Elf32_Word; - Elf_Ehdr_Size : constant Natural := Elf32_Ehdr_Size; - Elf_Shdr_Size : constant Natural := Elf32_Shdr_Size; - Elf_Phdr_Size : constant Natural := Elf32_Phdr_Size; - Elf_Sym_Size : constant Natural := Elf32_Sym_Size; - - Elf_Arch_Class : constant Elf_Uchar := ELFCLASS32; -end Elf_Arch32; diff --git a/ortho/mcode/elf_arch64.ads b/ortho/mcode/elf_arch64.ads deleted file mode 100644 index 504cd66b3..000000000 --- a/ortho/mcode/elf_arch64.ads +++ /dev/null @@ -1,37 +0,0 @@ --- ELF64 view of ELF. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Elf_Common; use Elf_Common; -with Elf64; use Elf64; - -package Elf_Arch64 is - subtype Elf_Ehdr is Elf64_Ehdr; - subtype Elf_Shdr is Elf64_Shdr; - subtype Elf_Sym is Elf64_Sym; - subtype Elf_Rel is Elf64_Rel; - subtype Elf_Rela is Elf64_Rela; - subtype Elf_Phdr is Elf64_Phdr; - - subtype Elf_Off is Elf64_Off; - subtype Elf_Size is Elf64_Xword; - Elf_Ehdr_Size : constant Natural := Elf64_Ehdr_Size; - Elf_Shdr_Size : constant Natural := Elf64_Shdr_Size; - Elf_Phdr_Size : constant Natural := Elf64_Phdr_Size; - Elf_Sym_Size : constant Natural := Elf64_Sym_Size; - - Elf_Arch_Class : constant Elf_Uchar := ELFCLASS64; -end Elf_Arch64; diff --git a/ortho/mcode/elf_common.adb b/ortho/mcode/elf_common.adb deleted file mode 100644 index 5d05a2dc7..000000000 --- a/ortho/mcode/elf_common.adb +++ /dev/null @@ -1,48 +0,0 @@ --- ELF definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package body Elf_Common is - function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar is - begin - return Shift_Right (Info, 4); - end Elf_St_Bind; - - function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar is - begin - return Info and 16#0F#; - end Elf_St_Type; - - function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar is - begin - return Shift_Left (B, 4) or T; - end Elf_St_Info; - --- function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is --- begin --- return Shift_Right (I, 8); --- end Elf32_R_Sym; - --- function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is --- begin --- return I and 16#Ff#; --- end Elf32_R_Type; - --- function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is --- begin --- return Shift_Left (S, 8) or T; --- end Elf32_R_Info; -end Elf_Common; diff --git a/ortho/mcode/elf_common.ads b/ortho/mcode/elf_common.ads deleted file mode 100644 index 28186d094..000000000 --- a/ortho/mcode/elf_common.ads +++ /dev/null @@ -1,250 +0,0 @@ --- ELF definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Elf_Common is - subtype Elf_Half is Unsigned_16; - subtype Elf_Sword is Integer_32; - subtype Elf_Word is Unsigned_32; - subtype Elf_Uchar is Unsigned_8; - - EI_NIDENT : constant Natural := 16; - type E_Ident_Type is array (Natural range 0 .. EI_NIDENT - 1) - of Elf_Uchar; - - -- e_type values. - ET_NONE : constant Elf_Half := 0; -- No file type - ET_REL : constant Elf_Half := 1; -- Relocatable file - ET_EXEC : constant Elf_Half := 2; -- Executable file - ET_DYN : constant Elf_Half := 3; -- Shared object file - ET_CORE : constant Elf_Half := 4; -- Core file - ET_LOPROC : constant Elf_Half := 16#Ff00#; -- Processor-specific - ET_HIPROC : constant Elf_Half := 16#Ffff#; -- Processor-specific - - -- e_machine values. - EM_NONE : constant Elf_Half := 0; -- No machine - EM_M32 : constant Elf_Half := 1; -- AT&T WE 32100 - EM_SPARC : constant Elf_Half := 2; -- SPARC - EM_386 : constant Elf_Half := 3; -- Intel Architecture - EM_68K : constant Elf_Half := 4; -- Motorola 68000 - EM_88K : constant Elf_Half := 5; -- Motorola 88000 - EM_860 : constant Elf_Half := 7; -- Intel 80860 - EM_MIPS : constant Elf_Half := 8; -- MIPS RS3000 Big-Endian - EM_MIPS_RS4_BE : constant Elf_Half := 10; -- MIPS RS4000 Big-Endian - -- RESERVED : constant Elf_Half := 11; -- -16 Reserved for future use - - -- e_version - EV_NONE : constant Elf_Uchar := 0; -- Invalid versionn - EV_CURRENT : constant Elf_Uchar := 1; -- Current version - - -- e_ident identification indexes. - EI_MAG0 : constant Natural := 0; -- File identification - EI_MAG1 : constant Natural := 1; -- File identification - EI_MAG2 : constant Natural := 2; -- File identification - EI_MAG3 : constant Natural := 3; -- File identification - EI_CLASS : constant Natural := 4; -- File class - EI_DATA : constant Natural := 5; -- Data encoding - EI_VERSION : constant Natural := 6; -- File version - EI_PAD : constant Natural := 7; -- Start of padding bytes - --EI_NIDENT : constant Natural := 16; -- Size of e_ident[] - - -- Magic values. - ELFMAG0 : constant Elf_Uchar := 16#7f#; -- e_ident[EI_MAG0] - ELFMAG1 : constant Elf_Uchar := Character'Pos ('E'); -- e_ident[EI_MAG1] - ELFMAG2 : constant Elf_Uchar := Character'Pos ('L'); -- e_ident[EI_MAG2] - ELFMAG3 : constant Elf_Uchar := Character'Pos ('F'); -- e_ident[EI_MAG3] - - ELFCLASSNONE : constant Elf_Uchar := 0; -- Invalid class - ELFCLASS32 : constant Elf_Uchar := 1; -- 32-bit objects - ELFCLASS64 : constant Elf_Uchar := 2; -- 64-bit objects - - ELFDATANONE : constant Elf_Uchar := 0; -- Invalid data encoding - ELFDATA2LSB : constant Elf_Uchar := 1; -- See below - ELFDATA2MSB : constant Elf_Uchar := 2; -- See below - - SHN_UNDEF : constant Elf_Half := 0; -- - SHN_LORESERVE : constant Elf_Half := 16#Ff00#; -- - SHN_LOPROC : constant Elf_Half := 16#ff00#; -- - SHN_HIPROC : constant Elf_Half := 16#ff1f#; -- - SHN_ABS : constant Elf_Half := 16#fff1#; -- - SHN_COMMON : constant Elf_Half := 16#fff2#; -- - SHN_HIRESERVE : constant Elf_Half := 16#ffff#; -- - - -- Sh_type. - SHT_NULL : constant Elf_Word := 0; - SHT_PROGBITS : constant Elf_Word := 1; - SHT_SYMTAB : constant Elf_Word := 2; - SHT_STRTAB : constant Elf_Word := 3; - SHT_RELA : constant Elf_Word := 4; - SHT_HASH : constant Elf_Word := 5; - SHT_DYNAMIC : constant Elf_Word := 6; - SHT_NOTE : constant Elf_Word := 7; - SHT_NOBITS : constant Elf_Word := 8; - SHT_REL : constant Elf_Word := 9; - SHT_SHLIB : constant Elf_Word := 10; - SHT_DYNSYM : constant Elf_Word := 11; - SHT_INIT_ARRAY : constant Elf_Word := 14; - SHT_FINI_ARRAY : constant Elf_Word := 15; - SHT_PREINIT_ARRAY : constant Elf_Word := 16; - SHT_GROUP : constant Elf_Word := 17; - SHT_SYMTAB_SHNDX : constant Elf_Word := 18; - SHT_NUM : constant Elf_Word := 19; - SHT_LOOS : constant Elf_Word := 16#60000000#; - SHT_GNU_LIBLIST : constant Elf_Word := 16#6ffffff7#; - SHT_CHECKSUM : constant Elf_Word := 16#6ffffff8#; - SHT_LOSUNW : constant Elf_Word := 16#6ffffffa#; - SHT_SUNW_Move : constant Elf_Word := 16#6ffffffa#; - SHT_SUNW_COMDAT : constant Elf_Word := 16#6ffffffb#; - SHT_SUNW_Syminfo : constant Elf_Word := 16#6ffffffc#; - SHT_GNU_Verdef : constant Elf_Word := 16#6ffffffd#; - SHT_GNU_Verneed : constant Elf_Word := 16#6ffffffe#; - SHT_GNU_Versym : constant Elf_Word := 16#6fffffff#; - SHT_HISUNW : constant Elf_Word := 16#6fffffff#; - SHT_HIOS : constant Elf_Word := 16#6fffffff#; - SHT_LOPROC : constant Elf_Word := 16#70000000#; - SHT_HIPROC : constant Elf_Word := 16#7fffffff#; - SHT_LOUSER : constant Elf_Word := 16#80000000#; - SHT_HIUSER : constant Elf_Word := 16#ffffffff#; - - - SHF_WRITE : constant := 16#1#; - SHF_ALLOC : constant := 16#2#; - SHF_EXECINSTR : constant := 16#4#; - SHF_MASKPROC : constant := 16#F0000000#; - - function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar; - function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar; - function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar; - pragma Inline (Elf_St_Bind); - pragma Inline (Elf_St_Type); - pragma Inline (Elf_St_Info); - - -- Symbol binding. - STB_LOCAL : constant Elf_Uchar := 0; - STB_GLOBAL : constant Elf_Uchar := 1; - STB_WEAK : constant Elf_Uchar := 2; - STB_LOPROC : constant Elf_Uchar := 13; - STB_HIPROC : constant Elf_Uchar := 15; - - -- Symbol types. - STT_NOTYPE : constant Elf_Uchar := 0; - STT_OBJECT : constant Elf_Uchar := 1; - STT_FUNC : constant Elf_Uchar := 2; - STT_SECTION : constant Elf_Uchar := 3; - STT_FILE : constant Elf_Uchar := 4; - STT_LOPROC : constant Elf_Uchar := 13; - STT_HIPROC : constant Elf_Uchar := 15; - - - PT_NULL : constant Elf_Word := 0; - PT_LOAD : constant Elf_Word := 1; - PT_DYNAMIC : constant Elf_Word := 2; - PT_INTERP : constant Elf_Word := 3; - PT_NOTE : constant Elf_Word := 4; - PT_SHLIB : constant Elf_Word := 5; - PT_PHDR : constant Elf_Word := 6; - PT_TLS : constant Elf_Word := 7; - PT_NUM : constant Elf_Word := 8; - PT_LOOS : constant Elf_Word := 16#60000000#; - PT_GNU_EH_FRAME : constant Elf_Word := 16#6474e550#; - PT_LOSUNW : constant Elf_Word := 16#6ffffffa#; - PT_SUNWBSS : constant Elf_Word := 16#6ffffffa#; - PT_SUNWSTACK : constant Elf_Word := 16#6ffffffb#; - PT_HISUNW : constant Elf_Word := 16#6fffffff#; - PT_HIOS : constant Elf_Word := 16#6fffffff#; - PT_LOPROC : constant Elf_Word := 16#70000000#; - PT_HIPROC : constant Elf_Word := 16#7fffffff#; - - PF_X : constant Elf_Word := 1; - PF_W : constant Elf_Word := 2; - PF_R : constant Elf_Word := 4; - - DT_NULL : constant Elf_Word := 0; - DT_NEEDED : constant Elf_Word := 1; - DT_PLTRELSZ : constant Elf_Word := 2; - DT_PLTGOT : constant Elf_Word := 3; - DT_HASH : constant Elf_Word := 4; - DT_STRTAB : constant Elf_Word := 5; - DT_SYMTAB : constant Elf_Word := 6; - DT_RELA : constant Elf_Word := 7; - DT_RELASZ : constant Elf_Word := 8; - DT_RELAENT : constant Elf_Word := 9; - DT_STRSZ : constant Elf_Word := 10; - DT_SYMENT : constant Elf_Word := 11; - DT_INIT : constant Elf_Word := 12; - DT_FINI : constant Elf_Word := 13; - DT_SONAME : constant Elf_Word := 14; - DT_RPATH : constant Elf_Word := 15; - DT_SYMBOLIC : constant Elf_Word := 16; - DT_REL : constant Elf_Word := 17; - DT_RELSZ : constant Elf_Word := 18; - DT_RELENT : constant Elf_Word := 19; - DT_PLTREL : constant Elf_Word := 20; - DT_DEBUG : constant Elf_Word := 21; - DT_TEXTREL : constant Elf_Word := 22; - DT_JMPREL : constant Elf_Word := 23; - DT_BIND_NOW : constant Elf_Word := 24; - DT_INIT_ARRAY : constant Elf_Word := 25; - DT_FINI_ARRAY : constant Elf_Word := 26; - DT_INIT_ARRAYSZ : constant Elf_Word := 27; - DT_FINI_ARRAYSZ : constant Elf_Word := 28; - DT_RUNPATH : constant Elf_Word := 29; - DT_FLAGS : constant Elf_Word := 30; - DT_ENCODING : constant Elf_Word := 32; - DT_PREINIT_ARRAY : constant Elf_Word := 32; - DT_PREINIT_ARRAYSZ : constant Elf_Word := 33; - DT_NUM : constant Elf_Word := 34; - DT_LOOS : constant Elf_Word := 16#60000000#; - DT_HIOS : constant Elf_Word := 16#6fffffff#; - DT_LOPROC : constant Elf_Word := 16#70000000#; - DT_HIPROC : constant Elf_Word := 16#7fffffff#; - DT_VALRNGLO : constant Elf_Word := 16#6ffffd00#; - DT_GNU_PRELINKED : constant Elf_Word := 16#6ffffdf5#; - DT_GNU_CONFLICTSZ : constant Elf_Word := 16#6ffffdf6#; - DT_GNU_LIBLISTSZ : constant Elf_Word := 16#6ffffdf7#; - DT_CHECKSUM : constant Elf_Word := 16#6ffffdf8#; - DT_PLTPADSZ : constant Elf_Word := 16#6ffffdf9#; - DT_MOVEENT : constant Elf_Word := 16#6ffffdfa#; - DT_MOVESZ : constant Elf_Word := 16#6ffffdfb#; - DT_FEATURE_1 : constant Elf_Word := 16#6ffffdfc#; - DT_POSFLAG_1 : constant Elf_Word := 16#6ffffdfd#; - DT_SYMINSZ : constant Elf_Word := 16#6ffffdfe#; - DT_SYMINENT : constant Elf_Word := 16#6ffffdff#; - DT_VALRNGHI : constant Elf_Word := 16#6ffffdff#; - DT_ADDRRNGLO : constant Elf_Word := 16#6ffffe00#; - DT_GNU_CONFLICT : constant Elf_Word := 16#6ffffef8#; - DT_GNU_LIBLIST : constant Elf_Word := 16#6ffffef9#; - DT_CONFIG : constant Elf_Word := 16#6ffffefa#; - DT_DEPAUDIT : constant Elf_Word := 16#6ffffefb#; - DT_AUDIT : constant Elf_Word := 16#6ffffefc#; - DT_PLTPAD : constant Elf_Word := 16#6ffffefd#; - DT_MOVETAB : constant Elf_Word := 16#6ffffefe#; - DT_SYMINFO : constant Elf_Word := 16#6ffffeff#; - DT_ADDRRNGHI : constant Elf_Word := 16#6ffffeff#; - DT_VERSYM : constant Elf_Word := 16#6ffffff0#; - DT_RELACOUNT : constant Elf_Word := 16#6ffffff9#; - DT_RELCOUNT : constant Elf_Word := 16#6ffffffa#; - DT_FLAGS_1 : constant Elf_Word := 16#6ffffffb#; - DT_VERDEF : constant Elf_Word := 16#6ffffffc#; - DT_VERDEFNUM : constant Elf_Word := 16#6ffffffd#; - DT_VERNEED : constant Elf_Word := 16#6ffffffe#; - DT_VERNEEDNUM : constant Elf_Word := 16#6fffffff#; - DT_AUXILIARY : constant Elf_Word := 16#7ffffffd#; - DT_FILTER : constant Elf_Word := 16#7fffffff#; - -end Elf_Common; diff --git a/ortho/mcode/elfdump.adb b/ortho/mcode/elfdump.adb deleted file mode 100644 index d49275912..000000000 --- a/ortho/mcode/elfdump.adb +++ /dev/null @@ -1,267 +0,0 @@ --- ELF dumper (main program). --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; use Ada.Text_IO; -with Elf_Common; use Elf_Common; -with Ada.Command_Line; use Ada.Command_Line; -with Hex_Images; use Hex_Images; -with Interfaces; use Interfaces; -with Elfdumper; use Elfdumper; - -procedure Elfdump is - Flag_Ehdr : Boolean := False; - Flag_Shdr : Boolean := False; - Flag_Strtab : Boolean := False; - Flag_Symtab : Boolean := False; - Flag_Dwarf_Info : Boolean := False; - Flag_Dwarf_Abbrev : Boolean := False; - Flag_Dwarf_Pubnames : Boolean := False; - Flag_Dwarf_Aranges : Boolean := False; - Flag_Dwarf_Line : Boolean := False; - Flag_Dwarf_Frame : Boolean := False; - Flag_Eh_Frame_Hdr : Boolean := False; - Flag_Long_Shdr : Boolean := False; - Flag_Phdr : Boolean := False; - Flag_Note : Boolean := False; - Flag_Dynamic : Boolean := False; - - procedure Disp_Max_Len (Str : String; Len : Natural) - is - begin - if Str'Length > Len then - Put (Str (Str'First .. Str'First + Len - 1)); - else - Put (Str); - Put ((Str'Length + 1 .. Len => ' ')); - end if; - end Disp_Max_Len; - - procedure Disp_Section_Header (File : Elf_File; Index : Elf_Half) is - begin - Put ("Section " & Hex_Image (Index)); - Put (" "); - Put (Get_Section_Name (File, Index)); - New_Line; - end Disp_Section_Header; - - procedure Disp_Elf_File (Filename : String) - is - File : Elf_File; - Ehdr : Elf_Ehdr_Acc; - Shdr : Elf_Shdr_Acc; - Phdr : Elf_Phdr_Acc; - Sh_Strtab : Strtab_Type; - begin - Open_File (File, Filename); - if Get_Status (File) /= Status_Ok then - Put_Line ("cannot open elf file '" & Filename & "': " & - Elf_File_Status'Image (Get_Status (File))); - return; - end if; - - Ehdr := Get_Ehdr (File); - - if Flag_Ehdr then - Disp_Ehdr (Ehdr.all); - end if; - - Load_Shdr (File); - Sh_Strtab := Get_Sh_Strtab (File); - - if Flag_Long_Shdr then - if Ehdr.E_Shnum = 0 then - Put ("no section"); - else - for I in 0 .. Ehdr.E_Shnum - 1 loop - Put ("Section " & Hex_Image (I)); - New_Line; - Disp_Shdr (Get_Shdr (File, I).all, Sh_Strtab); - end loop; - end if; - end if; - if Flag_Shdr then - if Ehdr.E_Shnum = 0 then - Put ("no section"); - else - Put ("Num Name Type "); - Put ("Offset Size Link Info Al Es"); - New_Line; - for I in 0 .. Ehdr.E_Shnum - 1 loop - declare - Shdr : Elf_Shdr_Acc := Get_Shdr (File, I); - begin - Put (Hex_Image (I)); - Put (" "); - Disp_Max_Len (Get_Section_Name (File, I), 20); - Put (" "); - Disp_Max_Len (Get_Shdr_Type_Name (Shdr.Sh_Type), 10); - Put (" "); - Put (Hex_Image (Shdr.Sh_Offset)); - Put (" "); - Put (Hex_Image (Shdr.Sh_Size)); - Put (" "); - Put (Hex_Image (Unsigned_16 (Shdr.Sh_Link and 16#Ffff#))); - Put (" "); - Put (Hex_Image (Unsigned_16 (Shdr.Sh_Info and 16#Ffff#))); - Put (" "); - Put (Hex_Image (Unsigned_8 (Shdr.Sh_Addralign and 16#ff#))); - Put (" "); - Put (Hex_Image (Unsigned_8 (Shdr.Sh_Entsize and 16#ff#))); - New_Line; - end; - end loop; - end if; - end if; - - if Flag_Phdr then - Load_Phdr (File); - if Ehdr.E_Phnum = 0 then - Put ("no program segment"); - else - for I in 0 .. Ehdr.E_Phnum - 1 loop - Put ("segment " & Hex_Image (I)); - New_Line; - Disp_Phdr (Get_Phdr (File, I).all); - end loop; - end if; - end if; - - -- Dump each section. - if Ehdr.E_Shnum > 0 then - for I in 0 .. Ehdr.E_Shnum - 1 loop - Shdr := Get_Shdr (File, I); - case Shdr.Sh_Type is - when SHT_SYMTAB => - if Flag_Symtab then - Disp_Section_Header (File, I); - Disp_Symtab (File, I); - end if; - when SHT_STRTAB => - if Flag_Strtab then - Disp_Section_Header (File, I); - Disp_Strtab (File, I); - end if; - when SHT_PROGBITS => - declare - Name : String := Get_Section_Name (File, I); - begin - if Flag_Dwarf_Abbrev and then Name = ".debug_abbrev" then - Disp_Section_Header (File, I); - Disp_Debug_Abbrev (File, I); - elsif Flag_Dwarf_Info and then Name = ".debug_info" then - Disp_Section_Header (File, I); - Disp_Debug_Info (File, I); - elsif Flag_Dwarf_Line and then Name = ".debug_line" then - Disp_Section_Header (File, I); - Disp_Debug_Line (File, I); - elsif Flag_Dwarf_Frame and then Name = ".debug_frame" then - Disp_Section_Header (File, I); - Disp_Debug_Frame (File, I); - elsif Flag_Dwarf_Pubnames - and then Name = ".debug_pubnames" - then - Disp_Section_Header (File, I); - Disp_Debug_Pubnames (File, I); - elsif Flag_Eh_Frame_Hdr and then Name = ".eh_frame_hdr" - then - Disp_Section_Header (File, I); - Disp_Eh_Frame_Hdr (File, I); - elsif Flag_Dwarf_Aranges - and then Name = ".debug_aranges" - then - Disp_Section_Header (File, I); - Disp_Debug_Aranges (File, I); - end if; - end; - when SHT_NOTE => - if Flag_Note then - Disp_Section_Header (File, I); - Disp_Section_Note (File, I); - end if; - when SHT_DYNAMIC => - if Flag_Dynamic then - Disp_Section_Header (File, I); - Disp_Dynamic (File, I); - end if; - when others => - null; - end case; - end loop; - elsif Ehdr.E_Phnum > 0 then - Load_Phdr (File); - for I in 0 .. Ehdr.E_Phnum - 1 loop - Phdr := Get_Phdr (File, I); - case Phdr.P_Type is - when PT_NOTE => - if Flag_Note then - Disp_Segment_Note (File, I); - end if; - when others => - null; - end case; - end loop; - end if; - end Disp_Elf_File; - -begin - for I in 1 .. Argument_Count loop - declare - Arg : String := Argument (I); - begin - if Arg (1) = '-' then - -- An option. - if Arg = "-e" then - Flag_Ehdr := True; - elsif Arg = "-t" then - Flag_Strtab := True; - elsif Arg = "-S" then - Flag_Symtab := True; - elsif Arg = "-s" then - Flag_Shdr := True; - elsif Arg = "-p" then - Flag_Phdr := True; - elsif Arg = "-n" then - Flag_Note := True; - elsif Arg = "-d" then - Flag_Dynamic := True; - elsif Arg = "--dwarf-info" then - Flag_Dwarf_Info := True; - elsif Arg = "--dwarf-abbrev" then - Flag_Dwarf_Abbrev := True; - elsif Arg = "--dwarf-line" then - Flag_Dwarf_Line := True; - elsif Arg = "--dwarf-frame" then - Flag_Dwarf_Frame := True; - elsif Arg = "--dwarf-pubnames" then - Flag_Dwarf_Pubnames := True; - elsif Arg = "--dwarf-aranges" then - Flag_Dwarf_Aranges := True; - elsif Arg = "--eh-frame-hdr" then - Flag_Eh_Frame_Hdr := True; - elsif Arg = "--long-shdr" then - Flag_Long_Shdr := True; - else - Put_Line ("unknown option '" & Arg & "'"); - return; - end if; - else - Disp_Elf_File (Arg); - end if; - end; - end loop; -end Elfdump; - diff --git a/ortho/mcode/elfdumper.adb b/ortho/mcode/elfdumper.adb deleted file mode 100644 index b3a3b70f2..000000000 --- a/ortho/mcode/elfdumper.adb +++ /dev/null @@ -1,2818 +0,0 @@ --- ELF dumper (library). --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System.Storage_Elements; use System.Storage_Elements; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Deallocation; -with GNAT.OS_Lib; -with Interfaces; use Interfaces; -with Hex_Images; use Hex_Images; -with Elf_Common; use Elf_Common; -with Dwarf; - -package body Elfdumper is - function Get_String (Strtab : Strtab_Type; N : Elf_Size) return String - is - E : Elf_Size; - begin - E := N; - while Strtab.Base (E) /= Nul loop - E := E + 1; - end loop; - if E = N then - return ""; - else - return String (Strtab.Base (N .. E - 1)); - end if; - end Get_String; - - procedure Disp_Ehdr (Ehdr : Elf_Ehdr) is - begin - Put ("File class: "); - case Ehdr.E_Ident (EI_CLASS) is - when ELFCLASSNONE => - Put ("none"); - when ELFCLASS32 => - Put ("class_32"); - when ELFCLASS64 => - Put ("class_64"); - when others => - Put ("others"); - end case; - New_Line; - - Put ("encoding : "); - case Ehdr.E_Ident (EI_DATA) is - when ELFDATANONE => - Put ("none"); - when ELFDATA2LSB => - Put ("LSB byte order"); - when ELFDATA2MSB => - Put ("MSB byte order"); - when others => - Put ("unknown"); - end case; - New_Line; - - Put ("version : "); - case Ehdr.E_Ident (EI_VERSION) is - when EV_NONE => - Put ("none"); - when EV_CURRENT => - Put ("current (1)"); - when others => - Put ("future"); - end case; - New_Line; - - if Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class --- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB - or Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT - then - Put_Line ("bad class/data encoding/version"); - return; - end if; - - Put ("File type : "); - case Ehdr.E_Type is - when ET_NONE => - Put ("no file type"); - when ET_REL => - Put ("relocatable file"); - when ET_EXEC => - Put ("executable file"); - when ET_CORE => - Put ("core file"); - when ET_LOPROC .. ET_HIPROC => - Put ("processor-specific"); - when others => - Put ("unknown"); - end case; - New_Line; - - Put ("machine : "); - case Ehdr.E_Machine is - when EM_NONE => - Put ("no machine"); - when EM_M32 => - Put ("AT&T WE 32100"); - when EM_SPARC => - Put ("SPARC"); - when EM_386 => - Put ("Intel architecture"); - when EM_68K => - Put ("Motorola 68000"); - when EM_88K => - Put ("Motorola 88000"); - when EM_860 => - Put ("Intel 80860"); - when EM_MIPS => - Put ("MIPS RS3000 Big-Endian"); - when EM_MIPS_RS4_BE => - Put ("MIPS RS4000 Big-Endian"); - when others => - Put ("unknown"); - end case; - New_Line; - - Put_Line ("Version : " & Hex_Image (Ehdr.E_Version)); - Put_Line ("Phoff : " & Hex_Image (Ehdr.E_Phoff)); - Put_Line ("Shoff : " & Hex_Image (Ehdr.E_Shoff)); - Put_Line ("flags : " & Hex_Image (Ehdr.E_Flags)); - Put_Line ("phentsize : " & Hex_Image (Ehdr.E_Ehsize)); - Put_Line ("phnum : " & Hex_Image (Ehdr.E_Phentsize)); - Put_Line ("shentsize : " & Hex_Image (Ehdr.E_Shentsize)); - Put_Line ("shnum : " & Hex_Image (Ehdr.E_Shnum)); - Put_Line ("shstrndx : " & Hex_Image (Ehdr.E_Shstrndx)); - end Disp_Ehdr; - - function Get_Shdr_Type_Name (Stype : Elf_Word) return String is - begin - case Stype is - when SHT_NULL => - return "NULL"; - when SHT_PROGBITS => - return "PROGBITS"; - when SHT_SYMTAB => - return "SYMTAB"; - when SHT_STRTAB => - return "STRTAB"; - when SHT_RELA => - return "RELA"; - when SHT_HASH => - return "HASH"; - when SHT_DYNAMIC => - return "DYNAMIC"; - when SHT_NOTE => - return "NOTE"; - when SHT_NOBITS => - return "NOBITS"; - when SHT_REL => - return "REL"; - when SHT_SHLIB => - return "SHLIB"; - when SHT_DYNSYM => - return "DYNSYM"; - when SHT_INIT_ARRAY => - return "INIT_ARRAY"; - when SHT_FINI_ARRAY => - return "FINI_ARRAY"; - when SHT_PREINIT_ARRAY => - return "PREINIT_ARRAY"; - when SHT_GROUP => - return "GROUP"; - when SHT_SYMTAB_SHNDX => - return "SYMTAB_SHNDX"; - when SHT_NUM => - return "NUM"; - when SHT_LOOS => - return "LOOS"; - when SHT_GNU_LIBLIST => - return "GNU_LIBLIST"; - when SHT_CHECKSUM => - return "CHECKSUM"; - when SHT_SUNW_Move => - return "SUNW_move"; - when SHT_SUNW_COMDAT => - return "SUNW_COMDAT"; - when SHT_SUNW_Syminfo => - return "SUNW_syminfo"; - when SHT_GNU_Verdef => - return "GNU_verdef"; - when SHT_GNU_Verneed => - return "GNU_verneed"; - when SHT_GNU_Versym => - return "GNU_versym"; - when SHT_LOPROC .. SHT_HIPROC => - return "Processor dependant"; - when SHT_LOUSER .. SHT_HIUSER => - return "User dependant"; - when others => - return "unknown"; - end case; - end Get_Shdr_Type_Name; - - procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type) - is - begin - Put_Line ("name : " & Hex_Image (Shdr.Sh_Name) & " """ - & Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) & """"); - Put ("type : " & Hex_Image (Shdr.Sh_Type) & " "); - Put (Get_Shdr_Type_Name (Shdr.Sh_Type)); - New_Line; - Put ("flags : " & Hex_Image (Shdr.Sh_Flags)); - if (Shdr.Sh_Flags and SHF_WRITE) /= 0 then - Put (" WRITE"); - end if; - if (Shdr.Sh_Flags and SHF_ALLOC) /= 0 then - Put (" ALLOC"); - end if; - if (Shdr.Sh_Flags and SHF_EXECINSTR) /= 0 then - Put (" EXEC"); - end if; - New_Line; - Put ("addr : " & Hex_Image (Shdr.Sh_Addr)); - Put (" offset : " & Hex_Image (Shdr.Sh_Offset)); - Put (" size : " & Hex_Image (Shdr.Sh_Size)); - New_Line; - Put ("link : " & Hex_Image (Shdr.Sh_Link)); - Put (" info : " & Hex_Image (Shdr.Sh_Info)); - Put (" addralign : " & Hex_Image (Shdr.Sh_Addralign)); - Put (" entsize : " & Hex_Image (Shdr.Sh_Entsize)); - New_Line; - end Disp_Shdr; - - procedure Disp_Sym (File : Elf_File; - Sym : Elf_Sym; - Strtab : Strtab_Type) - is - begin - Put (Hex_Image (Sym.St_Value)); - Put (" " & Hex_Image (Sym.St_Size)); - Put (' '); - --Put (" info:" & Hex_Image (Sym.St_Info) & " "); - case Elf_St_Bind (Sym.St_Info) is - when STB_LOCAL => - Put ("loc "); - when STB_GLOBAL => - Put ("glob"); - when STB_WEAK => - Put ("weak"); - when others => - Put ("? "); - end case; - Put (' '); - case Elf_St_Type (Sym.St_Info) is - when STT_NOTYPE => - Put ("none"); - when STT_OBJECT => - Put ("obj "); - when STT_FUNC => - Put ("func"); - when STT_SECTION => - Put ("sect"); - when STT_FILE => - Put ("file"); - when others => - Put ("? "); - end case; - --Put (" other:" & Hex_Image (Sym.St_Other)); - Put (' '); - case Sym.St_Shndx is - when SHN_UNDEF => - Put ("UNDEF "); - when 1 .. SHN_LORESERVE - 1 => - declare - S : String := Get_Section_Name (File, Sym.St_Shndx); - Max : constant Natural := 8; - begin - if S'Length <= Max then - Put (S); - for I in S'Length + 1 .. Max loop - Put (' '); - end loop; - else - Put (S (S'First .. S'First + Max - 1)); - end if; - end; - when SHN_LOPROC .. SHN_HIPROC => - Put ("*proc* "); - when SHN_ABS => - Put ("*ABS* "); - when SHN_COMMON => - Put ("*COMMON*"); - when others => - Put ("?? "); - end case; - --Put (" sect:" & Hex_Image (Sym.St_Shndx)); - Put (' '); - Put_Line (Get_String (Strtab, Elf_Size (Sym.St_Name))); - end Disp_Sym; - - function Get_Offset (File : Elf_File; Off : Elf_Off; Size : Elf_Size) - return Address - is - begin - if Off > File.Length or Off + Size > File.Length then - return Null_Address; - end if; - return File.Base + Storage_Offset (Off); - end Get_Offset; - - function Get_Section_Base (File : Elf_File; Shdr : Elf_Shdr) - return Address - is - begin - return Get_Offset (File, Shdr.Sh_Offset, Shdr.Sh_Size); - end Get_Section_Base; - - function Get_Section_Base (File : Elf_File; Index : Elf_Half) - return Address - is - Shdr : Elf_Shdr_Acc; - begin - Shdr := Get_Shdr (File, Index); - return Get_Section_Base (File, Shdr.all); - end Get_Section_Base; - - function Get_Segment_Base (File : Elf_File; Phdr : Elf_Phdr) - return Address - is - begin - return Get_Offset (File, Phdr.P_Offset, Phdr.P_Filesz); - end Get_Segment_Base; - - function Get_Segment_Base (File : Elf_File; Index : Elf_Half) - return Address - is - Phdr : Elf_Phdr_Acc; - begin - Phdr := Get_Phdr (File, Index); - return Get_Segment_Base (File, Phdr.all); - end Get_Segment_Base; - - procedure Open_File (File : out Elf_File; Filename : String) - is - function Malloc (Size : Integer) return Address; - pragma Import (C, Malloc); - - use GNAT.OS_Lib; - Length : Long_Integer; - Len : Integer; - Fd : File_Descriptor; - begin - File := (Filename => new String'(Filename), - Status => Status_Ok, - Length => 0, - Base => Null_Address, - Ehdr => null, - Shdr_Base => Null_Address, - Sh_Strtab => (null, 0), - Phdr_Base => Null_Address); - - -- Open the file. - Fd := Open_Read (Filename, Binary); - if Fd = Invalid_FD then - File.Status := Status_Open_Failure; - return; - end if; - - -- Get length. - Length := File_Length (Fd); - Len := Integer (Length); - if Len < Elf_Ehdr_Size then - File.Status := Status_Bad_File; - Close (Fd); - return; - end if; - - File.Length := Elf_Off (Len); - - -- Allocate memory for the file. - File.Base := Malloc (Len); - if File.Base = Null_Address then - File.Status := Status_Memory; - Close (Fd); - return; - end if; - - -- Read the whole file. - if Read (Fd, File.Base, Integer (Length)) /= Integer (Length) then - File.Status := Status_Read_Error; - Close (Fd); - return; - end if; - - Close (Fd); - - File.Ehdr := To_Elf_Ehdr_Acc (File.Base); - - if File.Ehdr.E_Ident (EI_MAG0) /= ELFMAG0 - or File.Ehdr.E_Ident (EI_MAG1) /= ELFMAG1 - or File.Ehdr.E_Ident (EI_MAG2) /= ELFMAG2 - or File.Ehdr.E_Ident (EI_MAG3) /= ELFMAG3 - then - File.Status := Status_Bad_Magic; - return; - end if; - - if File.Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class --- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB - or File.Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT - then - File.Status := Status_Bad_Class; - return; - end if; - end Open_File; - - function Get_Status (File : Elf_File) return Elf_File_Status is - begin - return File.Status; - end Get_Status; - - function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc is - begin - return File.Ehdr; - end Get_Ehdr; - - function Get_Shdr (File : Elf_File; Index : Elf_Half) - return Elf_Shdr_Acc - is - begin - if Index >= File.Ehdr.E_Shnum then - raise Constraint_Error; - end if; - return To_Elf_Shdr_Acc - (File.Shdr_Base - + Storage_Offset (Index * Elf_Half (Elf_Shdr_Size))); - end Get_Shdr; - - procedure Load_Phdr (File : in out Elf_File) - is - begin - if Get_Ehdr (File).E_Phentsize /= Elf_Half (Elf_Phdr_Size) then - return; - end if; - - File.Phdr_Base := - Get_Offset (File, Get_Ehdr (File).E_Phoff, - Elf_Size (Get_Ehdr (File).E_Phnum - * Elf_Half (Elf_Phdr_Size))); - end Load_Phdr; - - function Get_Phdr (File : Elf_File; Index : Elf_Half) - return Elf_Phdr_Acc - is - begin - if Index >= File.Ehdr.E_Phnum then - raise Constraint_Error; - end if; - return To_Elf_Phdr_Acc - (File.Phdr_Base - + Storage_Offset (Index * Elf_Half (Elf_Phdr_Size))); - end Get_Phdr; - - function Get_Strtab (File : Elf_File; Index : Elf_Half) - return Strtab_Type - is - Shdr : Elf_Shdr_Acc; - begin - Shdr := Get_Shdr (File, Index); - if Shdr = null or Shdr.Sh_Type /= SHT_STRTAB then - return Null_Strtab; - end if; - return (Base => To_Strtab_Fat_Acc (Get_Section_Base (File, Shdr.all)), - Length => Shdr.Sh_Size); - end Get_Strtab; - - procedure Load_Shdr (File : in out Elf_File) - is - begin - if Get_Ehdr (File).E_Shentsize /= Elf_Half (Elf_Shdr_Size) then - return; - end if; - - File.Shdr_Base := - Get_Offset (File, Get_Ehdr (File).E_Shoff, - Elf_Size (Get_Ehdr (File).E_Shnum - * Elf_Half (Elf_Shdr_Size))); - File.Sh_Strtab := Get_Strtab (File, Get_Ehdr (File).E_Shstrndx); - end Load_Shdr; - - function Get_Sh_Strtab (File : Elf_File) return Strtab_Type is - begin - return File.Sh_Strtab; - end Get_Sh_Strtab; - - function Get_Section_Name (File : Elf_File; Index : Elf_Half) - return String - is - begin - return Get_String (Get_Sh_Strtab (File), - Elf_Size (Get_Shdr (File, Index).Sh_Name)); - end Get_Section_Name; - - function Get_Section_By_Name (File : Elf_File; Name : String) - return Elf_Half - is - Ehdr : Elf_Ehdr_Acc; - Shdr : Elf_Shdr_Acc; - Sh_Strtab : Strtab_Type; - begin - Ehdr := Get_Ehdr (File); - Sh_Strtab := Get_Sh_Strtab (File); - for I in 1 .. Ehdr.E_Shnum - 1 loop - Shdr := Get_Shdr (File, I); - if Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) = Name then - return I; - end if; - end loop; - return 0; - end Get_Section_By_Name; - - procedure Disp_Symtab (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - S_Strtab : Strtab_Type; - Base : Address; - Off : Storage_Offset; - begin - Shdr := Get_Shdr (File, Index); - if Shdr.Sh_Entsize /= Elf_Size (Elf_Sym_Size) then - return; - end if; - S_Strtab := Get_Strtab (File, Elf_Half (Shdr.Sh_Link)); - Base := Get_Section_Base (File, Shdr.all); - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Disp_Sym (File, To_Elf_Sym_Acc (Base + Off).all, S_Strtab); - Off := Off + Storage_Offset (Elf_Sym_Size); - end loop; - end Disp_Symtab; - - procedure Disp_Strtab (File : Elf_File; Index : Elf_Half) - is - Strtab : Strtab_Type; - S, E : Elf_Size; - begin - Strtab := Get_Strtab (File, Index); - S := 1; - while S < Strtab.Length loop - E := S; - while Strtab.Base (E) /= Nul loop - E := E + 1; - end loop; - Put_Line (Hex_Image (S) & ": " - & String (Strtab.Base (S .. E - 1))); - S := E + 1; - end loop; - end Disp_Strtab; - - function Read_Byte (Addr : Address) return Unsigned_8 - is - type Unsigned_8_Acc is access all Unsigned_8; - function To_Unsigned_8_Acc is new Ada.Unchecked_Conversion - (Address, Unsigned_8_Acc); - begin - return To_Unsigned_8_Acc (Addr).all; - end Read_Byte; - - procedure Read_ULEB128 (Base : Address; - Off : in out Storage_Offset; - Res : out Unsigned_32) - is - B : Unsigned_8; - Shift : Integer; - begin - Res := 0; - Shift := 0; - loop - B := Read_Byte (Base + Off); - Off := Off + 1; - Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift); - exit when (B and 16#80#) = 0; - Shift := Shift + 7; - end loop; - end Read_ULEB128; - - procedure Read_SLEB128 (Base : Address; - Off : in out Storage_Offset; - Res : out Unsigned_32) - is - B : Unsigned_8; - Shift : Integer; - begin - Res := 0; - Shift := 0; - loop - B := Read_Byte (Base + Off); - Off := Off + 1; - Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift); - Shift := Shift + 7; - exit when (B and 16#80#) = 0; - end loop; - if Shift < 32 and (Res and Shift_Left (1, Shift - 1)) /= 0 then - Res := Res or Shift_Left (-1, Shift); - end if; - end Read_SLEB128; - - procedure Read_Word4 (Base : Address; - Off : in out Storage_Offset; - Res : out Unsigned_32) - is - B0, B1, B2, B3 : Unsigned_8; - begin - B0 := Read_Byte (Base + Off + 0); - B1 := Read_Byte (Base + Off + 1); - B2 := Read_Byte (Base + Off + 2); - B3 := Read_Byte (Base + Off + 3); - Res := Shift_Left (Unsigned_32 (B3), 24) - or Shift_Left (Unsigned_32 (B2), 16) - or Shift_Left (Unsigned_32 (B1), 8) - or Shift_Left (Unsigned_32 (B0), 0); - Off := Off + 4; - end Read_Word4; - - procedure Read_Word2 (Base : Address; - Off : in out Storage_Offset; - Res : out Unsigned_16) - is - B0, B1 : Unsigned_8; - begin - B0 := Read_Byte (Base + Off + 0); - B1 := Read_Byte (Base + Off + 1); - Res := Shift_Left (Unsigned_16 (B1), 8) - or Shift_Left (Unsigned_16 (B0), 0); - Off := Off + 2; - end Read_Word2; - - procedure Read_Byte (Base : Address; - Off : in out Storage_Offset; - Res : out Unsigned_8) - is - begin - Res := Read_Byte (Base + Off); - Off := Off + 1; - end Read_Byte; - - procedure Disp_Note (Base : Address; Size : Storage_Offset) - is - Off : Storage_Offset; - Namesz : Unsigned_32; - Descsz : Unsigned_32; - Ntype : Unsigned_32; - B : Unsigned_8; - Is_Full : Boolean; - begin - Off := 0; - while Off < Size loop - Read_Word4 (Base, Off, Namesz); - Read_Word4 (Base, Off, Descsz); - Read_Word4 (Base, Off, Ntype); - Put ("type : "); - Put (Hex_Image (Ntype)); - New_Line; - Put ("name : "); - Put (Hex_Image (Namesz)); - Put (" "); - for I in 1 .. Namesz loop - Read_Byte (Base, Off, B); - if B /= 0 then - Put (Character'Val (B)); - end if; - end loop; - if Namesz mod 4 /= 0 then - for I in (Namesz mod 4) .. 3 loop - Read_Byte (Base, Off, B); - end loop; - end if; - New_Line; - Put ("desc : "); - Put (Hex_Image (Descsz)); - Put (" "); - Is_Full := Descsz >= 20; - for I in 1 .. Descsz loop - if Is_Full and (I mod 16) = 1 then - New_Line; - end if; - Read_Byte (Base, Off, B); - Put (' '); - Put (Hex_Image (B)); - end loop; - if Descsz mod 4 /= 0 then - for I in (Descsz mod 4) .. 3 loop - Read_Byte (Base, Off, B); - end loop; - end if; - New_Line; - end loop; - end Disp_Note; - - procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - Disp_Note (Base, Storage_Offset (Shdr.Sh_Size)); - end Disp_Section_Note; - - procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half) - is - Phdr : Elf_Phdr_Acc; - Base : Address; - begin - Phdr := Get_Phdr (File, Index); - Base := Get_Segment_Base (File, Phdr.all); - Disp_Note (Base, Storage_Offset (Phdr.P_Filesz)); - end Disp_Segment_Note; - - - function Get_Dt_Name (Name : Elf_Word) return String is - begin - case Name is - when DT_NULL => - return "NULL"; - when DT_NEEDED => - return "NEEDED"; - when DT_PLTRELSZ => - return "PLTRELSZ"; - when DT_PLTGOT => - return "PLTGOT"; - when DT_HASH => - return "HASH"; - when DT_STRTAB => - return "STRTAB"; - when DT_SYMTAB => - return "SYMTAB"; - when DT_RELA => - return "RELA"; - when DT_RELASZ => - return "RELASZ"; - when DT_RELAENT => - return "RELAENT"; - when DT_STRSZ => - return "STRSZ"; - when DT_SYMENT => - return "SYMENT"; - when DT_INIT => - return "INIT"; - when DT_FINI => - return "FINI"; - when DT_SONAME => - return "SONAME"; - when DT_RPATH => - return "RPATH"; - when DT_SYMBOLIC => - return "SYMBOLIC"; - when DT_REL => - return "REL"; - when DT_RELSZ => - return "RELSZ"; - when DT_RELENT => - return "RELENT"; - when DT_PLTREL => - return "PLTREL"; - when DT_DEBUG => - return "DEBUG"; - when DT_TEXTREL => - return "TEXTREL"; - when DT_JMPREL => - return "JMPREL"; - when DT_BIND_NOW => - return "BIND_NOW"; - when DT_INIT_ARRAY => - return "INIT_ARRAY"; - when DT_FINI_ARRAY => - return "FINI_ARRAY"; - when DT_INIT_ARRAYSZ => - return "INIT_ARRAYSZ"; - when DT_FINI_ARRAYSZ => - return "FINI_ARRAYSZ"; - when DT_RUNPATH => - return "RUNPATH"; - when DT_FLAGS => - return "FLAGS"; --- when DT_ENCODING => --- return "ENCODING"; - when DT_PREINIT_ARRAY => - return "PREINIT_ARRAY"; - when DT_PREINIT_ARRAYSZ => - return "PREINIT_ARRAYSZ"; - when DT_NUM => - return "NUM"; - when DT_LOOS => - return "LOOS"; --- when DT_HIOS => --- return "HIOS"; - when DT_LOPROC => - return "LOPROC"; --- when DT_HIPROC => --- return "HIPROC"; - when DT_VALRNGLO => - return "VALRNGLO"; - when DT_GNU_PRELINKED => - return "GNU_PRELINKED"; - when DT_GNU_CONFLICTSZ => - return "GNU_CONFLICTSZ"; - when DT_GNU_LIBLISTSZ => - return "GNU_LIBLISTSZ"; - when DT_CHECKSUM => - return "CHECKSUM"; - when DT_PLTPADSZ => - return "PLTPADSZ"; - when DT_MOVEENT => - return "MOVEENT"; - when DT_MOVESZ => - return "MOVESZ"; - when DT_FEATURE_1 => - return "FEATURE_1"; - when DT_POSFLAG_1 => - return "POSFLAG_1"; - when DT_SYMINSZ => - return "SYMINSZ"; - when DT_SYMINENT => - return "SYMINENT"; --- when DT_VALRNGHI => --- return "VALRNGHI"; - when DT_ADDRRNGLO => - return "ADDRRNGLO"; - when DT_GNU_CONFLICT => - return "GNU_CONFLICT"; - when DT_GNU_LIBLIST => - return "GNU_LIBLIST"; - when DT_CONFIG => - return "CONFIG"; - when DT_DEPAUDIT => - return "DEPAUDIT"; - when DT_AUDIT => - return "AUDIT"; - when DT_PLTPAD => - return "PLTPAD"; - when DT_MOVETAB => - return "MOVETAB"; - when DT_SYMINFO => - return "SYMINFO"; --- when DT_ADDRRNGHI => --- return "ADDRRNGHI"; - when DT_VERSYM => - return "VERSYM"; - when DT_RELACOUNT => - return "RELACOUNT"; - when DT_RELCOUNT => - return "RELCOUNT"; - when DT_FLAGS_1 => - return "FLAGS_1"; - when DT_VERDEF => - return "VERDEF"; - when DT_VERDEFNUM => - return "VERDEFNUM"; - when DT_VERNEED => - return "VERNEED"; - when DT_VERNEEDNUM => - return "VERNEEDNUM"; - when DT_AUXILIARY => - return "AUXILIARY"; - when DT_FILTER => - return "FILTER"; - when others => - return "?unknown?"; - end case; - end Get_Dt_Name; - - procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - Tag : Unsigned_32; - Val : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Word4 (Base, Off, Tag); - Read_Word4 (Base, Off, Val); - Put ("tag : "); - Put (Hex_Image (Tag)); - Put (" ("); - Put (Get_Dt_Name (Tag)); - Put (")"); - Set_Col (34); - Put ("val : "); - Put (Hex_Image (Val)); - New_Line; - end loop; - end Disp_Dynamic; - - function Get_Dwarf_Form_Name (Name : Unsigned_32) return String - is - use Dwarf; - begin - case Name is - when DW_FORM_Addr => - return "addr"; - when DW_FORM_Block2 => - return "block2"; - when DW_FORM_Block4 => - return "block4"; - when DW_FORM_Data2 => - return "data2"; - when DW_FORM_Data4 => - return "data4"; - when DW_FORM_Data8 => - return "data8"; - when DW_FORM_String => - return "string"; - when DW_FORM_Block => - return "block"; - when DW_FORM_Block1 => - return "block1"; - when DW_FORM_Data1 => - return "data1"; - when DW_FORM_Flag => - return "flag"; - when DW_FORM_Sdata => - return "sdata"; - when DW_FORM_Strp => - return "strp"; - when DW_FORM_Udata => - return "udata"; - when DW_FORM_Ref_Addr => - return "ref_addr"; - when DW_FORM_Ref1 => - return "ref1"; - when DW_FORM_Ref2 => - return "ref2"; - when DW_FORM_Ref4 => - return "ref4"; - when DW_FORM_Ref8 => - return "ref8"; - when DW_FORM_Ref_Udata => - return "ref_udata"; - when DW_FORM_Indirect => - return "indirect"; - when others => - return "unknown"; - end case; - end Get_Dwarf_Form_Name; - - function Get_Dwarf_Tag_Name (Tag : Unsigned_32) return String - is - use Dwarf; - begin - case Tag is - when DW_TAG_Array_Type => - return "array_type"; - when DW_TAG_Class_Type => - return "class_type"; - when DW_TAG_Entry_Point => - return "entry_point"; - when DW_TAG_Enumeration_Type => - return "enumeration_type"; - when DW_TAG_Formal_Parameter => - return "formal_parameter"; - when DW_TAG_Imported_Declaration => - return "imported_declaration"; - when DW_TAG_Label => - return "label"; - when DW_TAG_Lexical_Block => - return "lexical_block"; - when DW_TAG_Member => - return "member"; - when DW_TAG_Pointer_Type => - return "pointer_type"; - when DW_TAG_Reference_Type => - return "reference_type"; - when DW_TAG_Compile_Unit => - return "compile_unit"; - when DW_TAG_String_Type => - return "string_type"; - when DW_TAG_Structure_Type => - return "structure_type"; - when DW_TAG_Subroutine_Type => - return "subroutine_type"; - when DW_TAG_Typedef => - return "typedef"; - when DW_TAG_Union_Type => - return "union_type"; - when DW_TAG_Unspecified_Parameters => - return "unspecified_parameters"; - when DW_TAG_Variant => - return "variant"; - when DW_TAG_Common_Block => - return "common_block"; - when DW_TAG_Common_Inclusion => - return "common_inclusion"; - when DW_TAG_Inheritance => - return "inheritance"; - when DW_TAG_Inlined_Subroutine => - return "inlined_subroutine"; - when DW_TAG_Module => - return "module"; - when DW_TAG_Ptr_To_Member_Type => - return "ptr_to_member_type"; - when DW_TAG_Set_Type => - return "set_type"; - when DW_TAG_Subrange_Type => - return "subrange_type"; - when DW_TAG_With_Stmt => - return "with_stmt"; - when DW_TAG_Access_Declaration => - return "access_declaration"; - when DW_TAG_Base_Type => - return "base_type"; - when DW_TAG_Catch_Block => - return "catch_block"; - when DW_TAG_Const_Type => - return "const_type"; - when DW_TAG_Constant => - return "constant"; - when DW_TAG_Enumerator => - return "enumerator"; - when DW_TAG_File_Type => - return "file_type"; - when DW_TAG_Friend => - return "friend"; - when DW_TAG_Namelist => - return "namelist"; - when DW_TAG_Namelist_Item => - return "namelist_item"; - when DW_TAG_Packed_Type => - return "packed_type"; - when DW_TAG_Subprogram => - return "subprogram"; - when DW_TAG_Template_Type_Parameter => - return "template_type_parameter"; - when DW_TAG_Template_Value_Parameter => - return "template_value_parameter"; - when DW_TAG_Thrown_Type => - return "thrown_type"; - when DW_TAG_Try_Block => - return "try_block"; - when DW_TAG_Variant_Part => - return "variant_part"; - when DW_TAG_Variable => - return "variable"; - when DW_TAG_Volatile_Type => - return "volatile_type"; - when DW_TAG_Dwarf_Procedure => - return "dwarf_procedure"; - when DW_TAG_Restrict_Type => - return "restrict_type"; - when DW_TAG_Interface_Type => - return "interface_type"; - when DW_TAG_Namespace => - return "namespace"; - when DW_TAG_Imported_Module => - return "imported_module"; - when DW_TAG_Unspecified_Type => - return "unspecified_type"; - when DW_TAG_Partial_Unit => - return "partial_unit"; - when DW_TAG_Imported_Unit => - return "imported_unit"; - when DW_TAG_Mutable_Type => - return "mutable_type"; - when others => - return "unknown"; - end case; - end Get_Dwarf_Tag_Name; - - function Get_Dwarf_At_Name (Attr : Unsigned_32) return String - is - use Dwarf; - begin - case Attr is - when DW_AT_Sibling => - return "sibling"; - when DW_AT_Location => - return "location"; - when DW_AT_Name => - return "name"; - when DW_AT_Ordering => - return "ordering"; - when DW_AT_Byte_Size => - return "byte_size"; - when DW_AT_Bit_Offset => - return "bit_offset"; - when DW_AT_Bit_Size => - return "bit_size"; - when DW_AT_Stmt_List => - return "stmt_list"; - when DW_AT_Low_Pc => - return "low_pc"; - when DW_AT_High_Pc => - return "high_pc"; - when DW_AT_Language => - return "language"; - when DW_AT_Discr => - return "discr"; - when DW_AT_Discr_Value => - return "discr_value"; - when DW_AT_Visibility => - return "visibility"; - when DW_AT_Import => - return "import"; - when DW_AT_String_Length => - return "string_length"; - when DW_AT_Common_Reference => - return "common_reference"; - when DW_AT_Comp_Dir => - return "comp_dir"; - when DW_AT_Const_Value => - return "const_value"; - when DW_AT_Containing_Type => - return "containing_type"; - when DW_AT_Default_Value => - return "default_value"; - when DW_AT_Inline => - return "inline"; - when DW_AT_Is_Optional => - return "is_optional"; - when DW_AT_Lower_Bound => - return "lower_bound"; - when DW_AT_Producer => - return "producer"; - when DW_AT_Prototyped => - return "prototyped"; - when DW_AT_Return_Addr => - return "return_addr"; - when DW_AT_Start_Scope => - return "start_scope"; - when DW_AT_Stride_Size => - return "stride_size"; - when DW_AT_Upper_Bound => - return "upper_bound"; - when DW_AT_Abstract_Origin => - return "abstract_origin"; - when DW_AT_Accessibility => - return "accessibility"; - when DW_AT_Address_Class => - return "address_class"; - when DW_AT_Artificial => - return "artificial"; - when DW_AT_Base_Types => - return "base_types"; - when DW_AT_Calling_Convention => - return "calling_convention"; - when DW_AT_Count => - return "count"; - when DW_AT_Data_Member_Location => - return "data_member_location"; - when DW_AT_Decl_Column => - return "decl_column"; - when DW_AT_Decl_File => - return "decl_file"; - when DW_AT_Decl_Line => - return "decl_line"; - when DW_AT_Declaration => - return "declaration"; - when DW_AT_Discr_List => - return "discr_list"; - when DW_AT_Encoding => - return "encoding"; - when DW_AT_External => - return "external"; - when DW_AT_Frame_Base => - return "frame_base"; - when DW_AT_Friend => - return "friend"; - when DW_AT_Identifier_Case => - return "identifier_case"; - when DW_AT_Macro_Info => - return "macro_info"; - when DW_AT_Namelist_Item => - return "namelist_item"; - when DW_AT_Priority => - return "priority"; - when DW_AT_Segment => - return "segment"; - when DW_AT_Specification => - return "specification"; - when DW_AT_Static_Link => - return "static_link"; - when DW_AT_Type => - return "type"; - when DW_AT_Use_Location => - return "use_location"; - when DW_AT_Variable_Parameter => - return "variable_parameter"; - when DW_AT_Virtuality => - return "virtuality"; - when DW_AT_Vtable_Elem_Location => - return "vtable_elem_location"; - when DW_AT_Allocated => - return "allocated"; - when DW_AT_Associated => - return "associated"; - when DW_AT_Data_Location => - return "data_location"; - when DW_AT_Stride => - return "stride"; - when DW_AT_Entry_Pc => - return "entry_pc"; - when DW_AT_Use_UTF8 => - return "use_utf8"; - when DW_AT_Extension => - return "extension"; - when DW_AT_Ranges => - return "ranges"; - when DW_AT_Trampoline => - return "trampoline"; - when DW_AT_Call_Column => - return "call_column"; - when DW_AT_Call_File => - return "call_file"; - when DW_AT_Call_Line => - return "call_line"; - when DW_AT_Description => - return "description"; - when others => - return "unknown"; - end case; - end Get_Dwarf_At_Name; - - procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Old_Off : Storage_Offset; - Off : Storage_Offset; - V : Unsigned_32; - Tag : Unsigned_32; - Name : Unsigned_32; - Form : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Old_Off := Off; - Read_ULEB128 (Base, Off, V); - Put_Line ("abbrev #" & Hex_Image (V) & " at " - & Hex_Image (Unsigned_32 (Old_Off)) & ':'); - if V = 0 then - Put_Line ("pad"); - goto Again; - end if; - Read_ULEB128 (Base, Off, Tag); - Put (" tag: " & Hex_Image (Tag)); - Put (" ("); - Put (Get_Dwarf_Tag_Name (Tag)); - Put ("), children: " & Hex_Image (Read_Byte (Base + Off))); - New_Line; - Off := Off + 1; - loop - Read_ULEB128 (Base, Off, Name); - Read_ULEB128 (Base, Off, Form); - Put (" name: " & Hex_Image (Name)); - Put (" ("); - Put (Get_Dwarf_At_Name (Name)); - Put (")"); - Set_Col (42); - Put ("form: " & Hex_Image (Form)); - Put (" ("); - Put (Get_Dwarf_Form_Name (Form)); - Put (")"); - New_Line; - exit when Name = 0 and Form = 0; - end loop; - << Again >> null; - end loop; - end Disp_Debug_Abbrev; - - type Abbrev_Map_Type is array (Unsigned_32 range <>) of Address; - type Abbrev_Map_Acc is access Abbrev_Map_Type; - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Abbrev_Map_Type, Abbrev_Map_Acc); - - procedure Build_Abbrev_Map (Base : Address; Res : out Abbrev_Map_Acc) - is - Max : Unsigned_32; - Off : Storage_Offset; - V : Unsigned_32; - V1 : Unsigned_32; - N_Res : Abbrev_Map_Acc; - begin - Off := 0; - Max := 0; - Res := new Abbrev_Map_Type (0 .. 128); - Res.all := (others => Null_Address); - loop - Read_ULEB128 (Base, Off, V); - if V > Max then - Max := V; - end if; - exit when V = 0; - if Max > Res.all'Last then - N_Res := new Abbrev_Map_Type (0 .. 2 * Max); - N_Res (Res'Range) := Res.all; - N_Res (Res'Last + 1 .. N_Res'Last) := (others => Null_Address); - Unchecked_Deallocation (Res); - Res := N_Res; - end if; - if Res (V) /= Null_Address then - Put_Line ("!! abbrev override !!"); - return; - end if; - Res (V) := Base + Off; - Read_ULEB128 (Base, Off, V); - -- Skip child flag. - Off := Off + 1; - loop - Read_ULEB128 (Base, Off, V); - Read_ULEB128 (Base, Off, V1); - exit when V = 0 and V1 = 0; - end loop; - end loop; - end Build_Abbrev_Map; - - procedure Disp_Block (Base : Address; - Off : in out Storage_Offset; - Cnt : Unsigned_32) - is - begin - for I in 1 .. Cnt loop - Put (" "); - Put (Hex_Image (Read_Byte (Base + Off + Storage_Offset (I - 1)))); - end loop; - Off := Off + Storage_Offset (Cnt); - end Disp_Block; - - procedure Disp_Dwarf_Form (Base : Address; - Off : in out Storage_Offset; - Form : Unsigned_32) - is - use Dwarf; - begin - case Form is - when DW_FORM_Addr => - declare - V : Unsigned_32; - begin - Read_Word4 (Base, Off, V); - Put ("address: " & Hex_Image (V)); - end; - when DW_FORM_Flag => - declare - V : Unsigned_8; - begin - Read_Byte (Base, Off, V); - Put ("flag: " & Hex_Image (V)); - end; - when DW_FORM_Block1 => - declare - V : Unsigned_8; - begin - Read_Byte (Base, Off, V); - Put ("block1: " & Hex_Image (V)); - Disp_Block (Base, Off, Unsigned_32 (V)); - end; - when DW_FORM_Data1 => - declare - V : Unsigned_8; - begin - Read_Byte (Base, Off, V); - Put ("data1: " & Hex_Image (V)); - end; - when DW_FORM_Data2 => - declare - V : Unsigned_16; - begin - Read_Word2 (Base, Off, V); - Put ("data2: " & Hex_Image (V)); - end; - when DW_FORM_Data4 => - declare - V : Unsigned_32; - begin - Read_Word4 (Base, Off, V); - Put ("data4: " & Hex_Image (V)); - end; - when DW_FORM_Sdata => - declare - V : Unsigned_32; - begin - Read_SLEB128 (Base, Off, V); - Put ("sdata: " & Hex_Image (V)); - end; - when DW_FORM_Udata => - declare - V : Unsigned_32; - begin - Read_ULEB128 (Base, Off, V); - Put ("udata: " & Hex_Image (V)); - end; - when DW_FORM_Ref4 => - declare - V : Unsigned_32; - begin - Read_Word4 (Base, Off, V); - Put ("ref4: " & Hex_Image (V)); - end; - when DW_FORM_Strp => - declare - V : Unsigned_32; - begin - Read_Word4 (Base, Off, V); - Put ("strp: " & Hex_Image (V)); - end; - when DW_FORM_String => - declare - C : Unsigned_8; - begin - Put ("string: "); - loop - Read_Byte (Base, Off, C); - exit when C = 0; - Put (Character'Val (C)); - end loop; - end; - when others => - Put ("???"); - raise Program_Error; - end case; - end Disp_Dwarf_Form; - - function Get_Dwarf_ATE_Name (Val : Unsigned_32) return String - is - use Dwarf; - begin - case Val is - when DW_ATE_Address => - return "address"; - when DW_ATE_Boolean => - return "boolean"; - when DW_ATE_Complex_Float => - return "complex_float"; - when DW_ATE_Float => - return "float"; - when DW_ATE_Signed => - return "signed"; - when DW_ATE_Signed_Char => - return "signed_char"; - when DW_ATE_Unsigned => - return "unsigned"; - when DW_ATE_Unsigned_Char => - return "unsigned_char"; - when DW_ATE_Imaginary_Float => - return "imaginary_float"; - when others => - return "unknown"; - end case; - end Get_Dwarf_ATE_Name; - - procedure Read_Dwarf_Constant (Base : Address; - Off : in out Storage_Offset; - Form : Unsigned_32; - Res : out Unsigned_32) - is - use Dwarf; - begin - case Form is - when DW_FORM_Data1 => - declare - V : Unsigned_8; - begin - Read_Byte (Base, Off, V); - Res := Unsigned_32 (V); - end; - when DW_FORM_Data2 => - declare - V : Unsigned_16; - begin - Read_Word2 (Base, Off, V); - Res := Unsigned_32 (V); - end; - when DW_FORM_Data4 => - declare - V : Unsigned_32; - begin - Read_Word4 (Base, Off, V); - Res := V; - end; - when DW_FORM_Sdata => - declare - V : Unsigned_32; - begin - Read_SLEB128 (Base, Off, V); - Res := V; - end; - when others => - raise Program_Error; - end case; - end Read_Dwarf_Constant; - - procedure Disp_Dwarf_Encoding - (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) - is - Val : Unsigned_32; - begin - Read_Dwarf_Constant (Base, Off, Form, Val); - Put (Get_Dwarf_ATE_Name (Val)); - end Disp_Dwarf_Encoding; - - function Get_Dwarf_Lang_Name (Lang : Unsigned_32) return String - is - use Dwarf; - begin - case Lang is - when DW_LANG_C89 => - return "C89"; - when DW_LANG_C => - return "C"; - when DW_LANG_Ada83 => - return "Ada83"; - when DW_LANG_C_Plus_Plus => - return "C_Plus_Plus"; - when DW_LANG_Cobol74 => - return "Cobol74"; - when DW_LANG_Cobol85 => - return "Cobol85"; - when DW_LANG_Fortran77 => - return "Fortran77"; - when DW_LANG_Fortran90 => - return "Fortran90"; - when DW_LANG_Pascal83 => - return "Pascal83"; - when DW_LANG_Modula2 => - return "Modula2"; - when DW_LANG_Java => - return "Java"; - when DW_LANG_C99 => - return "C99"; - when DW_LANG_Ada95 => - return "Ada95"; - when DW_LANG_Fortran95 => - return "Fortran95"; - when DW_LANG_PLI => - return "PLI"; - when others => - return "?unknown?"; - end case; - end Get_Dwarf_Lang_Name; - - procedure Disp_Dwarf_Language - (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) - is - Val : Unsigned_32; - begin - Read_Dwarf_Constant (Base, Off, Form, Val); - Put (Get_Dwarf_Lang_Name (Val)); - end Disp_Dwarf_Language; - - function Get_Dwarf_Op_Name (Op : Unsigned_8) return String - is - use Dwarf; - begin - case Op is - when DW_OP_Addr => - return "addr"; - when DW_OP_Deref => - return "deref"; - when DW_OP_Const1u => - return "const1u"; - when DW_OP_Const1s => - return "const1s"; - when DW_OP_Const2u => - return "const2u"; - when DW_OP_Const2s => - return "const2s"; - when DW_OP_Const4u => - return "const4u"; - when DW_OP_Const4s => - return "const4s"; - when DW_OP_Const8u => - return "const8u"; - when DW_OP_Const8s => - return "const8s"; - when DW_OP_Constu => - return "constu"; - when DW_OP_Consts => - return "consts"; - when DW_OP_Dup => - return "dup"; - when DW_OP_Drop => - return "drop"; - when DW_OP_Over => - return "over"; - when DW_OP_Pick => - return "pick"; - when DW_OP_Swap => - return "swap"; - when DW_OP_Rot => - return "rot"; - when DW_OP_Xderef => - return "xderef"; - when DW_OP_Abs => - return "abs"; - when DW_OP_And => - return "and"; - when DW_OP_Div => - return "div"; - when DW_OP_Minus => - return "minus"; - when DW_OP_Mod => - return "mod"; - when DW_OP_Mul => - return "mul"; - when DW_OP_Neg => - return "neg"; - when DW_OP_Not => - return "not"; - when DW_OP_Or => - return "or"; - when DW_OP_Plus => - return "plus"; - when DW_OP_Plus_Uconst => - return "plus_uconst"; - when DW_OP_Shl => - return "shl"; - when DW_OP_Shr => - return "shr"; - when DW_OP_Shra => - return "shra"; - when DW_OP_Xor => - return "xor"; - when DW_OP_Skip => - return "skip"; - when DW_OP_Bra => - return "bra"; - when DW_OP_Eq => - return "eq"; - when DW_OP_Ge => - return "ge"; - when DW_OP_Gt => - return "gt"; - when DW_OP_Le => - return "le"; - when DW_OP_Lt => - return "lt"; - when DW_OP_Ne => - return "ne"; - when DW_OP_Lit0 => - return "lit0"; - when DW_OP_Lit1 => - return "lit1"; - when DW_OP_Lit2 => - return "lit2"; - when DW_OP_Lit3 => - return "lit3"; - when DW_OP_Lit4 => - return "lit4"; - when DW_OP_Lit5 => - return "lit5"; - when DW_OP_Lit6 => - return "lit6"; - when DW_OP_Lit7 => - return "lit7"; - when DW_OP_Lit8 => - return "lit8"; - when DW_OP_Lit9 => - return "lit9"; - when DW_OP_Lit10 => - return "lit10"; - when DW_OP_Lit11 => - return "lit11"; - when DW_OP_Lit12 => - return "lit12"; - when DW_OP_Lit13 => - return "lit13"; - when DW_OP_Lit14 => - return "lit14"; - when DW_OP_Lit15 => - return "lit15"; - when DW_OP_Lit16 => - return "lit16"; - when DW_OP_Lit17 => - return "lit17"; - when DW_OP_Lit18 => - return "lit18"; - when DW_OP_Lit19 => - return "lit19"; - when DW_OP_Lit20 => - return "lit20"; - when DW_OP_Lit21 => - return "lit21"; - when DW_OP_Lit22 => - return "lit22"; - when DW_OP_Lit23 => - return "lit23"; - when DW_OP_Lit24 => - return "lit24"; - when DW_OP_Lit25 => - return "lit25"; - when DW_OP_Lit26 => - return "lit26"; - when DW_OP_Lit27 => - return "lit27"; - when DW_OP_Lit28 => - return "lit28"; - when DW_OP_Lit29 => - return "lit29"; - when DW_OP_Lit30 => - return "lit30"; - when DW_OP_Lit31 => - return "lit31"; - when DW_OP_Reg0 => - return "reg0"; - when DW_OP_Reg1 => - return "reg1"; - when DW_OP_Reg2 => - return "reg2"; - when DW_OP_Reg3 => - return "reg3"; - when DW_OP_Reg4 => - return "reg4"; - when DW_OP_Reg5 => - return "reg5"; - when DW_OP_Reg6 => - return "reg6"; - when DW_OP_Reg7 => - return "reg7"; - when DW_OP_Reg8 => - return "reg8"; - when DW_OP_Reg9 => - return "reg9"; - when DW_OP_Reg10 => - return "reg10"; - when DW_OP_Reg11 => - return "reg11"; - when DW_OP_Reg12 => - return "reg12"; - when DW_OP_Reg13 => - return "reg13"; - when DW_OP_Reg14 => - return "reg14"; - when DW_OP_Reg15 => - return "reg15"; - when DW_OP_Reg16 => - return "reg16"; - when DW_OP_Reg17 => - return "reg17"; - when DW_OP_Reg18 => - return "reg18"; - when DW_OP_Reg19 => - return "reg19"; - when DW_OP_Reg20 => - return "reg20"; - when DW_OP_Reg21 => - return "reg21"; - when DW_OP_Reg22 => - return "reg22"; - when DW_OP_Reg23 => - return "reg23"; - when DW_OP_Reg24 => - return "reg24"; - when DW_OP_Reg25 => - return "reg25"; - when DW_OP_Reg26 => - return "reg26"; - when DW_OP_Reg27 => - return "reg27"; - when DW_OP_Reg28 => - return "reg28"; - when DW_OP_Reg29 => - return "reg29"; - when DW_OP_Reg30 => - return "reg30"; - when DW_OP_Reg31 => - return "reg31"; - when DW_OP_Breg0 => - return "breg0"; - when DW_OP_Breg1 => - return "breg1"; - when DW_OP_Breg2 => - return "breg2"; - when DW_OP_Breg3 => - return "breg3"; - when DW_OP_Breg4 => - return "breg4"; - when DW_OP_Breg5 => - return "breg5"; - when DW_OP_Breg6 => - return "breg6"; - when DW_OP_Breg7 => - return "breg7"; - when DW_OP_Breg8 => - return "breg8"; - when DW_OP_Breg9 => - return "breg9"; - when DW_OP_Breg10 => - return "breg10"; - when DW_OP_Breg11 => - return "breg11"; - when DW_OP_Breg12 => - return "breg12"; - when DW_OP_Breg13 => - return "breg13"; - when DW_OP_Breg14 => - return "breg14"; - when DW_OP_Breg15 => - return "breg15"; - when DW_OP_Breg16 => - return "breg16"; - when DW_OP_Breg17 => - return "breg17"; - when DW_OP_Breg18 => - return "breg18"; - when DW_OP_Breg19 => - return "breg19"; - when DW_OP_Breg20 => - return "breg20"; - when DW_OP_Breg21 => - return "breg21"; - when DW_OP_Breg22 => - return "breg22"; - when DW_OP_Breg23 => - return "breg23"; - when DW_OP_Breg24 => - return "breg24"; - when DW_OP_Breg25 => - return "breg25"; - when DW_OP_Breg26 => - return "breg26"; - when DW_OP_Breg27 => - return "breg27"; - when DW_OP_Breg28 => - return "breg28"; - when DW_OP_Breg29 => - return "breg29"; - when DW_OP_Breg30 => - return "breg30"; - when DW_OP_Breg31 => - return "breg31"; - when DW_OP_Regx => - return "regx"; - when DW_OP_Fbreg => - return "fbreg"; - when DW_OP_Bregx => - return "bregx"; - when DW_OP_Piece => - return "piece"; - when DW_OP_Deref_Size => - return "deref_size"; - when DW_OP_Xderef_Size => - return "xderef_size"; - when DW_OP_Nop => - return "nop"; - when DW_OP_Push_Object_Address => - return "push_object_address"; - when DW_OP_Call2 => - return "call2"; - when DW_OP_Call4 => - return "call4"; - when DW_OP_Call_Ref => - return "call_ref"; - when others => - return "unknown"; - end case; - end Get_Dwarf_Op_Name; - - procedure Read_Dwarf_Block (Base : Address; - Off : in out Storage_Offset; - Form : Unsigned_32; - B : out Address; - L : out Unsigned_32) - is - use Dwarf; - begin - case Form is - when DW_FORM_Block1 => - B := Base + Off + 1; - L := Unsigned_32 (Read_Byte (Base + Off)); - Off := Off + 1; - when others => - raise Program_Error; - end case; - Off := Off + Storage_Offset (L); - end Read_Dwarf_Block; - - procedure Disp_Dwarf_Location - (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) - is - use Dwarf; - B : Address; - L : Unsigned_32; - Op : Unsigned_8; - Boff : Storage_Offset; - Is_Full : Boolean; - begin - Read_Dwarf_Block (Base, Off, Form, B, L); - if L = 0 then - return; - end if; - Is_Full := L > 6; - Boff := 0; - while Boff < Storage_Offset (L) loop - if Is_Full then - New_Line; - Put (" "); - Put (Hex_Image (Unsigned_32 (Boff))); - Put (": "); - end if; - Op := Read_Byte (B + Boff); - Put (' '); - Put (Get_Dwarf_Op_Name (Op)); - Boff := Boff + 1; - case Op is - when DW_OP_Addr => - declare - V : Unsigned_32; - begin - Read_Word4 (B, Boff, V); - Put (':'); - Put (Hex_Image (V)); - end; - when DW_OP_Deref => - null; - when DW_OP_Const1u - | DW_OP_Const1s => - declare - V : Unsigned_8; - begin - Read_Byte (B, Boff, V); - Put (':'); - Put (Hex_Image (V)); - end; --- DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant --- DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant --- DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant --- DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant --- DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant --- DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant --- DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant --- DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant --- DW_OP_Dup : constant := 16#12#; -- 0 --- DW_OP_Drop : constant := 16#13#; -- 0 --- DW_OP_Over : constant := 16#14#; -- 0 --- DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index - - when DW_OP_Swap - | DW_OP_Rot - | DW_OP_Xderef - | DW_OP_Abs - | DW_OP_And - | DW_OP_Div - | DW_OP_Minus - | DW_OP_Mod - | DW_OP_Mul - | DW_OP_Neg - | DW_OP_Not - | DW_OP_Or - | DW_OP_Plus => - null; - when DW_OP_Plus_Uconst - | DW_OP_Piece - | DW_OP_Regx => - declare - V : Unsigned_32; - begin - Read_ULEB128 (B, Boff, V); - Put (':'); - Put (Hex_Image (V)); - end; - when DW_OP_Shl - | DW_OP_Shr - | DW_OP_Shra - | DW_OP_Xor => - null; - when DW_OP_Skip - | DW_OP_Bra => - declare - V : Unsigned_16; - begin - Read_Word2 (B, Boff, V); - Put (':'); - Put (Hex_Image (V)); - Put (" (@"); - -- FIXME: signed - Put (Hex_Image (Unsigned_32 (Boff) + Unsigned_32 (V))); - Put (")"); - end; - when DW_OP_Eq - | DW_OP_Ge - | DW_OP_Gt - | DW_OP_Le - | DW_OP_Lt - | DW_OP_Ne => - null; - when DW_OP_Lit0 .. DW_OP_Lit31 => - null; - when DW_OP_Reg0 .. DW_OP_Reg31 => - null; - when DW_OP_Breg0 .. DW_OP_Breg31 - | DW_OP_Fbreg => - declare - V : Unsigned_32; - begin - Read_SLEB128 (B, Boff, V); - Put (':'); - Put (Hex_Image (V)); - end; - --- DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register --- DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset --- DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved --- DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved - when DW_OP_Nop => - null; --- DW_OP_Push_Object_Address : constant := 16#97#; -- 0 --- DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE --- DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE --- DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE - when others => - raise Program_Error; - end case; - end loop; - end Disp_Dwarf_Location; - - procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half) - is - use Dwarf; - - Abbrev_Index : Elf_Half; - Abbrev_Base : Address; - Map : Abbrev_Map_Acc; - Abbrev : Address; - - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - Aoff : Storage_Offset; - Old_Off : Storage_Offset; - - Len : Unsigned_32; - Ver : Unsigned_16; - Abbrev_Off : Unsigned_32; - Ptr_Sz : Unsigned_8; - Last : Storage_Offset; - Num : Unsigned_32; - - Tag : Unsigned_32; - Name : Unsigned_32; - Form : Unsigned_32; - - Level : Unsigned_8; - begin - Abbrev_Index := Get_Section_By_Name (File, ".debug_abbrev"); - Abbrev_Base := Get_Section_Base (File, Abbrev_Index); - Map := null; - - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Put_Line ("Compilation unit at #" - & Hex_Image (Unsigned_32 (Off)) & ":"); - Read_Word4 (Base, Off, Len); - Last := Off + Storage_Offset (Len); - Read_Word2 (Base, Off, Ver); - Read_Word4 (Base, Off, Abbrev_Off); - Read_Byte (Base, Off, Ptr_Sz); - Put (' '); - Put ("length: " & Hex_Image (Len)); - Put (", version: " & Hex_Image (Ver)); - Put (", abbrev offset: " & Hex_Image (Abbrev_Off)); - Put (", ptr_sz: " & Hex_Image (Ptr_Sz)); - New_Line; - Level := 0; - - Build_Abbrev_Map (Abbrev_Base + Storage_Offset (Abbrev_Off), Map); - loop - << Again >> null; - exit when Off >= Last; - Old_Off := Off; - Read_ULEB128 (Base, Off, Num); - Put ("<" & Hex_Image (Unsigned_32 (Old_Off)) & ">"); - Put ("<" & Hex_Image (Level) & ">"); - Put (" with abbrev #" & Hex_Image (Num)); - if Num = 0 then - Level := Level - 1; - New_Line; - goto Again; - end if; - if Num <= Map.all'Last then - Abbrev := Map (Num); - else - Abbrev := Null_Address; - end if; - if Abbrev = Null_Address then - New_Line; - Put ("!! abbrev #" & Hex_Image (Num) & " does not exist !!"); - New_Line; - return; - end if; - Aoff := 0; - Read_ULEB128 (Abbrev, Aoff, Tag); - if Read_Byte (Abbrev + Aoff) /= 0 then - Put (" [has_child]"); - Level := Level + 1; - end if; - New_Line; - - -- skip child. - Aoff := Aoff + 1; - Put (" tag: " & Hex_Image (Tag)); - Put (" ("); - Put (Get_Dwarf_Tag_Name (Tag)); - Put (")"); - New_Line; - - loop - Read_ULEB128 (Abbrev, Aoff, Name); - Read_ULEB128 (Abbrev, Aoff, Form); - exit when Name = 0 and Form = 0; - Put (" "); - Put (Get_Dwarf_At_Name (Name)); - Set_Col (24); - Put (": "); - Old_Off := Off; - Disp_Dwarf_Form (Base, Off, Form); - case Name is - when DW_AT_Encoding => - Put (": "); - Disp_Dwarf_Encoding (Base, Old_Off, Form); - when DW_AT_Location - | DW_AT_Frame_Base - | DW_AT_Data_Member_Location => - Put (":"); - Disp_Dwarf_Location (Base, Old_Off, Form); - when DW_AT_Language => - Put (": "); - Disp_Dwarf_Language (Base, Old_Off, Form); - when others => - null; - end case; - New_Line; - end loop; - end loop; - Unchecked_Deallocation (Map); - New_Line; - end loop; - end Disp_Debug_Info; - - function Get_Phdr_Type_Name (Ptype : Elf_Word) return String is - begin - case Ptype is - when PT_NULL => - return "NULL"; - when PT_LOAD => - return "LOAD"; - when PT_DYNAMIC => - return "DYNAMIC"; - when PT_INTERP => - return "INTERP"; - when PT_NOTE => - return "NOTE"; - when PT_SHLIB => - return "SHLIB"; - when PT_PHDR => - return "PHDR"; - when PT_TLS => - return "TLS"; - when PT_NUM => - return "NUM"; - when PT_GNU_EH_FRAME => - return "GNU_EH_FRAME"; - when PT_SUNWBSS => - return "SUNWBSS"; - when PT_SUNWSTACK => - return "SUNWSTACK"; - when others => - return "?unknown?"; - end case; - end Get_Phdr_Type_Name; - - procedure Disp_Phdr (Phdr : Elf_Phdr) - is - begin - Put ("type : " & Hex_Image (Phdr.P_Type)); - Put (" "); - Put (Get_Phdr_Type_Name (Phdr.P_Type)); - New_Line; - Put ("offset: " & Hex_Image (Phdr.P_Offset)); - Put (" vaddr: " & Hex_Image (Phdr.P_Vaddr)); - Put (" paddr: " & Hex_Image (Phdr.P_Paddr)); - New_Line; - Put ("filesz: " & Hex_Image (Phdr.P_Filesz)); - Put (" memsz: " & Hex_Image (Phdr.P_Memsz)); - Put (" align: " & Hex_Image (Phdr.P_Align)); - --New_Line; - Put (" flags: " & Hex_Image (Phdr.P_Flags)); - Put (" ("); - if (Phdr.P_Flags and PF_X) /= 0 then - Put ('X'); - end if; - if (Phdr.P_Flags and PF_W) /= 0 then - Put ('W'); - end if; - if (Phdr.P_Flags and PF_R) /= 0 then - Put ('R'); - end if; - Put (")"); - New_Line; - end Disp_Phdr; - - procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - B : Unsigned_8; - - Len : Unsigned_32; - Ver : Unsigned_16; - Info_Off : Unsigned_32; - Info_Length : Unsigned_32; - Last : Storage_Offset; - Ioff : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Word4 (Base, Off, Len); - Last := Off + Storage_Offset (Len); - Read_Word2 (Base, Off, Ver); - Read_Word4 (Base, Off, Info_Off); - Read_Word4 (Base, Off, Info_Length); - Put ("length: " & Hex_Image (Len)); - Put (", version: " & Hex_Image (Ver)); - Put (", offset: " & Hex_Image (Info_Off)); - Put (", length: " & Hex_Image (Info_Length)); - New_Line; - - loop - Read_Word4 (Base, Off, Ioff); - Put (" "); - Put (Hex_Image (Ioff)); - if Ioff /= 0 then - Put (": "); - loop - Read_Byte (Base, Off, B); - exit when B = 0; - Put (Character'Val (B)); - end loop; - end if; - New_Line; - exit when Ioff = 0; - end loop; - end loop; - end Disp_Debug_Pubnames; - - procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - - Set_Len : Unsigned_32; - Ver : Unsigned_16; - Info_Off : Unsigned_32; - Last : Storage_Offset; - Addr_Sz : Unsigned_8; - Seg_Sz : Unsigned_8; - Pad : Unsigned_32; - - Addr : Unsigned_32; - Len : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Word4 (Base, Off, Set_Len); - Last := Off + Storage_Offset (Set_Len); - Read_Word2 (Base, Off, Ver); - Read_Word4 (Base, Off, Info_Off); - Read_Byte (Base, Off, Addr_Sz); - Read_Byte (Base, Off, Seg_Sz); - Read_Word4 (Base, Off, Pad); - Put ("length: " & Hex_Image (Set_Len)); - Put (", version: " & Hex_Image (Ver)); - Put (", offset: " & Hex_Image (Info_Off)); - Put (", ptr_sz: " & Hex_Image (Addr_Sz)); - Put (", seg_sz: " & Hex_Image (Seg_Sz)); - New_Line; - - loop - Read_Word4 (Base, Off, Addr); - Read_Word4 (Base, Off, Len); - Put (" "); - Put (Hex_Image (Addr)); - Put ('+'); - Put (Hex_Image (Len)); - New_Line; - exit when Addr = 0 and Len = 0; - end loop; - end loop; - end Disp_Debug_Aranges; - - procedure Disp_String (Base : Address; Off : in out Storage_Offset) - is - B : Unsigned_8; - begin - loop - B := Read_Byte (Base + Off); - Off := Off + 1; - exit when B = 0; - Put (Character'Val (B)); - end loop; - end Disp_String; - - procedure Read_String (Base : Address; Off : in out Storage_Offset) - is - B : Unsigned_8; - begin - loop - Read_Byte (Base, Off, B); - exit when B = 0; - end loop; - end Read_String; - - function Get_Dwarf_LNS_Name (Lns : Unsigned_8) return String - is - use Dwarf; - begin - case Lns is - when DW_LNS_Copy => - return "copy"; - when DW_LNS_Advance_Pc => - return "advance_pc"; - when DW_LNS_Advance_Line => - return "advance_line"; - when DW_LNS_Set_File => - return "set_file"; - when DW_LNS_Set_Column => - return "set_column"; - when DW_LNS_Negate_Stmt => - return "negate_stmt"; - when DW_LNS_Set_Basic_Block => - return "set_basic_block"; - when DW_LNS_Const_Add_Pc => - return "const_add_pc"; - when DW_LNS_Fixed_Advance_Pc => - return "fixed_advance_pc"; - when DW_LNS_Set_Prologue_End => - return "set_prologue_end"; - when DW_LNS_Set_Epilogue_Begin => - return "set_epilogue_begin"; - when DW_LNS_Set_Isa => - return "set_isa"; - when others => - return "?unknown?"; - end case; - end Get_Dwarf_LNS_Name; - - procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half) - is - use Dwarf; - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - - type Opc_Length_Type is array (Unsigned_8 range <>) of Unsigned_8; - type Opc_Length_Acc is access Opc_Length_Type; - Opc_Length : Opc_Length_Acc; - - Total_Len : Unsigned_32; - Version : Unsigned_16; - Prolog_Len : Unsigned_32; - Min_Insn_Len : Unsigned_8; - Dflt_Is_Stmt : Unsigned_8; - Line_Base : Unsigned_8; - Line_Range : Unsigned_8; - Opc_Base : Unsigned_8; - - B : Unsigned_8; - Arg : Unsigned_32; - - Old_Off : Storage_Offset; - File_Dir : Unsigned_32; - File_Time : Unsigned_32; - File_Len : Unsigned_32; - - Ext_Len : Unsigned_32; - Ext_Opc : Unsigned_8; - - Last : Storage_Offset; - - Pc : Unsigned_32; - Line : Unsigned_32; - Line_Base2 : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Word4 (Base, Off, Total_Len); - Last := Off + Storage_Offset (Total_Len); - Read_Word2 (Base, Off, Version); - Read_Word4 (Base, Off, Prolog_Len); - Read_Byte (Base, Off, Min_Insn_Len); - Read_Byte (Base, Off, Dflt_Is_Stmt); - Read_Byte (Base, Off, Line_Base); - Read_Byte (Base, Off, Line_Range); - Read_Byte (Base, Off, Opc_Base); - - Pc := 0; - Line := 1; - - Put ("length: " & Hex_Image (Total_Len)); - Put (", version: " & Hex_Image (Version)); - Put (", prolog_len: " & Hex_Image (Prolog_Len)); - New_Line; - Put (" minimum_instruction_len: " & Hex_Image (Min_Insn_Len)); - Put (", default_is_stmt: " & Hex_Image (Dflt_Is_Stmt)); - New_Line; - Put (" line_base: " & Hex_Image (Line_Base)); - Put (", line_range: " & Hex_Image (Line_Range)); - Put (", opc_base: " & Hex_Image (Opc_Base)); - New_Line; - Line_Base2 := Unsigned_32 (Line_Base); - if (Line_Base and 16#80#) /= 0 then - Line_Base2 := Line_Base2 or 16#Ff_Ff_Ff_00#; - end if; - Put_Line ("standard_opcode_length:"); - Opc_Length := new Opc_Length_Type (1 .. Opc_Base - 1); - for I in 1 .. Opc_Base - 1 loop - Read_Byte (Base, Off, B); - Put (' '); - Put (Hex_Image (I)); - Put (" => "); - Put (Hex_Image (B)); - Opc_Length (I) := B; - New_Line; - end loop; - Put_Line ("include_directories:"); - loop - B := Read_Byte (Base + Off); - exit when B = 0; - Put (' '); - Disp_String (Base, Off); - New_Line; - end loop; - Off := Off + 1; - Put_Line ("file_names:"); - loop - B := Read_Byte (Base + Off); - exit when B = 0; - Old_Off := Off; - Read_String (Base, Off); - Read_ULEB128 (Base, Off, File_Dir); - Read_ULEB128 (Base, Off, File_Time); - Read_ULEB128 (Base, Off, File_Len); - Put (' '); - Put (Hex_Image (File_Dir)); - Put (' '); - Put (Hex_Image (File_Time)); - Put (' '); - Put (Hex_Image (File_Len)); - Put (' '); - Disp_String (Base, Old_Off); - New_Line; - end loop; - Off := Off + 1; - - while Off < Last loop - Put (" "); - Read_Byte (Base, Off, B); - Put (Hex_Image (B)); - Old_Off := Off; - if B < Opc_Base then - case B is - when 0 => - Put (" (extended)"); - Read_ULEB128 (Base, Off, Ext_Len); - Put (", len: "); - Put (Hex_Image (Ext_Len)); - Old_Off := Off; - Read_Byte (Base, Off, Ext_Opc); - Put (" opc:"); - Put (Hex_Image (Ext_Opc)); - Off := Old_Off + Storage_Offset (Ext_Len); - when others => - Put (" ("); - Put (Get_Dwarf_LNS_Name (B)); - Put (")"); - Set_Col (20); - for J in 1 .. Opc_Length (B) loop - Read_ULEB128 (Base, Off, Arg); - Put (" "); - Put (Hex_Image (Arg)); - end loop; - end case; - case B is - when DW_LNS_Copy => - Put (" pc="); - Put (Hex_Image (Pc)); - Put (", line="); - Put (Unsigned_32'Image (Line)); - when DW_LNS_Advance_Pc => - Read_ULEB128 (Base, Old_Off, Arg); - Pc := Pc + Arg * Unsigned_32 (Min_Insn_Len); - Put (" pc="); - Put (Hex_Image (Pc)); - when DW_LNS_Advance_Line => - Read_SLEB128 (Base, Old_Off, Arg); - Line := Line + Arg; - Put (" line="); - Put (Unsigned_32'Image (Line)); - when DW_LNS_Set_File => - null; - when DW_LNS_Set_Column => - null; - when DW_LNS_Negate_Stmt => - null; - when DW_LNS_Set_Basic_Block => - null; - when DW_LNS_Const_Add_Pc => - Pc := Pc + Unsigned_32 ((255 - Opc_Base) / Line_Range) - * Unsigned_32 (Min_Insn_Len); - Put (" pc="); - Put (Hex_Image (Pc)); - when others => - null; - end case; - New_Line; - else - B := B - Opc_Base; - Pc := Pc + Unsigned_32 (B / Line_Range) - * Unsigned_32 (Min_Insn_Len); - Line := Line + Line_Base2 + Unsigned_32 (B mod Line_Range); - Put (" pc="); - Put (Hex_Image (Pc)); - Put (", line="); - Put (Unsigned_32'Image (Line)); - New_Line; - end if; - end loop; - end loop; - end Disp_Debug_Line; - - function Get_Dwarf_Cfi_Name (Cfi : Unsigned_8) return String - is - use Dwarf; - begin - case Cfi is - when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max => - return "advance_loc"; - when DW_CFA_Offset_Min .. DW_CFA_Offset_Max => - return "offset"; - when DW_CFA_Restore_Min .. DW_CFA_Restore_Max => - return "restore"; - when DW_CFA_Nop => - return "nop"; - when DW_CFA_Set_Loc => - return "set_loc"; - when DW_CFA_Advance_Loc1 => - return "advance_loc1"; - when DW_CFA_Advance_Loc2 => - return "advance_loc2"; - when DW_CFA_Advance_Loc4 => - return "advance_loc4"; - when DW_CFA_Offset_Extended => - return "offset_extended"; - when DW_CFA_Restore_Extended => - return "restore_extended"; - when DW_CFA_Undefined => - return "undefined"; - when DW_CFA_Same_Value => - return "same_value"; - when DW_CFA_Register => - return "register"; - when DW_CFA_Remember_State => - return "remember_state"; - when DW_CFA_Restore_State => - return "restore_state"; - when DW_CFA_Def_Cfa => - return "def_cfa"; - when DW_CFA_Def_Cfa_Register => - return "def_cfa_register"; - when DW_CFA_Def_Cfa_Offset => - return "def_cfa_offset"; - when DW_CFA_Def_Cfa_Expression => - return "def_cfa_expression"; - when others => - return "?unknown?"; - end case; - end Get_Dwarf_Cfi_Name; - - procedure Disp_Cfi (Base : Address; Length : Storage_Count) - is - use Dwarf; - L : Storage_Offset; - Op : Unsigned_8; - Off : Unsigned_32; - Reg : Unsigned_32; - begin - L := 0; - while L < Length loop - Op := Read_Byte (Base + L); - Put (" "); - Put (Hex_Image (Op)); - Put (" "); - Put (Get_Dwarf_Cfi_Name (Op)); - Put (" "); - L := L + 1; - case Op is - when DW_CFA_Nop => - null; - when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max => - Put (Hex_Image (Op and 16#3f#)); - when DW_CFA_Offset_Min .. DW_CFA_Offset_Max => - Read_ULEB128 (Base, L, Off); - Put ("reg:"); - Put (Hex_Image (Op and 16#3f#)); - Put (", offset:"); - Put (Hex_Image (Off)); - when DW_CFA_Def_Cfa => - Read_ULEB128 (Base, L, Reg); - Read_ULEB128 (Base, L, Off); - Put ("reg:"); - Put (Hex_Image (Reg)); - Put (", offset:"); - Put (Hex_Image (Off)); - when DW_CFA_Def_Cfa_Offset => - Read_ULEB128 (Base, L, Off); - Put (Hex_Image (Off)); - when DW_CFA_Def_Cfa_Register => - Read_ULEB128 (Base, L, Reg); - Put ("reg:"); - Put (Hex_Image (Reg)); - when others => - Put ("?unknown?"); - New_Line; - exit; - end case; - New_Line; - end loop; - end Disp_Cfi; - - procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - Old_Off : Storage_Offset; - - Length : Unsigned_32; - Cie_Id : Unsigned_32; - Version : Unsigned_8; - Augmentation : Unsigned_8; - Code_Align : Unsigned_32; - Data_Align : Unsigned_32; - Ret_Addr_Reg : Unsigned_8; - - Init_Loc : Unsigned_32; - Addr_Rng : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Word4 (Base, Off, Length); - Old_Off := Off; - - Read_Word4 (Base, Off, Cie_Id); - if Cie_Id = 16#Ff_Ff_Ff_Ff# then - Read_Byte (Base, Off, Version); - Read_Byte (Base, Off, Augmentation); - Put ("length: "); - Put (Hex_Image (Length)); - Put (", CIE_id: "); - Put (Hex_Image (Cie_Id)); - Put (", version: "); - Put (Hex_Image (Version)); - if Augmentation /= 0 then - Put (" +augmentation"); - New_Line; - else - New_Line; - Read_ULEB128 (Base, Off, Code_Align); - Read_SLEB128 (Base, Off, Data_Align); - Read_Byte (Base, Off, Ret_Addr_Reg); - Put ("code_align: "); - Put (Hex_Image (Code_Align)); - Put (", data_align: "); - Put (Hex_Image (Data_Align)); - Put (", ret_addr_reg: "); - Put (Hex_Image (Ret_Addr_Reg)); - New_Line; - Put ("initial instructions:"); - New_Line; - Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off); - end if; - else - Read_Word4 (Base, Off, Init_Loc); - Read_Word4 (Base, Off, Addr_Rng); - Put ("length: "); - Put (Hex_Image (Length)); - Put (", CIE_pointer: "); - Put (Hex_Image (Cie_Id)); - Put (", address_range: "); - Put (Hex_Image (Init_Loc)); - Put ("-"); - Put (Hex_Image (Init_Loc + Addr_Rng)); - New_Line; - Put ("instructions:"); - New_Line; - Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off); - end if; - Off := Old_Off + Storage_Offset (Length); - end loop; - end Disp_Debug_Frame; - - procedure Read_Coded (Base : Address; - Offset : in out Storage_Offset; - Code : Unsigned_8; - Val : out Unsigned_32) - is - use Dwarf; - - V2 : Unsigned_16; - begin - if Code = DW_EH_PE_Omit then - return; - end if; - case Code and DW_EH_PE_Format_Mask is - when DW_EH_PE_Uleb128 => - Read_ULEB128 (Base, Offset, Val); - when DW_EH_PE_Udata2 => - Read_Word2 (Base, Offset, V2); - Val := Unsigned_32 (V2); - when DW_EH_PE_Udata4 => - Read_Word4 (Base, Offset, Val); - when DW_EH_PE_Sleb128 => - Read_SLEB128 (Base, Offset, Val); - when DW_EH_PE_Sdata2 => - Read_Word2 (Base, Offset, V2); - Val := Unsigned_32 (V2); - if (V2 and 16#80_00#) /= 0 then - Val := Val or 16#Ff_Ff_00_00#; - end if; - when DW_EH_PE_Sdata4 => - Read_Word4 (Base, Offset, Val); - when others => - raise Program_Error; - end case; - end Read_Coded; - - procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half) - is - Shdr : Elf_Shdr_Acc; - Base : Address; - Off : Storage_Offset; - - Version : Unsigned_8; - Eh_Frame_Ptr_Enc : Unsigned_8; - Fde_Count_Enc : Unsigned_8; - Table_Enc : Unsigned_8; - - Eh_Frame_Ptr : Unsigned_32; - Fde_Count : Unsigned_32; - - Loc : Unsigned_32; - Addr : Unsigned_32; - begin - Shdr := Get_Shdr (File, Index); - Base := Get_Section_Base (File, Shdr.all); - - Off := 0; - while Off < Storage_Offset (Shdr.Sh_Size) loop - Read_Byte (Base, Off, Version); - Read_Byte (Base, Off, Eh_Frame_Ptr_Enc); - Read_Byte (Base, Off, Fde_Count_Enc); - Read_Byte (Base, Off, Table_Enc); - Put ("version: "); - Put (Hex_Image (Version)); - Put (", encodings: ptr:"); - Put (Hex_Image (Eh_Frame_Ptr_Enc)); - Put (" count:"); - Put (Hex_Image (Fde_Count_Enc)); - Put (" table:"); - Put (Hex_Image (Table_Enc)); - New_Line; - Read_Coded (Base, Off, Eh_Frame_Ptr_Enc, Eh_Frame_Ptr); - Read_Coded (Base, Off, Fde_Count_Enc, Fde_Count); - Put ("eh_frame_ptr: "); - Put (Hex_Image (Eh_Frame_Ptr)); - Put (", fde_count: "); - Put (Hex_Image (Fde_Count)); - New_Line; - for I in 1 .. Fde_Count loop - Read_Coded (Base, Off, Table_Enc, Loc); - Read_Coded (Base, Off, Table_Enc, Addr); - Put (" init loc: "); - Put (Hex_Image (Loc)); - Put (", addr : "); - Put (Hex_Image (Addr)); - New_Line; - end loop; - end loop; - end Disp_Eh_Frame_Hdr; -end Elfdumper; diff --git a/ortho/mcode/elfdumper.ads b/ortho/mcode/elfdumper.ads deleted file mode 100644 index 0227f0f41..000000000 --- a/ortho/mcode/elfdumper.ads +++ /dev/null @@ -1,164 +0,0 @@ --- ELF dumper (library). --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; use System; -with Elf_Common; use Elf_Common; -with Elf_Arch; use Elf_Arch; -with Ada.Unchecked_Conversion; - -package Elfdumper is - procedure Disp_Ehdr (Ehdr : Elf_Ehdr); - - type Strtab_Fat_Type is array (Elf_Size) of Character; - type Strtab_Fat_Acc is access all Strtab_Fat_Type; - - type Strtab_Type is record - Base : Strtab_Fat_Acc; - Length : Elf_Size; - end record; - - Null_Strtab : constant Strtab_Type := (null, 0); - - Nul : constant Character := Character'Val (0); - - function Get_String (Strtab : Strtab_Type; N : Elf_Size) - return String; - - procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type); - - type Elf_Shdr_Array is array (Elf_Half range <>) of Elf_Shdr; - - type Elf_File is limited private; - type Elf_File_Status is - ( - -- No error. - Status_Ok, - - -- Cannot open file. - Status_Open_Failure, - - Status_Bad_File, - Status_Memory, - Status_Read_Error, - Status_Bad_Magic, - Status_Bad_Class - ); - - procedure Open_File (File : out Elf_File; Filename : String); - - function Get_Status (File : Elf_File) return Elf_File_Status; - - type Elf_Ehdr_Acc is access all Elf_Ehdr; - - function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc; - - procedure Load_Shdr (File : in out Elf_File); - - type Elf_Shdr_Acc is access all Elf_Shdr; - - function Get_Shdr (File : Elf_File; Index : Elf_Half) - return Elf_Shdr_Acc; - - function Get_Shdr_Type_Name (Stype : Elf_Word) return String; - - procedure Load_Phdr (File : in out Elf_File); - - type Elf_Phdr_Acc is access all Elf_Phdr; - - function Get_Phdr (File : Elf_File; Index : Elf_Half) - return Elf_Phdr_Acc; - - function Get_Segment_Base (File : Elf_File; Index : Elf_Half) - return Address; - - function Get_Sh_Strtab (File : Elf_File) return Strtab_Type; - - procedure Disp_Sym (File : Elf_File; - Sym : Elf_Sym; - Strtab : Strtab_Type); - - procedure Disp_Symtab (File : Elf_File; Index : Elf_Half); - procedure Disp_Strtab (File : Elf_File; Index : Elf_Half); - - function Get_Section_Name (File : Elf_File; Index : Elf_Half) - return String; - - function Get_Section_By_Name (File : Elf_File; Name : String) - return Elf_Half; - - procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half); - procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half); - procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half); - procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half); - procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half); - procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half); - procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half); - - procedure Disp_Phdr (Phdr : Elf_Phdr); - - procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half); - procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half); - - procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half); -private - use System; - - function To_Strtab_Fat_Acc is new Ada.Unchecked_Conversion - (Address, Strtab_Fat_Acc); - - type String_Acc is access String; - - function To_Elf_Ehdr_Acc is new Ada.Unchecked_Conversion - (Address, Elf_Ehdr_Acc); - - function To_Elf_Phdr_Acc is new Ada.Unchecked_Conversion - (Address, Elf_Phdr_Acc); - - function To_Elf_Shdr_Acc is new Ada.Unchecked_Conversion - (Address, Elf_Shdr_Acc); - - type Elf_Sym_Acc is access all Elf_Sym; - function To_Elf_Sym_Acc is new Ada.Unchecked_Conversion - (Address, Elf_Sym_Acc); - - type Elf_Shdr_Arr is array (Elf_Half) of Elf_Shdr; - - type Elf_Shdr_Arr_Acc is access all Elf_Shdr_Arr; - function To_Elf_Shdr_Arr_Acc is new Ada.Unchecked_Conversion - (Address, Elf_Shdr_Arr_Acc); - - type Elf_File is record - -- Name of the file. - Filename : String_Acc; - - -- Status, used to report errors. - Status : Elf_File_Status; - - -- Length of the file. - Length : Elf_Off; - - -- File contents. - Base : Address; - - Ehdr : Elf_Ehdr_Acc; - - Shdr_Base : Address; - Sh_Strtab : Strtab_Type; - - Phdr_Base : Address; - end record; -end Elfdumper; diff --git a/ortho/mcode/hex_images.adb b/ortho/mcode/hex_images.adb deleted file mode 100644 index a9dca324d..000000000 --- a/ortho/mcode/hex_images.adb +++ /dev/null @@ -1,71 +0,0 @@ --- To hexadecimal conversions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Conversion; - -package body Hex_Images is - type Hex_Str_Type is array (0 .. 15) of Character; - Hexdigits : constant Hex_Str_Type := "0123456789abcdef"; - - function Hex_Image (B : Unsigned_8) return String is - Res : String (1 .. 2); - begin - for I in 1 .. 2 loop - Res (I) := Hexdigits - (Natural (Shift_Right (B, 8 - 4 * I) and 16#0f#)); - end loop; - return Res; - end Hex_Image; - - function Conv is new Ada.Unchecked_Conversion - (Source => Integer_32, Target => Unsigned_32); - - function Hex_Image (W : Unsigned_32) return String is - Res : String (1 .. 8); - begin - for I in 1 .. 8 loop - Res (I) := Hexdigits - (Natural (Shift_Right (W, 32 - 4 * I) and 16#0f#)); - end loop; - return Res; - end Hex_Image; - - function Hex_Image (W : Unsigned_64) return String is - Res : String (1 .. 16); - begin - for I in 1 .. 16 loop - Res (I) := Hexdigits - (Natural (Shift_Right (W, 64 - 4 * I) and 16#0f#)); - end loop; - return Res; - end Hex_Image; - - function Hex_Image (W : Unsigned_16) return String is - Res : String (1 .. 4); - begin - for I in 1 .. 4 loop - Res (I) := Hexdigits - (Natural (Shift_Right (W, 16 - 4 * I) and 16#0f#)); - end loop; - return Res; - end Hex_Image; - - function Hex_Image (W : Integer_32) return String is - begin - return Hex_Image (Conv (W)); - end Hex_Image; -end Hex_Images; diff --git a/ortho/mcode/hex_images.ads b/ortho/mcode/hex_images.ads deleted file mode 100644 index 830d2ec43..000000000 --- a/ortho/mcode/hex_images.ads +++ /dev/null @@ -1,26 +0,0 @@ --- To hexadecimal conversions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Hex_Images is - function Hex_Image (W : Integer_32) return String; - function Hex_Image (W : Unsigned_32) return String; - function Hex_Image (B : Unsigned_8) return String; - function Hex_Image (W : Unsigned_16) return String; - function Hex_Image (W : Unsigned_64) return String; -end Hex_Images; diff --git a/ortho/mcode/memsegs.ads b/ortho/mcode/memsegs.ads deleted file mode 100644 index ff7f8947e..000000000 --- a/ortho/mcode/memsegs.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Memsegs_Mmap; -package Memsegs renames Memsegs_Mmap; - diff --git a/ortho/mcode/memsegs_c.c b/ortho/mcode/memsegs_c.c deleted file mode 100644 index f0a0e27d5..000000000 --- a/ortho/mcode/memsegs_c.c +++ /dev/null @@ -1,133 +0,0 @@ -/* Memory segment handling. - Copyright (C) 2006 Tristan Gingold. - - GHDL 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, or (at your option) any later - version. - - GHDL 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 GCC; see the file COPYING. If not, write to the Free - Software Foundation, 59 Temple Place - Suite 330, Boston, MA - 02111-1307, USA. -*/ -#ifndef WINNT - -#define _GNU_SOURCE -#include <sys/mman.h> -#include <stddef.h> -/* #include <stdio.h> */ - -/* TODO: init (get pagesize) - round size, - set rights. -*/ - -#ifdef __APPLE__ -#define MAP_ANONYMOUS MAP_ANON -#else -#define HAVE_MREMAP -#endif - -#ifndef HAVE_MREMAP -#include <string.h> -#endif - -void * -mmap_malloc (int size) -{ - void *res; - res = mmap (NULL, size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - /* printf ("mmap (%d) = %p\n", size, res); */ - if (res == MAP_FAILED) - return NULL; - return res; -} - -void * -mmap_realloc (void *ptr, int old_size, int size) -{ - void *res; -#ifdef HAVE_MREMAP - res = mremap (ptr, old_size, size, MREMAP_MAYMOVE); -#else - res = mmap (NULL, size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (res == MAP_FAILED) - return NULL; - memcpy (res, ptr, old_size); - munmap (ptr, old_size); -#endif - /* printf ("mremap (%p, %d, %d) = %p\n", ptr, old_size, size, res); */ -#if 0 - if (res == MAP_FAILED) - return NULL; -#endif - return res; -} - -void -mmap_free (void * ptr, int size) -{ - munmap (ptr, size); -} - -void -mmap_rx (void *ptr, int size) -{ - mprotect (ptr, size, PROT_READ | PROT_EXEC); -} - -#else -#include <windows.h> - -void * -mmap_malloc (int size) -{ - void *res; - res = VirtualAlloc (NULL, size, - MEM_COMMIT | MEM_RESERVE, - PAGE_READWRITE); - return res; -} - -void * -mmap_realloc (void *ptr, int old_size, int size) -{ - void *res; - - res = VirtualAlloc (NULL, size, - MEM_COMMIT | MEM_RESERVE, - PAGE_READWRITE); - - if (ptr != NULL) - { - CopyMemory (res, ptr, size > old_size ? old_size : size); - VirtualFree (ptr, old_size, MEM_RELEASE); - } - - return res; -} - -void -mmap_free (void * ptr, int size) -{ - VirtualFree (ptr, size, MEM_RELEASE); -} - -void -mmap_rx (void *ptr, int size) -{ - DWORD old; - - /* This is not supported on every version. - In case of failure, this should still work. */ - VirtualProtect (ptr, size, PAGE_EXECUTE_READ, &old); -} -#endif diff --git a/ortho/mcode/memsegs_mmap.adb b/ortho/mcode/memsegs_mmap.adb deleted file mode 100644 index 1ee8e7bcf..000000000 --- a/ortho/mcode/memsegs_mmap.adb +++ /dev/null @@ -1,64 +0,0 @@ --- Memory segments. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package body Memsegs_Mmap is - function Mmap_Malloc (Size : Natural) return Address; - pragma Import (C, Mmap_Malloc, "mmap_malloc"); - - function Mmap_Realloc (Ptr : Address; Old_Size : Natural; Size : Natural) - return Address; - pragma Import (C, Mmap_Realloc, "mmap_realloc"); - - procedure Mmap_Free (Ptr : Address; Size : Natural); - pragma Import (C, Mmap_Free, "mmap_free"); - - procedure Mmap_Rx (Ptr : Address; Size : Natural); - pragma Import (C, Mmap_Rx, "mmap_rx"); - - function Create return Memseg_Type is - begin - return (Base => Null_Address, Size => 0); - end Create; - - procedure Resize (Seg : in out Memseg_Type; Size : Natural) is - begin - if Seg.Size = 0 then - Seg.Base := Mmap_Malloc (Size); - else - Seg.Base := Mmap_Realloc (Seg.Base, Seg.Size, Size); - end if; - Seg.Size := Size; - end Resize; - - function Get_Address (Seg : Memseg_Type) return Address is - begin - return Seg.Base; - end Get_Address; - - procedure Delete (Seg : in out Memseg_Type) is - begin - Mmap_Free (Seg.Base, Seg.Size); - Seg.Base := Null_Address; - Seg.Size := 0; - end Delete; - - procedure Set_Rx (Seg : in out Memseg_Type) is - begin - Mmap_Rx (Seg.Base, Seg.Size); - end Set_Rx; -end Memsegs_Mmap; - diff --git a/ortho/mcode/memsegs_mmap.ads b/ortho/mcode/memsegs_mmap.ads deleted file mode 100644 index ba7d76618..000000000 --- a/ortho/mcode/memsegs_mmap.ads +++ /dev/null @@ -1,49 +0,0 @@ --- Memory segments. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; use System; - -package Memsegs_Mmap is - -- A memseg is a growable memory space. It can be resized with Resize. - -- After each operation the base address can change and must be get - -- with Get_Address. - type Memseg_Type is private; - - -- Create a new memseg. - function Create return Memseg_Type; - - -- Resize the memseg. - procedure Resize (Seg : in out Memseg_Type; Size : Natural); - - -- Get the base address. - function Get_Address (Seg : Memseg_Type) return Address; - - -- Free all the memory and initialize the memseg. - procedure Delete (Seg : in out Memseg_Type); - - -- Set the protection to read+execute. - procedure Set_Rx (Seg : in out Memseg_Type); - - pragma Inline (Create); - pragma Inline (Get_Address); -private - type Memseg_Type is record - Base : Address := Null_Address; - Size : Natural := 0; - end record; -end Memsegs_Mmap; - diff --git a/ortho/mcode/ortho_code-abi.ads b/ortho/mcode/ortho_code-abi.ads deleted file mode 100644 index e75b08509..000000000 --- a/ortho/mcode/ortho_code-abi.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Ortho_Code.X86.Abi; - -package Ortho_Code.Abi renames Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-binary.adb b/ortho/mcode/ortho_code-binary.adb deleted file mode 100644 index 7bb6bdd28..000000000 --- a/ortho/mcode/ortho_code-binary.adb +++ /dev/null @@ -1,37 +0,0 @@ --- Interface with binary writer for mcode. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Decls; -with Ortho_Code.Exprs; - -package body Ortho_Code.Binary is - function Get_Decl_Symbol (Decl : O_Dnode) return Symbol - is - begin - return To_Symbol (Decls.Get_Decl_Info (Decl)); - end Get_Decl_Symbol; - - function Get_Label_Symbol (Label : O_Enode) return Symbol is - begin - return To_Symbol (Exprs.Get_Label_Info (Label)); - end Get_Label_Symbol; - - procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol) is - begin - Exprs.Set_Label_Info (Label, To_Int32 (Sym)); - end Set_Label_Symbol; -end Ortho_Code.Binary; diff --git a/ortho/mcode/ortho_code-binary.ads b/ortho/mcode/ortho_code-binary.ads deleted file mode 100644 index 58c79d3b2..000000000 --- a/ortho/mcode/ortho_code-binary.ads +++ /dev/null @@ -1,31 +0,0 @@ --- Interface with binary writer for mcode. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Binary_File; use Binary_File; - -package Ortho_Code.Binary is - function To_Symbol is new Ada.Unchecked_Conversion - (Source => Int32, Target => Symbol); - - function To_Int32 is new Ada.Unchecked_Conversion - (Source => Symbol, Target => Int32); - - function Get_Decl_Symbol (Decl : O_Dnode) return Symbol; - function Get_Label_Symbol (Label : O_Enode) return Symbol; - procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol); -end Ortho_Code.Binary; - diff --git a/ortho/mcode/ortho_code-consts.adb b/ortho/mcode/ortho_code-consts.adb deleted file mode 100644 index d09a13c34..000000000 --- a/ortho/mcode/ortho_code-consts.adb +++ /dev/null @@ -1,559 +0,0 @@ --- Mcode back-end for ortho - Constants handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Conversion; -with GNAT.Table; -with Ada.Text_IO; -with Ortho_Code.Types; use Ortho_Code.Types; -with Ortho_Code.Debug; - -package body Ortho_Code.Consts is - type Cnode_Common is record - Kind : OC_Kind; - Lit_Type : O_Tnode; - end record; - for Cnode_Common use record - Kind at 0 range 0 .. 31; - Lit_Type at 4 range 0 .. 31; - end record; - for Cnode_Common'Size use 64; - - type Cnode_Signed is record - Val : Integer_64; - end record; - for Cnode_Signed'Size use 64; - - type Cnode_Unsigned is record - Val : Unsigned_64; - end record; - for Cnode_Unsigned'Size use 64; - - type Cnode_Float is record - Val : IEEE_Float_64; - end record; - for Cnode_Float'Size use 64; - - type Cnode_Enum is record - Id : O_Ident; - Val : Uns32; - end record; - for Cnode_Enum'Size use 64; - - type Cnode_Addr is record - Decl : O_Dnode; - Pad : Int32; - end record; - for Cnode_Addr'Size use 64; - - type Cnode_Aggr is record - Els : Int32; - Nbr : Int32; - end record; - for Cnode_Aggr'Size use 64; - - type Cnode_Sizeof is record - Atype : O_Tnode; - Pad : Int32; - end record; - for Cnode_Sizeof'Size use 64; - - type Cnode_Union is record - El : O_Cnode; - Field : O_Fnode; - end record; - for Cnode_Union'Size use 64; - - package Cnodes is new GNAT.Table - (Table_Component_Type => Cnode_Common, - Table_Index_Type => O_Cnode, - Table_Low_Bound => 2, - Table_Initial => 128, - Table_Increment => 100); - - function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is - begin - return Cnodes.Table (Cst).Kind; - end Get_Const_Kind; - - function Get_Const_Type (Cst : O_Cnode) return O_Tnode is - begin - return Cnodes.Table (Cst).Lit_Type; - end Get_Const_Type; - - function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64 - is - function To_Cnode_Unsigned is new Ada.Unchecked_Conversion - (Cnode_Common, Cnode_Unsigned); - begin - return To_Cnode_Unsigned (Cnodes.Table (Cst + 1)).Val; - end Get_Const_U64; - - function Get_Const_I64 (Cst : O_Cnode) return Integer_64 - is - function To_Cnode_Signed is new Ada.Unchecked_Conversion - (Cnode_Common, Cnode_Signed); - begin - return To_Cnode_Signed (Cnodes.Table (Cst + 1)).Val; - end Get_Const_I64; - - function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64 - is - function To_Cnode_Float is new Ada.Unchecked_Conversion - (Cnode_Common, Cnode_Float); - begin - return To_Cnode_Float (Cnodes.Table (Cst + 1)).Val; - end Get_Const_F64; - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Signed, Target => Cnode_Common); - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Signed, - Lit_Type => Ltype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Signed'(Val => Value))); - return Res; - end New_Signed_Literal; - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Unsigned_64, Target => Cnode_Common); - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Unsigned, - Lit_Type => Ltype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Value)); - return Res; - end New_Unsigned_Literal; - --- function Get_Const_Literal (Cst : O_Cnode) return Uns32 is --- begin --- return Cnodes.Table (Cst).Val; --- end Get_Const_Literal; - - function To_Uns64 is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Uns64); - - function Get_Const_U32 (Cst : O_Cnode) return Uns32 is - begin - return Uns32 (To_Uns64 (Cnodes.Table (Cst + 1))); - end Get_Const_U32; - - function Get_Const_R64 (Cst : O_Cnode) return Uns64 is - begin - return To_Uns64 (Cnodes.Table (Cst + 1)); - end Get_Const_R64; - - function Get_Const_Low (Cst : O_Cnode) return Uns32 - is - V : Uns64; - begin - V := Get_Const_R64 (Cst); - return Uns32 (V and 16#Ffff_Ffff#); - end Get_Const_Low; - - function Get_Const_High (Cst : O_Cnode) return Uns32 - is - V : Uns64; - begin - V := Get_Const_R64 (Cst); - return Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#); - end Get_Const_High; - - function Get_Const_Low (Cst : O_Cnode) return Int32 - is - V : Uns64; - begin - V := Get_Const_R64 (Cst); - return To_Int32 (Uns32 (V and 16#Ffff_Ffff#)); - end Get_Const_Low; - - function Get_Const_High (Cst : O_Cnode) return Int32 - is - V : Uns64; - begin - V := Get_Const_R64 (Cst); - return To_Int32 (Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#)); - end Get_Const_High; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode - is - Res : O_Cnode; - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Float, Target => Cnode_Common); - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Float, - Lit_Type => Ltype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Float'(Val => Value))); - return Res; - end New_Float_Literal; - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode is - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Null, - Lit_Type => Ltype)); - return Cnodes.Last; - end New_Null_Access; - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Addr, Target => Cnode_Common); - - function To_Cnode_Addr is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Addr); - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Address, - Lit_Type => Atype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); - return Res; - end New_Global_Unchecked_Address; - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Address, - Lit_Type => Atype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); - return Res; - end New_Global_Address; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Subprg_Address, - Lit_Type => Atype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Subprg, - Pad => 0))); - return Res; - end New_Subprogram_Address; - - function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is - begin - return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl; - end Get_Const_Decl; - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Enum, Target => Cnode_Common); - - function To_Cnode_Enum is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Enum); - - --function Get_Named_Literal_Id (Lit : O_Cnode) return O_Ident is - --begin - -- return To_Cnode_Enum (Cnodes.Table (Lit + 1)).Id; - --end Get_Named_Literal_Id; - - function New_Named_Literal - (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) - return O_Cnode - is - Res : O_Cnode; - begin - Cnodes.Append (Cnode_Common'(Kind => OC_Lit, - Lit_Type => Atype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Enum'(Id => Id, - Val => Val))); - if Prev /= O_Cnode_Null then - if Prev + 2 /= Res then - raise Syntax_Error; - end if; - end if; - return Res; - end New_Named_Literal; - - function Get_Lit_Ident (L : O_Cnode) return O_Ident is - begin - return To_Cnode_Enum (Cnodes.Table (L + 1)).Id; - end Get_Lit_Ident; - - function Get_Lit_Value (L : O_Cnode) return Uns32 is - begin - return To_Cnode_Enum (Cnodes.Table (L + 1)).Val; - end Get_Lit_Value; - - function Get_Lit_Chain (L : O_Cnode) return O_Cnode is - begin - return L + 2; - end Get_Lit_Chain; - - package Els is new GNAT.Table - (Table_Component_Type => O_Cnode, - Table_Index_Type => Int32, - Table_Low_Bound => 2, - Table_Initial => 128, - Table_Increment => 100); - - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Aggr, Target => Cnode_Common); - - function To_Cnode_Aggr is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Aggr); - - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode) - is - Val : Int32; - Num : Uns32; - begin - Num := Get_Type_Record_Nbr_Fields (Atype); - Val := Els.Allocate (Integer (Num)); - - Cnodes.Append (Cnode_Common'(Kind => OC_Record, - Lit_Type => Atype)); - List := (Res => Cnodes.Last, - Rec_Field => Get_Type_Record_Fields (Atype), - El => Val); - Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, - Nbr => Int32 (Num)))); - end Start_Record_Aggr; - - - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode) - is - begin - Els.Table (List.El) := Value; - List.El := List.El + 1; - end New_Record_Aggr_El; - - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode) is - begin - Res := List.Res; - end Finish_Record_Aggr; - - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - is - Val : Int32; - Num : Uns32; - begin - Num := Get_Type_Subarray_Length (Atype); - Val := Els.Allocate (Integer (Num)); - - Cnodes.Append (Cnode_Common'(Kind => OC_Array, - Lit_Type => Atype)); - List := (Res => Cnodes.Last, - El => Val); - Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, - Nbr => Int32 (Num)))); - end Start_Array_Aggr; - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - is - begin - Els.Table (List.El) := Value; - List.El := List.El + 1; - end New_Array_Aggr_El; - - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode) - is - begin - Res := List.Res; - end Finish_Array_Aggr; - - function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32 is - begin - return To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Nbr; - end Get_Const_Aggr_Length; - - function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode - is - El : Int32; - begin - El := To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Els; - return Els.Table (El + N); - end Get_Const_Aggr_Element; - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Union, Target => Cnode_Common); - - Res : O_Cnode; - begin - if Debug.Flag_Debug_Hli then - Cnodes.Append (Cnode_Common'(Kind => OC_Union, - Lit_Type => Atype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Union'(El => Value, - Field => Field))); - return Res; - else - return Value; - end if; - end New_Union_Aggr; - - function To_Cnode_Union is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Union); - - function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode is - begin - return To_Cnode_Union (Cnodes.Table (Cst + 1)).Field; - end Get_Const_Union_Field; - - function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode is - begin - return To_Cnode_Union (Cnodes.Table (Cst + 1)).El; - end Get_Const_Union_Value; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Sizeof, Target => Cnode_Common); - - Res : O_Cnode; - begin - if Debug.Flag_Debug_Hli then - Cnodes.Append (Cnode_Common'(Kind => OC_Sizeof, - Lit_Type => Rtype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype, - Pad => 0))); - return Res; - else - return New_Unsigned_Literal - (Rtype, Unsigned_64 (Get_Type_Size (Atype))); - end if; - end New_Sizeof; - - function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode - is - function To_Cnode_Sizeof is new Ada.Unchecked_Conversion - (Cnode_Common, Cnode_Sizeof); - begin - return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype; - end Get_Sizeof_Type; - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Sizeof, Target => Cnode_Common); - - Res : O_Cnode; - begin - if Debug.Flag_Debug_Hli then - Cnodes.Append (Cnode_Common'(Kind => OC_Alignof, - Lit_Type => Rtype)); - Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype, - Pad => 0))); - return Res; - else - return New_Unsigned_Literal - (Rtype, Unsigned_64 (Get_Type_Align_Bytes (Atype))); - end if; - end New_Alignof; - - function Get_Alignof_Type (Cst : O_Cnode) return O_Tnode - is - function To_Cnode_Sizeof is new Ada.Unchecked_Conversion - (Cnode_Common, Cnode_Sizeof); - begin - return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype; - end Get_Alignof_Type; - - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode is - begin - if Get_Field_Parent (Field) /= Rec_Type then - raise Syntax_Error; - end if; - return New_Unsigned_Literal - (Rtype, Unsigned_64 (Get_Field_Offset (Field))); - end New_Offsetof; - - procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is - begin - case Get_Const_Kind (Cst) is - when OC_Signed - | OC_Unsigned - | OC_Float => - H := Get_Const_High (Cst); - L := Get_Const_Low (Cst); - when OC_Null => - H := 0; - L := 0; - when OC_Lit => - H := 0; - L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val; - when OC_Array - | OC_Record - | OC_Union - | OC_Sizeof - | OC_Alignof - | OC_Address - | OC_Subprg_Address => - raise Syntax_Error; - end case; - end Get_Const_Bytes; - - procedure Mark (M : out Mark_Type) is - begin - M.Cnode := Cnodes.Last; - M.Els := Els.Last; - end Mark; - - procedure Release (M : Mark_Type) is - begin - Cnodes.Set_Last (M.Cnode); - Els.Set_Last (M.Els); - end Release; - - procedure Disp_Stats - is - use Ada.Text_IO; - begin - Put_Line ("Number of Cnodes: " & O_Cnode'Image (Cnodes.Last)); - Put_Line ("Number of Cnodes-Els: " & Int32'Image (Els.Last)); - end Disp_Stats; - - procedure Finish is - begin - Cnodes.Free; - Els.Free; - end Finish; -end Ortho_Code.Consts; diff --git a/ortho/mcode/ortho_code-consts.ads b/ortho/mcode/ortho_code-consts.ads deleted file mode 100644 index 0076bc6eb..000000000 --- a/ortho/mcode/ortho_code-consts.ads +++ /dev/null @@ -1,158 +0,0 @@ --- Mcode back-end for ortho - Constants handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Ortho_Code.Consts is - type OC_Kind is (OC_Signed, OC_Unsigned, OC_Float, OC_Lit, OC_Null, - OC_Array, OC_Record, OC_Union, - OC_Subprg_Address, OC_Address, - OC_Sizeof, OC_Alignof); - - function Get_Const_Kind (Cst : O_Cnode) return OC_Kind; - - function Get_Const_Type (Cst : O_Cnode) return O_Tnode; - - -- Get bytes for signed, unsigned, float, lit, null. - procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32); - - -- Used to set the length of a constrained type. - -- FIXME: check for no overflow. - function Get_Const_U32 (Cst : O_Cnode) return Uns32; - - function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64; - function Get_Const_I64 (Cst : O_Cnode) return Integer_64; - - function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64; - - -- Get the low and high part of a constant. - function Get_Const_Low (Cst : O_Cnode) return Uns32; - function Get_Const_High (Cst : O_Cnode) return Uns32; - - function Get_Const_Low (Cst : O_Cnode) return Int32; - function Get_Const_High (Cst : O_Cnode) return Int32; - - function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32; - function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode; - - -- Only available in HLI. - function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode; - function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode; - - -- Declaration for an address. - function Get_Const_Decl (Cst : O_Cnode) return O_Dnode; - - -- Get the type from an OC_Sizeof node. - function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode; - - -- Get the type from an OC_Alignof node. - function Get_Alignof_Type (Cst : O_Cnode) return O_Tnode; - - -- Get the value of a named literal. - --function Get_Const_Literal (Cst : O_Cnode) return Uns32; - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - function New_Named_Literal - (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) - return O_Cnode; - - -- For boolean/enum literals. - function Get_Lit_Ident (L : O_Cnode) return O_Ident; - function Get_Lit_Chain (L : O_Cnode) return O_Cnode; - function Get_Lit_Value (L : O_Cnode) return Uns32; - - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - 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; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record REC_TYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - - procedure Disp_Stats; - - type Mark_Type is limited private; - procedure Mark (M : out Mark_Type); - procedure Release (M : Mark_Type); - - procedure Finish; -private - type O_Array_Aggr_List is record - Res : O_Cnode; - El : Int32; - end record; - - type O_Record_Aggr_List is record - Res : O_Cnode; - Rec_Field : O_Fnode; - El : Int32; - end record; - - type Mark_Type is record - Cnode : O_Cnode; - Els : Int32; - end record; - -end Ortho_Code.Consts; diff --git a/ortho/mcode/ortho_code-debug.adb b/ortho/mcode/ortho_code-debug.adb deleted file mode 100644 index 0f3e01ab9..000000000 --- a/ortho/mcode/ortho_code-debug.adb +++ /dev/null @@ -1,143 +0,0 @@ --- Mcode back-end for ortho - Internal debugging. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Flags; - -package body Ortho_Code.Debug is - procedure Disp_Mode (M : Mode_Type) - is - use Ada.Text_IO; - begin - case M is - when Mode_U8 => - Put ("U8 "); - when Mode_U16 => - Put ("U16"); - when Mode_U32 => - Put ("U32"); - when Mode_U64 => - Put ("U64"); - when Mode_I8 => - Put ("I8 "); - when Mode_I16 => - Put ("I16"); - when Mode_I32 => - Put ("I32"); - when Mode_I64 => - Put ("I64"); - when Mode_X1 => - Put ("xxx"); - when Mode_Nil => - Put ("Nil"); - when Mode_F32 => - Put ("F32"); - when Mode_F64 => - Put ("F64"); - when Mode_B2 => - Put ("B2 "); - when Mode_Blk => - Put ("Blk"); - when Mode_P32 => - Put ("P32"); - when Mode_P64 => - Put ("P64"); - end case; - end Disp_Mode; - - procedure Set_Debug_Be_Flag (C : Character) - is - use Ada.Text_IO; - begin - case C is - when 'a' => - Flag_Debug_Asm := True; - when 'b' => - Flag_Debug_Body := True; - when 'B' => - Flag_Debug_Body2 := True; - when 'c' => - Flag_Debug_Code := True; - when 'C' => - Flag_Debug_Code2 := True; - when 'd' => - Flag_Debug_Dump := True; - when 'h' => - Flag_Debug_Hex := True; - when 'H' => - Flag_Debug_Hli := True; - when 'i' => - Flag_Debug_Insn := True; - when 's' => - Flag_Debug_Stat := True; - when 'k' => - Flag_Debug_Keep := True; - when 't' => - Flags.Flag_Type_Name := True; - when others => - Put_Line (Standard_Error, "unknown debug be flag '" & C & "'"); - end case; - end Set_Debug_Be_Flag; - - procedure Set_Be_Flag (Str : String) - is - use Ada.Text_IO; - - subtype Str_Type is String (1 .. Str'Length); - S : Str_Type renames Str; - begin - if S'Length > 11 and then S (1 .. 11) = "--be-debug=" then - for I in 12 .. S'Last loop - Set_Debug_Be_Flag (S (I)); - end loop; - elsif S'Length > 10 and then S (1 .. 10) = "--be-dump=" then - for I in 11 .. S'Last loop - case S (I) is - when 'c' => - Flag_Dump_Code := True; - when others => - Put_Line (Standard_Error, - "unknown back-end dump flag '" & S (I) & "'"); - end case; - end loop; - elsif S'Length > 10 and then S (1 .. 10) = "--be-disp=" then - for I in 11 .. S'Last loop - case S (I) is - when 'c' => - Flag_Disp_Code := True; - Flags.Flag_Type_Name := True; - when others => - Put_Line (Standard_Error, - "unknown back-end disp flag '" & S (I) & "'"); - end case; - end loop; - elsif S'Length > 9 and then S (1 .. 9) = "--be-opt=" then - for I in 10 .. S'Last loop - case S (I) is - when 'O' => - Flags.Flag_Optimize := True; - when 'b' => - Flags.Flag_Opt_BB := True; - when others => - Put_Line (Standard_Error, - "unknown back-end opt flag '" & S (I) & "'"); - end case; - end loop; - else - Put_Line (Standard_Error, "unknown back-end option " & Str); - end if; - end Set_Be_Flag; -end Ortho_Code.Debug; diff --git a/ortho/mcode/ortho_code-debug.ads b/ortho/mcode/ortho_code-debug.ads deleted file mode 100644 index 03f550ac9..000000000 --- a/ortho/mcode/ortho_code-debug.ads +++ /dev/null @@ -1,70 +0,0 @@ --- Mcode back-end for ortho - Internal debugging. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; - -package Ortho_Code.Debug is - package Int32_IO is new Ada.Text_IO.Integer_IO (Ortho_Code.Int32); - - procedure Disp_Mode (M : Mode_Type); - - -- Set a debug flag. - procedure Set_Debug_Be_Flag (C : Character); - - -- any '--be-XXX=YY' option. - procedure Set_Be_Flag (Str : String); - - -- c: tree created, before any back-end. - Flag_Disp_Code : Boolean := False; - Flag_Dump_Code : Boolean := False; - - -- a: disp assembly code. - Flag_Debug_Asm : Boolean := False; - - -- A: do internal checks (assertions). - Flag_Debug_Assert : Boolean := True; - - -- b: disp top-level subprogram body before code generation. - Flag_Debug_Body : Boolean := False; - - -- B: disp top-level subprogram body after code generation. - Flag_Debug_Body2 : Boolean := False; - - -- c: display generated code. - Flag_Debug_Code : Boolean := False; - - -- C: display generated code just before asm. - Flag_Debug_Code2 : Boolean := False; - - -- h: disp bytes generated (in hexa). - Flag_Debug_Hex : Boolean := False; - - -- H: generate high-level instructions. - Flag_Debug_Hli : Boolean := False; - - -- r: raw dump, do not generate code. - Flag_Debug_Dump : Boolean := False; - - -- i: disp insns, when generated. - Flag_Debug_Insn : Boolean := False; - - -- s: disp stats (number of nodes). - Flag_Debug_Stat : Boolean := False; - - -- k: keep all nodes in memory (do not free). - Flag_Debug_Keep: Boolean := False; -end Ortho_Code.Debug; diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb deleted file mode 100644 index fcbf0b0de..000000000 --- a/ortho/mcode/ortho_code-decls.adb +++ /dev/null @@ -1,783 +0,0 @@ --- Mcode back-end for ortho - Declarations handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.Table; -with Ada.Text_IO; -with Ortho_Ident; -with Ortho_Code.Debug; use Ortho_Code.Debug; -with Ortho_Code.Exprs; -with Ortho_Code.Abi; use Ortho_Code.Abi; -with Ortho_Code.Flags; - -package body Ortho_Code.Decls is - -- Common fields: - -- kind: 4 bits - -- storage: 2 bits - -- reg : 8 bits - -- depth : 16 bits - -- flags: addr + 9 - -- Additionnal fields: - -- OD_Type: Id, dtype - -- OD_Var: Id, Dtype, symbol - -- OD_Local: Id, Dtype, offset/reg - -- OD_Const: Id, Dtype, Val, Symbol? - -- OD_Function: Id, Dtype [interfaces follows], Symbol - -- OD_Procedure: Id [interfaces follows], Symbol - -- OD_Interface: Id, Dtype, offset/reg - -- OD_Begin: Last - -- OD_Body: Decl, Stmt, Parent - type Dnode_Common (Kind : OD_Kind := OD_Type) is record - Storage : O_Storage; - - -- True if the address of the declaration is taken. - Flag_Addr : Boolean; - - Flag2 : Boolean; - - Reg : O_Reg; - - -- Depth of the declaration. - Depth : O_Depth; - - case Kind is - when OD_Type - | OD_Const - | OD_Var - | OD_Local - | OD_Function - | OD_Procedure - | OD_Interface => - -- Identifier of this declaration. - Id : O_Ident; - -- Type of this declaration. - Dtype : O_Tnode; - -- Symbol or offset. - Ref : Int32; - -- For const: the value. - -- For subprg: size of pushed arguments. - Info2 : Int32; - when OD_Subprg_Ext => - -- Chain of interfaces. - Subprg_Inter : O_Dnode; - - when OD_Block => - -- Last declaration of this block. - Last : O_Dnode; - -- Max stack offset. - Block_Max_Stack : Uns32; - -- Infos: may be used to store symbols. - Block_Info1 : Int32; - Block_Info2 : Int32; - when OD_Body => - -- Corresponding declaration (function/procedure). - Body_Decl : O_Dnode; - -- Entry statement for this body. - Body_Stmt : O_Enode; - -- Parent (as a body) of this body or null if at top level. - Body_Parent : O_Dnode; - Body_Info : Int32; - when OD_Const_Val => - -- Corresponding declaration. - Val_Decl : O_Dnode; - -- Value. - Val_Val : O_Cnode; - end case; - end record; - - Use_Subprg_Ext : constant Boolean := False; - - pragma Pack (Dnode_Common); - - package Dnodes is new GNAT.Table - (Table_Component_Type => Dnode_Common, - Table_Index_Type => O_Dnode, - Table_Low_Bound => O_Dnode_First, - Table_Initial => 128, - Table_Increment => 100); - - package TDnodes is new GNAT.Table - (Table_Component_Type => O_Dnode, - Table_Index_Type => O_Tnode, - Table_Low_Bound => O_Tnode_First, - Table_Initial => 1, - Table_Increment => 100); - - Context : O_Dnode := O_Dnode_Null; - - function Get_Decl_Type (Decl : O_Dnode) return O_Tnode is - begin - return Dnodes.Table (Decl).Dtype; - end Get_Decl_Type; - - function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind is - begin - return Dnodes.Table (Decl).Kind; - end Get_Decl_Kind; - - function Get_Decl_Storage (Decl : O_Dnode) return O_Storage is - begin - return Dnodes.Table (Decl).Storage; - end Get_Decl_Storage; - - procedure Set_Decl_Storage (Decl : O_Dnode; Storage : O_Storage) is - begin - Dnodes.Table (Decl).Storage := Storage; - end Set_Decl_Storage; - - function Get_Decl_Reg (Decl : O_Dnode) return O_Reg is - begin - return Dnodes.Table (Decl).Reg; - end Get_Decl_Reg; - - procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg) is - begin - Dnodes.Table (Decl).Reg := Reg; - end Set_Decl_Reg; - - function Get_Decl_Depth (Decl : O_Dnode) return O_Depth is - begin - return Dnodes.Table (Decl).Depth; - end Get_Decl_Depth; - - function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode is - begin - case Get_Decl_Kind (Decl) is - when OD_Block => - return Get_Block_Last (Decl) + 1; - when OD_Body => - return Get_Block_Last (Decl + 1) + 1; - when OD_Function - | OD_Procedure => - if Use_Subprg_Ext then - return Decl + 2; - else - return Decl + 1; - end if; - when others => - return Decl + 1; - end case; - end Get_Decl_Chain; - - function Get_Body_Stmt (Bod : O_Dnode) return O_Enode is - begin - return Dnodes.Table (Bod).Body_Stmt; - end Get_Body_Stmt; - - function Get_Body_Decl (Bod : O_Dnode) return O_Dnode is - begin - return Dnodes.Table (Bod).Body_Decl; - end Get_Body_Decl; - - function Get_Body_Parent (Bod : O_Dnode) return O_Dnode is - begin - return Dnodes.Table (Bod).Body_Parent; - end Get_Body_Parent; - - function Get_Body_Info (Bod : O_Dnode) return Int32 is - begin - return Dnodes.Table (Bod).Body_Info; - end Get_Body_Info; - - procedure Set_Body_Info (Bod : O_Dnode; Info : Int32) is - begin - Dnodes.Table (Bod).Body_Info := Info; - end Set_Body_Info; - - function Get_Decl_Ident (Decl : O_Dnode) return O_Ident is - begin - return Dnodes.Table (Decl).Id; - end Get_Decl_Ident; - - function Get_Decl_Last return O_Dnode is - begin - return Dnodes.Last; - end Get_Decl_Last; - - function Get_Block_Last (Blk : O_Dnode) return O_Dnode is - begin - return Dnodes.Table (Blk).Last; - end Get_Block_Last; - - function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32 is - begin - return Dnodes.Table (Blk).Block_Max_Stack; - end Get_Block_Max_Stack; - - procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32) is - begin - Dnodes.Table (Blk).Block_Max_Stack := Max; - end Set_Block_Max_Stack; - - function Get_Block_Info1 (Blk : O_Dnode) return Int32 is - begin - return Dnodes.Table (Blk).Block_Info1; - end Get_Block_Info1; - - procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32) is - begin - Dnodes.Table (Blk).Block_Info1 := Info; - end Set_Block_Info1; - - function Get_Block_Info2 (Blk : O_Dnode) return Int32 is - begin - return Dnodes.Table (Blk).Block_Info2; - end Get_Block_Info2; - - procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32) is - begin - Dnodes.Table (Blk).Block_Info2 := Info; - end Set_Block_Info2; - - function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode - is - Res : O_Dnode; - begin - if Use_Subprg_Ext then - Res := Decl + 2; - else - Res := Decl + 1; - end if; - - if Get_Decl_Kind (Res) = OD_Interface then - return Res; - else - return O_Dnode_Null; - end if; - end Get_Subprg_Interfaces; - - function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode - is - Res : constant O_Dnode := Decl + 1; - begin - if Get_Decl_Kind (Res) = OD_Interface then - return Res; - else - return O_Dnode_Null; - end if; - end Get_Interface_Chain; - - function Get_Val_Decl (Decl : O_Dnode) return O_Dnode is - begin - return Dnodes.Table (Decl).Val_Decl; - end Get_Val_Decl; - - function Get_Val_Val (Decl : O_Dnode) return O_Cnode is - begin - return Dnodes.Table (Decl).Val_Val; - end Get_Val_Val; - - Cur_Depth : O_Depth := O_Toplevel; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Type, - Storage => O_Storage_Private, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => Atype, - Ref => 0, - Info2 => 0, - others => False)); - if Flags.Flag_Type_Name then - declare - L : O_Tnode; - begin - L := TDnodes.Last; - if Atype > L then - TDnodes.Set_Last (Atype); - TDnodes.Table (L + 1 .. Atype) := (others => O_Dnode_Null); - end if; - end; - TDnodes.Table (Atype) := Dnodes.Last; - end if; - end New_Type_Decl; - - function Get_Type_Decl (Atype : O_Tnode) return O_Dnode is - begin - if Atype <= TDnodes.Last then - return TDnodes.Table (Atype); - else - return O_Dnode_Null; - end if; - end Get_Type_Decl; - - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Const, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => Atype, - Ref => 0, - Info2 => 0, - others => False)); - Res := Dnodes.Last; - if not Flag_Debug_Hli then - Expand_Const_Decl (Res); - end if; - end New_Const_Decl; - - procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode) is - begin - if Dnodes.Table (Cst).Info2 /= 0 then - -- Value was already set. - raise Syntax_Error; - end if; - Dnodes.Table (Cst).Info2 := Int32 (Val); - if Flag_Debug_Hli then - Dnodes.Append (Dnode_Common'(Kind => OD_Const_Val, - Storage => O_Storage_Private, - Depth => Cur_Depth, - Reg => R_Nil, - Val_Decl => Cst, - Val_Val => Val, - others => False)); - else - Expand_Const_Value (Cst, Val); - end if; - end New_Const_Value; - - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - begin - if Storage = O_Storage_Local then - Dnodes.Append (Dnode_Common'(Kind => OD_Local, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => Atype, - Ref => 0, - Info2 => 0, - others => False)); - Res := Dnodes.Last; - else - Dnodes.Append (Dnode_Common'(Kind => OD_Var, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => Atype, - Ref => 0, - Info2 => 0, - others => False)); - Res := Dnodes.Last; - if not Flag_Debug_Hli then - Expand_Var_Decl (Res); - end if; - end if; - end New_Var_Decl; - - Static_Chain_Id : O_Ident := O_Ident_Nul; - - procedure Add_Static_Chain (Interfaces : in out O_Inter_List) - is - Res : O_Dnode; - begin - if Static_Chain_Id = O_Ident_Nul then - Static_Chain_Id := Ortho_Ident.Get_Identifier ("STATIC_CHAIN"); - end if; - - New_Interface_Decl (Interfaces, Res, Static_Chain_Id, O_Tnode_Ptr); - end Add_Static_Chain; - - procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List) - is - Storage : O_Storage; - Decl : constant O_Dnode := Dnodes.Last; - begin - Storage := Get_Decl_Storage (Decl); - if Cur_Depth /= O_Toplevel then - case Storage is - when O_Storage_External - | O_Storage_Local => - null; - when O_Storage_Public => - raise Syntax_Error; - when O_Storage_Private => - Storage := O_Storage_Local; - Set_Decl_Storage (Decl, Storage); - end case; - end if; - if Use_Subprg_Ext then - Dnodes.Append (Dnode_Common'(Kind => OD_Subprg_Ext, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Subprg_Inter => O_Dnode_Null, - others => False)); - end if; - - Start_Subprogram (Decl, Interfaces.Abi); - Interfaces.Decl := Decl; - if Storage = O_Storage_Local then - Add_Static_Chain (Interfaces); - end if; - end Start_Subprogram_Decl; - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Function, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => Rtype, - Ref => 0, - Info2 => 0, - others => False)); - Start_Subprogram_Decl (Interfaces); - end Start_Function_Decl; - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage) - is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Procedure, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Id => Ident, - Dtype => O_Tnode_Null, - Ref => 0, - Info2 => 0, - others => False)); - Start_Subprogram_Decl (Interfaces); - end Start_Procedure_Decl; - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) - is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Interface, - Storage => O_Storage_Local, - Depth => Cur_Depth + 1, - Reg => R_Nil, - Id => Ident, - Dtype => Atype, - Ref => 0, - Info2 => 0, - others => False)); - Res := Dnodes.Last; - New_Interface (Res, Interfaces.Abi); - end New_Interface_Decl; - - procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32) is - begin - Dnodes.Table (Decl).Ref := Off; - end Set_Local_Offset; - - function Get_Local_Offset (Decl : O_Dnode) return Int32 is - begin - return Dnodes.Table (Decl).Ref; - end Get_Local_Offset; - - function Get_Inter_Offset (Inter : O_Dnode) return Int32 is - begin - return Dnodes.Table (Inter).Ref; - end Get_Inter_Offset; - - procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32) is - begin - Dnodes.Table (Decl).Ref := Ref; - end Set_Decl_Info; - - function Get_Decl_Info (Decl : O_Dnode) return Int32 is - begin - return Dnodes.Table (Decl).Ref; - end Get_Decl_Info; - - procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32) is - begin - Dnodes.Table (Decl).Info2 := Val; - end Set_Subprg_Stack; - - function Get_Subprg_Stack (Decl : O_Dnode) return Int32 is - begin - return Dnodes.Table (Decl).Info2; - end Get_Subprg_Stack; - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode) is - begin - Res := Interfaces.Decl; - Finish_Subprogram (Res, Interfaces.Abi); - end Finish_Subprogram_Decl; - - Cur_Block : O_Dnode := O_Dnode_Null; - - function Start_Declare_Stmt return O_Dnode is - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Block, - Storage => O_Storage_Local, - Depth => Cur_Depth, - Reg => R_Nil, - Last => O_Dnode_Null, - Block_Max_Stack => 0, - Block_Info1 => 0, - Block_Info2 => 0, - others => False)); - Cur_Block := Dnodes.Last; - return Cur_Block; - end Start_Declare_Stmt; - - procedure Finish_Declare_Stmt (Parent : O_Dnode) is - begin - Dnodes.Table (Cur_Block).Last := Dnodes.Last; - Cur_Block := Parent; - end Finish_Declare_Stmt; - - function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode) - return O_Dnode - is - Res : O_Dnode; - begin - Dnodes.Append (Dnode_Common'(Kind => OD_Body, - Storage => O_Storage_Local, - Depth => Cur_Depth, - Reg => R_Nil, - Body_Parent => Context, - Body_Decl => Decl, - Body_Stmt => Stmt, - Body_Info => 0, - others => False)); - Res := Dnodes.Last; - Context := Res; - Cur_Depth := Cur_Depth + 1; - return Res; - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body is - begin - Cur_Depth := Cur_Depth - 1; - Context := Get_Body_Parent (Context); - end Finish_Subprogram_Body; - - --- function Image (Decl : O_Dnode) return String is --- begin --- return O_Dnode'Image (Decl); --- end Image; - - procedure Disp_Decl_Name (Decl : O_Dnode) - is - use Ada.Text_IO; - use Ortho_Ident; - Id : O_Ident; - begin - Id := Get_Decl_Ident (Decl); - if Is_Equal (Id, O_Ident_Nul) then - declare - Res : String := O_Dnode'Image (Decl); - begin - Res (1) := '?'; - Put (Res); - end; - else - Put (Get_String (Id)); - end if; - end Disp_Decl_Name; - - procedure Disp_Decl_Storage (Decl : O_Dnode) - is - use Ada.Text_IO; - begin - case Get_Decl_Storage (Decl) is - when O_Storage_Local => - Put ("local"); - when O_Storage_External => - Put ("external"); - when O_Storage_Public => - Put ("public"); - when O_Storage_Private => - Put ("private"); - end case; - end Disp_Decl_Storage; - - procedure Disp_Decl (Indent : Natural; Decl : O_Dnode) - is - use Ada.Text_IO; - use Ortho_Ident; - use Ortho_Code.Debug.Int32_IO; - begin - Set_Col (Count (Indent)); - Put (Int32 (Decl), 0); - Set_Col (Count (7 + Indent)); - case Get_Decl_Kind (Decl) is - when OD_Type => - Put ("type "); - Disp_Decl_Name (Decl); - Put (" is "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - when OD_Function => - Disp_Decl_Storage (Decl); - Put (" function "); - Disp_Decl_Name (Decl); - Put (" return "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - when OD_Procedure => - Disp_Decl_Storage (Decl); - Put (" procedure "); - Disp_Decl_Name (Decl); - when OD_Interface => - Put (" interface "); - Disp_Decl_Name (Decl); - Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - Put (", offset="); - Put (Get_Inter_Offset (Decl), 0); - when OD_Const => - Disp_Decl_Storage (Decl); - Put (" const "); - Disp_Decl_Name (Decl); - Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - when OD_Const_Val => - Put ("constant "); - Disp_Decl_Name (Get_Val_Decl (Decl)); - Put (": "); - Put (Int32 (Get_Val_Val (Decl)), 0); - when OD_Local => - Put ("local "); - Disp_Decl_Name (Decl); - Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - Put (", offset="); - Put (Get_Inter_Offset (Decl), 0); - when OD_Var => - Disp_Decl_Storage (Decl); - Put (" var "); - Disp_Decl_Name (Decl); - Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - when OD_Body => - Put ("body of "); - Put (Int32 (Get_Body_Decl (Decl)), 0); - Put (", stmt at "); - Put (Int32 (Get_Body_Stmt (Decl)), 0); - when OD_Block => - Put ("block until "); - Put (Int32 (Get_Block_Last (Decl)), 0); - when OD_Subprg_Ext => - Put ("Subprg_Ext"); --- when others => --- Put (OD_Kind'Image (Get_Decl_Kind (Decl))); - end case; - New_Line; - end Disp_Decl; - - procedure Disp_Decls (Indent : Natural; First, Last : O_Dnode) - is - N : O_Dnode; - begin - N := First; - while N <= Last loop - case Get_Decl_Kind (N) is - when OD_Body => - Disp_Decl (Indent, N); - Ortho_Code.Exprs.Disp_Subprg_Body - (Indent + 2, Get_Body_Stmt (N)); - N := N + 1; - when OD_Block => - -- Skip inner bindings. - N := Get_Block_Last (N) + 1; - when others => - Disp_Decl (Indent, N); - N := N + 1; - end case; - end loop; - end Disp_Decls; - - procedure Disp_Block (Indent : Natural; Start : O_Dnode) - is - Last : O_Dnode; - begin - if Get_Decl_Kind (Start) /= OD_Block then - Disp_Decl (Indent, Start); - raise Program_Error; - end if; - Last := Get_Block_Last (Start); - Disp_Decl (Indent, Start); - Disp_Decls (Indent, Start + 1, Last); - end Disp_Block; - - procedure Disp_All_Decls - is - begin - if False then - for I in Dnodes.First .. Dnodes.Last loop - Disp_Decl (1, I); - end loop; - end if; - - Disp_Decls (1, Dnodes.First, Dnodes.Last); - end Disp_All_Decls; - - procedure Debug_Decl (Decl : O_Dnode) is - begin - Disp_Decl (1, Decl); - end Debug_Decl; - - pragma Unreferenced (Debug_Decl); - - procedure Disp_Stats - is - use Ada.Text_IO; - begin - Put_Line ("Number of Dnodes: " & O_Dnode'Image (Dnodes.Last)); - Put_Line ("Number of TDnodes: " & O_Tnode'Image (TDnodes.Last)); - end Disp_Stats; - - procedure Mark (M : out Mark_Type) is - begin - M.Dnode := Dnodes.Last; - M.TDnode := TDnodes.Last; - end Mark; - - procedure Release (M : Mark_Type) is - begin - Dnodes.Set_Last (M.Dnode); - TDnodes.Set_Last (M.TDnode); - end Release; - - procedure Finish is - begin - Dnodes.Free; - TDnodes.Free; - end Finish; -end Ortho_Code.Decls; diff --git a/ortho/mcode/ortho_code-decls.ads b/ortho/mcode/ortho_code-decls.ads deleted file mode 100644 index ad18892fe..000000000 --- a/ortho/mcode/ortho_code-decls.ads +++ /dev/null @@ -1,209 +0,0 @@ --- Mcode back-end for ortho - Declarations handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Abi; - -package Ortho_Code.Decls is - -- Kind of a declaration. - type OD_Kind is (OD_Type, - OD_Const, OD_Const_Val, - - -- Global and local variables. - OD_Var, OD_Local, - - -- Subprograms. - OD_Function, OD_Procedure, - - -- Additional node for a subprogram. Internal use only. - OD_Subprg_Ext, - - OD_Interface, - OD_Body, - OD_Block); - - -- Return the kind of declaration DECL. - function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind; - - -- Return the type of a declaration. - function Get_Decl_Type (Decl : O_Dnode) return O_Tnode; - - -- Return the identifier of a declaration. - function Get_Decl_Ident (Decl : O_Dnode) return O_Ident; - - -- Return the storage of a declaration. - function Get_Decl_Storage (Decl : O_Dnode) return O_Storage; - - -- Return the depth of a declaration. - function Get_Decl_Depth (Decl : O_Dnode) return O_Depth; - - -- Register for the declaration. - function Get_Decl_Reg (Decl : O_Dnode) return O_Reg; - procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg); - - -- Return the next decl (in the same scope) after DECL. - -- This skips declarations in an inner block. - function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode; - - -- Get the last declaration. - function Get_Decl_Last return O_Dnode; - - -- Return the subprogram declaration correspondig to body BOD. - function Get_Body_Decl (Bod : O_Dnode) return O_Dnode; - - -- Return the parent of a body. - function Get_Body_Parent (Bod : O_Dnode) return O_Dnode; - - -- Get the entry statement of body DECL. - function Get_Body_Stmt (Bod : O_Dnode) return O_Enode; - - -- Get/Set the info field of a body. - function Get_Body_Info (Bod : O_Dnode) return Int32; - procedure Set_Body_Info (Bod : O_Dnode; Info : Int32); - - -- Get the last declaration of block BLK. - function Get_Block_Last (Blk : O_Dnode) return O_Dnode; - - -- Get/Set the block max stack offset. - function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32; - procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32); - - -- Info on blocks. - function Get_Block_Info1 (Blk : O_Dnode) return Int32; - procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32); - function Get_Block_Info2 (Blk : O_Dnode) return Int32; - procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32); - - -- Get the declaration and the value associated with a constant value. - function Get_Val_Decl (Decl : O_Dnode) return O_Dnode; - function Get_Val_Val (Decl : O_Dnode) return O_Cnode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - -- If Flag_Type_Name is set, a map from type to name is maintained. - function Get_Type_Decl (Atype : O_Tnode) return O_Dnode; - - -- Set/Get the offset (or register) of interface or local DECL. - -- To be used by ABI. - procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32); - function Get_Local_Offset (Decl : O_Dnode) return Int32; - - -- Get/Set user info on subprogram, variable, constant declaration. - procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32); - function Get_Decl_Info (Decl : O_Dnode) return Int32; - - -- Get/Set the stack size of subprogram arguments. - procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32); - function Get_Subprg_Stack (Decl : O_Dnode) return Int32; - - -- Get the first interface of a subprogram declaration. - function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode; - - -- Get the next interface. - -- End of interface chain when result is O_Dnode_Null. - function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode; - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value to CST. - procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - type O_Inter_List is limited private; - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - - -- Start subprogram body of DECL. STMT is the corresponding statement. - -- Return the declaration for the body. - function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode) - return O_Dnode; - procedure Finish_Subprogram_Body; - - -- Start a declarative region. - function Start_Declare_Stmt return O_Dnode; - procedure Finish_Declare_Stmt (Parent : O_Dnode); - - procedure Disp_All_Decls; - procedure Disp_Block (Indent : Natural; Start : O_Dnode); - procedure Disp_Decl_Name (Decl : O_Dnode); - procedure Disp_Decl (Indent : Natural; Decl : O_Dnode); - procedure Disp_Stats; - - type Mark_Type is limited private; - procedure Mark (M : out Mark_Type); - procedure Release (M : Mark_Type); - - procedure Finish; -private - type O_Inter_List is record - -- The declaration of the subprogram. - Decl : O_Dnode; - - -- Last declared parameter. - Last_Param : O_Dnode; - - -- Data for ABI. - Abi : Ortho_Code.Abi.O_Abi_Subprg; - end record; - - type Mark_Type is record - Dnode : O_Dnode; - TDnode : O_Tnode; - end record; - -end Ortho_Code.Decls; diff --git a/ortho/mcode/ortho_code-disps.adb b/ortho/mcode/ortho_code-disps.adb deleted file mode 100644 index 9e8ac1272..000000000 --- a/ortho/mcode/ortho_code-disps.adb +++ /dev/null @@ -1,790 +0,0 @@ --- Mcode back-end for ortho - Internal tree dumper. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; use Ada.Text_IO; -with Ortho_Code.Debug; -with Ortho_Code.Consts; -with Ortho_Code.Decls; -with Ortho_Code.Types; -with Ortho_Code.Flags; -with Ortho_Ident; -with Interfaces; - -package body Ortho_Code.Disps is - procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode); - procedure Disp_Expr (Expr : O_Enode); - - procedure Disp_Indent (Indent : Natural) - is - begin - Put ((1 .. 2 * Indent => ' ')); - end Disp_Indent; - - procedure Disp_Ident (Id : O_Ident) - is - use Ortho_Ident; - begin - Put (Get_String (Id)); - end Disp_Ident; - - procedure Disp_Storage (Storage : O_Storage) is - begin - case Storage is - when O_Storage_External => - Put ("external"); - when O_Storage_Public => - Put ("public"); - when O_Storage_Private => - Put ("private"); - when O_Storage_Local => - Put ("local"); - end case; - end Disp_Storage; - - procedure Disp_Label (Label : O_Enode) - is - N : Int32; - begin - case Get_Expr_Kind (Label) is - when OE_Label => - Put ("label"); - N := Int32 (Label); - when OE_Loop => - Put ("loop"); - N := Int32 (Label); - when OE_BB => - Put ("BB"); - N := Get_BB_Number (Label); - when others => - raise Program_Error; - end case; - Put (Int32'Image (N)); - Put (":"); - end Disp_Label; - - procedure Disp_Call (Call : O_Enode) - is - Arg : O_Enode; - begin - Decls.Disp_Decl_Name (Get_Call_Subprg (Call)); - - Arg := Get_Arg_Link (Call); - if Arg /= O_Enode_Null then - Put (" ("); - loop - Disp_Expr (Get_Expr_Operand (Arg)); - Arg := Get_Arg_Link (Arg); - exit when Arg = O_Enode_Null; - Put (", "); - end loop; - Put (")"); - end if; - end Disp_Call; - - procedure Put_Trim (Str : String) is - begin - if Str (Str'First) = ' ' then - Put (Str (Str'First + 1 .. Str'Last)); - else - Put (Str); - end if; - end Put_Trim; - - procedure Disp_Typed_Lit (Lit : O_Cnode; Val : String) - is - use Ortho_Code.Consts; - begin - Disp_Type (Get_Const_Type (Lit)); - Put ("'["); - Put_Trim (Val); - Put (']'); - end Disp_Typed_Lit; - - procedure Disp_Lit (Lit : O_Cnode) - is - use Interfaces; - use Ortho_Code.Consts; - begin - case Get_Const_Kind (Lit) is - when OC_Unsigned => - Disp_Typed_Lit (Lit, Unsigned_64'Image (Get_Const_U64 (Lit))); - when OC_Signed => - Disp_Typed_Lit (Lit, Integer_64'Image (Get_Const_I64 (Lit))); - when OC_Subprg_Address => - Disp_Type (Get_Const_Type (Lit)); - Put ("'subprg_addr ("); - Decls.Disp_Decl_Name (Get_Const_Decl (Lit)); - Put (")"); - when OC_Address => - Disp_Type (Get_Const_Type (Lit)); - Put ("'address ("); - Decls.Disp_Decl_Name (Get_Const_Decl (Lit)); - Put (")"); - when OC_Sizeof => - Disp_Type (Get_Const_Type (Lit)); - Put ("'sizeof ("); - Disp_Type (Get_Sizeof_Type (Lit)); - Put (")"); - when OC_Null => - Disp_Type (Get_Const_Type (Lit)); - Put ("'[null]"); - when OC_Lit => - declare - L : O_Cnode; - begin - L := Types.Get_Type_Enum_Lit - (Get_Const_Type (Lit), Get_Lit_Value (Lit)); - Disp_Typed_Lit - (Lit, Ortho_Ident.Get_String (Get_Lit_Ident (L))); - end; - when OC_Array => - Put ('{'); - for I in 1 .. Get_Const_Aggr_Length (Lit) loop - if I /= 1 then - Put (", "); - end if; - Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1)); - end loop; - Put ('}'); - when OC_Record => - declare - use Ortho_Code.Types; - F : O_Fnode; - begin - F := Get_Type_Record_Fields (Get_Const_Type (Lit)); - Put ('{'); - for I in 1 .. Get_Const_Aggr_Length (Lit) loop - if I /= 1 then - Put (", "); - end if; - Put ('.'); - Disp_Ident (Get_Field_Ident (F)); - Put (" = "); - Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1)); - F := Get_Field_Chain (F); - end loop; - Put ('}'); - end; - when OC_Union => - Put ('{'); - Put ('.'); - Disp_Ident (Types.Get_Field_Ident (Get_Const_Union_Field (Lit))); - Put ('='); - Disp_Lit (Get_Const_Union_Value (Lit)); - Put ('}'); - when others => - Put ("*lit " & OC_Kind'Image (Get_Const_Kind (Lit)) & '*'); - end case; - end Disp_Lit; - - procedure Disp_Expr (Expr : O_Enode) - is - Kind : OE_Kind; - begin - Kind := Get_Expr_Kind (Expr); - case Kind is - when OE_Const => - case Get_Expr_Mode (Expr) is - when Mode_I8 - | Mode_I16 - | Mode_I32 => - Put_Trim (Int32'Image (To_Int32 (Get_Expr_Low (Expr)))); - when Mode_U8 - | Mode_U16 - | Mode_U32 => - Put_Trim (Uns32'Image (Get_Expr_Low (Expr))); - when others => - Put ("const:"); - Debug.Disp_Mode (Get_Expr_Mode (Expr)); - end case; - when OE_Lit => - Disp_Lit (Get_Expr_Lit (Expr)); - when OE_Case_Expr => - Put ("{case}"); - when OE_Kind_Dyadic - | OE_Kind_Cmp - | OE_Add - | OE_Mul - | OE_Shl => - Put ("("); - Disp_Expr (Get_Expr_Left (Expr)); - Put (' '); - case Kind is - when OE_Eq => - Put ('='); - when OE_Neq => - Put ("/="); - when OE_Lt => - Put ("<"); - when OE_Gt => - Put (">"); - when OE_Ge => - Put (">="); - when OE_Le => - Put ("<="); - when OE_Add => - Put ('+'); - when OE_Mul => - Put ('*'); - when OE_Add_Ov => - Put ("+#"); - when OE_Sub_Ov => - Put ("-#"); - when OE_Mul_Ov => - Put ("*#"); - when OE_Shl => - Put ("<<"); - when OE_And => - Put ("and"); - when OE_Or => - Put ("or"); - when others => - Put (OE_Kind'Image (Kind)); - end case; - Put (' '); - Disp_Expr (Get_Expr_Right (Expr)); - Put (")"); - when OE_Not => - Put ("not "); - Disp_Expr (Get_Expr_Operand (Expr)); - when OE_Neg_Ov => - Put ("neg "); - Disp_Expr (Get_Expr_Operand (Expr)); - when OE_Abs_Ov => - Put ("abs "); - Disp_Expr (Get_Expr_Operand (Expr)); - when OE_Indir => - declare - Op : O_Enode; - begin - Op := Get_Expr_Operand (Expr); - case Get_Expr_Kind (Op) is - when OE_Addrg - | OE_Addrl => - Decls.Disp_Decl_Name (Get_Addr_Object (Op)); - when others => - --Put ("*"); - Disp_Expr (Op); - end case; - end; - when OE_Addrl - | OE_Addrg => - -- Put ('@'); - Decls.Disp_Decl_Name (Get_Addr_Object (Expr)); - when OE_Call => - Disp_Call (Expr); - when OE_Alloca => - Put ("alloca ("); - Disp_Expr (Get_Expr_Operand (Expr)); - Put (")"); - when OE_Conv => - Disp_Type (Get_Conv_Type (Expr)); - Put ("'conv ("); - Disp_Expr (Get_Expr_Operand (Expr)); - Put (")"); - when OE_Conv_Ptr => - Disp_Type (Get_Conv_Type (Expr)); - Put ("'address ("); - Disp_Expr (Get_Expr_Operand (Expr)); - Put (")"); - when OE_Typed => - Disp_Type (Get_Conv_Type (Expr)); - Put ("'"); - -- Note: there is always parenthesis around comparison. - Disp_Expr (Get_Expr_Operand (Expr)); - when OE_Record_Ref => - Disp_Expr (Get_Expr_Operand (Expr)); - Put ("."); - Disp_Ident (Types.Get_Field_Ident (Get_Ref_Field (Expr))); - when OE_Access_Ref => - Disp_Expr (Get_Expr_Operand (Expr)); - Put (".all"); - when OE_Index_Ref => - Disp_Expr (Get_Expr_Operand (Expr)); - Put ('['); - Disp_Expr (Get_Ref_Index (Expr)); - Put (']'); - when OE_Slice_Ref => - Disp_Expr (Get_Expr_Operand (Expr)); - Put ('['); - Disp_Expr (Get_Ref_Index (Expr)); - Put ("...]"); - when OE_Get_Stack => - Put ("%sp"); - when OE_Get_Frame => - Put ("%fp"); - when others => - Put_Line (Standard_Error, "disps.disp_expr: unknown expr " - & OE_Kind'Image (Kind)); - end case; - end Disp_Expr; - - procedure Disp_Fields (Indent : Natural; Atype : O_Tnode) - is - use Types; - Nbr : Uns32; - F : O_Fnode; - begin - Nbr := Get_Type_Record_Nbr_Fields (Atype); - F := Get_Type_Record_Fields (Atype); - for I in 1 .. Nbr loop - Disp_Indent (Indent); - Disp_Ident (Get_Field_Ident (F)); - Put (": "); - Disp_Type (Get_Field_Type (F)); - Put (";"); - New_Line; - F := Get_Field_Chain (F); - end loop; - end Disp_Fields; - - procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False) - is - use Types; - Kind : OT_Kind; - Decl : O_Dnode; - begin - if not Force then - Decl := Decls.Get_Type_Decl (Atype); - if Decl /= O_Dnode_Null then - Decls.Disp_Decl_Name (Decl); - return; - end if; - end if; - - Kind := Get_Type_Kind (Atype); - case Kind is - when OT_Signed => - Put ("signed ("); - Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype))); - Put (")"); - when OT_Unsigned => - Put ("unsigned ("); - Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype))); - Put (")"); - when OT_Float => - Put ("float"); - when OT_Access => - Put ("access"); - declare - Acc_Type : O_Tnode; - begin - Acc_Type := Get_Type_Access_Type (Atype); - if Acc_Type /= O_Tnode_Null then - Put (' '); - Disp_Type (Acc_Type); - end if; - end; - when OT_Ucarray => - Put ("array ["); - Disp_Type (Get_Type_Ucarray_Index (Atype)); - Put ("] of "); - Disp_Type (Get_Type_Ucarray_Element (Atype)); - when OT_Subarray => - Put ("subarray "); - Disp_Type (Get_Type_Subarray_Base (Atype)); - Put ("["); - Put_Trim (Uns32'Image (Get_Type_Subarray_Length (Atype))); - Put ("]"); - when OT_Record => - Put_Line ("record"); - Disp_Fields (1, Atype); - Put ("end record"); - when OT_Union => - Put_Line ("union"); - Disp_Fields (1, Atype); - Put ("end union"); - when OT_Boolean => - declare - Lit : O_Cnode; - begin - Put ("boolean {"); - Lit := Get_Type_Bool_False (Atype); - Disp_Ident (Consts.Get_Lit_Ident (Lit)); - Put (", "); - Lit := Get_Type_Bool_True (Atype); - Disp_Ident (Consts.Get_Lit_Ident (Lit)); - Put ("}"); - end; - when OT_Enum => - declare - use Consts; - Lit : O_Cnode; - begin - Put ("enum {"); - Lit := Get_Type_Enum_Lits (Atype); - for I in 1 .. Get_Type_Enum_Nbr_Lits (Atype) loop - if I /= 1 then - Put (", "); - end if; - Disp_Ident (Get_Lit_Ident (Lit)); - Put (" ="); - Put (Uns32'Image (I - 1)); - Lit := Get_Lit_Chain (Lit); - end loop; - Put ('}'); - end; - when OT_Complete => - Put ("-- complete: "); - Disp_Type (Get_Type_Complete_Type (Atype)); - end case; - end Disp_Type; - - procedure Disp_Decl_Storage (Decl : O_Dnode) is - begin - Disp_Storage (Decls.Get_Decl_Storage (Decl)); - Put (' '); - end Disp_Decl_Storage; - - procedure Disp_Subprg_Decl (Indent : Natural; Decl : O_Dnode) - is - use Decls; - Kind : OD_Kind; - Inter : O_Dnode; - begin - Disp_Decl_Storage (Decl); - Kind := Get_Decl_Kind (Decl); - case Kind is - when OD_Function => - Put ("function "); - when OD_Procedure => - Put ("procedure "); - when others => - raise Program_Error; - end case; - - Disp_Decl_Name (Decl); - Inter := Get_Subprg_Interfaces (Decl); - Put (" ("); - New_Line; - if Inter /= O_Dnode_Null then - loop - Disp_Indent (Indent + 1); - Disp_Decl_Name (Inter); - Put (": "); - Disp_Type (Get_Decl_Type (Inter)); - Inter := Get_Interface_Chain (Inter); - exit when Inter = O_Dnode_Null; - Put (";"); - New_Line; - end loop; - else - Disp_Indent (Indent + 1); - end if; - Put (")"); - if Kind = OD_Function then - New_Line; - Disp_Indent (Indent + 1); - Put ("return "); - Disp_Type (Get_Decl_Type (Decl)); - end if; - end Disp_Subprg_Decl; - - procedure Disp_Decl (Indent : Natural; - Decl : O_Dnode; - Nl : Boolean := False) - is - use Decls; - Kind : OD_Kind; - Dtype : O_Tnode; - begin - Kind := Get_Decl_Kind (Decl); - if Kind = OD_Interface then - return; - end if; - Disp_Indent (Indent); - case Kind is - when OD_Type => - Dtype := Get_Decl_Type (Decl); - Put ("type "); - Disp_Decl_Name (Decl); - Put (" is "); - Disp_Type (Dtype, True); - Put_Line (";"); - when OD_Local - | OD_Var => - Disp_Decl_Storage (Decl); - Put ("var "); - Disp_Decl_Name (Decl); - Put (" : "); - Dtype := Get_Decl_Type (Decl); - Disp_Type (Dtype); - if True then - Put (" {size=" - & Uns32'Image (Types.Get_Type_Size (Dtype)) & "}"); - end if; - Put_Line (";"); - when OD_Const => - Disp_Decl_Storage (Decl); - Put ("constant "); - Disp_Decl_Name (Decl); - Put (" : "); - Disp_Type (Get_Decl_Type (Decl)); - Put_Line (";"); - when OD_Const_Val => - Put ("constant "); - Disp_Decl_Name (Get_Val_Decl (Decl)); - Put (" := "); - Disp_Lit (Get_Val_Val (Decl)); - Put_Line (";"); - when OD_Function - | OD_Procedure => - Disp_Subprg_Decl (Indent, Decl); - Put_Line (";"); - when OD_Interface => - null; - when OD_Body => - -- Put ("body "); - Disp_Subprg_Decl (Indent, Get_Body_Decl (Decl)); - -- Disp_Decl_Name (Get_Body_Decl (Decl)); - New_Line; - Disp_Subprg (Indent, Get_Body_Stmt (Decl)); - when OD_Block | OD_Subprg_Ext => - null; - end case; - if Nl then - New_Line; - end if; - end Disp_Decl; - - procedure Disp_Stmt (Indent : in out Natural; Stmt : O_Enode) - is - use Decls; - Expr : O_Enode; - begin - case Get_Expr_Kind (Stmt) is - when OE_Beg => - Disp_Indent (Indent); - Put_Line ("declare"); - declare - Last : O_Dnode; - Decl : O_Dnode; - begin - Decl := Get_Block_Decls (Stmt); - Last := Get_Block_Last (Decl); - Decl := Decl + 1; - while Decl <= Last loop - case Get_Decl_Kind (Decl) is - when OD_Block => - Decl := Get_Block_Last (Decl) + 1; - when others => - Disp_Decl (Indent + 1, Decl, False); - Decl := Decl + 1; - end case; - end loop; - end; - Disp_Indent (Indent); - Put_Line ("begin"); - Indent := Indent + 1; - when OE_End => - Indent := Indent - 1; - Disp_Indent (Indent); - Put_Line ("end;"); - when OE_Line => - Disp_Indent (Indent); - Put_Line ("--#" & Int32'Image (Get_Expr_Line_Number (Stmt))); - when OE_BB => - Disp_Indent (Indent); - Put_Line ("# BB" & Int32'Image (Get_BB_Number (Stmt))); - when OE_Asgn => - Disp_Indent (Indent); - Disp_Expr (Get_Assign_Target (Stmt)); - Put (" := "); - Disp_Expr (Get_Expr_Operand (Stmt)); - Put_Line (";"); - when OE_Call => - Disp_Indent (Indent); - Disp_Call (Stmt); - Put_Line (";"); - when OE_Jump_F => - Disp_Indent (Indent); - Put ("jump "); - Disp_Label (Get_Jump_Label (Stmt)); - Put (" if not "); - Disp_Expr (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Jump_T => - Disp_Indent (Indent); - Put ("jump "); - Disp_Label (Get_Jump_Label (Stmt)); - Put (" if "); - Disp_Expr (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Jump => - Disp_Indent (Indent); - Put ("jump "); - Disp_Label (Get_Jump_Label (Stmt)); - New_Line; - when OE_Label => - Disp_Indent (Indent); - Disp_Label (Stmt); - New_Line; - when OE_Ret => - Disp_Indent (Indent); - Put ("return"); - Expr := Get_Expr_Operand (Stmt); - if Expr /= O_Enode_Null then - Put (" "); - Disp_Expr (Expr); - end if; - Put_Line (";"); - when OE_Set_Stack => - Disp_Indent (Indent); - Put ("%sp := "); - Disp_Expr (Get_Expr_Operand (Stmt)); - Put_Line (";"); - when OE_Leave => - Disp_Indent (Indent); - Put_Line ("# leave"); - when OE_If => - Disp_Indent (Indent); - Put ("if "); - Disp_Expr (Get_Expr_Operand (Stmt)); - Put (" then"); - New_Line; - Indent := Indent + 1; - when OE_Else => - Disp_Indent (Indent - 1); - Put ("else"); - New_Line; - when OE_Endif => - Indent := Indent - 1; - Disp_Indent (Indent); - Put_Line ("end if;"); - when OE_Loop => - Disp_Indent (Indent); - Disp_Label (Stmt); - New_Line; - Indent := Indent + 1; - when OE_Exit => - Disp_Indent (Indent); - Put ("exit "); - Disp_Label (Get_Jump_Label (Stmt)); - Put (";"); - New_Line; - when OE_Next => - Disp_Indent (Indent); - Put ("next "); - Disp_Label (Get_Jump_Label (Stmt)); - Put (";"); - New_Line; - when OE_Eloop => - Indent := Indent - 1; - Disp_Indent (Indent); - Put_Line ("end loop;"); - when OE_Case => - Disp_Indent (Indent); - Put ("case "); - Disp_Expr (Get_Expr_Operand (Stmt)); - Put (" is"); - New_Line; - if Debug.Flag_Debug_Hli then - Indent := Indent + 2; - end if; - when OE_Case_Branch => - Disp_Indent (Indent - 1); - Put ("when "); - declare - C : O_Enode; - L, H : O_Enode; - begin - C := Get_Case_Branch_Choice (Stmt); - loop - L := Get_Expr_Left (C); - H := Get_Expr_Right (C); - if L = O_Enode_Null then - Put ("others"); - else - Disp_Expr (L); - if H /= O_Enode_Null then - Put (" ... "); - Disp_Expr (H); - end if; - end if; - C := Get_Case_Choice_Link (C); - exit when C = O_Enode_Null; - New_Line; - Disp_Indent (Indent - 1); - Put (" | "); - end loop; - Put (" =>"); - New_Line; - end; - when OE_Case_End => - Indent := Indent - 2; - Disp_Indent (Indent); - Put ("end case;"); - New_Line; - when others => - Put_Line (Standard_Error, "debug.disp_stmt: unknown statement " & - OE_Kind'Image (Get_Expr_Kind (Stmt))); - end case; - end Disp_Stmt; - - procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode) - is - Stmt : O_Enode; - N_Ident : Natural := Ident; - begin - Stmt := S_Entry; - loop - Stmt := Get_Stmt_Link (Stmt); - Disp_Stmt (N_Ident, Stmt); - exit when Get_Expr_Kind (Stmt) = OE_Leave; - end loop; - end Disp_Subprg; - - Last_Decl : O_Dnode := O_Dnode_First; - - procedure Disp_Decls_Until (Last : O_Dnode; Nl : Boolean := False) is - begin - while Last_Decl <= Last loop - Disp_Decl (0, Last_Decl, Nl); - Last_Decl := Last_Decl + 1; - end loop; - end Disp_Decls_Until; - - procedure Disp_Subprg (Subprg : Subprogram_Data_Acc) - is - use Decls; - begin - Disp_Decls_Until (Subprg.D_Body, True); - if Get_Decl_Kind (Last_Decl) /= OD_Block then - raise Program_Error; - end if; - if Debug.Flag_Debug_Keep then - -- If nodes are kept, the next declaration to be displayed (at top - -- level) is the one that follow the subprogram block. - Last_Decl := Get_Block_Last (Last_Decl) + 1; - else - -- If nodes are not kept, this subprogram block will be freed, and - -- the next declaration is the block itself. - Last_Decl := Subprg.D_Body; - end if; - end Disp_Subprg; - - procedure Init is - begin - Flags.Flag_Type_Name := True; - end Init; - - procedure Finish is - begin - Disp_Decls_Until (Decls.Get_Decl_Last, True); - end Finish; - -end Ortho_Code.Disps; diff --git a/ortho/mcode/ortho_code-disps.ads b/ortho/mcode/ortho_code-disps.ads deleted file mode 100644 index 5ae4d8697..000000000 --- a/ortho/mcode/ortho_code-disps.ads +++ /dev/null @@ -1,25 +0,0 @@ --- Mcode back-end for ortho - Internal tree dumper. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Exprs; use Ortho_Code.Exprs; - -package Ortho_Code.Disps is - procedure Disp_Subprg (Subprg : Subprogram_Data_Acc); - procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False); - procedure Init; - procedure Finish; -end Ortho_Code.Disps; diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb deleted file mode 100644 index ad67d1ff6..000000000 --- a/ortho/mcode/ortho_code-dwarf.adb +++ /dev/null @@ -1,1351 +0,0 @@ --- Mcode back-end for ortho - Dwarf generator. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.Directory_Operations; -with GNAT.Table; -with Interfaces; use Interfaces; -with Binary_File; use Binary_File; -with Dwarf; use Dwarf; -with Ada.Text_IO; -with Ortho_Code.Decls; -with Ortho_Code.Types; -with Ortho_Code.Consts; -with Ortho_Code.Flags; -with Ortho_Ident; -with Ortho_Code.Binary; - -package body Ortho_Code.Dwarf is - -- Dwarf debugging format. - -- Debugging. - Line1_Sect : Section_Acc := null; - Line_Last : Int32 := 0; - Line_Pc : Pc_Type := 0; - - -- Constant. - Min_Insn_Len : constant := 1; - Line_Base : constant := 1; - Line_Range : constant := 4; - Line_Opcode_Base : constant := 13; - Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range; - -- + Line_Base; - - Cur_File : Natural := 0; - Last_File : Natural := 0; - - Orig_Sym : Symbol; - End_Sym : Symbol; - Abbrev_Sym : Symbol; - Info_Sym : Symbol; - Line_Sym : Symbol; - - Line_Sect : Section_Acc; - Abbrev_Sect : Section_Acc; - Info_Sect : Section_Acc; - Aranges_Sect : Section_Acc; - - Abbrev_Last : Unsigned_32; - --- procedure Gen_String (Str : String) --- is --- begin --- for I in Str'Range loop --- Gen_B8 (Character'Pos (Str (I))); --- end loop; --- end Gen_String; - - procedure Gen_String_Nul (Str : String) - is - begin - Prealloc (Str'Length + 1); - for I in Str'Range loop - Gen_B8 (Character'Pos (Str (I))); - end loop; - Gen_B8 (0); - end Gen_String_Nul; - - procedure Gen_Sleb128 (V : Int32) - is - V1 : Uns32 := To_Uns32 (V); - V2 : Uns32; - B : Byte; - function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural) - return Uns32; - pragma Import (Intrinsic, Shift_Right_Arithmetic); - begin - loop - B := Byte (V1 and 16#7F#); - V2 := Shift_Right_Arithmetic (V1, 7); - if (V2 = 0 and (B and 16#40#) = 0) - or (V2 = -1 and (B and 16#40#) /= 0) - then - Gen_B8 (B); - exit; - else - Gen_B8 (B or 16#80#); - V1 := V2; - end if; - end loop; - end Gen_Sleb128; - - procedure Gen_Uleb128 (V : Unsigned_32) - is - V1 : Unsigned_32 := V; - B : Byte; - begin - loop - B := Byte (V1 and 16#7f#); - V1 := Shift_Right (V1, 7); - if V1 /= 0 then - Gen_B8 (B or 16#80#); - else - Gen_B8 (B); - exit; - end if; - end loop; - end Gen_Uleb128; - --- procedure New_Debug_Line_Decl (Line : Int32) --- is --- begin --- Line_Last := Line; --- end New_Debug_Line_Decl; - - procedure Set_Line_Stmt (Line : Int32) - is - Pc : Pc_Type; - D_Pc : Pc_Type; - D_Ln : Int32; - begin - if Line = Line_Last then - return; - end if; - Pc := Get_Current_Pc; - - D_Pc := (Pc - Line_Pc) / Min_Insn_Len; - D_Ln := Line - Line_Last; - - -- Always emit line information, since missing info can distrub the - -- user. - -- As an optimization, we could try to emit the highest line for the - -- same PC, since GDB seems to handle this way. - if False and D_Pc = 0 then - return; - end if; - - Set_Current_Section (Line1_Sect); - Prealloc (32); - - if Cur_File /= Last_File then - Gen_B8 (Byte (DW_LNS_Set_File)); - Gen_Uleb128 (Unsigned_32 (Cur_File)); - Last_File := Cur_File; - elsif Cur_File = 0 then - return; - end if; - - if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then - -- Emit an advance line. - Gen_B8 (Byte (DW_LNS_Advance_Line)); - Gen_Sleb128 (Int32 (D_Ln - Line_Base)); - D_Ln := Line_Base; - end if; - if D_Pc >= Line_Max_Addr then - -- Emit an advance addr. - Gen_B8 (Byte (DW_LNS_Advance_Pc)); - Gen_Uleb128 (Unsigned_32 (D_Pc)); - D_Pc := 0; - end if; - Gen_B8 (Line_Opcode_Base - + Byte (D_Pc) * Line_Range - + Byte (D_Ln - Line_Base)); - - --Set_Current_Section (Text_Sect); - Line_Pc := Pc; - Line_Last := Line; - end Set_Line_Stmt; - - - type String_Acc is access constant String; - - type Dir_Chain; - type Dir_Chain_Acc is access Dir_Chain; - type Dir_Chain is record - Name : String_Acc; - Next : Dir_Chain_Acc; - end record; - - type File_Chain; - type File_Chain_Acc is access File_Chain; - type File_Chain is record - Name : String_Acc; - Dir : Natural; - Next : File_Chain_Acc; - end record; - - Dirs : Dir_Chain_Acc := null; - Files : File_Chain_Acc := null; - - procedure Set_Filename (Dir : String; File : String) - is - D : Natural; - F : Natural; - D_C : Dir_Chain_Acc; - F_C : File_Chain_Acc; - begin - -- Find directory. - if Dir = "" then - -- Current directory. - D := 0; - elsif Dirs = null then - -- First directory. - Dirs := new Dir_Chain'(Name => new String'(Dir), - Next => null); - D := 1; - else - -- Find a directory. - D_C := Dirs; - D := 1; - loop - exit when D_C.Name.all = Dir; - D := D + 1; - if D_C.Next = null then - D_C.Next := new Dir_Chain'(Name => new String'(Dir), - Next => null); - exit; - else - D_C := D_C.Next; - end if; - end loop; - end if; - - -- Find file. - F := 1; - if Files = null then - -- first file. - Files := new File_Chain'(Name => new String'(File), - Dir => D, - Next => null); - else - F_C := Files; - loop - exit when F_C.Name.all = File and F_C.Dir = D; - F := F + 1; - if F_C.Next = null then - F_C.Next := new File_Chain'(Name => new String'(File), - Dir => D, - Next => null); - exit; - else - F_C := F_C.Next; - end if; - end loop; - end if; - Cur_File := F; - end Set_Filename; - - procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is - begin - Gen_Uleb128 (Tag); - Gen_B8 (Child); - end Gen_Abbrev_Header; - - procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is - begin - Gen_Uleb128 (Attr); - Gen_Uleb128 (Form); - end Gen_Abbrev_Tuple; - - procedure Init - is - begin - -- Generate type names. - Flags.Flag_Type_Name := True; - - - Orig_Sym := Create_Local_Symbol; - Set_Symbol_Pc (Orig_Sym, False); - End_Sym := Create_Local_Symbol; - - Create_Section (Line1_Sect, ".debug_line-1", Section_Debug); - Set_Current_Section (Line1_Sect); - - -- Write Address. - Gen_B8 (0); -- extended opcode - Gen_B8 (5); -- length: 1 + 4 - Gen_B8 (Byte (DW_LNE_Set_Address)); - Gen_Ua_32 (Orig_Sym, 0); - - Line_Last := 1; - - Create_Section (Line_Sect, ".debug_line", Section_Debug); - Set_Section_Info (Line_Sect, null, 0, 0); - Set_Current_Section (Line_Sect); - Line_Sym := Create_Local_Symbol; - Set_Symbol_Pc (Line_Sym, False); - - -- Abbrevs. - Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug); - Set_Section_Info (Abbrev_Sect, null, 0, 0); - Set_Current_Section (Abbrev_Sect); - - Abbrev_Sym := Create_Local_Symbol; - Set_Symbol_Pc (Abbrev_Sym, False); - - Gen_Uleb128 (1); - Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes); - - Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4); - Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String); - Gen_Abbrev_Tuple (0, 0); - - Abbrev_Last := 1; - - -- Info. - Create_Section (Info_Sect, ".debug_info", Section_Debug); - Set_Section_Info (Info_Sect, null, 0, 0); - Set_Current_Section (Info_Sect); - Info_Sym := Create_Local_Symbol; - Set_Symbol_Pc (Info_Sym, False); - - Gen_32 (7); -- Length: to be patched. - Gen_16 (2); -- version - Gen_Ua_32 (Abbrev_Sym, 0); -- Abbrev offset - Gen_B8 (4); -- Ptr size. - - -- Compile_unit. - Gen_Uleb128 (1); - Gen_Ua_32 (Line_Sym, 0); - Gen_Ua_32 (Orig_Sym, 0); - Gen_Ua_32 (End_Sym, 0); - Gen_String_Nul ("T.Gingold ortho_mcode (2004)"); - Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir); - end Init; - - procedure Emit_Decl (Decl : O_Dnode); - - -- Next node to be emitted. - Last_Decl : O_Dnode := O_Dnode_First; - - procedure Emit_Decls_Until (Last : O_Dnode) - is - use Ortho_Code.Decls; - begin - while Last_Decl < Last loop - Emit_Decl (Last_Decl); - Last_Decl := Get_Decl_Chain (Last_Decl); - end loop; - end Emit_Decls_Until; - - procedure Finish - is - Length : Pc_Type; - Last : O_Dnode; - begin - Set_Symbol_Pc (End_Sym, False); - Length := Get_Current_Pc; - - Last := Decls.Get_Decl_Last; - Emit_Decls_Until (Last); - if Last_Decl <= Last then - Emit_Decl (Last); - end if; - - -- Finish abbrevs. - Set_Current_Section (Abbrev_Sect); - Gen_Uleb128 (0); - - -- Emit header. - Set_Current_Section (Line_Sect); - - -- Unit_Length (to be patched). - Gen_32 (0); - -- version - Gen_16 (2); - -- header_length (to be patched). - Gen_32 (5 + 12 + 1); - -- minimum_instruction_length. - Gen_B8 (Min_Insn_Len); - -- default_is_stmt - Gen_B8 (1); - -- line base - Gen_B8 (Line_Base); - -- line range - Gen_B8 (Line_Range); - -- opcode base - Gen_B8 (Line_Opcode_Base); - -- standard_opcode_length. - Gen_B8 (0); -- copy - Gen_B8 (1); -- advance pc - Gen_B8 (1); -- advance line - Gen_B8 (1); -- set file - Gen_B8 (1); -- set column - Gen_B8 (0); -- negate stmt - Gen_B8 (0); -- set basic block - Gen_B8 (0); -- const add pc - Gen_B8 (1); -- fixed advance pc - Gen_B8 (0); -- set prologue end - Gen_B8 (0); -- set epilogue begin - Gen_B8 (1); -- set isa - --if Line_Opcode_Base /= 13 then - -- raise Program_Error; - --end if; - - -- include directories - declare - D : Dir_Chain_Acc; - begin - D := Dirs; - while D /= null loop - Gen_String_Nul (D.Name.all); - D := D.Next; - end loop; - Gen_B8 (0); -- last entry. - end; - - -- file_names. - declare - F : File_Chain_Acc; - begin - F := Files; - while F /= null loop - Gen_String_Nul (F.Name.all); - Gen_Uleb128 (Unsigned_32 (F.Dir)); - Gen_B8 (0); -- time - Gen_B8 (0); -- length - F := F.Next; - end loop; - Gen_B8 (0); -- last entry. - end; - - -- Set prolog length - Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6)); - - Merge_Section (Line_Sect, Line1_Sect); - - -- Emit end of sequence. - Gen_B8 (0); -- extended opcode - Gen_B8 (1); -- length: 1 - Gen_B8 (Byte (DW_LNE_End_Sequence)); - - -- Set total length. - Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); - - -- Info. - Set_Current_Section (Info_Sect); - -- Finish child. - Gen_Uleb128 (0); - -- Set total length. - Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); - - -- Aranges - Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug); - Set_Section_Info (Aranges_Sect, null, 0, 0); - Set_Current_Section (Aranges_Sect); - - Gen_32 (28); -- Length. - Gen_16 (2); -- version - Gen_Ua_32 (Info_Sym, 0); -- info offset - Gen_B8 (4); -- Ptr size. - Gen_B8 (0); -- seg desc size. - Gen_32 (0); -- pad - Gen_Ua_32 (Orig_Sym, 0); -- text offset - Gen_32 (Unsigned_32 (Length)); - Gen_32 (0); -- End - Gen_32 (0); - end Finish; - - procedure Generate_Abbrev (Abbrev : out Unsigned_32) is - begin - Abbrev_Last := Abbrev_Last + 1; - Abbrev := Abbrev_Last; - - Set_Current_Section (Abbrev_Sect); - -- FIXME: should be enough ? - Prealloc (128); - Gen_Uleb128 (Abbrev); - end Generate_Abbrev; - - procedure Gen_Info_Header (Abbrev : Unsigned_32) is - begin - Set_Current_Section (Info_Sect); - Gen_Uleb128 (Abbrev); - end Gen_Info_Header; - - function Gen_Info_Sibling return Pc_Type - is - Pc : Pc_Type; - begin - Pc := Get_Current_Pc; - Gen_32 (0); - return Pc; - end Gen_Info_Sibling; - - procedure Patch_Info_Sibling (Pc : Pc_Type) is - begin - Patch_32 (Pc, Unsigned_32 (Get_Current_Pc)); - end Patch_Info_Sibling; - - Abbrev_Base_Type : Unsigned_32 := 0; - Abbrev_Base_Type_Name : Unsigned_32 := 0; - Abbrev_Pointer : Unsigned_32 := 0; - Abbrev_Pointer_Name : Unsigned_32 := 0; - Abbrev_Uncomplete_Pointer : Unsigned_32 := 0; - Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0; - Abbrev_Ucarray : Unsigned_32 := 0; - Abbrev_Ucarray_Name : Unsigned_32 := 0; - Abbrev_Uc_Subrange : Unsigned_32 := 0; - Abbrev_Subarray : Unsigned_32 := 0; - Abbrev_Subarray_Name : Unsigned_32 := 0; - Abbrev_Subrange : Unsigned_32 := 0; - Abbrev_Struct : Unsigned_32 := 0; - Abbrev_Struct_Name : Unsigned_32 := 0; - Abbrev_Union : Unsigned_32 := 0; - Abbrev_Union_Name : Unsigned_32 := 0; - Abbrev_Member : Unsigned_32 := 0; - Abbrev_Enum : Unsigned_32 := 0; - Abbrev_Enum_Name : Unsigned_32 := 0; - Abbrev_Enumerator : Unsigned_32 := 0; - - package TOnodes is new GNAT.Table - (Table_Component_Type => Pc_Type, - Table_Index_Type => O_Tnode, - Table_Low_Bound => O_Tnode_First, - Table_Initial => 16, - Table_Increment => 100); - - procedure Emit_Type_Ref (Atype : O_Tnode) - is - Off : Pc_Type; - begin - Off := TOnodes.Table (Atype); - if Off = Null_Pc then - raise Program_Error; - end if; - Gen_32 (Unsigned_32 (Off)); - end Emit_Type_Ref; - - procedure Emit_Ident (Id : O_Ident) - is - use Ortho_Ident; - L : Natural; - begin - L := Get_String_Length (Id); - Prealloc (Pc_Type (L) + 128); - Gen_String_Nul (Get_String (Id)); - end Emit_Ident; - - procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type) - is - Prev : O_Tnode; - begin - if Atype > TOnodes.Last then - -- Expand. - Prev := TOnodes.Last; - TOnodes.Set_Last (Atype); - TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc); - end if; - TOnodes.Table (Atype) := Pc; - end Add_Type_Ref; - - procedure Emit_Decl_Ident (Decl : O_Dnode) - is - use Ortho_Code.Decls; - begin - Emit_Ident (Get_Decl_Ident (Decl)); - end Emit_Decl_Ident; - - procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode) - is - use Ortho_Code.Decls; - begin - if Decl /= O_Dnode_Null then - Emit_Ident (Get_Decl_Ident (Decl)); - end if; - end Emit_Decl_Ident_If_Set; - - procedure Emit_Type (Atype : O_Tnode); - - procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1); - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - begin - if Decl = O_Dnode_Null then - if Abbrev_Base_Type = 0 then - Generate_Abbrev (Abbrev_Base_Type); - Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Base_Type); - else - if Abbrev_Base_Type_Name = 0 then - Generate_Abbrev (Abbrev_Base_Type_Name); - Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Base_Type_Name); - Emit_Decl_Ident (Decl); - end if; - - case Get_Type_Kind (Atype) is - when OT_Signed => - Gen_B8 (DW_ATE_Signed); - when OT_Unsigned => - Gen_B8 (DW_ATE_Unsigned); - when OT_Float => - Gen_B8 (DW_ATE_Float); - when others => - raise Program_Error; - end case; - Gen_B8 (Byte (Get_Type_Size (Atype))); - end Emit_Base_Type; - - procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - - procedure Finish_Gen_Abbrev_Uncomplete is - begin - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev_Uncomplete; - - Dtype : O_Tnode; - D_Pc : Pc_Type; - begin - Dtype := Get_Type_Access_Type (Atype); - - if Dtype = O_Tnode_Null then - if Decl = O_Dnode_Null then - if Abbrev_Uncomplete_Pointer = 0 then - Generate_Abbrev (Abbrev_Uncomplete_Pointer); - Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); - Finish_Gen_Abbrev_Uncomplete; - end if; - Gen_Info_Header (Abbrev_Uncomplete_Pointer); - else - if Abbrev_Uncomplete_Pointer_Name = 0 then - Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name); - Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev_Uncomplete; - end if; - Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name); - Emit_Decl_Ident (Decl); - end if; - Gen_B8 (Byte (Get_Type_Size (Atype))); - else - if Decl = O_Dnode_Null then - if Abbrev_Pointer = 0 then - Generate_Abbrev (Abbrev_Pointer); - Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Pointer); - else - if Abbrev_Pointer_Name = 0 then - Generate_Abbrev (Abbrev_Pointer_Name); - Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Pointer_Name); - Emit_Decl_Ident (Decl); - end if; - Gen_B8 (Byte (Get_Type_Size (Atype))); - -- Break possible loops: generate the access entry... - D_Pc := Get_Current_Pc; - Gen_32 (0); - -- ... generate the designated type ... - Emit_Type (Dtype); - -- ... and write its reference. - Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype))); - end if; - end Emit_Access_Type; - - procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - begin - if Decl = O_Dnode_Null then - if Abbrev_Ucarray = 0 then - Generate_Abbrev (Abbrev_Ucarray); - Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Ucarray); - else - if Abbrev_Ucarray_Name = 0 then - Generate_Abbrev (Abbrev_Ucarray_Name); - Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Ucarray_Name); - Emit_Decl_Ident (Decl); - end if; - Emit_Type_Ref (Get_Type_Ucarray_Element (Atype)); - - if Abbrev_Uc_Subrange = 0 then - Generate_Abbrev (Abbrev_Uc_Subrange); - Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (0, 0); - end if; - - Gen_Info_Header (Abbrev_Uc_Subrange); - Emit_Type_Ref (Get_Type_Ucarray_Index (Atype)); - - Gen_Uleb128 (0); - end Emit_Ucarray_Type; - - procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - - Base : O_Tnode; - begin - if Decl = O_Dnode_Null then - if Abbrev_Subarray = 0 then - Generate_Abbrev (Abbrev_Subarray); - Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Subarray); - else - if Abbrev_Subarray_Name = 0 then - Generate_Abbrev (Abbrev_Subarray_Name); - Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Subarray_Name); - Emit_Decl_Ident (Decl); - end if; - - Base := Get_Type_Subarray_Base (Atype); - - Emit_Type_Ref (Get_Type_Ucarray_Element (Base)); - Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype))); - - if Abbrev_Subrange = 0 then - Generate_Abbrev (Abbrev_Subrange); - Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1); - Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata); - Gen_Abbrev_Tuple (0, 0); - end if; - - Gen_Info_Header (Abbrev_Subrange); - Emit_Type_Ref (Get_Type_Ucarray_Index (Base)); - Gen_B8 (0); - Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype))); - - Gen_Uleb128 (0); - end Emit_Subarray_Type; - - procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - Nbr : Uns32; - F : O_Fnode; - Loc_Pc : Pc_Type; - Sibling_Pc : Pc_Type; - begin - if Abbrev_Member = 0 then - Generate_Abbrev (Abbrev_Member); - - Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - - Set_Current_Section (Info_Sect); - Sibling_Pc := Gen_Info_Sibling; - Emit_Decl_Ident_If_Set (Decl); - Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype))); - - Nbr := Get_Type_Record_Nbr_Fields (Atype); - F := Get_Type_Record_Fields (Atype); - while Nbr > 0 loop - Gen_Uleb128 (Abbrev_Member); - Emit_Ident (Get_Field_Ident (F)); - Emit_Type_Ref (Get_Field_Type (F)); - - -- Location. - Loc_Pc := Get_Current_Pc; - Gen_B8 (3); - Gen_B8 (DW_OP_Plus_Uconst); - Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F))); - Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1))); - - F := Get_Field_Chain (F); - Nbr := Nbr - 1; - end loop; - - -- end of children. - Gen_Uleb128 (0); - Patch_Info_Sibling (Sibling_Pc); - end Emit_Members; - - procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - begin - if Decl = O_Dnode_Null then - if Abbrev_Struct = 0 then - Generate_Abbrev (Abbrev_Struct); - - Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Struct); - else - if Abbrev_Struct_Name = 0 then - Generate_Abbrev (Abbrev_Struct_Name); - - Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Struct_Name); - end if; - Emit_Members (Atype, Decl); - end Emit_Record_Type; - - procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - begin - if Decl = O_Dnode_Null then - if Abbrev_Union = 0 then - Generate_Abbrev (Abbrev_Union); - - Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Union); - else - if Abbrev_Union_Name = 0 then - Generate_Abbrev (Abbrev_Union_Name); - - Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Union_Name); - end if; - Emit_Members (Atype, Decl); - end Emit_Union_Type; - - procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode) - is - use Ortho_Code.Types; - use Ortho_Code.Consts; - procedure Finish_Gen_Abbrev is - begin - Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); - Gen_Abbrev_Tuple (0, 0); - end Finish_Gen_Abbrev; - - procedure Emit_Enumerator (L : O_Cnode) is - begin - Gen_Uleb128 (Abbrev_Enumerator); - Emit_Ident (Get_Lit_Ident (L)); - Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L))); - end Emit_Enumerator; - - Nbr : Uns32; - L : O_Cnode; - Sibling_Pc : Pc_Type; - begin - if Abbrev_Enumerator = 0 then - Generate_Abbrev (Abbrev_Enumerator); - - Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata); - Gen_Abbrev_Tuple (0, 0); - end if; - if Decl = O_Dnode_Null then - if Abbrev_Enum = 0 then - Generate_Abbrev (Abbrev_Enum); - Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Enum); - else - if Abbrev_Enum_Name = 0 then - Generate_Abbrev (Abbrev_Enum_Name); - Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Finish_Gen_Abbrev; - end if; - Gen_Info_Header (Abbrev_Enum_Name); - end if; - - Sibling_Pc := Gen_Info_Sibling; - Emit_Decl_Ident_If_Set (Decl); - Gen_B8 (Byte (Get_Type_Size (Atype))); - case Get_Type_Kind (Atype) is - when OT_Enum => - Nbr := Get_Type_Enum_Nbr_Lits (Atype); - L := Get_Type_Enum_Lits (Atype); - while Nbr > 0 loop - Emit_Enumerator (L); - - L := Get_Lit_Chain (L); - Nbr := Nbr - 1; - end loop; - when OT_Boolean => - Emit_Enumerator (Get_Type_Bool_False (Atype)); - Emit_Enumerator (Get_Type_Bool_True (Atype)); - when others => - raise Program_Error; - end case; - - -- End of children. - Gen_Uleb128 (0); - Patch_Info_Sibling (Sibling_Pc); - end Emit_Enum_Type; - - procedure Emit_Type (Atype : O_Tnode) - is - use Ortho_Code.Types; - use Ada.Text_IO; - Kind : OT_Kind; - Decl : O_Dnode; - begin - -- If already emitted, then return. - if Atype <= TOnodes.Last - and then TOnodes.Table (Atype) /= Null_Pc - then - return; - end if; - - Kind := Get_Type_Kind (Atype); - - -- First step: emit inner types (if any). - case Kind is - when OT_Signed - | OT_Unsigned - | OT_Float - | OT_Boolean - | OT_Enum => - null; - when OT_Access => - null; - when OT_Ucarray => - Emit_Type (Get_Type_Ucarray_Index (Atype)); - Emit_Type (Get_Type_Ucarray_Element (Atype)); - when OT_Subarray => - Emit_Type (Get_Type_Subarray_Base (Atype)); - when OT_Record - | OT_Union => - declare - Nbr : Uns32; - F : O_Fnode; - begin - Nbr := Get_Type_Record_Nbr_Fields (Atype); - F := Get_Type_Record_Fields (Atype); - while Nbr > 0 loop - Emit_Type (Get_Field_Type (F)); - F := Get_Field_Chain (F); - Nbr := Nbr - 1; - end loop; - end; - when OT_Complete => - null; - end case; - - Set_Current_Section (Info_Sect); - Add_Type_Ref (Atype, Get_Current_Pc); - - Decl := Decls.Get_Type_Decl (Atype); - - -- Second step: emit info. - case Kind is - when OT_Signed - | OT_Unsigned - | OT_Float => - Emit_Base_Type (Atype, Decl); - -- base types. - when OT_Access => - Emit_Access_Type (Atype, Decl); - when OT_Ucarray => - Emit_Ucarray_Type (Atype, Decl); - when OT_Subarray => - Emit_Subarray_Type (Atype, Decl); - when OT_Record => - Emit_Record_Type (Atype, Decl); - when OT_Union => - Emit_Union_Type (Atype, Decl); - when OT_Enum - | OT_Boolean => - Emit_Enum_Type (Atype, Decl); - when OT_Complete => - null; - end case; - end Emit_Type; - - procedure Emit_Decl_Type (Decl : O_Dnode) - is - use Ortho_Code.Decls; - begin - Emit_Type_Ref (Get_Decl_Type (Decl)); - end Emit_Decl_Type; - - Abbrev_Variable : Unsigned_32 := 0; - Abbrev_Const : Unsigned_32 := 0; - - procedure Emit_Local_Location (Decl : O_Dnode) - is - use Ortho_Code.Decls; - Pc : Pc_Type; - begin - Pc := Get_Current_Pc; - Gen_B8 (2); - Gen_B8 (DW_OP_Fbreg); - Gen_Sleb128 (Get_Decl_Info (Decl)); - Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1))); - end Emit_Local_Location; - - procedure Emit_Global_Location (Decl : O_Dnode) - is - use Ortho_Code.Binary; - begin - Gen_B8 (5); - Gen_B8 (DW_OP_Addr); - Gen_Ua_32 (Get_Decl_Symbol (Decl), 0); - end Emit_Global_Location; - - procedure Emit_Variable (Decl : O_Dnode) - is - use Ortho_Code.Decls; - Dtype : O_Tnode; - begin - if Get_Decl_Ident (Decl) = O_Ident_Nul then - return; - end if; - - if Abbrev_Variable = 0 then - Generate_Abbrev (Abbrev_Variable); - Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - - Dtype := Get_Decl_Type (Decl); - Emit_Type (Dtype); - - Gen_Info_Header (Abbrev_Variable); - Emit_Decl_Ident (Decl); - Emit_Type_Ref (Dtype); - case Get_Decl_Kind (Decl) is - when OD_Local => - Emit_Local_Location (Decl); - when OD_Var => - Emit_Global_Location (Decl); - when others => - raise Program_Error; - end case; - end Emit_Variable; - - procedure Emit_Const (Decl : O_Dnode) - is - use Ortho_Code.Decls; - Dtype : O_Tnode; - begin - if Abbrev_Const = 0 then - Generate_Abbrev (Abbrev_Const); - -- FIXME: should be a TAG_Constant, however, GDB does not support it. - -- work-around: could use a const_type. - Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); - - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - - Dtype := Get_Decl_Type (Decl); - Emit_Type (Dtype); - Gen_Info_Header (Abbrev_Const); - Emit_Decl_Ident (Decl); - Emit_Type_Ref (Dtype); - Emit_Global_Location (Decl); - end Emit_Const; - - procedure Emit_Type_Decl (Decl : O_Dnode) - is - use Ortho_Code.Decls; - begin - Emit_Type (Get_Decl_Type (Decl)); - end Emit_Type_Decl; - - Subprg_Sym : Symbol; - - Abbrev_Block : Unsigned_32 := 0; - - procedure Emit_Block_Decl (Decl : O_Dnode) - is - use Ortho_Code.Decls; - Last : O_Dnode; - Sdecl : O_Dnode; - Sibling_Pc : Pc_Type; - begin - if Abbrev_Block = 0 then - Generate_Abbrev (Abbrev_Block); - - Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (0, 0); - end if; - - Gen_Info_Header (Abbrev_Block); - Sibling_Pc := Gen_Info_Sibling; - - Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); - Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); - - -- Emit decls for children. - Last := Get_Block_Last (Decl); - Sdecl := Decl + 1; - while Sdecl <= Last loop - Emit_Decl (Sdecl); - Sdecl := Get_Decl_Chain (Sdecl); - end loop; - - -- End of children. - Set_Current_Section (Info_Sect); - Gen_Uleb128 (0); - - Patch_Info_Sibling (Sibling_Pc); - end Emit_Block_Decl; - - Abbrev_Function : Unsigned_32 := 0; - Abbrev_Procedure : Unsigned_32 := 0; - Abbrev_Interface : Unsigned_32 := 0; - - procedure Emit_Subprg_Body (Bod : O_Dnode) - is - use Ortho_Code.Decls; - Kind : OD_Kind; - Decl : O_Dnode; - Idecl : O_Dnode; - Prev_Subprg_Sym : Symbol; - Sibling_Pc : Pc_Type; - begin - Decl := Get_Body_Decl (Bod); - Kind := Get_Decl_Kind (Decl); - - -- Emit interfaces type. - Idecl := Get_Subprg_Interfaces (Decl); - while Idecl /= O_Dnode_Null loop - Emit_Type (Get_Decl_Type (Idecl)); - Idecl := Get_Interface_Chain (Idecl); - end loop; - - if Kind = OD_Function then - Emit_Type (Get_Decl_Type (Decl)); - if Abbrev_Function = 0 then - Generate_Abbrev (Abbrev_Function); - - Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); - --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - Gen_Info_Header (Abbrev_Function); - else - if Abbrev_Procedure = 0 then - Generate_Abbrev (Abbrev_Procedure); - - Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); - --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - Gen_Info_Header (Abbrev_Procedure); - end if; - - Sibling_Pc := Gen_Info_Sibling; - - if Kind = OD_Function then - Emit_Decl_Type (Decl); - end if; - - Emit_Decl_Ident (Decl); - Prev_Subprg_Sym := Subprg_Sym; - Subprg_Sym := Binary.Get_Decl_Symbol (Decl); - Gen_Ua_32 (Subprg_Sym, 0); - Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); - - -- Frame base. - Gen_B8 (1); - Gen_B8 (DW_OP_Reg5); - - -- Interfaces. - Idecl := Get_Subprg_Interfaces (Decl); - if Idecl /= O_Dnode_Null then - if Abbrev_Interface = 0 then - Generate_Abbrev (Abbrev_Interface); - - Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No); - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); - Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); - Gen_Abbrev_Tuple (0, 0); - end if; - - loop - Gen_Info_Header (Abbrev_Interface); - Emit_Decl_Type (Idecl); - Emit_Decl_Ident (Idecl); - - Emit_Local_Location (Idecl); - - Idecl := Get_Interface_Chain (Idecl); - exit when Idecl = O_Dnode_Null; - end loop; - end if; - - -- Internal declarations. - Emit_Block_Decl (Bod + 1); - - -- End of children. - Gen_Uleb128 (0); - - Patch_Info_Sibling (Sibling_Pc); - - Subprg_Sym := Prev_Subprg_Sym; - end Emit_Subprg_Body; - - procedure Emit_Decl (Decl : O_Dnode) - is - use Ada.Text_IO; - use Ortho_Code.Decls; - begin - case Get_Decl_Kind (Decl) is - when OD_Type => - Emit_Type_Decl (Decl); - when OD_Local - | OD_Var => - Emit_Variable (Decl); - when OD_Const => - Emit_Const (Decl); - when OD_Function - | OD_Procedure - | OD_Interface => - null; - when OD_Body => - Emit_Subprg_Body (Decl); - when OD_Block => - Emit_Block_Decl (Decl); - when others => - Put_Line ("dwarf.emit_decl: emit " - & OD_Kind'Image (Get_Decl_Kind (Decl))); - end case; - end Emit_Decl; - - procedure Emit_Subprg (Bod : O_Dnode) is - begin - Emit_Decls_Until (Bod); - Emit_Decl (Bod); - Last_Decl := Decls.Get_Decl_Chain (Bod); - end Emit_Subprg; - - procedure Mark (M : out Mark_Type) is - begin - M.Last_Decl := Last_Decl; - M.Last_Tnode := TOnodes.Last; - end Mark; - - procedure Release (M : Mark_Type) is - begin - Last_Decl := M.Last_Decl; - TOnodes.Set_Last (M.Last_Tnode); - end Release; - -end Ortho_Code.Dwarf; - diff --git a/ortho/mcode/ortho_code-dwarf.ads b/ortho/mcode/ortho_code-dwarf.ads deleted file mode 100644 index c120bcfe1..000000000 --- a/ortho/mcode/ortho_code-dwarf.ads +++ /dev/null @@ -1,41 +0,0 @@ --- Mcode back-end for ortho - Dwarf generator. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ortho_Code.Dwarf is - procedure Init; - procedure Finish; - - -- For a body. - procedure Emit_Subprg (Bod : O_Dnode); - - -- Emit all debug info until but not including LAST. - procedure Emit_Decls_Until (Last : O_Dnode); - - -- For a line in a subprogram. - procedure Set_Line_Stmt (Line : Int32); - procedure Set_Filename (Dir : String; File : String); - - type Mark_Type is limited private; - procedure Mark (M : out Mark_Type); - procedure Release (M : Mark_Type); - -private - type Mark_Type is record - Last_Decl : O_Dnode; - Last_Tnode : O_Tnode; - end record; -end Ortho_Code.Dwarf; diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb deleted file mode 100644 index b2dfa1a67..000000000 --- a/ortho/mcode/ortho_code-exprs.adb +++ /dev/null @@ -1,1663 +0,0 @@ --- Mcode back-end for ortho - Expressions and control handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with Ada.Unchecked_Deallocation; -with GNAT.Table; -with Ortho_Code.Types; use Ortho_Code.Types; -with Ortho_Code.Consts; use Ortho_Code.Consts; -with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Debug; use Ortho_Code.Debug; -with Ortho_Code.Abi; use Ortho_Code.Abi; -with Ortho_Code.Disps; -with Ortho_Code.Opts; -with Ortho_Code.Flags; - -package body Ortho_Code.Exprs is - - type Enode_Pad is mod 256; - - type Enode_Common is record - Kind : OE_Kind; -- about 1 byte (6 bits) - Reg : O_Reg; -- 1 byte - Mode : Mode_Type; -- 4 bits - Ref : Boolean; - Flag1 : Boolean; - Flag2 : Boolean; - Flag3 : Boolean; - Pad : Enode_Pad; - Arg1 : O_Enode; - Arg2 : O_Enode; - Info : Int32; - end record; - pragma Pack (Enode_Common); - for Enode_Common'Size use 4*32; - for Enode_Common'Alignment use 4; - - package Enodes is new GNAT.Table - (Table_Component_Type => Enode_Common, - Table_Index_Type => O_Enode, - Table_Low_Bound => 2, - Table_Initial => 1024, - Table_Increment => 100); - - function Get_Expr_Kind (Enode : O_Enode) return OE_Kind is - begin - return Enodes.Table (Enode).Kind; - end Get_Expr_Kind; - - function Get_Expr_Mode (Enode : O_Enode) return Mode_Type is - begin - return Enodes.Table (Enode).Mode; - end Get_Expr_Mode; - - function Get_Enode_Type (Enode : O_Enode) return O_Tnode is - begin - return O_Tnode (Enodes.Table (Enode).Info); - end Get_Enode_Type; - - function Get_Expr_Reg (Enode : O_Enode) return O_Reg is - begin - return Enodes.Table (Enode).Reg; - end Get_Expr_Reg; - - procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg) is - begin - Enodes.Table (Enode).Reg := Reg; - end Set_Expr_Reg; - - function Get_Expr_Operand (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg1; - end Get_Expr_Operand; - - procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode) is - begin - Enodes.Table (Enode).Arg1 := Val; - end Set_Expr_Operand; - - function Get_Expr_Left (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg1; - end Get_Expr_Left; - - function Get_Expr_Right (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg2; - end Get_Expr_Right; - - procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode) is - begin - Enodes.Table (Enode).Arg1 := Val; - end Set_Expr_Left; - - procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode) is - begin - Enodes.Table (Enode).Arg2 := Val; - end Set_Expr_Right; - - function Get_Expr_Low (Cst : O_Enode) return Uns32 is - begin - return To_Uns32 (Int32 (Enodes.Table (Cst).Arg1)); - end Get_Expr_Low; - - function Get_Expr_High (Cst : O_Enode) return Uns32 is - begin - return To_Uns32 (Int32 (Enodes.Table (Cst).Arg2)); - end Get_Expr_High; - - function Get_Assign_Target (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg2; - end Get_Assign_Target; - - procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode) is - begin - Enodes.Table (Enode).Arg2 := Targ; - end Set_Assign_Target; - - function Get_Expr_Lit (Lit : O_Enode) return O_Cnode is - begin - return O_Cnode (Enodes.Table (Lit).Arg1); - end Get_Expr_Lit; - - function Get_Conv_Type (Enode : O_Enode) return O_Tnode is - begin - return O_Tnode (Enodes.Table (Enode).Arg2); - end Get_Conv_Type; - - -- Leave node corresponding to the entry. - function Get_Entry_Leave (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg1; - end Get_Entry_Leave; - - procedure Set_Entry_Leave (Enode : O_Enode; Leave : O_Enode) is - begin - Enodes.Table (Enode).Arg1 := Leave; - end Set_Entry_Leave; - - function Get_Jump_Label (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg2; - end Get_Jump_Label; - - procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode) is - begin - Enodes.Table (Enode).Arg2 := Label; - end Set_Jump_Label; - - function Get_Addr_Object (Enode : O_Enode) return O_Dnode is - begin - return O_Dnode (Enodes.Table (Enode).Arg1); - end Get_Addr_Object; - - function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg2; - end Get_Addrl_Frame; - - procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode) is - begin - Enodes.Table (Enode).Arg2 := Frame; - end Set_Addrl_Frame; - - function Get_Call_Subprg (Enode : O_Enode) return O_Dnode is - begin - return O_Dnode (Enodes.Table (Enode).Arg1); - end Get_Call_Subprg; - - function Get_Stack_Adjust (Enode : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Enode).Arg1); - end Get_Stack_Adjust; - - function Get_Arg_Link (Enode : O_Enode) return O_Enode is - begin - return Enodes.Table (Enode).Arg2; - end Get_Arg_Link; - - function Get_Block_Decls (Blk : O_Enode) return O_Dnode is - begin - return O_Dnode (Enodes.Table (Blk).Arg2); - end Get_Block_Decls; - - function Get_Block_Parent (Blk : O_Enode) return O_Enode is - begin - return Enodes.Table (Blk).Arg1; - end Get_Block_Parent; - - function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean is - begin - return Enodes.Table (Blk).Flag1; - end Get_Block_Has_Alloca; - - procedure Set_Block_Has_Alloca (Blk : O_Enode; Flag : Boolean) is - begin - Enodes.Table (Blk).Flag1 := Flag; - end Set_Block_Has_Alloca; - - function Get_End_Beg (Blk : O_Enode) return O_Enode is - begin - return Enodes.Table (Blk).Arg1; - end Get_End_Beg; - - function Get_Label_Info (Label : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Label).Arg2); - end Get_Label_Info; - - procedure Set_Label_Info (Label : O_Enode; Info : Int32) is - begin - Enodes.Table (Label).Arg2 := O_Enode (Info); - end Set_Label_Info; - - function Get_Label_Block (Label : O_Enode) return O_Enode is - begin - return Enodes.Table (Label).Arg1; - end Get_Label_Block; - - function Get_Spill_Info (Spill : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Spill).Arg2); - end Get_Spill_Info; - - procedure Set_Spill_Info (Spill : O_Enode; Info : Int32) is - begin - Enodes.Table (Spill).Arg2 := O_Enode (Info); - end Set_Spill_Info; - - -- Get the statement link. - function Get_Stmt_Link (Stmt : O_Enode) return O_Enode is - begin - return O_Enode (Enodes.Table (Stmt).Info); - end Get_Stmt_Link; - - procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode) is - begin - Enodes.Table (Stmt).Info := Int32 (Next); - end Set_Stmt_Link; - - function Get_BB_Next (Stmt : O_Enode) return O_Enode is - begin - return Enodes.Table (Stmt).Arg1; - end Get_BB_Next; - pragma Unreferenced (Get_BB_Next); - - procedure Set_BB_Next (Stmt : O_Enode; Next : O_Enode) is - begin - Enodes.Table (Stmt).Arg1 := Next; - end Set_BB_Next; - - function Get_BB_Number (Stmt : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Stmt).Arg2); - end Get_BB_Number; - - function Get_Loop_Level (Stmt : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Stmt).Arg1); - end Get_Loop_Level; - - procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is - begin - Enodes.Table (Stmt).Arg1 := O_Enode (Level); - end Set_Loop_Level; - - procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is - begin - Enodes.Table (C).Arg2 := Branch; - end Set_Case_Branch; - - procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode) is - begin - Enodes.Table (Branch).Arg1 := Choice; - end Set_Case_Branch_Choice; - - function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode is - begin - return Enodes.Table (Branch).Arg1; - end Get_Case_Branch_Choice; - - procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode) is - begin - Enodes.Table (Choice).Info := Int32 (N_Choice); - end Set_Case_Choice_Link; - - function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode is - begin - return O_Enode (Enodes.Table (Choice).Info); - end Get_Case_Choice_Link; - - function Get_Ref_Field (Ref : O_Enode) return O_Fnode is - begin - return O_Fnode (Enodes.Table (Ref).Arg2); - end Get_Ref_Field; - - function Get_Ref_Index (Ref : O_Enode) return O_Enode is - begin - return Enodes.Table (Ref).Arg2; - end Get_Ref_Index; - - function Get_Expr_Line_Number (Stmt : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Stmt).Arg1); - end Get_Expr_Line_Number; - - function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32 is - begin - return Int32 (Enodes.Table (Stmt).Arg1); - end Get_Intrinsic_Operation; - - Last_Stmt : O_Enode := O_Enode_Null; - - procedure Link_Stmt (Stmt : O_Enode) is - begin - if Last_Stmt = O_Enode_Null then - raise Program_Error; - end if; - Set_Stmt_Link (Last_Stmt, Stmt); - Last_Stmt := Stmt; - end Link_Stmt; - - function New_Enode (Kind : OE_Kind; - Rtype : O_Tnode; - Arg1 : O_Enode; - Arg2 : O_Enode) return O_Enode - is - Mode : Mode_Type; - begin - Mode := Get_Type_Mode (Rtype); - Enodes.Append (Enode_Common'(Kind => Kind, - Reg => 0, - Mode => Mode, - Ref => False, - Flag1 => False, - Flag2 => False, - Flag3 => False, - Pad => 0, - Arg1 => Arg1, - Arg2 => Arg2, - Info => Int32 (Rtype))); - return Enodes.Last; - end New_Enode; - - function New_Enode (Kind : OE_Kind; - Mode : Mode_Type; - Rtype : O_Tnode; - Arg1 : O_Enode; - Arg2 : O_Enode) return O_Enode - is - begin - Enodes.Append (Enode_Common'(Kind => Kind, - Reg => 0, - Mode => Mode, - Ref => False, - Flag1 => False, - Flag2 => False, - Flag3 => False, - Pad => 0, - Arg1 => Arg1, - Arg2 => Arg2, - Info => Int32 (Rtype))); - return Enodes.Last; - end New_Enode; - - procedure New_Enode_Stmt (Kind : OE_Kind; Arg1 : O_Enode; Arg2 : O_Enode) - is - begin - Enodes.Append (Enode_Common'(Kind => Kind, - Reg => 0, - Mode => Mode_Nil, - Ref => False, - Flag1 => False, - Flag2 => False, - Flag3 => False, - Pad => 0, - Arg1 => Arg1, - Arg2 => Arg2, - Info => 0)); - Link_Stmt (Enodes.Last); - end New_Enode_Stmt; - - procedure New_Enode_Stmt - (Kind : OE_Kind; Mode : Mode_Type; Arg1 : O_Enode; Arg2 : O_Enode) - is - begin - Enodes.Append (Enode_Common'(Kind => Kind, - Reg => 0, - Mode => Mode, - Ref => False, - Flag1 => False, - Flag2 => False, - Flag3 => False, - Pad => 0, - Arg1 => Arg1, - Arg2 => Arg2, - Info => 0)); - Link_Stmt (Enodes.Last); - end New_Enode_Stmt; - - Bb_Num : Int32 := 0; - Last_Bb : O_Enode := O_Enode_Null; - - procedure Create_BB is - begin - New_Enode_Stmt (OE_BB, Mode_Nil, O_Enode_Null, O_Enode (Bb_Num)); - if Last_Bb /= O_Enode_Null then - Set_BB_Next (Last_Bb, Enodes.Last); - end if; - Last_Bb := Enodes.Last; - Bb_Num := Bb_Num + 1; - end Create_BB; - - procedure Start_BB is - begin - if Flags.Flag_Opt_BB then - Create_BB; - end if; - end Start_BB; - pragma Inline (Start_BB); - - procedure Check_Ref (E : O_Enode) is - begin - if Enodes.Table (E).Ref then - raise Syntax_Error; - end if; - Enodes.Table (E).Ref := True; - end Check_Ref; - - procedure Check_Ref (E : O_Lnode) is - begin - Check_Ref (O_Enode (E)); - end Check_Ref; - - procedure Check_Value_Type (Val : O_Enode; Vtype : O_Tnode) is - begin - if Get_Enode_Type (Val) /= Vtype then - raise Syntax_Error; - end if; - end Check_Value_Type; - - function New_Const_U32 (Val : Uns32; Vtype : O_Tnode) return O_Enode - is - begin - return New_Enode (OE_Const, Vtype, - O_Enode (To_Int32 (Val)), O_Enode_Null); - end New_Const_U32; - - Last_Decl : O_Dnode := 2; - Cur_Block : O_Enode := O_Enode_Null; - - procedure Start_Declare_Stmt - is - Res : O_Enode; - begin - New_Enode_Stmt (OE_Beg, Cur_Block, O_Enode_Null); - Res := Enodes.Last; - Enodes.Table (Res).Arg2 := O_Enode - (Ortho_Code.Decls.Start_Declare_Stmt); - Cur_Block := Res; - end Start_Declare_Stmt; - - function New_Stack (Rtype : O_Tnode) return O_Enode is - begin - return New_Enode (OE_Get_Stack, Rtype, O_Enode_Null, O_Enode_Null); - end New_Stack; - - procedure New_Stack_Restore (Blk : O_Enode) - is - Save_Asgn : O_Enode; - Save_Var : O_Dnode; - begin - Save_Asgn := Get_Stmt_Link (Blk); - Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn)); - New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)), - O_Enode_Null); - end New_Stack_Restore; - - procedure Finish_Declare_Stmt - is - Parent : O_Dnode; - begin - if Get_Block_Has_Alloca (Cur_Block) then - New_Stack_Restore (Cur_Block); - end if; - New_Enode_Stmt (OE_End, Cur_Block, O_Enode_Null); - Cur_Block := Get_Block_Parent (Cur_Block); - if Cur_Block = O_Enode_Null then - Parent := O_Dnode_Null; - else - Parent := Get_Block_Decls (Cur_Block); - end if; - Ortho_Code.Decls.Finish_Declare_Stmt (Parent); - end Finish_Declare_Stmt; - - function New_Label return O_Enode is - begin - return New_Enode (OE_Label, Mode_Nil, O_Tnode_Null, - Cur_Block, O_Enode_Null); - end New_Label; - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - Start : O_Enode; - D_Body : O_Dnode; - Data : Subprogram_Data_Acc; - begin - if Cur_Subprg = null then - Abi.Start_Body (Func); - end if; - - Start := New_Enode (OE_Entry, Mode_Nil, O_Tnode_Null, - Last_Stmt, O_Enode_Null); - D_Body := Decls.Start_Subprogram_Body (Func, Start); - - -- Create the corresponding decl. - Enodes.Table (Start).Arg2 := O_Enode (D_Body); - - -- Create the data record. - Data := new Subprogram_Data'(Parent => Cur_Subprg, - First_Child => null, - Last_Child => null, - Brother => null, - Depth => Get_Decl_Depth (Func), - D_Decl => Func, - E_Entry => Start, - D_Body => D_Body, - Exit_Label => O_Enode_Null, - Last_Stmt => O_Enode_Null, - Stack_Max => 0); - - if not Flag_Debug_Hli then - Data.Exit_Label := New_Label; - end if; - - -- Link the record. - if Cur_Subprg = null then - -- A top-level subprogram. - if First_Subprg = null then - First_Subprg := Data; - else - Last_Subprg.Brother := Data; - end if; - Last_Subprg := Data; - else - -- A nested subprogram. - if Cur_Subprg.First_Child = null then - Cur_Subprg.First_Child := Data; - else - Cur_Subprg.Last_Child.Brother := Data; - end if; - Cur_Subprg.Last_Child := Data; - - -- Also save last_stmt. - Cur_Subprg.Last_Stmt := Last_Stmt; - end if; - - Cur_Subprg := Data; - Last_Stmt := Start; - - Start_Declare_Stmt; - - -- Create a basic block for the beginning of the subprogram. - Start_BB; - - -- Disp declarations. - if Cur_Subprg.Parent = null then - if Ortho_Code.Debug.Flag_Debug_Body - or Ortho_Code.Debug.Flag_Debug_Code - then - while Last_Decl <= D_Body loop - case Get_Decl_Kind (Last_Decl) is - when OD_Block => - -- Skip blocks. - Disp_Decl (1, Last_Decl); - Last_Decl := Get_Block_Last (Last_Decl) + 1; - when others => - Disp_Decl (1, Last_Decl); - Last_Decl := Last_Decl + 1; - end case; - end loop; - end if; - end if; - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body - is - Parent : Subprogram_Data_Acc; - begin - Finish_Declare_Stmt; - - -- Create a new basic block for the epilog. - Start_BB; - - if not Flag_Debug_Hli then - Link_Stmt (Cur_Subprg.Exit_Label); - end if; - - New_Enode_Stmt (OE_Leave, O_Enode_Null, O_Enode_Null); - - -- Save last statement. - Cur_Subprg.Last_Stmt := Enodes.Last; - -- Set Leave of Entry. - Set_Entry_Leave (Cur_Subprg.E_Entry, Enodes.Last); - - Decls.Finish_Subprogram_Body; - - Parent := Cur_Subprg.Parent; - - if Flags.Flag_Optimize then - Opts.Optimize_Subprg (Cur_Subprg); - end if; - - if Parent = null then - -- This is a top-level subprogram. - if Ortho_Code.Debug.Flag_Disp_Code then - Disps.Disp_Subprg (Cur_Subprg); - end if; - if Ortho_Code.Debug.Flag_Dump_Code then - Disp_Subprg_Body (1, Cur_Subprg.E_Entry); - end if; - if not Ortho_Code.Debug.Flag_Debug_Dump then - Abi.Finish_Body (Cur_Subprg); - end if; - end if; - - -- Restore Cur_Subprg. - Cur_Subprg := Parent; - - -- Restore Last_Stmt. - if Cur_Subprg = null then - Last_Stmt := O_Enode_Null; - else - Last_Stmt := Cur_Subprg.Last_Stmt; - end if; - end Finish_Subprogram_Body; - - function Get_Inner_Alloca (Label : O_Enode) return O_Enode - is - Res : O_Enode := O_Enode_Null; - Blk : O_Enode; - Last_Blk : constant O_Enode := Get_Label_Block (Label); - begin - Blk := Cur_Block; - while Blk /= Last_Blk loop - if Get_Block_Has_Alloca (Blk) then - Res := Blk; - end if; - Blk := Get_Block_Parent (Blk); - end loop; - return Res; - end Get_Inner_Alloca; - - procedure Emit_Jmp (Code : OE_Kind; Expr : O_Enode; Label : O_Enode) - is - begin - -- Discard jump after jump. - if Code /= OE_Jump or else Get_Expr_Kind (Last_Stmt) /= OE_Jump then - New_Enode_Stmt (Code, Expr, Label); - end if; - end Emit_Jmp; - - - -- If there is stack allocated memory to be freed, free it. - -- Then jump to LABEL. - procedure New_Allocb_Jump (Label : O_Enode) - is - Inner_Alloca : O_Enode; - begin - Inner_Alloca := Get_Inner_Alloca (Label); - if Inner_Alloca /= O_Enode_Null then - New_Stack_Restore (Inner_Alloca); - end if; - Emit_Jmp (OE_Jump, O_Enode_Null, Label); - end New_Allocb_Jump; - - function New_Lit (Lit : O_Cnode) return O_Enode - is - L_Type : O_Tnode; - H, L : Uns32; - begin - L_Type := Get_Const_Type (Lit); - if Flag_Debug_Hli then - return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null); - else - case Get_Const_Kind (Lit) is - when OC_Signed - | OC_Unsigned - | OC_Float - | OC_Null - | OC_Lit => - Get_Const_Bytes (Lit, H, L); - return New_Enode - (OE_Const, L_Type, - O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); - when OC_Address - | OC_Subprg_Address => - return New_Enode (OE_Addrg, L_Type, - O_Enode (Get_Const_Decl (Lit)), O_Enode_Null); - when OC_Array - | OC_Record - | OC_Union - | OC_Sizeof - | OC_Alignof => - raise Syntax_Error; - end case; - end if; - end New_Lit; - - function Get_Static_Chain (Depth : O_Depth) return O_Enode - is - Cur_Depth : O_Depth := Cur_Subprg.Depth; - Subprg : Subprogram_Data_Acc; - Res : O_Enode; - begin - if Depth = Cur_Depth then - return New_Enode (OE_Get_Frame, Abi.Mode_Ptr, O_Tnode_Ptr, - O_Enode_Null, O_Enode_Null); - else - Subprg := Cur_Subprg; - Res := O_Enode_Null; - loop - -- The static chain is the first interface of the subprogram. - Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr, - O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)), - Res); - Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null); - Cur_Depth := Cur_Depth - 1; - if Cur_Depth = Depth then - return Res; - end if; - Subprg := Subprg.Parent; - end loop; - end if; - end Get_Static_Chain; - - function New_Obj (Obj : O_Dnode) return O_Lnode - is - O_Type : O_Tnode; - Kind : OE_Kind; - Chain : O_Enode; - Depth : O_Depth; - begin - O_Type := Get_Decl_Type (Obj); - case Get_Decl_Kind (Obj) is - when OD_Local - | OD_Interface => - Kind := OE_Addrl; - -- Local declarations are 1 deeper than their subprogram. - Depth := Get_Decl_Depth (Obj) - 1; - if Depth /= Cur_Subprg.Depth then - Chain := Get_Static_Chain (Depth); - else - Chain := O_Enode_Null; - end if; - when OD_Var - | OD_Const => - Kind := OE_Addrg; - Chain := O_Enode_Null; - when others => - raise Program_Error; - end case; - return O_Lnode (New_Enode (Kind, Abi.Mode_Ptr, O_Type, - O_Enode (Obj), Chain)); - end New_Obj; - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - L_Type : O_Tnode; - begin - L_Type := Get_Enode_Type (Left); - if Flag_Debug_Assert then - if L_Type /= Get_Enode_Type (Right) then - raise Syntax_Error; - end if; - if Get_Type_Mode (L_Type) = Mode_Blk then - raise Syntax_Error; - end if; - Check_Ref (Left); - Check_Ref (Right); - end if; - - return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), - L_Type, Left, Right); - end New_Dyadic_Op; - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode - is - O_Type : O_Tnode; - begin - O_Type := Get_Enode_Type (Operand); - - if Flag_Debug_Assert then - if Get_Type_Mode (O_Type) = Mode_Blk then - raise Syntax_Error; - end if; - Check_Ref (Operand); - end if; - - return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), O_Type, - Operand, O_Enode_Null); - end New_Monadic_Op; - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode - is - Res : O_Enode; - begin - if Flag_Debug_Assert then - if Get_Enode_Type (Left) /= Get_Enode_Type (Right) then - raise Syntax_Error; - end if; - if Get_Expr_Mode (Left) = Mode_Blk then - raise Syntax_Error; - end if; - if Get_Type_Kind (Ntype) /= OT_Boolean then - raise Syntax_Error; - end if; - Check_Ref (Left); - Check_Ref (Right); - end if; - - Res := New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), Ntype, - Left, Right); - if Flag_Debug_Hli then - return New_Enode (OE_Typed, Ntype, Res, O_Enode (Ntype)); - else - return Res; - end if; - end New_Compare_Op; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode is - begin - return New_Const_U32 (Get_Type_Size (Atype), Rtype); - end New_Sizeof; - - function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode is - begin - return New_Const_U32 (Get_Field_Offset (Field), Rtype); - end New_Offsetof; - - function Is_Pow2 (V : Uns32) return Boolean is - begin - return (V and -V) = V; - end Is_Pow2; - - function Extract_Pow2 (V : Uns32) return Uns32 is - begin - for I in Natural range 0 .. 31 loop - if V = Shift_Left (1, I) then - return Uns32 (I); - end if; - end loop; - raise Program_Error; - end Extract_Pow2; - - function New_Index_Slice_Element - (Arr : O_Lnode; Index : O_Enode; Res_Type : O_Tnode) - return O_Lnode - is - El_Type : O_Tnode; - In_Type : O_Tnode; - Sz : O_Enode; - El_Size : Uns32; - begin - El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); - In_Type := Get_Enode_Type (Index); - - if Flag_Debug_Assert then - Check_Ref (Index); - Check_Ref (Arr); - end if; - - -- result := arr + index * sizeof (element). - El_Size := Get_Type_Size (El_Type); - if El_Size = 1 then - Sz := Index; - elsif Get_Expr_Kind (Index) = OE_Const then - -- FIXME: may recycle previous index? - Sz := New_Const_U32 (Get_Expr_Low (Index) * El_Size, In_Type); - else - if Is_Pow2 (El_Size) then - Sz := New_Const_U32 (Extract_Pow2 (El_Size), In_Type); - Sz := New_Enode (OE_Shl, In_Type, Index, Sz); - else - Sz := New_Const_U32 (El_Size, In_Type); - Sz := New_Enode (OE_Mul, In_Type, Index, Sz); - end if; - end if; - return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, - O_Enode (Arr), Sz)); - end New_Index_Slice_Element; - - function New_Hli_Index_Slice - (Kind : OE_Kind; Res_Type : O_Tnode; Arr : O_Lnode; Index : O_Enode) - return O_Lnode - is - begin - if Flag_Debug_Assert then - Check_Ref (Index); - Check_Ref (Arr); - end if; - return O_Lnode (New_Enode (Kind, Res_Type, O_Enode (Arr), Index)); - end New_Hli_Index_Slice; - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode - is - El_Type : O_Tnode; - begin - El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); - - if Flag_Debug_Hli then - return New_Hli_Index_Slice (OE_Index_Ref, El_Type, Arr, Index); - else - return New_Index_Slice_Element (Arr, Index, El_Type); - end if; - end New_Indexed_Element; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - is - begin - if Flag_Debug_Hli then - return New_Hli_Index_Slice (OE_Slice_Ref, Res_Type, Arr, Index); - else - return New_Index_Slice_Element (Arr, Index, Res_Type); - end if; - end New_Slice; - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - Offset : Uns32; - Off : O_Enode; - Res_Type : O_Tnode; - begin - if Flag_Debug_Assert then - Check_Ref (Rec); - end if; - - Res_Type := Get_Field_Type (El); - if Flag_Debug_Hli then - return O_Lnode (New_Enode (OE_Record_Ref, Res_Type, - O_Enode (Rec), O_Enode (El))); - else - Offset := Get_Field_Offset (El); - if Offset = 0 then - return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, - O_Enode (Rec), O_Enode (Res_Type))); - else - Off := New_Enode (OE_Const, Mode_U32, O_Tnode_Null, - O_Enode (Offset), O_Enode_Null); - - return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, - O_Enode (Rec), Off)); - end if; - end if; - end New_Selected_Element; - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - Acc_Type : O_Tnode; - Res_Type : O_Tnode; - begin - Acc_Type := Get_Enode_Type (Acc); - - if Flag_Debug_Assert then - if Get_Type_Kind (Acc_Type) /= OT_Access then - raise Syntax_Error; - end if; - Check_Ref (Acc); - end if; - - Res_Type := Get_Type_Access_Type (Acc_Type); - if Flag_Debug_Hli then - return O_Lnode (New_Enode (OE_Access_Ref, Abi.Mode_Ptr, Res_Type, - Acc, O_Enode_Null)); - else - return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, - Acc, O_Enode (Res_Type))); - end if; - end New_Access_Element; - - function New_Convert_Ov (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_Ov; - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode is - begin - if Flag_Debug_Assert then - if Get_Type_Kind (Atype) /= OT_Access then - raise Syntax_Error; - end if; - Check_Ref (Lvalue); - end if; - - return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, - O_Enode (Lvalue), O_Enode (Atype)); - end New_Unchecked_Address; - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is - begin - if Flag_Debug_Assert then - if Get_Type_Kind (Atype) /= OT_Access then - raise Syntax_Error; - end if; - if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue))) - /= Get_Base_Type (Get_Type_Access_Type (Atype)) - then - raise Syntax_Error; - end if; - Check_Ref (Lvalue); - end if; - - return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, - O_Enode (Lvalue), O_Enode (Atype)); - end New_Address; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Enode is - begin - raise Program_Error; - return O_Enode_Null; - end New_Subprogram_Address; - - function New_Value (Lvalue : O_Lnode) return O_Enode - is - V_Type : O_Tnode; - begin - V_Type := Get_Enode_Type (O_Enode (Lvalue)); - - if Flag_Debug_Assert then - Check_Ref (Lvalue); - end if; - - return New_Enode (OE_Indir, V_Type, O_Enode (Lvalue), O_Enode_Null); - end New_Value; - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - Save_Var : O_Dnode; - Stmt : O_Enode; - St_Type : O_Tnode; - begin - if Flag_Debug_Assert then - Check_Ref (Size); - if Get_Type_Kind (Rtype) /= OT_Access then - raise Syntax_Error; - end if; - if Get_Type_Kind (Get_Enode_Type (Size)) /= OT_Unsigned then - raise Syntax_Error; - end if; - end if; - - if not Get_Block_Has_Alloca (Cur_Block) then - Set_Block_Has_Alloca (Cur_Block, True); - if Stack_Ptr_Type /= O_Tnode_Null then - St_Type := Stack_Ptr_Type; - else - St_Type := Rtype; - end if; - -- Add a decl. - New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type); - -- Add insn to save stack ptr. - Stmt := New_Enode (OE_Asgn, St_Type, - New_Stack (St_Type), - O_Enode (New_Obj (Save_Var))); - if Cur_Block = Last_Stmt then - Set_Stmt_Link (Last_Stmt, Stmt); - Last_Stmt := Stmt; - else - Set_Stmt_Link (Stmt, Get_Stmt_Link (Cur_Block)); - Set_Stmt_Link (Cur_Block, Stmt); - end if; - end if; - - return New_Enode (OE_Alloca, Rtype, Size, O_Enode (Rtype)); - end New_Alloca; - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - Depth : O_Depth; - Arg : O_Enode; - First_Inter : O_Dnode; - begin - First_Inter := Get_Subprg_Interfaces (Subprg); - if Get_Decl_Storage (Subprg) = O_Storage_Local then - Depth := Get_Decl_Depth (Subprg); - Arg := New_Enode (OE_Arg, Abi.Mode_Ptr, O_Tnode_Ptr, - Get_Static_Chain (Depth - 1), O_Enode_Null); - First_Inter := Get_Interface_Chain (First_Inter); - else - Arg := O_Enode_Null; - end if; - Assocs := (Subprg => Subprg, - First_Arg => Arg, - Last_Arg => Arg, - Next_Inter => First_Inter); - end Start_Association; - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) - is - V_Type : O_Tnode; - Mode : Mode_Type; - N_Mode : Mode_Type; - Res : O_Enode; - begin - V_Type := Get_Enode_Type (Val); - - if Flag_Debug_Assert then - if Assocs.Next_Inter = O_Dnode_Null then - -- More assocs than interfaces. - raise Syntax_Error; - end if; - Check_Value_Type (Val, Get_Decl_Type (Assocs.Next_Inter)); - Check_Ref (Val); - end if; - - -- Follow the C convention call: no parameters shorter than int. - Mode := Get_Type_Mode (V_Type); - case Mode is - when Mode_B2 - | Mode_U8 - | Mode_U16 => - N_Mode := Mode_U32; - when Mode_I8 - | Mode_I16 => - N_Mode := Mode_I32; - when Mode_P32 - | Mode_U32 - | Mode_I32 - | Mode_U64 - | Mode_I64 - | Mode_P64 - | Mode_F32 - | Mode_F64 => - N_Mode := Mode; - when Mode_Blk - | Mode_Nil - | Mode_X1 => - 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)); - else - Res := Val; - end if; - Res := New_Enode (OE_Arg, N_Mode, V_Type, Res, O_Enode_Null); - if Assocs.Last_Arg /= O_Enode_Null then - Enodes.Table (Assocs.Last_Arg).Arg2 := Res; - else - Assocs.First_Arg := Res; - end if; - Assocs.Last_Arg := Res; - Assocs.Next_Inter := Get_Interface_Chain (Assocs.Next_Inter); - end New_Association; - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - F_Type : O_Tnode; - begin - if Flag_Debug_Assert then - if Assocs.Next_Inter /= O_Dnode_Null then - -- Not enough assocs. - raise Syntax_Error; - end if; - end if; - - F_Type := Get_Decl_Type (Assocs.Subprg); - return New_Enode (OE_Call, F_Type, - O_Enode (Assocs.Subprg), Assocs.First_Arg); - end New_Function_Call; - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is - begin - if Flag_Debug_Assert then - if Assocs.Next_Inter /= O_Dnode_Null then - -- Not enough assocs. - raise Syntax_Error; - end if; - end if; - New_Enode_Stmt (OE_Call, O_Enode (Assocs.Subprg), Assocs.First_Arg); - end New_Procedure_Call; - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) - is - V_Type : O_Tnode; - begin - V_Type := Get_Enode_Type (Value); - - if Flag_Debug_Assert then - Check_Value_Type (Value, Get_Enode_Type (O_Enode (Target))); - Check_Ref (Value); - Check_Ref (Target); - end if; - - New_Enode_Stmt (OE_Asgn, Get_Type_Mode (V_Type), - Value, O_Enode (Target)); - end New_Assign_Stmt; - - procedure New_Return_Stmt (Value : O_Enode) - is - V_Type : O_Tnode; - begin - V_Type := Get_Enode_Type (Value); - - if Flag_Debug_Assert then - Check_Ref (Value); - Check_Value_Type (Value, Get_Decl_Type (Cur_Subprg.D_Decl)); - end if; - - New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null); - if not Flag_Debug_Hli then - New_Allocb_Jump (Cur_Subprg.Exit_Label); - end if; - end New_Return_Stmt; - - procedure New_Return_Stmt is - begin - if Flag_Debug_Assert then - if Get_Decl_Kind (Cur_Subprg.D_Decl) /= OD_Procedure then - raise Syntax_Error; - end if; - end if; - - if not Flag_Debug_Hli then - New_Allocb_Jump (Cur_Subprg.Exit_Label); - else - New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null); - end if; - end New_Return_Stmt; - - - procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) is - begin - if Flag_Debug_Assert then - if Get_Expr_Mode (Cond) /= Mode_B2 then - -- COND must be a boolean. - raise Syntax_Error; - end if; - Check_Ref (Cond); - end if; - - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_If, Cond, O_Enode_Null); - Block := (Label_End => O_Enode_Null, - Label_Next => Last_Stmt); - else - Block := (Label_End => O_Enode_Null, - Label_Next => New_Label); - Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next); - Start_BB; - end if; - end Start_If_Stmt; - - procedure New_Else_Stmt (Block : in out O_If_Block) is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Else, O_Enode_Null, O_Enode_Null); - else - if Block.Label_End = O_Enode_Null then - Block.Label_End := New_Label; - end if; - Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); - Start_BB; - Link_Stmt (Block.Label_Next); - Block.Label_Next := O_Enode_Null; - end if; - end New_Else_Stmt; - - procedure Finish_If_Stmt (Block : in out O_If_Block) is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null); - else - -- Create a badic-block after the IF. - Start_BB; - if Block.Label_Next /= O_Enode_Null then - Link_Stmt (Block.Label_Next); - end if; - if Block.Label_End /= O_Enode_Null then - Link_Stmt (Block.Label_End); - end if; - end if; - end Finish_If_Stmt; - - procedure Start_Loop_Stmt (Label : out O_Snode) is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null); - Label := (Label_Start => Last_Stmt, - Label_End => O_Enode_Null); - else - -- Create a basic-block at the beginning of the loop. - Start_BB; - Label.Label_Start := New_Label; - Link_Stmt (Label.Label_Start); - Label.Label_End := New_Label; - end if; - end Start_Loop_Stmt; - - procedure Finish_Loop_Stmt (Label : in out O_Snode) - is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null); - else - Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start); - Start_BB; - Link_Stmt (Label.Label_End); - end if; - end Finish_Loop_Stmt; - - procedure New_Exit_Stmt (L : O_Snode) - is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start); - else - New_Allocb_Jump (L.Label_End); - end if; - end New_Exit_Stmt; - - procedure New_Next_Stmt (L : O_Snode) - is - begin - if not Flag_Lower_Stmt then - New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start); - else - New_Allocb_Jump (L.Label_Start); - end if; - end New_Next_Stmt; - - procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode) - is - V_Type : O_Tnode; - Mode : Mode_Type; - Start : O_Enode; - begin - V_Type := Get_Enode_Type (Value); - Mode := Get_Type_Mode (V_Type); - - if Flag_Debug_Assert then - Check_Ref (Value); - case Mode is - when Mode_U8 .. Mode_U64 - | Mode_I8 .. Mode_I64 - | Mode_B2 => - null; - when others => - raise Syntax_Error; - end case; - end if; - - New_Enode_Stmt (OE_Case, Mode, Value, O_Enode_Null); - Start := Enodes.Last; - if Flag_Debug_Hli then - Block := (Expr => Start, - Expr_Type => V_Type, - Last_Node => O_Enode_Null, - Label_End => O_Enode_Null, - Label_Branch => Start); - else - Block := (Expr => Start, - Expr_Type => V_Type, - Last_Node => Start, - Label_End => New_Label, - Label_Branch => O_Enode_Null); - end if; - end Start_Case_Stmt; - - procedure Start_Choice (Block : in out O_Case_Block) - is - B : O_Enode; - begin - if Flag_Debug_Hli then - B := New_Enode (OE_Case_Branch, Mode_Nil, O_Tnode_Null, - O_Enode_Null, O_Enode_Null); - Link_Stmt (B); - -- Link it. - Set_Case_Branch (Block.Label_Branch, B); - Block.Label_Branch := B; - else - -- Jump to the end of the case statement. - -- If there is already a branch open, this is ok - -- (do not fall-through). - -- If there is no branch open, then this is the default choice - -- (nothing to do). - Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); - - -- Create a label for the code of this branch. - Block.Label_Branch := New_Label; - end if; - end Start_Choice; - - procedure Insert_Choice_Stmt (Block : in out O_Case_Block; Stmt : O_Enode) - is - Prev : O_Enode; - begin - Prev := Get_Stmt_Link (Block.Last_Node); - Set_Stmt_Link (Block.Last_Node, Stmt); - Block.Last_Node := Stmt; - if Prev = O_Enode_Null then - Last_Stmt := Stmt; - else - Set_Stmt_Link (Stmt, Prev); - end if; - end Insert_Choice_Stmt; - - procedure Emit_Choice_Jmp (Block : in out O_Case_Block; - Code : OE_Kind; Expr : O_Enode; Label : O_Enode) - is - Jmp : O_Enode; - begin - Jmp := New_Enode (Code, Mode_Nil, O_Tnode_Null, Expr, Label); - Insert_Choice_Stmt (Block, Jmp); - end Emit_Choice_Jmp; - - -- Create a node containing the value of the case expression. - function New_Case_Expr (Block : O_Case_Block) return O_Enode is - begin - return New_Enode (OE_Case_Expr, Block.Expr_Type, - Block.Expr, O_Enode_Null); - end New_Case_Expr; - - procedure New_Hli_Choice (Block : in out O_Case_Block; - Hi, Lo : O_Enode) - is - Res : O_Enode; - begin - Res := New_Enode (OE_Case_Choice, Mode_Nil, O_Tnode_Null, Hi, Lo); - if Block.Label_End = O_Enode_Null then - Set_Case_Branch_Choice (Block.Label_Branch, Res); - else - Set_Case_Choice_Link (Block.Label_End, Res); - end if; - Block.Label_End := Res; - end New_Hli_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) - is - Res : O_Enode; - begin - if Flag_Debug_Hli then - New_Hli_Choice (Block, New_Lit (Expr), O_Enode_Null); - else - Res := New_Enode (OE_Eq, Mode_B2, O_Tnode_Null, - New_Case_Expr (Block), New_Lit (Expr)); - Emit_Choice_Jmp (Block, OE_Jump_T, Res, Block.Label_Branch); - end if; - end New_Expr_Choice; - - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode) - is - E1 : O_Enode; - E2 : O_Enode; - Label : O_Enode; - begin - if Flag_Debug_Hli then - New_Hli_Choice (Block, New_Lit (Low), New_Lit (High)); - else - -- Internal label. - Label := New_Label; - E1 := New_Enode (OE_Lt, Mode_B2, O_Tnode_Null, - New_Case_Expr (Block), New_Lit (Low)); - Emit_Choice_Jmp (Block, OE_Jump_T, E1, Label); - E2 := New_Enode (OE_Le, Mode_B2, O_Tnode_Null, - New_Case_Expr (Block), New_Lit (High)); - Emit_Choice_Jmp (Block, OE_Jump_T, E2, Block.Label_Branch); - Insert_Choice_Stmt (Block, Label); - end if; - end New_Range_Choice; - - procedure New_Default_Choice (Block : in out O_Case_Block) is - begin - if Flag_Debug_Hli then - New_Hli_Choice (Block, O_Enode_Null, O_Enode_Null); - else - -- Jump to the code. - Emit_Choice_Jmp (Block, OE_Jump, O_Enode_Null, Block.Label_Branch); - end if; - end New_Default_Choice; - - procedure Finish_Choice (Block : in out O_Case_Block) is - begin - if Flag_Debug_Hli then - Block.Label_End := O_Enode_Null; - else - -- Put the label of the branch. - Start_BB; - Link_Stmt (Block.Label_Branch); - end if; - end Finish_Choice; - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) is - begin - if Flag_Debug_Hli then - New_Enode_Stmt (OE_Case_End, O_Enode_Null, O_Enode_Null); - else - -- Jump to the end of the case statement. - -- Note: this is not required, since the next instruction is the - -- label. - -- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); - - -- Put the label of the end of the case. - Start_BB; - Link_Stmt (Block.Label_End); - Block.Label_End := O_Enode_Null; - end if; - end Finish_Case_Stmt; - - procedure New_Debug_Line_Stmt (Line : Natural) is - begin - New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null); - end New_Debug_Line_Stmt; - - procedure Debug_Expr (N : O_Enode) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - Indent : constant Count := Col; - begin - Put (Int32 (N), 0); - Set_Col (Indent + 7); - Disp_Mode (Get_Expr_Mode (N)); - Put (" "); - Put (OE_Kind'Image (Get_Expr_Kind (N))); - Set_Col (Indent + 28); --- Put (Abi.Image_Insn (Get_Expr_Insn (N))); --- Put (" "); - Put (Abi.Image_Reg (Get_Expr_Reg (N))); - Put (" "); - Put (Int32 (Enodes.Table (N).Arg1), 7); - Put (Int32 (Enodes.Table (N).Arg2), 7); - Put (Enodes.Table (N).Info, 7); - New_Line; - end Debug_Expr; - - procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode) - is - use Ada.Text_IO; - N : O_Enode; - N_Indent : Natural; - begin - N := Subprg; - if Get_Expr_Kind (N) /= OE_Entry then - raise Program_Error; - end if; - -- Display the entry. - Set_Col (Count (Indent)); - Debug_Expr (N); - -- Display the subprogram, binding. - N_Indent := Indent;-- + 1; - N := N + 1; - loop - case Get_Expr_Kind (N) is - when OE_Entry => - N := Get_Entry_Leave (N) + 1; - when OE_Leave => - Set_Col (Count (Indent)); - Debug_Expr (N); - exit; - when others => - Set_Col (Count (N_Indent)); - Debug_Expr (N); - case Get_Expr_Kind (N) is - when OE_Beg => - Disp_Block (N_Indent + 2, - O_Dnode (Enodes.Table (N).Arg2)); - N_Indent := N_Indent + 1; - when OE_End => - N_Indent := N_Indent - 1; - when others => - null; - end case; - N := N + 1; - end case; - end loop; - end Disp_Subprg_Body; - - procedure Disp_All_Enode is - begin - for I in Enodes.First .. Enodes.Last loop - Debug_Expr (I); - end loop; - end Disp_All_Enode; - - Max_Enode : O_Enode := O_Enode_Null; - - procedure Mark (M : out Mark_Type) is - begin - M.Enode := Enodes.Last; - end Mark; - - procedure Release (M : Mark_Type) is - begin - Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); - Enodes.Set_Last (M.Enode); - end Release; - - procedure Disp_Stats - is - use Ada.Text_IO; - begin - Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); - Put ("Number of Enodes:" & O_Enode'Image (Enodes.Last)); - Put (", max:" & O_Enode'Image (Max_Enode)); - New_Line; - end Disp_Stats; - - procedure Free_Subprogram_Data (Data : in out Subprogram_Data_Acc) - is - procedure Free is new Ada.Unchecked_Deallocation - (Subprogram_Data, Subprogram_Data_Acc); - Ch, N_Ch : Subprogram_Data_Acc; - begin - Ch := Data.First_Child; - while Ch /= null loop - N_Ch := Ch.Brother; - Free_Subprogram_Data (Ch); - Ch := N_Ch; - end loop; - Free (Data); - end Free_Subprogram_Data; - - procedure Finish is - begin - Enodes.Free; - Free_Subprogram_Data (First_Subprg); - end Finish; -end Ortho_Code.Exprs; diff --git a/ortho/mcode/ortho_code-exprs.ads b/ortho/mcode/ortho_code-exprs.ads deleted file mode 100644 index 9bd4596d7..000000000 --- a/ortho/mcode/ortho_code-exprs.ads +++ /dev/null @@ -1,600 +0,0 @@ --- Mcode back-end for ortho - Expressions and control handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ortho_Code.Exprs is - type OE_Kind is - ( - OE_Nil, - - -- Dyadic operations. - -- ARG1 is left, ARG2 is right. - OE_Add_Ov, - OE_Sub_Ov, - OE_Mul_Ov, - OE_Div_Ov, - OE_Rem, - OE_Mod, - - OE_And, - OE_Or, - OE_Xor, - - -- Monadic operations. - -- ARG1 is expression. - OE_Not, - OE_Neg_Ov, - OE_Abs_Ov, - - -- Comparaison. - -- ARG1 is left, ARG2 is right. - OE_Eq, - OE_Neq, - OE_Le, - OE_Lt, - OE_Ge, - OE_Gt, - - -- Without checks, for addresses. - OE_Add, - OE_Mul, - OE_Shl, -- Left shift - - -- A literal. - -- ARG1 is low part, ARG2 is high part. - OE_Const, - - -- Address of a local variable/parameter. - -- ARG1 is object. - -- ARG2 is the frame pointer or O_Enode_Null for current frame pointer. - OE_Addrl, - -- Address of a global variable. - -- ARG1 is object. - OE_Addrg, - - -- Pointer dereference. - -- ARG1 is operand. - OE_Indir, - - -- Conversion. - -- ARG1 is expression. - -- ARG2: type - OE_Conv_Ptr, - OE_Conv, - - -- Typed expression. - OE_Typed, - - -- Local memory allocation. - -- ARG1 is size (in bytes). - OE_Alloca, - - -- Statements. - - -- Subrogram entry. - -- ARG1 is the corresponding Leave (used to skip inner subprograms). - -- ARG2 is unused. - OE_Entry, - -- Subprogram exit. - -- ARG1 and ARG2 are unused. - OE_Leave, - - -- Declaration blocks. - -- ARG1: parent - -- ARG2: corresponding declarations. - OE_Beg, - -- ARG1: corresponding beg - -- ARG2: unsused. - OE_End, - - -- Assignment. - -- ARG1 is value, ARG2 is target (address). - OE_Asgn, - - -- Subprogram calls. - -- ARG1 is value - -- ARG2 is link to the next argument. - OE_Arg, - -- ARG1 is subprogram - -- ARG2 is arguments. - OE_Call, - -- ARG1 is intrinsic operation. - OE_Intrinsic, - - -- Modify the stack pointer value, to align the stack before pushing - -- arguments, or to free the stack. - -- ARG1 is the signed offset. - OE_Stack_Adjust, - - -- Return ARG1 (if not mode_nil) from current subprogram. - -- ARG1: expression. - OE_Ret, - - -- Line number (for debugging). - -- ARG1: line number - OE_Line, - - -- High level instructions. - - -- Basic block. - -- ARG1: next BB - -- ARG2: number - OE_BB, - - -- ARG1 is the literal. - OE_Lit, - -- ARG1: value - -- ARG2: first branch (HLI only). - OE_Case, - -- ARG1: the corresponding OE_Case - OE_Case_Expr, - -- ARG1: left bound - -- ARG2: right bound - -- LINK: choice link - OE_Case_Choice, - -- ARG1: choice link - -- ARG2: next branch - OE_Case_Branch, - -- End of case. - OE_Case_End, - - -- ARG1: the condition - -- ARG2: the else/endif - OE_If, - OE_Else, - OE_Endif, - - -- ARG1: loop level. - OE_Loop, - -- ARG1: loop. - OE_Eloop, - -- ARG2: loop. - OE_Next, - OE_Exit, - - -- ARG1: the record - -- ARG2: the field - OE_Record_Ref, - - -- ARG1: the expression. - OE_Access_Ref, - - -- ARG1: the array - -- ARG2: the index - OE_Index_Ref, - OE_Slice_Ref, - - -- Low level instructions. - - -- Label. - -- ARG1: current block (used for alloca), only during tree building. - -- ARG2: user info (generally used to store symbol). - OE_Label, - - -- Jump to ARG2. - OE_Jump, - - -- Jump to ARG2 if ARG1 is true/false. - OE_Jump_T, - OE_Jump_F, - - -- Used internally only. - -- ARG2 is info/target, ARG1 is expression (if any). - OE_Spill, - OE_Reload, - OE_Move, - - -- Alloca/allocb handling. - OE_Get_Stack, - OE_Set_Stack, - - -- Get current frame pointer. - OE_Get_Frame, - - -- Additionnal reg - OE_Reg - ); - for OE_Kind'Size use 8; - - subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor; - subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt; - - - -- BE representation of an instruction. - type O_Insn is mod 256; - - type Subprogram_Data; - type Subprogram_Data_Acc is access Subprogram_Data; - - type Subprogram_Data is record - -- Parent or null if top-level subprogram. - Parent : Subprogram_Data_Acc; - - -- Block in which this subprogram is declared, or o_dnode_null if - -- top-level subprogram. - --Parent_Block : O_Dnode; - - -- First and last child, or null if no children. - First_Child : Subprogram_Data_Acc; - Last_Child : Subprogram_Data_Acc; - - -- Next subprogram at the same depth level. - Brother : Subprogram_Data_Acc; - - -- Depth of the subprogram. - Depth : O_Depth; - - -- Dnode for the declaration. - D_Decl : O_Dnode; - - -- Enode for the Entry. - E_Entry : O_Enode; - - -- Dnode for the Body. - D_Body : O_Dnode; - - -- Label just before leave. - Exit_Label : O_Enode; - - -- Last statement of this subprogram. - Last_Stmt : O_Enode; - - -- Static maximum stack use. - Stack_Max : Uns32; - end record; - - -- Data for the current subprogram. - Cur_Subprg : Subprogram_Data_Acc := null; - - -- First and last (top-level) subprogram. - First_Subprg : Subprogram_Data_Acc := null; - Last_Subprg : Subprogram_Data_Acc := null; - - -- Type of the stack pointer - for OE_Get_Stack and OE_Set_Stack. - -- Can be set by back-ends. - Stack_Ptr_Type : O_Tnode := O_Tnode_Null; - - -- Create a new node. - -- Should be used only by back-end to add internal nodes. - function New_Enode (Kind : OE_Kind; - Mode : Mode_Type; - Rtype : O_Tnode; - Arg1 : O_Enode; - Arg2 : O_Enode) return O_Enode; - - -- Get the kind of ENODE. - function Get_Expr_Kind (Enode : O_Enode) return OE_Kind; - pragma Inline (Get_Expr_Kind); - - -- Get the mode of ENODE. - function Get_Expr_Mode (Enode : O_Enode) return Mode_Type; - pragma Inline (Get_Expr_Mode); - - -- Get/Set the register of ENODE. - function Get_Expr_Reg (Enode : O_Enode) return O_Reg; - procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg); - pragma Inline (Get_Expr_Reg); - pragma Inline (Set_Expr_Reg); - - -- Get the operand of an unary expression. - function Get_Expr_Operand (Enode : O_Enode) return O_Enode; - procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode); - - -- Get left/right operand of a binary expression. - function Get_Expr_Left (Enode : O_Enode) return O_Enode; - function Get_Expr_Right (Enode : O_Enode) return O_Enode; - procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode); - procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode); - - -- Get the low and high part of an OE_CONST node. - function Get_Expr_Low (Cst : O_Enode) return Uns32; - function Get_Expr_High (Cst : O_Enode) return Uns32; - - -- Get target of the assignment. - function Get_Assign_Target (Enode : O_Enode) return O_Enode; - procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode); - - -- For OE_Lit: get the literal. - function Get_Expr_Lit (Lit : O_Enode) return O_Cnode; - - -- Type of a OE_Conv/OE_Nop/OE_Typed/OE_Alloca - -- Used only for display/debugging purposes. - function Get_Conv_Type (Enode : O_Enode) return O_Tnode; - - -- Leave node corresponding to the entry. - function Get_Entry_Leave (Enode : O_Enode) return O_Enode; - - -- Get the label of a jump/ret - function Get_Jump_Label (Enode : O_Enode) return O_Enode; - procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode); - - -- Get the object of addrl,addrp,addrg - function Get_Addr_Object (Enode : O_Enode) return O_Dnode; - - -- Get the computed frame for the object. - -- If O_Enode_Null, then use current frame. - function Get_Addrl_Frame (Enode : O_Enode) return O_Enode; - procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode); - - -- Return the stack adjustment. For positive values, this is the amount of - -- bytes to allocate on the stack before pushing arguments, so that the - -- stack pointer stays aligned. For negtive values, this is the amount of - -- bytes to release on the stack. - function Get_Stack_Adjust (Enode : O_Enode) return Int32; - - -- Get the subprogram called by ENODE. - function Get_Call_Subprg (Enode : O_Enode) return O_Dnode; - - -- Get the first argument of a call, or the next argument of an arg. - function Get_Arg_Link (Enode : O_Enode) return O_Enode; - - -- Get the declaration chain of a Beg statement. - function Get_Block_Decls (Blk : O_Enode) return O_Dnode; - - -- Get the parent of the block. - function Get_Block_Parent (Blk : O_Enode) return O_Enode; - - -- Get the corresponding beg. - function Get_End_Beg (Blk : O_Enode) return O_Enode; - - -- True if the block contains an alloca insn. - function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean; - - -- Set the next branch of a case/case_branch. - procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode); - - -- Set the first choice of a case branch. - procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode); - function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode; - - -- Set the choice link of a case choice. - procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode); - function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode; - - -- Get/Set the max stack size for the end block BLKE. - --function Get_Block_Max_Stack (Blke : O_Enode) return Int32; - --procedure Set_Block_Max_Stack (Blke : O_Enode; Max : Int32); - - -- Get the field of an o_record_ref node. - function Get_Ref_Field (Ref : O_Enode) return O_Fnode; - - -- Get the index of an OE_Index_Ref or OE_Slice_Ref node. - function Get_Ref_Index (Ref : O_Enode) return O_Enode; - - -- Get/Set the info field of a label. - function Get_Label_Info (Label : O_Enode) return Int32; - procedure Set_Label_Info (Label : O_Enode; Info : Int32); - - -- Get the info of a spill. - function Get_Spill_Info (Spill : O_Enode) return Int32; - procedure Set_Spill_Info (Spill : O_Enode; Info : Int32); - - -- Get the statement link. - function Get_Stmt_Link (Stmt : O_Enode) return O_Enode; - procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode); - - -- Get the line number of an OE_Line statement. - function Get_Expr_Line_Number (Stmt : O_Enode) return Int32; - - -- Get the operation of an intrinsic. - function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32; - - -- Get the basic block label (uniq number). - function Get_BB_Number (Stmt : O_Enode) return Int32; - - -- For OE_Loop, set loop level (an integer). - -- Reserved for back-end in HLI mode only. - function Get_Loop_Level (Stmt : O_Enode) return Int32; - procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32); - - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - -- Translate a scalar literal into an expression. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Translate an object (var, const or interface) into an lvalue. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode; - - -- Returns the offset of FIELD in its record. The result is a literal - -- of unsigned type RTYPE. - function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode; - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (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. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - type O_Assoc_List is limited private; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - type O_If_Block is limited private; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - type O_Snode is private; - O_Snode_Null : constant O_Snode; - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - type O_Case_Block is limited private; - procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode); - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - procedure New_Debug_Line_Stmt (Line : Natural); - - procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode); - procedure Disp_All_Enode; - procedure Disp_Stats; - - type Mark_Type is limited private; - procedure Mark (M : out Mark_Type); - procedure Release (M : Mark_Type); - - procedure Finish; -private - type O_Assoc_List is record - -- Subprogram being called. - Subprg : O_Dnode; - -- First and last argument statement. - First_Arg : O_Enode; - Last_Arg : O_Enode; - -- Interface for the next association. - Next_Inter : O_Dnode; - end record; - - type O_Case_Block is record - -- Expression for the selection. - Expr : O_Enode; - - -- Type of expression. - -- Used to perform checks. - Expr_Type : O_Tnode; - - -- Choice code and branch code is not mixed (anymore). - -- Therefore, code to perform choices is inserted. - -- Last node of the choice code. - Last_Node : O_Enode; - - -- Label at the end of the case statement. - -- used to jump from the end of a branch to the end of the statement. - Label_End : O_Enode; - - -- Label of the branch code. - Label_Branch : O_Enode; - end record; - - type O_If_Block is record - Label_End : O_Enode; - Label_Next : O_Enode; - end record; - - type O_Snode is record - Label_Start : O_Enode; - Label_End : O_Enode; - end record; - O_Snode_Null : constant O_Snode := (Label_Start => O_Enode_Null, - Label_End => O_Enode_Null); - - type Mark_Type is record - Enode : O_Enode; - end record; -end Ortho_Code.Exprs; diff --git a/ortho/mcode/ortho_code-flags.ads b/ortho/mcode/ortho_code-flags.ads deleted file mode 100644 index 805f3779b..000000000 --- a/ortho/mcode/ortho_code-flags.ads +++ /dev/null @@ -1,35 +0,0 @@ --- Compile flags for mcode. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ortho_Code.Flags is - type Debug_Type is (Debug_None, Debug_Dwarf); - - -- Debugging information generated. - Flag_Debug : Debug_Type := Debug_None; - - -- If set, generate a map from type to type declaration. - Flag_Type_Name : Boolean := False; - - -- If set, enable optimiztions. - Flag_Optimize : Boolean := False; - - -- If set, create basic blocks during tree building. - Flag_Opt_BB : Boolean := False; - - -- If set, add profiling calls. - Flag_Profile : Boolean := False; -end Ortho_Code.Flags; diff --git a/ortho/mcode/ortho_code-opts.adb b/ortho/mcode/ortho_code-opts.adb deleted file mode 100644 index 0ea6b039b..000000000 --- a/ortho/mcode/ortho_code-opts.adb +++ /dev/null @@ -1,214 +0,0 @@ --- Mcode back-end for ortho - Optimization. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Flags; - -package body Ortho_Code.Opts is - procedure Relabel_Jump (Jmp : O_Enode) - is - Label : O_Enode; - Bb : O_Enode; - begin - Label := Get_Jump_Label (Jmp); - if Get_Expr_Kind (Label) = OE_Label then - Bb := O_Enode (Get_Label_Info (Label)); - if Bb /= O_Enode_Null then - Set_Jump_Label (Jmp, Bb); - end if; - end if; - end Relabel_Jump; - - procedure Jmp_To_Bb (Subprg : Subprogram_Data_Acc) - is - First : O_Enode; - Stmt : O_Enode; - Prev : O_Enode; - Cur_Bb : O_Enode; - begin - -- Get first statement after entry. - First := Get_Stmt_Link (Subprg.E_Entry); - - -- First loop: - -- If a label belongs to a BB (ie, is at the beginning of a BB), - -- then link it to the BB. - Stmt := First; - Cur_Bb := O_Enode_Null; - loop - case Get_Expr_Kind (Stmt) is - when OE_Leave => - exit; - when OE_BB => - Cur_Bb := Stmt; - when OE_Label => - if Cur_Bb /= O_Enode_Null then - Set_Label_Info (Stmt, Int32 (Cur_Bb)); - end if; - when OE_Jump - | OE_Jump_T - | OE_Jump_F => - -- This handles backward jump. - Relabel_Jump (Stmt); - when others => - Cur_Bb := O_Enode_Null; - end case; - Stmt := Get_Stmt_Link (Stmt); - end loop; - - -- Second loop: - -- Transform jump to label to jump to BB. - Stmt := First; - Prev := O_Enode_Null; - loop - case Get_Expr_Kind (Stmt) is - when OE_Leave => - exit; - when OE_Jump - | OE_Jump_T - | OE_Jump_F => - -- This handles forward jump. - Relabel_Jump (Stmt); - -- Update PREV. - Prev := Stmt; - when OE_Label => - -- Remove the Label. - -- Do not update PREV. - if Get_Label_Info (Stmt) /= 0 then - Set_Stmt_Link (Prev, Get_Stmt_Link (Stmt)); - end if; - when others => - Prev := Stmt; - end case; - Stmt := Get_Stmt_Link (Stmt); - end loop; - end Jmp_To_Bb; - - type Oe_Kind_Bool_Array is array (OE_Kind) of Boolean; - Is_Passive_Stmt : constant Oe_Kind_Bool_Array := - (OE_Label | OE_BB | OE_End | OE_Beg => True, - others => False); - - -- Return the next statement after STMT which really execute instructions. - function Get_Fall_Stmt (Stmt : O_Enode) return O_Enode - is - Res : O_Enode; - begin - Res := Stmt; - loop - Res := Get_Stmt_Link (Res); - case Get_Expr_Kind (Res) is - when OE_Label - | OE_BB - | OE_End - | OE_Beg => - null; - when others => - return Res; - end case; - end loop; - end Get_Fall_Stmt; - pragma Unreferenced (Get_Fall_Stmt); - - procedure Thread_Jump (Subprg : Subprogram_Data_Acc) - is - First : O_Enode; - Stmt : O_Enode; - Prev, Next : O_Enode; - Kind : OE_Kind; - begin - -- Get first statement after entry. - First := Get_Stmt_Link (Subprg.E_Entry); - - -- First loop: - -- If a label belongs to a BB (ie, is at the beginning of a BB), - -- then link it to the BB. - Stmt := First; - Prev := O_Enode_Null; - loop - Next := Get_Stmt_Link (Stmt); - Kind := Get_Expr_Kind (Stmt); - case Kind is - when OE_Leave => - exit; - when OE_Jump => - -- Remove the jump if followed by the label. - -- * For _T/_F: should convert to a ignore value. - -- Discard unreachable statements after the jump. - declare - N_Stmt : O_Enode; - P_Stmt : O_Enode; - Label : O_Enode; - Flag_Discard : Boolean; - K_Stmt : OE_Kind; - begin - N_Stmt := Next; - P_Stmt := Stmt; - Label := Get_Jump_Label (Stmt); - Flag_Discard := True; - loop - if N_Stmt = Label then - -- Remove STMT. - Set_Stmt_Link (Prev, Next); - exit; - end if; - K_Stmt := Get_Expr_Kind (N_Stmt); - if K_Stmt = OE_Label then - -- Do not discard anymore statements, since they are - -- now reachable. - Flag_Discard := False; - end if; - if not Is_Passive_Stmt (K_Stmt) then - if not Flag_Discard then - -- We have found the next statement. - -- Keep the jump. - Prev := Stmt; - exit; - else - -- Delete insn. - N_Stmt := Get_Stmt_Link (N_Stmt); - Set_Stmt_Link (P_Stmt, N_Stmt); - end if; - else - -- Iterate. - P_Stmt := N_Stmt; - N_Stmt := Get_Stmt_Link (N_Stmt); - end if; - end loop; - end; - when others => - Prev := Stmt; - end case; - Stmt := Next; - end loop; - end Thread_Jump; - - procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc) - is - begin - -- Jump optimisation: - -- * discard insns after a OE_JUMP. - -- * Remove jump if followed by label - -- (through label, BB, comments, end, line) - -- * Redirect jump to jump (infinite loop !) - -- * Revert jump_t/f if expr is not (XXX) - -- * Jmp_t/f L:; jmp L2; L1: -> jmp_f/t L2 - Thread_Jump (Subprg); - if Flags.Flag_Opt_BB then - Jmp_To_Bb (Subprg); - end if; - end Optimize_Subprg; -end Ortho_Code.Opts; - diff --git a/ortho/mcode/ortho_code-opts.ads b/ortho/mcode/ortho_code-opts.ads deleted file mode 100644 index 27a907c7b..000000000 --- a/ortho/mcode/ortho_code-opts.ads +++ /dev/null @@ -1,22 +0,0 @@ --- Mcode back-end for ortho - Optimization. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Exprs; use Ortho_Code.Exprs; - -package Ortho_Code.Opts is - procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc); -end Ortho_Code.Opts; diff --git a/ortho/mcode/ortho_code-types.adb b/ortho/mcode/ortho_code-types.adb deleted file mode 100644 index e0c070c27..000000000 --- a/ortho/mcode/ortho_code-types.adb +++ /dev/null @@ -1,820 +0,0 @@ --- Mcode back-end for ortho - type handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with Ada.Unchecked_Conversion; -with GNAT.Table; -with Ortho_Code.Consts; use Ortho_Code.Consts; -with Ortho_Code.Debug; -with Ortho_Code.Abi; use Ortho_Code.Abi; -with Ortho_Ident; - -package body Ortho_Code.Types is - type Bool_Array is array (Natural range <>) of Boolean; - pragma Pack (Bool_Array); - - type Tnode_Common is record - Kind : OT_Kind; -- 4 bits. - Mode : Mode_Type; -- 4 bits. - Align : Small_Natural; -- 2 bits. - Deferred : Boolean; -- 1 bit (True if the type was incomplete at first) - Flag1 : Boolean; - Pad0 : Bool_Array (0 .. 19); - Size : Uns32; - end record; - pragma Pack (Tnode_Common); - for Tnode_Common'Size use 64; - - type Tnode_Access is record - Dtype : O_Tnode; - Pad : Uns32; - end record; - - type Tnode_Array is record - Element_Type : O_Tnode; - Index_Type : O_Tnode; - end record; - - type Tnode_Subarray is record - Base_Type : O_Tnode; - Length : Uns32; - end record; - - type Tnode_Record is record - Fields : O_Fnode; - Nbr_Fields : Uns32; - end record; - - type Tnode_Enum is record - Lits : O_Cnode; - Nbr_Lits : Uns32; - end record; - - type Tnode_Bool is record - Lit_False : O_Cnode; - Lit_True : O_Cnode; - end record; - - package Tnodes is new GNAT.Table - (Table_Component_Type => Tnode_Common, - Table_Index_Type => O_Tnode, - Table_Low_Bound => O_Tnode_First, - Table_Initial => 128, - Table_Increment => 100); - - type Field_Type is record - Parent : O_Tnode; - Ident : O_Ident; - Ftype : O_Tnode; - Offset : Uns32; - Next : O_Fnode; - end record; - - package Fnodes is new GNAT.Table - (Table_Component_Type => Field_Type, - Table_Index_Type => O_Fnode, - Table_Low_Bound => 2, - Table_Initial => 64, - Table_Increment => 100); - - function Get_Type_Kind (Atype : O_Tnode) return OT_Kind is - begin - return Tnodes.Table (Atype).Kind; - end Get_Type_Kind; - - function Get_Type_Size (Atype : O_Tnode) return Uns32 is - begin - return Tnodes.Table (Atype).Size; - end Get_Type_Size; - - function Get_Type_Align (Atype : O_Tnode) return Small_Natural is - begin - return Tnodes.Table (Atype).Align; - end Get_Type_Align; - - function Get_Type_Align_Bytes (Atype : O_Tnode) return Uns32 is - begin - return 2 ** Get_Type_Align (Atype); - end Get_Type_Align_Bytes; - - function Get_Type_Mode (Atype : O_Tnode) return Mode_Type is - begin - return Tnodes.Table (Atype).Mode; - end Get_Type_Mode; - - function Get_Type_Deferred (Atype : O_Tnode) return Boolean is - begin - return Tnodes.Table (Atype).Deferred; - end Get_Type_Deferred; - - function Get_Type_Flag1 (Atype : O_Tnode) return Boolean is - begin - return Tnodes.Table (Atype).Flag1; - end Get_Type_Flag1; - - procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean) is - begin - Tnodes.Table (Atype).Flag1 := Flag; - end Set_Type_Flag1; - - function To_Tnode_Access is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Access); - - function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode - is - begin - return To_Tnode_Access (Tnodes.Table (Atype + 1)).Dtype; - end Get_Type_Access_Type; - - - function To_Tnode_Array is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Array); - - function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode is - begin - return To_Tnode_Array (Tnodes.Table (Atype + 1)).Index_Type; - end Get_Type_Ucarray_Index; - - function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode is - begin - return To_Tnode_Array (Tnodes.Table (Atype + 1)).Element_Type; - end Get_Type_Ucarray_Element; - - - function To_Tnode_Subarray is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Subarray); - - function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode is - begin - return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Base_Type; - end Get_Type_Subarray_Base; - - function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32 is - begin - return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Length; - end Get_Type_Subarray_Length; - - - function To_Tnode_Record is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Record); - - function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode is - begin - return To_Tnode_Record (Tnodes.Table (Atype + 1)).Fields; - end Get_Type_Record_Fields; - - function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32 is - begin - return To_Tnode_Record (Tnodes.Table (Atype + 1)).Nbr_Fields; - end Get_Type_Record_Nbr_Fields; - - function To_Tnode_Enum is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Enum); - - function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode is - begin - return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Lits; - end Get_Type_Enum_Lits; - - function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode - is - F : O_Cnode; - begin - F := Get_Type_Enum_Lits (Atype); - return F + 2 * O_Cnode (Pos); - end Get_Type_Enum_Lit; - - function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32 is - begin - return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Nbr_Lits; - end Get_Type_Enum_Nbr_Lits; - - - function To_Tnode_Bool is new Ada.Unchecked_Conversion - (Source => Tnode_Common, Target => Tnode_Bool); - - function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode is - begin - return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_False; - end Get_Type_Bool_False; - - function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode is - begin - return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_True; - end Get_Type_Bool_True; - - function Get_Field_Offset (Field : O_Fnode) return Uns32 is - begin - return Fnodes.Table (Field).Offset; - end Get_Field_Offset; - - procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32) is - begin - Fnodes.Table (Field).Offset := Offset; - end Set_Field_Offset; - - function Get_Field_Parent (Field : O_Fnode) return O_Tnode is - begin - return Fnodes.Table (Field).Parent; - end Get_Field_Parent; - - function Get_Field_Type (Field : O_Fnode) return O_Tnode is - begin - return Fnodes.Table (Field).Ftype; - end Get_Field_Type; - - function Get_Field_Ident (Field : O_Fnode) return O_Ident is - begin - return Fnodes.Table (Field).Ident; - end Get_Field_Ident; - - function Get_Field_Chain (Field : O_Fnode) return O_Fnode is - begin - return Fnodes.Table (Field).Next; - end Get_Field_Chain; - - function New_Unsigned_Type (Size : Natural) return O_Tnode - is - Mode : Mode_Type; - Sz : Uns32; - begin - case Size is - when 8 => - Mode := Mode_U8; - Sz := 1; - when 16 => - Mode := Mode_U16; - Sz := 2; - when 32 => - Mode := Mode_U32; - Sz := 4; - when 64 => - Mode := Mode_U64; - Sz := 8; - when others => - raise Program_Error; - end case; - Tnodes.Append (Tnode_Common'(Kind => OT_Unsigned, - Mode => Mode, - Align => Mode_Align (Mode), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => Sz)); - return Tnodes.Last; - end New_Unsigned_Type; - - function New_Signed_Type (Size : Natural) return O_Tnode - is - Mode : Mode_Type; - Sz : Uns32; - begin - case Size is - when 8 => - Mode := Mode_I8; - Sz := 1; - when 16 => - Mode := Mode_I16; - Sz := 2; - when 32 => - Mode := Mode_I32; - Sz := 4; - when 64 => - Mode := Mode_I64; - Sz := 8; - when others => - raise Program_Error; - end case; - Tnodes.Append (Tnode_Common'(Kind => OT_Signed, - Mode => Mode, - Align => Mode_Align (Mode), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => Sz)); - return Tnodes.Last; - end New_Signed_Type; - - function New_Float_Type return O_Tnode is - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Float, - Mode => Mode_F64, - Align => Mode_Align (Mode_F64), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => 8)); - return Tnodes.Last; - end New_Float_Type; - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Enum, Target => Tnode_Common); - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) - is - Mode : Mode_Type; - Sz : Uns32; - begin - case Size is - when 8 => - Mode := Mode_U8; - Sz := 1; - when 16 => - Mode := Mode_U16; - Sz := 2; - when 32 => - Mode := Mode_U32; - Sz := 4; - when 64 => - Mode := Mode_U64; - Sz := 8; - when others => - raise Program_Error; - end case; - Tnodes.Append (Tnode_Common'(Kind => OT_Enum, - Mode => Mode, - Align => Mode_Align (Mode), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => Sz)); - List := (Res => Tnodes.Last, - First => O_Cnode_Null, - Last => O_Cnode_Null, - Nbr => 0); - Tnodes.Increment_Last; - end Start_Enum_Type; - - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode) - is - begin - Res := New_Named_Literal (List.Res, Ident, List.Nbr, List.Last); - List.Nbr := List.Nbr + 1; - if List.Last = O_Cnode_Null then - List.First := Res; - end if; - List.Last := Res; - end New_Enum_Literal; - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Res := List.Res; - Tnodes.Table (List.Res + 1) := To_Tnode_Common - (Tnode_Enum'(Lits => List.First, - Nbr_Lits => List.Nbr)); - end Finish_Enum_Type; - - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Bool, Target => Tnode_Common); - - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode) - is - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Boolean, - Mode => Mode_B2, - Align => 0, - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => 1)); - Res := Tnodes.Last; - False_E := New_Named_Literal (Res, False_Id, 0, O_Cnode_Null); - True_E := New_Named_Literal (Res, True_Id, 1, False_E); - Tnodes.Append (To_Tnode_Common (Tnode_Bool'(Lit_False => False_E, - Lit_True => True_E))); - end New_Boolean_Type; - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Array, Target => Tnode_Common); - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode - is - Res : O_Tnode; - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Ucarray, - Mode => Mode_Blk, - Align => Get_Type_Align (El_Type), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => 0)); - Res := Tnodes.Last; - Tnodes.Append (To_Tnode_Common (Tnode_Array'(Element_Type => El_Type, - Index_Type => Index_Type))); - return Res; - end New_Array_Type; - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Subarray, Target => Tnode_Common); - - function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32) - return O_Tnode - is - Res : O_Tnode; - Size : Uns32; - begin - Size := Get_Type_Size (Get_Type_Array_Element (Atype)); - Tnodes.Append (Tnode_Common'(Kind => OT_Subarray, - Mode => Mode_Blk, - Align => Get_Type_Align (Atype), - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => Size * Length)); - Res := Tnodes.Last; - Tnodes.Append (To_Tnode_Common (Tnode_Subarray'(Base_Type => Atype, - Length => Length))); - return Res; - end New_Constrained_Array_Type; - - procedure Create_Completer (Atype : O_Tnode) is - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Complete, - Mode => Mode_Nil, - Align => 0, - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => To_Uns32 (Int32 (Atype)))); - end Create_Completer; - - function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode is - begin - return O_Tnode (To_Int32 (Tnodes.Table (Atype).Size)); - end Get_Type_Complete_Type; - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Access, Target => Tnode_Common); - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode - is - Res : O_Tnode; - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Access, - Mode => Mode_P32, - Align => Mode_Align (Mode_P32), - Deferred => Dtype = O_Tnode_Null, - Flag1 => False, - Pad0 => (others => False), - Size => 4)); - Res := Tnodes.Last; - Tnodes.Append (To_Tnode_Common (Tnode_Access'(Dtype => Dtype, - Pad => 0))); - return Res; - end New_Access_Type; - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is - begin - if Get_Type_Access_Type (Atype) /= O_Tnode_Null then - raise Program_Error; - end if; - Tnodes.Table (Atype + 1) := - To_Tnode_Common (Tnode_Access'(Dtype => Dtype, - Pad => 0)); - if Flag_Type_Completer then - Create_Completer (Atype); - end if; - end Finish_Access_Type; - - - function To_Tnode_Common is new Ada.Unchecked_Conversion - (Source => Tnode_Record, Target => Tnode_Common); - - function Create_Record_Type (Deferred : Boolean) return O_Tnode - is - Res : O_Tnode; - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Record, - Mode => Mode_Blk, - Align => 0, - Deferred => Deferred, - Flag1 => False, - Pad0 => (others => False), - Size => 0)); - Res := Tnodes.Last; - Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null, - Nbr_Fields => 0))); - return Res; - end Create_Record_Type; - - procedure Start_Record_Type (Elements : out O_Element_List) - is - begin - Elements := (Res => Create_Record_Type (False), - First_Field => O_Fnode_Null, - Last_Field => O_Fnode_Null, - Off => 0, - Align => 0, - Nbr => 0); - end Start_Record_Type; - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is - begin - Res := Create_Record_Type (True); - end New_Uncomplete_Record_Type; - - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) - is - begin - Elements := (Res => Res, - First_Field => O_Fnode_Null, - Last_Field => O_Fnode_Null, - Off => 0, - Align => 0, - Nbr => 0); - end Start_Uncomplete_Record_Type; - - function Get_Mode_Size (Mode : Mode_Type) return Uns32 is - begin - case Mode is - when Mode_B2 - | Mode_U8 - | Mode_I8 => - return 1; - when Mode_I16 - | Mode_U16 => - return 2; - when Mode_I32 - | Mode_U32 - | Mode_P32 - | Mode_F32 => - return 4; - when Mode_I64 - | Mode_U64 - | Mode_P64 - | Mode_F64 => - return 8; - when Mode_X1 - | Mode_Nil - | Mode_Blk => - raise Program_Error; - end case; - end Get_Mode_Size; - - function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32 - is - Msk : constant Uns32 := Get_Type_Align_Bytes (Atype) - 1; - begin - -- Align. - return (Off + Msk) and (not Msk); - end Do_Align; - - function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32 - is - Msk : constant Uns32 := (2 ** Mode_Align (Mode)) - 1; - begin - -- Align. - return (Off + Msk) and (not Msk); - end Do_Align; - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - begin - Elements.Off := Do_Align (Elements.Off, Etype); - - Fnodes.Append (Field_Type'(Parent => Elements.Res, - Ident => Ident, - Ftype => Etype, - Offset => Elements.Off, - Next => O_Fnode_Null)); - El := Fnodes.Last; - Elements.Off := Elements.Off + Get_Type_Size (Etype); - if Get_Type_Align (Etype) > Elements.Align then - Elements.Align := Get_Type_Align (Etype); - end if; - if Elements.Last_Field /= O_Fnode_Null then - Fnodes.Table (Elements.Last_Field).Next := Fnodes.Last; - else - Elements.First_Field := Fnodes.Last; - end if; - Elements.Last_Field := Fnodes.Last; - Elements.Nbr := Elements.Nbr + 1; - end New_Record_Field; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) - is - begin - Tnodes.Table (Elements.Res).Size := Do_Align (Elements.Off, - Elements.Res); - Tnodes.Table (Elements.Res).Align := Elements.Align; - Tnodes.Table (Elements.Res + 1) := To_Tnode_Common - (Tnode_Record'(Fields => Elements.First_Field, - Nbr_Fields => Elements.Nbr)); - Res := Elements.Res; - if Flag_Type_Completer - and then Tnodes.Table (Elements.Res).Deferred - then - Create_Completer (Elements.Res); - end if; - end Finish_Record_Type; - - procedure Start_Union_Type (Elements : out O_Element_List) - is - begin - Tnodes.Append (Tnode_Common'(Kind => OT_Union, - Mode => Mode_Blk, - Align => 0, - Deferred => False, - Flag1 => False, - Pad0 => (others => False), - Size => 0)); - Elements := (Res => Tnodes.Last, - First_Field => O_Fnode_Null, - Last_Field => O_Fnode_Null, - Off => 0, - Align => 0, - Nbr => 0); - Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null, - Nbr_Fields => 0))); - end Start_Union_Type; - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - Off : Uns32; - begin - Off := Elements.Off; - Elements.Off := 0; - New_Record_Field (Elements, El, Ident, Etype); - if Off > Elements.Off then - Elements.Off := Off; - end if; - end New_Union_Field; - - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) - is - begin - Finish_Record_Type (Elements, Res); - end Finish_Union_Type; - - function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode - is - Base : O_Tnode; - begin - case Get_Type_Kind (Atype) is - when OT_Ucarray => - Base := Atype; - when OT_Subarray => - Base := Get_Type_Subarray_Base (Atype); - when others => - raise Program_Error; - end case; - return Get_Type_Ucarray_Element (Base); - end Get_Type_Array_Element; - - procedure Debug_Type (Atype : O_Tnode) - is - use Ortho_Code.Debug.Int32_IO; - use Ada.Text_IO; - Kind : OT_Kind; - begin - Put (Int32 (Atype), 3); - Put (" "); - Kind := Get_Type_Kind (Atype); - Put (OT_Kind'Image (Get_Type_Kind (Atype))); - Put (" "); - Put (Mode_Type'Image (Get_Type_Mode (Atype))); - Put (" D="); - Put (Boolean'Image (Get_Type_Deferred (Atype))); - Put (" F1="); - Put (Boolean'Image (Get_Type_Flag1 (Atype))); - New_Line; - case Kind is - when OT_Boolean => - Put (" false: "); - Put (Int32 (Get_Type_Bool_False (Atype))); - Put (", true: "); - Put (Int32 (Get_Type_Bool_True (Atype))); - New_Line; - when OT_Access => - Put (" acc_type: "); - Put (Int32 (Get_Type_Access_Type (Atype))); - New_Line; - when OT_Record => - Put (" fields: "); - Put (Int32 (Get_Type_Record_Fields (Atype))); - Put (", nbr_fields: "); - Put (To_Int32 (Get_Type_Record_Nbr_Fields (Atype))); - New_Line; - when OT_Subarray => - Put (" base type: "); - Put (Int32 (Get_Type_Subarray_Base (Atype))); - Put (", length: "); - Put (To_Int32 (Get_Type_Subarray_Length (Atype))); - New_Line; - when others => - null; - end case; - end Debug_Type; - - procedure Debug_Field (Field : O_Fnode) - is - use Ortho_Code.Debug.Int32_IO; - use Ada.Text_IO; - begin - Put (Int32 (Field), 3); - Put (" "); - Put (" Offset="); - Put (To_Int32 (Get_Field_Offset (Field)), 0); - Put (", Ident="); - Put (Ortho_Ident.Get_String (Get_Field_Ident (Field))); - Put (", Type="); - Put (Int32 (Get_Field_Type (Field)), 0); - Put (", Chain="); - Put (Int32 (Get_Field_Chain (Field)), 0); - New_Line; - end Debug_Field; - - function Get_Type_Limit return O_Tnode is - begin - return Tnodes.Last; - end Get_Type_Limit; - - function Get_Type_Next (Atype : O_Tnode) return O_Tnode is - begin - case Tnodes.Table (Atype).Kind is - when OT_Unsigned - | OT_Signed - | OT_Float => - return Atype + 1; - when OT_Boolean - | OT_Enum - | OT_Ucarray - | OT_Subarray - | OT_Access - | OT_Record - | OT_Union => - return Atype + 2; - when OT_Complete => - return Atype + 1; - end case; - end Get_Type_Next; - - function Get_Base_Type (Atype : O_Tnode) return O_Tnode - is - begin - case Get_Type_Kind (Atype) is - when OT_Subarray => - return Get_Type_Subarray_Base (Atype); - when others => - return Atype; - end case; - end Get_Base_Type; - - procedure Mark (M : out Mark_Type) is - begin - M.Tnode := Tnodes.Last; - M.Fnode := Fnodes.Last; - end Mark; - - procedure Release (M : Mark_Type) is - begin - Tnodes.Set_Last (M.Tnode); - Fnodes.Set_Last (M.Fnode); - end Release; - - procedure Disp_Stats - is - use Ada.Text_IO; - begin - Put_Line ("Number of Tnodes: " & O_Tnode'Image (Tnodes.Last)); - Put_Line ("Number of Fnodes: " & O_Fnode'Image (Fnodes.Last)); - end Disp_Stats; - - procedure Finish is - begin - Tnodes.Free; - Fnodes.Free; - end Finish; -end Ortho_Code.Types; diff --git a/ortho/mcode/ortho_code-types.ads b/ortho/mcode/ortho_code-types.ads deleted file mode 100644 index da6549841..000000000 --- a/ortho/mcode/ortho_code-types.ads +++ /dev/null @@ -1,240 +0,0 @@ --- Mcode back-end for ortho - type handling. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ortho_Code.Types is - type OT_Kind is (OT_Unsigned, OT_Signed, OT_Boolean, OT_Enum, OT_Float, - OT_Ucarray, OT_Subarray, OT_Access, - OT_Record, OT_Union, - - -- Type completion. Mark the completion of a type. - -- Optionnal. - OT_Complete); - - -- Kind of ATYPE. - function Get_Type_Kind (Atype : O_Tnode) return OT_Kind; - - -- Number of bytes of type ATYPE. - function Get_Type_Size (Atype : O_Tnode) return Uns32; - - -- Same as Get_Type_Size but for modes. - -- Returns 0 in case of error. - function Get_Mode_Size (Mode : Mode_Type) return Uns32; - - -- Alignment for ATYPE, in power of 2. - subtype Small_Natural is Natural range 0 .. 3; - type Mode_Align_Array is array (Mode_Type) of Small_Natural; - function Get_Type_Align (Atype : O_Tnode) return Small_Natural; - - -- Alignment for ATYPE in bytes. - function Get_Type_Align_Bytes (Atype : O_Tnode) return Uns32; - - -- Return true is the type was incomplete at creation. - -- (it may - or not - have been completed later). - function Get_Type_Deferred (Atype : O_Tnode) return Boolean; - - -- A back-end reserved flag. - -- Initialized to False. - function Get_Type_Flag1 (Atype : O_Tnode) return Boolean; - procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean); - - -- Align OFF on ATYPE. - function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32; - function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32; - - -- Get the mode for ATYPE. - function Get_Type_Mode (Atype : O_Tnode) return Mode_Type; - - -- Get the type designated by access type ATYPE. - function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode; - - -- Get the index type of array type ATYPE. - function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode; - - -- Get the element type of array type ATYPE. - function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode; - - -- Get the base type of array type ATYPE. - function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode; - - -- Get number of element for array type ATYPE. - function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32; - - -- Get the first field of record/union ATYPE. - function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode; - - -- Get the number of fields of record/union ATYPE. - function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32; - - -- Get the first literal of enum type ATYPE. - function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode; - - -- Get the POS th literal of enum type ATYPE. - -- The first is when POS = 0. - function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode; - - -- Get the number of literals of enum type ATYPE. - function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32; - - -- Get the false/true literal of boolean type ATYPE. - function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode; - function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode; - - -- Return the union/record type which contains FIELD. - function Get_Field_Parent (Field : O_Fnode) return O_Tnode; - - -- Get the offset of FIELD in its record/union. - function Get_Field_Offset (Field : O_Fnode) return Uns32; - procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32); - - -- Get the type of FIELD. - function Get_Field_Type (Field : O_Fnode) return O_Tnode; - - -- Get the name of FIELD. - function Get_Field_Ident (Field : O_Fnode) return O_Ident; - - -- Get the next field. - function Get_Field_Chain (Field : O_Fnode) return O_Fnode; - - -- Get the type that was completed. - function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32) - return O_Tnode; - - -- Return the base type of ATYPE: for a subarray this is the uc array, - -- otherwise this is the type. - function Get_Base_Type (Atype : O_Tnode) return O_Tnode; - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Non-primitives. - - -- Type of an element of a ucarray or constrained array. - function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode; - - -- Get a type number limit (an O_Tnode is a number). - -- There is no type whose number is beyond this limit. - -- Note: the limit may not be a type! - function Get_Type_Limit return O_Tnode; - - -- Get the type which follows ATYPE. - -- User has to check that the result is valid (ie not beyond limit). - function Get_Type_Next (Atype : O_Tnode) return O_Tnode; - - procedure Disp_Stats; - - -- Free all the memory used. - procedure Finish; - - type Mark_Type is limited private; - procedure Mark (M : out Mark_Type); - procedure Release (M : Mark_Type); - - procedure Debug_Type (Atype : O_Tnode); - procedure Debug_Field (Field : O_Fnode); -private - type O_Enum_List is record - Res : O_Tnode; - First : O_Cnode; - Last : O_Cnode; - Nbr : Uns32; - end record; - - type O_Element_List is record - Res : O_Tnode; - Nbr : Uns32; - Off : Uns32; - Align : Small_Natural; - First_Field : O_Fnode; - Last_Field : O_Fnode; - end record; - - type Mark_Type is record - Tnode : O_Tnode; - Fnode : O_Fnode; - end record; - -end Ortho_Code.Types; - diff --git a/ortho/mcode/ortho_code-x86-abi.adb b/ortho/mcode/ortho_code-x86-abi.adb deleted file mode 100644 index bb06d51d4..000000000 --- a/ortho/mcode/ortho_code-x86-abi.adb +++ /dev/null @@ -1,762 +0,0 @@ --- X86 ABI definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Exprs; use Ortho_Code.Exprs; -with Ortho_Code.Consts; -with Ortho_Code.Debug; -with Ortho_Code.Disps; -with Ortho_Code.Flags; -with Ortho_Code.Dwarf; -with Ortho_Code.X86; use Ortho_Code.X86; -with Ortho_Code.X86.Insns; -with Ortho_Code.X86.Emits; -with Ortho_Code.X86.Flags; -with Binary_File; -with Binary_File.Memory; -with Ada.Text_IO; - -package body Ortho_Code.X86.Abi is - procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg) - is - pragma Unreferenced (Subprg); - begin - -- First argument is at %ebp + 8 - Abi.Offset := 8; - end Start_Subprogram; - - procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg) - is - Itype : O_Tnode; - Size : Uns32; - begin - Itype := Get_Decl_Type (Inter); - Size := Get_Type_Size (Itype); - Size := (Size + 3) and not 3; - Set_Local_Offset (Inter, Abi.Offset); - Abi.Offset := Abi.Offset + Int32 (Size); - end New_Interface; - - procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg) - is - use Binary_File; - function To_Int32 is new Ada.Unchecked_Conversion - (Source => Symbol, Target => Int32); - begin - Set_Decl_Info (Subprg, - To_Int32 (Create_Symbol (Get_Decl_Ident (Subprg)))); - -- Offset is 8 biased. - Set_Subprg_Stack (Subprg, Abi.Offset - 8); - end Finish_Subprogram; - - procedure Link_Stmt (Stmt : O_Enode) is - begin - Set_Stmt_Link (Last_Link, Stmt); - Last_Link := Stmt; - end Link_Stmt; - - procedure Disp_Subprg (Subprg : O_Dnode); - - - Exprs_Mark : Exprs.Mark_Type; - Decls_Mark : Decls.Mark_Type; - Consts_Mark : Consts.Mark_Type; - Types_Mark : Types.Mark_Type; - Dwarf_Mark : Dwarf.Mark_Type; - - procedure Start_Body (Subprg : O_Dnode) - is - pragma Unreferenced (Subprg); - begin - if not Debug.Flag_Debug_Keep then - Mark (Exprs_Mark); - Mark (Decls_Mark); - Consts.Mark (Consts_Mark); - Mark (Types_Mark); - end if; - end Start_Body; - - procedure Finish_Body (Subprg : Subprogram_Data_Acc) - is - use Ortho_Code.Flags; - - Child : Subprogram_Data_Acc; - begin - if Debug.Flag_Debug_Hli then - Disps.Disp_Subprg (Subprg); - return; - end if; - - Insns.Gen_Subprg_Insns (Subprg); - - if Ortho_Code.Debug.Flag_Debug_Body2 then - Disp_Subprg_Body (1, Subprg.E_Entry); - end if; - - if Ortho_Code.Debug.Flag_Debug_Code then - Disp_Subprg (Subprg.D_Body); - end if; - - Emits.Emit_Subprg (Subprg); - - if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel - and then Flag_Debug = Debug_Dwarf - then - Dwarf.Emit_Decls_Until (Subprg.D_Body); - if not Debug.Flag_Debug_Keep then - Dwarf.Mark (Dwarf_Mark); - end if; - end if; - - -- Recurse on nested subprograms. - Child := Subprg.First_Child; - while Child /= null loop - Finish_Body (Child); - Child := Child.Brother; - end loop; - - if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel then - if Flag_Debug = Debug_Dwarf then - Dwarf.Emit_Subprg (Subprg.D_Body); - end if; - - if not Debug.Flag_Debug_Keep then - Release (Exprs_Mark); - Release (Decls_Mark); - Consts.Release (Consts_Mark); - Release (Types_Mark); - Dwarf.Release (Dwarf_Mark); - end if; - end if; - end Finish_Body; - - procedure Expand_Const_Decl (Decl : O_Dnode) is - begin - Emits.Emit_Const_Decl (Decl); - end Expand_Const_Decl; - - procedure Expand_Var_Decl (Decl : O_Dnode) is - begin - Emits.Emit_Var_Decl (Decl); - end Expand_Var_Decl; - - procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode) is - begin - Emits.Emit_Const_Value (Decl, Val); - end Expand_Const_Value; - - procedure Disp_Label (Label : O_Enode) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - begin - Put ("L"); - Put (Int32 (Label), 0); - end Disp_Label; - - procedure Disp_Reg (Reg : O_Enode) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - begin - Put ("reg_"); - Put (Int32 (Reg), 0); - Put ("{"); - Put (Image_Reg (Get_Expr_Reg (Reg))); - Put ("}"); - end Disp_Reg; - - procedure Disp_Local (Stmt : O_Enode) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - Obj : constant O_Dnode := Get_Addr_Object (Stmt); - Frame : constant O_Enode := Get_Addrl_Frame (Stmt); - begin - if Frame = O_Enode_Null then - Put ("fp"); - else - Disp_Reg (Frame); - end if; - Put (","); - Put (Get_Local_Offset (Obj), 0); - Put (" {"); - Disp_Decl_Name (Obj); - Put ("}"); - end Disp_Local; - - procedure Disp_Uns32 (Val : Uns32) - is - use Ada.Text_IO; - U2c : constant array (Uns32 range 0 .. 15) of Character - := "0123456789abcdef"; - V : Uns32 := Val; - begin - for I in 0 .. 7 loop - Put (U2c (Shift_Right (V, 28))); - V := Shift_Left (V, 4); - end loop; - end Disp_Uns32; - - procedure Disp_Const (Stmt : O_Enode) - is - use Ada.Text_IO; - begin - Put ("["); - case Get_Expr_Mode (Stmt) is - when Mode_U64 - | Mode_I64 - | Mode_F64 => - Disp_Uns32 (Get_Expr_High (Stmt)); - Put (","); - when others => - null; - end case; - Disp_Uns32 (Get_Expr_Low (Stmt)); - Put ("]"); - end Disp_Const; - - procedure Disp_Irm_Code (Stmt : O_Enode) - is - use Ortho_Code.Debug.Int32_IO; - use Ada.Text_IO; - Reg : O_Reg; - Kind : OE_Kind; - begin - Reg := Get_Expr_Reg (Stmt); - Kind := Get_Expr_Kind (Stmt); - case Reg is - when R_Mem => - case Kind is - when OE_Indir => - Put ('('); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - Put (')'); --- when OE_Lit => --- Put ("(&n)"); - when others => - raise Program_Error; - end case; - when R_Imm => - case Kind is - when OE_Const => - Disp_Const (Stmt); - when OE_Addrg => - Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); - when OE_Add => - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put ("+"); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - when others => - raise Program_Error; - end case; - when Regs_R32 - | R_Any32 - | R_Any8 - | Regs_R64 - | R_Any64 - | Regs_Cc - | Regs_Fp - | Regs_Xmm => - Disp_Reg (Stmt); - when R_Spill => - Disp_Reg (Stmt); - --Disp_Irm_Code (Get_Stmt_Link (Stmt)); - when R_B_Off - | R_I_Off - | R_B_I - | R_Sib => - case Kind is - when OE_Addrl => - Disp_Local (Stmt); - when OE_Add => - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (" + "); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - when others => - raise Program_Error; - end case; - when R_I => - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (" * "); - case Get_Expr_Low (Get_Expr_Right (Stmt)) is - when 0 => - Put ('1'); - when 1 => - Put ('2'); - when 2 => - Put ('4'); - when 3 => - Put ('8'); - when others => - Put ('?'); - end case; - when others => - Ada.Text_IO.Put_Line - ("abi.disp_irm_code: unhandled reg=" & Image_Reg (Reg) - & ", stmt=" & O_Enode'Image (Stmt)); - raise Program_Error; - end case; - end Disp_Irm_Code; - - procedure Disp_Decls (Block : O_Dnode) - is - Decl : O_Dnode; - Last : O_Dnode; - begin - Last := Get_Block_Last (Block); - Disp_Decl (2, Block); - Decl := Block + 1; - while Decl <= Last loop - case Get_Decl_Kind (Decl) is - when OD_Local => - Disp_Decl (2, Decl); - when OD_Block => - -- Skip internal blocks. - Decl := Get_Block_Last (Decl); - when others => - Disp_Decl (2, Decl); - null; - end case; - Decl := Decl + 1; - end loop; - end Disp_Decls; - - procedure Disp_Stmt (Stmt : O_Enode) - is - use Ada.Text_IO; - use Debug.Int32_IO; - Kind : OE_Kind; - Mode : Mode_Type; - - procedure Disp_Op_Name (Name : String) is - begin - Put (Name); - Put (":"); - Debug.Disp_Mode (Mode); - Put (" "); - end Disp_Op_Name; - - procedure Disp_Reg_Op_Name (Name : String) is - begin - Put (" "); - Disp_Reg (Stmt); - Put (" = "); - Disp_Op_Name (Name); - end Disp_Reg_Op_Name; - - begin - Kind := Get_Expr_Kind (Stmt); - Mode := Get_Expr_Mode (Stmt); - - case Kind is - when OE_Beg => - Put (" # block start"); - if Get_Block_Has_Alloca (Stmt) then - Put (" [alloca]"); - end if; - New_Line; - Disp_Decls (Get_Block_Decls (Stmt)); - when OE_End => - Put_Line (" # block end"); - when OE_Indir => - Disp_Reg_Op_Name ("indir"); - Put ("("); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - Put_Line (")"); - when OE_Alloca => - Disp_Reg_Op_Name ("alloca"); - Put ("("); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - Put_Line (")"); - when OE_Kind_Cmp - | OE_Kind_Dyadic => - Disp_Reg_Op_Name ("op"); - Put ("{"); - Put (OE_Kind'Image (Kind)); - Put ("} "); - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (", "); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - New_Line; - when OE_Abs_Ov - | OE_Neg_Ov - | OE_Not => - Disp_Reg_Op_Name ("op"); - Put ("{"); - Put (OE_Kind'Image (Kind)); - Put ("} "); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Const => - Disp_Reg_Op_Name ("const"); - Disp_Const (Stmt); - New_Line; - when OE_Jump_F => - Put (" jump_f "); - Disp_Reg (Get_Expr_Operand (Stmt)); - Put (" "); - Disp_Label (Get_Jump_Label (Stmt)); - New_Line; - when OE_Jump_T => - Put (" jump_t "); - Disp_Reg (Get_Expr_Operand (Stmt)); - Put (" "); - Disp_Label (Get_Jump_Label (Stmt)); - New_Line; - when OE_Jump => - Put (" jump "); - Disp_Label (Get_Jump_Label (Stmt)); - New_Line; - when OE_Label => - Disp_Label (Stmt); - Put_Line (":"); - when OE_Asgn => - Put (" assign:"); - Debug.Disp_Mode (Mode); - Put (" ("); - Disp_Irm_Code (Get_Assign_Target (Stmt)); - Put (") <- "); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Set_Stack => - Put (" set_stack"); - Put (" <- "); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Spill => - Disp_Reg_Op_Name ("spill"); - Disp_Reg (Get_Expr_Operand (Stmt)); - Put (", offset="); - Put (Int32'Image (Get_Spill_Info (Stmt))); - New_Line; - when OE_Reload => - Disp_Reg_Op_Name ("reload"); - Disp_Reg (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Arg => - Put (" push "); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Call => - if Get_Expr_Mode (Stmt) /= Mode_Nil then - Disp_Reg_Op_Name ("call"); - else - Put (" "); - Disp_Op_Name ("call"); - Put (" "); - end if; - Disp_Decl_Name (Get_Call_Subprg (Stmt)); - New_Line; - when OE_Stack_Adjust => - Put (" stack_adjust: "); - Put (Int32'Image (Get_Stack_Adjust (Stmt))); - New_Line; - when OE_Intrinsic => - Disp_Reg_Op_Name ("intrinsic"); - --Disp_Decl_Name (Get_Call_Subprg (Stmt)); - New_Line; - when OE_Conv => - Disp_Reg_Op_Name ("conv"); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Move => - Disp_Reg_Op_Name ("move"); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Ret => - Put (" ret"); - if Get_Expr_Mode (Stmt) /= Mode_Nil then - Put (" "); - Disp_Reg (Get_Expr_Operand (Stmt)); - end if; - New_Line; - when OE_Case => - Disp_Reg_Op_Name ("case"); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Case_Expr => - Disp_Reg_Op_Name ("case_expr"); - Disp_Irm_Code (Get_Expr_Operand (Stmt)); - New_Line; - when OE_Leave => - Put_Line ("leave"); - when OE_Entry => - Put_Line ("entry"); - when OE_Line => - Put (" # line #"); - Put (Get_Expr_Line_Number (Stmt), 0); - New_Line; - when OE_Addrl => - Disp_Reg_Op_Name ("lea{addrl}"); - Put ("("); - Disp_Local (Stmt); - Put (")"); - New_Line; - when OE_Addrg => - Disp_Reg_Op_Name ("lea{addrg}"); - Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); - New_Line; - when OE_Add => - Disp_Reg_Op_Name ("lea{add}"); - Put ("("); - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (" + "); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - Put (")"); - New_Line; - when OE_Mul => - Disp_Reg_Op_Name ("mul"); - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (", "); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - New_Line; - when OE_Shl => - Disp_Reg_Op_Name ("shl"); - Disp_Irm_Code (Get_Expr_Left (Stmt)); - Put (", "); - Disp_Irm_Code (Get_Expr_Right (Stmt)); - New_Line; - when OE_Reg => - Disp_Reg_Op_Name ("reg"); - New_Line; - when others => - Ada.Text_IO.Put_Line - ("abi.disp_stmt: unhandled enode " & OE_Kind'Image (Kind)); - raise Program_Error; - end case; - end Disp_Stmt; - - procedure Disp_Subprg_Decl (Decl : O_Dnode) - is - use Ada.Text_IO; - Arg : O_Dnode; - begin - Put ("subprogram "); - Disp_Decl_Name (Decl); - Put_Line (":"); - Arg := Decl + 1; - while Get_Decl_Kind (Arg) = OD_Interface loop - Disp_Decl (2, Arg); - Arg := Arg + 1; - end loop; - end Disp_Subprg_Decl; - - procedure Disp_Subprg (Subprg : O_Dnode) - is - use Ada.Text_IO; - - Stmt : O_Enode; - begin - Disp_Subprg_Decl (Get_Body_Decl (Subprg)); - - Stmt := Get_Body_Stmt (Subprg); - loop - exit when Stmt = O_Enode_Null; - Disp_Stmt (Stmt); - exit when Get_Expr_Kind (Stmt) = OE_Leave; - Stmt := Get_Stmt_Link (Stmt); - end loop; - end Disp_Subprg; - - procedure New_Debug_Filename_Decl (Filename : String) - is - use Ortho_Code.Flags; - begin - if Flag_Debug = Debug_Dwarf then - Dwarf.Set_Filename ("", Filename); - end if; - end New_Debug_Filename_Decl; - - procedure Init - is - use Ortho_Code.Debug; - begin - -- Alignment of doubles is platform dependent. - Mode_Align (Mode_F64) := X86.Flags.Mode_F64_Align; - - if Flag_Debug_Hli then - Disps.Init; - else - Emits.Init; - end if; - end Init; - - procedure Finish - is - use Ortho_Code.Debug; - begin - if Flag_Debug_Hli then - Disps.Finish; - else - Emits.Finish; - end if; - end Finish; - --- function Image_Insn (Insn : O_Insn) return String is --- begin --- case Insn is --- when Insn_Nil => --- return "nil"; --- when Insn_Imm => --- return "imm"; --- when Insn_Base_Off => --- return "B+O"; --- when Insn_Loadm => --- return "ldm"; --- when Insn_Loadi => --- return "ldi"; --- when Insn_Mem => --- return "mem"; --- when Insn_Cmp => --- return "cmp"; --- when Insn_Op => --- return "op "; --- when Insn_Rop => --- return "rop"; --- when Insn_Call => --- return "cal"; --- when others => --- return "???"; --- end case; --- end Image_Insn; - - function Image_Reg (Reg : O_Reg) return String is - begin - case Reg is - when R_Nil => - return "nil "; - when R_None => - return " -- "; - when R_Spill => - return "spil"; - when R_Mem => - return "mem "; - when R_Imm => - return "imm "; - when R_Irm => - return "irm "; - when R_Rm => - return "rm "; - when R_Sib => - return "sib "; - when R_B_Off => - return "b+o "; - when R_B_I => - return "b+i "; - when R_I => - return "s*i "; - when R_Ir => - return " ir "; - when R_I_Off => - return "i+o "; - when R_Any32 => - return "r32 "; - when R_Any_Cc => - return "cc "; - when R_Any8 => - return "r8 "; - when R_Any64 => - return "r64 "; - - when R_St0 => - return "st0 "; - when R_Ax => - return "ax "; - when R_Dx => - return "dx "; - when R_Cx => - return "cx "; - when R_Bx => - return "bx "; - when R_Si => - return "si "; - when R_Di => - return "di "; - when R_Sp => - return "sp "; - when R_Bp => - return "bp "; - when R_Edx_Eax => - return "dxax"; - when R_Ebx_Ecx => - return "bxcx"; - when R_Esi_Edi => - return "sidi"; - when R_Eq => - return "eq? "; - when R_Ne => - return "ne? "; - when R_Uge => - return "uge?"; - when R_Sge => - return "sge?"; - when R_Ugt => - return "ugt?"; - when R_Sgt => - return "sgt?"; - when R_Ule => - return "ule?"; - when R_Sle => - return "sle?"; - when R_Ult => - return "ult?"; - when R_Slt => - return "slt?"; - when R_Xmm0 => - return "xmm0"; - when R_Xmm1 => - return "xmm1"; - when R_Xmm2 => - return "xmm2"; - when R_Xmm3 => - return "xmm3"; - when others => - return "????"; - end case; - end Image_Reg; - - -- From GCC. - -- FIXME: these don't handle overflow! - function Divdi3 (A, B : Long_Integer) return Long_Integer; - pragma Import (C, Divdi3, "__divdi3"); - - function Muldi3 (A, B : Long_Integer) return Long_Integer; - pragma Import (C, Muldi3, "__muldi3"); - - procedure Chkstk (Sz : Integer); - pragma Import (C, Chkstk, "__chkstk"); - - procedure Link_Intrinsics - is - begin - Binary_File.Memory.Set_Symbol_Address - (Ortho_Code.X86.Emits.Intrinsics_Symbol - (Ortho_Code.X86.Intrinsic_Mul_Ov_I64), - Muldi3'Address); - Binary_File.Memory.Set_Symbol_Address - (Ortho_Code.X86.Emits.Intrinsics_Symbol - (Ortho_Code.X86.Intrinsic_Div_Ov_I64), - Divdi3'Address); - if X86.Flags.Flag_Alloca_Call then - Binary_File.Memory.Set_Symbol_Address - (Ortho_Code.X86.Emits.Chkstk_Symbol, Chkstk'Address); - end if; - end Link_Intrinsics; -end Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-x86-abi.ads b/ortho/mcode/ortho_code-x86-abi.ads deleted file mode 100644 index 7b166dad8..000000000 --- a/ortho/mcode/ortho_code-x86-abi.ads +++ /dev/null @@ -1,76 +0,0 @@ --- X86 ABI definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Types; use Ortho_Code.Types; - -package Ortho_Code.X86.Abi is - type O_Abi_Subprg is private; - - procedure Init; - procedure Finish; - - Mode_Align : Mode_Align_Array := - (Mode_U8 | Mode_I8 => 0, - Mode_U16 | Mode_I16 => 1, - Mode_U32 | Mode_I32 | Mode_F32 | Mode_P32 => 2, - Mode_U64 | Mode_I64 => 2, - Mode_F64 => 2, -- 2 for SVR4-ABI and Darwin, 3 for Windows. - Mode_Blk | Mode_X1 | Mode_Nil | Mode_P64 => 0, - Mode_B2 => 0); - - Mode_Ptr : constant Mode_Type := Mode_P32; - - Flag_Type_Completer : constant Boolean := False; - Flag_Lower_Stmt : constant Boolean := True; - - Flag_Sse2 : Boolean := False; - - -- Procedures to layout a subprogram declaration. - procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg); - procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg); - procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg); - - -- Only called for top-level subprograms. - procedure Start_Body (Subprg : O_Dnode); - -- Finish compilation of a body. - procedure Finish_Body (Subprg : Subprogram_Data_Acc); - - procedure Expand_Const_Decl (Decl : O_Dnode); - procedure Expand_Var_Decl (Decl : O_Dnode); - procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode); - - procedure New_Debug_Filename_Decl (Filename : String); - - Last_Link : O_Enode; - procedure Link_Stmt (Stmt : O_Enode); - - -- Disp SUBPRG (subprg declaration) as a declaration (name and interfaces). - procedure Disp_Subprg_Decl (Decl : O_Dnode); - - procedure Disp_Stmt (Stmt : O_Enode); - - --function Image_Insn (Insn : O_Insn) return String; - function Image_Reg (Reg : O_Reg) return String; - - -- Link in memory intrinsics symbols. - procedure Link_Intrinsics; -private - type O_Abi_Subprg is record - -- For x86: offset of the next argument. - Offset : Int32 := 0; - end record; -end Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-x86-emits.adb b/ortho/mcode/ortho_code-x86-emits.adb deleted file mode 100644 index ad1ef559b..000000000 --- a/ortho/mcode/ortho_code-x86-emits.adb +++ /dev/null @@ -1,2322 +0,0 @@ --- Mcode back-end for ortho - Binary X86 instructions generator. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Abi; -with Ortho_Code.Decls; -with Ortho_Code.Types; -with Ortho_Code.Consts; -with Ortho_Code.Debug; -with Ortho_Code.X86.Insns; -with Ortho_Code.X86.Flags; -with Ortho_Code.Flags; -with Ortho_Code.Dwarf; -with Ortho_Code.Binary; use Ortho_Code.Binary; -with Ortho_Ident; -with Ada.Text_IO; -with Interfaces; use Interfaces; - -package body Ortho_Code.X86.Emits is - type Insn_Size is (Sz_8, Sz_16, Sz_32l, Sz_32h); - - type Fp_Size is (Fp_32, Fp_64); - - Sect_Text : Binary_File.Section_Acc; - Sect_Rodata : Binary_File.Section_Acc; - Sect_Bss : Binary_File.Section_Acc; - - Reg_Helper : O_Reg; - - Subprg_Pc : Pc_Type; - - procedure Error_Emit (Msg : String; Insn : O_Enode) - is - use Ada.Text_IO; - begin - Put ("error_emit: "); - Put (Msg); - Put (", insn="); - Put (O_Enode'Image (Insn)); - Put (" ("); - Put (OE_Kind'Image (Get_Expr_Kind (Insn))); - Put (")"); - New_Line; - raise Program_Error; - end Error_Emit; - - - procedure Gen_Insn_Sz (B : Byte; Sz : Insn_Size) is - begin - case Sz is - when Sz_8 => - Gen_B8 (B); - when Sz_16 => - Gen_B8 (16#66#); - Gen_B8 (B + 1); - when Sz_32l - | Sz_32h => - Gen_B8 (B + 1); - end case; - end Gen_Insn_Sz; - - procedure Gen_Insn_Sz_S8 (B : Byte; Sz : Insn_Size) is - begin - case Sz is - when Sz_8 => - Gen_B8 (B); - when Sz_16 => - Gen_B8 (16#66#); - Gen_B8 (B + 3); - when Sz_32l - | Sz_32h => - Gen_B8 (B + 3); - end case; - end Gen_Insn_Sz_S8; - - function Get_Const_Val (C : O_Enode; Sz : Insn_Size) return Uns32 is - begin - case Sz is - when Sz_8 - | Sz_16 - | Sz_32l => - return Get_Expr_Low (C); - when Sz_32h => - return Get_Expr_High (C); - end case; - end Get_Const_Val; - - function Is_Imm8 (N : O_Enode; Sz : Insn_Size) return Boolean is - begin - if Get_Expr_Kind (N) /= OE_Const then - return False; - end if; - return Get_Const_Val (N, Sz) <= 127; - end Is_Imm8; - - procedure Gen_Imm8 (N : O_Enode; Sz : Insn_Size) is - begin - Gen_B8 (Byte (Get_Const_Val (N, Sz))); - end Gen_Imm8; - --- procedure Gen_Imm32 (N : O_Enode; Sz : Insn_Size) --- is --- use Interfaces; --- begin --- case Get_Expr_Kind (N) is --- when OE_Const => --- Gen_Le32 (Unsigned_32 (Get_Const_Val (N, Sz))); --- when OE_Addrg => --- Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0); --- when others => --- raise Program_Error; --- end case; --- end Gen_Imm32; - - procedure Gen_Imm (N : O_Enode; Sz : Insn_Size) is - begin - case Get_Expr_Kind (N) is - when OE_Const => - case Sz is - when Sz_8 => - Gen_B8 (Byte (Get_Expr_Low (N) and 16#FF#)); - when Sz_16 => - Gen_Le16 (Unsigned_32 (Get_Expr_Low (N) and 16#FF_FF#)); - when Sz_32l => - Gen_Le32 (Unsigned_32 (Get_Expr_Low (N))); - when Sz_32h => - Gen_Le32 (Unsigned_32 (Get_Expr_High (N))); - end case; - when OE_Addrg => - if Sz /= Sz_32l then - raise Program_Error; - end if; - Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0); - when OE_Add => - declare - P : O_Enode; - L, R : O_Enode; - S, C : O_Enode; - Off : Int32; - begin - Off := 0; - P := N; - if Sz /= Sz_32l then - raise Program_Error; - end if; - loop - L := Get_Expr_Left (P); - R := Get_Expr_Right (P); - - -- Extract the const node. - if Get_Expr_Kind (R) = OE_Const then - S := L; - C := R; - elsif Get_Expr_Kind (L) = OE_Const then - S := R; - C := L; - else - raise Program_Error; - end if; - if Get_Expr_Mode (C) /= Mode_U32 then - raise Program_Error; - end if; - Off := Off + To_Int32 (Get_Expr_Low (C)); - - exit when Get_Expr_Kind (S) = OE_Addrg; - P := S; - if Get_Expr_Kind (P) /= OE_Add then - raise Program_Error; - end if; - end loop; - Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (S)), - Integer_32 (Off)); - end; - when others => - raise Program_Error; - end case; - end Gen_Imm; - - Rm_Base : O_Reg; - Rm_Index : O_Reg; - Rm_Offset : Int32; - Rm_Sym : Symbol; - Rm_Scale : Byte; - - procedure Fill_Sib (N : O_Enode) - is - use Ortho_Code.Decls; - Reg : O_Reg; - begin - Reg := Get_Expr_Reg (N); - if Reg in Regs_R32 then - if Rm_Base = R_Nil then - Rm_Base := Reg; - elsif Rm_Index = R_Nil then - Rm_Index := Reg; - else - raise Program_Error; - end if; - return; - end if; - case Get_Expr_Kind (N) is - when OE_Indir => - Fill_Sib (Get_Expr_Operand (N)); - when OE_Addrl => - declare - Frame : O_Enode; - begin - Frame := Get_Addrl_Frame (N); - if Frame = O_Enode_Null then - Rm_Base := R_Bp; - else - Rm_Base := Get_Expr_Reg (Frame); - end if; - end; - Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N)); - when OE_Addrg => - if Rm_Sym /= Null_Symbol then - raise Program_Error; - end if; - Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N)); - when OE_Add => - Fill_Sib (Get_Expr_Left (N)); - Fill_Sib (Get_Expr_Right (N)); - when OE_Const => - Rm_Offset := Rm_Offset + To_Int32 (Get_Expr_Low (N)); - when OE_Shl => - if Rm_Index /= R_Nil then - raise Program_Error; - end if; - Rm_Index := Get_Expr_Reg (Get_Expr_Left (N)); - Rm_Scale := Byte (Get_Expr_Low (Get_Expr_Right (N))); - when others => - Error_Emit ("fill_sib", N); - end case; - end Fill_Sib; - - function To_Reg32 (R : O_Reg) return Byte is - begin - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - end To_Reg32; - pragma Inline (To_Reg32); - - function To_Reg_Xmm (R : O_Reg) return Byte is - begin - return O_Reg'Pos (R) - O_Reg'Pos (R_Xmm0); - end To_Reg_Xmm; - pragma Inline (To_Reg_Xmm); - - function To_Reg32 (R : O_Reg; Sz : Insn_Size) return Byte is - begin - case Sz is - when Sz_8 => - if R in Regs_R8 then - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - else - raise Program_Error; - end if; - when Sz_16 => - if R in Regs_R32 then - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - else - raise Program_Error; - end if; - when Sz_32l => - case R is - when Regs_R32 => - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - when R_Edx_Eax => - return 2#000#; - when R_Ebx_Ecx => - return 2#001#; - when R_Esi_Edi => - return 2#111#; - when others => - raise Program_Error; - end case; - when Sz_32h => - case R is - when R_Edx_Eax => - return 2#010#; - when R_Ebx_Ecx => - return 2#011#; - when R_Esi_Edi => - return 2#110#; - when others => - raise Program_Error; - end case; - end case; - end To_Reg32; - - function To_Cond (R : O_Reg) return Byte is - begin - return O_Reg'Pos (R) - O_Reg'Pos (R_Ov); - end To_Cond; - pragma Inline (To_Cond); - - procedure Gen_Sib is - begin - if Rm_Base = R_Nil then - Gen_B8 (Rm_Scale * 2#1_000_000# - + To_Reg32 (Rm_Index) * 2#1_000# - + 2#101#); - else - Gen_B8 (Rm_Scale * 2#1_000_000# - + To_Reg32 (Rm_Index) * 2#1_000# - + To_Reg32 (Rm_Base)); - end if; - end Gen_Sib; - - -- Generate an R/M (+ SIB) byte. - -- R is added to the R/M byte. - procedure Gen_Rm_Mem (R : Byte; N : O_Enode; Sz : Insn_Size) - is - Reg : O_Reg; - begin - Reg := Get_Expr_Reg (N); - Rm_Base := R_Nil; - Rm_Index := R_Nil; - if Sz = Sz_32h then - Rm_Offset := 4; - else - Rm_Offset := 0; - end if; - Rm_Scale := 0; - Rm_Sym := Null_Symbol; - case Reg is - when R_Mem - | R_Imm - | R_Eq - | R_B_Off - | R_B_I - | R_I_Off - | R_Sib => - Fill_Sib (N); - when Regs_R32 => - Rm_Base := Reg; - when R_Spill => - Rm_Base := R_Bp; - Rm_Offset := Rm_Offset + Get_Spill_Info (N); - when others => - Error_Emit ("gen_rm_mem: unhandled reg", N); - end case; - if Rm_Index /= R_Nil then - -- SIB. - if Rm_Base = R_Nil then - Gen_B8 (2#00_000_100# + R); - Rm_Base := R_Bp; - Gen_Sib; - Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); - elsif Rm_Sym = Null_Symbol and Rm_Offset = 0 and Rm_Base /= R_Bp then - Gen_B8 (2#00_000_100# + R); - Gen_Sib; - elsif Rm_Sym = Null_Symbol and Rm_Offset <= 127 and Rm_Offset >= -128 - then - Gen_B8 (2#01_000_100# + R); - Gen_Sib; - Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); - else - Gen_B8 (2#10_000_100# + R); - Gen_Sib; - Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); - end if; - return; - end if; - case Rm_Base is - when R_Sp => - raise Program_Error; - when R_Nil => - Gen_B8 (2#00_000_101# + R); - Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); - when R_Ax - | R_Bx - | R_Cx - | R_Dx - | R_Bp - | R_Si - | R_Di => - if Rm_Offset = 0 and Rm_Sym = Null_Symbol and Rm_Base /= R_Bp then - Gen_B8 (2#00_000_000# + R + To_Reg32 (Rm_Base)); - elsif Rm_Sym = Null_Symbol - and Rm_Offset <= 127 and Rm_Offset >= -128 - then - Gen_B8 (2#01_000_000# + R + To_Reg32 (Rm_Base)); - Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); - else - Gen_B8 (2#10_000_000# + R + To_Reg32 (Rm_Base)); - Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); - end if; - when others => - raise Program_Error; - end case; - end Gen_Rm_Mem; - - procedure Gen_Rm (R : Byte; N : O_Enode; Sz : Insn_Size) - is - Reg : O_Reg; - begin - Reg := Get_Expr_Reg (N); - if Reg in Regs_R32 or Reg in Regs_R64 then - Gen_B8 (2#11_000_000# + R + To_Reg32 (Reg, Sz)); - return; - else - Gen_Rm_Mem (R, N, Sz); - end if; - end Gen_Rm; - - procedure Emit_Op (Op : Byte; Stmt : O_Enode; Sz : Insn_Size) - is - L, R : O_Enode; - Lr, Rr : O_Reg; - begin - L := Get_Expr_Left (Stmt); - R := Get_Expr_Right (Stmt); - Lr := Get_Expr_Reg (L); - Rr := Get_Expr_Reg (R); - Start_Insn; - case Rr is - when R_Imm => - if Is_Imm8 (R, Sz) then - Gen_Insn_Sz_S8 (16#80#, Sz); - Gen_Rm (Op, L, Sz); - Gen_Imm8 (R, Sz); - elsif Lr = R_Ax then - Gen_Insn_Sz (2#000_000_100# + Op, Sz); - Gen_Imm (R, Sz); - else - Gen_Insn_Sz (16#80#, Sz); - Gen_Rm (Op, L, Sz); - Gen_Imm (R, Sz); - end if; - when R_Mem - | R_Spill - | Regs_R32 - | Regs_R64 => - Gen_Insn_Sz (2#00_000_010# + Op, Sz); - Gen_Rm (To_Reg32 (Lr, Sz) * 8, R, Sz); - when others => - Error_Emit ("emit_op", Stmt); - end case; - End_Insn; - end Emit_Op; - - procedure Gen_Into is - begin - Start_Insn; - Gen_B8 (2#1100_1110#); - End_Insn; - end Gen_Into; - - procedure Gen_Cdq is - begin - Start_Insn; - Gen_B8 (2#1001_1001#); - End_Insn; - end Gen_Cdq; - - procedure Gen_Mono_Op (Op : Byte; Val : O_Enode; Sz : Insn_Size) is - begin - Start_Insn; - Gen_Insn_Sz (2#1111_011_0#, Sz); - Gen_Rm (Op, Val, Sz); - End_Insn; - end Gen_Mono_Op; - - procedure Emit_Mono_Op_Stmt (Op : Byte; Stmt : O_Enode; Sz : Insn_Size) - is - begin - Gen_Mono_Op (Op, Get_Expr_Operand (Stmt), Sz); - end Emit_Mono_Op_Stmt; - - procedure Emit_Load_Imm (Stmt : O_Enode; Sz : Insn_Size) - is - Tr : O_Reg; - begin - Tr := Get_Expr_Reg (Stmt); - Start_Insn; - -- FIXME: handle 0. - case Sz is - when Sz_8 => - Gen_B8 (2#1011_0_000# + To_Reg32 (Tr, Sz)); - when Sz_16 => - Gen_B8 (16#66#); - Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz)); - when Sz_32l - | Sz_32h => - Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz)); - end case; - Gen_Imm (Stmt, Sz); - End_Insn; - end Emit_Load_Imm; - - function Fp_Size_To_Mf (Sz : Fp_Size) return Byte is - begin - case Sz is - when Fp_32 => - return 2#00_0#; - when Fp_64 => - return 2#10_0#; - end case; - end Fp_Size_To_Mf; - - procedure Emit_Load_Fp (Stmt : O_Enode; Sz : Fp_Size) - is - Sym : Symbol; - R : O_Reg; - begin - Set_Current_Section (Sect_Rodata); - Gen_Pow_Align (3); - Prealloc (8); - Sym := Create_Local_Symbol; - Set_Symbol_Pc (Sym, False); - Gen_Le32 (Unsigned_32 (Get_Expr_Low (Stmt))); - if Sz = Fp_64 then - Gen_Le32 (Unsigned_32 (Get_Expr_High (Stmt))); - end if; - Set_Current_Section (Sect_Text); - - R := Get_Expr_Reg (Stmt); - case R is - when R_St0 => - Start_Insn; - Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); - Gen_B8 (2#00_000_101#); - Gen_X86_32 (Sym, 0); - End_Insn; - when Regs_Xmm => - Start_Insn; - case Sz is - when Fp_32 => - Gen_B8 (16#F3#); - when Fp_64 => - Gen_B8 (16#F2#); - end case; - Gen_B8 (16#0f#); - Gen_B8 (16#10#); - Gen_B8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#); - Gen_X86_32 (Sym, 0); - End_Insn; - when others => - raise Program_Error; - end case; - end Emit_Load_Fp; - - procedure Emit_Load_Fp_Mem (Stmt : O_Enode; Sz : Fp_Size) - is - begin - Start_Insn; - Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); - Gen_Rm_Mem (2#000_000#, Get_Expr_Operand (Stmt), Sz_32l); - End_Insn; - end Emit_Load_Fp_Mem; - - procedure Emit_Load_Mem (Stmt : O_Enode; Sz : Insn_Size) - is - Tr : O_Reg; - Val : O_Enode; - begin - Tr := Get_Expr_Reg (Stmt); - Val := Get_Expr_Operand (Stmt); - case Tr is - when Regs_R32 - | Regs_R64 => - -- mov REG, OP - Start_Insn; - Gen_Insn_Sz (2#1000_101_0#, Sz); - Gen_Rm_Mem (To_Reg32 (Tr, Sz) * 8, Val, Sz); - End_Insn; - when R_Eq => - -- Cmp OP, 1 - Start_Insn; - Gen_Insn_Sz_S8 (2#1000_000_0#, Sz); - Gen_Rm_Mem (2#111_000#, Val, Sz); - Gen_B8 (1); - End_Insn; - when others => - Error_Emit ("emit_load_mem", Stmt); - end case; - end Emit_Load_Mem; - - - procedure Emit_Store (Stmt : O_Enode; Sz : Insn_Size) - is - T, R : O_Enode; - Tr, Rr : O_Reg; - B : Byte; - begin - T := Get_Assign_Target (Stmt); - R := Get_Expr_Operand (Stmt); - Tr := Get_Expr_Reg (T); - Rr := Get_Expr_Reg (R); - Start_Insn; - case Rr is - when R_Imm => - if False and (Tr in Regs_R32 or Tr in Regs_R64) then - B := 2#1011_1_000#; - case Sz is - when Sz_8 => - B := B and not 2#0000_1_000#; - when Sz_16 => - Gen_B8 (16#66#); - when Sz_32l - | Sz_32h => - null; - end case; - Gen_B8 (B + To_Reg32 (Tr, Sz)); - else - Gen_Insn_Sz (2#1100_011_0#, Sz); - Gen_Rm_Mem (16#00#, T, Sz); - end if; - Gen_Imm (R, Sz); - when Regs_R32 - | Regs_R64 => - Gen_Insn_Sz (2#1000_100_0#, Sz); - Gen_Rm_Mem (To_Reg32 (Rr, Sz) * 8, T, Sz); - when others => - Error_Emit ("emit_store", Stmt); - end case; - End_Insn; - end Emit_Store; - - procedure Emit_Store_Fp (Stmt : O_Enode; Sz : Fp_Size) - is - begin - -- fstp - Start_Insn; - Gen_B8 (2#11011_00_1# + Fp_Size_To_Mf (Sz)); - Gen_Rm_Mem (2#011_000#, Get_Assign_Target (Stmt), Sz_32l); - End_Insn; - end Emit_Store_Fp; - - procedure Emit_Push_32 (Val : O_Enode; Sz : Insn_Size) - is - R : O_Reg; - begin - R := Get_Expr_Reg (Val); - Start_Insn; - case R is - when R_Imm => - if Is_Imm8 (Val, Sz) then - Gen_B8 (2#0110_1010#); - Gen_Imm8 (Val, Sz); - else - Gen_B8 (2#0110_1000#); - Gen_Imm (Val, Sz); - end if; - when Regs_R32 - | Regs_R64 => - Gen_B8 (2#01010_000# + To_Reg32 (R, Sz)); - when others => - Gen_B8 (2#1111_1111#); - Gen_Rm (2#110_000#, Val, Sz); - end case; - End_Insn; - end Emit_Push_32; - - procedure Emit_Pop_32 (Val : O_Enode; Sz : Insn_Size) - is - R : O_Reg; - begin - R := Get_Expr_Reg (Val); - Start_Insn; - case R is - when Regs_R32 - | Regs_R64 => - Gen_B8 (2#01011_000# + To_Reg32 (R, Sz)); - when others => - Gen_B8 (2#1000_1111#); - Gen_Rm (2#000_000#, Val, Sz); - end case; - End_Insn; - end Emit_Pop_32; - - procedure Emit_Push_Fp (Op : O_Enode; Sz : Fp_Size) - is - pragma Unreferenced (Op); - begin - Start_Insn; - -- subl esp, val - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_101_100#); - case Sz is - when Fp_32 => - Gen_B8 (4); - when Fp_64 => - Gen_B8 (8); - end case; - End_Insn; - -- fstp st, (esp) - Start_Insn; - Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); - Gen_B8 (2#00_011_100#); - Gen_B8 (2#00_100_100#); - End_Insn; - end Emit_Push_Fp; - - function Prepare_Label (Label : O_Enode) return Symbol - is - Sym : Symbol; - begin - Sym := Get_Label_Symbol (Label); - if Sym = Null_Symbol then - Sym := Create_Local_Symbol; - Set_Label_Symbol (Label, Sym); - end if; - return Sym; - end Prepare_Label; - - procedure Emit_Jmp_T (Stmt : O_Enode; Reg : O_Reg) - is - Sym : Symbol; - Val : Pc_Type; - Opc : Byte; - begin - Sym := Prepare_Label (Get_Jump_Label (Stmt)); - Val := Get_Symbol_Value (Sym); - Start_Insn; - Opc := To_Cond (Reg); - if Val = 0 then - -- Assume long jmp. - Gen_B8 (16#0f#); - Gen_B8 (16#80# + Opc); - Gen_X86_Pc32 (Sym); - else - if Val + 128 < Get_Current_Pc + 4 then - -- Long jmp. - Gen_B8 (16#0f#); - Gen_B8 (16#80# + Opc); - Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); - else - -- short jmp. - Gen_B8 (16#70# + Opc); - Gen_B8 (Byte (Val - (Get_Current_Pc + 1))); - end if; - end if; - End_Insn; - end Emit_Jmp_T; - - procedure Emit_Jmp (Stmt : O_Enode) - is - Sym : Symbol; - Val : Pc_Type; - begin - Sym := Prepare_Label (Get_Jump_Label (Stmt)); - Val := Get_Symbol_Value (Sym); - Start_Insn; - if Val = 0 then - -- Assume long jmp. - Gen_B8 (16#e9#); - Gen_X86_Pc32 (Sym); - else - if Val + 128 < Get_Current_Pc + 4 then - -- Long jmp. - Gen_B8 (16#e9#); - Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); - else - -- short jmp. - Gen_B8 (16#eb#); - Gen_B8 (Byte ((Val - (Get_Current_Pc + 1)) and 16#Ff#)); - end if; - end if; - End_Insn; - end Emit_Jmp; - - procedure Emit_Label (Stmt : O_Enode) - is - Sym : Symbol; - begin - Sym := Prepare_Label (Stmt); - Set_Symbol_Pc (Sym, False); - end Emit_Label; - - procedure Gen_Call (Sym : Symbol) is - begin - Start_Insn; - Gen_B8 (16#E8#); - Gen_X86_Pc32 (Sym); - End_Insn; - end Gen_Call; - - procedure Emit_Setup_Frame (Stmt : O_Enode) - is - Val : constant Int32 := Get_Stack_Adjust (Stmt); - begin - if Val > 0 then - Start_Insn; - -- subl esp, val - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_101_100#); - Gen_B8 (Byte (Val)); - End_Insn; - elsif Val < 0 then - Start_Insn; - if -Val <= 127 then - -- addl esp, val - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_000_100#); - Gen_B8 (Byte (-Val)); - else - -- addl esp, val - Gen_B8 (2#100000_01#); - Gen_B8 (2#11_000_100#); - Gen_Le32 (Unsigned_32 (-Val)); - end if; - End_Insn; - end if; - end Emit_Setup_Frame; - - procedure Emit_Call (Stmt : O_Enode) - is - use Ortho_Code.Decls; - Subprg : O_Dnode; - Sym : Symbol; - begin - Subprg := Get_Call_Subprg (Stmt); - Sym := Get_Decl_Symbol (Subprg); - Gen_Call (Sym); - end Emit_Call; - - procedure Emit_Intrinsic (Stmt : O_Enode) - is - Op : Int32; - begin - Op := Get_Intrinsic_Operation (Stmt); - Start_Insn; - Gen_B8 (16#E8#); - Gen_X86_Pc32 (Intrinsics_Symbol (Op)); - End_Insn; - - Start_Insn; - -- addl esp, val - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_000_100#); - Gen_B8 (16); - End_Insn; - end Emit_Intrinsic; - - procedure Emit_Setcc (Dest : O_Enode; Cond : O_Reg) - is - begin - if Cond not in Regs_Cc then - raise Program_Error; - end if; - Start_Insn; - Gen_B8 (16#0f#); - Gen_B8 (16#90# + To_Cond (Cond)); - Gen_Rm (2#000_000#, Dest, Sz_8); - End_Insn; - end Emit_Setcc; - - procedure Emit_Setcc_Reg (Reg : O_Reg; Cond : O_Reg) - is - begin - if Cond not in Regs_Cc then - raise Program_Error; - end if; - Start_Insn; - Gen_B8 (16#0f#); - Gen_B8 (16#90# + To_Cond (Cond)); - Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz_8)); - End_Insn; - end Emit_Setcc_Reg; - - procedure Emit_Tst (Reg : O_Reg; Sz : Insn_Size) - is - begin - Start_Insn; - Gen_Insn_Sz (2#1000_0100#, Sz); - Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz) * 9); - End_Insn; - end Emit_Tst; - - procedure Gen_Cmp_Imm (Reg : O_Reg; Val : Int32; Sz : Insn_Size) - is - B : Byte; - begin - Start_Insn; - if Val <= 127 and Val >= -128 then - B := 2#10#; - else - B := 0; - end if; - Gen_Insn_Sz (2#1000_0000# + B, Sz); - Gen_B8 (2#11_111_000# + To_Reg32 (Reg)); - if B = 0 then - Gen_Le32 (Unsigned_32 (To_Uns32 (Val))); - else - Gen_B8 (Byte (To_Uns32 (Val) and 16#Ff#)); - end if; - End_Insn; - end Gen_Cmp_Imm; - - procedure Emit_Spill (Stmt : O_Enode; Sz : Insn_Size) - is - Reg : O_Reg; - Expr : O_Enode; - begin - Expr := Get_Expr_Operand (Stmt); - Reg := Get_Expr_Reg (Expr); - if Reg = R_Spill then - if Get_Expr_Kind (Expr) = OE_Conv then - return; - else - raise Program_Error; - end if; - end if; - Start_Insn; - Gen_Insn_Sz (2#1000_1000#, Sz); - Gen_Rm (To_Reg32 (Reg, Sz) * 8, Stmt, Sz); - End_Insn; - end Emit_Spill; - - procedure Emit_Load (Reg : O_Reg; Val : O_Enode; Sz : Insn_Size) - is - begin - Start_Insn; - Gen_Insn_Sz (2#1000_1010#, Sz); - Gen_Rm (To_Reg32 (Reg, Sz) * 8, Val, Sz); - End_Insn; - end Emit_Load; - - procedure Emit_Lea (Stmt : O_Enode) - is - Reg : O_Reg; - begin - -- Hack: change the register to use the real address instead of it. - Reg := Get_Expr_Reg (Stmt); - Set_Expr_Reg (Stmt, R_Mem); - - Start_Insn; - Gen_B8 (2#10001101#); - Gen_Rm_Mem (To_Reg32 (Reg) * 8, Stmt, Sz_32l); - End_Insn; - Set_Expr_Reg (Stmt, Reg); - end Emit_Lea; - - procedure Gen_Umul (Stmt : O_Enode; Sz : Insn_Size) - is - begin - if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= R_Ax then - raise Program_Error; - end if; - Start_Insn; - Gen_Insn_Sz (16#F6#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Right (Stmt), Sz); - End_Insn; - end Gen_Umul; - - procedure Gen_Mul (Stmt : O_Enode; Sz : Insn_Size) - is - Reg : O_Reg; - Right : O_Enode; - Reg_R : O_Reg; - begin - Reg := Get_Expr_Reg (Stmt); - Right := Get_Expr_Right (Stmt); - if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= Reg - or Sz /= Sz_32l - then - raise Program_Error; - end if; - Start_Insn; - if Reg = R_Ax then - Gen_Insn_Sz (16#F6#, Sz); - Gen_Rm (2#100_000#, Right, Sz); - else - Reg_R := Get_Expr_Reg (Right); - case Reg_R is - when R_Imm => - if Is_Imm8 (Right, Sz) then - Gen_B8 (16#6B#); - Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); - Gen_Imm8 (Right, Sz); - else - Gen_B8 (16#69#); - Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); - Gen_Imm (Right, Sz); - end if; - when R_Mem - | R_Spill - | Regs_R32 => - Gen_B8 (16#0F#); - Gen_B8 (16#AF#); - Gen_Rm (To_Reg32 (Reg, Sz) * 8, Right, Sz); - when others => - Error_Emit ("gen_mul", Stmt); - end case; - end if; - End_Insn; - end Gen_Mul; - - -- Do not trap if COND is true. - procedure Gen_Ov_Check (Cond : O_Reg) is - begin - -- JXX +2 - Start_Insn; - Gen_B8 (16#70# + To_Cond (Cond)); - Gen_B8 (16#02#); - End_Insn; - -- INT 4 (overflow). - Start_Insn; - Gen_B8 (16#CD#); - Gen_B8 (16#04#); - End_Insn; - end Gen_Ov_Check; - - procedure Emit_Abs (Val : O_Enode; Mode : Mode_Type) - is - Szh : Insn_Size; - Pc_Jmp : Pc_Type; - begin - case Mode is - when Mode_I32 => - Szh := Sz_32l; - when Mode_I64 => - Szh := Sz_32h; - when others => - raise Program_Error; - end case; - Emit_Tst (Get_Expr_Reg (Val), Szh); - -- JXX + - Start_Insn; - Gen_B8 (16#70# + To_Cond (R_Sge)); - Gen_B8 (0); - End_Insn; - Pc_Jmp := Get_Current_Pc; - -- NEG - Gen_Mono_Op (2#011_000#, Val, Sz_32l); - if Mode = Mode_I64 then - -- Propagate carray. - -- Adc reg,0 - -- neg reg - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_Rm (2#010_000#, Val, Sz_32h); - Gen_B8 (0); - End_Insn; - Gen_Mono_Op (2#011_000#, Val, Sz_32h); - end if; - Gen_Into; - Patch_B8 (Pc_Jmp - 1, Unsigned_8 (Get_Current_Pc - Pc_Jmp)); - end Emit_Abs; - - procedure Gen_Alloca (Stmt : O_Enode) - is - Reg : O_Reg; - begin - Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); - if Reg not in Regs_R32 or else Reg /= Get_Expr_Reg (Stmt) then - raise Program_Error; - end if; - -- Align stack on word. - -- Add reg, (stack_boundary - 1) - Start_Insn; - Gen_B8 (2#1000_0011#); - Gen_B8 (2#11_000_000# + To_Reg32 (Reg)); - Gen_B8 (Byte (X86.Flags.Stack_Boundary - 1)); - End_Insn; - -- and reg, ~(stack_boundary - 1) - Start_Insn; - Gen_B8 (2#1000_0001#); - Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); - Gen_Le32 (not (X86.Flags.Stack_Boundary - 1)); - End_Insn; - if X86.Flags.Flag_Alloca_Call then - Gen_Call (Chkstk_Symbol); - else - -- subl esp, reg - Start_Insn; - Gen_B8 (2#0001_1011#); - Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); - End_Insn; - end if; - -- movl reg, esp - Start_Insn; - Gen_B8 (2#1000_1001#); - Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); - End_Insn; - end Gen_Alloca; - - -- Byte/word to long. - procedure Gen_Movzx (Reg : Regs_R32; Op : O_Enode; Sz : Insn_Size) - is - B : Byte; - begin - Start_Insn; - Gen_B8 (16#0f#); - case Sz is - when Sz_8 => - B := 0; - when Sz_16 => - B := 1; - when Sz_32l - | Sz_32h => - raise Program_Error; - end case; - Gen_B8 (2#1011_0110# + B); - Gen_Rm (To_Reg32 (Reg) * 8, Op, Sz_8); - End_Insn; - end Gen_Movzx; - - -- Convert U32 to xx. - procedure Gen_Conv_U32 (Stmt : O_Enode) - is - Op : O_Enode; - Reg_Op : O_Reg; - Reg_Res : O_Reg; - begin - Op := Get_Expr_Operand (Stmt); - Reg_Op := Get_Expr_Reg (Op); - Reg_Res := Get_Expr_Reg (Stmt); - case Get_Expr_Mode (Stmt) is - when Mode_I32 => - if Reg_Res not in Regs_R32 then - raise Program_Error; - end if; - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - Emit_Tst (Reg_Res, Sz_32l); - Gen_Ov_Check (R_Sge); - when Mode_U8 - | Mode_B2 => - if Reg_Res not in Regs_R32 then - raise Program_Error; - end if; - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - -- cmpl VAL, 0xff - Start_Insn; - Gen_B8 (2#1000_0001#); - Gen_Rm (2#111_000#, Op, Sz_32l); - Gen_Le32 (16#00_00_00_Ff#); - End_Insn; - Gen_Ov_Check (R_Ule); - 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) - is - Op : O_Enode; - Reg_Op : O_Reg; - Reg_Res : O_Reg; - begin - Op := Get_Expr_Operand (Stmt); - Reg_Op := Get_Expr_Reg (Op); - Reg_Res := Get_Expr_Reg (Stmt); - case Get_Expr_Mode (Stmt) is - when Mode_I64 => - if Reg_Res /= R_Edx_Eax or Reg_Op /= R_Ax then - raise Program_Error; - end if; - Gen_Cdq; - when Mode_U32 => - if Reg_Res not in Regs_R32 then - raise Program_Error; - end if; - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - Emit_Tst (Reg_Res, Sz_32l); - Gen_Ov_Check (R_Sge); - when Mode_B2 => - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - Gen_Cmp_Imm (Reg_Res, 1, Sz_32l); - Gen_Ov_Check (R_Ule); - when Mode_U8 => - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32l); - Gen_Ov_Check (R_Ule); - when Mode_F64 => - Emit_Push_32 (Op, Sz_32l); - -- fild (%esp) - Start_Insn; - Gen_B8 (2#11011_011#); - Gen_B8 (2#00_000_100#); - Gen_B8 (2#00_100_100#); - End_Insn; - -- addl %esp, 4 - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_000_100#); - Gen_B8 (4); - End_Insn; - when others => - Error_Emit ("gen_conv_i32", Stmt); - end case; - end Gen_Conv_I32; - - -- Convert U8 to xxx - procedure Gen_Conv_U8 (Stmt : O_Enode) - is - Op : O_Enode; - Reg_Res : O_Reg; - begin - Op := Get_Expr_Operand (Stmt); - Reg_Res := Get_Expr_Reg (Stmt); - case Get_Expr_Mode (Stmt) is - when Mode_U32 - | Mode_I32 - | Mode_U16 - | Mode_I16 => - if Reg_Res not in Regs_R32 then - raise Program_Error; - end if; - Gen_Movzx (Reg_Res, Op, Sz_8); - when others => - Error_Emit ("gen_conv_U8", Stmt); - end case; - end Gen_Conv_U8; - - -- Convert B2 to xxx - procedure Gen_Conv_B2 (Stmt : O_Enode) - is - Op : O_Enode; - Reg_Res : O_Reg; - begin - Op := Get_Expr_Operand (Stmt); - Reg_Res := Get_Expr_Reg (Stmt); - case Get_Expr_Mode (Stmt) is - when Mode_U32 - | Mode_I32 - | Mode_U16 - | Mode_I16 => - Gen_Movzx (Reg_Res, Op, Sz_8); - when others => - Error_Emit ("gen_conv_B2", Stmt); - end case; - end Gen_Conv_B2; - - -- Convert I64 to xxx - procedure Gen_Conv_I64 (Stmt : O_Enode) - is - Op : O_Enode; - begin - Op := Get_Expr_Operand (Stmt); - case Get_Expr_Mode (Stmt) is - when Mode_I32 => - -- move dx to reg_helper - Start_Insn; - Gen_B8 (2#1000_1001#); - Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); - End_Insn; - Gen_Cdq; - -- cmp reg_helper, dx - Start_Insn; - Gen_B8 (2#0011_1001#); - Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); - End_Insn; - Gen_Ov_Check (R_Eq); - when Mode_F64 => - Emit_Push_32 (Op, Sz_32h); - Emit_Push_32 (Op, Sz_32l); - -- fild (%esp) - Start_Insn; - Gen_B8 (2#11011_111#); - Gen_B8 (2#00_101_100#); - Gen_B8 (2#00_100_100#); - End_Insn; - -- addl %esp, 8 - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_000_100#); - Gen_B8 (8); - End_Insn; - when others => - Error_Emit ("gen_conv_I64", Stmt); - end case; - end Gen_Conv_I64; - - -- Convert FP to xxx. - procedure Gen_Conv_Fp (Stmt : O_Enode) is - begin - case Get_Expr_Mode (Stmt) is - when Mode_I32 => - -- subl %esp, 4 - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_101_100#); - Gen_B8 (4); - End_Insn; - -- fistp (%esp) - Start_Insn; - Gen_B8 (2#11011_011#); - Gen_B8 (2#00_011_100#); - Gen_B8 (2#00_100_100#); - End_Insn; - Emit_Pop_32 (Stmt, Sz_32l); - when Mode_I64 => - -- subl %esp, 8 - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_101_100#); - Gen_B8 (8); - End_Insn; - -- fistp (%esp) - Start_Insn; - Gen_B8 (2#11011_111#); - Gen_B8 (2#00_111_100#); - Gen_B8 (2#00_100_100#); - End_Insn; - Emit_Pop_32 (Stmt, Sz_32l); - Emit_Pop_32 (Stmt, Sz_32h); - when others => - Error_Emit ("gen_conv_fp", Stmt); - end case; - end Gen_Conv_Fp; - - procedure Gen_Emit_Op (Stmt : O_Enode; Cl : Byte; Ch : Byte) is - begin - case Get_Expr_Mode (Stmt) is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Op (Cl, Stmt, Sz_32l); - when Mode_I64 - | Mode_U64 => - Emit_Op (Cl, Stmt, Sz_32l); - Emit_Op (Ch, Stmt, Sz_32h); - when Mode_B2 - | Mode_I8 - | Mode_U8 => - Emit_Op (Cl, Stmt, Sz_8); - when others => - Error_Emit ("gen_emit_op", Stmt); - end case; - end Gen_Emit_Op; - - procedure Gen_Check_Overflow (Mode : Mode_Type) is - begin - case Mode is - when Mode_I32 - | Mode_I64 - | Mode_I8 => - Gen_Into; - when Mode_U64 - | Mode_U32 - | Mode_U8 => - -- FIXME: check no carry. - null; - when Mode_B2 => - null; - when others => - raise Program_Error; - end case; - end Gen_Check_Overflow; - - procedure Gen_Emit_Fp_Op (Stmt : O_Enode; B_St1 : Byte; B_Mem : Byte) - is - Right : O_Enode; - Reg : O_Reg; - B_Size : Byte; - begin - Right := Get_Expr_Right (Stmt); - Reg := Get_Expr_Reg (Right); - Start_Insn; - case Reg is - when R_St0 => - Gen_B8 (2#11011_110#); - Gen_B8 (2#11_000_001# or B_St1); - when R_Mem => - case Get_Expr_Mode (Stmt) is - when Mode_F32 => - B_Size := 0; - when Mode_F64 => - B_Size := 2#100#; - when others => - raise Program_Error; - end case; - Gen_B8 (2#11011_000# or B_Size); - Gen_Rm_Mem (B_Mem, Right, Sz_32l); - when others => - raise Program_Error; - end case; - End_Insn; - end Gen_Emit_Fp_Op; - - procedure Emit_Mod (Stmt : O_Enode) - is - Right : O_Enode; - Pc1, Pc2, Pc3: Pc_Type; - begin - -- a : EAX - -- d : EDX - -- b : Rm - - -- d := Rm - -- d := d ^ a - -- cltd - -- if cc < 0 then - -- idiv b - -- if edx /= 0 then - -- edx := edx + b - -- end if - -- else - -- idiv b - -- end if - Right := Get_Expr_Right (Stmt); - -- %edx <- right - Emit_Load (R_Dx, Right, Sz_32l); - -- xorl %eax -> %edx - Start_Insn; - Gen_B8 (2#0011_0011#); - Gen_B8 (2#11_010_000#); - End_Insn; - Gen_Cdq; - -- js - Start_Insn; - Gen_B8 (2#0111_1000#); - Gen_B8 (0); - End_Insn; - Pc1 := Get_Current_Pc; - -- idiv - Gen_Mono_Op (2#111_000#, Right, Sz_32l); - -- jmp - Start_Insn; - Gen_B8 (2#1110_1011#); - Gen_B8 (0); - End_Insn; - Pc2 := Get_Current_Pc; - Patch_B8 (Pc1 - 1, Unsigned_8 (Get_Current_Pc - Pc1)); - -- idiv - Gen_Mono_Op (2#111_000#, Right, Sz_32l); - -- tstl %edx,%edx - Start_Insn; - Gen_B8 (2#1000_0101#); - Gen_B8 (2#11_010_010#); - End_Insn; - -- jz - Start_Insn; - Gen_B8 (2#0111_0100#); - Gen_B8 (0); - End_Insn; - Pc3 := Get_Current_Pc; - -- addl b, %edx - Start_Insn; - Gen_B8 (2#00_000_011#); - Gen_Rm (2#010_000#, Right, Sz_32l); - End_Insn; - Patch_B8 (Pc2 - 1, Unsigned_8 (Get_Current_Pc - Pc2)); - Patch_B8 (Pc3 - 1, Unsigned_8 (Get_Current_Pc - Pc3)); - end Emit_Mod; - - procedure Emit_Insn (Stmt : O_Enode) - is - use Ortho_Code.Flags; - Kind : OE_Kind; - Mode : Mode_Type; - Reg : O_Reg; - begin - Kind := Get_Expr_Kind (Stmt); - Mode := Get_Expr_Mode (Stmt); - case Kind is - when OE_Beg => - if Flag_Debug /= Debug_None then - Decls.Set_Block_Info1 (Get_Block_Decls (Stmt), - Int32 (Get_Current_Pc - Subprg_Pc)); - end if; - when OE_End => - if Flag_Debug /= Debug_None then - Decls.Set_Block_Info2 (Get_Block_Decls (Get_End_Beg (Stmt)), - Int32 (Get_Current_Pc - Subprg_Pc)); - end if; - when OE_Leave => - null; - when OE_BB => - null; - when OE_Add_Ov => - if Mode in Mode_Fp then - Gen_Emit_Fp_Op (Stmt, 2#000_000#, 2#000_000#); - else - Gen_Emit_Op (Stmt, 2#000_000#, 2#010_000#); - Gen_Check_Overflow (Mode); - end if; - when OE_Or => - Gen_Emit_Op (Stmt, 2#001_000#, 2#001_000#); - when OE_And => - Gen_Emit_Op (Stmt, 2#100_000#, 2#100_000#); - when OE_Xor => - Gen_Emit_Op (Stmt, 2#110_000#, 2#110_000#); - when OE_Sub_Ov => - if Mode in Mode_Fp then - Gen_Emit_Fp_Op (Stmt, 2#100_000#, 2#100_000#); - else - Gen_Emit_Op (Stmt, 2#101_000#, 2#011_000#); - Gen_Check_Overflow (Mode); - end if; - when OE_Mul_Ov - | OE_Mul => - case Mode is - when Mode_U8 => - Gen_Umul (Stmt, Sz_8); - when Mode_U16 => - Gen_Umul (Stmt, Sz_16); - when Mode_U32 => - Gen_Mul (Stmt, Sz_32l); - when Mode_I32 => - Gen_Mono_Op (2#101_000#, Get_Expr_Right (Stmt), Sz_32l); - when Mode_F32 - | Mode_F64 => - Gen_Emit_Fp_Op (Stmt, 2#001_000#, 2#001_000#); - when others => - Error_Emit ("emit_insn: mul_ov", Stmt); - end case; - when OE_Shl => - declare - Right : O_Enode; - Sz : Insn_Size; - Val : Uns32; - begin - case Mode is - when Mode_U32 => - Sz := Sz_32l; - when others => - Error_Emit ("emit_insn: shl", Stmt); - end case; - Right := Get_Expr_Right (Stmt); - if Get_Expr_Kind (Right) = OE_Const then - Val := Get_Expr_Low (Right); - Start_Insn; - if Val = 1 then - Gen_Insn_Sz (2#1101000_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); - else - Gen_Insn_Sz (2#1100000_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); - Gen_B8 (Byte (Val and 31)); - end if; - End_Insn; - else - if Get_Expr_Reg (Right) /= R_Cx then - raise Program_Error; - end if; - Start_Insn; - Gen_Insn_Sz (2#1101001_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); - End_Insn; - end if; - end; - when OE_Mod - | OE_Rem - | OE_Div_Ov => - case Mode is - when Mode_U32 => - -- Xorl edx, edx - Start_Insn; - Gen_B8 (2#0011_0001#); - Gen_B8 (2#11_010_010#); - End_Insn; - Gen_Mono_Op (2#110_000#, Get_Expr_Right (Stmt), Sz_32l); - when Mode_I32 => - if Kind = OE_Mod then - Emit_Mod (Stmt); - else - Gen_Cdq; - Gen_Mono_Op (2#111_000#, Get_Expr_Right (Stmt), Sz_32l); - end if; - when Mode_F32 - | Mode_F64 => - if Kind = OE_Div_Ov then - Gen_Emit_Fp_Op (Stmt, 2#111_000#, 2#110_000#); - else - raise Program_Error; - end if; - when others => - Error_Emit ("emit_insn: mod_ov", Stmt); - end case; - - when OE_Not => - case Mode is - when Mode_B2 => - -- Xor VAL, $1 - Start_Insn; - Gen_B8 (2#1000_0011#); - Gen_Rm (2#110_000#, Stmt, Sz_8); - Gen_B8 (16#01#); - End_Insn; - when Mode_U8 => - Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_8); - when Mode_U16 => - Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_16); - when Mode_U32 => - Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l); - when Mode_U64 => - Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l); - Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32h); - when others => - Error_Emit ("emit_insn: not", Stmt); - end case; - - when OE_Neg_Ov => - case Mode is - when Mode_I8 => - Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_8); - --Gen_Into; - when Mode_I16 => - Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_16); - --Gen_Into; - when Mode_I32 => - Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l); - --Gen_Into; - when Mode_I64 => - Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l); - -- adcl 0, high - Start_Insn; - Gen_B8 (2#100000_11#); - Gen_Rm (2#010_000#, Get_Expr_Operand (Stmt), Sz_32h); - Gen_B8 (0); - End_Insn; - Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32h); - --Gen_Into; - when Mode_F32 - | Mode_F64 => - -- fchs - Start_Insn; - Gen_B8 (2#11011_001#); - Gen_B8 (2#1110_0000#); - End_Insn; - when others => - Error_Emit ("emit_insn: neg_ov", Stmt); - end case; - - when OE_Abs_Ov => - case Mode is - when Mode_I32 - | Mode_I64 => - Emit_Abs (Get_Expr_Operand (Stmt), Mode); - when Mode_F32 - | Mode_F64 => - -- fabs - Start_Insn; - Gen_B8 (2#11011_001#); - Gen_B8 (2#1110_0001#); - End_Insn; - when others => - Error_Emit ("emit_insn: abs_ov", Stmt); - end case; - - when OE_Kind_Cmp => - case Get_Expr_Mode (Get_Expr_Left (Stmt)) is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Op (2#111_000#, Stmt, Sz_32l); - when Mode_B2 - | Mode_I8 - | Mode_U8 => - Emit_Op (2#111_000#, Stmt, Sz_8); - when Mode_U64 => - declare - Pc : Pc_Type; - begin - Emit_Op (2#111_000#, Stmt, Sz_32h); - -- jne - Start_Insn; - Gen_B8 (2#0111_0101#); - Gen_B8 (0); - End_Insn; - Pc := Get_Current_Pc; - Emit_Op (2#111_000#, Stmt, Sz_32l); - Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); - end; - when Mode_I64 => - declare - Pc : Pc_Type; - begin - Reg := Get_Expr_Reg (Stmt); - Emit_Op (2#111_000#, Stmt, Sz_32h); - -- Note: this does not clobber a reg due to care in - -- insns. - Emit_Setcc_Reg (Reg, Ekind_Signed_To_Cc (Kind)); - -- jne - Start_Insn; - Gen_B8 (2#0111_0101#); - Gen_B8 (0); - End_Insn; - Pc := Get_Current_Pc; - Emit_Op (2#111_000#, Stmt, Sz_32l); - Emit_Setcc_Reg (Reg, Ekind_Unsigned_To_Cc (Kind)); - Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); - return; - end; - when Mode_F32 - | Mode_F64 => - -- fcomip st, st(1) - Start_Insn; - Gen_B8 (2#11011_111#); - Gen_B8 (2#1111_0001#); - End_Insn; - -- fstp st, st (0) - Start_Insn; - Gen_B8 (2#11011_101#); - Gen_B8 (2#11_011_000#); - End_Insn; - when others => - Error_Emit ("emit_insn: cmp", Stmt); - end case; - Reg := Get_Expr_Reg (Stmt); - if Reg not in Regs_Cc then - Error_Emit ("emit_insn/cmp: not cc", Stmt); - end if; - when OE_Const - | OE_Addrg => - case Mode is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Load_Imm (Stmt, Sz_32l); - when Mode_B2 - | Mode_U8 - | Mode_I8 => - Emit_Load_Imm (Stmt, Sz_8); - when Mode_I64 - | Mode_U64 => - Emit_Load_Imm (Stmt, Sz_32l); - Emit_Load_Imm (Stmt, Sz_32h); - when Mode_F32 => - Emit_Load_Fp (Stmt, Fp_32); - when Mode_F64 => - Emit_Load_Fp (Stmt, Fp_64); - when others => - Error_Emit ("emit_insn: const", Stmt); - end case; - when OE_Indir => - case Mode is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Load_Mem (Stmt, Sz_32l); - when Mode_B2 - | Mode_U8 - | Mode_I8 => - Emit_Load_Mem (Stmt, Sz_8); - when Mode_U64 - | Mode_I64 => - Emit_Load_Mem (Stmt, Sz_32l); - Emit_Load_Mem (Stmt, Sz_32h); - when Mode_F32 => - Emit_Load_Fp_Mem (Stmt, Fp_32); - when Mode_F64 => - Emit_Load_Fp_Mem (Stmt, Fp_64); - when others => - Error_Emit ("emit_insn: indir", Stmt); - end case; - - when OE_Conv => - case Get_Expr_Mode (Get_Expr_Operand (Stmt)) is - when Mode_U32 => - Gen_Conv_U32 (Stmt); - when Mode_I32 => - Gen_Conv_I32 (Stmt); - when Mode_U8 => - Gen_Conv_U8 (Stmt); - when Mode_B2 => - Gen_Conv_B2 (Stmt); - when Mode_I64 => - Gen_Conv_I64 (Stmt); - when Mode_F32 - | Mode_F64 => - Gen_Conv_Fp (Stmt); - when others => - Error_Emit ("emit_insn: conv", Stmt); - end case; - - when OE_Asgn => - case Mode is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Store (Stmt, Sz_32l); - when Mode_B2 - | Mode_U8 - | Mode_I8 => - Emit_Store (Stmt, Sz_8); - when Mode_U64 - | Mode_I64 => - Emit_Store (Stmt, Sz_32l); - Emit_Store (Stmt, Sz_32h); - when Mode_F32 => - Emit_Store_Fp (Stmt, Fp_32); - when Mode_F64 => - Emit_Store_Fp (Stmt, Fp_64); - when others => - Error_Emit ("emit_insn: move", Stmt); - end case; - - when OE_Jump_F => - Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); - if Reg not in Regs_Cc then - Error_Emit ("emit_insn/jmp_f: not cc", Stmt); - end if; - Emit_Jmp_T (Stmt, Inverse_Cc (Reg)); - when OE_Jump_T => - Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); - if Reg not in Regs_Cc then - Error_Emit ("emit_insn/jmp_t: not cc", Stmt); - end if; - Emit_Jmp_T (Stmt, Reg); - when OE_Jump => - Emit_Jmp (Stmt); - when OE_Label => - Emit_Label (Stmt); - - when OE_Ret => - -- Value already set. - null; - - when OE_Arg => - case Mode is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); - when Mode_U64 - | Mode_I64 => - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32h); - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); - when Mode_F32 => - Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_32); - when Mode_F64 => - Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_64); - when others => - Error_Emit ("emit_insn: oe_arg", Stmt); - end case; - when OE_Stack_Adjust => - Emit_Setup_Frame (Stmt); - when OE_Call => - Emit_Call (Stmt); - when OE_Intrinsic => - Emit_Intrinsic (Stmt); - - when OE_Move => - declare - Operand : O_Enode; - Op_Reg : O_Reg; - begin - Reg := Get_Expr_Reg (Stmt); - Operand := Get_Expr_Operand (Stmt); - Op_Reg := Get_Expr_Reg (Operand); - case Mode is - when Mode_B2 => - if Reg in Regs_R32 and then Op_Reg in Regs_Cc then - Emit_Setcc (Stmt, Op_Reg); - elsif (Reg = R_Eq or Reg = R_Ne) - and then Op_Reg in Regs_R32 - then - Emit_Tst (Op_Reg, Sz_8); - else - Error_Emit ("emit_insn: move/b2", Stmt); - end if; - when Mode_U32 - | Mode_I32 => - -- mov REG, OP - Start_Insn; - Gen_Insn_Sz (2#1000_101_0#, Sz_32l); - Gen_Rm (To_Reg32 (Reg, Sz_32l) * 8, Operand, Sz_32l); - End_Insn; - when others => - Error_Emit ("emit_insn: move", Stmt); - end case; - end; - - when OE_Alloca => - if Mode /= Mode_P32 then - raise Program_Error; - end if; - Gen_Alloca (Stmt); - - when OE_Set_Stack => - Emit_Load_Mem (Stmt, Sz_32l); - - when OE_Add - | OE_Addrl => - case Mode is - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Lea (Stmt); - when others => - Error_Emit ("emit_insn: oe_add", Stmt); - end case; - - when OE_Spill => - case Mode is - when Mode_B2 - | Mode_U8 - | Mode_I8 => - Emit_Spill (Stmt, Sz_8); - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Spill (Stmt, Sz_32l); - when Mode_U64 - | Mode_I64 => - Emit_Spill (Stmt, Sz_32l); - Emit_Spill (Stmt, Sz_32h); - when others => - Error_Emit ("emit_insn: spill", Stmt); - end case; - - when OE_Reload => - declare - Expr : O_Enode; - begin - Reg := Get_Expr_Reg (Stmt); - Expr := Get_Expr_Operand (Stmt); - case Mode is - when Mode_B2 - | Mode_U8 - | Mode_I8 => - Emit_Load (Reg, Expr, Sz_8); - when Mode_U32 - | Mode_I32 - | Mode_P32 => - Emit_Load (Reg, Expr, Sz_32l); - when Mode_U64 - | Mode_I64 => - Emit_Load (Reg, Expr, Sz_32l); - Emit_Load (Reg, Expr, Sz_32h); - when others => - Error_Emit ("emit_insn: reload", Stmt); - end case; - end; - - when OE_Reg => - Reg_Helper := Get_Expr_Reg (Stmt); - - when OE_Case_Expr - | OE_Case => - null; - - when OE_Line => - if Flag_Debug = Debug_Dwarf then - Dwarf.Set_Line_Stmt (Get_Expr_Line_Number (Stmt)); - Set_Current_Section (Sect_Text); - end if; - when others => - Error_Emit ("cannot handle insn", Stmt); - end case; - end Emit_Insn; - - procedure Push_Reg_If_Used (Reg : Regs_R32) - is - use Ortho_Code.X86.Insns; - begin - if Reg_Used (Reg) then - Start_Insn; - Gen_B8 (2#01010_000# + To_Reg32 (Reg, Sz_32l)); - End_Insn; - end if; - end Push_Reg_If_Used; - - procedure Pop_Reg_If_Used (Reg : Regs_R32) - is - use Ortho_Code.X86.Insns; - begin - if Reg_Used (Reg) then - Start_Insn; - Gen_B8 (2#01011_000# + To_Reg32 (Reg, Sz_32l)); - End_Insn; - end if; - end Pop_Reg_If_Used; - - procedure Emit_Prologue (Subprg : Subprogram_Data_Acc) - is - use Ortho_Code.Decls; - use Ortho_Code.Flags; - use Ortho_Code.X86.Insns; - Sym : Symbol; - Subprg_Decl : O_Dnode; - Is_Global : Boolean; - Frame_Size : Unsigned_32; - Saved_Regs_Size : Unsigned_32; - begin - -- Switch to .text section and align the function (to avoid the nested - -- function trick and for performance). - Set_Current_Section (Sect_Text); - Gen_Pow_Align (2); - - Subprg_Decl := Subprg.D_Decl; - Sym := Get_Decl_Symbol (Subprg_Decl); - case Get_Decl_Storage (Subprg_Decl) is - when O_Storage_Public - | O_Storage_External => - -- FIXME: should not accept the external case. - Is_Global := True; - when others => - Is_Global := False; - end case; - Set_Symbol_Pc (Sym, Is_Global); - Subprg_Pc := Get_Current_Pc; - - Saved_Regs_Size := Boolean'Pos(Reg_Used (R_Di)) * 4 - + Boolean'Pos(Reg_Used (R_Si)) * 4 - + Boolean'Pos(Reg_Used (R_Bx)) * 4; - - -- Compute frame size. - -- 8 bytes are used by return address and saved frame pointer. - Frame_Size := Unsigned_32 (Subprg.Stack_Max) + 8 + Saved_Regs_Size; - -- Align. - Frame_Size := (Frame_Size + X86.Flags.Stack_Boundary - 1) - and not (X86.Flags.Stack_Boundary - 1); - -- The 8 bytes are already allocated. - Frame_Size := Frame_Size - 8 - Saved_Regs_Size; - - -- Emit prolog. - -- push %ebp - Start_Insn; - Gen_B8 (2#01010_101#); - End_Insn; - -- movl %esp, %ebp - Start_Insn; - Gen_B8 (2#1000100_1#); - Gen_B8 (2#11_100_101#); - End_Insn; - -- subl XXX, %esp - if Frame_Size /= 0 then - if not X86.Flags.Flag_Alloca_Call - or else Frame_Size <= 4096 - then - Start_Insn; - if Frame_Size < 128 then - Gen_B8 (2#100000_11#); - Gen_B8 (2#11_101_100#); - Gen_B8 (Byte (Frame_Size)); - else - Gen_B8 (2#100000_01#); - Gen_B8 (2#11_101_100#); - Gen_Le32 (Frame_Size); - end if; - End_Insn; - else - -- mov stack_size,%eax - Start_Insn; - Gen_B8 (2#1011_1_000#); - Gen_Le32 (Frame_Size); - End_Insn; - Gen_Call (Chkstk_Symbol); - end if; - end if; - - if Flag_Profile then - Gen_Call (Mcount_Symbol); - end if; - - -- Save registers. - Push_Reg_If_Used (R_Di); - Push_Reg_If_Used (R_Si); - Push_Reg_If_Used (R_Bx); - end Emit_Prologue; - - procedure Emit_Epilogue (Subprg : Subprogram_Data_Acc) - is - use Ortho_Code.Decls; - use Ortho_Code.Types; - use Ortho_Code.Flags; - Decl : O_Dnode; - begin - -- Restore registers. - Pop_Reg_If_Used (R_Bx); - Pop_Reg_If_Used (R_Si); - Pop_Reg_If_Used (R_Di); - - Decl := Subprg.D_Decl; - if Get_Decl_Kind (Decl) = OD_Function then - case Get_Type_Mode (Get_Decl_Type (Decl)) is - when Mode_U8 - | Mode_B2 => - -- movzx %al,%eax - Start_Insn; - Gen_B8 (16#0f#); - Gen_B8 (2#1011_0110#); - Gen_B8 (2#11_000_000#); - End_Insn; - when Mode_U32 - | Mode_I32 - | Mode_U64 - | Mode_I64 - | Mode_F32 - | Mode_F64 - | Mode_P32 => - null; - when others => - raise Program_Error; - end case; - end if; - - -- leave - Start_Insn; - Gen_B8 (2#1100_1001#); - End_Insn; - - -- ret - Start_Insn; - Gen_B8 (2#1100_0011#); - End_Insn; - - if Flag_Debug = Debug_Dwarf then - Set_Body_Info (Subprg.D_Body, Int32 (Get_Current_Pc - Subprg_Pc)); - end if; - end Emit_Epilogue; - - procedure Emit_Subprg (Subprg : Subprogram_Data_Acc) - is - Stmt : O_Enode; - begin - if Debug.Flag_Debug_Code2 then - Abi.Disp_Subprg_Decl (Subprg.D_Decl); - end if; - - Emit_Prologue (Subprg); - - Stmt := Subprg.E_Entry; - loop - Stmt := Get_Stmt_Link (Stmt); - - if Debug.Flag_Debug_Code2 then - Abi.Disp_Stmt (Stmt); - end if; - - Emit_Insn (Stmt); - exit when Get_Expr_Kind (Stmt) = OE_Leave; - end loop; - - Emit_Epilogue (Subprg); - end Emit_Subprg; - - procedure Emit_Var_Decl (Decl : O_Dnode) - is - use Decls; - use Types; - Sym : Symbol; - Storage : O_Storage; - Dtype : O_Tnode; - begin - Set_Current_Section (Sect_Bss); - Sym := Create_Symbol (Get_Decl_Ident (Decl)); - Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); - Storage := Get_Decl_Storage (Decl); - Dtype := Get_Decl_Type (Decl); - case Storage is - when O_Storage_External => - null; - when O_Storage_Public - | O_Storage_Private => - Gen_Pow_Align (Get_Type_Align (Dtype)); - Set_Symbol_Pc (Sym, Storage = O_Storage_Public); - Gen_Space (Integer_32 (Get_Type_Size (Dtype))); - when O_Storage_Local => - raise Program_Error; - end case; - Set_Current_Section (Sect_Text); - end Emit_Var_Decl; - - procedure Emit_Const_Decl (Decl : O_Dnode) - is - use Decls; - use Types; - Sym : Symbol; - begin - Set_Current_Section (Sect_Rodata); - Sym := Create_Symbol (Get_Decl_Ident (Decl)); - Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); - Set_Current_Section (Sect_Text); - end Emit_Const_Decl; - - procedure Emit_Const (Val : O_Cnode) - is - use Consts; - use Types; - H, L : Uns32; - begin - case Get_Const_Kind (Val) is - when OC_Signed - | OC_Unsigned - | OC_Float - | OC_Null - | OC_Lit => - Get_Const_Bytes (Val, H, L); - case Get_Type_Mode (Get_Const_Type (Val)) is - when Mode_U8 - | Mode_I8 - | Mode_B2 => - Gen_B8 (Byte (L)); - when Mode_U32 - | Mode_I32 - | Mode_F32 - | Mode_P32 => - Gen_Le32 (Unsigned_32 (L)); - when Mode_F64 - | Mode_I64 - | Mode_U64 => - Gen_Le32 (Unsigned_32 (L)); - Gen_Le32 (Unsigned_32 (H)); - when others => - raise Program_Error; - end case; - when OC_Address - | OC_Subprg_Address => - Gen_X86_32 (Get_Decl_Symbol (Get_Const_Decl (Val)), 0); - when OC_Array => - for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop - Emit_Const (Get_Const_Aggr_Element (Val, I)); - end loop; - when OC_Record => - declare - E : O_Cnode; - begin - for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop - E := Get_Const_Aggr_Element (Val, I); - Gen_Pow_Align (Get_Type_Align (Get_Const_Type (E))); - Emit_Const (E); - end loop; - end; - when OC_Sizeof - | OC_Alignof - | OC_Union => - raise Program_Error; - end case; - end Emit_Const; - - procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode) - is - use Decls; - use Types; - Sym : Symbol; - Dtype : O_Tnode; - begin - Set_Current_Section (Sect_Rodata); - Sym := Get_Decl_Symbol (Decl); - - Dtype := Get_Decl_Type (Decl); - Gen_Pow_Align (Get_Type_Align (Dtype)); - Set_Symbol_Pc (Sym, Get_Decl_Storage (Decl) = O_Storage_Public); - Prealloc (Pc_Type (Get_Type_Size (Dtype))); - Emit_Const (Val); - - Set_Current_Section (Sect_Text); - end Emit_Const_Value; - - procedure Init - is - use Ortho_Ident; - use Ortho_Code.Flags; - begin - Arch := Arch_X86; - - Create_Section (Sect_Text, ".text", Section_Exec + Section_Read); - Create_Section (Sect_Rodata, ".rodata", Section_Read); - Create_Section (Sect_Bss, ".bss", - Section_Read + Section_Write + Section_Zero); - - Set_Current_Section (Sect_Text); - - if Flag_Profile then - Mcount_Symbol := Create_Symbol (Get_Identifier ("mcount")); - end if; - - if X86.Flags.Flag_Alloca_Call then - Chkstk_Symbol := Create_Symbol (Get_Identifier ("___chkstk")); - end if; - - Intrinsics_Symbol (Intrinsic_Mul_Ov_U64) := - Create_Symbol (Get_Identifier ("__muldi3")); - Intrinsics_Symbol (Intrinsic_Div_Ov_U64) := - Create_Symbol (Get_Identifier ("__mcode_div_ov_u64")); - Intrinsics_Symbol (Intrinsic_Mod_Ov_U64) := - Create_Symbol (Get_Identifier ("__mcode_mod_ov_u64")); - Intrinsics_Symbol (Intrinsic_Mul_Ov_I64) := - Create_Symbol (Get_Identifier ("__muldi3")); - Intrinsics_Symbol (Intrinsic_Div_Ov_I64) := - Create_Symbol (Get_Identifier ("__divdi3")); - Intrinsics_Symbol (Intrinsic_Mod_Ov_I64) := - Create_Symbol (Get_Identifier ("__mcode_mod_ov_i64")); - Intrinsics_Symbol (Intrinsic_Rem_Ov_I64) := - Create_Symbol (Get_Identifier ("__mcode_rem_ov_i64")); - - if Debug.Flag_Debug_Asm then - Dump_Asm := True; - end if; - if Debug.Flag_Debug_Hex then - Debug_Hex := True; - end if; - - if Flag_Debug = Debug_Dwarf then - Dwarf.Init; - Set_Current_Section (Sect_Text); - end if; - end Init; - - procedure Finish - is - use Ortho_Code.Flags; - begin - if Flag_Debug = Debug_Dwarf then - Set_Current_Section (Sect_Text); - Dwarf.Finish; - end if; - end Finish; - -end Ortho_Code.X86.Emits; - diff --git a/ortho/mcode/ortho_code-x86-emits.ads b/ortho/mcode/ortho_code-x86-emits.ads deleted file mode 100644 index 9ddb43ee5..000000000 --- a/ortho/mcode/ortho_code-x86-emits.ads +++ /dev/null @@ -1,36 +0,0 @@ --- Mcode back-end for ortho - Binary X86 instructions generator. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Binary_File; use Binary_File; - -package Ortho_Code.X86.Emits is - procedure Init; - procedure Finish; - - procedure Emit_Subprg (Subprg : Subprogram_Data_Acc); - - procedure Emit_Var_Decl (Decl : O_Dnode); - procedure Emit_Const_Decl (Decl : O_Dnode); - procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode); - - type Intrinsic_Symbols_Map is array (Intrinsics_X86) of Symbol; - Intrinsics_Symbol : Intrinsic_Symbols_Map; - - Mcount_Symbol : Symbol; - Chkstk_Symbol : Symbol; -end Ortho_Code.X86.Emits; - diff --git a/ortho/mcode/ortho_code-x86-flags_linux.ads b/ortho/mcode/ortho_code-x86-flags_linux.ads deleted file mode 100644 index 30bc7f7b3..000000000 --- a/ortho/mcode/ortho_code-x86-flags_linux.ads +++ /dev/null @@ -1,31 +0,0 @@ --- X86 ABI flags. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Ortho_Code.X86.Flags_Linux is - -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc - -- modifies ESP directly. - Flag_Alloca_Call : constant Boolean := False; - - -- Prefered stack alignment. - -- Must be a power of 2. - Stack_Boundary : constant Unsigned_32 := 2 ** 3; - - -- Alignment for double (64 bit float). - Mode_F64_Align : constant Natural := 2; -end Ortho_Code.X86.Flags_Linux; diff --git a/ortho/mcode/ortho_code-x86-flags_macosx.ads b/ortho/mcode/ortho_code-x86-flags_macosx.ads deleted file mode 100644 index a33085294..000000000 --- a/ortho/mcode/ortho_code-x86-flags_macosx.ads +++ /dev/null @@ -1,31 +0,0 @@ --- X86 ABI flags. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Ortho_Code.X86.Flags_Macosx is - -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc - -- modifies ESP directly. - Flag_Alloca_Call : constant Boolean := False; - - -- Prefered stack alignment. - -- Must be a power of 2. - Stack_Boundary : constant Unsigned_32 := 2 ** 4; - - -- Alignment for double (64 bit float). - Mode_F64_Align : constant Natural := 2; -end Ortho_Code.X86.Flags_Macosx; diff --git a/ortho/mcode/ortho_code-x86-flags_windows.ads b/ortho/mcode/ortho_code-x86-flags_windows.ads deleted file mode 100644 index 3296aaf2c..000000000 --- a/ortho/mcode/ortho_code-x86-flags_windows.ads +++ /dev/null @@ -1,31 +0,0 @@ --- X86 ABI flags. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; - -package Ortho_Code.X86.Flags_Windows is - -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc - -- modifies ESP directly. - Flag_Alloca_Call : constant Boolean := True; - - -- Prefered stack alignment. - -- Must be a power of 2. - Stack_Boundary : constant Unsigned_32 := 2 ** 3; - - -- Alignment for double (64 bit float). - Mode_F64_Align : constant Natural := 3; -end Ortho_Code.X86.Flags_Windows; diff --git a/ortho/mcode/ortho_code-x86-insns.adb b/ortho/mcode/ortho_code-x86-insns.adb deleted file mode 100644 index c218a9ae0..000000000 --- a/ortho/mcode/ortho_code-x86-insns.adb +++ /dev/null @@ -1,2068 +0,0 @@ --- Mcode back-end for ortho - mcode to X86 instructions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; -with Ada.Text_IO; -with Ortho_Code.Abi; -with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Types; use Ortho_Code.Types; -with Ortho_Code.Debug; -with Ortho_Code.X86.Flags; - -package body Ortho_Code.X86.Insns is - procedure Link_Stmt (Stmt : O_Enode) - is - use Ortho_Code.Abi; - begin - Set_Stmt_Link (Last_Link, Stmt); - Last_Link := Stmt; - if Debug.Flag_Debug_Insn then - Disp_Stmt (Stmt); - end if; - end Link_Stmt; - - function Get_Reg_Any (Mode : Mode_Type) return O_Reg is - begin - case Mode is - when Mode_I16 .. Mode_I32 - | Mode_U16 .. Mode_U32 - | Mode_P32 => - return R_Any32; - when Mode_I8 - | Mode_U8 - | Mode_B2 => - return R_Any8; - when Mode_U64 - | Mode_I64 => - return R_Any64; - when Mode_F32 - | Mode_F64 => - if Abi.Flag_Sse2 then - return R_Any_Xmm; - else - return R_St0; - end if; - when Mode_P64 - | Mode_X1 - | Mode_Nil - | Mode_Blk => - raise Program_Error; - end case; - end Get_Reg_Any; - - function Get_Reg_Any (Stmt : O_Enode) return O_Reg is - begin - return Get_Reg_Any (Get_Expr_Mode (Stmt)); - end Get_Reg_Any; - - -- Stack slot management. - Stack_Offset : Uns32 := 0; - Stack_Max : Uns32 := 0; - - -- Count how many bytes have been pushed on the stack, during a call. This - -- is used to correctly align the stack for nested calls. - Push_Offset : Uns32 := 0; - - -- STMT is an OE_END statement. - -- Swap Stack_Offset with Max_Stack of STMT. - procedure Swap_Stack_Offset (Blk : O_Dnode) - is - Prev_Offset : Uns32; - begin - Prev_Offset := Get_Block_Max_Stack (Blk); - Set_Block_Max_Stack (Blk, Stack_Offset); - Stack_Offset := Prev_Offset; - end Swap_Stack_Offset; - - procedure Expand_Decls (Block : O_Dnode) - is - Last : O_Dnode; - Decl : O_Dnode; - Decl_Type : O_Tnode; - begin - if Get_Decl_Kind (Block) /= OD_Block then - raise Program_Error; - end if; - Last := Get_Block_Last (Block); - Decl := Block + 1; - while Decl <= Last loop - case Get_Decl_Kind (Decl) is - when OD_Local => - Decl_Type := Get_Decl_Type (Decl); - Stack_Offset := Do_Align (Stack_Offset, Decl_Type); - Stack_Offset := Stack_Offset + Get_Type_Size (Decl_Type); - Set_Local_Offset (Decl, -Int32 (Stack_Offset)); - if Stack_Offset > Stack_Max then - Stack_Max := Stack_Offset; - end if; - when OD_Type - | OD_Const - | OD_Const_Val - | OD_Var - | OD_Function - | OD_Procedure - | OD_Interface - | OD_Body - | OD_Subprg_Ext => - null; - when OD_Block => - Decl := Get_Block_Last (Decl); - end case; - Decl := Decl + 1; - end loop; - end Expand_Decls; - - function Ekind_To_Cc (Stmt : O_Enode; Mode : Mode_Type) return O_Reg - is - Kind : OE_Kind; - begin - Kind := Get_Expr_Kind (Stmt); - case Mode is - when Mode_U8 .. Mode_U64 - | Mode_F32 .. Mode_F64 - | Mode_P32 - | Mode_P64 - | Mode_B2 => - return Ekind_Unsigned_To_Cc (Kind); - when Mode_I8 .. Mode_I64 => - return Ekind_Signed_To_Cc (Kind); - when others => - raise Program_Error; - end case; - end Ekind_To_Cc; - - -- CC is the result of A CMP B. - -- Returns the condition for B CMP A. - function Reverse_Cc (Cc : O_Reg) return O_Reg is - begin - case Cc is - when R_Ult => - return R_Ugt; - when R_Uge => - return R_Ule; - when R_Eq => - return R_Eq; - when R_Ne => - return R_Ne; - when R_Ule => - return R_Uge; - when R_Ugt => - return R_Ult; - when R_Slt => - return R_Sgt; - when R_Sge => - return R_Sle; - when R_Sle => - return R_Sge; - when R_Sgt => - return R_Slt; - when others => - raise Program_Error; - end case; - end Reverse_Cc; - - -- Get the register in which a result of MODE is returned. - function Get_Call_Register (Mode : Mode_Type) return O_Reg is - begin - case Mode is - when Mode_U8 .. Mode_U32 - | Mode_I8 .. Mode_I32 - | Mode_P32 - | Mode_B2 => - return R_Ax; - when Mode_U64 - | Mode_I64 => - return R_Edx_Eax; - when Mode_F32 - | Mode_F64 => - if Abi.Flag_Sse2 and True then - -- Note: this shouldn't be enabled as the svr4 ABI specifies - -- ST0. - return R_Xmm0; - else - return R_St0; - end if; - when Mode_Nil => - return R_None; - when Mode_X1 - | Mode_Blk - | Mode_P64 => - raise Program_Error; - end case; - end Get_Call_Register; - --- function Ensure_Rm (Stmt : O_Enode) return O_Enode --- is --- begin --- case Get_Expr_Reg (Stmt) is --- when R_Mem --- | Regs_Any32 => --- return Stmt; --- when others => --- raise Program_Error; --- end case; --- end Ensure_Rm; - --- function Ensure_Ireg (Stmt : O_Enode) return O_Enode --- is --- Reg : O_Reg; --- begin --- Reg := Get_Expr_Reg (Stmt); --- case Reg is --- when Regs_Any32 --- | R_Imm => --- return Stmt; --- when others => --- raise Program_Error; --- end case; --- end Ensure_Ireg; - - function Insert_Move (Expr : O_Enode; Dest : O_Reg) return O_Enode - is - N : O_Enode; - begin - N := New_Enode (OE_Move, Get_Expr_Mode (Expr), O_Tnode_Null, - Expr, O_Enode_Null); - Set_Expr_Reg (N, Dest); - Link_Stmt (N); - return N; - end Insert_Move; - --- function Insert_Spill (Expr : O_Enode) return O_Enode --- is --- N : O_Enode; --- begin --- N := New_Enode (OE_Spill, Get_Expr_Mode (Expr), O_Tnode_Null, --- Expr, O_Enode_Null); --- Set_Expr_Reg (N, R_Spill); --- Link_Stmt (N); --- return N; --- end Insert_Spill; - - procedure Error_Gen_Insn (Stmt : O_Enode; Reg : O_Reg) - is - use Ada.Text_IO; - begin - Put_Line ("gen_insn error: cannot match reg " & Abi.Image_Reg (Reg) - & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt))); - raise Program_Error; - end Error_Gen_Insn; - - procedure Error_Gen_Insn (Stmt : O_Enode; Mode : Mode_Type) - is - use Ada.Text_IO; - begin - Put_Line ("gen_insn error: cannot match mode " & Mode_Type'Image (Mode) - & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt)) - & " of mode " & Mode_Type'Image (Get_Expr_Mode (Stmt))); - raise Program_Error; - end Error_Gen_Insn; - - pragma No_Return (Error_Gen_Insn); - - Cur_Block : O_Enode; - - type O_Inum is new Int32; - O_Free : constant O_Inum := 0; - O_Iroot : constant O_Inum := 1; - - - Insn_Num : O_Inum; - - function Get_Insn_Num return O_Inum is - begin - Insn_Num := Insn_Num + 1; - return Insn_Num; - end Get_Insn_Num; - - - type Reg_Info_Type is record - -- Statement number which use this register. - -- This is a distance. - Num : O_Inum; - - -- Statement which produces this value. - -- Used to have more info on this register (such as mode to allocate - -- a spill location). - Stmt : O_Enode; - - -- If set, this register has been used. - -- All callee-saved registers marked must be saved. - Used : Boolean; - end record; - - Init_Reg_Info : constant Reg_Info_Type := (Num => O_Free, - Stmt => O_Enode_Null, - Used => False); - type Reg32_Info_Array is array (Regs_R32) of Reg_Info_Type; - Regs : Reg32_Info_Array := (others => Init_Reg_Info); - - Reg_Cc : Reg_Info_Type := Init_Reg_Info; - - type Fp_Stack_Type is mod 8; - type RegFp_Info_Array is array (Fp_Stack_Type) of Reg_Info_Type; - Fp_Top : Fp_Stack_Type := 0; - Fp_Regs : RegFp_Info_Array; - - type Reg_Xmm_Info_Array is array (Regs_Xmm) of Reg_Info_Type; - Info_Regs_Xmm : Reg_Xmm_Info_Array := (others => Init_Reg_Info); - - function Reg_Used (Reg : Regs_R32) return Boolean is - begin - return Regs (Reg).Used; - end Reg_Used; - - procedure Dump_Reg32_Info (Reg : Regs_R32) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - use Abi; - begin - Put (Image_Reg (Reg)); - Put (": "); - Put (Int32 (Regs (Reg).Stmt), 0); - Put (", num: "); - Put (Int32 (Regs (Reg).Num), 0); - --Put (", twin: "); - --Put (Image_Reg (Regs (Reg).Twin_Reg)); - --Put (", link: "); - --Put (Image_Reg (Regs (Reg).Link)); - New_Line; - end Dump_Reg32_Info; - - procedure Dump_Regs - is - use Ada.Text_IO; - use Debug.Int32_IO; - begin --- Put ("free_regs: "); --- Put (Image_Reg (Free_Regs)); --- Put (", to_free_regs: "); --- Put (Image_Reg (To_Free_Regs)); --- New_Line; - - for I in Regs_R32 loop - Dump_Reg32_Info (I); - end loop; - for I in Fp_Stack_Type loop - Put ("fp" & Fp_Stack_Type'Image (I)); - Put (": "); - Put (Int32 (Fp_Regs (I).Stmt), 0); - New_Line; - end loop; - end Dump_Regs; - - pragma Unreferenced (Dump_Regs); - - procedure Error_Reg (Msg : String; Stmt : O_Enode; Reg : O_Reg) - is - use Ada.Text_IO; - use Ortho_Code.Debug.Int32_IO; - begin - Put ("error reg: "); - Put (Msg); - New_Line; - Put (" stmt: "); - Put (Int32 (Stmt), 0); - Put (", reg: "); - Put (Abi.Image_Reg (Reg)); - New_Line; - --Dump_Regs; - raise Program_Error; - end Error_Reg; - pragma No_Return (Error_Reg); - - -- Free_XX - -- Mark a register as unused. - procedure Free_R32 (Reg : O_Reg) is - begin - if Regs (Reg).Num = O_Free then - raise Program_Error; - end if; - Regs (Reg).Num := O_Free; - end Free_R32; - - procedure Free_Fp is - begin - if Fp_Regs (Fp_Top).Stmt = O_Enode_Null then - raise Program_Error; - end if; - Fp_Regs (Fp_Top).Stmt := O_Enode_Null; - Fp_Top := Fp_Top + 1; - end Free_Fp; - - procedure Free_Cc is - begin - if Reg_Cc.Num = O_Free then - raise Program_Error; - end if; - Reg_Cc.Num := O_Free; - end Free_Cc; - - procedure Free_Xmm (Reg : O_Reg) is - begin - if Info_Regs_Xmm (Reg).Num = O_Free then - raise Program_Error; - end if; - Info_Regs_Xmm (Reg).Num := O_Free; - end Free_Xmm; - - -- Allocate a stack slot for spilling. - procedure Alloc_Spill (N : O_Enode) - is - Mode : Mode_Type; - begin - Mode := Get_Expr_Mode (N); - -- Allocate on the stack. - Stack_Offset := Types.Do_Align (Stack_Offset, Mode); - Stack_Offset := Stack_Offset + Types.Get_Mode_Size (Mode); - if Stack_Offset > Stack_Max then - Stack_Max := Stack_Offset; - end if; - Set_Spill_Info (N, -Int32 (Stack_Offset)); - end Alloc_Spill; - - -- Insert a spill statement after ORIG: will save register(s) allocated by - -- ORIG. - -- Return the register(s) spilt (There might be several registers if - -- ORIG uses a R64 register). - function Insert_Spill (Orig : O_Enode) return O_Reg - is - N : O_Enode; - Mode : Mode_Type; - Reg_Orig : O_Reg; - begin - -- Add a spill statement. - Mode := Get_Expr_Mode (Orig); - N := New_Enode (OE_Spill, Mode, O_Tnode_Null, Orig, O_Enode_Null); - Alloc_Spill (N); - - -- Insert the statement after the one that set the register - -- being spilled. - -- That's very important to be able to easily find the spill location, - -- when it will be reloaded. - if Orig = Abi.Last_Link then - Link_Stmt (N); - else - Set_Stmt_Link (N, Get_Stmt_Link (Orig)); - Set_Stmt_Link (Orig, N); - end if; - Reg_Orig := Get_Expr_Reg (Orig); - Set_Expr_Reg (N, Reg_Orig); - Set_Expr_Reg (Orig, R_Spill); - return Reg_Orig; - end Insert_Spill; - - procedure Spill_R32 (Reg : Regs_R32) - is - Reg_Orig : O_Reg; - begin - if Regs (Reg).Num = O_Free then - -- This register was not allocated. - raise Program_Error; - end if; - - Reg_Orig := Insert_Spill (Regs (Reg).Stmt); - - -- Free the register. - case Reg_Orig is - when Regs_R32 => - if Reg_Orig /= Reg then - raise Program_Error; - end if; - Free_R32 (Reg); - when Regs_R64 => - Free_R32 (Get_R64_High (Reg_Orig)); - Free_R32 (Get_R64_Low (Reg_Orig)); - when others => - raise Program_Error; - end case; - end Spill_R32; - - procedure Alloc_R32 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is - begin - if Regs (Reg).Num /= O_Free then - Spill_R32 (Reg); - end if; - Regs (Reg) := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_R32; - - procedure Clobber_R32 (Reg : O_Reg) is - begin - if Regs (Reg).Num /= O_Free then - Spill_R32 (Reg); - end if; - end Clobber_R32; - - procedure Alloc_Fp (Stmt : O_Enode) - is - begin - Fp_Top := Fp_Top - 1; - - if Fp_Regs (Fp_Top).Stmt /= O_Enode_Null then - -- Must spill-out. - raise Program_Error; - end if; - Fp_Regs (Fp_Top).Stmt := Stmt; - end Alloc_Fp; - - procedure Alloc_R64 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) - is - Rh, Rl : O_Reg; - begin - Rl := Get_R64_Low (Reg); - Rh := Get_R64_High (Reg); - if Regs (Rl).Num /= O_Free - or Regs (Rh).Num /= O_Free - then - Spill_R32 (Rl); - end if; - Regs (Rh) := (Num => Num, Stmt => Stmt, Used => True); - Regs (Rl) := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_R64; - - procedure Alloc_Cc (Stmt : O_Enode; Num : O_Inum) is - begin - if Reg_Cc.Num /= O_Free then - raise Program_Error; - end if; - Reg_Cc := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_Cc; - - procedure Spill_Xmm (Reg : Regs_Xmm) - is - Reg_Orig : O_Reg; - begin - if Info_Regs_Xmm (Reg).Num = O_Free then - -- This register was not allocated. - raise Program_Error; - end if; - - Reg_Orig := Insert_Spill (Info_Regs_Xmm (Reg).Stmt); - - -- Free the register. - if Reg_Orig /= Reg then - raise Program_Error; - end if; - Free_Xmm (Reg); - end Spill_Xmm; - - procedure Alloc_Xmm (Reg : Regs_Xmm; Stmt : O_Enode; Num : O_Inum) is - begin - if Info_Regs_Xmm (Reg).Num /= O_Free then - Spill_Xmm (Reg); - end if; - Info_Regs_Xmm (Reg) := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_Xmm; - - procedure Clobber_Xmm (Reg : Regs_Xmm) is - begin - if Info_Regs_Xmm (Reg).Num /= O_Free then - Spill_Xmm (Reg); - end if; - end Clobber_Xmm; - pragma Unreferenced (Clobber_Xmm); - - function Alloc_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) return O_Reg - is - Best_Reg : O_Reg; - Best_Num : O_Inum; - begin - case Reg is - when Regs_R32 => - Alloc_R32 (Reg, Stmt, Num); - return Reg; - when Regs_R64 => - Alloc_R64 (Reg, Stmt, Num); - return Reg; - when R_St0 => - Alloc_Fp (Stmt); - return Reg; - when Regs_Xmm => - Alloc_Xmm (Reg, Stmt, Num); - return Reg; - when R_Any32 => - Best_Num := O_Inum'Last; - Best_Reg := R_None; - for I in Regs_R32 loop - if I not in R_Sp .. R_Bp then - if Regs (I).Num = O_Free then - Alloc_R32 (I, Stmt, Num); - return I; - elsif Regs (I).Num <= Best_Num then - Best_Reg := I; - Best_Num := Regs (I).Num; - end if; - end if; - end loop; - Alloc_R32 (Best_Reg, Stmt, Num); - return Best_Reg; - when R_Any8 => - Best_Num := O_Inum'Last; - Best_Reg := R_None; - for I in Regs_R8 loop - if Regs (I).Num = O_Free then - Alloc_R32 (I, Stmt, Num); - return I; - elsif Regs (I).Num <= Best_Num then - Best_Reg := I; - Best_Num := Regs (I).Num; - end if; - end loop; - Alloc_R32 (Best_Reg, Stmt, Num); - return Best_Reg; - when R_Any64 => - declare - Rh, Rl : O_Reg; - begin - Best_Num := O_Inum'Last; - Best_Reg := R_None; - for I in Regs_R64 loop - Rh := Get_R64_High (I); - Rl := Get_R64_Low (I); - if Regs (Rh).Num = O_Free - and then Regs (Rl).Num = O_Free - then - Alloc_R64 (I, Stmt, Num); - return I; - elsif Regs (Rh).Num <= Best_Num - and Regs (Rl).Num <= Best_Num - then - Best_Reg := I; - Best_Num := O_Inum'Max (Regs (Rh).Num, - Regs (Rl).Num); - end if; - end loop; - Alloc_R64 (Best_Reg, Stmt, Num); - return Best_Reg; - end; - when R_Any_Xmm => - Best_Num := O_Inum'Last; - Best_Reg := R_None; - for I in Regs_X86_Xmm loop - if Info_Regs_Xmm (I).Num = O_Free then - Alloc_Xmm (I, Stmt, Num); - return I; - elsif Info_Regs_Xmm (I).Num <= Best_Num then - Best_Reg := I; - Best_Num := Info_Regs_Xmm (I).Num; - end if; - end loop; - Alloc_Xmm (Best_Reg, Stmt, Num); - return Best_Reg; - when others => - Error_Reg ("alloc_reg: unknown reg", O_Enode_Null, Reg); - raise Program_Error; - end case; - end Alloc_Reg; - - function Gen_Reload (Spill : O_Enode; Reg : O_Reg; Num : O_Inum) - return O_Enode - is - N : O_Enode; - Mode : Mode_Type; - begin - -- Add a reload node. - Mode := Get_Expr_Mode (Spill); - N := New_Enode (OE_Reload, Mode, O_Tnode_Null, Spill, O_Enode_Null); - -- Note: this does not use a just-freed register, since - -- this case only occurs at the first call. - Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num)); - Link_Stmt (N); - return N; - end Gen_Reload; - - function Reload (Expr : O_Enode; Dest : O_Reg; Num : O_Inum) return O_Enode - is - Reg : O_Reg; - Spill : O_Enode; - begin - Reg := Get_Expr_Reg (Expr); - case Reg is - when R_Spill => - -- Restore the register between the statement and the spill. - Spill := Get_Stmt_Link (Expr); - Set_Expr_Reg (Expr, Get_Expr_Reg (Spill)); - Set_Expr_Reg (Spill, R_Spill); - case Dest is - when R_Mem - | R_Irm - | R_Rm => - return Spill; - when Regs_R32 - | R_Any32 - | Regs_R64 - | R_Any64 - | R_Any8 => - return Gen_Reload (Spill, Dest, Num); - when R_Sib => - return Gen_Reload (Spill, R_Any32, Num); - when R_Ir => - return Gen_Reload (Spill, Get_Reg_Any (Expr), Num); - when others => - Error_Reg ("reload: unhandled dest in spill", Expr, Dest); - end case; - when Regs_R32 => - case Dest is - when R_Irm - | R_Rm - | R_Ir - | R_Any32 - | R_Any8 - | R_Sib => - return Expr; - when Regs_R32 => - if Dest = Reg then - return Expr; - end if; - Free_R32 (Reg); - Spill := Insert_Move (Expr, Dest); - Alloc_R32 (Dest, Spill, Num); - return Spill; - when others => - Error_Reg ("reload: unhandled dest in R32", Expr, Dest); - end case; - when Regs_R64 => - return Expr; - when R_St0 => - return Expr; - when Regs_Xmm => - return Expr; - when R_Mem => - if Get_Expr_Kind (Expr) = OE_Indir then - Set_Expr_Operand (Expr, - Reload (Get_Expr_Operand (Expr), R_Sib, Num)); - return Expr; - else - raise Program_Error; - end if; - when R_B_Off - | R_B_I - | R_I_Off - | R_Sib => - case Get_Expr_Kind (Expr) is - when OE_Add => - Set_Expr_Left - (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num)); - Set_Expr_Right - (Expr, Reload (Get_Expr_Right (Expr), R_Any32, Num)); - return Expr; - when OE_Addrl => - Spill := Get_Addrl_Frame (Expr); - if Spill /= O_Enode_Null then - Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num)); - end if; - return Expr; - when others => - Error_Reg ("reload: unhandle expr in b_off", Expr, Dest); - end case; - when R_I => - Set_Expr_Left (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num)); - return Expr; - when R_Imm => - return Expr; - when others => - Error_Reg ("reload: unhandled reg", Expr, Reg); - end case; - end Reload; - - procedure Renum_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is - begin - case Reg is - when Regs_R32 => - Regs (Reg).Num := Num; - Regs (Reg).Stmt := Stmt; - when Regs_Cc => - Reg_Cc.Num := Num; - Reg_Cc.Stmt := Stmt; - when R_St0 => - null; - when Regs_R64 => - declare - L, H : O_Reg; - begin - L := Get_R64_Low (Reg); - Regs (L).Num := Num; - Regs (L).Stmt := Stmt; - H := Get_R64_High (Reg); - Regs (H).Num := Num; - Regs (H).Stmt := Stmt; - end; - when others => - Error_Reg ("renum_reg", Stmt, Reg); - end case; - end Renum_Reg; - - procedure Free_Insn_Regs (Insn : O_Enode) - is - R : O_Reg; - begin - R := Get_Expr_Reg (Insn); - case R is - when R_Ax - | R_Bx - | R_Cx - | R_Dx - | R_Si - | R_Di => - Free_R32 (R); - when R_Sp - | R_Bp => - null; - when R_St0 => - Free_Fp; - when Regs_Xmm => - Free_Xmm (R); - when Regs_R64 => - Free_R32 (Get_R64_High (R)); - Free_R32 (Get_R64_Low (R)); - when R_Mem => - if Get_Expr_Kind (Insn) = OE_Indir then - Free_Insn_Regs (Get_Expr_Operand (Insn)); - else - raise Program_Error; - end if; - when R_B_Off - | R_B_I - | R_I_Off - | R_Sib => - case Get_Expr_Kind (Insn) is - when OE_Add => - Free_Insn_Regs (Get_Expr_Left (Insn)); - Free_Insn_Regs (Get_Expr_Right (Insn)); - when OE_Addrl => - if Get_Addrl_Frame (Insn) /= O_Enode_Null then - Free_Insn_Regs (Get_Addrl_Frame (Insn)); - end if; - when others => - raise Program_Error; - end case; - when R_I => - Free_Insn_Regs (Get_Expr_Left (Insn)); - when R_Imm => - null; - when R_Spill => - null; - when others => - Error_Reg ("free_insn_regs: unknown reg", Insn, R); - end case; - end Free_Insn_Regs; - - procedure Insert_Reg (Mode : Mode_Type) - is - N : O_Enode; - Num : O_Inum; - begin - Num := Get_Insn_Num; - N := New_Enode (OE_Reg, Mode, O_Tnode_Null, - O_Enode_Null, O_Enode_Null); - Set_Expr_Reg (N, Alloc_Reg (Get_Reg_Any (Mode), N, Num)); - Link_Stmt (N); - Free_Insn_Regs (N); - end Insert_Reg; - - procedure Insert_Arg (Expr : O_Enode) - is - N : O_Enode; - begin - Free_Insn_Regs (Expr); - N := New_Enode (OE_Arg, Get_Expr_Mode (Expr), O_Tnode_Null, - Expr, O_Enode_Null); - Set_Expr_Reg (N, R_None); - Link_Stmt (N); - end Insert_Arg; - - function Insert_Intrinsic (Stmt : O_Enode; Reg : O_Reg; Num : O_Inum) - return O_Enode - is - N : O_Enode; - Op : Int32; - Mode : Mode_Type; - begin - Mode := Get_Expr_Mode (Stmt); - case Get_Expr_Kind (Stmt) is - when OE_Mul_Ov => - case Mode is - when Mode_U64 => - Op := Intrinsic_Mul_Ov_U64; - when Mode_I64 => - Op := Intrinsic_Mul_Ov_I64; - when others => - raise Program_Error; - end case; - when OE_Div_Ov => - case Mode is - when Mode_U64 => - Op := Intrinsic_Div_Ov_U64; - when Mode_I64 => - Op := Intrinsic_Div_Ov_I64; - when others => - raise Program_Error; - end case; - when OE_Mod => - case Mode is - when Mode_U64 => - Op := Intrinsic_Mod_Ov_U64; - when Mode_I64 => - Op := Intrinsic_Mod_Ov_I64; - when others => - raise Program_Error; - end case; - when OE_Rem => - case Mode is - when Mode_U64 => - -- For unsigned, MOD == REM. - Op := Intrinsic_Mod_Ov_U64; - when Mode_I64 => - Op := Intrinsic_Rem_Ov_I64; - when others => - raise Program_Error; - end case; - when others => - raise Program_Error; - end case; - - -- Save caller-saved registers. - Clobber_R32 (R_Ax); - Clobber_R32 (R_Dx); - Clobber_R32 (R_Cx); - - N := New_Enode (OE_Intrinsic, Mode, O_Tnode_Null, - O_Enode (Op), O_Enode_Null); - Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num)); - Link_Stmt (N); - return N; - end Insert_Intrinsic; - - -- REG is mandatory: the result of STMT must satisfy the REG constraint. - function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) - return O_Enode; - - function Gen_Conv_From_Fp_Insn (Stmt : O_Enode; - Reg : O_Reg; - Pnum : O_Inum) - return O_Enode - is - Num : O_Inum; - Left : O_Enode; - begin - Left := Get_Expr_Operand (Stmt); - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_St0, Num); - Free_Insn_Regs (Left); - Set_Expr_Operand (Stmt, Left); - case Reg is - when Regs_R32 - | R_Any32 - | Regs_R64 - | R_Any64 => - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - when R_Rm - | R_Irm - | R_Ir => - Set_Expr_Reg (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); - when others => - raise Program_Error; - end case; - Link_Stmt (Stmt); - return Stmt; --- declare --- Spill : O_Enode; --- begin --- Num := Get_Insn_Num; --- Left := Gen_Insn (Left, R_St0, Num); --- Set_Expr_Operand (Stmt, Left); --- Set_Expr_Reg (Stmt, R_Spill); --- Free_Insn_Regs (Left); --- Link_Stmt (Stmt); --- Spill := Insert_Spill (Stmt); --- case Reg is --- when R_Any32 --- | Regs_R32 => --- return Gen_Reload (Spill, Reg, Pnum); --- when R_Ir => --- return Gen_Reload (Spill, R_Any32, Pnum); --- when R_Rm --- | R_Irm => --- return Spill; --- when others => --- Error_Reg --- ("gen_insn:oe_conv(fp)", Stmt, Reg); --- end case; --- end; - end Gen_Conv_From_Fp_Insn; - - function Gen_Call (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) - return O_Enode - is - use Interfaces; - Left : O_Enode; - Reg_Res : O_Reg; - Subprg : O_Dnode; - Push_Size : Uns32; - Pad : Uns32; - Res_Stmt : O_Enode; - begin - -- Emit Setup_Frame (to align stack). - Subprg := Get_Call_Subprg (Stmt); - Push_Size := Uns32 (Get_Subprg_Stack (Subprg)); - -- Pad the stack if necessary. - Pad := (Push_Size + Push_Offset) and Uns32 (Flags.Stack_Boundary - 1); - if Pad /= 0 then - Pad := Uns32 (Flags.Stack_Boundary) - Pad; - Link_Stmt (New_Enode (OE_Stack_Adjust, Mode_Nil, O_Tnode_Null, - O_Enode (Pad), O_Enode_Null)); - end if; - -- The stack has been adjusted by Pad bytes. - Push_Offset := Push_Offset + Pad; - - -- Generate code for arguments (if any). - Left := Get_Arg_Link (Stmt); - if Left /= O_Enode_Null then - Left := Gen_Insn (Left, R_None, Pnum); - end if; - - -- Clobber registers. - Clobber_R32 (R_Ax); - Clobber_R32 (R_Dx); - Clobber_R32 (R_Cx); - -- FIXME: fp regs. - - -- Add the call. - Reg_Res := Get_Call_Register (Get_Expr_Mode (Stmt)); - Set_Expr_Reg (Stmt, Reg_Res); - Link_Stmt (Stmt); - Res_Stmt := Stmt; - - if Push_Size + Pad /= 0 then - Res_Stmt := - New_Enode (OE_Stack_Adjust, Get_Expr_Mode (Stmt), O_Tnode_Null, - O_Enode (-Int32 (Push_Size + Pad)), O_Enode_Null); - Set_Expr_Reg (Res_Stmt, Reg_Res); - Link_Stmt (Res_Stmt); - end if; - - -- The stack has been restored (just after the call). - Push_Offset := Push_Offset - (Push_Size + Pad); - - case Reg is - when R_Any32 - | R_Any64 - | R_Any8 - | R_Irm - | R_Rm - | R_Ir - | R_Sib - | R_Ax - | R_St0 - | R_Edx_Eax => - Reg_Res := Alloc_Reg (Reg_Res, Res_Stmt, Pnum); - return Res_Stmt; - when R_Any_Cc => - -- Move to register. - -- (use the 'test' instruction). - Alloc_Cc (Res_Stmt, Pnum); - return Insert_Move (Res_Stmt, R_Ne); - when R_None => - if Reg_Res /= R_None then - raise Program_Error; - end if; - return Res_Stmt; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - end Gen_Call; - - function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) - return O_Enode - is - Kind : OE_Kind; - - Left : O_Enode; - Right : O_Enode; - - Reg1 : O_Reg; - -- P_Reg : O_Reg; - Reg_L : O_Reg; - Reg_Res : O_Reg; - - Num : O_Inum; - begin - Kind := Get_Expr_Kind (Stmt); - case Kind is - when OE_Addrl => - Right := Get_Addrl_Frame (Stmt); - if Right /= O_Enode_Null then - Num := Get_Insn_Num; - Right := Gen_Insn (Right, R_Any32, Num); - Set_Addrl_Frame (Stmt, Right); - else - Num := O_Free; - end if; - case Reg is - when R_Sib => - Set_Expr_Reg (Stmt, R_B_Off); - return Stmt; - when R_Irm - | R_Ir => - if Right /= O_Enode_Null then - Free_Insn_Regs (Right); - end if; - Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); - Link_Stmt (Stmt); - return Stmt; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - when OE_Addrg => - case Reg is - when R_Sib - | R_Irm - | R_Ir => - Set_Expr_Reg (Stmt, R_Imm); - return Stmt; - when R_Any32 - | Regs_R32 => - Set_Expr_Reg (Stmt, Reg); - Link_Stmt (Stmt); - return Stmt; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - when OE_Indir => - Left := Get_Expr_Operand (Stmt); - case Reg is - when R_Irm - | R_Rm => - Left := Gen_Insn (Left, R_Sib, Pnum); - Set_Expr_Reg (Stmt, R_Mem); - Set_Expr_Operand (Stmt, Left); - when R_Ir - | R_Sib - | R_I_Off => - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Sib, Num); - Reg1 := Get_Reg_Any (Stmt); - if Reg1 = R_Any64 then - Reg1 := Alloc_Reg (Reg1, Stmt, Pnum); - Free_Insn_Regs (Left); - else - Free_Insn_Regs (Left); - Reg1 := Alloc_Reg (Reg1, Stmt, Pnum); - end if; - Set_Expr_Reg (Stmt, Reg1); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Stmt); - when Regs_R32 - | R_Any32 - | R_Any8 - | Regs_Fp => - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Sib, Num); - Free_Insn_Regs (Left); - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Stmt); - when Regs_R64 - | R_Any64 => - -- Avoid overwritting: - -- Eg: axdx = indir (ax) - -- axdx = indir (ax+dx) - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Sib, Num); - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - Left := Reload (Left, R_Sib, Num); - Free_Insn_Regs (Left); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Stmt); - when R_Any_Cc => - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Sib, Num); - -- Generate a cmp $1, XX - Set_Expr_Reg (Stmt, R_Eq); - Set_Expr_Operand (Stmt, Left); - Free_Insn_Regs (Left); - Link_Stmt (Stmt); - Alloc_Cc (Stmt, Pnum); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - return Stmt; - when OE_Conv_Ptr => - -- Delete nops. - return Gen_Insn (Get_Expr_Operand (Stmt), Reg, Pnum); - when OE_Const => - case Get_Expr_Mode (Stmt) is - when Mode_U8 .. Mode_U32 - | Mode_I8 .. Mode_I32 - | Mode_P32 - | Mode_B2 => - case Reg is - when R_Imm - | Regs_Imm32 => - Set_Expr_Reg (Stmt, R_Imm); - when Regs_R32 - | R_Any32 - | R_Any8 => - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - Link_Stmt (Stmt); - when R_Rm => - Set_Expr_Reg - (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); - Link_Stmt (Stmt); - when R_Any_Cc => - Num := Get_Insn_Num; - Set_Expr_Reg (Stmt, Alloc_Reg (R_Any8, Stmt, Num)); - Link_Stmt (Stmt); - Free_Insn_Regs (Stmt); - Right := Insert_Move (Stmt, R_Ne); - Alloc_Cc (Right, Pnum); - return Right; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - when Mode_F32 - | Mode_F64 => - case Reg is - when R_Ir - | R_Irm - | R_Rm - | R_St0 => - Num := Get_Insn_Num; - if Reg = R_St0 or not Abi.Flag_Sse2 then - Reg1 := R_St0; - else - Reg1 := R_Any_Xmm; - end if; - Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Num)); - Link_Stmt (Stmt); - when others => - raise Program_Error; - end case; - when Mode_U64 - | Mode_I64 => - case Reg is - when R_Irm - | R_Ir - | R_Rm => - Set_Expr_Reg (Stmt, R_Imm); - when R_Mem => - Set_Expr_Reg (Stmt, R_Mem); - when Regs_R64 - | R_Any64 => - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - Link_Stmt (Stmt); - when others => - raise Program_Error; - end case; - when others => - raise Program_Error; - end case; - return Stmt; - when OE_Alloca => - -- Roughly speaking, emited code is: (MASK is a constant). - -- VAL := (VAL + MASK) & ~MASK - -- SP := SP - VAL - -- res <- SP - Left := Get_Expr_Operand (Stmt); - case Reg is - when R_Ir - | R_Irm - | R_Any32 => - Num := Get_Insn_Num; - if X86.Flags.Flag_Alloca_Call then - Reg_L := R_Ax; - else - Reg_L := R_Any32; - end if; - Left := Gen_Insn (Left, Reg_L, Num); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Left); - Free_Insn_Regs (Left); - Set_Expr_Reg (Stmt, Alloc_Reg (Reg_L, Stmt, Pnum)); - Link_Stmt (Stmt); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - return Stmt; - - when OE_Kind_Cmp => - -- Return LEFT cmp RIGHT, ie compute RIGHT - LEFT - Num := Get_Insn_Num; - Left := Get_Expr_Left (Stmt); - Reg_L := Get_Reg_Any (Left); - Left := Gen_Insn (Left, Reg_L, Num); - - Right := Get_Expr_Right (Stmt); - case Get_Expr_Mode (Right) is - when Mode_F32 - | Mode_F64 => - Reg1 := R_St0; - when others => - Reg1 := R_Irm; - end case; - Right := Gen_Insn (Right, Reg1, Num); - - -- FIXME: what about if right was spilled out of FP regs ? - -- (it is reloaded in reverse). - Left := Reload (Left, Reg_L, Num); - - Set_Expr_Right (Stmt, Right); - Set_Expr_Left (Stmt, Left); - - Link_Stmt (Stmt); - - Reg_Res := Ekind_To_Cc (Stmt, Get_Expr_Mode (Left)); - case Get_Expr_Mode (Left) is - when Mode_F32 - | Mode_F64 => - Reg_Res := Reverse_Cc (Reg_Res); - when Mode_I64 => - -- I64 is a little bit special... - Reg_Res := Get_R64_High (Get_Expr_Reg (Left)); - if Reg_Res not in Regs_R8 then - Reg_Res := R_Nil; - for I in Regs_R8 loop - if Regs (I).Num = O_Free then - Reg_Res := I; - exit; - end if; - end loop; - if Reg_Res = R_Nil then - -- FIXME: to be handled. - -- Can this happen ? - raise Program_Error; - end if; - end if; - - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - - Set_Expr_Reg (Stmt, Reg_Res); - case Reg is - when R_Any_Cc => - Right := Insert_Move (Stmt, R_Ne); - Alloc_Cc (Right, Pnum); - return Right; - when R_Any8 - | Regs_R8 - | R_Irm - | R_Ir - | R_Rm => - Reg_Res := Alloc_Reg (Reg_Res, Stmt, Pnum); - return Stmt; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - when others => - null; - end case; - Set_Expr_Reg (Stmt, Reg_Res); - - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - - case Reg is - when R_Any_Cc => - Alloc_Cc (Stmt, Pnum); - return Stmt; - when R_Any8 - | Regs_R8 => - Reg_Res := Alloc_Reg (Reg, Stmt, Pnum); - return Insert_Move (Stmt, Reg_Res); - when R_Irm - | R_Ir - | R_Rm => - Reg_Res := Alloc_Reg (R_Any8, Stmt, Pnum); - return Insert_Move (Stmt, Reg_Res); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - when OE_Add => - declare - R_L : O_Reg; - R_R : O_Reg; - begin - Left := Gen_Insn (Get_Expr_Left (Stmt), R_Sib, Pnum); - Right := Gen_Insn (Get_Expr_Right (Stmt), R_Sib, Pnum); - Left := Reload (Left, R_Sib, Pnum); - Set_Expr_Right (Stmt, Right); - Set_Expr_Left (Stmt, Left); - R_L := Get_Expr_Reg (Left); - R_R := Get_Expr_Reg (Right); - -- Results can be: Reg, R_B_Off, R_Sib, R_Imm, R_B_I - case R_L is - when R_Any32 - | Regs_R32 => - case R_R is - when R_Imm => - Set_Expr_Reg (Stmt, R_B_Off); - when R_B_Off - | R_I - | R_I_Off => - Set_Expr_Reg (Stmt, R_Sib); - when R_Any32 - | Regs_R32 => - Set_Expr_Reg (Stmt, R_B_I); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - when R_Imm => - case R_R is - when R_Imm => - Set_Expr_Reg (Stmt, R_Imm); - when R_Any32 - | Regs_R32 - | R_B_Off => - Set_Expr_Reg (Stmt, R_B_Off); - when R_I - | R_I_Off => - Set_Expr_Reg (Stmt, R_I_Off); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - when R_B_Off => - case R_R is - when R_Imm => - Set_Expr_Reg (Stmt, R_B_Off); - when R_Any32 - | Regs_R32 - | R_I => - Set_Expr_Reg (Stmt, R_Sib); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - when R_I_Off => - case R_R is - when R_Imm => - Set_Expr_Reg (Stmt, R_I_Off); - when R_Any32 - | Regs_R32 => - Set_Expr_Reg (Stmt, R_Sib); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - when R_I => - case R_R is - when R_Imm - | Regs_R32 - | R_B_Off => - Set_Expr_Reg (Stmt, R_Sib); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - when R_Sib - | R_B_I => - if R_R = R_Imm then - Set_Expr_Reg (Stmt, R_Sib); - else - Num := Get_Insn_Num; - Free_Insn_Regs (Left); - Set_Expr_Reg (Left, Alloc_Reg (R_Any32, Left, Num)); - Link_Stmt (Left); - case R_R is - when R_Any32 - | Regs_R32 - | R_I => - Set_Expr_Reg (Stmt, R_B_I); - when others => - Error_Gen_Insn (Stmt, R_R); - end case; - end if; - when others => - Error_Gen_Insn (Stmt, R_L); - end case; - - case Reg is - when R_Sib => - null; - when R_Ir - | R_Irm => - if Get_Expr_Reg (Stmt) /= R_Imm then - Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - Link_Stmt (Stmt); - end if; - when R_Any32 - | Regs_R32 => - Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); - Link_Stmt (Stmt); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - end; - return Stmt; - when OE_Mul => - Num := Get_Insn_Num; - Left := Gen_Insn (Get_Expr_Left (Stmt), R_Ax, Num); - Set_Expr_Left (Stmt, Left); - - Right := Gen_Insn (Get_Expr_Right (Stmt), R_Any32, Num); - if Get_Expr_Kind (Right) /= OE_Const then - raise Program_Error; - end if; - Set_Expr_Right (Stmt, Right); - - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - Clobber_R32 (R_Dx); - Set_Expr_Reg (Stmt, Alloc_Reg (R_Ax, Stmt, Pnum)); - case Reg is - when R_Sib - | R_B_Off => - null; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - Link_Stmt (Stmt); - return Stmt; - when OE_Shl => - Num := Get_Insn_Num; - Right := Get_Expr_Right (Stmt); - if Get_Expr_Kind (Right) /= OE_Const then - Right := Gen_Insn (Right, R_Cx, Num); - else - Right := Gen_Insn (Right, R_Imm, Num); - end if; - Left := Get_Expr_Left (Stmt); - Reg1 := Get_Reg_Any (Stmt); - Left := Gen_Insn (Left, Reg1, Pnum); - if Get_Expr_Kind (Right) /= OE_Const then - Right := Reload (Right, R_Cx, Num); - end if; - Left := Reload (Left, Reg1, Pnum); - Set_Expr_Left (Stmt, Left); - Set_Expr_Right (Stmt, Right); - if Reg = R_Sib - and then Get_Expr_Kind (Right) = OE_Const - and then Get_Expr_Low (Right) in 0 .. 3 - then - Set_Expr_Reg (Stmt, R_I); - else - Link_Stmt (Stmt); - Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); - Free_Insn_Regs (Right); - end if; - return Stmt; - - when OE_Add_Ov - | OE_Sub_Ov - | OE_And - | OE_Xor - | OE_Or => - -- Accepted is: R with IMM or R/M - Num := Get_Insn_Num; - Right := Get_Expr_Right (Stmt); - Left := Get_Expr_Left (Stmt); - case Reg is - when R_Irm - | R_Rm - | R_Ir - | R_Sib => - Right := Gen_Insn (Right, R_Irm, Num); - Reg1 := Get_Reg_Any (Stmt); - Left := Gen_Insn (Left, Reg1, Num); - Right := Reload (Right, R_Irm, Num); - Left := Reload (Left, Reg1, Num); - Reg_Res := Get_Expr_Reg (Left); - when R_Any_Cc => - Right := Gen_Insn (Right, R_Irm, Num); - Left := Gen_Insn (Left, R_Any8, Num); - Reg_Res := R_Ne; - Alloc_Cc (Stmt, Num); - Free_Insn_Regs (Left); - when R_Any32 - | Regs_R32 - | R_Any8 - | R_Any64 - | Regs_R64 - | Regs_Fp => - Right := Gen_Insn (Right, R_Irm, Num); - Left := Gen_Insn (Left, Reg, Num); - Right := Reload (Right, R_Irm, Num); - Left := Reload (Left, Reg, Num); - Reg_Res := Get_Expr_Reg (Left); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - Set_Expr_Right (Stmt, Right); - Set_Expr_Left (Stmt, Left); - Set_Expr_Reg (Stmt, Reg_Res); - Renum_Reg (Reg_Res, Stmt, Pnum); - Link_Stmt (Stmt); - Free_Insn_Regs (Right); - return Stmt; - - when OE_Mod - | OE_Rem - | OE_Mul_Ov - | OE_Div_Ov => - declare - Mode : Mode_Type; - begin - Num := Get_Insn_Num; - Mode := Get_Expr_Mode (Stmt); - Left := Get_Expr_Left (Stmt); - Right := Get_Expr_Right (Stmt); - case Mode is - when Mode_I32 - | Mode_U32 - | Mode_I16 - | Mode_U16 => - Left := Gen_Insn (Left, R_Ax, Num); - Right := Gen_Insn (Right, R_Rm, Num); - Left := Reload (Left, R_Ax, Num); - case Kind is - when OE_Div_Ov - | OE_Rem - | OE_Mod => - -- Be sure EDX is free. - Reg_Res := Alloc_Reg (R_Dx, Stmt, Pnum); - when others => - Reg_Res := R_Nil; - end case; - Right := Reload (Right, R_Rm, Num); - Set_Expr_Right (Stmt, Right); - Set_Expr_Left (Stmt, Left); - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - if Reg_Res /= R_Nil then - Free_R32 (Reg_Res); - end if; - if Kind = OE_Div_Ov or Kind = OE_Mul_Ov then - Reg_Res := R_Ax; - Clobber_R32 (R_Dx); - else - Reg_Res := R_Dx; - Clobber_R32 (R_Ax); - end if; - Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum)); - Link_Stmt (Stmt); - return Reload (Stmt, Reg, Pnum); - when Mode_U64 - | Mode_I64 => - -- FIXME: align stack - Insert_Arg (Gen_Insn (Right, R_Irm, Num)); - Insert_Arg (Gen_Insn (Left, R_Irm, Num)); - return Insert_Intrinsic (Stmt, R_Edx_Eax, Pnum); - when Mode_F32 - | Mode_F64 => - Left := Gen_Insn (Left, R_St0, Num); - Right := Gen_Insn (Right, R_Rm, Num); - Set_Expr_Left (Stmt, Left); - Set_Expr_Right (Stmt, Right); - Free_Insn_Regs (Right); - Free_Insn_Regs (Left); - Set_Expr_Reg (Stmt, Alloc_Reg (R_St0, Stmt, Pnum)); - Link_Stmt (Stmt); - return Stmt; - when others => - Error_Gen_Insn (Stmt, Mode); - end case; - end; - - when OE_Not - | OE_Abs_Ov - | OE_Neg_Ov => - Left := Get_Expr_Operand (Stmt); - case Reg is - when R_Any32 - | Regs_R32 - | R_Any64 - | Regs_R64 - | R_Any8 - | R_St0 => - Reg_Res := Reg; - when R_Any_Cc => - if Kind /= OE_Not then - raise Program_Error; - end if; - Left := Gen_Insn (Left, R_Any_Cc, Pnum); - Set_Expr_Operand (Stmt, Left); - Reg_Res := Inverse_Cc (Get_Expr_Reg (Left)); - Free_Cc; - Set_Expr_Reg (Stmt, Reg_Res); - Alloc_Cc (Stmt, Pnum); - return Stmt; - when R_Irm - | R_Rm - | R_Ir => - Reg_Res := Get_Reg_Any (Get_Expr_Mode (Left)); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - Left := Gen_Insn (Left, Reg_Res, Pnum); - Set_Expr_Operand (Stmt, Left); - Reg_Res := Get_Expr_Reg (Left); - Free_Insn_Regs (Left); - Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum)); - Link_Stmt (Stmt); - return Stmt; - when OE_Conv => - declare - O_Mode : Mode_Type; -- Operand mode - R_Mode : Mode_Type; -- Result mode - begin - Left := Get_Expr_Operand (Stmt); - O_Mode := Get_Expr_Mode (Left); - R_Mode := Get_Expr_Mode (Stmt); - -- Simple case: no conversion. - -- FIXME: should be handled by EXPR and convert to NOP. - if Get_Expr_Mode (Left) = Get_Expr_Mode (Stmt) then - -- A no-op. - return Gen_Insn (Left, Reg, Pnum); - end if; - case R_Mode is - when Mode_B2 => - case O_Mode is - when Mode_U32 - | Mode_I32 => - -- Detect for bound. - null; - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when Mode_U8 => - case O_Mode is - when Mode_U16 - | Mode_U32 - | Mode_I32 => - -- Detect for bound. - null; - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when Mode_U32 => - case O_Mode is - when Mode_I32 => - -- Detect for bound. - null; - when Mode_B2 - | Mode_U8 - | Mode_U16 => - -- Zero extend. - null; - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when Mode_I32 => - case O_Mode is - when Mode_U8 - | Mode_I8 - | Mode_B2 - | Mode_U16 - | Mode_U32 => - -- Zero extend - -- Detect for bound (U32). - null; - when Mode_I64 => - -- Detect for bound (U32) - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Edx_Eax, Num); - Free_Insn_Regs (Left); - Set_Expr_Operand (Stmt, Left); - case Reg is - when R_Ax - | R_Any32 - | R_Rm - | R_Irm - | R_Ir => - Set_Expr_Reg - (Stmt, Alloc_Reg (R_Ax, Stmt, Num)); - when others => - raise Program_Error; - end case; - Insert_Reg (Mode_U32); - Link_Stmt (Stmt); - return Stmt; - when Mode_F64 - | Mode_F32 => - return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum); - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when Mode_I64 => - case O_Mode is - when Mode_I32 => - -- Sign extend. - Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Ax, Num); - Set_Expr_Operand (Stmt, Left); - Free_Insn_Regs (Left); - case Reg is - when R_Edx_Eax - | R_Any64 - | R_Rm - | R_Irm - | R_Ir => - Set_Expr_Reg - (Stmt, Alloc_Reg (R_Edx_Eax, Stmt, Pnum)); - when others => - raise Program_Error; - end case; - Link_Stmt (Stmt); - return Stmt; - when Mode_F64 - | Mode_F32 => - return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum); - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when Mode_F64 => - case O_Mode is - when Mode_I32 - | Mode_I64 => - null; - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - when others => - Error_Gen_Insn (Stmt, O_Mode); - end case; - Left := Gen_Insn (Left, R_Rm, Pnum); - Set_Expr_Operand (Stmt, Left); - case Reg is - when R_Irm - | R_Rm - | R_Ir - | R_Sib - | R_Any32 - | Regs_R32 - | R_Any64 - | R_Any8 - | Regs_R64 - | Regs_Fp => - Free_Insn_Regs (Left); - Set_Expr_Reg - (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); - when others => - Error_Gen_Insn (Stmt, Reg); - end case; - Link_Stmt (Stmt); - return Stmt; - end; - when OE_Arg => - if Reg /= R_None then - raise Program_Error; - end if; - Left := Get_Arg_Link (Stmt); - if Left /= O_Enode_Null then - -- Recurse on next argument, so the first argument is pushed - -- the last one. - Left := Gen_Insn (Left, R_None, Pnum); - end if; - - Left := Get_Expr_Operand (Stmt); - case Get_Expr_Mode (Left) is - when Mode_F32 .. Mode_F64 => - -- fstp instruction. - Reg_Res := R_St0; - when others => - -- Push instruction. - Reg_Res := R_Irm; - end case; - Left := Gen_Insn (Left, Reg_Res, Pnum); - Set_Expr_Operand (Stmt, Left); - Push_Offset := Push_Offset + - Do_Align (Get_Mode_Size (Get_Expr_Mode (Left)), Mode_U32); - Link_Stmt (Stmt); - Free_Insn_Regs (Left); - return Stmt; - when OE_Call => - return Gen_Call (Stmt, Reg, Pnum); - when OE_Case_Expr => - Left := Get_Expr_Operand (Stmt); - Set_Expr_Reg (Stmt, Alloc_Reg (Get_Expr_Reg (Left), Stmt, Pnum)); - return Stmt; - when OE_Get_Stack => - Set_Expr_Reg (Stmt, R_Sp); - return Stmt; - when OE_Get_Frame => - Set_Expr_Reg (Stmt, R_Bp); - return Stmt; - when others => - Ada.Text_IO.Put_Line - ("gen_insn: unhandled enode " & OE_Kind'Image (Kind)); - raise Program_Error; - end case; - end Gen_Insn; - - procedure Assert_Free_Regs (Stmt : O_Enode) is - begin - for I in Regs_R32 loop - if Regs (I).Num /= O_Free then - Error_Reg ("gen_insn_stmt: reg is not free", Stmt, I); - end if; - end loop; - for I in Fp_Stack_Type loop - if Fp_Regs (I).Stmt /= O_Enode_Null then - Error_Reg ("gen_insn_stmt: reg is not free", Stmt, R_St0); - end if; - end loop; - end Assert_Free_Regs; - - procedure Gen_Insn_Stmt (Stmt : O_Enode) - is - Kind : OE_Kind; - - Left : O_Enode; - Right : O_Enode; - P_Reg : O_Reg; - Num : O_Inum; - - Prev_Stack_Offset : Uns32; - begin - Insn_Num := O_Iroot; - Num := Get_Insn_Num; - Prev_Stack_Offset := Stack_Offset; - - Kind := Get_Expr_Kind (Stmt); - case Kind is - when OE_Asgn => - Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Ir, Num); - Right := Gen_Insn (Get_Assign_Target (Stmt), R_Sib, Num); - Left := Reload (Left, R_Ir, Num); - --Right := Reload (Right, R_Sib, Num); - Set_Expr_Operand (Stmt, Left); - Set_Assign_Target (Stmt, Right); - Link_Stmt (Stmt); - Free_Insn_Regs (Left); - Free_Insn_Regs (Right); - when OE_Set_Stack => - Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Rm, Num); - Set_Expr_Operand (Stmt, Left); - Set_Expr_Reg (Stmt, R_Sp); - Link_Stmt (Stmt); - when OE_Jump_F - | OE_Jump_T => - Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Any_Cc, Num); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Stmt); - Free_Cc; - when OE_Beg => - declare - Block_Decl : O_Dnode; - begin - Cur_Block := Stmt; - Block_Decl := Get_Block_Decls (Cur_Block); - Set_Block_Max_Stack (Block_Decl, Stack_Offset); - Expand_Decls (Block_Decl); - end; - Link_Stmt (Stmt); - when OE_End => - Swap_Stack_Offset (Get_Block_Decls (Cur_Block)); - Cur_Block := Get_Block_Parent (Cur_Block); - Link_Stmt (Stmt); - when OE_Jump - | OE_Label => - Link_Stmt (Stmt); - when OE_Leave => - Link_Stmt (Stmt); - when OE_Call => - Link_Stmt (Gen_Call (Stmt, R_None, Num)); - when OE_Ret => - Left := Get_Expr_Operand (Stmt); - P_Reg := Get_Call_Register (Get_Expr_Mode (Stmt)); - Left := Gen_Insn (Left, P_Reg, Num); - Set_Expr_Operand (Stmt, Left); - Link_Stmt (Stmt); - Free_Insn_Regs (Left); - when OE_Case => - Left := Gen_Insn (Get_Expr_Operand (Stmt), - Get_Reg_Any (Get_Expr_Mode (Stmt)), - Num); - Set_Expr_Operand (Stmt, Left); - Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); - Link_Stmt (Stmt); - Free_Insn_Regs (Left); - when OE_Line => - Set_Expr_Reg (Stmt, R_None); - Link_Stmt (Stmt); - when OE_BB => - -- Keep BB. - Link_Stmt (Stmt); - when others => - Ada.Text_IO.Put_Line - ("gen_insn_stmt: unhandled enode " & OE_Kind'Image (Kind)); - raise Program_Error; - end case; - - -- Free any spill stack slots. - case Kind is - when OE_Beg - | OE_End => - null; - when others => - Stack_Offset := Prev_Stack_Offset; - end case; - - -- Check all registers are free. - if Debug.Flag_Debug_Assert then - Assert_Free_Regs (Stmt); - end if; - end Gen_Insn_Stmt; - - procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc) - is - First : O_Enode; - Stmt : O_Enode; - N_Stmt : O_Enode; - begin - if Debug.Flag_Debug_Insn then - declare - Inter : O_Dnode; - begin - Disp_Decl (1, Subprg.D_Decl); - Inter := Get_Subprg_Interfaces (Subprg.D_Decl); - while Inter /= O_Dnode_Null loop - Disp_Decl (2, Inter); - Inter := Get_Interface_Chain (Inter); - end loop; - end; - end if; - - for I in Regs_R32 loop - Regs (I).Used := False; - end loop; - - Stack_Max := 0; - Stack_Offset := 0; - First := Subprg.E_Entry; - Expand_Decls (Subprg.D_Body + 1); - Abi.Last_Link := First; - - -- Generate instructions. - -- Skip OE_Entry. - Stmt := Get_Stmt_Link (First); - loop - N_Stmt := Get_Stmt_Link (Stmt); - Gen_Insn_Stmt (Stmt); - exit when Get_Expr_Kind (Stmt) = OE_Leave; - Stmt := N_Stmt; - end loop; - - -- Keep stack depth for this subprogram. - Subprg.Stack_Max := Stack_Max; - - -- Sanity check: there must be no remaining pushed bytes. - if Push_Offset /= 0 then - raise Program_Error with "gen_subprg_insn: push_offset not 0"; - end if; - end Gen_Subprg_Insns; - -end Ortho_Code.X86.Insns; diff --git a/ortho/mcode/ortho_code-x86-insns.ads b/ortho/mcode/ortho_code-x86-insns.ads deleted file mode 100644 index 9411737a0..000000000 --- a/ortho/mcode/ortho_code-x86-insns.ads +++ /dev/null @@ -1,25 +0,0 @@ --- Mcode back-end for ortho - mcode to X86 instructions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ortho_Code.X86.Insns is - function Reg_Used (Reg : Regs_R32) return Boolean; - - -- Split enodes of SUBPRG into instructions. - procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc); - -end Ortho_Code.X86.Insns; - diff --git a/ortho/mcode/ortho_code-x86.adb b/ortho/mcode/ortho_code-x86.adb deleted file mode 100644 index 175dd7e99..000000000 --- a/ortho/mcode/ortho_code-x86.adb +++ /dev/null @@ -1,109 +0,0 @@ --- Mcode back-end for ortho - X86 common definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package body Ortho_Code.X86 is - function Inverse_Cc (R : O_Reg) return O_Reg is - begin - case R is - when R_Ult => - return R_Uge; - when R_Uge => - return R_Ult; - when R_Eq => - return R_Ne; - when R_Ne => - return R_Eq; - when R_Ule => - return R_Ugt; - when R_Ugt => - return R_Ule; - when R_Slt => - return R_Sge; - when R_Sge => - return R_Slt; - when R_Sle => - return R_Sgt; - when R_Sgt => - return R_Sle; - when others => - raise Program_Error; - end case; - end Inverse_Cc; - - function Get_R64_High (Reg : Regs_R64) return Regs_R32 is - begin - case Reg is - when R_Edx_Eax => - return R_Dx; - when R_Ebx_Ecx => - return R_Bx; - when R_Esi_Edi => - return R_Si; - end case; - end Get_R64_High; - - function Get_R64_Low (Reg : Regs_R64) return Regs_R32 is - begin - case Reg is - when R_Edx_Eax => - return R_Ax; - when R_Ebx_Ecx => - return R_Cx; - when R_Esi_Edi => - return R_Di; - end case; - end Get_R64_Low; - - function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is - begin - case Kind is - when OE_Eq => - return R_Eq; - when OE_Neq => - return R_Ne; - when OE_Lt => - return R_Ult; - when OE_Le => - return R_Ule; - when OE_Gt => - return R_Ugt; - when OE_Ge => - return R_Uge; - end case; - end Ekind_Unsigned_To_Cc; - - function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is - begin - case Kind is - when OE_Eq => - return R_Eq; - when OE_Neq => - return R_Ne; - when OE_Lt => - return R_Slt; - when OE_Le => - return R_Sle; - when OE_Gt => - return R_Sgt; - when OE_Ge => - return R_Sge; - end case; - end Ekind_Signed_To_Cc; - -end Ortho_Code.X86; - - diff --git a/ortho/mcode/ortho_code-x86.ads b/ortho/mcode/ortho_code-x86.ads deleted file mode 100644 index 24be1eb6c..000000000 --- a/ortho/mcode/ortho_code-x86.ads +++ /dev/null @@ -1,160 +0,0 @@ --- Mcode back-end for ortho - X86 common definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Code.Exprs; use Ortho_Code.Exprs; - -package Ortho_Code.X86 is - -- Registers. - R_Nil : constant O_Reg := 0; - - -- Not a value. Used for statements. - R_None : constant O_Reg := 1; - - -- Memory. - R_Mem : constant O_Reg := 2; - - -- Spilled out. - R_Spill : constant O_Reg := 3; - - -- Register or memory. - -- THis can only be requested. - R_Rm : constant O_Reg := 48; - - -- Immediat - R_Imm : constant O_Reg := 49; - - -- Immediat, register or memory. - -- This can be requested. - R_Irm : constant O_Reg := 50; - - -- Immediat or register. - -- This can be requested. - R_Ir : constant O_Reg := 51; - - -- BASE + OFFSET - R_B_Off : constant O_Reg := 52; - - -- BASE+INDEX*SCALE+OFFSET - -- This can be requested. - R_Sib : constant O_Reg := 53; - - -- INDEX*SCALE + OFFSET - -- This can be requested. - R_I_Off : constant O_Reg := 54; - - -- BASE + INDEX*SCALE - R_B_I : constant O_Reg := 55; - - -- INDEX*SCALE - R_I : constant O_Reg := 56; - - subtype Regs_Imm32 is O_Reg range R_Irm .. R_I_Off; - - R_Any8 : constant O_Reg := 6; - R_Any32 : constant O_Reg := 7; - R_Ax : constant O_Reg := 8; - R_Cx : constant O_Reg := 9; - R_Dx : constant O_Reg := 10; - R_Bx : constant O_Reg := 11; - R_Sp : constant O_Reg := 12; - R_Bp : constant O_Reg := 13; - R_Si : constant O_Reg := 14; - R_Di : constant O_Reg := 15; - - subtype Regs_R8 is O_Reg range R_Ax .. R_Bx; - subtype Regs_R32 is O_Reg range R_Ax .. R_Di; - - R_St0 : constant O_Reg := 16; - R_St1 : constant O_Reg := 17; - R_St2 : constant O_Reg := 18; - R_St3 : constant O_Reg := 19; - R_St4 : constant O_Reg := 20; - R_St5 : constant O_Reg := 21; - R_St6 : constant O_Reg := 22; - R_St7 : constant O_Reg := 23; - --R_Any_Fp : constant O_Reg := 24; - - subtype Regs_Fp is O_Reg range R_St0 .. R_St7; - - -- Any condition register. - R_Any_Cc : constant O_Reg := 32; - R_Ov : constant O_Reg := 32; - R_Ult : constant O_Reg := 34; - R_Uge : constant O_Reg := 35; - R_Eq : constant O_Reg := 36; - R_Ne : constant O_Reg := 37; - R_Ule : constant O_Reg := 38; - R_Ugt : constant O_Reg := 39; - R_Slt : constant O_Reg := 44; - R_Sge : constant O_Reg := 45; - R_Sle : constant O_Reg := 46; - R_Sgt : constant O_Reg := 47; - - subtype Regs_Cc is O_Reg range R_Ov .. R_Sgt; - - R_Edx_Eax : constant O_Reg := 64; - R_Ebx_Ecx : constant O_Reg := 65; - R_Esi_Edi : constant O_Reg := 66; - R_Any64 : constant O_Reg := 67; - - subtype Regs_R64 is O_Reg range R_Edx_Eax .. R_Esi_Edi; - - R_Any_Xmm : constant O_Reg := 79; - - R_Xmm0 : constant O_Reg := 80; - R_Xmm1 : constant O_Reg := R_Xmm0 + 1; - R_Xmm2 : constant O_Reg := R_Xmm0 + 2; - R_Xmm3 : constant O_Reg := R_Xmm0 + 3; - R_Xmm4 : constant O_Reg := R_Xmm0 + 4; - R_Xmm5 : constant O_Reg := R_Xmm0 + 5; - R_Xmm6 : constant O_Reg := R_Xmm0 + 6; - R_Xmm7 : constant O_Reg := R_Xmm0 + 7; - R_Xmm8 : constant O_Reg := R_Xmm0 + 8; - R_Xmm9 : constant O_Reg := R_Xmm0 + 9; - R_Xmm10 : constant O_Reg := R_Xmm0 + 10; - R_Xmm11 : constant O_Reg := R_Xmm0 + 11; - R_Xmm12 : constant O_Reg := R_Xmm0 + 12; - R_Xmm13 : constant O_Reg := R_Xmm0 + 13; - R_Xmm14 : constant O_Reg := R_Xmm0 + 14; - R_Xmm15 : constant O_Reg := R_Xmm0 + 15; - - subtype Regs_X86_64_Xmm is O_Reg range R_Xmm0 .. R_Xmm15; - subtype Regs_X86_Xmm is O_Reg range R_Xmm0 .. R_Xmm7; - subtype Regs_Xmm is O_Reg range R_Xmm0 .. R_Xmm15; - - function Get_R64_High (Reg : Regs_R64) return Regs_R32; - function Get_R64_Low (Reg : Regs_R64) return Regs_R32; - - function Inverse_Cc (R : O_Reg) return O_Reg; - - -- Intrinsic subprograms. - Intrinsic_Mul_Ov_U64 : constant Int32 := 1; - Intrinsic_Div_Ov_U64 : constant Int32 := 2; - Intrinsic_Mod_Ov_U64 : constant Int32 := 3; - Intrinsic_Mul_Ov_I64 : constant Int32 := 4; - Intrinsic_Div_Ov_I64 : constant Int32 := 5; - Intrinsic_Mod_Ov_I64 : constant Int32 := 6; - Intrinsic_Rem_Ov_I64 : constant Int32 := 7; - - subtype Intrinsics_X86 is Int32 - range Intrinsic_Mul_Ov_U64 .. Intrinsic_Rem_Ov_I64; - - -- Convert a KIND to a reg. - function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg; - function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg; - -end Ortho_Code.X86; diff --git a/ortho/mcode/ortho_code.ads b/ortho/mcode/ortho_code.ads deleted file mode 100644 index 0657b07e6..000000000 --- a/ortho/mcode/ortho_code.ads +++ /dev/null @@ -1,150 +0,0 @@ --- Mcode back-end for ortho - common definitions. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Conversion; - -package Ortho_Code is - type Int32 is range -(2 ** 31) .. (2 ** 31) - 1; - - type Uns32 is mod 2 ** 32; - - type Uns64 is mod 2 ** 64; - - function Shift_Right (L : Uns64; R : Natural) return Uns64; - function Shift_Right (L : Uns32; R : Natural) return Uns32; - pragma Import (Intrinsic, Shift_Right); - - function Shift_Right_Arithmetic (L : Uns32; R : Natural) return Uns32; - pragma Import (Intrinsic, Shift_Right_Arithmetic); - - function Shift_Left (L : Uns32; R : Natural) return Uns32; - pragma Import (Intrinsic, Shift_Left); - - type O_Tnode is new Int32; - for O_Tnode'Size use 32; - O_Tnode_Null : constant O_Tnode := 0; - O_Tnode_First : constant O_Tnode := 2; - - -- A generic pointer. - -- This is used by static chains. - O_Tnode_Ptr : constant O_Tnode := 2; - - type O_Cnode is new Int32; - for O_Cnode'Size use 32; - O_Cnode_Null : constant O_Cnode := 0; - - type O_Dnode is new Int32; - for O_Dnode'Size use 32; - O_Dnode_Null : constant O_Dnode := 0; - O_Dnode_First : constant O_Dnode := 2; - - type O_Enode is new Int32; - for O_Enode'Size use 32; - O_Enode_Null : constant O_Enode := 0; - O_Enode_Err : constant O_Enode := 1; - - type O_Fnode is new Int32; - for O_Fnode'Size use 32; - O_Fnode_Null : constant O_Fnode := 0; - - type O_Lnode is new Int32; - for O_Lnode'Size use 32; - O_Lnode_Null : constant O_Lnode := 0; - - type O_Ident is new Int32; - O_Ident_Nul : constant O_Ident := 0; - - function To_Int32 is new Ada.Unchecked_Conversion - (Source => Uns32, Target => Int32); - - function To_Uns32 is new Ada.Unchecked_Conversion - (Source => Int32, Target => Uns32); - - - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - - -- Depth of a declaration. - -- 0 for top-level, - -- 1 for declared in a top-level subprogram - type O_Depth is range 0 .. (2 ** 16) - 1; - O_Toplevel : constant O_Depth := 0; - - -- BE representation of a register. - type O_Reg is mod 256; - R_Nil : constant O_Reg := 0; - - type Mode_Type is (Mode_U8, Mode_U16, Mode_U32, Mode_U64, - Mode_I8, Mode_I16, Mode_I32, Mode_I64, - Mode_X1, Mode_Nil, Mode_F32, Mode_F64, - Mode_B2, Mode_Blk, Mode_P32, Mode_P64); - - subtype Mode_Uns is Mode_Type range Mode_U8 .. Mode_U64; - subtype Mode_Int is Mode_Type range Mode_I8 .. Mode_I64; - subtype Mode_Fp is Mode_Type range Mode_F32 .. Mode_F64; - -- Mode_Ptr : constant Mode_Type := Mode_P32; - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - Syntax_Error : exception; -end Ortho_Code; diff --git a/ortho/mcode/ortho_code_main.adb b/ortho/mcode/ortho_code_main.adb deleted file mode 100644 index a0e6dc6c6..000000000 --- a/ortho/mcode/ortho_code_main.adb +++ /dev/null @@ -1,198 +0,0 @@ --- Mcode back-end for ortho - Main subprogram. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Conversion; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Unchecked_Deallocation; -with Ada.Text_IO; use Ada.Text_IO; -with Binary_File; use Binary_File; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ortho_Code.Debug; -with Ortho_Mcode; use Ortho_Mcode; -with Ortho_Front; use Ortho_Front; -with Ortho_Code.Flags; use Ortho_Code.Flags; -with Binary_File.Elf; -with Binary_File.Coff; -with Binary_File.Memory; - -procedure Ortho_Code_Main -is - Output : String_Acc := null; - type Format_Type is (Format_Coff, Format_Elf); - Format : constant Format_Type := Format_Elf; - Fd : File_Descriptor; - - First_File : Natural; - Opt : String_Acc; - Opt_Arg : String_Acc; - Filename : String_Acc; - Exec_Func : String_Acc; - Res : Natural; - I : Natural; - Argc : Natural; - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); -begin - First_File := Natural'Last; - Exec_Func := null; - - Ortho_Front.Init; - - Argc := Argument_Count; - I := 1; - while I <= Argc loop - declare - Arg : constant String := Argument (I); - begin - if Arg (1) = '-' then - if Arg'Length > 5 and then Arg (1 .. 5) = "--be-" then - Ortho_Code.Debug.Set_Be_Flag (Arg); - I := I + 1; - elsif Arg = "-o" then - if I = Argc then - Put_Line (Standard_Error, "error: missing filename to '-o'"); - return; - end if; - Output := new String'(Argument (I + 1)); - I := I + 2; - elsif Arg = "-quiet" then - -- Skip silently. - I := I + 1; - elsif Arg = "--exec" then - if I = Argc then - Put_Line (Standard_Error, - "error: missing function name to '--exec'"); - return; - end if; - Exec_Func := new String'(Argument (I + 1)); - I := I + 2; - elsif Arg = "-g" then - Flag_Debug := Debug_Dwarf; - I := I + 1; - elsif Arg = "-p" or Arg = "-pg" then - Flag_Profile := True; - I := I + 1; - else - -- This is really an argument. - Opt := new String'(Arg); - if I < Argument_Count then - Opt_Arg := new String'(Argument (I + 1)); - else - Opt_Arg := null; - end if; - Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); - case Res is - when 0 => - Put_Line (Standard_Error, "unknown option '" & Arg & "'"); - return; - when 1 => - I := I + 1; - when 2 => - I := I + 2; - when others => - raise Program_Error; - end case; - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Opt_Arg); - end if; - else - First_File := I; - exit; - end if; - end; - end loop; - - Ortho_Mcode.Init; - - Set_Exit_Status (Failure); - - if First_File > Argument_Count then - begin - if not Parse (null) then - return; - end if; - exception - when others => - return; - end; - else - for I in First_File .. Argument_Count loop - Filename := new String'(Argument (First_File)); - begin - if not Parse (Filename) then - return; - end if; - exception - when others => - return; - end; - end loop; - end if; - - Ortho_Mcode.Finish; - - if Ortho_Code.Debug.Flag_Debug_Hli then - Set_Exit_Status (Success); - return; - end if; - - if Output /= null then - Fd := Create_File (Output.all, Binary); - if Fd /= Invalid_FD then - case Format is - when Format_Elf => - Binary_File.Elf.Write_Elf (Fd); - when Format_Coff => - Binary_File.Coff.Write_Coff (Fd); - end case; - Close (Fd); - end if; - elsif Exec_Func /= null then - declare - Sym : Symbol; - - type Func_Acc is access function return Integer; - function Conv is new Ada.Unchecked_Conversion - (Source => Pc_Type, Target => Func_Acc); - F : Func_Acc; - V : Integer; - Err : Boolean; - begin - Binary_File.Memory.Write_Memory_Init; - Binary_File.Memory.Write_Memory_Relocate (Err); - if Err then - return; - end if; - Sym := Binary_File.Get_Symbol (Exec_Func.all); - if Sym = Null_Symbol then - Put_Line (Standard_Error, "no '" & Exec_Func.all & "' symbol"); - else - F := Conv (Get_Symbol_Vaddr (Sym)); - V := F.all; - Put_Line ("Result is " & Integer'Image (V)); - end if; - end; - end if; - - Set_Exit_Status (Success); -exception - when others => - Set_Exit_Status (2); - raise; -end Ortho_Code_Main; - - diff --git a/ortho/mcode/ortho_ident.adb b/ortho/mcode/ortho_ident.adb deleted file mode 100644 index 0893b75dd..000000000 --- a/ortho/mcode/ortho_ident.adb +++ /dev/null @@ -1,117 +0,0 @@ --- Mcode back-end for ortho. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with GNAT.Table; - -package body Ortho_Ident is - package Ids is new GNAT.Table - (Table_Component_Type => Natural, - Table_Index_Type => O_Ident, - Table_Low_Bound => 2, - Table_Initial => 128, - Table_Increment => 100); - - package Strs is new GNAT.Table - (Table_Component_Type => Character, - Table_Index_Type => Natural, - Table_Low_Bound => 2, - Table_Initial => 128, - Table_Increment => 100); - - function Get_Identifier (Str : String) return O_Ident - is - Start : Natural; - begin - Start := Strs.Allocate (Str'Length + 1); - for I in Str'Range loop - Strs.Table (Start + I - Str'First) := Str (I); - end loop; - Strs.Table (Start + Str'Length) := ASCII.Nul; - Ids.Append (Start); - return Ids.Last; - end Get_Identifier; - - function Is_Equal (L, R : O_Ident) return Boolean - is - begin - return L = R; - end Is_Equal; - - function Get_String_Length (Id : O_Ident) return Natural - is - Start : Natural; - begin - Start := Ids.Table (Id); - if Id = Ids.Last then - return Strs.Last - Start + 1 - 1; - else - return Ids.Table (Id + 1) - 1 - Start; - end if; - end Get_String_Length; - - function Get_String (Id : O_Ident) return String - is - Res : String (1 .. Get_String_Length (Id)); - Start : constant Natural := Ids.Table (Id); - begin - for I in Res'Range loop - Res (I) := Strs.Table (Start + I - Res'First); - end loop; - return Res; - end Get_String; - - function Get_Cstring (Id : O_Ident) return System.Address is - begin - return Strs.Table (Ids.Table (Id))'Address; - end Get_Cstring; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean - is - Start : constant Natural := Ids.Table (Id); - Len : constant Natural := Get_String_Length (Id); - begin - if Len /= Str'Length then - return False; - end if; - for I in Str'Range loop - if Str (I) /= Strs.Table (Start + I - Str'First) then - return False; - end if; - end loop; - return True; - end Is_Equal; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = O_Ident_Nul; - end Is_Nul; - - procedure Disp_Stats - is - use Ada.Text_IO; - begin - Put_Line ("Number of Ident: " & O_Ident'Image (Ids.Last)); - Put_Line ("Number of Ident-Strs: " & Natural'Image (Strs.Last)); - end Disp_Stats; - - procedure Finish is - begin - Ids.Free; - Strs.Free; - end Finish; -end Ortho_Ident; diff --git a/ortho/mcode/ortho_ident.ads b/ortho/mcode/ortho_ident.ads deleted file mode 100644 index cdc42fcad..000000000 --- a/ortho/mcode/ortho_ident.ads +++ /dev/null @@ -1,38 +0,0 @@ --- Mcode back-end for ortho. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Ortho_Code; use Ortho_Code; - -package Ortho_Ident is - subtype O_Ident is Ortho_Code.O_Ident; - - function Get_Identifier (Str : String) return O_Ident; - function Is_Equal (L, R : O_Ident) return Boolean; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; - function Get_String (Id : O_Ident) return String; - function Get_String_Length (Id : O_Ident) return Natural; - - -- Note: the address is valid until the next call to get_identifier. - function Get_Cstring (Id : O_Ident) return System.Address; - - O_Ident_Nul : constant O_Ident := Ortho_Code.O_Ident_Nul; - - procedure Disp_Stats; - procedure Finish; -end Ortho_Ident; diff --git a/ortho/mcode/ortho_jit.adb b/ortho/mcode/ortho_jit.adb deleted file mode 100644 index 7aa9724f2..000000000 --- a/ortho/mcode/ortho_jit.adb +++ /dev/null @@ -1,125 +0,0 @@ --- Ortho JIT implementation for mcode. --- Copyright (C) 2009 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ada.Text_IO; - -with Binary_File; use Binary_File; -with Binary_File.Memory; -with Ortho_Mcode; use Ortho_Mcode; -with Ortho_Mcode.Jit; -with Ortho_Code.Flags; use Ortho_Code.Flags; -with Ortho_Code.Debug; -with Ortho_Code.Abi; -with Binary_File.Elf; - -package body Ortho_Jit is - Snap_Filename : GNAT.OS_Lib.String_Access := null; - - -- Initialize the whole engine. - procedure Init is - begin - Ortho_Mcode.Init; - Binary_File.Memory.Write_Memory_Init; - end Init; - - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address) - renames Ortho_Mcode.Jit.Set_Address; - - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address - renames Ortho_Mcode.Jit.Get_Address; - - -- Do link. - procedure Link (Status : out Boolean) is - begin - if Ortho_Code.Debug.Flag_Debug_Hli then - -- Can't generate code in HLI. - Status := True; - return; - end if; - - Ortho_Mcode.Finish; - - Ortho_Code.Abi.Link_Intrinsics; - - Binary_File.Memory.Write_Memory_Relocate (Status); - if Status then - return; - end if; - - if Snap_Filename /= null then - declare - use Ada.Text_IO; - Fd : File_Descriptor; - begin - Fd := Create_File (Snap_Filename.all, Binary); - if Fd = Invalid_FD then - Put_Line (Standard_Error, - "can't open '" & Snap_Filename.all & "'"); - Status := False; - return; - else - Binary_File.Elf.Write_Elf (Fd); - Close (Fd); - end if; - end; - end if; - end Link; - - procedure Finish is - begin - -- Free all the memory. - Ortho_Mcode.Free_All; - - Binary_File.Finish; - end Finish; - - function Decode_Option (Option : String) return Boolean - is - Opt : constant String (1 .. Option'Length) := Option; - begin - if Opt = "-g" then - Flag_Debug := Debug_Dwarf; - return True; - elsif Opt'Length > 5 and then Opt (1 .. 5) = "--be-" then - Ortho_Code.Debug.Set_Be_Flag (Opt); - return True; - elsif Opt'Length > 7 and then Opt (1 .. 7) = "--snap=" then - Snap_Filename := new String'(Opt (8 .. Opt'Last)); - return True; - else - return False; - end if; - end Decode_Option; - - procedure Disp_Help is - use Ada.Text_IO; - begin - Put_Line (" -g Generate debugging informations"); - Put_Line (" --debug-be=X Set X internal debugging flags"); - Put_Line (" --snap=FILE Write memory snapshot to FILE"); - end Disp_Help; - - function Get_Jit_Name return String is - begin - return "mcode"; - end Get_Jit_Name; - -end Ortho_Jit; diff --git a/ortho/mcode/ortho_mcode-jit.adb b/ortho/mcode/ortho_mcode-jit.adb deleted file mode 100644 index 7e845cc6e..000000000 --- a/ortho/mcode/ortho_mcode-jit.adb +++ /dev/null @@ -1,28 +0,0 @@ -with Ada.Unchecked_Conversion; - -with Ortho_Code.Binary; -with Binary_File; use Binary_File; -with Binary_File.Memory; - -package body Ortho_Mcode.Jit is - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address) - is - use Ortho_Code.Binary; - begin - Binary_File.Memory.Set_Symbol_Address - (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)), Addr); - end Set_Address; - - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address - is - use Ortho_Code.Binary; - - function Conv is new Ada.Unchecked_Conversion - (Source => Pc_Type, Target => Address); - begin - return Conv (Get_Symbol_Vaddr - (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)))); - end Get_Address; -end Ortho_Mcode.Jit; diff --git a/ortho/mcode/ortho_mcode-jit.ads b/ortho/mcode/ortho_mcode-jit.ads deleted file mode 100644 index c689a1e12..000000000 --- a/ortho/mcode/ortho_mcode-jit.ads +++ /dev/null @@ -1,9 +0,0 @@ -with System; use System; - -package Ortho_Mcode.Jit is - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address); - - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address; -end Ortho_Mcode.Jit; diff --git a/ortho/mcode/ortho_mcode.adb b/ortho/mcode/ortho_mcode.adb deleted file mode 100644 index 55e890bf3..000000000 --- a/ortho/mcode/ortho_mcode.adb +++ /dev/null @@ -1,738 +0,0 @@ --- Mcode back-end for ortho. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with Ortho_Code.Debug; -with Ortho_Ident; -with Ortho_Code.Abi; --- with Binary_File; - -package body Ortho_Mcode is - procedure New_Debug_Comment_Stmt (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Stmt; - - procedure Start_Const_Value (Const : in out O_Dnode) - is - pragma Unreferenced (Const); - begin - null; - end Start_Const_Value; - - procedure Start_Record_Type (Elements : out O_Element_List) is - begin - Ortho_Code.Types.Start_Record_Type - (Ortho_Code.Types.O_Element_List (Elements)); - end Start_Record_Type; - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) is - begin - Ortho_Code.Types.New_Record_Field - (Ortho_Code.Types.O_Element_List (Elements), - Ortho_Code.O_Fnode (El), Ident, Ortho_Code.O_Tnode (Etype)); - end New_Record_Field; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Ortho_Code.Types.Finish_Record_Type - (Ortho_Code.Types.O_Element_List (Elements), - Ortho_Code.O_Tnode (Res)); - end Finish_Record_Type; - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is - begin - Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res)); - end New_Uncomplete_Record_Type; - - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) is - begin - Ortho_Code.Types.Start_Uncomplete_Record_Type - (Ortho_Code.O_Tnode (Res), - Ortho_Code.Types.O_Element_List (Elements)); - end Start_Uncomplete_Record_Type; - - procedure Start_Union_Type (Elements : out O_Element_List) is - begin - Ortho_Code.Types.Start_Union_Type - (Ortho_Code.Types.O_Element_List (Elements)); - end Start_Union_Type; - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) is - begin - Ortho_Code.Types.New_Union_Field - (Ortho_Code.Types.O_Element_List (Elements), - Ortho_Code.O_Fnode (El), - Ident, - Ortho_Code.O_Tnode (Etype)); - end New_Union_Field; - - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Ortho_Code.Types.Finish_Union_Type - (Ortho_Code.Types.O_Element_List (Elements), - Ortho_Code.O_Tnode (Res)); - end Finish_Union_Type; - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode is - begin - return O_Tnode - (Ortho_Code.Types.New_Access_Type (Ortho_Code.O_Tnode (Dtype))); - end New_Access_Type; - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is - begin - Ortho_Code.Types.Finish_Access_Type (Ortho_Code.O_Tnode (Atype), - Ortho_Code.O_Tnode (Dtype)); - end Finish_Access_Type; - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) - is - pragma Warnings (Off, Const); - begin - New_Const_Value (Ortho_Code.O_Dnode (Const), Ortho_Code.O_Cnode (Val)); - end Finish_Const_Value; - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode is - begin - return O_Tnode - (Ortho_Code.Types.New_Array_Type (Ortho_Code.O_Tnode (El_Type), - Ortho_Code.O_Tnode (Index_Type))); - end New_Array_Type; - - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode - is - Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length); - L_Type : Ortho_Code.O_Tnode; - begin - L_Type := Get_Const_Type (Len); - if Get_Type_Kind (L_Type) /= OT_Unsigned then - raise Syntax_Error; - end if; - return O_Tnode (New_Constrained_Array_Type - (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len))); - end New_Constrained_Array_Type; - - function New_Unsigned_Type (Size : Natural) return O_Tnode is - begin - return O_Tnode (Ortho_Code.Types.New_Unsigned_Type (Size)); - end New_Unsigned_Type; - - function New_Signed_Type (Size : Natural) return O_Tnode is - begin - return O_Tnode (Ortho_Code.Types.New_Signed_Type (Size)); - end New_Signed_Type; - - function New_Float_Type return O_Tnode is - begin - return O_Tnode (Ortho_Code.Types.New_Float_Type); - end New_Float_Type; - - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode) is - begin - Ortho_Code.Types.New_Boolean_Type (Ortho_Code.O_Tnode (Res), - False_Id, - Ortho_Code.O_Cnode (False_E), - True_Id, - Ortho_Code.O_Cnode (True_E)); - end New_Boolean_Type; - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is - begin - Ortho_Code.Types.Start_Enum_Type (Ortho_Code.Types.O_Enum_List (List), - Size); - end Start_Enum_Type; - - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode) is - begin - Ortho_Code.Types.New_Enum_Literal (Ortho_Code.Types.O_Enum_List (List), - Ident, Ortho_Code.O_Cnode (Res)); - end New_Enum_Literal; - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Ortho_Code.Types.Finish_Enum_Type (Ortho_Code.Types.O_Enum_List (List), - Ortho_Code.O_Tnode (Res)); - end Finish_Enum_Type; - - ------------------- - -- Expressions -- - ------------------- - - To_Op : constant array (ON_Op_Kind) of Ortho_Code.ON_Op_Kind := - ( - ON_Nil => ON_Nil, - - -- Dyadic operations. - ON_Add_Ov => ON_Add_Ov, - ON_Sub_Ov => ON_Sub_Ov, - ON_Mul_Ov => ON_Mul_Ov, - ON_Div_Ov => ON_Div_Ov, - ON_Rem_Ov => ON_Rem_Ov, - ON_Mod_Ov => ON_Mod_Ov, - - -- Binary operations. - ON_And => ON_And, - ON_Or => ON_Or, - ON_Xor => ON_Xor, - - -- Monadic operations. - ON_Not => ON_Not, - ON_Neg_Ov => ON_Neg_Ov, - ON_Abs_Ov => ON_Abs_Ov, - - -- Comparaisons - ON_Eq => ON_Eq, - ON_Neq => ON_Neq, - ON_Le => ON_Le, - ON_Lt => ON_Lt, - ON_Ge => ON_Ge, - ON_Gt => ON_Gt - ); - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Signed_Literal (Ortho_Code.O_Tnode (Ltype), - Value)); - end New_Signed_Literal; - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Unsigned_Literal (Ortho_Code.O_Tnode (Ltype), - Value)); - end New_Unsigned_Literal; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Float_Literal (Ortho_Code.O_Tnode (Ltype), - Value)); - end New_Float_Literal; - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Null_Access (Ortho_Code.O_Tnode (Ltype))); - end New_Null_Access; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode) is - begin - Ortho_Code.Consts.Start_Record_Aggr - (Ortho_Code.Consts.O_Record_Aggr_List (List), - Ortho_Code.O_Tnode (Atype)); - end Start_Record_Aggr; - - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode) is - begin - Ortho_Code.Consts.New_Record_Aggr_El - (Ortho_Code.Consts.O_Record_Aggr_List (List), - Ortho_Code.O_Cnode (Value)); - end New_Record_Aggr_El; - - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode) is - begin - Ortho_Code.Consts.Finish_Record_Aggr - (Ortho_Code.Consts.O_Record_Aggr_List (List), - Ortho_Code.O_Cnode (Res)); - end Finish_Record_Aggr; - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - is - begin - Ortho_Code.Consts.Start_Array_Aggr - (Ortho_Code.Consts.O_Array_Aggr_List (List), - Ortho_Code.O_Tnode (Atype)); - end Start_Array_Aggr; - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) is - begin - Ortho_Code.Consts.New_Array_Aggr_El - (Ortho_Code.Consts.O_Array_Aggr_List (List), - Ortho_Code.O_Cnode (Value)); - end New_Array_Aggr_El; - - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode) is - begin - Ortho_Code.Consts.Finish_Array_Aggr - (Ortho_Code.Consts.O_Array_Aggr_List (List), - Ortho_Code.O_Cnode (Res)); - end Finish_Array_Aggr; - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Union_Aggr (Ortho_Code.O_Tnode (Atype), - Ortho_Code.O_Fnode (Field), - Ortho_Code.O_Cnode (Value))); - end New_Union_Aggr; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Sizeof (Ortho_Code.O_Tnode (Atype), - Ortho_Code.O_Tnode (Rtype))); - end New_Sizeof; - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Alignof (Ortho_Code.O_Tnode (Atype), - Ortho_Code.O_Tnode (Rtype))); - end New_Alignof; - - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Offsetof (Ortho_Code.O_Tnode (Atype), - Ortho_Code.O_Fnode (Field), - Ortho_Code.O_Tnode (Rtype))); - end New_Offsetof; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Subprogram_Address - (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype))); - end New_Subprogram_Address; - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Global_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); - end New_Global_Address; - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode - (Ortho_Code.Consts.New_Global_Unchecked_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); - end New_Global_Unchecked_Address; - - function New_Lit (Lit : O_Cnode) return O_Enode is - begin - return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit))); - end New_Lit; - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Dyadic_Op (To_Op (Kind), - Ortho_Code.O_Enode (Left), - Ortho_Code.O_Enode (Right))); - end New_Dyadic_Op; - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Monadic_Op (To_Op (Kind), - Ortho_Code.O_Enode (Operand))); - end New_Monadic_Op; - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Compare_Op (To_Op (Kind), - Ortho_Code.O_Enode (Left), - Ortho_Code.O_Enode (Right), - Ortho_Code.O_Tnode (Ntype))); - end New_Compare_Op; - - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode is - begin - return O_Lnode - (Ortho_Code.Exprs.New_Indexed_Element (Ortho_Code.O_Lnode (Arr), - Ortho_Code.O_Enode (Index))); - end New_Indexed_Element; - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode is - begin - return O_Lnode - (Ortho_Code.Exprs.New_Slice (Ortho_Code.O_Lnode (Arr), - Ortho_Code.O_Tnode (Res_Type), - Ortho_Code.O_Enode (Index))); - end New_Slice; - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode is - begin - return O_Lnode - (Ortho_Code.Exprs.New_Selected_Element (Ortho_Code.O_Lnode (Rec), - Ortho_Code.O_Fnode (El))); - end New_Selected_Element; - - function New_Access_Element (Acc : O_Enode) return O_Lnode is - begin - return O_Lnode - (Ortho_Code.Exprs.New_Access_Element (Ortho_Code.O_Enode (Acc))); - end New_Access_Element; - - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Convert_Ov (Ortho_Code.O_Enode (Val), - Ortho_Code.O_Tnode (Rtype))); - end New_Convert_Ov; - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Address (Ortho_Code.O_Lnode (Lvalue), - Ortho_Code.O_Tnode (Atype))); - end New_Address; - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Unchecked_Address (Ortho_Code.O_Lnode (Lvalue), - Ortho_Code.O_Tnode (Atype))); - end New_Unchecked_Address; - - function New_Value (Lvalue : O_Lnode) return O_Enode is - begin - return O_Enode - (Ortho_Code.Exprs.New_Value (Ortho_Code.O_Lnode (Lvalue))); - end New_Value; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return New_Value (New_Obj (Obj)); - end New_Obj_Value; - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is - begin - return O_Enode (Ortho_Code.Exprs.New_Alloca (Ortho_Code.O_Tnode (Rtype), - Ortho_Code.O_Enode (Size))); - end New_Alloca; - - --------------------- - -- Declarations. -- - --------------------- - - procedure New_Debug_Filename_Decl (Filename : String) - renames Ortho_Code.Abi.New_Debug_Filename_Decl; - - procedure New_Debug_Line_Decl (Line : Natural) - is - pragma Unreferenced (Line); - begin - null; - end New_Debug_Line_Decl; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is - begin - Ortho_Code.Decls.New_Type_Decl (Ident, Ortho_Code.O_Tnode (Atype)); - end New_Type_Decl; - - To_Storage : constant array (O_Storage) of Ortho_Code.O_Storage := - (O_Storage_External => O_Storage_External, - O_Storage_Public => O_Storage_Public, - O_Storage_Private => O_Storage_Private, - O_Storage_Local => O_Storage_Local); - - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) is - begin - Ortho_Code.Decls.New_Const_Decl - (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), - Ortho_Code.O_Tnode (Atype)); - end New_Const_Decl; - - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) is - begin - Ortho_Code.Decls.New_Var_Decl - (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), - Ortho_Code.O_Tnode (Atype)); - end New_Var_Decl; - - function New_Obj (Obj : O_Dnode) return O_Lnode is - begin - return O_Lnode (Ortho_Code.Exprs.New_Obj (Ortho_Code.O_Dnode (Obj))); - end New_Obj; - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) is - begin - Ortho_Code.Decls.Start_Function_Decl - (Ortho_Code.Decls.O_Inter_List (Interfaces), - Ident, To_Storage (Storage), Ortho_Code.O_Tnode (Rtype)); - end Start_Function_Decl; - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage) is - begin - Ortho_Code.Decls.Start_Procedure_Decl - (Ortho_Code.Decls.O_Inter_List (Interfaces), - Ident, To_Storage (Storage)); - end Start_Procedure_Decl; - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) is - begin - Ortho_Code.Decls.New_Interface_Decl - (Ortho_Code.Decls.O_Inter_List (Interfaces), - Ortho_Code.O_Dnode (Res), - Ident, - Ortho_Code.O_Tnode (Atype)); - end New_Interface_Decl; - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode) is - begin - Ortho_Code.Decls.Finish_Subprogram_Decl - (Ortho_Code.Decls.O_Inter_List (Interfaces), Ortho_Code.O_Dnode (Res)); - end Finish_Subprogram_Decl; - - procedure Start_Subprogram_Body (Func : O_Dnode) is - begin - Ortho_Code.Exprs.Start_Subprogram_Body (Ortho_Code.O_Dnode (Func)); - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body - renames Ortho_Code.Exprs.Finish_Subprogram_Body; - - ------------------- - -- Statements. -- - ------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) - renames Ortho_Code.Exprs.New_Debug_Line_Stmt; - - procedure New_Debug_Comment_Decl (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Decl; - - procedure Start_Declare_Stmt renames - Ortho_Code.Exprs.Start_Declare_Stmt; - procedure Finish_Declare_Stmt renames - Ortho_Code.Exprs.Finish_Declare_Stmt; - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is - begin - Ortho_Code.Exprs.Start_Association - (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Dnode (Subprg)); - end Start_Association; - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is - begin - Ortho_Code.Exprs.New_Association - (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Enode (Val)); - end New_Association; - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is - begin - return O_Enode (Ortho_Code.Exprs.New_Function_Call - (Ortho_Code.Exprs.O_Assoc_List (Assocs))); - end New_Function_Call; - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is - begin - Ortho_Code.Exprs.New_Procedure_Call - (Ortho_Code.Exprs.O_Assoc_List (Assocs)); - end New_Procedure_Call; - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is - begin - Ortho_Code.Exprs.New_Assign_Stmt (Ortho_Code.O_Lnode (Target), - Ortho_Code.O_Enode (Value)); - end New_Assign_Stmt; - - procedure New_Return_Stmt (Value : O_Enode) is - begin - Ortho_Code.Exprs.New_Return_Stmt (Ortho_Code.O_Enode (Value)); - end New_Return_Stmt; - - procedure New_Return_Stmt - renames Ortho_Code.Exprs.New_Return_Stmt; - - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is - begin - Ortho_Code.Exprs.Start_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block), - Ortho_Code.O_Enode (Cond)); - end Start_If_Stmt; - - procedure New_Else_Stmt (Block : in out O_If_Block) is - begin - Ortho_Code.Exprs.New_Else_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); - end New_Else_Stmt; - - procedure Finish_If_Stmt (Block : in out O_If_Block) is - begin - Ortho_Code.Exprs.Finish_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); - end Finish_If_Stmt; - - procedure Start_Loop_Stmt (Label : out O_Snode) is - begin - Ortho_Code.Exprs.Start_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); - end Start_Loop_Stmt; - - procedure Finish_Loop_Stmt (Label : in out O_Snode) is - begin - Ortho_Code.Exprs.Finish_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); - end Finish_Loop_Stmt; - - procedure New_Exit_Stmt (L : O_Snode) is - begin - Ortho_Code.Exprs.New_Exit_Stmt (Ortho_Code.Exprs.O_Snode (L)); - end New_Exit_Stmt; - - procedure New_Next_Stmt (L : O_Snode) is - begin - Ortho_Code.Exprs.New_Next_Stmt (Ortho_Code.Exprs.O_Snode (L)); - end New_Next_Stmt; - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is - begin - Ortho_Code.Exprs.Start_Case_Stmt - (Ortho_Code.Exprs.O_Case_Block (Block), Ortho_Code.O_Enode (Value)); - end Start_Case_Stmt; - - procedure Start_Choice (Block : in out O_Case_Block) is - begin - Ortho_Code.Exprs.Start_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); - end Start_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is - begin - Ortho_Code.Exprs.New_Expr_Choice (Ortho_Code.Exprs.O_Case_Block (Block), - Ortho_Code.O_Cnode (Expr)); - end New_Expr_Choice; - - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode) is - begin - Ortho_Code.Exprs.New_Range_Choice - (Ortho_Code.Exprs.O_Case_Block (Block), - Ortho_Code.O_Cnode (Low), Ortho_Code.O_Cnode (High)); - end New_Range_Choice; - - procedure New_Default_Choice (Block : in out O_Case_Block) is - begin - Ortho_Code.Exprs.New_Default_Choice - (Ortho_Code.Exprs.O_Case_Block (Block)); - end New_Default_Choice; - - procedure Finish_Choice (Block : in out O_Case_Block) is - begin - Ortho_Code.Exprs.Finish_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); - end Finish_Choice; - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) is - begin - Ortho_Code.Exprs.Finish_Case_Stmt - (Ortho_Code.Exprs.O_Case_Block (Block)); - end Finish_Case_Stmt; - - procedure Init is - begin - -- Create an anonymous pointer type. - if New_Access_Type (O_Tnode_Null) /= O_Tnode (O_Tnode_Ptr) then - raise Program_Error; - end if; - -- Do not finish the access, since this creates an infinite recursion - -- in gdb (at least for GDB 6.3). - --Finish_Access_Type (O_Tnode_Ptr, O_Tnode_Ptr); - Ortho_Code.Abi.Init; - end Init; - - procedure Finish is - begin - if False then - Ortho_Code.Decls.Disp_All_Decls; - --Ortho_Code.Exprs.Disp_All_Enode; - end if; - Ortho_Code.Abi.Finish; - if Debug.Flag_Debug_Stat then - Ada.Text_IO.Put_Line ("Statistics:"); - Ortho_Code.Exprs.Disp_Stats; - Ortho_Code.Decls.Disp_Stats; - Ortho_Code.Types.Disp_Stats; - Ortho_Code.Consts.Disp_Stats; - Ortho_Ident.Disp_Stats; - -- Binary_File.Disp_Stats; - end if; - end Finish; - - procedure Free_All is - begin - Ortho_Code.Types.Finish; - Ortho_Code.Exprs.Finish; - Ortho_Code.Consts.Finish; - Ortho_Code.Decls.Finish; - Ortho_Ident.Finish; - end Free_All; -end Ortho_Mcode; diff --git a/ortho/mcode/ortho_mcode.ads b/ortho/mcode/ortho_mcode.ads deleted file mode 100644 index 45e803690..000000000 --- a/ortho/mcode/ortho_mcode.ads +++ /dev/null @@ -1,583 +0,0 @@ --- DO NOT MODIFY - this file was generated from: --- ortho_nodes.common.ads and ortho_mcode.private.ads --- --- Mcode back-end for ortho. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with Ortho_Code; use Ortho_Code; -with Ortho_Code.Types; use Ortho_Code.Types; -with Ortho_Code.Consts; use Ortho_Code.Consts; -with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Exprs; use Ortho_Code.Exprs; - --- Interface to create nodes. -package Ortho_Mcode is - -- Initialize nodes. - procedure Init; - procedure Finish; - - procedure Free_All; - --- Start of common part - - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - type O_Dnode is private; - type O_Fnode is private; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- Type definitions -- - ------------------------ - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - 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; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record ATYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - ------------------- - -- Expressions -- - ------------------- - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (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. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - --- End of common part -private - -- MCode supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - type O_Tnode is new Ortho_Code.O_Tnode; - type O_Cnode is new Ortho_Code.O_Cnode; - type O_Dnode is new Ortho_Code.O_Dnode; - type O_Enode is new Ortho_Code.O_Enode; - type O_Fnode is new Ortho_Code.O_Fnode; - type O_Lnode is new Ortho_Code.O_Lnode; - type O_Snode is new Ortho_Code.Exprs.O_Snode; - - O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); - O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); - O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); - O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); - O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null); - O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null); - O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null); - - type O_Element_List is new Ortho_Code.Types.O_Element_List; - type O_Enum_List is new Ortho_Code.Types.O_Enum_List; - type O_Inter_List is new Ortho_Code.Decls.O_Inter_List; - type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List; - type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List; - type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List; - type O_If_Block is new Ortho_Code.Exprs.O_If_Block; - type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block; - - pragma Inline (New_Lit); - pragma Inline (New_Dyadic_Op); - pragma Inline (New_Monadic_Op); - pragma Inline (New_Compare_Op); - pragma Inline (New_Signed_Literal); - pragma Inline (New_Unsigned_Literal); - pragma Inline (New_Float_Literal); - pragma Inline (New_Null_Access); - - pragma Inline (Start_Record_Aggr); - pragma Inline (New_Record_Aggr_El); - pragma Inline (Finish_Record_Aggr); - - pragma Inline (Start_Array_Aggr); - pragma Inline (New_Array_Aggr_El); - pragma Inline (Finish_Array_Aggr); - - pragma Inline (New_Union_Aggr); - pragma Inline (New_Sizeof); - pragma Inline (New_Alignof); - pragma Inline (New_Offsetof); - - pragma Inline (New_Indexed_Element); - pragma Inline (New_Slice); - pragma Inline (New_Selected_Element); - pragma Inline (New_Access_Element); - - pragma Inline (New_Convert_Ov); - - pragma Inline (New_Address); - pragma Inline (New_Global_Address); - pragma Inline (New_Unchecked_Address); - pragma Inline (New_Global_Unchecked_Address); - pragma Inline (New_Subprogram_Address); - - pragma Inline (New_Value); - pragma Inline (New_Obj_Value); - - pragma Inline (New_Alloca); - - pragma Inline (New_Debug_Filename_Decl); - pragma Inline (New_Debug_Line_Decl); - pragma Inline (New_Debug_Comment_Decl); - - pragma Inline (New_Type_Decl); - pragma Inline (New_Const_Decl); - - pragma Inline (Start_Const_Value); - pragma Inline (Finish_Const_Value); - pragma Inline (New_Var_Decl); - - pragma Inline (New_Obj); - pragma Inline (Start_Function_Decl); - pragma Inline (Start_Procedure_Decl); - pragma Inline (New_Interface_Decl); - pragma Inline (Finish_Subprogram_Decl); - pragma Inline (Start_Subprogram_Body); - pragma Inline (Finish_Subprogram_Body); - - pragma Inline (New_Debug_Line_Stmt); - pragma Inline (New_Debug_Comment_Stmt); - - pragma Inline (Start_Declare_Stmt); - pragma Inline (Finish_Declare_Stmt); - - -- Create a function call or a procedure call. - pragma Inline (Start_Association); - pragma Inline (New_Association); - pragma Inline (New_Function_Call); - pragma Inline (New_Procedure_Call); - - pragma Inline (New_Assign_Stmt); - pragma Inline (New_Return_Stmt); - pragma Inline (Start_If_Stmt); - pragma Inline (New_Else_Stmt); - pragma Inline (Finish_If_Stmt); - - pragma Inline (Start_Loop_Stmt); - pragma Inline (Finish_Loop_Stmt); - pragma Inline (New_Exit_Stmt); - pragma Inline (New_Next_Stmt); - - pragma Inline (Start_Case_Stmt); - pragma Inline (Start_Choice); - pragma Inline (New_Expr_Choice); - pragma Inline (New_Range_Choice); - pragma Inline (New_Default_Choice); - pragma Inline (Finish_Choice); - pragma Inline (Finish_Case_Stmt); -end Ortho_Mcode; diff --git a/ortho/mcode/ortho_mcode.private.ads b/ortho/mcode/ortho_mcode.private.ads deleted file mode 100644 index 1b414773f..000000000 --- a/ortho/mcode/ortho_mcode.private.ads +++ /dev/null @@ -1,151 +0,0 @@ --- Mcode back-end for ortho. --- Copyright (C) 2006 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with Ortho_Code; use Ortho_Code; -with Ortho_Code.Types; use Ortho_Code.Types; -with Ortho_Code.Consts; use Ortho_Code.Consts; -with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Exprs; use Ortho_Code.Exprs; - --- Interface to create nodes. -package Ortho_Mcode is - -- Initialize nodes. - procedure Init; - procedure Finish; - - procedure Free_All; - -private - -- MCode supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - type O_Tnode is new Ortho_Code.O_Tnode; - type O_Cnode is new Ortho_Code.O_Cnode; - type O_Dnode is new Ortho_Code.O_Dnode; - type O_Enode is new Ortho_Code.O_Enode; - type O_Fnode is new Ortho_Code.O_Fnode; - type O_Lnode is new Ortho_Code.O_Lnode; - type O_Snode is new Ortho_Code.Exprs.O_Snode; - - O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); - O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); - O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); - O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); - O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null); - O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null); - O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null); - - type O_Element_List is new Ortho_Code.Types.O_Element_List; - type O_Enum_List is new Ortho_Code.Types.O_Enum_List; - type O_Inter_List is new Ortho_Code.Decls.O_Inter_List; - type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List; - type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List; - type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List; - type O_If_Block is new Ortho_Code.Exprs.O_If_Block; - type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block; - - pragma Inline (New_Lit); - pragma Inline (New_Dyadic_Op); - pragma Inline (New_Monadic_Op); - pragma Inline (New_Compare_Op); - pragma Inline (New_Signed_Literal); - pragma Inline (New_Unsigned_Literal); - pragma Inline (New_Float_Literal); - pragma Inline (New_Null_Access); - - pragma Inline (Start_Record_Aggr); - pragma Inline (New_Record_Aggr_El); - pragma Inline (Finish_Record_Aggr); - - pragma Inline (Start_Array_Aggr); - pragma Inline (New_Array_Aggr_El); - pragma Inline (Finish_Array_Aggr); - - pragma Inline (New_Union_Aggr); - pragma Inline (New_Sizeof); - pragma Inline (New_Alignof); - pragma Inline (New_Offsetof); - - pragma Inline (New_Indexed_Element); - pragma Inline (New_Slice); - pragma Inline (New_Selected_Element); - pragma Inline (New_Access_Element); - - pragma Inline (New_Convert_Ov); - - pragma Inline (New_Address); - pragma Inline (New_Global_Address); - pragma Inline (New_Unchecked_Address); - pragma Inline (New_Global_Unchecked_Address); - pragma Inline (New_Subprogram_Address); - - pragma Inline (New_Value); - pragma Inline (New_Obj_Value); - - pragma Inline (New_Alloca); - - pragma Inline (New_Debug_Filename_Decl); - pragma Inline (New_Debug_Line_Decl); - pragma Inline (New_Debug_Comment_Decl); - - pragma Inline (New_Type_Decl); - pragma Inline (New_Const_Decl); - - pragma Inline (Start_Const_Value); - pragma Inline (Finish_Const_Value); - pragma Inline (New_Var_Decl); - - pragma Inline (New_Obj); - pragma Inline (Start_Function_Decl); - pragma Inline (Start_Procedure_Decl); - pragma Inline (New_Interface_Decl); - pragma Inline (Finish_Subprogram_Decl); - pragma Inline (Start_Subprogram_Body); - pragma Inline (Finish_Subprogram_Body); - - pragma Inline (New_Debug_Line_Stmt); - pragma Inline (New_Debug_Comment_Stmt); - - pragma Inline (Start_Declare_Stmt); - pragma Inline (Finish_Declare_Stmt); - - -- Create a function call or a procedure call. - pragma Inline (Start_Association); - pragma Inline (New_Association); - pragma Inline (New_Function_Call); - pragma Inline (New_Procedure_Call); - - pragma Inline (New_Assign_Stmt); - pragma Inline (New_Return_Stmt); - pragma Inline (Start_If_Stmt); - pragma Inline (New_Else_Stmt); - pragma Inline (Finish_If_Stmt); - - pragma Inline (Start_Loop_Stmt); - pragma Inline (Finish_Loop_Stmt); - pragma Inline (New_Exit_Stmt); - pragma Inline (New_Next_Stmt); - - pragma Inline (Start_Case_Stmt); - pragma Inline (Start_Choice); - pragma Inline (New_Expr_Choice); - pragma Inline (New_Range_Choice); - pragma Inline (New_Default_Choice); - pragma Inline (Finish_Choice); - pragma Inline (Finish_Case_Stmt); -end Ortho_Mcode; diff --git a/ortho/mcode/ortho_nodes.ads b/ortho/mcode/ortho_nodes.ads deleted file mode 100644 index 7a2df3f30..000000000 --- a/ortho/mcode/ortho_nodes.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Ortho_Mcode; -package Ortho_Nodes renames Ortho_Mcode; diff --git a/ortho/oread/Makefile b/ortho/oread/Makefile deleted file mode 100644 index f94535181..000000000 --- a/ortho/oread/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -# -*- Makefile -*- for the ortho-code compiler. -# Copyright (C) 2005 Tristan Gingold -# -# GHDL 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, or (at your option) any later -# version. -# -# GHDL 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 GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. -BE = gcc -ortho_srcdir=.. -BACK_END=$(ortho_srcdir)/$(BE) -ortho_exec=oread-$(BE) - -all: $(ortho_exec) - -test: test.s - $(CC) -o $@ $^ - -test.s: $(ortho_exec) - ./$(ortho_exec) test - -$(ortho_exec): force - $(MAKE) -f $(BACK_END)/Makefile ortho_exec=$(ortho_exec) - -clean: - $(MAKE) -f $(BACK_END)/Makefile clean - $(RM) -f oread-gcc oread-mcode *.o *~ - -distclean: clean - $(MAKE) -f $(BACK_END)/Makefile distclean - -force: - -.PHONY: force diff --git a/ortho/oread/ortho_front.adb b/ortho/oread/ortho_front.adb deleted file mode 100644 index 84bbd1b9d..000000000 --- a/ortho/oread/ortho_front.adb +++ /dev/null @@ -1,2677 +0,0 @@ --- Ortho code compiler. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Deallocation; -with Ortho_Nodes; use Ortho_Nodes; -with Ortho_Ident; use Ortho_Ident; -with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Interfaces; use Interfaces; -with Ada.Exceptions; ---with GNAT.Debug_Pools; - --- TODO: --- uncomplete type: check for type redefinition - -package body Ortho_Front is - -- If true, emit line number before each statement. - -- If flase, keep line number indication in the source file. - Flag_Renumber : Boolean := True; - - procedure Init is - begin - null; - end Init; - - function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural - is - pragma Unreferenced (Arg); - begin - if Opt.all = "-r" or Opt.all = "--ghdl-r" then - Flag_Renumber := True; - return 1; - else - return 0; - end if; - end Decode_Option; - - -- File buffer. - File_Name : String_Acc; - Buf : String (1 .. 2048 + 1); - Buf_Len : Natural; - Pos : Natural; - Lineno : Natural; - - Fd : File_Descriptor; - - Error : exception; - - procedure Puterr (Msg : String) - is - L : Integer; - pragma Unreferenced (L); - begin - L := Write (Standerr, Msg'Address, Msg'Length); - end Puterr; - - procedure Puterr (N : Natural) - is - Str : constant String := Natural'Image (N); - begin - Puterr (Str (Str'First + 1 .. Str'Last)); - end Puterr; - - procedure Newline_Err is - begin - Puterr ((1 => LF)); - end Newline_Err; - - procedure Scan_Error (Msg : String) is - begin - Puterr (File_Name.all); - Puterr (":"); - Puterr (Lineno); - Puterr (": "); - Puterr (Msg); - Newline_Err; - raise Error; - end Scan_Error; - - procedure Parse_Error (Msg : String); - pragma No_Return (Parse_Error); - - procedure Parse_Error (Msg : String) is - begin - Puterr (File_Name.all); - Puterr (":"); - Puterr (Lineno); - Puterr (": "); - Puterr (Msg); - Newline_Err; - raise Error; - end Parse_Error; - - --- Uniq_Num : Natural := 0; - --- function Get_Uniq_Id return O_Ident --- is --- Str : String (1 .. 8); --- V : Natural; --- begin --- V := Uniq_Num; --- Uniq_Num := Uniq_Num + 1; --- Str (1) := 'L'; --- Str (2) := '.'; --- for I in reverse 3 .. Str'Last loop --- Str (I) := Character'Val ((V mod 10) + Character'Pos('0')); --- V := V / 10; --- end loop; --- return Get_Identifier (Str); --- end Get_Uniq_Id; - - -- Get the next character. - -- Return NUL on end of file. - function Get_Char return Character - is - Res : Character; - begin - if Buf (Pos) = NUL then - -- Read line. - Buf_Len := Read (Fd, Buf'Address, Buf'Length - 1); - if Buf_Len = 0 then - -- End of file. - return NUL; - end if; - Pos := 1; - Buf (Buf_Len + 1) := NUL; - end if; - - Res := Buf (Pos); - Pos := Pos + 1; - return Res; - end Get_Char; - - procedure Unget_Char is - begin - if Pos = Buf'First then - raise Program_Error; - end if; - Pos := Pos - 1; - end Unget_Char; - - type Token_Type is - (Tok_Eof, - Tok_Line_Number, Tok_File_Name, Tok_Comment, - Tok_Ident, Tok_Num, Tok_String, Tok_Float_Num, - Tok_Plus, Tok_Minus, - Tok_Star, Tok_Div, Tok_Mod, Tok_Rem, - Tok_Sharp, - Tok_Not, Tok_Abs, - Tok_Or, Tok_And, Tok_Xor, - Tok_Equal, Tok_Not_Equal, - Tok_Greater, Tok_Greater_Eq, - Tok_Less, Tok_Less_Eq, - Tok_Colon, Tok_Semicolon, - Tok_Comma, Tok_Dot, Tok_Tick, Tok_Arob, Tok_Elipsis, - Tok_Assign, - Tok_Left_Paren, Tok_Right_Paren, - Tok_Left_Brace, Tok_Right_Brace, - Tok_Left_Brack, Tok_Right_Brack, - Tok_Unsigned, Tok_Signed, Tok_Float, - Tok_Array, Tok_Subarray, - Tok_Access, Tok_Record, Tok_Union, - Tok_Boolean, Tok_Enum, - Tok_If, Tok_Then, Tok_Else, Tok_Elsif, - Tok_Loop, Tok_Exit, Tok_Next, - Tok_Is, Tok_Of, Tok_All, - Tok_Return, - Tok_Type, - Tok_External, Tok_Private, Tok_Public, Tok_Local, - Tok_Procedure, Tok_Function, - Tok_Constant, Tok_Var, - Tok_Declare, Tok_Begin, Tok_End, - Tok_Case, Tok_When, Tok_Default, Tok_Arrow, - Tok_Null); - - type Hash_Type is new Unsigned_32; - - type Name_Type; - type Name_Acc is access Name_Type; - - -- Symbol table. - type Syment_Type; - type Syment_Acc is access Syment_Type; - type Syment_type is record - -- The hash for the symbol. - Hash : Hash_Type; - -- Identification of the symbol. - Ident : O_Ident; - -- Next symbol with the same collision. - Next : Syment_Acc; - -- Meaning of the symbol. - Name : Name_Acc; - end record; - - -- Well known identifiers (used for attributes). - Id_Address : Syment_Acc; - Id_Unchecked_Address : Syment_Acc; - Id_Subprg_Addr : Syment_Acc; - Id_Conv : Syment_Acc; - Id_Sizeof : Syment_Acc; - Id_Alignof : Syment_Acc; - Id_Alloca : Syment_Acc; - Id_Offsetof : Syment_Acc; - - Token_Number : Unsigned_64; - Token_Float : IEEE_Float_64; - Token_Ident : String (1 .. 256); - Token_Idlen : Natural; - Token_Hash : Hash_Type; - Token_Sym : Syment_Acc; - - -- The symbol table. - type Syment_Acc_Array is array (Hash_Type range <>) of Syment_Acc; - Hash_Max : constant Hash_Type := 511; - Symtable : Syment_Acc_Array (0 .. Hash_Max - 1) := (others => null); - - type Node_Kind is (Decl_Keyword, Decl_Type, Decl_Param, - Node_Function, Node_Procedure, Node_Object, Node_Field, - Node_Lit, - Type_Boolean, Type_Enum, - Type_Unsigned, Type_Signed, Type_Float, - Type_Array, Type_Subarray, - Type_Access, Type_Record, Type_Union); - subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure; - - type Node (<>); - type Node_Acc is access Node; - type Node (Kind : Node_Kind) is record - case Kind is - when Decl_Keyword => - -- Keyword. - -- A keyword is not a declaration since the identifier has only - -- one meaning (the keyword). - Keyword : Token_Type; - when Decl_Type - | Decl_Param - | Node_Function - | Node_Procedure - | Node_Object - | Node_Lit => - -- Declarations - -- All declarations but NODE_PROCEDURE have a type. - Decl_Dtype : Node_Acc; - Decl_Storage : O_Storage; - case Kind is - when Decl_Type => - -- Type declaration. - null; - when Decl_Param => - -- Parameter identifier. - Param_Name : Syment_Acc; - -- Parameter ortho node. - Param_Node : O_Dnode; - -- Next parameter of the parameters list. - Param_Next : Node_Acc; - when Node_Procedure - | Node_Function => - -- Subprogram symbol name. - Subprg_Name : Syment_Acc; - -- List of parameters. - Subprg_Params : Node_Acc; - -- Subprogram ortho node. - Subprg_Node : O_Dnode; - when Node_Object => - -- Name of the object (constant, variable). - Obj_Name : O_Ident; - -- Ortho node of the object. - Obj_Node : O_Dnode; - when Node_Lit => - -- Name of the literal. - Lit_Name : O_Ident; - -- Enum literal - Lit_Cnode : O_Cnode; - -- Next literal for the type. - Lit_Next : Node_Acc; - when others => - null; - end case; - when Node_Field => - -- Record field. - Field_Ident : Syment_Acc; - Field_Fnode : O_Fnode; - Field_Type : Node_Acc; - Field_Next : Node_Acc; - when Type_Signed - | Type_Unsigned - | Type_Float - | Type_Array - | Type_Subarray - | Type_Record - | Type_Union - | Type_Access - | Type_Boolean - | Type_Enum => - -- Ortho node type. - Type_Onode : O_Tnode; - case Kind is - when Type_Array => - Array_Index : Node_Acc; - Array_Element : Node_Acc; - when Type_Subarray => - Subarray_Base : Node_Acc; - --Subarray_Length : Natural; - when Type_Access => - Access_Dtype : Node_Acc; - when Type_Record - | Type_Union => - Record_Union_Fields : Node_Acc; - when Type_Enum - | Type_Boolean => - Enum_Lits : Node_Acc; - when Type_Float => - null; - when others => - null; - end case; - end case; - end record; - - type Scope_Type; - type Scope_Acc is access Scope_Type; - - type Name_Type is record - -- Current interpretation of the symbol. - Inter : Node_Acc; - -- Next declaration in the current scope. - Next : Syment_Acc; - -- Interpretation in a previous scope. - Up : Name_Acc; - -- Current scope. - Scope : Scope_Acc; - end record; - - type Scope_Type is record - -- Simply linked list of names. - Names : Syment_Acc; - -- Previous scope. - Prev : Scope_Acc; - end record; - - -- Return the current declaration for symbol SYM. - function Get_Decl (Sym : Syment_Acc) return Node_Acc; - pragma Inline (Get_Decl); - - procedure Scan_Char (C : Character) - is - R : Character; - begin - - if C = '\' then - R := Get_Char; - case R is - when 'n' => - R := LF; - when 'r' => - R := CR; - when ''' => - R := '''; - when '"' => -- " - R := '"'; -- " - when others => - Scan_Error ("bad character sequence \" & R); - end case; - else - R := C; - end if; - Token_Idlen := Token_Idlen + 1; - Token_Ident (Token_Idlen) := R; - end Scan_Char; - - function Get_Hash (Str : String) return Hash_Type - is - Res : Hash_Type; - begin - Res := 0; - for I in Str'Range loop - Res := Res * 31 + Character'Pos (Str (I)); - end loop; - return Res; - end Get_Hash; - - -- Previous token. - Tok_Previous : Token_Type; - - function Scan_Number (First_Char : Character) return Token_Type - is - function To_Digit (C : Character) return Integer is - begin - case C is - when '0' .. '9' => - return Character'Pos (C) - Character'Pos ('0'); - when 'A' .. 'F' => - return Character'Pos (C) - Character'Pos ('A') + 10; - when 'a' .. 'f' => - return Character'Pos (C) - Character'Pos ('a') + 10; - when others => - return -1; - end case; - end To_Digit; - - function Is_Digit (C : Character) return Boolean is - begin - case C is - when '0' .. '9' - | 'A' .. 'F' - | 'a' .. 'f' => - return True; - when others => - return False; - end case; - end Is_Digit; - - After_Point : Integer; - C : Character; - Exp : Integer; - Exp_Neg : Boolean; - Base : Unsigned_64; - begin - Token_Number := 0; - C := First_Char; - loop - Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C)); - C := Get_Char; - exit when not Is_Digit (C); - end loop; - if C = '#' then - Base := Token_Number; - Token_Number := 0; - C := Get_Char; - loop - Token_Number := Token_Number * Base + Unsigned_64 (To_Digit (C)); - C := Get_Char; - exit when C = '#'; - end loop; - return Tok_Num; - end if; - if C = '.' then - -- A real number. - After_Point := 0; - Token_Float := IEEE_Float_64 (Token_Number); - loop - C := Get_Char; - exit when C not in '0' .. '9'; - Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C)); - After_Point := After_Point + 1; - end loop; - if C = 'e' or C = 'E' then - Exp := 0; - C := Get_Char; - Exp_Neg := False; - if C = '-' then - Exp_Neg := True; - C := Get_Char; - elsif C = '+' then - C := Get_Char; - elsif not Is_Digit (C) then - Scan_Error ("digit expected"); - end if; - while Is_Digit (C) loop - Exp := Exp * 10 + To_Digit (C); - C := Get_Char; - end loop; - if Exp_Neg then - Exp := -Exp; - end if; - Exp := Exp - After_Point; - else - Exp := - After_Point; - end if; - Unget_Char; - Token_Float := Token_Float * 10.0 ** Exp; - if Token_Float > IEEE_Float_64'Last then - Token_Float := IEEE_Float_64'Last; - end if; - return Tok_Float_Num; - else - Unget_Char; - return Tok_Num; - end if; - end Scan_Number; - - procedure Scan_Comment - is - C : Character; - begin - Token_Idlen := 0; - loop - C := Get_Char; - exit when C = CR or C = LF; - Token_Idlen := Token_Idlen + 1; - Token_Ident (Token_Idlen) := C; - end loop; - Unget_Char; - end Scan_Comment; - - -- Get the next token. - function Get_Token return Token_Type - is - C : Character; - begin - loop - - C := Get_Char; - << Again >> null; - case C is - when NUL => - return Tok_Eof; - when ' ' | HT => - null; - when LF => - Lineno := Lineno + 1; - C := Get_Char; - if C /= CR then - goto Again; - end if; - when CR => - Lineno := Lineno + 1; - C := Get_Char; - if C /= LF then - goto Again; - end if; - when '+' => - return Tok_Plus; - when '-' => - C := Get_Char; - if C = '-' then - C := Get_Char; - if C = '#' then - return Tok_Line_Number; - elsif C = 'F' then - Scan_Comment; - return Tok_File_Name; - elsif C = ' ' then - Scan_Comment; - return Tok_Comment; - else - Scan_Error ("bad comment"); - end if; - else - Unget_Char; - return Tok_Minus; - end if; - when '/' => - C := Get_Char; - if C = '=' then - return Tok_Not_Equal; - else - Unget_Char; - return Tok_Div; - end if; - when '*' => - return Tok_Star; - when '#' => - return Tok_Sharp; - when '=' => - C := Get_Char; - if C = '>' then - return Tok_Arrow; - else - Unget_Char; - return Tok_Equal; - end if; - when '>' => - C := Get_Char; - if C = '=' then - return Tok_Greater_Eq; - else - Unget_Char; - return Tok_Greater; - end if; - when '(' => - return Tok_Left_Paren; - when ')' => - return Tok_Right_Paren; - when '{' => - return Tok_Left_Brace; - when '}' => - return Tok_Right_Brace; - when '[' => - return Tok_Left_Brack; - when ']' => - return Tok_Right_Brack; - when '<' => - C := Get_Char; - if C = '=' then - return Tok_Less_Eq; - else - Unget_Char; - return Tok_Less; - end if; - when ':' => - C := Get_Char; - if C = '=' then - return Tok_Assign; - else - Unget_Char; - return Tok_Colon; - end if; - when '.' => - C := Get_Char; - if C = '.' then - C := Get_Char; - if C = '.' then - return Tok_Elipsis; - else - Scan_Error ("'...' expected"); - end if; - else - Unget_Char; - return Tok_Dot; - end if; - when ';' => - return Tok_Semicolon; - when ',' => - return Tok_Comma; - when '@' => - return Tok_Arob; - when ''' => - if Tok_Previous = Tok_Ident then - return Tok_Tick; - else - Token_Number := Character'Pos (Get_Char); - C := Get_Char; - if C /= ''' then - Scan_Error ("ending single quote expected"); - end if; - return Tok_Num; - end if; - when '"' => -- " - -- Eat double quote. - C := Get_Char; - Token_Idlen := 0; - loop - Scan_Char (C); - C := Get_Char; - exit when C = '"'; -- " - end loop; - return Tok_String; - when '0' .. '9' => - return Scan_Number (C); - when 'a' .. 'z' - | 'A' .. 'Z' - | '_' => - Token_Idlen := 0; - Token_Hash := 0; - loop - Token_Idlen := Token_Idlen + 1; - Token_Ident (Token_Idlen) := C; - Token_Hash := Token_Hash * 31 + Character'Pos (C); - C := Get_Char; - exit when (C < 'A' or C > 'Z') - and (C < 'a' or C > 'z') - and (C < '0' or C > '9') - and (C /= '_'); - end loop; - Unget_Char; - declare - H : Hash_Type; - S : Syment_Acc; - N : Node_Acc; - begin - H := Token_Hash mod Hash_Max; - S := Symtable (H); - while S /= null loop - if S.Hash = Token_Hash - and then Is_Equal (S.Ident, - Token_Ident (1 .. Token_Idlen)) - then - -- This identifier is known. - Token_Sym := S; - - -- It may be a keyword. - if S.Name /= null then - N := Get_Decl (S); - if N.Kind = Decl_Keyword then - return N.Keyword; - end if; - end if; - - return Tok_Ident; - end if; - S := S.Next; - end loop; - Symtable (H) := new Syment_Type' - (Hash => Token_Hash, - Ident => Get_Identifier (Token_Ident (1 .. Token_Idlen)), - Next => Symtable (H), - Name => null); - Token_Sym := Symtable (H); - return Tok_Ident; - end; - when others => - Scan_Error ("Bad character:" - & Integer'Image (Character'Pos (C)) - & C); - return Tok_Eof; - end case; - end loop; - end Get_Token; - - -- The current token. - Tok : Token_Type; - - procedure Next_Token is - begin - Tok_Previous := Tok; - Tok := Get_Token; - end Next_Token; - - procedure Expect (T : Token_Type; Msg : String := "") is - begin - if Tok /= T then - if Msg'Length = 0 then - case T is - when Tok_Left_Brace => - Parse_Error ("'{' expected"); - when others => - if Tok = Tok_Ident then - Parse_Error - (Token_Type'Image (T) & " expected, found '" & - Token_Ident (1 .. Token_Idlen) & "'"); - else - Parse_Error (Token_Type'Image (T) & " expected, found " - & Token_Type'Image (Tok)); - end if; - end case; - else - Parse_Error (Msg); - end if; - end if; - end Expect; - - procedure Next_Expect (T : Token_Type; Msg : String := "") is - begin - Next_Token; - Expect (T, Msg); - end Next_Expect; - - -- Scopes and identifiers. - - - -- Current scope. - Scope : Scope_Acc := null; - - -- Add a declaration for symbol SYM in the current scope. - -- INTER defines the meaning of the declaration. - -- There must be at most one declaration for a symbol in the current scope, - -- i.e. a symbol cannot be redefined. - procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc); - - -- Return TRUE iff SYM is already defined in the current scope. - function Is_Defined (Sym : Syment_Acc) return Boolean; - - -- Create new scope. - procedure Push_Scope; - - -- Close the current scope. Symbols defined in the scope regain their - -- previous declaration. - procedure Pop_Scope; - - - procedure Push_Scope - is - Nscope : Scope_Acc; - begin - Nscope := new Scope_Type'(Names => null, Prev => Scope); - Scope := Nscope; - end Push_Scope; - - procedure Pop_Scope - is - procedure Free is new Ada.Unchecked_Deallocation - (Object => Name_Type, Name => Name_Acc); - - procedure Free is new Ada.Unchecked_Deallocation - (Object => Scope_Type, Name => Scope_Acc); - - Sym : Syment_Acc; - N_Sym : Syment_Acc; - Name : Name_Acc; - Old_Scope : Scope_Acc; - begin - Sym := Scope.Names; - while Sym /= null loop - Name := Sym.Name; - -- Check. - if Name.Scope /= Scope then - raise Program_Error; - end if; - - -- Set the interpretation of this symbol. - Sym.Name := Name.Up; - - N_Sym := Name.Next; - - Free (Name); - Sym := N_Sym; - end loop; - - -- Free scope. - Old_Scope := Scope; - Scope := Scope.Prev; - Free (Old_Scope); - end Pop_Scope; - - function Is_Defined (Sym : Syment_Acc) return Boolean is - begin - if Sym.Name /= null - and then Sym.Name.Scope = Scope - then - return True; - else - return False; - end if; - end Is_Defined; - - function New_Symbol (Str : String) return Syment_Acc - is - Ent : Syment_Acc; - H : Hash_Type; - begin - Ent := new Syment_Type'(Hash => Get_Hash (Str), - Ident => Get_Identifier (Str), - Next => null, - Name => null); - H := Ent.Hash mod Hash_Max; - Ent.Next := Symtable (H); - Symtable (H) := Ent; - return Ent; - end New_Symbol; - - procedure Add_Keyword (Str : String; Token : Token_Type) - is - Ent : Syment_Acc; - begin - Ent := New_Symbol (Str); - if Ent.Name /= null - or else Scope /= null - then - -- Redefinition of a keyword. - raise Program_Error; - end if; - Ent.Name := new Name_Type'(Inter => new Node'(Kind => Decl_Keyword, - Keyword => Token), - Next => null, - Up => null, - Scope => null); - end Add_Keyword; - - procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc) - is - Name : Name_Acc; - Prev : Node_Acc; - begin - Name := Sym.Name; - if Name /= null and then Name.Scope = Scope then - Prev := Name.Inter; - if Prev.Kind = Inter.Kind - and then Prev.Decl_Dtype = Inter.Decl_Dtype - and then Prev.Decl_Storage = O_Storage_External - and then Inter.Decl_Storage = O_Storage_Public - then - -- Redefinition - Name.Inter := Inter; - return; - end if; - Parse_Error ("redefinition of " & Get_String (Sym.Ident)); - end if; - Name := new Name_Type'(Inter => Inter, - Next => Scope.Names, - Up => Sym.Name, - Scope => Scope); - Sym.Name := Name; - Scope.Names := Sym; - end Add_Decl; - - function Get_Decl (Sym : Syment_Acc) return Node_Acc is - begin - if Sym.Name = null then - Parse_Error ("undefined identifier " & Get_String (Sym.Ident)); - else - return Sym.Name.Inter; - end if; - end Get_Decl; - - function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode; - function Parse_Address (Prefix : Node_Acc) return O_Enode; - function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode; - procedure Parse_Declaration; - procedure Parse_Compound_Statement; - - function Parse_Type return Node_Acc; - - procedure Parse_Fields (Aggr_Type : Node_Acc; - Constr : in out O_Element_List) - is - F_Type : Node_Acc; - F : Syment_Acc; - Last_Field : Node_Acc; - Field : Node_Acc; - begin - Last_Field := null; - loop - exit when Tok = Tok_End; - - if Tok /= Tok_Ident then - Parse_Error ("field name expected"); - end if; - F := Token_Sym; - Next_Expect (Tok_Colon, "':' expected"); - Next_Token; - F_Type := Parse_Type; - Field := new Node'(Kind => Node_Field, - Field_Ident => F, - Field_Fnode => O_Fnode_Null, - Field_Type => F_Type, - Field_Next => null); - case Aggr_Type.Kind is - when Type_Record => - New_Record_Field (Constr, Field.Field_Fnode, F.Ident, - F_Type.Type_Onode); - when Type_Union => - New_Union_Field (Constr, Field.Field_Fnode, F.Ident, - F_Type.Type_Onode); - when others => - raise Program_Error; - end case; - if Last_Field = null then - Aggr_Type.Record_Union_Fields := Field; - else - Last_Field.Field_Next := Field; - end if; - Last_Field := Field; - Expect (Tok_Semicolon, "';' expected"); - Next_Token; - end loop; - end Parse_Fields; - - procedure Parse_Record_Type (Def : Node_Acc) - is - Constr : O_Element_List; - begin - if Def.Type_Onode = O_Tnode_Null then - Start_Record_Type (Constr); - else - Start_Uncomplete_Record_Type (Def.Type_Onode, Constr); - end if; - Parse_Fields (Def, Constr); - Next_Expect (Tok_Record, "end record expected"); - Finish_Record_Type (Constr, Def.Type_Onode); - end Parse_Record_Type; - - procedure Parse_Union_Type (Def : Node_Acc) - is - Constr : O_Element_List; - begin - Start_Union_Type (Constr); - Parse_Fields (Def, Constr); - Next_Expect (Tok_Union, "end union expected"); - Finish_Union_Type (Constr, Def.Type_Onode); - end Parse_Union_Type; - - function Parse_Type return Node_Acc - is - Res : Node_Acc; - T : Token_Type; - begin - T := Tok; - case T is - when Tok_Unsigned - | Tok_Signed => - Next_Expect (Tok_Left_Paren, "'(' expected"); - Next_Expect (Tok_Num, "number expected"); - case T is - when Tok_Unsigned => - Res := new Node' - (Kind => Type_Unsigned, - Type_Onode => New_Unsigned_Type (Natural - (Token_Number))); - when Tok_Signed => - Res := new Node' - (Kind => Type_Signed, - Type_Onode => New_Signed_Type (Natural - (Token_Number))); - when others => - raise Program_Error; - end case; - Next_Expect (Tok_Right_Paren, "')' expected"); - when Tok_Float => - Res := new Node'(Kind => Type_Float, - Type_Onode => New_Float_Type); - when Tok_Array => - declare - Index_Node : Node_Acc; - El_Node : Node_Acc; - begin - Next_Expect (Tok_Left_Brack, "'[' expected"); - Next_Token; - Index_Node := Parse_Type; - Expect (Tok_Right_Brack, "']' expected"); - Next_Expect (Tok_Of, "'of' expected"); - Next_Token; - El_Node := Parse_Type; - Res := new Node' - (Kind => Type_Array, - Type_Onode => New_Array_Type (El_Node.Type_Onode, - Index_Node.Type_Onode), - Array_Index => Index_Node, - Array_Element => El_Node); - end; - return Res; - when Tok_Subarray => - declare - Base_Node : Node_Acc; - Res_Type : O_Tnode; - begin - Next_Token; - Base_Node := Parse_Type; - Expect (Tok_Left_Brack); - Next_Token; - Res_Type := New_Constrained_Array_Type - (Base_Node.Type_Onode, - Parse_Constant_Value (Base_Node.Array_Index)); - Expect (Tok_Right_Brack); - Next_Token; - Res := new Node' (Kind => Type_Subarray, - Type_Onode => Res_Type, - Subarray_Base => Base_Node); - return Res; - end; - when Tok_Ident => - declare - Inter : Node_Acc; - begin - Inter := Get_Decl (Token_Sym); - if Inter = null then - Parse_Error ("undefined type name symbol " - & Get_String (Token_Sym.Ident)); - end if; - if Inter.Kind /= Decl_Type then - Parse_Error ("type declarator expected"); - end if; - Res := Inter.Decl_Dtype; - end; - when Tok_Access => - declare - Dtype : Node_Acc; - begin - Next_Token; - if Tok = Tok_Semicolon then - Res := new Node' - (Kind => Type_Access, - Type_Onode => New_Access_Type (O_Tnode_Null), - Access_Dtype => null); - else - Dtype := Parse_Type; - Res := new Node' - (Kind => Type_Access, - Type_Onode => New_Access_Type (Dtype.Type_Onode), - Access_Dtype => Dtype); - end if; - return Res; - end; - when Tok_Record => - Next_Token; - if Tok = Tok_Semicolon then - -- Uncomplete record type. - Res := new Node'(Kind => Type_Record, - Type_Onode => O_Tnode_Null, - Record_Union_Fields => null); - New_Uncomplete_Record_Type (Res.Type_Onode); - return Res; - end if; - - Res := new Node'(Kind => Type_Record, - Type_Onode => O_Tnode_Null, - Record_Union_Fields => null); - Parse_Record_Type (Res); - when Tok_Union => - Next_Token; - Res := new Node'(Kind => Type_Union, - Type_Onode => O_Tnode_Null, - Record_Union_Fields => null); - Parse_Union_Type (Res); - - when Tok_Boolean => - declare - False_Lit, True_Lit : Node_Acc; - begin - Res := new Node'(Kind => Type_Boolean, - Type_Onode => O_Tnode_Null, - Enum_Lits => null); - Next_Expect (Tok_Left_Brace, "'{' expected"); - Next_Expect (Tok_Ident, "identifier expected"); - False_Lit := new Node'(Kind => Node_Lit, - Decl_Dtype => Res, - Decl_Storage => O_Storage_Public, - Lit_Name => Token_Sym.Ident, - Lit_Cnode => O_Cnode_Null, - Lit_Next => null); - Next_Expect (Tok_Comma, "',' expected"); - Next_Expect (Tok_Ident, "identifier expected"); - True_Lit := new Node'(Kind => Node_Lit, - Decl_Dtype => Res, - Decl_Storage => O_Storage_Public, - Lit_Name => Token_Sym.Ident, - Lit_Cnode => O_Cnode_Null, - Lit_Next => null); - Next_Expect (Tok_Right_Brace, "'}' expected"); - False_Lit.Lit_Next := True_Lit; - Res.Enum_Lits := False_Lit; - New_Boolean_Type (Res.Type_Onode, - False_Lit.Lit_Name, False_Lit.Lit_Cnode, - True_Lit.Lit_Name, True_Lit.Lit_Cnode); - end; - when Tok_Enum => - declare - List : O_Enum_List; - Lit : Node_Acc; - Last_Lit : Node_Acc; - begin - Res := new Node'(Kind => Type_Enum, - Type_Onode => O_Tnode_Null, - Enum_Lits => null); - Last_Lit := null; - Push_Scope; - Next_Expect (Tok_Left_Brace); - Next_Token; - -- FIXME: set a size to the enum. - Start_Enum_Type (List, 8); - loop - Expect (Tok_Ident); - Lit := new Node'(Kind => Node_Lit, - Decl_Dtype => Res, - Decl_Storage => O_Storage_Public, - Lit_Name => Token_Sym.Ident, - Lit_Cnode => O_Cnode_Null, - Lit_Next => null); - Add_Decl (Token_Sym, Lit); - New_Enum_Literal (List, Lit.Lit_Name, Lit.Lit_Cnode); - if Last_Lit = null then - Res.Enum_Lits := Lit; - else - Last_Lit.Lit_Next := Lit; - end if; - Last_Lit := Lit; - Next_Expect (Tok_Equal); - Next_Expect (Tok_Num); - Next_Token; - exit when Tok = Tok_Right_Brace; - Expect (Tok_Comma); - Next_Token; - end loop; - Finish_Enum_Type (List, Res.Type_Onode); - Pop_Scope; - end; - when others => - Parse_Error ("bad type " & Token_Type'Image (Tok)); - return null; - end case; - Next_Token; - return Res; - end Parse_Type; - - procedure Parse_Type_Completion (Decl : Node_Acc) - is - begin - case Tok is - when Tok_Record => - Next_Token; - Parse_Record_Type (Decl.Decl_Dtype); - Next_Token; - when Tok_Access => - Next_Token; - declare - Dtype : Node_Acc; - begin - Dtype := Parse_Type; - Decl.Decl_Dtype.Access_Dtype := Dtype; - Finish_Access_Type (Decl.Decl_Dtype.Type_Onode, - Dtype.Type_Onode); - end; - when others => - Parse_Error ("'access' or 'record' expected"); - end case; - end Parse_Type_Completion; - --- procedure Parse_Declaration; - - procedure Parse_Expression (Expr_Type : Node_Acc; - Expr : out O_Enode; - Res_Type : out Node_Acc); - procedure Parse_Name (Prefix : Node_Acc; - Name : out O_Lnode; N_Type : out Node_Acc); - procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc); - - -- Expect: '(' - -- Let: next token. - procedure Parse_Association (Constr : in out O_Assoc_List; - Decl : Node_Acc); - - function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc - is - Field : Node_Acc; - begin - Field := Aggr_Type.Record_Union_Fields; - while Field /= null loop - exit when Field.Field_Ident = Token_Sym; - Field := Field.Field_Next; - end loop; - if Field = null then - Parse_Error ("no such field name"); - end if; - return Field; - end Find_Field_By_Name; - - -- expect: offsetof id. - function Parse_Offsetof (Atype : Node_Acc) return O_Cnode - is - Rec_Type : Node_Acc; - Rec_Field : Node_Acc; - begin - Next_Expect (Tok_Left_Paren); - Next_Expect (Tok_Ident); - Rec_Type := Get_Decl (Token_Sym); - if Rec_Type.Kind /= Decl_Type - or else Rec_Type.Decl_Dtype.Kind /= Type_Record - then - Parse_Error ("type name expected"); - end if; - Next_Expect (Tok_Dot); - Next_Expect (Tok_Ident); - Rec_Field := Find_Field_By_Name (Rec_Type.Decl_Dtype); - Next_Expect (Tok_Right_Paren); - return New_Offsetof (Rec_Type.Decl_Dtype.Type_Onode, - Rec_Field.Field_Fnode, - Atype.Type_Onode); - end Parse_Offsetof; - - function Parse_Sizeof (Atype : Node_Acc) return O_Cnode - is - Res : O_Cnode; - begin - Next_Expect (Tok_Left_Paren); - Next_Token; - if Tok /= Tok_Ident then - Parse_Error ("type name expected"); - end if; - Res := New_Sizeof - (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode, - Atype.Type_Onode); - Next_Expect (Tok_Right_Paren); - return Res; - end Parse_Sizeof; - - function Parse_Alignof (Atype : Node_Acc) return O_Cnode - is - Res : O_Cnode; - begin - Next_Expect (Tok_Left_Paren); - Next_Token; - if Tok /= Tok_Ident then - Parse_Error ("type name expected"); - end if; - Res := New_Alignof - (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode, - Atype.Type_Onode); - Next_Expect (Tok_Right_Paren); - return Res; - end Parse_Alignof; - - -- Parse a literal whose type is ATYPE. - function Parse_Typed_Literal (Atype : Node_Acc) return O_Cnode - is - Res : O_Cnode; - begin - case Tok is - when Tok_Num => - case Atype.Kind is - when Type_Signed => - Res := New_Signed_Literal - (Atype.Type_Onode, Integer_64 (Token_Number)); - when Type_Unsigned => - Res := New_Unsigned_Literal - (Atype.Type_Onode, Token_Number); - when others => - Parse_Error ("bad type for integer literal"); - end case; - when Tok_Minus => - Next_Token; - case Tok is - when Tok_Num => - declare - V : Integer_64; - begin - if Token_Number = Unsigned_64 (Integer_64'Last) + 1 then - V := Integer_64'First; - else - V := -Integer_64 (Token_Number); - end if; - Res := New_Signed_Literal (Atype.Type_Onode, V); - end; - when Tok_Float_Num => - Res := New_Float_Literal (Atype.Type_Onode, -Token_Float); - when others => - Parse_Error ("bad token after '-'"); - end case; - when Tok_Float_Num => - Res := New_Float_Literal (Atype.Type_Onode, Token_Float); - when Tok_Ident => - declare - Pfx : Node_Acc; - N : Node_Acc; - begin - -- Note: we don't use get_decl, since the name can be a literal - -- name, which is not directly visible. - if Token_Sym.Name /= null - and then Token_Sym.Name.Inter.Kind = Decl_Type - then - -- A typed expression. - Pfx := Token_Sym.Name.Inter; - N := Pfx.Decl_Dtype; - if Atype /= null and then N /= Atype then - Parse_Error ("type mismatch"); - end if; - Next_Expect (Tok_Tick); - Next_Token; - if Tok = Tok_Left_Brack then - Next_Token; - Res := Parse_Typed_Literal (N); - Expect (Tok_Right_Brack); - elsif Tok = Tok_Ident then - if Token_Sym = Id_Offsetof then - Res := Parse_Offsetof (N); - elsif Token_Sym = Id_Sizeof then - Res := Parse_Sizeof (N); - elsif Token_Sym = Id_Alignof then - Res := Parse_Alignof (N); - elsif Token_Sym = Id_Address - or Token_Sym = Id_Unchecked_Address - or Token_Sym = Id_Subprg_Addr - then - Res := Parse_Constant_Address (Pfx); - elsif Token_Sym = Id_Conv then - Next_Expect (Tok_Left_Paren); - Next_Token; - Res := Parse_Typed_Literal (N); - Expect (Tok_Right_Paren); - else - Parse_Error ("offsetof or sizeof attributes expected"); - end if; - else - Parse_Error ("'[' or attribute expected"); - end if; - else - if Atype.Kind /= Type_Enum - and then Atype.Kind /= Type_Boolean - then - Parse_Error ("name allowed only for enumeration"); - end if; - N := Atype.Enum_Lits; - while N /= null loop - if Is_Equal (N.Lit_Name, Token_Sym.Ident) then - Res := N.Lit_Cnode; - exit; - end if; - N := N.Lit_Next; - end loop; - if N = null then - Parse_Error ("no matching literal"); - return O_Cnode_Null; - end if; - end if; - end; - when Tok_Null => - Res := New_Null_Access (Atype.Type_Onode); - when others => - Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); - return O_Cnode_Null; - end case; - Next_Token; - return Res; - end Parse_Typed_Literal; - - -- expect: next token - -- Parse an expression starting with NAME. - procedure Parse_Named_Expression - (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - begin - if Tok = Tok_Tick then - Next_Token; - if Tok = Tok_Left_Brack then - -- Typed literal. - Next_Token; - Res := New_Lit (Parse_Typed_Literal (Name.Decl_Dtype)); - Res_Type := Name.Decl_Dtype; - Expect (Tok_Right_Brack); - Next_Token; - elsif Tok = Tok_Left_Paren then - -- Typed expression (used for comparaison operators) - Next_Token; - Parse_Expression (Name.Decl_Dtype, Res, Res_Type); - Expect (Tok_Right_Paren); - Next_Token; - 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. - elsif Token_Sym = Id_Address - or Token_Sym = Id_Unchecked_Address - or Token_Sym = Id_Subprg_Addr - then - Res_Type := Name.Decl_Dtype; - Res := Parse_Address (Name); - -- Fall-through. - elsif Token_Sym = Id_Sizeof then - Res_Type := Name.Decl_Dtype; - Res := New_Lit (Parse_Sizeof (Res_Type)); - Next_Token; - return; - elsif Token_Sym = Id_Alignof then - Res_Type := Name.Decl_Dtype; - Res := New_Lit (Parse_Alignof (Res_Type)); - Next_Token; - return; - elsif Token_Sym = Id_Alloca then - Next_Expect (Tok_Left_Paren); - Next_Token; - Parse_Expression (null, Res, Res_Type); - -- Discard Res_Type. - Res_Type := Name.Decl_Dtype; - Res := New_Alloca (Res_Type.Type_Onode, Res); - Expect (Tok_Right_Paren); - Next_Token; - return; - elsif Token_Sym = Id_Offsetof then - Res_Type := Atype; - Res := New_Lit (Parse_Offsetof (Res_Type)); - Next_Token; - return; - else - Parse_Error ("unknown attribute name"); - end if; - -- Fall-through. - else - Parse_Error ("typed expression expected"); - end if; - elsif Tok = Tok_Left_Paren then - if Name.Kind /= Node_Function then - Parse_Error ("function name expected"); - end if; - declare - Constr : O_Assoc_List; - begin - Parse_Association (Constr, Name); - Res := New_Function_Call (Constr); - Res_Type := Name.Decl_Dtype; - -- Fall-through. - end; - elsif Name.Kind = Node_Object - or else Name.Kind = Decl_Param - then - -- Name. - declare - Lval : O_Lnode; - begin - Parse_Name (Name, Lval, Res_Type); - Res := New_Value (Lval); - end; - else - Parse_Error ("bad ident expression: " - & Token_Type'Image (Tok)); - end if; - - -- Continue. - -- R_TYPE and RES must be set. - if Tok = Tok_Dot then - if Stop_At_All then - return; - end if; - Next_Token; - if Tok = Tok_All then - if Res_Type.Kind /= Type_Access then - Parse_Error ("type of prefix is not an access"); - end if; - declare - N : O_Lnode; - begin - Next_Token; - N := New_Access_Element (Res); - Res_Type := Res_Type.Access_Dtype; - Parse_Lvalue (N, Res_Type); - Res := New_Value (N); - end; - return; - else - Parse_Error ("'.all' expected"); - end if; - end if; - end Parse_Named_Expression; - - procedure Parse_Primary_Expression (Atype : Node_Acc; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - begin - case Tok is - when Tok_Num - | Tok_Float_Num => - if Atype = null then - Parse_Error ("numeric literal without type context"); - end if; - Res_Type := Atype; - Res := New_Lit (Parse_Typed_Literal (Atype)); - when Tok_Ident => - declare - N : Node_Acc; - begin - N := Get_Decl (Token_Sym); - Next_Token; - Parse_Named_Expression (Atype, N, False, Res, Res_Type); - end; - when Tok_Left_Paren => - Next_Token; - Parse_Expression (Atype, Res, Res_Type); - Expect (Tok_Right_Paren); - Next_Token; - when others => - Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); - end case; - end Parse_Primary_Expression; - - -- Parse '-' EXPR, 'not' EXPR, 'abs' EXPR or EXPR. - procedure Parse_Unary_Expression (Atype : Node_Acc; - Res : out O_Enode; - Res_Type : out Node_Acc) - is - begin - case Tok is - when Tok_Minus => - Next_Token; - Parse_Primary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Neg_Ov, Res); - when Tok_Not => - Next_Token; - Parse_Unary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Not, Res); - when Tok_Abs => - Next_Token; - Parse_Unary_Expression (Atype, Res, Res_Type); - Res := New_Monadic_Op (ON_Abs_Ov, Res); - when others => - Parse_Primary_Expression (Atype, Res, Res_Type); - end case; - end Parse_Unary_Expression; - - function Check_Sharp (Op_Ov : ON_Op_Kind) return ON_Op_Kind is - begin - Next_Expect (Tok_Sharp); - Next_Token; - return Op_Ov; - end Check_Sharp; - - procedure Parse_Expression (Expr_Type : Node_Acc; - Expr : out O_Enode; - Res_Type : out Node_Acc) - is - Op_Type : Node_Acc; - L : O_Enode; - R : O_Enode; - Op : ON_Op_Kind; - begin - if Expr_Type = null or else Expr_Type.Kind = Type_Boolean then - -- The type of the expression isn't known, as this can be a - -- comparaison operator. - Op_Type := null; - else - Op_Type := Expr_Type; - end if; - Parse_Unary_Expression (Op_Type, L, Res_Type); - case Tok is - when Tok_Div => - Op := Check_Sharp (ON_Div_Ov); - when Tok_Plus => - Op := Check_Sharp (ON_Add_Ov); - when Tok_Minus => - Op := Check_Sharp (ON_Sub_Ov); - when Tok_Star => - Op := Check_Sharp (ON_Mul_Ov); - when Tok_Mod => - Op := Check_Sharp (ON_Mod_Ov); - when Tok_Rem => - Op := Check_Sharp (ON_Rem_Ov); - - when Tok_Equal => - Op := ON_Eq; - when Tok_Not_Equal => - Op := ON_Neq; - when Tok_Greater => - Op := ON_Gt; - when Tok_Greater_Eq => - Op := ON_Ge; - when Tok_Less => - Op := ON_Lt; - when Tok_Less_Eq => - Op := ON_Le; - - when Tok_Or => - Op := ON_Or; - Next_Token; - when Tok_And => - Op := ON_And; - Next_Token; - when Tok_Xor => - Op := ON_Xor; - Next_Token; - - when others => - Expr := L; - return; - end case; - if Op in ON_Compare_Op_Kind then - Next_Token; - end if; - - Parse_Unary_Expression (Res_Type, R, Res_Type); - case Op is - when ON_Dyadic_Op_Kind => - Expr := New_Dyadic_Op (Op, L, R); - when ON_Compare_Op_Kind => - if Expr_Type = null then - Parse_Error ("comparaison operator requires a type"); - end if; - Expr := New_Compare_Op (Op, L, R, Expr_Type.Type_Onode); - Res_Type := Expr_Type; - when others => - raise Program_Error; - end case; - end Parse_Expression; - - -- Expect and leave: next token - procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) - is - begin - loop - case Tok is - when Tok_Dot => - Next_Token; - if Tok = Tok_All then - if N_Type.Kind /= Type_Access then - Parse_Error ("type of prefix is not an access"); - end if; - N := New_Access_Element (New_Value (N)); - N_Type := N_Type.Access_Dtype; - Next_Token; - elsif Tok = Tok_Ident then - if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union - then - Parse_Error - ("type of prefix is neither a record nor an union"); - end if; - declare - Field : Node_Acc; - begin - Field := Find_Field_By_Name (N_Type); - N := New_Selected_Element (N, Field.Field_Fnode); - N_Type := Field.Field_Type; - Next_Token; - end; - else - Parse_Error - ("'.' must be followed by 'all' or a field name"); - end if; - when Tok_Left_Brack => - declare - V : O_Enode; - Bt : Node_Acc; - Res_Type : Node_Acc; - begin - Next_Token; - if N_Type.Kind = Type_Subarray then - Bt := N_Type.Subarray_Base; - else - Bt := N_Type; - end if; - if Bt.Kind /= Type_Array then - Parse_Error ("type of prefix is not an array"); - end if; - Parse_Expression (Bt.Array_Index, V, Res_Type); - if Tok = Tok_Elipsis then - N := New_Slice (N, Bt.Type_Onode, V); - Next_Token; - else - N := New_Indexed_Element (N, V); - N_Type := Bt.Array_Element; - end if; - Expect (Tok_Right_Brack); - Next_Token; - end; - when others => - return; - end case; - end loop; - end Parse_Lvalue; - - procedure Parse_Name (Prefix : Node_Acc; - Name : out O_Lnode; N_Type : out Node_Acc) - is - begin - case Prefix.Kind is - when Decl_Param => - Name := New_Obj (Prefix.Param_Node); - N_Type := Prefix.Decl_Dtype; - when Node_Object => - Name := New_Obj (Prefix.Obj_Node); - N_Type := Prefix.Decl_Dtype; - when Decl_Type => - declare - Val : O_Enode; - begin - Parse_Named_Expression (null, Prefix, True, Val, N_Type); - if N_Type /= Prefix.Decl_Dtype then - Parse_Error ("type doesn't match"); - end if; - if Tok = Tok_Dot then - Next_Token; - if Tok = Tok_All then - if N_Type.Kind /= Type_Access then - Parse_Error ("type of prefix is not an access"); - end if; - Name := New_Access_Element (Val); - N_Type := N_Type.Access_Dtype; - Next_Token; - else - Parse_Error ("'.all' expected"); - end if; - else - Parse_Error ("name expected"); - end if; - end; - when others => - Parse_Error ("invalid name"); - end case; - Parse_Lvalue (Name, N_Type); - end Parse_Name; - - -- Expect: '(' - -- Let: next token. - procedure Parse_Association (Constr : in out O_Assoc_List; Decl : Node_Acc) - is - Param : Node_Acc; - Expr : O_Enode; - Expr_Type : Node_Acc; - begin - Start_Association (Constr, Decl.Subprg_Node); - if Tok /= Tok_Left_Paren then - Parse_Error ("'(' expected for a subprogram call"); - end if; - Next_Token; - Param := Decl.Subprg_Params; - while Tok /= Tok_Right_Paren loop - if Param = null then - Parse_Error ("too many parameters"); - end if; - Parse_Expression (Param.Decl_Dtype, Expr, Expr_Type); - New_Association (Constr, Expr); - Param := Param.Param_Next; - exit when Tok /= Tok_Comma; - Next_Token; - end loop; - if Param /= null then - Parse_Error ("missing parameters"); - end if; - if Tok /= Tok_Right_Paren then - Parse_Error ("')' expected to finish a subprogram call, found " - & Token_Type'Image (Tok)); - end if; - Next_Token; - end Parse_Association; - - type Loop_Info; - type Loop_Info_Acc is access Loop_Info; - type Loop_Info is record - Num : Natural; - Blk : O_Snode; - Prev : Loop_Info_Acc; - end record; - procedure Free is new Ada.Unchecked_Deallocation - (Name => Loop_Info_Acc, Object => Loop_Info); - - Loop_Stack : Loop_Info_Acc := null; - - function Find_Loop (N : Natural) return Loop_Info_Acc - is - Res : Loop_Info_Acc; - begin - Res := Loop_Stack; - while Res /= null loop - if Res.Num = N then - return Res; - end if; - Res := Res.Prev; - end loop; - return null; - end Find_Loop; - - Current_Subprg : Node_Acc := null; - - procedure Parse_Statement; - - -- Expect : next token - -- Let: next token - procedure Parse_Statements is - begin - loop - exit when Tok = Tok_End; - exit when Tok = Tok_Else; - exit when Tok = Tok_When; - Parse_Statement; - end loop; - end Parse_Statements; - - -- Expect : next token - -- Let: next token - procedure Parse_Statement is - begin - if Flag_Renumber then - New_Debug_Line_Stmt (Lineno); - end if; - - case Tok is - when Tok_Comment => - Next_Token; - - when Tok_Declare => - Start_Declare_Stmt; - Parse_Compound_Statement; - Expect (Tok_Semicolon); - Next_Token; - Finish_Declare_Stmt; - - when Tok_Line_Number => - Next_Expect (Tok_Num); - if Flag_Renumber = False then - New_Debug_Line_Stmt (Natural (Token_Number)); - end if; - Next_Token; - - when Tok_If => - declare - If_Blk : O_If_Block; - Cond : O_Enode; - Cond_Type : Node_Acc; - begin - Next_Token; - Parse_Expression (null, Cond, Cond_Type); - Start_If_Stmt (If_Blk, Cond); - Expect (Tok_Then); - Next_Token; - Parse_Statements; - if Tok = Tok_Else then - Next_Token; - New_Else_Stmt (If_Blk); - Parse_Statements; - end if; - Finish_If_Stmt (If_Blk); - Expect (Tok_End); - Next_Expect (Tok_If); - Next_Expect (Tok_Semicolon); - Next_Token; - end; - - when Tok_Loop => - declare - Info : Loop_Info_Acc; - Num : Natural; - begin - Next_Expect (Tok_Num); - Num := Natural (Token_Number); - if Find_Loop (Num) /= null then - Parse_Error ("loop label already defined"); - end if; - Info := new Loop_Info; - Info.Num := Num; - Info.Prev := Loop_Stack; - Loop_Stack := Info; - Start_Loop_Stmt (Info.Blk); - Next_Expect (Tok_Colon); - Next_Token; - Parse_Statements; - Finish_Loop_Stmt (Info.Blk); - Next_Expect (Tok_Loop); - Next_Expect (Tok_Semicolon); - Loop_Stack := Info.Prev; - Free (Info); - Next_Token; - end; - - when Tok_Exit - | Tok_Next => - declare - Label : Loop_Info_Acc; - Etok : Token_Type; - begin - Etok := Tok; - Next_Expect (Tok_Loop); - Next_Expect (Tok_Num); - Label := Find_Loop (Natural (Token_Number)); - if Label = null then - Parse_Error ("no such loop"); - end if; - if Etok = Tok_Exit then - New_Exit_Stmt (Label.Blk); - else - New_Next_Stmt (Label.Blk); - end if; - Next_Expect (Tok_Semicolon); - Next_Token; - end; - - when Tok_Return => - declare - Res : O_Enode; - Res_Type : Node_Acc; - begin - Next_Token; - if Tok /= Tok_Semicolon then - Parse_Expression (Current_Subprg.Decl_Dtype, Res, Res_Type); - New_Return_Stmt (Res); - if Tok /= Tok_Semicolon then - Parse_Error ("';' expected at end of return statement"); - end if; - else - New_Return_Stmt; - end if; - Next_Token; - end; - - when Tok_Ident => - -- This is either a procedure call or an assignment. - declare - Inter : Node_Acc; - begin - Inter := Get_Decl (Token_Sym); - Next_Token; - if Tok = Tok_Left_Paren then - -- A procedure call. - declare - Constr : O_Assoc_List; - begin - Parse_Association (Constr, Inter); - New_Procedure_Call (Constr); - if Tok /= Tok_Semicolon then - Parse_Error ("';' expected after call"); - end if; - Next_Token; - return; - end; - else - -- An assignment. - declare - Name : O_Lnode; - Expr : O_Enode; - Expr_Type : Node_Acc; - N_Type : Node_Acc; - begin - Parse_Name (Inter, Name, N_Type); - if Tok /= Tok_Assign then - Parse_Error ("`:=' expected after a variable"); - end if; - Next_Token; - Parse_Expression (N_Type, Expr, Expr_Type); - New_Assign_Stmt (Name, Expr); - if Tok /= Tok_Semicolon then - Parse_Error ("';' expected at end of assignment"); - end if; - Next_Token; - return; - end; - end if; - end; - - when Tok_Case => - declare - Case_Blk : O_Case_Block; - L : O_Cnode; - Choice : O_Enode; - Choice_Type : Node_Acc; - begin - Next_Token; - Parse_Expression (null, Choice, Choice_Type); - Start_Case_Stmt (Case_Blk, Choice); - Expect (Tok_Is); - Next_Token; - loop - exit when Tok = Tok_End; - Expect (Tok_When); - Next_Token; - Start_Choice (Case_Blk); - loop - if Tok = Tok_Default then - New_Default_Choice (Case_Blk); - Next_Token; - else - L := Parse_Typed_Literal (Choice_Type); - if Tok = Tok_Elipsis then - Next_Token; - New_Range_Choice - (Case_Blk, L, Parse_Typed_Literal (Choice_Type)); - else - New_Expr_Choice (Case_Blk, L); - end if; - end if; - exit when Tok = Tok_Arrow; - Expect (Tok_Comma); - Next_Token; - end loop; - -- Skip '=>'. - Next_Token; - Finish_Choice (Case_Blk); - Parse_Statements; - end loop; - Finish_Case_Stmt (Case_Blk); - Expect (Tok_End); - Next_Expect (Tok_Case); - Next_Expect (Tok_Semicolon); - Next_Token; - end; - when others => - Parse_Error ("bad statement: " & Token_Type'Image (Tok)); - end case; - end Parse_Statement; - - procedure Parse_Compound_Statement is - begin - if Tok /= Tok_Declare then - Parse_Error ("'declare' expected to start a statements block"); - end if; - Next_Token; - - Push_Scope; - - -- Parse declarations. - while Tok /= Tok_Begin loop - Parse_Declaration; - end loop; - Next_Token; - - -- Parse statements. - Parse_Statements; - Expect (Tok_End); - Next_Token; - - Pop_Scope; - end Parse_Compound_Statement; - - -- Parse (P1 : T1; P2: T2; ...) - function Parse_Parameter_List return Node_Acc - is - First, Last : Node_Acc; - P : Node_Acc; - begin - Expect (Tok_Left_Paren); - Next_Token; - if Tok = Tok_Right_Paren then - Next_Token; - return null; - end if; - First := null; - Last := null; - loop - Expect (Tok_Ident); - P := new Node'(Kind => Decl_Param, - Decl_Dtype => null, - Decl_Storage => O_Storage_Public, - Param_Node => O_Dnode_Null, - Param_Name => Token_Sym, - Param_Next => null); - -- Link - if Last = null then - First := P; - else - Last.Param_Next := P; - end if; - Last := P; - Next_Expect (Tok_Colon); - Next_Token; - P.Decl_Dtype := Parse_Type; - exit when Tok = Tok_Right_Paren; - Expect (Tok_Semicolon); - Next_Token; - end loop; - Next_Token; - return First; - end Parse_Parameter_List; - - procedure Create_Interface_List (Constr : in out O_Inter_List; - First_Inter : Node_Acc) - is - Inter : Node_Acc; - begin - Inter := First_Inter; - while Inter /= null loop - New_Interface_Decl (Constr, Inter.Param_Node, Inter.Param_Name.Ident, - Inter.Decl_Dtype.Type_Onode); - Inter := Inter.Param_Next; - end loop; - end Create_Interface_List; - - procedure Check_Parameter_List (List : Node_Acc) - is - Param : Node_Acc; - begin - Next_Expect (Tok_Left_Paren); - Next_Token; - Param := List; - while Tok /= Tok_Right_Paren loop - if Param = null then - Parse_Error ("subprogram redefined with more parameters"); - end if; - Expect (Tok_Ident); - if Token_Sym /= Param.Param_Name then - Parse_Error ("subprogram redefined with different parameter name"); - end if; - Next_Expect (Tok_Colon); - Next_Token; - if Parse_Type /= Param.Decl_Dtype then - Parse_Error ("subprogram redefined with different parameter type"); - end if; - Param := Param.Param_Next; - exit when Tok = Tok_Right_Paren; - Expect (Tok_Semicolon); - Next_Token; - end loop; - Expect (Tok_Right_Paren); - Next_Token; - if Param /= null then - Parse_Error ("subprogram redefined with less parameters"); - end if; - end Check_Parameter_List; - - procedure Parse_Subprogram_Body (Subprg : Node_Acc) - is - Param : Node_Acc; - Prev_Subprg : Node_Acc; - begin - Prev_Subprg := Current_Subprg; - Current_Subprg := Subprg; - - Start_Subprogram_Body (Subprg.Subprg_Node); - Push_Scope; - - -- Put parameters in the current scope. - Param := Subprg.Subprg_Params; - while Param /= null loop - Add_Decl (Param.Param_Name, Param); - Param := Param.Param_Next; - end loop; - - Parse_Compound_Statement; - - Pop_Scope; - Finish_Subprogram_Body; - - Current_Subprg := Prev_Subprg; - end Parse_Subprogram_Body; - - procedure Parse_Function_Definition (Storage : O_Storage) - is - Constr : O_Inter_List; - Sym : Syment_Acc; - N : Node_Acc; - begin - Expect (Tok_Function); - Next_Expect (Tok_Ident); - Sym := Token_Sym; - if Sym.Name /= null then - N := Get_Decl (Sym); - Check_Parameter_List (N.Subprg_Params); - Expect (Tok_Return); - Next_Expect (Tok_Ident); - Next_Token; - else - N := new Node'(Kind => Node_Function, - Decl_Dtype => null, - Decl_Storage => Storage, - Subprg_Node => O_Dnode_Null, - Subprg_Name => Sym, - Subprg_Params => null); - Next_Token; - N.Subprg_Params := Parse_Parameter_List; - Expect (Tok_Return); - Next_Token; - N.Decl_Dtype := Parse_Type; - - Start_Function_Decl (Constr, N.Subprg_Name.Ident, Storage, - N.Decl_Dtype.Type_Onode); - Create_Interface_List (Constr, N.Subprg_Params); - Finish_Subprogram_Decl (Constr, N.Subprg_Node); - - Add_Decl (Sym, N); - end if; - - if Tok = Tok_Declare then - Parse_Subprogram_Body (N); - end if; - end Parse_Function_Definition; - - procedure Parse_Procedure_Definition (Storage : O_Storage) - is - Constr : O_Inter_List; - Sym : Syment_Acc; - N : Node_Acc; - begin - Expect (Tok_Procedure); - Next_Expect (Tok_Ident); - Sym := Token_Sym; - if Sym.Name /= null then - N := Get_Decl (Sym); - Check_Parameter_List (N.Subprg_Params); - else - N := new Node'(Kind => Node_Procedure, - Decl_Dtype => null, - Decl_Storage => Storage, - Subprg_Node => O_Dnode_Null, - Subprg_Name => Sym, - Subprg_Params => null); - Next_Token; - N.Subprg_Params := Parse_Parameter_List; - - Start_Procedure_Decl (Constr, N.Subprg_Name.Ident, Storage); - Create_Interface_List (Constr, N.Subprg_Params); - Finish_Subprogram_Decl (Constr, N.Subprg_Node); - - Add_Decl (Sym, N); - end if; - - if Tok = Tok_Declare then - Parse_Subprogram_Body (N); - end if; - end Parse_Procedure_Definition; - - function Parse_Address (Prefix : Node_Acc) return O_Enode - is - Pfx : Node_Acc; - N : O_Lnode; - N_Type : Node_Acc; - Res : O_Enode; - Attr : Syment_Acc; - T : O_Tnode; - begin - Attr := Token_Sym; - Next_Expect (Tok_Left_Paren); - Next_Expect (Tok_Ident); - Pfx := Get_Decl (Token_Sym); - T := Prefix.Decl_Dtype.Type_Onode; - if Attr = Id_Subprg_Addr then - Expect (Tok_Ident); - Pfx := Get_Decl (Token_Sym); - if Pfx.Kind not in Nodes_Subprogram then - Parse_Error ("subprogram identifier expected"); - end if; - Res := New_Lit (New_Subprogram_Address (Pfx.Subprg_Node, T)); - Next_Token; - else - Next_Token; - Parse_Name (Pfx, N, N_Type); - if Attr = Id_Address then - Res := New_Address (N, T); - elsif Attr = Id_Unchecked_Address then - Res := New_Unchecked_Address (N, T); - else - Parse_Error ("address attribute expected"); - end if; - end if; - Expect (Tok_Right_Paren); - Next_Token; - return Res; - end Parse_Address; - - function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode - is - Pfx : Node_Acc; - Res : O_Cnode; - Attr : Syment_Acc; - T : O_Tnode; - begin - Attr := Token_Sym; - Next_Expect (Tok_Left_Paren); - Next_Expect (Tok_Ident); - Pfx := Get_Decl (Token_Sym); - T := Prefix.Decl_Dtype.Type_Onode; - if Attr = Id_Subprg_Addr then - Expect (Tok_Ident); - Pfx := Get_Decl (Token_Sym); - if Pfx.Kind not in Nodes_Subprogram then - Parse_Error ("subprogram identifier expected"); - end if; - Res := New_Subprogram_Address (Pfx.Subprg_Node, T); - Next_Token; - else - Next_Token; - if Attr = Id_Address then - Res := New_Global_Address (Pfx.Obj_Node, T); - elsif Attr = Id_Unchecked_Address then - Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T); - else - Parse_Error ("address attribute expected"); - end if; - end if; - Expect (Tok_Right_Paren); - return Res; - end Parse_Constant_Address; - - function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode - is - Res : O_Cnode; - begin - case Atype.Kind is - when Type_Subarray => - declare - Constr : O_Array_Aggr_List; - El : Node_Acc; - begin - Expect (Tok_Left_Brace); - Next_Token; - Start_Array_Aggr (Constr, Atype.Type_Onode); - El := Atype.Subarray_Base.Array_Element; - for I in Natural loop - exit when Tok = Tok_Right_Brace; - if I /= 0 then - Expect (Tok_Comma); - Next_Token; - end if; - New_Array_Aggr_El (Constr, Parse_Constant_Value (El)); - end loop; - Finish_Array_Aggr (Constr, Res); - Next_Token; - return Res; - end; - when Type_Unsigned - | Type_Signed - | Type_Enum - | Type_Float - | Type_Boolean - | Type_Access => - --return Parse_Primary_Expression (Atype); - return Parse_Typed_Literal (Atype); - when Type_Record => - declare - Constr : O_Record_Aggr_List; - Field : Node_Acc; - begin - Expect (Tok_Left_Brace); - Next_Token; - Start_Record_Aggr (Constr, Atype.Type_Onode); - Field := Atype.Record_Union_Fields; - while Field /= null loop - if Tok = Tok_Dot then - Next_Expect (Tok_Ident); - if Token_Sym /= Field.Field_Ident then - Parse_Error ("bad field name"); - end if; - Next_Expect (Tok_Equal); - Next_Token; - end if; - New_Record_Aggr_El - (Constr, Parse_Constant_Value (Field.Field_Type)); - Field := Field.Field_Next; - if Field /= null then - Expect (Tok_Comma); - Next_Token; - end if; - end loop; - Finish_Record_Aggr (Constr, Res); - Expect (Tok_Right_Brace); - Next_Token; - return Res; - end; - when Type_Union => - declare - Field : Node_Acc; - begin - Expect (Tok_Left_Brace); - Next_Token; - Expect (Tok_Dot); - Next_Expect (Tok_Ident); - Field := Find_Field_By_Name (Atype); - Next_Expect (Tok_Equal); - Next_Token; - Res := New_Union_Aggr - (Atype.Type_Onode, Field.Field_Fnode, - Parse_Constant_Value (Field.Field_Type)); - Expect (Tok_Right_Brace); - Next_Token; - return Res; - end; - when others => - raise Program_Error; - end case; - end Parse_Constant_Value; - - procedure Parse_Constant_Declaration (Storage : O_Storage) - is - N : Node_Acc; - Sym : Syment_Acc; - --Val : O_Cnode; - begin - Expect (Tok_Constant); - Next_Expect (Tok_Ident); - Sym := Token_Sym; - N := new Node'(Kind => Node_Object, - Decl_Dtype => null, - Decl_Storage => Storage, - Obj_Name => Sym.Ident, - Obj_Node => O_Dnode_Null); - Next_Expect (Tok_Colon); - Next_Token; - N.Decl_Dtype := Parse_Type; - New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); - Add_Decl (Sym, N); - --- if Storage /= O_Storage_External then --- Expect (Tok_Assign); --- Next_Token; --- Start_Const_Value (N.Obj_Node); --- Val := Parse_Constant_Value (N.Decl_Dtype); --- Finish_Const_Value (N.Obj_Node, Val); --- end if; - end Parse_Constant_Declaration; - - procedure Parse_Constant_Value_Declaration - is - N : Node_Acc; - Val : O_Cnode; - begin - Next_Expect (Tok_Ident); - N := Get_Decl (Token_Sym); - if N.Kind /= Node_Object then - Parse_Error ("name of a constant expected"); - end if; - -- FIXME: should check storage, - -- should check the object is a constant, - -- should check the object has no value. - Next_Expect (Tok_Assign); - Next_Token; - Start_Const_Value (N.Obj_Node); - Val := Parse_Constant_Value (N.Decl_Dtype); - Finish_Const_Value (N.Obj_Node, Val); - end Parse_Constant_Value_Declaration; - - procedure Parse_Var_Declaration (Storage : O_Storage) - is - N : Node_Acc; - Sym : Syment_Acc; - begin - Expect (Tok_Var); - Next_Expect (Tok_Ident); - Sym := Token_Sym; - N := new Node'(Kind => Node_Object, - Decl_Dtype => null, - Decl_Storage => Storage, - Obj_Name => Sym.Ident, - Obj_Node => O_Dnode_Null); - Next_Expect (Tok_Colon); - Next_Token; - N.Decl_Dtype := Parse_Type; - New_Var_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); - Add_Decl (Sym, N); - end Parse_Var_Declaration; - - procedure Parse_Stored_Decl (Storage : O_Storage) - is - begin - Next_Token; - if Tok = Tok_Function then - Parse_Function_Definition (Storage); - elsif Tok = Tok_Procedure then - Parse_Procedure_Definition (Storage); - elsif Tok = Tok_Constant then - Parse_Constant_Declaration (Storage); - elsif Tok = Tok_Var then - Parse_Var_Declaration (Storage); - else - Parse_Error ("function declaration expected"); - end if; - end Parse_Stored_Decl; - - procedure Parse_Declaration - is - Inter : Node_Acc; - S : Syment_Acc; - begin - if Flag_Renumber then - New_Debug_Line_Decl (Lineno); - end if; - - case Tok is - when Tok_Type => - Next_Token; - if Tok /= Tok_Ident then - Parse_Error ("identifier for type expected"); - end if; - S := Token_Sym; - Next_Expect (Tok_Is); - Next_Token; - if Is_Defined (S) then - Parse_Type_Completion (Get_Decl (S)); - else - Inter := new Node'(Kind => Decl_Type, - Decl_Storage => O_Storage_Public, - Decl_Dtype => Parse_Type); - Add_Decl (S, Inter); - New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode); - end if; - when Tok_External => - Parse_Stored_Decl (O_Storage_External); - when Tok_Private => - Parse_Stored_Decl (O_Storage_Private); - when Tok_Public => - Parse_Stored_Decl (O_Storage_Public); - when Tok_Local => - Parse_Stored_Decl (O_Storage_Local); - when Tok_Constant => - Parse_Constant_Value_Declaration; - when Tok_Comment => - New_Debug_Comment_Decl (Token_Ident (1 .. Token_Idlen)); - Next_Token; - return; - when Tok_File_Name => - if Flag_Renumber = False then - New_Debug_Filename_Decl (Token_Ident (1 .. Token_Idlen)); - end if; - Next_Token; - return; - when others => - Parse_Error ("declaration expected"); - end case; - Expect (Tok_Semicolon); - Next_Token; - end Parse_Declaration; - --- procedure Put (Str : String) --- is --- L : Integer; --- begin --- L := Write (Standout, Str'Address, Str'Length); --- end Put; - - function Parse (Filename : String_Acc) return Boolean - is - begin - -- Initialize symbol table. - Add_Keyword ("type", Tok_Type); - Add_Keyword ("return", Tok_Return); - Add_Keyword ("if", Tok_If); - Add_Keyword ("then", Tok_Then); - Add_Keyword ("else", Tok_Else); - Add_Keyword ("elsif", Tok_Elsif); - Add_Keyword ("loop", Tok_Loop); - Add_Keyword ("exit", Tok_Exit); - Add_Keyword ("next", Tok_Next); - Add_Keyword ("signed", Tok_Signed); - Add_Keyword ("unsigned", Tok_Unsigned); - Add_Keyword ("float", Tok_Float); - Add_Keyword ("is", Tok_Is); - Add_Keyword ("of", Tok_Of); - Add_Keyword ("all", Tok_All); - Add_Keyword ("not", Tok_Not); - Add_Keyword ("abs", Tok_Abs); - Add_Keyword ("or", Tok_Or); - Add_Keyword ("and", Tok_And); - Add_Keyword ("xor", Tok_Xor); - Add_Keyword ("mod", Tok_Mod); - Add_Keyword ("rem", Tok_Rem); - Add_Keyword ("array", Tok_Array); - Add_Keyword ("access", Tok_Access); - Add_Keyword ("record", Tok_Record); - Add_Keyword ("union", Tok_Union); - Add_Keyword ("end", Tok_End); - Add_Keyword ("boolean", Tok_Boolean); - Add_Keyword ("enum", Tok_Enum); - Add_Keyword ("external", Tok_External); - Add_Keyword ("private", Tok_Private); - Add_Keyword ("public", Tok_Public); - Add_Keyword ("local", Tok_Local); - Add_Keyword ("procedure", Tok_Procedure); - Add_Keyword ("function", Tok_Function); - Add_Keyword ("constant", Tok_Constant); - Add_Keyword ("var", Tok_Var); - Add_Keyword ("subarray", Tok_Subarray); - Add_Keyword ("declare", Tok_Declare); - Add_Keyword ("begin", Tok_Begin); - Add_Keyword ("end", Tok_End); - Add_Keyword ("null", Tok_Null); - Add_Keyword ("case", Tok_Case); - Add_Keyword ("when", Tok_When); - Add_Keyword ("default", Tok_Default); - - Id_Address := New_Symbol ("address"); - Id_Unchecked_Address := New_Symbol ("unchecked_address"); - Id_Subprg_Addr := New_Symbol ("subprg_addr"); - Id_Conv := New_Symbol ("conv"); - Id_Sizeof := New_Symbol ("sizeof"); - Id_Alignof := New_Symbol ("alignof"); - Id_Alloca := New_Symbol ("alloca"); - Id_Offsetof := New_Symbol ("offsetof"); - - -- Initialize the scanner. - Buf (1) := NUL; - Pos := 1; - Lineno := 1; - if Filename = null then - Fd := Standin; - File_Name := new String'("*stdin*"); - else - declare - Name : String (1 .. Filename'Length + 1); - --("C:\cygwin\home\tgingold\src\ortho\x86\tests\olang\ex2.ol", - begin - Name (1 .. Filename'Length) := Filename.all; - Name (Name'Last) := NUL; - File_Name := Filename; - Fd := Open_Read (Name'Address, Text); - if Fd = Invalid_FD then - Puterr ("cannot open '" & Filename.all & '''); - Newline_Err; - return False; - end if; - end; - end if; - - New_Debug_Filename_Decl (File_Name.all); - - Push_Scope; - Next_Token; - while Tok /= Tok_Eof loop - Parse_Declaration; - end loop; - Pop_Scope; - - if Fd /= Standin then - Close (Fd); - end if; - return True; - exception - when E : others => - Puterr (Ada.Exceptions.Exception_Information (E)); - raise; - end Parse; -end Ortho_Front; diff --git a/ortho/ortho_front.ads b/ortho/ortho_front.ads deleted file mode 100644 index 1d20e15d7..000000000 --- a/ortho/ortho_front.ads +++ /dev/null @@ -1,41 +0,0 @@ --- Ortho front-end specifications. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package Ortho_Front is - type String_Acc is access String; - - -- Called before decode_option. - -- This procedure can only do internal initializations. It cannot call - -- ortho subprograms. - procedure Init; - - -- An ortho back-end decodes the command line. Unknown options may - -- be decoded by the user, with this function. - -- When an ortho back-end encounter an unknown option, it sets OPT with - -- this option and ARG with the next one, if any. - -- - -- DECODE_OPTION must return the number of argument used, ie: - -- 0 if OPT is unknown. - -- 1 if OPT is known but ARG is unused. - -- 2 if OPT is known and ARG used. - function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural; - - -- Start to parse file FILENAME. - -- Return False in case of error. - function Parse (Filename : String_Acc) return Boolean; -end Ortho_Front; diff --git a/ortho/ortho_jit.ads b/ortho/ortho_jit.ads deleted file mode 100644 index 89c3663f3..000000000 --- a/ortho/ortho_jit.ads +++ /dev/null @@ -1,43 +0,0 @@ --- Ortho JIT specifications. --- Copyright (C) 2009 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; use System; -with Ortho_Nodes; use Ortho_Nodes; - -package Ortho_Jit is - -- Initialize the whole engine. - procedure Init; - - -- Set address of non-defined global variables or functions. - procedure Set_Address (Decl : O_Dnode; Addr : Address); - -- Get address of a global. - function Get_Address (Decl : O_Dnode) return Address; - - -- Do link. - procedure Link (Status : out Boolean); - - -- Release memory (but the generated code). - procedure Finish; - - function Decode_Option (Option : String) return Boolean; - procedure Disp_Help; - - -- Return the name of the code generator, to be displayed by --version. - function Get_Jit_Name return String; -end Ortho_Jit; - diff --git a/ortho/ortho_nodes.common.ads b/ortho/ortho_nodes.common.ads deleted file mode 100644 index 178187482..000000000 --- a/ortho/ortho_nodes.common.ads +++ /dev/null @@ -1,453 +0,0 @@ --- Ortho specifications. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL 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, or (at your option) any later --- version. --- --- GHDL 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 GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; - --- Interface to create nodes. -package ORTHO_NODES is - - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - type O_Dnode is private; - type O_Fnode is private; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- Type definitions -- - ------------------------ - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - 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; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record ATYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - ------------------- - -- Expressions -- - ------------------- - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (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. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - -private - --- PRIVATE PART is defined by ortho_nodes.ads in one of the subdirectory. -end ORTHO_NODES; |