diff options
Diffstat (limited to 'src/ortho')
129 files changed, 42281 insertions, 0 deletions
diff --git a/src/ortho/Makefile.inc b/src/ortho/Makefile.inc new file mode 100644 index 000000000..597aaeff1 --- /dev/null +++ b/src/ortho/Makefile.inc @@ -0,0 +1,38 @@ +# 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/src/ortho/debug/Makefile b/src/ortho/debug/Makefile new file mode 100644 index 000000000..0c15111ef --- /dev/null +++ b/src/ortho/debug/Makefile @@ -0,0 +1,47 @@ +# -*- 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/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb new file mode 100644 index 000000000..2725668bb --- /dev/null +++ b/src/ortho/debug/ortho_debug-disp.adb @@ -0,0 +1,1064 @@ +-- 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/src/ortho/debug/ortho_debug-disp.ads b/src/ortho/debug/ortho_debug-disp.ads new file mode 100644 index 000000000..c365a3530 --- /dev/null +++ b/src/ortho/debug/ortho_debug-disp.ads @@ -0,0 +1,29 @@ +-- 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/src/ortho/debug/ortho_debug-main.adb b/src/ortho/debug/ortho_debug-main.adb new file mode 100644 index 000000000..b470deaab --- /dev/null +++ b/src/ortho/debug/ortho_debug-main.adb @@ -0,0 +1,151 @@ +-- 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/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb new file mode 100644 index 000000000..8285a6473 --- /dev/null +++ b/src/ortho/debug/ortho_debug.adb @@ -0,0 +1,1931 @@ +-- 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/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads new file mode 100644 index 000000000..69ee16cf7 --- /dev/null +++ b/src/ortho/debug/ortho_debug.private.ads @@ -0,0 +1,467 @@ +-- 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/src/ortho/debug/ortho_debug_front.ads b/src/ortho/debug/ortho_debug_front.ads new file mode 100644 index 000000000..17e32c9ed --- /dev/null +++ b/src/ortho/debug/ortho_debug_front.ads @@ -0,0 +1,20 @@ +-- 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/src/ortho/debug/ortho_ident.ads b/src/ortho/debug/ortho_ident.ads new file mode 100644 index 000000000..46aa8854d --- /dev/null +++ b/src/ortho/debug/ortho_ident.ads @@ -0,0 +1,20 @@ +-- 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/src/ortho/debug/ortho_ident_hash.adb b/src/ortho/debug/ortho_ident_hash.adb new file mode 100644 index 000000000..60ab89586 --- /dev/null +++ b/src/ortho/debug/ortho_ident_hash.adb @@ -0,0 +1,72 @@ +-- 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/src/ortho/debug/ortho_ident_hash.ads b/src/ortho/debug/ortho_ident_hash.ads new file mode 100644 index 000000000..a6e4a56cc --- /dev/null +++ b/src/ortho/debug/ortho_ident_hash.ads @@ -0,0 +1,46 @@ +-- 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/src/ortho/debug/ortho_ident_simple.adb b/src/ortho/debug/ortho_ident_simple.adb new file mode 100644 index 000000000..83b9756f8 --- /dev/null +++ b/src/ortho/debug/ortho_ident_simple.adb @@ -0,0 +1,44 @@ +-- 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/src/ortho/debug/ortho_ident_simple.ads b/src/ortho/debug/ortho_ident_simple.ads new file mode 100644 index 000000000..f94fe1938 --- /dev/null +++ b/src/ortho/debug/ortho_ident_simple.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/debug/ortho_nodes.ads b/src/ortho/debug/ortho_nodes.ads new file mode 100644 index 000000000..8ade66722 --- /dev/null +++ b/src/ortho/debug/ortho_nodes.ads @@ -0,0 +1,21 @@ +-- 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/src/ortho/gcc/Makefile b/src/ortho/gcc/Makefile new file mode 100644 index 000000000..5aafb31c7 --- /dev/null +++ b/src/ortho/gcc/Makefile @@ -0,0 +1,86 @@ +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/src/ortho/gcc/Makefile.conf.linux b/src/ortho/gcc/Makefile.conf.linux new file mode 100644 index 000000000..00ea91728 --- /dev/null +++ b/src/ortho/gcc/Makefile.conf.linux @@ -0,0 +1,4 @@ +# Example Makefile.conf +# Copy this file to Makefile.conf and edit as necessary for your platform + +HOST_LIBS = -ldl -lstdc++ diff --git a/src/ortho/gcc/lang.opt b/src/ortho/gcc/lang.opt new file mode 100644 index 000000000..562fbe08d --- /dev/null +++ b/src/ortho/gcc/lang.opt @@ -0,0 +1,96 @@ +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/src/ortho/gcc/ortho-lang.c b/src/ortho/gcc/ortho-lang.c new file mode 100644 index 000000000..c19012e6e --- /dev/null +++ b/src/ortho/gcc/ortho-lang.c @@ -0,0 +1,2191 @@ +/* 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/src/ortho/gcc/ortho_gcc-main.adb b/src/ortho/gcc/ortho_gcc-main.adb new file mode 100644 index 000000000..70c8a7f79 --- /dev/null +++ b/src/ortho/gcc/ortho_gcc-main.adb @@ -0,0 +1,42 @@ +-- 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/src/ortho/gcc/ortho_gcc-main.ads b/src/ortho/gcc/ortho_gcc-main.ads new file mode 100644 index 000000000..4bd73a1b6 --- /dev/null +++ b/src/ortho/gcc/ortho_gcc-main.ads @@ -0,0 +1 @@ +procedure Ortho_Gcc.Main; diff --git a/src/ortho/gcc/ortho_gcc.adb b/src/ortho/gcc/ortho_gcc.adb new file mode 100644 index 000000000..ae7b4f53b --- /dev/null +++ b/src/ortho/gcc/ortho_gcc.adb @@ -0,0 +1,121 @@ +-- 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/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads new file mode 100644 index 000000000..0afdc0887 --- /dev/null +++ b/src/ortho/gcc/ortho_gcc.ads @@ -0,0 +1,701 @@ +-- 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/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads new file mode 100644 index 000000000..cc2f556f0 --- /dev/null +++ b/src/ortho/gcc/ortho_gcc.private.ads @@ -0,0 +1,269 @@ +-- 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/src/ortho/gcc/ortho_gcc_front.ads b/src/ortho/gcc/ortho_gcc_front.ads new file mode 100644 index 000000000..553057b20 --- /dev/null +++ b/src/ortho/gcc/ortho_gcc_front.ads @@ -0,0 +1,2 @@ +with Ortho_Front; +package Ortho_Gcc_Front renames Ortho_Front; diff --git a/src/ortho/gcc/ortho_ident.adb b/src/ortho/gcc/ortho_ident.adb new file mode 100644 index 000000000..770fece2b --- /dev/null +++ b/src/ortho/gcc/ortho_ident.adb @@ -0,0 +1,56 @@ +-- 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/src/ortho/gcc/ortho_ident.ads b/src/ortho/gcc/ortho_ident.ads new file mode 100644 index 000000000..76c09ceb9 --- /dev/null +++ b/src/ortho/gcc/ortho_ident.ads @@ -0,0 +1,30 @@ +-- 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/src/ortho/gcc/ortho_nodes.ads b/src/ortho/gcc/ortho_nodes.ads new file mode 100644 index 000000000..7c6c4a076 --- /dev/null +++ b/src/ortho/gcc/ortho_nodes.ads @@ -0,0 +1,3 @@ +with Ortho_Gcc; + +package Ortho_Nodes renames Ortho_Gcc; diff --git a/src/ortho/llvm/Makefile b/src/ortho/llvm/Makefile new file mode 100644 index 000000000..135dbdf4b --- /dev/null +++ b/src/ortho/llvm/Makefile @@ -0,0 +1,30 @@ +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/src/ortho/llvm/llvm-analysis.ads b/src/ortho/llvm/llvm-analysis.ads new file mode 100644 index 000000000..bfecec579 --- /dev/null +++ b/src/ortho/llvm/llvm-analysis.ads @@ -0,0 +1,53 @@ +-- 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/src/ortho/llvm/llvm-bitwriter.ads b/src/ortho/llvm/llvm-bitwriter.ads new file mode 100644 index 000000000..3f9c518e4 --- /dev/null +++ b/src/ortho/llvm/llvm-bitwriter.ads @@ -0,0 +1,34 @@ +-- 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/src/ortho/llvm/llvm-cbindings.cpp b/src/ortho/llvm/llvm-cbindings.cpp new file mode 100644 index 000000000..e4d666ade --- /dev/null +++ b/src/ortho/llvm/llvm-cbindings.cpp @@ -0,0 +1,61 @@ +/* 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/src/ortho/llvm/llvm-core.ads b/src/ortho/llvm/llvm-core.ads new file mode 100644 index 000000000..74a47484f --- /dev/null +++ b/src/ortho/llvm/llvm-core.ads @@ -0,0 +1,1279 @@ +-- 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/src/ortho/llvm/llvm-executionengine.ads b/src/ortho/llvm/llvm-executionengine.ads new file mode 100644 index 000000000..72d4cda2f --- /dev/null +++ b/src/ortho/llvm/llvm-executionengine.ads @@ -0,0 +1,163 @@ +-- 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/src/ortho/llvm/llvm-target.ads b/src/ortho/llvm/llvm-target.ads new file mode 100644 index 000000000..b7c35848a --- /dev/null +++ b/src/ortho/llvm/llvm-target.ads @@ -0,0 +1,84 @@ +-- 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/src/ortho/llvm/llvm-targetmachine.ads b/src/ortho/llvm/llvm-targetmachine.ads new file mode 100644 index 000000000..cbf074940 --- /dev/null +++ b/src/ortho/llvm/llvm-targetmachine.ads @@ -0,0 +1,122 @@ +-- 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/src/ortho/llvm/llvm-transforms-scalar.ads b/src/ortho/llvm/llvm-transforms-scalar.ads new file mode 100644 index 000000000..0f23ce87e --- /dev/null +++ b/src/ortho/llvm/llvm-transforms-scalar.ads @@ -0,0 +1,169 @@ +-- 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/src/ortho/llvm/llvm-transforms.ads b/src/ortho/llvm/llvm-transforms.ads new file mode 100644 index 000000000..d5a8011ce --- /dev/null +++ b/src/ortho/llvm/llvm-transforms.ads @@ -0,0 +1,21 @@ +-- 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/src/ortho/llvm/llvm.ads b/src/ortho/llvm/llvm.ads new file mode 100644 index 000000000..80d036b84 --- /dev/null +++ b/src/ortho/llvm/llvm.ads @@ -0,0 +1,21 @@ +-- 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/src/ortho/llvm/ortho_code_main.adb b/src/ortho/llvm/ortho_code_main.adb new file mode 100644 index 000000000..300bb32d1 --- /dev/null +++ b/src/ortho/llvm/ortho_code_main.adb @@ -0,0 +1,391 @@ +-- 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/src/ortho/llvm/ortho_ident.adb b/src/ortho/llvm/ortho_ident.adb new file mode 100644 index 000000000..e7b650539 --- /dev/null +++ b/src/ortho/llvm/ortho_ident.adb @@ -0,0 +1,134 @@ +-- 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/src/ortho/llvm/ortho_ident.ads b/src/ortho/llvm/ortho_ident.ads new file mode 100644 index 000000000..7d3955c02 --- /dev/null +++ b/src/ortho/llvm/ortho_ident.ads @@ -0,0 +1,42 @@ +-- 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/src/ortho/llvm/ortho_jit.adb b/src/ortho/llvm/ortho_jit.adb new file mode 100644 index 000000000..fdda667d9 --- /dev/null +++ b/src/ortho/llvm/ortho_jit.adb @@ -0,0 +1,151 @@ +-- 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/src/ortho/llvm/ortho_llvm-jit.adb b/src/ortho/llvm/ortho_llvm-jit.adb new file mode 100644 index 000000000..9155a02c7 --- /dev/null +++ b/src/ortho/llvm/ortho_llvm-jit.adb @@ -0,0 +1,55 @@ +-- 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/src/ortho/llvm/ortho_llvm-jit.ads b/src/ortho/llvm/ortho_llvm-jit.ads new file mode 100644 index 000000000..5296e2ed8 --- /dev/null +++ b/src/ortho/llvm/ortho_llvm-jit.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb new file mode 100644 index 000000000..dd8e64971 --- /dev/null +++ b/src/ortho/llvm/ortho_llvm.adb @@ -0,0 +1,2881 @@ +-- 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/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads new file mode 100644 index 000000000..8e68eb139 --- /dev/null +++ b/src/ortho/llvm/ortho_llvm.ads @@ -0,0 +1,737 @@ +-- 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/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads new file mode 100644 index 000000000..842a119b5 --- /dev/null +++ b/src/ortho/llvm/ortho_llvm.private.ads @@ -0,0 +1,305 @@ +-- 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/src/ortho/llvm/ortho_nodes.ads b/src/ortho/llvm/ortho_nodes.ads new file mode 100644 index 000000000..34d1dbbc9 --- /dev/null +++ b/src/ortho/llvm/ortho_nodes.ads @@ -0,0 +1,20 @@ +-- 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/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile new file mode 100644 index 000000000..19d5d26aa --- /dev/null +++ b/src/ortho/mcode/Makefile @@ -0,0 +1,37 @@ +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/src/ortho/mcode/binary_file-coff.adb b/src/ortho/mcode/binary_file-coff.adb new file mode 100644 index 000000000..cf3cba3f4 --- /dev/null +++ b/src/ortho/mcode/binary_file-coff.adb @@ -0,0 +1,407 @@ +-- 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/src/ortho/mcode/binary_file-coff.ads b/src/ortho/mcode/binary_file-coff.ads new file mode 100644 index 000000000..e671555ea --- /dev/null +++ b/src/ortho/mcode/binary_file-coff.ads @@ -0,0 +1,23 @@ +-- 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/src/ortho/mcode/binary_file-elf.adb b/src/ortho/mcode/binary_file-elf.adb new file mode 100644 index 000000000..329dbacd3 --- /dev/null +++ b/src/ortho/mcode/binary_file-elf.adb @@ -0,0 +1,679 @@ +-- 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/src/ortho/mcode/binary_file-elf.ads b/src/ortho/mcode/binary_file-elf.ads new file mode 100644 index 000000000..e0d3a4d2a --- /dev/null +++ b/src/ortho/mcode/binary_file-elf.ads @@ -0,0 +1,22 @@ +-- 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/src/ortho/mcode/binary_file-memory.adb b/src/ortho/mcode/binary_file-memory.adb new file mode 100644 index 000000000..a37af9cb7 --- /dev/null +++ b/src/ortho/mcode/binary_file-memory.adb @@ -0,0 +1,101 @@ +-- 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/src/ortho/mcode/binary_file-memory.ads b/src/ortho/mcode/binary_file-memory.ads new file mode 100644 index 000000000..a205da527 --- /dev/null +++ b/src/ortho/mcode/binary_file-memory.ads @@ -0,0 +1,25 @@ +-- 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/src/ortho/mcode/binary_file.adb b/src/ortho/mcode/binary_file.adb new file mode 100644 index 000000000..6043d7319 --- /dev/null +++ b/src/ortho/mcode/binary_file.adb @@ -0,0 +1,977 @@ +-- 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/src/ortho/mcode/binary_file.ads b/src/ortho/mcode/binary_file.ads new file mode 100644 index 000000000..1a2bf588d --- /dev/null +++ b/src/ortho/mcode/binary_file.ads @@ -0,0 +1,305 @@ +-- 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/src/ortho/mcode/coff.ads b/src/ortho/mcode/coff.ads new file mode 100644 index 000000000..6ef9cdde9 --- /dev/null +++ b/src/ortho/mcode/coff.ads @@ -0,0 +1,208 @@ +-- 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/src/ortho/mcode/coffdump.adb b/src/ortho/mcode/coffdump.adb new file mode 100644 index 000000000..6384b6c27 --- /dev/null +++ b/src/ortho/mcode/coffdump.adb @@ -0,0 +1,274 @@ +-- 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/src/ortho/mcode/disa_sparc.adb b/src/ortho/mcode/disa_sparc.adb new file mode 100644 index 000000000..8c9176ff8 --- /dev/null +++ b/src/ortho/mcode/disa_sparc.adb @@ -0,0 +1,274 @@ +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/src/ortho/mcode/disa_sparc.ads b/src/ortho/mcode/disa_sparc.ads new file mode 100644 index 000000000..486dff977 --- /dev/null +++ b/src/ortho/mcode/disa_sparc.ads @@ -0,0 +1,15 @@ +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/src/ortho/mcode/disa_x86.adb b/src/ortho/mcode/disa_x86.adb new file mode 100644 index 000000000..1d2d48565 --- /dev/null +++ b/src/ortho/mcode/disa_x86.adb @@ -0,0 +1,997 @@ +-- 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/src/ortho/mcode/disa_x86.ads b/src/ortho/mcode/disa_x86.ads new file mode 100644 index 000000000..c215cf0a3 --- /dev/null +++ b/src/ortho/mcode/disa_x86.ads @@ -0,0 +1,34 @@ +-- 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/src/ortho/mcode/disassemble.ads b/src/ortho/mcode/disassemble.ads new file mode 100644 index 000000000..5c9811fed --- /dev/null +++ b/src/ortho/mcode/disassemble.ads @@ -0,0 +1,3 @@ +with Disa_X86; + +package Disassemble renames Disa_X86; diff --git a/src/ortho/mcode/dwarf.ads b/src/ortho/mcode/dwarf.ads new file mode 100644 index 000000000..40ee94f10 --- /dev/null +++ b/src/ortho/mcode/dwarf.ads @@ -0,0 +1,446 @@ +-- 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/src/ortho/mcode/elf32.adb b/src/ortho/mcode/elf32.adb new file mode 100644 index 000000000..ef58fe64b --- /dev/null +++ b/src/ortho/mcode/elf32.adb @@ -0,0 +1,48 @@ +-- 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/src/ortho/mcode/elf32.ads b/src/ortho/mcode/elf32.ads new file mode 100644 index 000000000..5afd317f6 --- /dev/null +++ b/src/ortho/mcode/elf32.ads @@ -0,0 +1,124 @@ +-- 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/src/ortho/mcode/elf64.ads b/src/ortho/mcode/elf64.ads new file mode 100644 index 000000000..217e5557a --- /dev/null +++ b/src/ortho/mcode/elf64.ads @@ -0,0 +1,105 @@ +-- 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/src/ortho/mcode/elf_arch.ads b/src/ortho/mcode/elf_arch.ads new file mode 100644 index 000000000..325c4e5e3 --- /dev/null +++ b/src/ortho/mcode/elf_arch.ads @@ -0,0 +1,2 @@ +with Elf_Arch32; +package Elf_Arch renames Elf_Arch32; diff --git a/src/ortho/mcode/elf_arch32.ads b/src/ortho/mcode/elf_arch32.ads new file mode 100644 index 000000000..5e987b1e6 --- /dev/null +++ b/src/ortho/mcode/elf_arch32.ads @@ -0,0 +1,37 @@ +-- 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/src/ortho/mcode/elf_arch64.ads b/src/ortho/mcode/elf_arch64.ads new file mode 100644 index 000000000..504cd66b3 --- /dev/null +++ b/src/ortho/mcode/elf_arch64.ads @@ -0,0 +1,37 @@ +-- 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/src/ortho/mcode/elf_common.adb b/src/ortho/mcode/elf_common.adb new file mode 100644 index 000000000..5d05a2dc7 --- /dev/null +++ b/src/ortho/mcode/elf_common.adb @@ -0,0 +1,48 @@ +-- 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/src/ortho/mcode/elf_common.ads b/src/ortho/mcode/elf_common.ads new file mode 100644 index 000000000..28186d094 --- /dev/null +++ b/src/ortho/mcode/elf_common.ads @@ -0,0 +1,250 @@ +-- 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/src/ortho/mcode/elfdump.adb b/src/ortho/mcode/elfdump.adb new file mode 100644 index 000000000..d49275912 --- /dev/null +++ b/src/ortho/mcode/elfdump.adb @@ -0,0 +1,267 @@ +-- 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/src/ortho/mcode/elfdumper.adb b/src/ortho/mcode/elfdumper.adb new file mode 100644 index 000000000..b3a3b70f2 --- /dev/null +++ b/src/ortho/mcode/elfdumper.adb @@ -0,0 +1,2818 @@ +-- 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/src/ortho/mcode/elfdumper.ads b/src/ortho/mcode/elfdumper.ads new file mode 100644 index 000000000..0227f0f41 --- /dev/null +++ b/src/ortho/mcode/elfdumper.ads @@ -0,0 +1,164 @@ +-- 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/src/ortho/mcode/hex_images.adb b/src/ortho/mcode/hex_images.adb new file mode 100644 index 000000000..a9dca324d --- /dev/null +++ b/src/ortho/mcode/hex_images.adb @@ -0,0 +1,71 @@ +-- 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/src/ortho/mcode/hex_images.ads b/src/ortho/mcode/hex_images.ads new file mode 100644 index 000000000..830d2ec43 --- /dev/null +++ b/src/ortho/mcode/hex_images.ads @@ -0,0 +1,26 @@ +-- 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/src/ortho/mcode/memsegs.ads b/src/ortho/mcode/memsegs.ads new file mode 100644 index 000000000..ff7f8947e --- /dev/null +++ b/src/ortho/mcode/memsegs.ads @@ -0,0 +1,3 @@ +with Memsegs_Mmap; +package Memsegs renames Memsegs_Mmap; + diff --git a/src/ortho/mcode/memsegs_c.c b/src/ortho/mcode/memsegs_c.c new file mode 100644 index 000000000..f0a0e27d5 --- /dev/null +++ b/src/ortho/mcode/memsegs_c.c @@ -0,0 +1,133 @@ +/* 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/src/ortho/mcode/memsegs_mmap.adb b/src/ortho/mcode/memsegs_mmap.adb new file mode 100644 index 000000000..1ee8e7bcf --- /dev/null +++ b/src/ortho/mcode/memsegs_mmap.adb @@ -0,0 +1,64 @@ +-- 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/src/ortho/mcode/memsegs_mmap.ads b/src/ortho/mcode/memsegs_mmap.ads new file mode 100644 index 000000000..ba7d76618 --- /dev/null +++ b/src/ortho/mcode/memsegs_mmap.ads @@ -0,0 +1,49 @@ +-- 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/src/ortho/mcode/ortho_code-abi.ads b/src/ortho/mcode/ortho_code-abi.ads new file mode 100644 index 000000000..e75b08509 --- /dev/null +++ b/src/ortho/mcode/ortho_code-abi.ads @@ -0,0 +1,3 @@ +with Ortho_Code.X86.Abi; + +package Ortho_Code.Abi renames Ortho_Code.X86.Abi; diff --git a/src/ortho/mcode/ortho_code-binary.adb b/src/ortho/mcode/ortho_code-binary.adb new file mode 100644 index 000000000..7bb6bdd28 --- /dev/null +++ b/src/ortho/mcode/ortho_code-binary.adb @@ -0,0 +1,37 @@ +-- 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/src/ortho/mcode/ortho_code-binary.ads b/src/ortho/mcode/ortho_code-binary.ads new file mode 100644 index 000000000..58c79d3b2 --- /dev/null +++ b/src/ortho/mcode/ortho_code-binary.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb new file mode 100644 index 000000000..d09a13c34 --- /dev/null +++ b/src/ortho/mcode/ortho_code-consts.adb @@ -0,0 +1,559 @@ +-- 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/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads new file mode 100644 index 000000000..0076bc6eb --- /dev/null +++ b/src/ortho/mcode/ortho_code-consts.ads @@ -0,0 +1,158 @@ +-- 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/src/ortho/mcode/ortho_code-debug.adb b/src/ortho/mcode/ortho_code-debug.adb new file mode 100644 index 000000000..0f3e01ab9 --- /dev/null +++ b/src/ortho/mcode/ortho_code-debug.adb @@ -0,0 +1,143 @@ +-- 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/src/ortho/mcode/ortho_code-debug.ads b/src/ortho/mcode/ortho_code-debug.ads new file mode 100644 index 000000000..03f550ac9 --- /dev/null +++ b/src/ortho/mcode/ortho_code-debug.ads @@ -0,0 +1,70 @@ +-- 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/src/ortho/mcode/ortho_code-decls.adb b/src/ortho/mcode/ortho_code-decls.adb new file mode 100644 index 000000000..fcbf0b0de --- /dev/null +++ b/src/ortho/mcode/ortho_code-decls.adb @@ -0,0 +1,783 @@ +-- 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/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads new file mode 100644 index 000000000..ad18892fe --- /dev/null +++ b/src/ortho/mcode/ortho_code-decls.ads @@ -0,0 +1,209 @@ +-- 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/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb new file mode 100644 index 000000000..9e8ac1272 --- /dev/null +++ b/src/ortho/mcode/ortho_code-disps.adb @@ -0,0 +1,790 @@ +-- 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/src/ortho/mcode/ortho_code-disps.ads b/src/ortho/mcode/ortho_code-disps.ads new file mode 100644 index 000000000..5ae4d8697 --- /dev/null +++ b/src/ortho/mcode/ortho_code-disps.ads @@ -0,0 +1,25 @@ +-- 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/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb new file mode 100644 index 000000000..ad67d1ff6 --- /dev/null +++ b/src/ortho/mcode/ortho_code-dwarf.adb @@ -0,0 +1,1351 @@ +-- 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/src/ortho/mcode/ortho_code-dwarf.ads b/src/ortho/mcode/ortho_code-dwarf.ads new file mode 100644 index 000000000..c120bcfe1 --- /dev/null +++ b/src/ortho/mcode/ortho_code-dwarf.ads @@ -0,0 +1,41 @@ +-- 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/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb new file mode 100644 index 000000000..b2dfa1a67 --- /dev/null +++ b/src/ortho/mcode/ortho_code-exprs.adb @@ -0,0 +1,1663 @@ +-- 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/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads new file mode 100644 index 000000000..9bd4596d7 --- /dev/null +++ b/src/ortho/mcode/ortho_code-exprs.ads @@ -0,0 +1,600 @@ +-- 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/src/ortho/mcode/ortho_code-flags.ads b/src/ortho/mcode/ortho_code-flags.ads new file mode 100644 index 000000000..805f3779b --- /dev/null +++ b/src/ortho/mcode/ortho_code-flags.ads @@ -0,0 +1,35 @@ +-- 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/src/ortho/mcode/ortho_code-opts.adb b/src/ortho/mcode/ortho_code-opts.adb new file mode 100644 index 000000000..0ea6b039b --- /dev/null +++ b/src/ortho/mcode/ortho_code-opts.adb @@ -0,0 +1,214 @@ +-- 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/src/ortho/mcode/ortho_code-opts.ads b/src/ortho/mcode/ortho_code-opts.ads new file mode 100644 index 000000000..27a907c7b --- /dev/null +++ b/src/ortho/mcode/ortho_code-opts.ads @@ -0,0 +1,22 @@ +-- 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/src/ortho/mcode/ortho_code-types.adb b/src/ortho/mcode/ortho_code-types.adb new file mode 100644 index 000000000..e0c070c27 --- /dev/null +++ b/src/ortho/mcode/ortho_code-types.adb @@ -0,0 +1,820 @@ +-- 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/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads new file mode 100644 index 000000000..da6549841 --- /dev/null +++ b/src/ortho/mcode/ortho_code-types.ads @@ -0,0 +1,240 @@ +-- 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/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb new file mode 100644 index 000000000..bb06d51d4 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -0,0 +1,762 @@ +-- 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/src/ortho/mcode/ortho_code-x86-abi.ads b/src/ortho/mcode/ortho_code-x86-abi.ads new file mode 100644 index 000000000..7b166dad8 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-abi.ads @@ -0,0 +1,76 @@ +-- 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/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb new file mode 100644 index 000000000..ad1ef559b --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -0,0 +1,2322 @@ +-- 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/src/ortho/mcode/ortho_code-x86-emits.ads b/src/ortho/mcode/ortho_code-x86-emits.ads new file mode 100644 index 000000000..9ddb43ee5 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-emits.ads @@ -0,0 +1,36 @@ +-- 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/src/ortho/mcode/ortho_code-x86-flags_linux.ads b/src/ortho/mcode/ortho_code-x86-flags_linux.ads new file mode 100644 index 000000000..30bc7f7b3 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-flags_linux.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/mcode/ortho_code-x86-flags_macosx.ads b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads new file mode 100644 index 000000000..a33085294 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/mcode/ortho_code-x86-flags_windows.ads b/src/ortho/mcode/ortho_code-x86-flags_windows.ads new file mode 100644 index 000000000..3296aaf2c --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-flags_windows.ads @@ -0,0 +1,31 @@ +-- 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/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb new file mode 100644 index 000000000..c218a9ae0 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-insns.adb @@ -0,0 +1,2068 @@ +-- 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/src/ortho/mcode/ortho_code-x86-insns.ads b/src/ortho/mcode/ortho_code-x86-insns.ads new file mode 100644 index 000000000..9411737a0 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-insns.ads @@ -0,0 +1,25 @@ +-- 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/src/ortho/mcode/ortho_code-x86.adb b/src/ortho/mcode/ortho_code-x86.adb new file mode 100644 index 000000000..175dd7e99 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86.adb @@ -0,0 +1,109 @@ +-- 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/src/ortho/mcode/ortho_code-x86.ads b/src/ortho/mcode/ortho_code-x86.ads new file mode 100644 index 000000000..24be1eb6c --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86.ads @@ -0,0 +1,160 @@ +-- 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/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads new file mode 100644 index 000000000..0657b07e6 --- /dev/null +++ b/src/ortho/mcode/ortho_code.ads @@ -0,0 +1,150 @@ +-- 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/src/ortho/mcode/ortho_code_main.adb b/src/ortho/mcode/ortho_code_main.adb new file mode 100644 index 000000000..a0e6dc6c6 --- /dev/null +++ b/src/ortho/mcode/ortho_code_main.adb @@ -0,0 +1,198 @@ +-- 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/src/ortho/mcode/ortho_ident.adb b/src/ortho/mcode/ortho_ident.adb new file mode 100644 index 000000000..0893b75dd --- /dev/null +++ b/src/ortho/mcode/ortho_ident.adb @@ -0,0 +1,117 @@ +-- 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/src/ortho/mcode/ortho_ident.ads b/src/ortho/mcode/ortho_ident.ads new file mode 100644 index 000000000..cdc42fcad --- /dev/null +++ b/src/ortho/mcode/ortho_ident.ads @@ -0,0 +1,38 @@ +-- 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/src/ortho/mcode/ortho_jit.adb b/src/ortho/mcode/ortho_jit.adb new file mode 100644 index 000000000..7aa9724f2 --- /dev/null +++ b/src/ortho/mcode/ortho_jit.adb @@ -0,0 +1,125 @@ +-- 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/src/ortho/mcode/ortho_mcode-jit.adb b/src/ortho/mcode/ortho_mcode-jit.adb new file mode 100644 index 000000000..7e845cc6e --- /dev/null +++ b/src/ortho/mcode/ortho_mcode-jit.adb @@ -0,0 +1,28 @@ +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/src/ortho/mcode/ortho_mcode-jit.ads b/src/ortho/mcode/ortho_mcode-jit.ads new file mode 100644 index 000000000..c689a1e12 --- /dev/null +++ b/src/ortho/mcode/ortho_mcode-jit.ads @@ -0,0 +1,9 @@ +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/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb new file mode 100644 index 000000000..55e890bf3 --- /dev/null +++ b/src/ortho/mcode/ortho_mcode.adb @@ -0,0 +1,738 @@ +-- 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/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads new file mode 100644 index 000000000..45e803690 --- /dev/null +++ b/src/ortho/mcode/ortho_mcode.ads @@ -0,0 +1,583 @@ +-- 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/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads new file mode 100644 index 000000000..1b414773f --- /dev/null +++ b/src/ortho/mcode/ortho_mcode.private.ads @@ -0,0 +1,151 @@ +-- 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/src/ortho/mcode/ortho_nodes.ads b/src/ortho/mcode/ortho_nodes.ads new file mode 100644 index 000000000..7a2df3f30 --- /dev/null +++ b/src/ortho/mcode/ortho_nodes.ads @@ -0,0 +1,2 @@ +with Ortho_Mcode; +package Ortho_Nodes renames Ortho_Mcode; diff --git a/src/ortho/oread/Makefile b/src/ortho/oread/Makefile new file mode 100644 index 000000000..f94535181 --- /dev/null +++ b/src/ortho/oread/Makefile @@ -0,0 +1,43 @@ +# -*- 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/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb new file mode 100644 index 000000000..84bbd1b9d --- /dev/null +++ b/src/ortho/oread/ortho_front.adb @@ -0,0 +1,2677 @@ +-- 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/src/ortho/ortho_front.ads b/src/ortho/ortho_front.ads new file mode 100644 index 000000000..1d20e15d7 --- /dev/null +++ b/src/ortho/ortho_front.ads @@ -0,0 +1,41 @@ +-- 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/src/ortho/ortho_jit.ads b/src/ortho/ortho_jit.ads new file mode 100644 index 000000000..89c3663f3 --- /dev/null +++ b/src/ortho/ortho_jit.ads @@ -0,0 +1,43 @@ +-- 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/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads new file mode 100644 index 000000000..178187482 --- /dev/null +++ b/src/ortho/ortho_nodes.common.ads @@ -0,0 +1,453 @@ +-- 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; |