diff options
Diffstat (limited to 'translate/grt')
| -rw-r--r-- | translate/grt/config/pthread.c | 21 | ||||
| -rw-r--r-- | translate/grt/config/win32.c | 6 | ||||
| -rw-r--r-- | translate/grt/grt-disp_rti.adb | 390 | ||||
| -rw-r--r-- | translate/grt/grt-disp_rti.ads | 18 | ||||
| -rw-r--r-- | translate/grt/grt-disp_tree.adb | 448 | ||||
| -rw-r--r-- | translate/grt/grt-disp_tree.ads | 20 | ||||
| -rw-r--r-- | translate/grt/grt-main.adb | 32 | ||||
| -rw-r--r-- | translate/grt/grt-main.ads | 5 | ||||
| -rw-r--r-- | translate/grt/grt-modules.adb | 39 | ||||
| -rw-r--r-- | translate/grt/grt-modules.ads | 22 | ||||
| -rw-r--r-- | translate/grt/grt-options.adb | 17 | ||||
| -rw-r--r-- | translate/grt/grt-options.ads | 13 | ||||
| -rw-r--r-- | translate/grt/grt-processes.adb | 1 | ||||
| -rw-r--r-- | translate/grt/grt-rtis_utils.adb | 4 |
14 files changed, 600 insertions, 436 deletions
diff --git a/translate/grt/config/pthread.c b/translate/grt/config/pthread.c index f611bb6..f0cee39 100644 --- a/translate/grt/config/pthread.c +++ b/translate/grt/config/pthread.c @@ -42,9 +42,9 @@ typedef struct } Stack_Type_t, *Stack_Type; Stack_Type_t main_stack_context; -extern Stack_Type grt_stack_main_stack; +extern void grt_set_main_stack (Stack_Type_t *stack); -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- void grt_stack_init(void) // Initialize the stacks package. // This may adjust stack sizes. @@ -58,10 +58,10 @@ void grt_stack_init(void) // lock the mutex, as we are currently running pthread_mutex_lock(&(main_stack_context.mutex)); - grt_stack_main_stack= &main_stack_context; + grt_set_main_stack (&main_stack_context); } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- static void* grt_stack_loop(void* pv_myStack) { Stack_Type myStack= (Stack_Type)pv_myStack; @@ -84,7 +84,7 @@ static void* grt_stack_loop(void* pv_myStack) return 0; } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- Stack_Type grt_stack_create(void* Func, void* Arg) // Create a new stack, which on first execution will call FUNC with // an argument ARG. @@ -115,7 +115,7 @@ Stack_Type grt_stack_create(void* Func, void* Arg) return newStack; } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- void grt_stack_switch(Stack_Type To, Stack_Type From) // Resume stack TO and save the current context to the stack pointed by // CUR. @@ -134,14 +134,16 @@ void grt_stack_switch(Stack_Type To, Stack_Type From) pthread_mutex_lock(&(From->mutex)); } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- void grt_stack_delete(Stack_Type Stack) // Delete stack STACK, which must not be currently executed. // => procedure Stack_Delete (Stack : Stack_Type); { INFO("grt_stack_delete\n"); } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- + +#ifndef WITH_GNAT_RUN_TIME void __gnat_raise_storage_error(void) { abort (); @@ -151,7 +153,8 @@ void __gnat_raise_program_error(void) { abort (); } +#endif /* WITH_GNAT_RUN_TIME */ -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- // end of file diff --git a/translate/grt/config/win32.c b/translate/grt/config/win32.c index 6c55f7b..80ea270 100644 --- a/translate/grt/config/win32.c +++ b/translate/grt/config/win32.c @@ -148,7 +148,8 @@ void grt_stack_delete(Stack_Type Stack) { INFO("grt_stack_delete\n"); } -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- +#ifndef WITH_GNAT_RUN_TIME void __gnat_raise_storage_error(void) { abort (); @@ -158,7 +159,8 @@ void __gnat_raise_program_error(void) { abort (); } +#endif -//------------------------------------------------------------------------------ +//---------------------------------------------------------------------------- // end of file diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb index 28ad75d..e9ac3e6 100644 --- a/translate/grt/grt-disp_rti.adb +++ b/translate/grt/grt-disp_rti.adb @@ -15,14 +15,10 @@ -- 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 Grt.Rtis; use Grt.Rtis; -with Grt.Stdio; use Grt.Stdio; with Grt.Astdio; use Grt.Astdio; -with Grt.Types; use Grt.Types; with Grt.Errors; use Grt.Errors; with Grt.Rtis_Addr; use Grt.Rtis_Addr; -with Grt.Options; use Grt.Options; +with Grt.Hooks; use Grt.Hooks; package body Grt.Disp_Rti is procedure Disp_Kind (Kind : Ghdl_Rtik); @@ -119,12 +115,6 @@ package body Grt.Disp_Rti is -- end case; -- end Get_Scalar_Type_Kind; - procedure Disp_Value (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Obj : in out Address; - Is_Sig : Boolean); - procedure Disp_Array_Value_1 (Stream : FILEs; El_Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; @@ -989,10 +979,16 @@ package body Grt.Disp_Rti is end case; end Disp_Rti; + Disp_Rti_Flag : Boolean := False; + procedure Disp_All is Ctxt : Rti_Context; begin + if not Disp_Rti_Flag then + return; + end if; + Put ("DISP_RTI.Disp_All: "); Disp_Kind (Ghdl_Rti_Top_Ptr.Common.Kind); New_Line; @@ -1006,364 +1002,34 @@ package body Grt.Disp_Rti is --Disp_Hierarchy; end Disp_All; - -- Get next interesting child. - procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; - Index : in out Ghdl_Index_Type; - Child : out Ghdl_Rti_Access) - is - begin - -- Exit if no more children. - while Index < Parent.Nbr_Child loop - Child := Parent.Children (Index); - Index := Index + 1; - case Child.Kind is - when Ghdl_Rtik_Package - | Ghdl_Rtik_Entity - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Block - | Ghdl_Rtik_For_Generate - | Ghdl_Rtik_If_Generate - | Ghdl_Rtik_Instance => - return; - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard => - if Disp_Tree >= Disp_Tree_Port then - return; - end if; - when Ghdl_Rtik_Process => - if Disp_Tree >= Disp_Tree_Proc then - return; - end if; - when others => - null; - end case; - end loop; - Child := null; - end Get_Tree_Child; - - procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + function Disp_Rti_Option (Opt : String) return Boolean is begin - case Rti.Kind is - when Ghdl_Rtik_Entity - | Ghdl_Rtik_Process - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Block - | Ghdl_Rtik_If_Generate => - declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); - begin - Disp_Name (Blk.Name); - end; - when Ghdl_Rtik_Package_Body - | Ghdl_Rtik_Package => - declare - Blk : Ghdl_Rtin_Block_Acc; - Lib : Ghdl_Rtin_Type_Scalar_Acc; - begin - Blk := To_Ghdl_Rtin_Block_Acc (Rti); - if Rti.Kind = Ghdl_Rtik_Package_Body then - Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); - end if; - Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); - Disp_Name (Lib.Name); - Put ('.'); - Disp_Name (Blk.Name); - end; - when Ghdl_Rtik_For_Generate => - declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); - Iter : Ghdl_Rtin_Object_Acc; - Addr : Address; - begin - Disp_Name (Blk.Name); - Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); - Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); - Put ('('); - Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); - Put (')'); - end; - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard - | Ghdl_Rtik_Iterator => - Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); - when Ghdl_Rtik_Instance => - Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); - when others => - null; - end case; - - case Rti.Kind is - when Ghdl_Rtik_Package - | Ghdl_Rtik_Package_Body => - Put (" [package]"); - when Ghdl_Rtik_Entity => - Put (" [entity]"); - when Ghdl_Rtik_Architecture => - Put (" [arch]"); - when Ghdl_Rtik_Process => - Put (" [process]"); - when Ghdl_Rtik_Block => - Put (" [block]"); - when Ghdl_Rtik_For_Generate => - Put (" [for-generate]"); - when Ghdl_Rtik_If_Generate => - Put (" [if-generate "); - if Ctxt.Base = Null_Address then - Put ("false]"); - else - Put ("true]"); - end if; - when Ghdl_Rtik_Signal => - Put (" [signal]"); - when Ghdl_Rtik_Port => - Put (" [port "); - case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is - when Ghdl_Rti_Signal_Mode_In => - Put ("in"); - when Ghdl_Rti_Signal_Mode_Out => - Put ("out"); - when Ghdl_Rti_Signal_Mode_Inout => - Put ("inout"); - when Ghdl_Rti_Signal_Mode_Buffer => - Put ("buffer"); - when Ghdl_Rti_Signal_Mode_Linkage => - Put ("linkage"); - when others => - Put ("?"); - end case; - Put ("]"); - when Ghdl_Rtik_Guard => - Put (" [guard]"); - when Ghdl_Rtik_Iterator => - Put (" [iterator]"); - when Ghdl_Rtik_Instance => - Put (" [instance]"); - when others => - null; - end case; - end Disp_Tree_Child; - - procedure Disp_Tree_Block - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; - procedure Disp_Tree_Block1 - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + procedure Disp_Rti_Help is - Child : Ghdl_Rti_Access; - Child2 : Ghdl_Rti_Access; - Index : Ghdl_Index_Type; - - procedure Disp_Header (Nctxt : Rti_Context; - Force_Cont : Boolean := False) - is - begin - Put (Pfx); - - if Blk.Common.Kind /= Ghdl_Rtik_Entity - and Child2 = null - and Force_Cont = False - then - Put ("`-"); - else - Put ("+-"); - end if; - - Disp_Tree_Child (Child, Nctxt); - New_Line; - end Disp_Header; - - procedure Disp_Sub_Block - (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) - is - Npfx : String (1 .. Pfx'Length + 2); - begin - Npfx (1 .. Pfx'Length) := Pfx; - Npfx (Pfx'Length + 2) := ' '; - if Child2 = null then - Npfx (Pfx'Length + 1) := ' '; - else - Npfx (Pfx'Length + 1) := '|'; - end if; - Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); - end Disp_Sub_Block; - + procedure P (Str : String) renames Put_Line; begin - Index := 0; - Get_Tree_Child (Blk, Index, Child); - while Child /= null loop - Get_Tree_Child (Blk, Index, Child2); + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; - case Child.Kind is - when Ghdl_Rtik_Process - | Ghdl_Rtik_Block => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off, - Block => Child); - Disp_Header (Nctxt, False); - Disp_Sub_Block (Nblk, Nctxt); - end; - when Ghdl_Rtik_For_Generate => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - Length : Ghdl_Index_Type; - Old_Child2 : Ghdl_Rti_Access; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, - Block => Child); - Length := Get_For_Generate_Length (Nblk, Ctxt); - Disp_Header (Nctxt, Length > 1); - Old_Child2 := Child2; - if Length > 1 then - Child2 := Child; - end if; - for I in 1 .. Length loop - Disp_Sub_Block (Nblk, Nctxt); - if I /= Length then - Nctxt.Base := Nctxt.Base + Nblk.Size; - if I = Length - 1 then - Child2 := Old_Child2; - end if; - Disp_Header (Nctxt); - end if; - end loop; - Child2 := Old_Child2; - end; - when Ghdl_Rtik_If_Generate => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, - Block => Child); - Disp_Header (Nctxt); - if Nctxt.Base /= Null_Address then - Disp_Sub_Block (Nblk, Nctxt); - end if; - end; - when Ghdl_Rtik_Instance => - declare - Inst : Ghdl_Rtin_Instance_Acc; - Sub_Ctxt : Rti_Context; - Sub_Blk : Ghdl_Rtin_Block_Acc; - Npfx : String (1 .. Pfx'Length + 4); - Comp : Ghdl_Rtin_Component_Acc; - Ch : Ghdl_Rti_Access; - begin - Disp_Header (Ctxt); - Inst := To_Ghdl_Rtin_Instance_Acc (Child); - Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); - Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); - if Inst.Instance.Kind = Ghdl_Rtik_Component - and then Disp_Tree >= Disp_Tree_Port - then - -- Disp generics and ports of the component. - Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); - for I in 1 .. Comp.Nbr_Child loop - Ch := Comp.Children (I - 1); - if Ch.Kind = Ghdl_Rtik_Port then - -- Disp only port (and not generics). - Put (Pfx); - if Child2 = null then - Put (" "); - else - Put ("| "); - end if; - if I = Comp.Nbr_Child and then Sub_Blk = null then - Put ("`-"); - else - Put ("+-"); - end if; - Disp_Tree_Child (Ch, Sub_Ctxt); - New_Line; - end if; - end loop; - end if; - if Sub_Blk /= null then - Npfx (1 .. Pfx'Length) := Pfx; - if Child2 = null then - Npfx (Pfx'Length + 1) := ' '; - else - Npfx (Pfx'Length + 1) := '|'; - end if; - Npfx (Pfx'Length + 2) := ' '; - Npfx (Pfx'Length + 3) := '`'; - Npfx (Pfx'Length + 4) := '-'; - Put (Npfx); - Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); - New_Line; - Npfx (Pfx'Length + 3) := ' '; - Npfx (Pfx'Length + 4) := ' '; - Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); - end if; - end; - when others => - Disp_Header (Ctxt); - end case; - - Child := Child2; - end loop; - end Disp_Tree_Block1; + Disp_Rti_Hooks : aliased constant Hooks_Type := + (Option => Disp_Rti_Option'Access, + Help => Disp_Rti_Help'Access, + Init => null, + Start => Disp_All'Access, + Finish => null); - procedure Disp_Tree_Block - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) - is + procedure Register is begin - case Blk.Common.Kind is - when Ghdl_Rtik_Architecture => - declare - Npfx : String (1 .. Pfx'Length + 2); - Nctxt : Rti_Context; - begin - -- The entity. - Nctxt := (Base => Ctxt.Base, - Block => Blk.Parent); - Disp_Tree_Block1 - (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); - -- Then the architecture. - Put (Pfx); - Put ("`-"); - Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); - New_Line; - Npfx (1 .. Pfx'Length) := Pfx; - Npfx (Pfx'Length + 1) := ' '; - Npfx (Pfx'Length + 2) := ' '; - Disp_Tree_Block1 (Blk, Ctxt, Npfx); - end; - when Ghdl_Rtik_Package_Body => - Disp_Tree_Block1 - (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); - when others => - Disp_Tree_Block1 (Blk, Ctxt, Pfx); - end case; - end Disp_Tree_Block; - - procedure Disp_Hierarchy - is - Ctxt : Rti_Context; - Parent : Ghdl_Rtin_Block_Acc; - Child : Ghdl_Rti_Access; - begin - Ctxt := Get_Top_Context; - Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); - - Disp_Tree_Child (Parent.Parent, Ctxt); - New_Line; - Disp_Tree_Block (Parent, Ctxt, ""); + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; - for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop - Child := Ghdl_Rti_Top_Ptr.Children (I - 1); - Ctxt := (Base => Null_Address, - Block => Child); - Disp_Tree_Child (Child, Ctxt); - New_Line; - Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); - end loop; - end Disp_Hierarchy; end Grt.Disp_Rti; diff --git a/translate/grt/grt-disp_rti.ads b/translate/grt/grt-disp_rti.ads index 890c5e1..fc13e22 100644 --- a/translate/grt/grt-disp_rti.ads +++ b/translate/grt/grt-disp_rti.ads @@ -15,8 +15,22 @@ -- 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 Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + package Grt.Disp_Rti is - procedure Disp_All; + -- Disp NAME. If NAME is null, then disp <anonymous>. + procedure Disp_Name (Name : Ghdl_C_String); + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean); - procedure Disp_Hierarchy; + procedure Register; end Grt.Disp_Rti; diff --git a/translate/grt/grt-disp_tree.adb b/translate/grt/grt-disp_tree.adb new file mode 100644 index 0000000..e4f55f3 --- /dev/null +++ b/translate/grt/grt-disp_tree.adb @@ -0,0 +1,448 @@ +-- GHDL Run Time (GRT) - Tree displayer. +-- 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 System; use System; +with Grt.Disp_Rti; use Grt.Disp_Rti; +with Grt.Rtis; use Grt.Rtis; +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Types; use Grt.Types; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Disp_Tree is + -- Set by --disp-tree, to display the design hierarchy. + type Disp_Tree_Kind is + ( + Disp_Tree_None, -- Do not disp tree. + Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. + Disp_Tree_Proc, -- As above plus processes + Disp_Tree_Port -- As above plus ports and signals. + ); + Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None; + + + -- Get next interesting child. + procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; + Index : in out Ghdl_Index_Type; + Child : out Ghdl_Rti_Access) + is + begin + -- Exit if no more children. + while Index < Parent.Nbr_Child loop + Child := Parent.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_Instance => + return; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + if Disp_Tree_Flag >= Disp_Tree_Port then + return; + end if; + when Ghdl_Rtik_Process => + if Disp_Tree_Flag >= Disp_Tree_Proc then + return; + end if; + when others => + null; + end case; + end loop; + Child := null; + end Get_Tree_Child; + + procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Process + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + declare + Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); + begin + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Package => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Rti); + if Rti.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + Disp_Name (Lib.Name); + Put ('.'); + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_For_Generate => + declare + Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Disp_Name (Blk.Name); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Put ('('); + Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Put (')'); + end; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Iterator => + Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); + when Ghdl_Rtik_Instance => + Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); + when others => + null; + end case; + + case Rti.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body => + Put (" [package]"); + when Ghdl_Rtik_Entity => + Put (" [entity]"); + when Ghdl_Rtik_Architecture => + Put (" [arch]"); + when Ghdl_Rtik_Process => + Put (" [process]"); + when Ghdl_Rtik_Block => + Put (" [block]"); + when Ghdl_Rtik_For_Generate => + Put (" [for-generate]"); + when Ghdl_Rtik_If_Generate => + Put (" [if-generate "); + if Ctxt.Base = Null_Address then + Put ("false]"); + else + Put ("true]"); + end if; + when Ghdl_Rtik_Signal => + Put (" [signal]"); + when Ghdl_Rtik_Port => + Put (" [port "); + case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + Put ("in"); + when Ghdl_Rti_Signal_Mode_Out => + Put ("out"); + when Ghdl_Rti_Signal_Mode_Inout => + Put ("inout"); + when Ghdl_Rti_Signal_Mode_Buffer => + Put ("buffer"); + when Ghdl_Rti_Signal_Mode_Linkage => + Put ("linkage"); + when others => + Put ("?"); + end case; + Put ("]"); + when Ghdl_Rtik_Guard => + Put (" [guard]"); + when Ghdl_Rtik_Iterator => + Put (" [iterator]"); + when Ghdl_Rtik_Instance => + Put (" [instance]"); + when others => + null; + end case; + end Disp_Tree_Child; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + + procedure Disp_Tree_Block1 + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + Child : Ghdl_Rti_Access; + Child2 : Ghdl_Rti_Access; + Index : Ghdl_Index_Type; + + procedure Disp_Header (Nctxt : Rti_Context; + Force_Cont : Boolean := False) + is + begin + Put (Pfx); + + if Blk.Common.Kind /= Ghdl_Rtik_Entity + and Child2 = null + and Force_Cont = False + then + Put ("`-"); + else + Put ("+-"); + end if; + + Disp_Tree_Child (Child, Nctxt); + New_Line; + end Disp_Header; + + procedure Disp_Sub_Block + (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) + is + Npfx : String (1 .. Pfx'Length + 2); + begin + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 2) := ' '; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); + end Disp_Sub_Block; + + begin + Index := 0; + Get_Tree_Child (Blk, Index, Child); + while Child /= null loop + Get_Tree_Child (Blk, Index, Child2); + + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off, + Block => Child); + Disp_Header (Nctxt, False); + Disp_Sub_Block (Nblk, Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + Length : Ghdl_Index_Type; + Old_Child2 : Ghdl_Rti_Access; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + Disp_Header (Nctxt, Length > 1); + Old_Child2 := Child2; + if Length > 1 then + Child2 := Child; + end if; + for I in 1 .. Length loop + Disp_Sub_Block (Nblk, Nctxt); + if I /= Length then + Nctxt.Base := Nctxt.Base + Nblk.Size; + if I = Length - 1 then + Child2 := Old_Child2; + end if; + Disp_Header (Nctxt); + end if; + end loop; + Child2 := Old_Child2; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, + Block => Child); + Disp_Header (Nctxt); + if Nctxt.Base /= Null_Address then + Disp_Sub_Block (Nblk, Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + declare + Inst : Ghdl_Rtin_Instance_Acc; + Sub_Ctxt : Rti_Context; + Sub_Blk : Ghdl_Rtin_Block_Acc; + Npfx : String (1 .. Pfx'Length + 4); + Comp : Ghdl_Rtin_Component_Acc; + Ch : Ghdl_Rti_Access; + begin + Disp_Header (Ctxt); + Inst := To_Ghdl_Rtin_Instance_Acc (Child); + Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); + Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); + if Inst.Instance.Kind = Ghdl_Rtik_Component + and then Disp_Tree_Flag >= Disp_Tree_Port + then + -- Disp generics and ports of the component. + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + for I in 1 .. Comp.Nbr_Child loop + Ch := Comp.Children (I - 1); + if Ch.Kind = Ghdl_Rtik_Port then + -- Disp only port (and not generics). + Put (Pfx); + if Child2 = null then + Put (" "); + else + Put ("| "); + end if; + if I = Comp.Nbr_Child and then Sub_Blk = null then + Put ("`-"); + else + Put ("+-"); + end if; + Disp_Tree_Child (Ch, Sub_Ctxt); + New_Line; + end if; + end loop; + end if; + if Sub_Blk /= null then + Npfx (1 .. Pfx'Length) := Pfx; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Npfx (Pfx'Length + 2) := ' '; + Npfx (Pfx'Length + 3) := '`'; + Npfx (Pfx'Length + 4) := '-'; + Put (Npfx); + Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); + New_Line; + Npfx (Pfx'Length + 3) := ' '; + Npfx (Pfx'Length + 4) := ' '; + Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); + end if; + end; + when others => + Disp_Header (Ctxt); + end case; + + Child := Child2; + end loop; + end Disp_Tree_Block1; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + begin + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + declare + Npfx : String (1 .. Pfx'Length + 2); + Nctxt : Rti_Context; + begin + -- The entity. + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); + -- Then the architecture. + Put (Pfx); + Put ("`-"); + Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); + New_Line; + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 1) := ' '; + Npfx (Pfx'Length + 2) := ' '; + Disp_Tree_Block1 (Blk, Ctxt, Npfx); + end; + when Ghdl_Rtik_Package_Body => + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); + when others => + Disp_Tree_Block1 (Blk, Ctxt, Pfx); + end case; + end Disp_Tree_Block; + + procedure Disp_Hierarchy + is + Ctxt : Rti_Context; + Parent : Ghdl_Rtin_Block_Acc; + Child : Ghdl_Rti_Access; + begin + if Disp_Tree_Flag = Disp_Tree_None then + return; + end if; + + Ctxt := Get_Top_Context; + Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + + Disp_Tree_Child (Parent.Parent, Ctxt); + New_Line; + Disp_Tree_Block (Parent, Ctxt, ""); + + for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop + Child := Ghdl_Rti_Top_Ptr.Children (I - 1); + Ctxt := (Base => Null_Address, + Block => Child); + Disp_Tree_Child (Child, Ctxt); + New_Line; + Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); + end loop; + end Disp_Hierarchy; + + function Disp_Tree_Option (Opt : String) return Boolean + is + begin + if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then + if Opt'Length = 11 then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=port" then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=proc" then + Disp_Tree_Flag := Disp_Tree_Proc; + elsif Opt (12 .. Opt'Last) = "=inst" then + Disp_Tree_Flag := Disp_Tree_Inst; + elsif Opt (12 .. Opt'Last) = "=none" then + Disp_Tree_Flag := Disp_Tree_None; + else + Error ("bad argument for --disp-tree option, try --help"); + end if; + return True; + else + return False; + end if; + end Disp_Tree_Option; + + procedure Disp_Tree_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --disp-tree[=KIND] disp the design hierarchy after elaboration"); + P (" KIND is inst, proc, port (default)"); + end Disp_Tree_Help; + + Disp_Tree_Hooks : aliased constant Hooks_Type := + (Option => Disp_Tree_Option'Access, + Help => Disp_Tree_Help'Access, + Init => null, + Start => Disp_Hierarchy'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Tree_Hooks'Access); + end Register; + +end Grt.Disp_Tree; diff --git a/translate/grt/grt-disp_tree.ads b/translate/grt/grt-disp_tree.ads new file mode 100644 index 0000000..574626e --- /dev/null +++ b/translate/grt/grt-disp_tree.ads @@ -0,0 +1,20 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- 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 Grt.Disp_Tree is + procedure Register; +end Grt.Disp_Tree; diff --git a/translate/grt/grt-main.adb b/translate/grt/grt-main.adb index 28bd8b0..86a388c 100644 --- a/translate/grt/grt-main.adb +++ b/translate/grt/grt-main.adb @@ -18,21 +18,18 @@ with System.Storage_Elements; -- Work around GNAT bug. with Grt.Types; use Grt.Types; with Grt.Errors; -with Grt.Vcd; -with Grt.Vcdz; -with Grt.Vpi; -with Grt.Waves; with Grt.Stacks; with Grt.Processes; with Grt.Signals; with Grt.Options; use Grt.Options; -with Grt.Disp_Rti; with Grt.Stats; with Grt.Hooks; with Grt.Disp_Signals; with Grt.Disp; +with Grt.Modules; -- The following packages are not referenced in this package. +-- These are subprograms called only from GHDL generated code. -- They are with'ed in order to be present in the binary. pragma Warnings (Off); with Grt.Files; @@ -42,7 +39,6 @@ with Grt.Shadow_Ieee; with Grt.Images; with Grt.Values; with Grt.Names; -with Grt.Vital_Annotate; pragma Warnings (On); package body Grt.Main is @@ -81,23 +77,15 @@ package body Grt.Main is end if; end Check_Flag_String; - procedure Register_Modules is - begin - -- List of modules to be registered. - Grt.Vcd.Register; - Grt.Vcdz.Register; - Grt.Waves.Register; - Grt.Vpi.Register; - Grt.Vital_Annotate.Register; - end Register_Modules; - procedure Run is use Grt.Errors; Stop : Boolean; Status : Integer; begin - Register_Modules; + -- Register modules. + -- They may insert hooks. + Grt.Modules.Register_Modules; -- If the time resolution is to be set by the user, select a default -- resolution. Options may override it. @@ -105,8 +93,10 @@ package body Grt.Main is Set_Time_Resolution ('n'); end if; + -- Decode options. Grt.Options.Decode (Stop); + -- Check coherency between GRT and GHDL generated code. Check_Flag_String; -- Early stop (for options such as --help). @@ -138,15 +128,9 @@ package body Grt.Main is Stats.Start_Order; end if; - if Disp_Tree /= Disp_Tree_None then - Grt.Disp_Rti.Disp_Hierarchy; - end if; + Grt.Hooks.Call_Start_Hooks; if not Flag_No_Run then - if Grt.Options.Flag_Dump_Rti then - Grt.Disp_Rti.Disp_All; - end if; - Grt.Signals.Order_All_Signals; if Grt.Options.Disp_Signals_Map then diff --git a/translate/grt/grt-main.ads b/translate/grt/grt-main.ads index c62fe00..15c669e 100644 --- a/translate/grt/grt-main.ads +++ b/translate/grt/grt-main.ads @@ -17,11 +17,6 @@ -- 02111-1307, USA. package Grt.Main is - -- Register modules. - -- This is automatically called by RUN. - -- Do not call this procedure. - procedure Register_Modules; - -- Elaborate and simulate the design. procedure Run; end Grt.Main; diff --git a/translate/grt/grt-modules.adb b/translate/grt/grt-modules.adb new file mode 100644 index 0000000..6fe8eea --- /dev/null +++ b/translate/grt/grt-modules.adb @@ -0,0 +1,39 @@ +-- GHDL Run Time (GRT) - Modules. +-- 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 System.Storage_Elements; -- Work around GNAT bug. +with Grt.Vcd; +with Grt.Vcdz; +with Grt.Vpi; +with Grt.Waves; +with Grt.Vital_Annotate; +with Grt.Disp_Tree; +with Grt.Disp_Rti; + +package body Grt.Modules is + procedure Register_Modules is + begin + -- List of modules to be registered. + Grt.Disp_Tree.Register; + Grt.Vcd.Register; + Grt.Vcdz.Register; + Grt.Waves.Register; + Grt.Vpi.Register; + Grt.Vital_Annotate.Register; + Grt.Disp_Rti.Register; + end Register_Modules; +end Grt.Modules; diff --git a/translate/grt/grt-modules.ads b/translate/grt/grt-modules.ads new file mode 100644 index 0000000..2148597 --- /dev/null +++ b/translate/grt/grt-modules.ads @@ -0,0 +1,22 @@ +-- GHDL Run Time (GRT) - Modules. +-- 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 Grt.Modules is + -- Register optional modules. + procedure Register_Modules; +end Grt.Modules; diff --git a/translate/grt/grt-options.adb b/translate/grt/grt-options.adb index 15b56d4..140f088 100644 --- a/translate/grt/grt-options.adb +++ b/translate/grt/grt-options.adb @@ -169,7 +169,6 @@ package body Grt.Options is P (" --disp-sig-types disp signal types"); P (" --disp-signals-map disp map bw declared sigs and internal sigs"); P (" --disp-signals-table disp internal signals"); - P (" --dump-rti dump Run Time Information"); P (" --checks do internal checks after each process run"); P (" --activity=LEVEL watch activity of LEVEL signals"); P (" LEVEL is all, min (default) or none (unsafe)"); @@ -260,20 +259,6 @@ package body Grt.Options is elsif Argument = "--help" or else Argument = "-h" then Help; Stop := True; - elsif Len >= 11 and then Argument (1 .. 11) = "--disp-tree" then - if Len = 11 then - Disp_Tree := Disp_Tree_Port; - elsif Argument (12 .. Len) = "=port" then - Disp_Tree := Disp_Tree_Port; - elsif Argument (12 .. Len) = "=proc" then - Disp_Tree := Disp_Tree_Proc; - elsif Argument (12 .. Len) = "=inst" then - Disp_Tree := Disp_Tree_Inst; - elsif Argument (12 .. Len) = "=none" then - Disp_Tree := Disp_Tree_None; - else - Error ("bad argument for --disp-tree option, try --help"); - end if; elsif Argument = "--disp-time" then Disp_Time := True; elsif Argument = "--trace-signals" then @@ -294,8 +279,6 @@ package body Grt.Options is Disp_Signals_Map := True; elsif Argument = "--disp-signals-table" then Disp_Signals_Table := True; - elsif Argument = "--dump-rti" then - Flag_Dump_Rti := True; elsif Argument = "--stats" then Flag_Stats := True; elsif Argument = "--no-run" then diff --git a/translate/grt/grt-options.ads b/translate/grt/grt-options.ads index 756fe5d..7e2c17b 100644 --- a/translate/grt/grt-options.ads +++ b/translate/grt/grt-options.ads @@ -56,16 +56,6 @@ package Grt.Options is -- If STOP is true, there nothing must happen (set by --help). procedure Decode (Stop : out Boolean); - -- Set by --disp-tree, to display the design hierarchy. - type Disp_Tree_Kind is - ( - Disp_Tree_None, -- Do not disp tree. - Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. - Disp_Tree_Proc, -- As above plus processes - Disp_Tree_Port -- As above plus ports and signals. - ); - Disp_Tree : Disp_Tree_Kind := Disp_Tree_None; - -- Set by --disp-time (and --trace-signals, --trace-processes) to display -- time and deltas. Disp_Time : Boolean := False; @@ -108,9 +98,6 @@ package Grt.Options is -- The maximum stack size for non-sensitized processes. Stack_Max_Size : Natural := 128 * 1024; - -- If set, dump rtis. - Flag_Dump_Rti : Boolean := False; - -- Set by --no-run -- If set, do not simulate, only elaborate. Flag_No_Run : Boolean := False; diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb index 1bb0be8..54eb28b 100644 --- a/translate/grt/grt-processes.adb +++ b/translate/grt/grt-processes.adb @@ -806,7 +806,6 @@ package body Grt.Processes is new Process_Id_Array (1 .. Nbr_Non_Postponed_Processes); Postponed_Resume_Process_Table := new Process_Id_Array (1 .. Nbr_Postponed_Processes); - Grt.Hooks.Call_Start_Hooks; Status := Run_Through_Longjump (Initialization_Phase'Access); if Status /= Run_Resumed then diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb index 62cd407..9754ada 100644 --- a/translate/grt/grt-rtis_utils.adb +++ b/translate/grt/grt-rtis_utils.adb @@ -94,7 +94,9 @@ package body Grt.Rtis_Utils is Obj := To_Ghdl_Rtin_Instance_Acc (Child); Get_Instance_Context (Obj, Ctxt, Nctxt); - Res := Traverse_Instance (Nctxt); + if Nctxt /= Null_Context then + Res := Traverse_Instance (Nctxt); + end if; end; end if; when Ghdl_Rtik_Package |