diff options
Diffstat (limited to 'ortho/mcode/ortho_code-decls.adb')
| -rw-r--r-- | ortho/mcode/ortho_code-decls.adb | 754 |
1 files changed, 754 insertions, 0 deletions
diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb new file mode 100644 index 0000000..44a2595 --- /dev/null +++ b/ortho/mcode/ortho_code-decls.adb @@ -0,0 +1,754 @@ +-- 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_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; + + 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 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 := Decl + 1; + begin + 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 : 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 + 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; + + Dnodes.Append (Dnode_Common'(Kind => OD_Interface, + Storage => O_Storage_Local, + Depth => Cur_Depth + 1, + Reg => R_Nil, + Id => Static_Chain_Id, + Dtype => O_Tnode_Ptr, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + New_Interface (Res, Interfaces.Abi); + end Add_Static_Chain; + + procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List) + is + Storage : O_Storage; + begin + Storage := Get_Decl_Storage (Dnodes.Last); + 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 (Dnodes.Last, Storage); + end case; + end if; + Start_Subprogram (Dnodes.Last, Interfaces.Abi); + Interfaces.Decl := Dnodes.Last; + 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 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 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; |