diff options
| -rw-r--r-- | README | 5 | ||||
| -rw-r--r-- | canon.adb | 18 | ||||
| -rw-r--r-- | disp_tree.adb | 10 | ||||
| -rw-r--r-- | flags.ads | 3 | ||||
| -rw-r--r-- | iirs.adb | 94 | ||||
| -rw-r--r-- | iirs.ads | 73 | ||||
| -rw-r--r-- | iirs_utils.adb | 24 | ||||
| -rw-r--r-- | iirs_utils.ads | 4 | ||||
| -rw-r--r-- | nodes.adb | 18 | ||||
| -rw-r--r-- | nodes.ads | 36 | ||||
| -rw-r--r-- | ortho/gcc/ortho-lang.c | 50 | ||||
| -rw-r--r-- | sem.adb | 8 | ||||
| -rw-r--r-- | sem_decls.adb | 69 | ||||
| -rw-r--r-- | sem_decls.ads | 5 | ||||
| -rw-r--r-- | sem_expr.adb | 6 | ||||
| -rw-r--r-- | sem_names.adb | 12 | ||||
| -rw-r--r-- | sem_stmts.adb | 8 | ||||
| -rw-r--r-- | sem_types.adb | 64 | ||||
| -rw-r--r-- | sem_types.ads | 7 | ||||
| -rw-r--r-- | std_package.adb | 36 | ||||
| -rwxr-xr-x | translate/gcc/dist.sh | 1 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdldrv.adb | 1 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 10 | ||||
| -rw-r--r-- | translate/grt/Makefile.inc | 7 | ||||
| -rw-r--r-- | translate/grt/config/amd64.S | 116 | ||||
| -rw-r--r-- | translate/translation.adb | 336 | ||||
| -rw-r--r-- | xtools/Makefile | 32 |
27 files changed, 794 insertions, 259 deletions
@@ -33,8 +33,9 @@ the GHDL back-end (ghdl1) in ./translate: $ make BE=gcc the GHDL driver in ./translate/ghdldrv: $ make ghdl_gcc -the VHDL libraries: - $ cd translate/ghdldrv +the VHDL libraries (in ./translate/ghdldrv; you may need to slighly edit + Makefile to change the compiler): + $ ln -sf ghdl_gcc ghdl $ make install.all and the GHDL run-time (GRT) in ./translate/grt: $ make @@ -56,24 +56,6 @@ package body Canon is procedure Canon_Block_Configuration (Top : Iir_Design_Unit; Conf : Iir_Block_Configuration); - function Is_Signal_Object (Decl: Iir) return Boolean is - Adecl: Iir; - begin - Adecl := Get_Base_Name (Decl); - case Get_Kind (Adecl) is - when Iir_Kind_Variable_Declaration - | Iir_Kind_Variable_Interface_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Constant_Interface_Declaration => - return False; - when Iir_Kind_Signal_Declaration - | Iir_Kind_Signal_Interface_Declaration => - return True; - when others => - Error_Kind ("is_signal_object", Adecl); - end case; - end Is_Signal_Object; - procedure Canon_Extract_Sensitivity_Aggregate (Aggr : Iir; Sensitivity_List : Iir_List; diff --git a/disp_tree.adb b/disp_tree.adb index 8f4c967..fd51c14 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -1120,6 +1120,8 @@ package body Disp_Tree is Disp_Type_Resolved_Flag (Tree); Header ("signal_type_flag: ", False); Disp_Flag (Get_Signal_Type_Flag (Tree)); + Header ("has_signal_flag: ", False); + Disp_Flag (Get_Has_Signal_Flag (Tree)); Header ("type declarator:"); Disp_Tree (Get_Type_Declarator (Tree), Ntab, True); Header ("base type:"); @@ -1152,6 +1154,8 @@ package body Disp_Tree is Disp_Type_Resolved_Flag (Tree); Header ("signal_type_flag: ", False); Disp_Flag (Get_Signal_Type_Flag (Tree)); + Header ("has_signal_flag: ", False); + Disp_Flag (Get_Has_Signal_Flag (Tree)); Header ("type declarator:"); Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); Header ("base type:"); @@ -1187,6 +1191,8 @@ package body Disp_Tree is Disp_Type_Resolved_Flag (Tree); Header ("signal_type_flag: ", False); Disp_Flag (Get_Signal_Type_Flag (Tree)); + Header ("has_signal_flag: ", False); + Disp_Flag (Get_Has_Signal_Flag (Tree)); Header ("base type:"); Disp_Tree (Get_Base_Type (Tree), Ntab, True); Header ("type mark:"); @@ -1205,6 +1211,8 @@ package body Disp_Tree is Disp_Type_Resolved_Flag (Tree); Header ("signal_type_flag: ", False); Disp_Flag (Get_Signal_Type_Flag (Tree)); + Header ("has_signal_flag: ", False); + Disp_Flag (Get_Has_Signal_Flag (Tree)); Header ("index_subtype_list:"); Disp_Tree_List (Get_Index_Subtype_List (Tree), Ntab, True); Header ("element_subtype:"); @@ -1219,6 +1227,8 @@ package body Disp_Tree is Disp_Type_Resolved_Flag (Tree); Header ("signal_type_flag: ", False); Disp_Flag (Get_Signal_Type_Flag (Tree)); + Header ("has_signal_flag: ", False); + Disp_Flag (Get_Has_Signal_Flag (Tree)); Header ("elements:"); Disp_Tree_Chain (Get_Element_Declaration_Chain (Tree), Ntab, True); when Iir_Kind_Record_Subtype_Definition => @@ -133,6 +133,9 @@ package Flags is -- If set, generate cross-references during sem. Flag_Xref : Boolean := False; + -- If set, all the design units are analyzed in whole to do the simulation. + Flag_Whole_Analyze : Boolean := False; + -- --warn-undriven --Warn_Undriven : Boolean := False; @@ -937,13 +937,13 @@ package body Iirs is function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type is begin Check_Kind_For_Guarded_Target_State (Stmt); - return Tri_State_Type'Val (Get_State4 (Stmt)); + return Tri_State_Type'Val (Get_State3 (Stmt)); end Get_Guarded_Target_State; procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type) is begin Check_Kind_For_Guarded_Target_State (Stmt); - Set_State4 (Stmt, Tri_State_Type'Pos (State)); + Set_State3 (Stmt, Tri_State_Type'Pos (State)); end Set_Guarded_Target_State; procedure Check_Kind_For_Library_Unit (Target : Iir) is @@ -2380,13 +2380,13 @@ package body Iirs is function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind is begin Check_Kind_For_Signal_Kind (Target); - return Iir_Signal_Kind'Val (Get_State4 (Target)); + return Iir_Signal_Kind'Val (Get_State3 (Target)); end Get_Signal_Kind; procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind) is begin Check_Kind_For_Signal_Kind (Target); - Set_State4 (Target, Iir_Signal_Kind'Pos (Signal_Kind)); + Set_State3 (Target, Iir_Signal_Kind'Pos (Signal_Kind)); end Set_Signal_Kind; procedure Check_Kind_For_Base_Name (Target : Iir) is @@ -3623,16 +3623,16 @@ package body Iirs is end case; end Check_Kind_For_Text_File_Flag; - function Get_Text_File_Flag (Target : Iir) return Boolean is + function Get_Text_File_Flag (Atype : Iir) return Boolean is begin - Check_Kind_For_Text_File_Flag (Target); - return Get_Flag3 (Target); + Check_Kind_For_Text_File_Flag (Atype); + return Get_Flag4 (Atype); end Get_Text_File_Flag; - procedure Set_Text_File_Flag (Target : Iir; Flag : Boolean) is + procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean) is begin - Check_Kind_For_Text_File_Flag (Target); - Set_Flag3 (Target, Flag); + Check_Kind_For_Text_File_Flag (Atype); + Set_Flag4 (Atype, Flag); end Set_Text_File_Flag; procedure Check_Kind_For_Type_Staticness (Target : Iir) is @@ -3663,16 +3663,16 @@ package body Iirs is end case; end Check_Kind_For_Type_Staticness; - function Get_Type_Staticness (Target : Iir) return Iir_Staticness is + function Get_Type_Staticness (Atype : Iir) return Iir_Staticness is begin - Check_Kind_For_Type_Staticness (Target); - return Iir_Staticness'Val (Get_State1 (Target)); + Check_Kind_For_Type_Staticness (Atype); + return Iir_Staticness'Val (Get_State1 (Atype)); end Get_Type_Staticness; - procedure Set_Type_Staticness (Target : Iir; Static : Iir_Staticness) is + procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness) is begin - Check_Kind_For_Type_Staticness (Target); - Set_State1 (Target, Iir_Staticness'Pos (Static)); + Check_Kind_For_Type_Staticness (Atype); + Set_State1 (Atype, Iir_Staticness'Pos (Static)); end Set_Type_Staticness; procedure Check_Kind_For_Index_Subtype_List (Target : Iir) is @@ -4101,6 +4101,28 @@ package body Iirs is Set_Flag2 (Proc, Flag); end Set_Passive_Flag; + procedure Check_Kind_For_Resolution_Function_Flag (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Function_Declaration => + null; + when others => + Failed ("Resolution_Function_Flag", Target); + end case; + end Check_Kind_For_Resolution_Function_Flag; + + function Get_Resolution_Function_Flag (Func : Iir) return Boolean is + begin + Check_Kind_For_Resolution_Function_Flag (Func); + return Get_Flag7 (Func); + end Get_Resolution_Function_Flag; + + procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean) is + begin + Check_Kind_For_Resolution_Function_Flag (Func); + Set_Flag7 (Func, Flag); + end Set_Resolution_Function_Flag; + procedure Check_Kind_For_Wait_State (Target : Iir) is begin case Get_Kind (Target) is @@ -4283,6 +4305,42 @@ package body Iirs is Set_Flag2 (Atype, Flag); end Set_Signal_Type_Flag; + procedure Check_Kind_For_Has_Signal_Flag (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Error + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + null; + when others => + Failed ("Has_Signal_Flag", Target); + end case; + end Check_Kind_For_Has_Signal_Flag; + + function Get_Has_Signal_Flag (Atype : Iir) return Boolean is + begin + Check_Kind_For_Has_Signal_Flag (Atype); + return Get_Flag3 (Atype); + end Get_Has_Signal_Flag; + + procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean) is + begin + Check_Kind_For_Has_Signal_Flag (Atype); + Set_Flag3 (Atype, Flag); + end Set_Has_Signal_Flag; + procedure Check_Kind_For_Purity_State (Target : Iir) is begin case Get_Kind (Target) is @@ -4296,13 +4354,13 @@ package body Iirs is function Get_Purity_State (Proc : Iir) return Iir_Pure_State is begin Check_Kind_For_Purity_State (Proc); - return Iir_Pure_State'Val (Get_State3 (Proc)); + return Iir_Pure_State'Val (Get_State2 (Proc)); end Get_Purity_State; procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State) is begin Check_Kind_For_Purity_State (Proc); - Set_State3 (Proc, Iir_Pure_State'Pos (State)); + Set_State2 (Proc, Iir_Pure_State'Pos (State)); end Set_Purity_State; procedure Check_Kind_For_Elab_Flag (Target : Iir) is @@ -858,7 +858,7 @@ package Iirs is -- Get/Set_Name_Staticness (State2) -- -- Only for Iir_Kind_Signal_Interface_Declaration: - -- Get/Set_Signal_Kind (State4) + -- Get/Set_Signal_Kind (State3) -- Iir_Kind_Function_Declaration (Medium) -- Iir_Kind_Procedure_Declaration (Medium) @@ -913,8 +913,11 @@ package Iirs is -- -- Get/Set_Use_Flag (Flag6) -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Resolution_Function_Flag (Flag7) + -- -- Only for Iir_Kind_Procedure_Declaration: - -- Get/Set_Purity_State (State3) + -- Get/Set_Purity_State (State2) -- -- Get/Set_Wait_State (State1) @@ -1018,7 +1021,7 @@ package Iirs is -- -- Get/Set_Name_Staticness (State2) -- - -- Get/Set_Signal_Kind (State4) + -- Get/Set_Signal_Kind (State3) -- Iir_Kind_Guard_Signal_Declaration (Medium) -- @@ -1048,7 +1051,7 @@ package Iirs is -- -- Get/Set_Name_Staticness (State2) -- - -- Get/Set_Signal_Kind (State4) + -- Get/Set_Signal_Kind (State3) -- Iir_Kind_Constant_Declaration (Medium) -- Iir_Kind_Iterator_Declaration (Medium) @@ -1260,6 +1263,8 @@ package Iirs is -- Get/Set the signal_type flag of a type definition. -- It is true when the type can be used for a signal. -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Enumeration_Type_Definition (Short) -- @@ -1279,6 +1284,8 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Enumeration_Literal (Medium) @@ -1329,6 +1336,8 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Unit_Declaration (Medium) @@ -1363,6 +1372,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Array_Type_Definition (Medium) -- This defines an unconstrained array type. @@ -1380,6 +1391,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Record_Type_Definition (Short) -- @@ -1396,6 +1409,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Access_Type_Definition (Short) -- @@ -1416,10 +1431,6 @@ package Iirs is -- Iir_Kind_File_Type_Definition (Short) -- - -- True if this is the std.textio.text file type, which may require special - -- handling. - -- Get/Set_Text_File_Flag (Flag3) - -- -- Get/Set_Type_Mark (Field2) -- -- Get/Set_Type_Declarator (Field3) @@ -1430,6 +1441,10 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) -- + -- True if this is the std.textio.text file type, which may require special + -- handling. + -- Get/Set_Text_File_Flag (Flag4) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Incomplete_Type_Definition (Short) @@ -1449,6 +1464,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Protected_Type_Declaration (Short) -- @@ -1501,6 +1518,8 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Access_Subtype_Definition (Short) @@ -1533,6 +1552,8 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Array_Subtype_Definition (Medium) @@ -1564,6 +1585,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- Iir_Kind_Range_Expression (Short) -- @@ -1629,7 +1652,7 @@ package Iirs is -- Get/Set_Visible_Flag (Flag4) -- -- True if the target of the assignment is guarded - -- Get_Guarded_Target_State (State4) + -- Get_Guarded_Target_State (State3) -- Iir_Kind_Sensitized_Process_Statement (Medium) -- Iir_Kind_Process_Statement (Medium) @@ -1892,7 +1915,7 @@ package Iirs is -- Get/Set_Visible_Flag (Flag4) -- -- True if the target of the assignment is guarded - -- Get_Guarded_Target_State (State4) + -- Get_Guarded_Target_State (State3) -- Iir_Kind_Variable_Assignment_Statement (Short) -- @@ -2405,6 +2428,8 @@ package Iirs is -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) -- End of Iir_Kind. @@ -3833,7 +3858,7 @@ package Iirs is -- target). -- If UNKNOWN, this is not determined at compile time but at run-time. -- This is the case for formal signal interfaces of subprograms. - -- Field: State4 (pos) + -- Field: State3 (pos) function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type; procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type); @@ -4116,7 +4141,7 @@ package Iirs is function Get_Mode (Target : Iir) return Iir_Mode; procedure Set_Mode (Target : Iir; Mode : Iir_Mode); - -- Field: State4 (pos) + -- Field: State3 (pos) function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind; procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind); @@ -4356,13 +4381,14 @@ package Iirs is function Get_Resolution_Function (Decl : Iir) return Iir; procedure Set_Resolution_Function (Decl : Iir; Func : Iir); - -- Field: Flag3 - function Get_Text_File_Flag (Target : Iir) return Boolean; - procedure Set_Text_File_Flag (Target : Iir; Flag : Boolean); + -- True if ATYPE defines std.textio.text file type. + -- Field: Flag4 + function Get_Text_File_Flag (Atype : Iir) return Boolean; + procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean); -- Field: State1 (pos) - function Get_Type_Staticness (Target : Iir) return Iir_Staticness; - procedure Set_Type_Staticness (Target : Iir; Static : Iir_Staticness); + function Get_Type_Staticness (Atype : Iir) return Iir_Staticness; + procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness); -- Field: Field6 (uc) function Get_Index_Subtype_List (Decl : Iir) return Iir_List; @@ -4451,6 +4477,11 @@ package Iirs is function Get_Passive_Flag (Proc : Iir) return Boolean; procedure Set_Passive_Flag (Proc : Iir; Flag : Boolean); + -- True if the function is used as a resolution function. + -- Field: Flag7 + function Get_Resolution_Function_Flag (Func : Iir) return Boolean; + procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean); + -- Get/Set the wait state of the current subprogram or process. -- TRUE if it contains a wait statement, either directly or -- indirectly. @@ -4496,8 +4527,14 @@ package Iirs is function Get_Signal_Type_Flag (Atype : Iir) return Boolean; procedure Set_Signal_Type_Flag (Atype : Iir; Flag : Boolean); + -- True if ATYPE is used to declare a signal or to handle a signal + -- (such as slice or aliases). + -- Field: Flag3 + function Get_Has_Signal_Flag (Atype : Iir) return Boolean; + procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean); + -- Get/Set the purity status of a subprogram. - -- Field: State3 (pos) + -- Field: State2 (pos) function Get_Purity_State (Proc : Iir) return Iir_Pure_State; procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State); diff --git a/iirs_utils.adb b/iirs_utils.adb index b5b63d2..0a336c5 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -810,4 +810,28 @@ package body Iirs_Utils is end case; end Get_Physical_Literal_Value; + function Is_Signal_Object (Name : Iir) return Boolean + is + Adecl: Iir; + begin + Adecl := Get_Base_Name (Name); + case Get_Kind (Adecl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call => + return False; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration => + return True; + when others => + Error_Kind ("is_signal_object", Adecl); + end case; + end Is_Signal_Object; + + end Iirs_Utils; diff --git a/iirs_utils.ads b/iirs_utils.ads index f567d10..90de032 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -152,5 +152,9 @@ package Iirs_Utils is -- a unit_declaration. -- See also Evaluation.Get_Physical_Value. function Get_Physical_Literal_Value (Lit : Iir) return Iir_Int64; + + -- Return TRUE if the base name of NAME is a signal object. + function Is_Signal_Object (Name: Iir) return Boolean; + end Iirs_Utils; @@ -320,6 +320,16 @@ package body Nodes is Nodet.Table (N).Flag6 := V; end Set_Flag6; + function Get_Flag7 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag7; + end Get_Flag7; + + procedure Set_Flag7 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag7 := V; + end Set_Flag7; + function Get_State1 (N : Node_Type) return Bit2_Type is begin @@ -343,22 +353,22 @@ package body Nodes is function Get_State3 (N : Node_Type) return Bit2_Type is begin - return Nodet.Table (N).State3; + return Nodet.Table (N + 1).State1; end Get_State3; procedure Set_State3 (N : Node_Type; V : Bit2_Type) is begin - Nodet.Table (N).State3 := V; + Nodet.Table (N + 1).State1 := V; end Set_State3; function Get_State4 (N : Node_Type) return Bit2_Type is begin - return Nodet.Table (N).State4; + return Nodet.Table (N + 1).State2; end Get_State4; procedure Set_State4 (N : Node_Type; V : Bit2_Type) is begin - Nodet.Table (N).State4 := V; + Nodet.Table (N + 1).State2 := V; end Set_State4; @@ -61,6 +61,7 @@ package Nodes is -- Flag4 : Boolean -- Flag5 : Boolean -- Flag6 : Boolean + -- Flag7 : Boolean -- Nkind : Kind_Type -- State1 : Bit2_Type -- State2 : Bit2_Type @@ -205,6 +206,11 @@ package Nodes is procedure Set_Flag6 (N : Node_Type; V : Boolean); pragma Inline (Set_Flag6); + function Get_Flag7 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag7); + procedure Set_Flag7 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag7); + function Get_State1 (N : Node_Type) return Bit2_Type; pragma Inline (Get_State1); @@ -364,30 +370,12 @@ private -- purity_state for iir_kind_sensitized_process_statement -- purity_state for iir_kinds_procedure_specification -- purity_state for iir_kinds_function_specification - State3 : Bit2_Type := 0; - - -- Usages of State4: - -- wait_state for iir_kind_process_statement - -- wait_state for iir_kind_sensitized_process_statement - -- wait_state for iir_kinds_procedure_specification - -- wait_state for iir_kinds_function_specification - State4 : Bit2_Type := 0; - - -- 2bits fields (4 -> 8 bits) - -- Usages of State5: - -- passive_state for iir_kind_process_statement - -- passive_state for iir_kind_sensitized_process_statement - -- passive_state for iir_kinds_procedure_specification - -- passive_state for iir_kinds_function_specification - -- signal_kind for iir_kind_signal_declaration - -- signal_kind for iir_kind_guard_signal_declaration - -- signal_kind for iir_kind_signal_interface_declaration - -- direction for iir_kind_range_expression - -- direction for iir_kind_file_declaration - -- guarded_target_flag for iir_kind_concurrent_conditional_signal_assign - -- guarded_target_flag for iir_kind_selected_conditional_signal_assign - -- guarded_target_flag for iir_kind_signal_assignment_statement - Unused_State5 : Bit2_Type := 0; + Unused_State3 : Bit2_Type := 0; + + Flag7 : Boolean := False; + Flag8 : Boolean := False; + Flag9 : Boolean := False; + Flag10 : Boolean := False; -- 3bits fields (1 -> 3 bits) -- Usages of odigit1: diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c index e223f41..c024558 100644 --- a/ortho/gcc/ortho-lang.c +++ b/ortho/gcc/ortho-lang.c @@ -72,6 +72,8 @@ push_binding (void) 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; @@ -906,8 +908,10 @@ new_alloca (tree rtype, tree size) tree res; tree args; - /* Must save stack. */ - cur_binding_level->save_stack = 1; + /* 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; args = tree_cons (NULL_TREE, fold_convert (size_type_node, size), NULL_TREE); res = build3 (CALL_EXPR, ptr_type_node, stack_alloc_function_ptr, @@ -919,9 +923,16 @@ tree new_signed_literal (tree ltype, long long value) { tree res; + HOST_WIDE_INT lo; + HOST_WIDE_INT hi; + + lo = value; + if (sizeof (HOST_WIDE_INT) == sizeof (long long)) + hi = value >> (8 * sizeof (HOST_WIDE_INT) - 1); + else + hi = value >> (8 * sizeof (HOST_WIDE_INT)); - res = build_int_cst_wide (ltype, - value, value >> (8 * sizeof (HOST_WIDE_INT))); + res = build_int_cst_wide (ltype, lo, hi); return res; } @@ -929,9 +940,16 @@ tree new_unsigned_literal (tree ltype, unsigned long long value) { tree res; + unsigned HOST_WIDE_INT lo; + unsigned HOST_WIDE_INT hi; + + lo = value; + if (sizeof (HOST_WIDE_INT) == sizeof (long long)) + hi = 0; + else + hi = value >> (8 * sizeof (HOST_WIDE_INT)); - res = build_int_cst_wide (ltype, - value, value >> (8 * sizeof (HOST_WIDE_INT))); + res = build_int_cst_wide (ltype, lo, hi); return res; } @@ -954,14 +972,20 @@ new_float_literal (tree ltype, double value) 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); - REAL_VALUE_FROM_INT (r_sign, - (HOST_WIDE_INT) s, - (HOST_WIDE_INT) (s >> (8 * sizeof (HOST_WIDE_INT))), - DFmode); + lo = s; + if (sizeof (HOST_WIDE_INT) == sizeof (long long)) + hi = s >> (8 * sizeof (HOST_WIDE_INT) - 1); + else + hi = s >> (8 * sizeof (HOST_WIDE_INT)); + + res = build_int_cst_wide (ltype, lo, hi); + REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode); real_2expN (&r_exp, ex - 60); real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp); res = build_real (ltype, r); @@ -1617,6 +1641,8 @@ new_interface_decl (struct o_inter_list *interfaces, DECL_ARG_TYPE (r) = atype; } + layout_decl (r, 0); + chain_append (&interfaces->param_chain, r); ortho_list_append (&interfaces->param_list, atype); *res = r; @@ -1634,6 +1660,10 @@ finish_subprogram_decl (struct o_inter_list *interfaces, tree *res) 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 (FUNCTION_DECL, interfaces->ident, build_function_type (interfaces->rtype, interfaces->param_list.first)); @@ -75,7 +75,7 @@ package body Sem is -- entity declarative part. Push_Signals_Declarative_Part (Implicit, Entity); - Sem_Declaration_Chain (Entity); + Sem_Declaration_Chain (Entity, not Flags.Flag_Whole_Analyze); Sem_Specification_Chain (Entity, Null_Iir); -- Check for missing subprogram bodies. @@ -557,7 +557,7 @@ package body Sem is Add_Context_Clauses (Entity_Design); Sem_Scopes.Add_Entity_Declarations (Get_Library_Unit (Entity_Design)); - Sem_Declaration_Chain (Decl); + Sem_Declaration_Chain (Decl, False); -- GHDL: no need to check for missing subprogram bodies, since they are -- not allowed in configuration declarations. @@ -2002,7 +2002,7 @@ package body Sem is Push_Signals_Declarative_Part (Implicit, Decl); - Sem_Declaration_Chain (Decl); + Sem_Declaration_Chain (Decl, not Flags.Flag_Whole_Analyze); -- GHDL: subprogram bodies appear in package body. Pop_Signals_Declarative_Part (Implicit); @@ -2059,7 +2059,7 @@ package body Sem is Sem_Scopes.Add_Package_Declarations (Package_Decl); - Sem_Declaration_Chain (Decl); + Sem_Declaration_Chain (Decl, False); Check_Full_Declaration (Decl, Decl); Check_Full_Declaration (Package_Decl, Decl); diff --git a/sem_decls.adb b/sem_decls.adb index da0e85d..a51d0fa 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -131,6 +131,7 @@ package body Sem_Decls is Error_Msg_Sem ("interface signal can't be of kind register", El); end case; + Set_Type_Has_Signal (A_Type); end if; case Get_Kind (El) is @@ -950,7 +951,7 @@ package body Sem_Decls is end if; end Create_Implicit_Operations; - procedure Sem_Type_Declaration (Decl: Iir) + procedure Sem_Type_Declaration (Decl: Iir; Is_Global : Boolean) is Def: Iir; Inter : Name_Interpretation_Type; @@ -1092,11 +1093,15 @@ package body Sem_Decls is end if; end; end if; + + if Is_Global then + Set_Type_Has_Signal (Def); + end if; end if; end if; end Sem_Type_Declaration; - procedure Sem_Subtype_Declaration (Decl: Iir) + procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) is Def: Iir; Res: Iir; @@ -1176,6 +1181,9 @@ package body Sem_Decls is Set_Type (Decl, Def); Set_Type_Declarator (Def, Decl); Name_Visible (Decl); + if Is_Global then + Set_Type_Has_Signal (Def); + end if; end Sem_Subtype_Declaration; -- If DECL is a constant declaration, and there is already a constant @@ -1372,6 +1380,7 @@ package body Sem_Decls is end if; Set_Expr_Staticness (Decl, None); Set_Has_Disconnect_Flag (Decl, False); + Set_Type_Has_Signal (Atype); when Iir_Kind_Variable_Declaration => -- LRM93 4.3.1.3 Variable declarations @@ -1740,6 +1749,9 @@ package body Sem_Decls is Set_Name_Staticness (Alias, Get_Name_Staticness (N_Name)); Set_Expr_Staticness (Alias, Get_Expr_Staticness (N_Name)); + if Is_Signal_Object (N_Name) then + Set_Type_Has_Signal (N_Type); + end if; end Sem_Object_Alias_Declaration; function Signature_Match (N_Entity : Iir; Sig : Iir_Signature) @@ -2144,28 +2156,61 @@ package body Sem_Decls is Set_Visible_Flag (Group, True); end Sem_Group_Declaration; + -- Return TRUE if FUNC can be a resolution function. + function Can_Be_Resolution_Function (Func : Iir_Function_Declaration) + return Boolean + is + Param : Iir; + Param_Type : Iir; + Res_Type : Iir; + begin + Param := Get_Interface_Declaration_Chain (Func); + + -- Return now if the number of parameters is not 1. + if Param = Null_Iir or else Get_Chain (Param) /= Null_Iir then + return False; + end if; + Param_Type := Get_Type (Param); + case Get_Kind (Param_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + null; + when others => + return False; + end case; + Res_Type := Get_Return_Type (Func); + if Get_Base_Type (Get_Element_Subtype (Param_Type)) + /= Get_Base_Type (Res_Type) + then + return False; + end if; + return True; + end Can_Be_Resolution_Function; + -- Semantize every declaration of DECLS_PARENT. -- STMTS is the concurrent statement list associated with DECLS_PARENT -- if any, or null_iir. This is used for specification. - procedure Sem_Declaration_Chain (Parent : Iir) + procedure Sem_Declaration_Chain (Parent : Iir; Is_Global : Boolean) is Decl: Iir; Last_Decl : Iir; Attr_Spec_Chain : Iir; + Kind : Iir_Kind; begin -- Due to implicit declarations, the list can grow during sem. Decl := Get_Declaration_Chain (Parent); Last_Decl := Null_Iir; Attr_Spec_Chain := Null_Iir; + loop << Again >> exit when Decl = Null_Iir; - case Get_Kind (Decl) is - when Iir_Kind_Type_Declaration => - Sem_Type_Declaration (Decl); - when Iir_Kind_Anonymous_Type_Declaration => - Sem_Type_Declaration (Decl); + Kind := Get_Kind (Decl); + case Kind is + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Sem_Type_Declaration (Decl, Is_Global); when Iir_Kind_Subtype_Declaration => - Sem_Subtype_Declaration (Decl); + Sem_Subtype_Declaration (Decl, Is_Global); when Iir_Kind_Signal_Declaration => Sem_Object_Declaration (Decl, Parent); when Iir_Kind_Constant_Declaration => @@ -2200,6 +2245,12 @@ package body Sem_Decls is -- attribute specification. goto Again; end if; + if Is_Global + and then Kind = Iir_Kind_Function_Declaration + and then Can_Be_Resolution_Function (Res) + then + Set_Resolution_Function_Flag (Res, True); + end if; end; when Iir_Kind_Function_Body | Iir_Kind_Procedure_Body => diff --git a/sem_decls.ads b/sem_decls.ads index c8dede1..dfd389f 100644 --- a/sem_decls.ads +++ b/sem_decls.ads @@ -32,7 +32,10 @@ package Sem_Decls is (Decl : Iir; Is_Std_Standard : Boolean := False); -- Semantize declarations of PARENT. - procedure Sem_Declaration_Chain (Parent : Iir); + -- If IS_GLOBAL is set, then declarations may be seen outside of the units. + -- This must be set for entities and packages (except when + -- Flags.Flag_Whole_Analyze is set). + procedure Sem_Declaration_Chain (Parent : Iir; Is_Global : Boolean); -- Check all declarations of DECLS_PARENT are complete -- This checks subprograms, deferred constants, incomplete types and diff --git a/sem_expr.adb b/sem_expr.adb index 77735b4..d850f76 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -3313,7 +3313,7 @@ package body Sem_Expr is -- Emit an error if the constant EXPR is deferred and cannot be used in -- the current context. - procedure Check_Constant_Restriction (Expr : Iir) + procedure Check_Constant_Restriction (Expr : Iir; Loc : Iir) is Lib : Iir; Cur_Lib : Iir; @@ -3346,7 +3346,7 @@ package body Sem_Expr is or else (Get_Kind (Cur_Lib) = Iir_Kind_Package_Body and then Get_Package (Cur_Lib) = Lib) then - Error_Msg_Sem ("invalid use of a deferred constant", Expr); + Error_Msg_Sem ("invalid use of a deferred constant", Loc); end if; end Check_Constant_Restriction; @@ -3459,7 +3459,7 @@ package body Sem_Expr is if Get_Kind (E) = Iir_Kind_Constant_Declaration and then not Deferred_Constant_Allowed then - Check_Constant_Restriction (E); + Check_Constant_Restriction (E, Expr); end if; E := Name_To_Expression (Expr, A_Type); return E; diff --git a/sem_names.adb b/sem_names.adb index 1cd3635..749a3cd 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -15,22 +15,23 @@ -- 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 Sem_Scopes; use Sem_Scopes; -with Sem_Expr; use Sem_Expr; with Evaluation; use Evaluation; with Iirs_Utils; use Iirs_Utils; with Libraries; with Errorout; use Errorout; with Flags; -with Sem; with Name_Table; with Std_Package; use Std_Package; with Types; use Types; -with Std_Names; with Iir_Chains; use Iir_Chains; +with Std_Names; +with Sem; +with Sem_Scopes; use Sem_Scopes; +with Sem_Expr; use Sem_Expr; with Sem_Stmts; use Sem_Stmts; with Sem_Decls; use Sem_Decls; with Sem_Assocs; use Sem_Assocs; +with Sem_Types; with Xrefs; use Xrefs; package body Sem_Names is @@ -667,6 +668,9 @@ package body Sem_Names is (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), Get_Type_Staticness (Slice_Type))); Set_Type (Name, Expr_Type); + if Is_Signal_Object (Prefix) then + Sem_Types.Set_Type_Has_Signal (Expr_Type); + end if; end Finish_Sem_Slice_Name; procedure Finish_Sem_Function_Call (Call : Iir) diff --git a/sem_stmts.adb b/sem_stmts.adb index b0e5b3c..4357065 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -19,12 +19,13 @@ with Errorout; use Errorout; with Types; use Types; with Flags; with Sem_Specs; use Sem_Specs; +with Std_Package; use Std_Package; with Sem; use Sem; with Sem_Decls; use Sem_Decls; with Sem_Expr; use Sem_Expr; -with Std_Package; use Std_Package; with Sem_Names; use Sem_Names; with Sem_Scopes; use Sem_Scopes; +with Sem_Types; with Std_Names; with Evaluation; use Evaluation; with Iirs_Utils; use Iirs_Utils; @@ -465,6 +466,7 @@ package body Sem_Stmts is if Target /= Null_Iir then Set_Target (Stmt, Target); Check_Target (Stmt, Target); + Sem_Types.Set_Type_Has_Signal (Get_Type (Target)); else Ok := False; end if; @@ -1214,7 +1216,7 @@ package body Sem_Stmts is -- Sem declarations Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent)); - Sem_Declaration_Chain (Body_Parent); + Sem_Declaration_Chain (Body_Parent, False); Sem_Specification_Chain (Body_Parent, Null_Iir); -- Sem statements. @@ -1807,7 +1809,7 @@ package body Sem_Stmts is if Sem_Decls then Sem_Labels_Chain (Blk); - Sem_Declaration_Chain (Blk); + Sem_Declaration_Chain (Blk, False); end if; Sem_Concurrent_Statement_Chain (Blk, False); diff --git a/sem_types.adb b/sem_types.adb index c378db2..bb946a5 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -31,6 +31,66 @@ with Std_Package; use Std_Package; with Xrefs; use Xrefs; package body Sem_Types is + procedure Set_Type_Has_Signal (Atype : Iir) + is + begin + -- Sanity check. + if not Get_Signal_Type_Flag (Atype) then + -- Do not crash since this may be called on an erroneous design. + return; + end if; + + -- If the type is already marked, nothing to do. + if Get_Has_Signal_Flag (Atype) then + return; + end if; + + Set_Has_Signal_Flag (Atype, True); + + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when Iir_Kinds_Subtype_Definition => + declare + Func : Iir_Function_Declaration; + Mark : Iir; + begin + Set_Type_Has_Signal (Get_Base_Type (Atype)); + Func := Get_Resolution_Function (Atype); + if Func /= Null_Iir then + Func := Get_Named_Entity (Func); + Set_Resolution_Function_Flag (Func, True); + end if; + Mark := Get_Type_Mark (Atype); + if Mark /= Null_Iir then + Set_Type_Has_Signal (Mark); + end if; + end; + when Iir_Kind_Array_Type_Definition => + Set_Type_Has_Signal (Get_Element_Subtype (Atype)); + when Iir_Kind_Record_Type_Definition => + declare + El : Iir; + begin + El := Get_Element_Declaration_Chain (Atype); + while El /= Null_Iir loop + Set_Type_Has_Signal (Get_Type (El)); + El := Get_Chain (El); + end loop; + end; + when Iir_Kind_Error => + null; + when Iir_Kind_Incomplete_Type_Definition => + -- No need to copy the flag. + null; + when others => + Error_Kind ("set_type_has_signal(2)", Atype); + end case; + end Set_Type_Has_Signal; + -- Sem a range expression. -- Both left and right bounds must be of the same type kind, ie -- integer types, or if INT_ONLY is false, real types. @@ -419,7 +479,7 @@ package body Sem_Types is -- body. Open_Declarative_Region; - Sem_Decls.Sem_Declaration_Chain (Decl); + Sem_Decls.Sem_Declaration_Chain (Decl, False); El := Get_Declaration_Chain (Decl); while El /= Null_Iir loop case Get_Kind (El) is @@ -540,7 +600,7 @@ package body Sem_Types is Add_Protected_Type_Declarations (Decl); end if; - Sem_Decls.Sem_Declaration_Chain (Bod); + Sem_Decls.Sem_Declaration_Chain (Bod, False); El := Get_Declaration_Chain (Bod); while El /= Null_Iir loop diff --git a/sem_types.ads b/sem_types.ads index 390976e..6df559d 100644 --- a/sem_types.ads +++ b/sem_types.ads @@ -38,4 +38,11 @@ package Sem_Types is -- A_RANGE. -- This function extract the type of the range expression. function Range_To_Subtype_Definition (A_Range: Iir) return Iir; + + -- ATYPE is used to declare a signal. + -- Set (recursively) the Has_Signal_Flag on ATYPE and all types used by + -- ATYPE (basetype, elements...) + -- If ATYPE can have signal (eg: access or file type), then this procedure + -- returns silently. + procedure Set_Type_Has_Signal (Atype : Iir); end Sem_Types; diff --git a/std_package.adb b/std_package.adb index 4cf1b45..2f3832a 100644 --- a/std_package.adb +++ b/std_package.adb @@ -187,6 +187,7 @@ package body Std_Package is Set_Base_Type (Type_Definition, Type_Definition); Set_Type_Staticness (Type_Definition, Locally); Set_Signal_Type_Flag (Type_Definition, True); + Set_Has_Signal_Flag (Type_Definition, not Flags.Flag_Whole_Analyze); Type_Decl := Create_Std_Iir (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Type_Decl, Type_Name); @@ -213,6 +214,8 @@ package body Std_Package is Set_Range_Constraint (Subtype_Definition, Constraint); Set_Type_Staticness (Subtype_Definition, Locally); Set_Signal_Type_Flag (Subtype_Definition, True); + Set_Has_Signal_Flag (Subtype_Definition, + not Flags.Flag_Whole_Analyze); -- type is Subtype_Decl := Create_Std_Iir (Iir_Kind_Subtype_Declaration); @@ -272,6 +275,8 @@ package body Std_Package is (Name_True, Boolean_Type_Definition); Set_Type_Staticness (Boolean_Type_Definition, Locally); Set_Signal_Type_Flag (Boolean_Type_Definition, True); + Set_Has_Signal_Flag (Boolean_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type boolean is Boolean_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); @@ -299,6 +304,8 @@ package body Std_Package is (Get_Std_Character ('1'), Bit_Type_Definition); Set_Type_Staticness (Bit_Type_Definition, Locally); Set_Signal_Type_Flag (Bit_Type_Definition, True); + Set_Has_Signal_Flag (Bit_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type bit is Bit_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); @@ -341,6 +348,8 @@ package body Std_Package is end if; Set_Type_Staticness (Character_Type_Definition, Locally); Set_Signal_Type_Flag (Character_Type_Definition, True); + Set_Has_Signal_Flag (Character_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type character is Character_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); @@ -375,6 +384,8 @@ package body Std_Package is (Name_Failure, Severity_Level_Type_Definition); Set_Type_Staticness (Severity_Level_Type_Definition, Locally); Set_Signal_Type_Flag (Severity_Level_Type_Definition, True); + Set_Has_Signal_Flag (Severity_Level_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type severity_level is Severity_Level_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); @@ -421,6 +432,7 @@ package body Std_Package is Universal_Real_Type_Definition); Set_Type_Staticness (Universal_Real_Type_Definition, Locally); Set_Signal_Type_Flag (Universal_Real_Type_Definition, True); + Set_Has_Signal_Flag (Universal_Real_Type_Definition, False); Universal_Real_Type := Create_Std_Iir (Iir_Kind_Anonymous_Type_Declaration); @@ -441,6 +453,7 @@ package body Std_Package is Set_Range_Constraint (Universal_Real_Subtype_Definition, Constraint); Set_Type_Staticness (Universal_Real_Subtype_Definition, Locally); Set_Signal_Type_Flag (Universal_Real_Subtype_Definition, True); + Set_Has_Signal_Flag (Universal_Real_Subtype_Definition, False); -- type is Universal_Real_Subtype := @@ -476,6 +489,7 @@ package body Std_Package is Convertible_Real_Type_Definition); Set_Type_Staticness (Convertible_Real_Type_Definition, Locally); Set_Signal_Type_Flag (Convertible_Real_Type_Definition, True); + Set_Has_Signal_Flag (Convertible_Real_Type_Definition, False); Convertible_Real_Type := Create_Std_Iir (Iir_Kind_Anonymous_Type_Declaration); @@ -514,6 +528,8 @@ package body Std_Package is Set_Base_Type (Real_Type_Definition, Real_Type_Definition); Set_Type_Staticness (Real_Type_Definition, Locally); Set_Signal_Type_Flag (Real_Type_Definition, True); + Set_Has_Signal_Flag (Real_Type_Definition, + not Flags.Flag_Whole_Analyze); Real_Type := Create_Std_Iir (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Real_Type, Name_Real); @@ -533,6 +549,8 @@ package body Std_Package is Set_Range_Constraint (Real_Subtype_Definition, Constraint); Set_Type_Staticness (Real_Subtype_Definition, Locally); Set_Signal_Type_Flag (Real_Subtype_Definition, True); + Set_Has_Signal_Flag (Real_Subtype_Definition, + not Flags.Flag_Whole_Analyze); Real_Subtype := Create_Std_Iir (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Real_Subtype, Name_Real); @@ -558,6 +576,8 @@ package body Std_Package is Set_Range_Constraint (Natural_Subtype_Definition, Constraint); Set_Type_Staticness (Natural_Subtype_Definition, Locally); Set_Signal_Type_Flag (Natural_Subtype_Definition, True); + Set_Has_Signal_Flag (Natural_Subtype_Definition, + not Flags.Flag_Whole_Analyze); Natural_Subtype := Create_Std_Iir (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Natural_Subtype, Name_Natural); @@ -582,6 +602,8 @@ package body Std_Package is Set_Range_Constraint (Positive_Subtype_Definition, Constraint); Set_Type_Staticness (Positive_Subtype_Definition, Locally); Set_Signal_Type_Flag (Positive_Subtype_Definition, True); + Set_Has_Signal_Flag (Positive_Subtype_Definition, + not Flags.Flag_Whole_Analyze); Positive_Subtype := Create_Std_Iir (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Positive_Subtype, Name_Positive); @@ -603,6 +625,8 @@ package body Std_Package is Character_Type_Definition); Set_Type_Staticness (String_Type_Definition, None); Set_Signal_Type_Flag (String_Type_Definition, True); + Set_Has_Signal_Flag (String_Type_Definition, + not Flags.Flag_Whole_Analyze); String_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); Set_Std_Identifier (String_Type, Name_String); @@ -626,6 +650,8 @@ package body Std_Package is Set_Element_Subtype (Bit_Vector_Type_Definition, Bit_Type_Definition); Set_Type_Staticness (Bit_Vector_Type_Definition, None); Set_Signal_Type_Flag (Bit_Vector_Type_Definition, True); + Set_Has_Signal_Flag (Bit_Vector_Type_Definition, + not Flags.Flag_Whole_Analyze); Bit_Vector_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); Set_Std_Identifier (Bit_Vector_Type, Name_Bit_Vector); @@ -700,6 +726,8 @@ package body Std_Package is Set_Base_Type (Time_Type_Definition, Time_Type_Definition); Set_Type_Staticness (Time_Type_Definition, Locally);--Time_Staticness Set_Signal_Type_Flag (Time_Type_Definition, True); + Set_Has_Signal_Flag (Time_Type_Definition, + not Flags.Flag_Whole_Analyze); Build_Init (Last_Unit); @@ -741,6 +769,8 @@ package body Std_Package is --Set_Type_Mark (Time_Subtype_Definition, Time_Type_Definition); Set_Type_Staticness (Time_Subtype_Definition, Time_Staticness); Set_Signal_Type_Flag (Time_Subtype_Definition, True); + Set_Has_Signal_Flag (Time_Subtype_Definition, + not Flags.Flag_Whole_Analyze); -- subtype Time_Subtype := Create_Std_Iir (Iir_Kind_Subtype_Declaration); @@ -790,6 +820,8 @@ package body Std_Package is Set_Type_Staticness (Delay_Length_Subtype_Definition, Time_Staticness); Set_Signal_Type_Flag (Delay_Length_Subtype_Definition, True); + Set_Has_Signal_Flag (Delay_Length_Subtype_Definition, + not Flags.Flag_Whole_Analyze); Delay_Length_Subtype := Create_Std_Iir (Iir_Kind_Subtype_Declaration); @@ -847,6 +879,8 @@ package body Std_Package is (Name_Append_Mode, File_Open_Kind_Type_Definition); Set_Type_Staticness (File_Open_Kind_Type_Definition, Locally); Set_Signal_Type_Flag (File_Open_Kind_Type_Definition, True); + Set_Has_Signal_Flag (File_Open_Kind_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type file_open_kind is File_Open_Kind_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); @@ -887,6 +921,8 @@ package body Std_Package is (Name_Mode_Error, File_Open_Status_Type_Definition); Set_Type_Staticness (File_Open_Status_Type_Definition, Locally); Set_Signal_Type_Flag (File_Open_Status_Type_Definition, True); + Set_Has_Signal_Flag (File_Open_Status_Type_Definition, + not Flags.Flag_Whole_Analyze); -- type file_open_kind is File_Open_Status_Type := Create_Std_Iir (Iir_Kind_Type_Declaration); diff --git a/translate/gcc/dist.sh b/translate/gcc/dist.sh index 59effd4..e16475a 100755 --- a/translate/gcc/dist.sh +++ b/translate/gcc/dist.sh @@ -366,6 +366,7 @@ i386.S sparc.S ppc.S ia64.S +amd64.S times.c clock.c linux.c diff --git a/translate/ghdldrv/ghdldrv.adb b/translate/ghdldrv/ghdldrv.adb index 6612fb3..5b9b8ad 100644 --- a/translate/ghdldrv/ghdldrv.adb +++ b/translate/ghdldrv/ghdldrv.adb @@ -1223,6 +1223,7 @@ package body Ghdldrv is if Elab_Index < 0 then Analyze_Files (Args, True); else + Flags.Flag_Whole_Analyze := True; Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last)); Setup_Compiler (False); diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index df64ebc..55be418 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -84,6 +84,9 @@ package body Ghdlrun is -- Initialize. Back_End.Finish_Compilation := Trans_Be.Finish_Compilation'Access; + -- The design is always analyzed in whole. + Flags.Flag_Whole_Analyze := True; + Setup_Libraries (False); Libraries.Load_Std_Library; @@ -458,8 +461,11 @@ package body Ghdlrun is Std_Standard_Bit_RTI_Ptr := Get_Address (Trans_Decls.Std_Standard_Bit_Rti); if Ieee.Std_Logic_1164.Resolved /= Null_Iir then - Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := Get_Address - (Translation.Get_Resolv_Ortho_Decl (Ieee.Std_Logic_1164.Resolved)); + Decl := Translation.Get_Resolv_Ortho_Decl + (Ieee.Std_Logic_1164.Resolved); + if Decl /= O_Dnode_Null then + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := Get_Address (Decl); + end if; end if; Def (Trans_Decls.Ghdl_Protected_Enter, diff --git a/translate/grt/Makefile.inc b/translate/grt/Makefile.inc index 249e84b..4e4388a 100644 --- a/translate/grt/Makefile.inc +++ b/translate/grt/Makefile.inc @@ -45,6 +45,10 @@ ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) GRT_TARGET_OBJS=i386.o linux.o times.o GRT_EXTRA_LIB=-ldl endif +ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB=-ldl +endif ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),) GRT_TARGET_OBJS=sparc.o linux.o times.o GRT_EXTRA_LIB=-ldl @@ -109,6 +113,9 @@ ppc.o: $(GRTSRCDIR)/config/ppc.S ia64.o: $(GRTSRCDIR)/config/ia64.S $(CC) -c $(GRT_FLAGS) -o $@ $< +amd64.o: $(GRTSRCDIR)/config/amd64.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + linux.o: $(GRTSRCDIR)/config/linux.c $(CC) -c $(GRT_FLAGS) -o $@ $< diff --git a/translate/grt/config/amd64.S b/translate/grt/config/amd64.S new file mode 100644 index 0000000..76475ac --- /dev/null +++ b/translate/grt/config/amd64.S @@ -0,0 +1,116 @@ +/* GRT stack implementation for amd64 (x86_64) + 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. +*/ + .file "amd64.S" + .version "01.01" + + .text + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,@function +grt_stack_loop: + mov 0(%rsp),%rdi + call *8(%rsp) + jmp grt_stack_loop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + Args: FUNC (RDI), ARG (RSI) + */ + .align 4 + .globl grt_stack_create + .type grt_stack_create,@function +grt_stack_create: + /* Standard prologue. */ + pushq %rbp + movq %rsp,%rbp + /* Save args. */ + sub $0x10,%rsp + mov %rdi,-8(%rbp) + mov %rsi,-16(%rbp) + + /* Allocate the stack, and exit in case of failure */ + callq grt_stack_allocate + test %rax,%rax + je .Ldone + + /* Note: %RAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + mov -8(%rbp), %rdi + mov %rdi, -8(%rax) + /* The argument. */ + mov -16(%rbp), %rsi + mov %rsi, -16(%rax) + /* The return function. Must be 8 mod 16. */ + movq $grt_stack_loop, -24(%rax) + /* The context. */ + mov %rbp, -32(%rax) + mov %rbx, -40(%rax) + mov %r12, -48(%rax) + mov %r13, -56(%rax) + mov %r14, -64(%rax) + mov %r15, -72(%rax) + + /* Save the new stack pointer to the stack context. */ + lea -72(%rax), %rsi + mov %rsi, (%rax) + +.Ldone: + leave + ret + .size grt_stack_create,. - grt_stack_create + + + + .align 4 + .globl grt_stack_switch + /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)] + Both are pointers to a stack_context. */ + .type grt_stack_switch,@function +grt_stack_switch: + /* Save call-used registers. */ + pushq %rbp + pushq %rbx + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + /* Save the current stack. */ + movq %rsp, (%rsi) + /* Stack switch. */ + movq (%rdi), %rsp + /* Restore call-used registers. */ + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbx + popq %rbp + /* Return val. */ + movq %rdx, %rax + /* Run. */ + ret + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/translate/translation.adb b/translate/translation.adb index 7881530..a55314a 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -1377,8 +1377,15 @@ package body Translation is function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode is + Info : Subprg_Resolv_Info_Acc; begin - return Get_Info (Func).Subprg_Resolv.Resolv_Func; + Info := Get_Info (Func).Subprg_Resolv; + if Info = null then + -- Maybe the resolver is not used. + return O_Dnode_Null; + else + return Info.Resolv_Func; + end if; end Get_Resolv_Ortho_Decl; -- Return true is INFO is a type info for a composite type, ie: @@ -1987,8 +1994,10 @@ package body Translation is -- Get the offset in the range pointed by RANGE_PTR of INDEX. -- This checks INDEX belongs to the range. + -- INDEX_TYPE is the subtype of the array index. function Translate_Index_To_Offset (Range_Ptr : O_Dnode; Index : O_Enode; + Index_Expr : Iir; Index_Type : Iir; Loc : Iir) return O_Enode; @@ -2249,6 +2258,9 @@ package body Translation is -- Close the temporary region. procedure Close_Temp; + -- Check there is no temporary region. + procedure Check_No_Temp; + -- Free all old temp. -- Used only to free memory. procedure Free_Old_Temp; @@ -3099,6 +3111,9 @@ package body Translation is -- never deallocated. Old_Level : Temp_Level_Acc := null; + -- If set, emit comments for open_temp/close_temp. + Flag_Debug_Temp : constant Boolean := False; + procedure Open_Temp is L : Temp_Level_Acc; @@ -3119,6 +3134,10 @@ package body Translation is L.Level := Temp_Level.Level + 1; end if; Temp_Level := L; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Open_Temp level " & Natural'Image (L.Level)); + end if; end Open_Temp; procedure Add_Transient_Type_In_Temp (Atype : Iir) @@ -3139,6 +3158,11 @@ package body Translation is -- OPEN_TEMP was not called. raise Internal_Error; end if; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Close_Temp level " & Natural'Image (Temp_Level.Level)); + end if; + if Temp_Level.Stack2_Mark /= O_Dnode_Null then Start_Association (Constr, Ghdl_Stack2_Release); New_Association (Constr, @@ -3171,6 +3195,13 @@ package body Translation is Old_Level := L; end Close_Temp; + procedure Check_No_Temp is + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + end Check_No_Temp; + procedure Free_Old_Temp is procedure Free is new Ada.Unchecked_Deallocation @@ -4258,8 +4289,7 @@ package body Translation is Chap7.Translate_Expression (Get_Nth_Element (Get_Index_List (Spec), 0), Iter_Type), - Iter_Type, - Spec), + Scheme, Iter_Type, Spec), True); Close_Temp; end; @@ -4289,8 +4319,7 @@ package body Translation is (Range_Ptr, New_Value (New_Selected_Element (New_Obj (Slice), Type_Info.T.Range_Left)), - Iter_Type, - Spec)); + Spec, Iter_Type, Spec)); Right := Create_Temp_Init (Ghdl_Index_Type, Chap6.Translate_Index_To_Offset @@ -4298,8 +4327,7 @@ package body Translation is New_Value (New_Selected_Element (New_Obj (Slice), Type_Info.T.Range_Right)), - Iter_Type, - Spec)); + Spec, Iter_Type, Spec)); Index := Create_Temp (Ghdl_Index_Type); High := Create_Temp (Ghdl_Index_Type); Start_If_Stmt @@ -4786,6 +4814,8 @@ package body Translation is Chap4.Elab_Declaration_Chain (Subprg, Final); + pragma Debug (Check_No_Temp); + -- If finalization is required, create a dummy loop around the -- body and convert returns into exit out of this loop. -- If the subprogram is a function, also create a variable for the @@ -4838,6 +4868,8 @@ package body Translation is Finish_Subprogram_Body; + pragma Debug (Check_No_Temp); + Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Body; @@ -5318,7 +5350,7 @@ package body Translation is Info.C := new Complex_Type_Info; Info.C.Size_Var (Mode_Value) := Create_Var (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Info.C.Size_Var (Mode_Signal) := Create_Var (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); end if; @@ -5790,7 +5822,7 @@ package body Translation is ------------- function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is begin - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then return Mode_Signal; else return Mode_Value; @@ -6015,7 +6047,7 @@ package body Translation is if not Completion then Create_Array_Fat_Pointer (Info, Mode_Value); end if; - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Array_Fat_Pointer (Info, Mode_Signal); end if; Finish_Type_Definition (Info, Completion); @@ -6083,6 +6115,7 @@ package body Translation is else -- Length is known. Create a constrained array. Info.Type_Mode := Type_Mode_Array; + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop case I is when Mode_Value => @@ -6342,6 +6375,7 @@ package body Translation is El := Get_Chain (El); end loop; + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop Start_Record_Type (El_List); El := Get_Element_Declaration_Chain (Def); @@ -6355,9 +6389,6 @@ package body Translation is end loop; Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); end loop; - if Get_Signal_Type_Flag (Def) = False then - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - end if; Info.Type_Mode := Type_Mode_Record; Finish_Type_Definition (Info); @@ -6717,7 +6748,6 @@ package body Translation is Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); Finish_Subprogram_Body; - end Translate_Protected_Type_Body_Subprograms; --------------- @@ -7355,7 +7385,7 @@ package body Translation is -- Declare subprograms. Id := Get_Identifier (Decl); Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); end if; @@ -7367,12 +7397,12 @@ package body Translation is case Get_Kind (Def) is when Iir_Kind_Array_Type_Definition => Create_Array_Type_Builder (Def, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Array_Type_Builder (Def, Mode_Signal); end if; when Iir_Kind_Record_Type_Definition => Create_Record_Type_Builder (Def, Mode_Value); - if Get_Signal_Type_Flag (Def) then + if Get_Has_Signal_Flag (Def) then Create_Record_Type_Builder (Def, Mode_Signal); end if; when others => @@ -8758,12 +8788,9 @@ package body Translation is -- FIXME: to be improved ? -- Only required for transient types. - -- FIXME: check this (why open/close_temp ?) - Open_Temp; Define_Global_Const (Info.Object_Var, Chap7.Translate_Static_Expression (Val, Def)); - Close_Temp; end if; when others => Error_Kind ("create_objet", El); @@ -10170,40 +10197,6 @@ package body Translation is end case; end Translate_Declaration; - -- Mark FUNC (by adding the subprg_resolv info) iif it can be a - -- resolution function. - procedure Check_Resolution_Function (Func : Iir) - is - Param : Iir; - Param_Type : Iir; - Res_Type : Iir; - Info : Subprg_Info_Acc; - begin - Param := Get_Interface_Declaration_Chain (Func); - - -- Return now if the number of parameters is not 1. - if Param = Null_Iir or else Get_Chain (Param) /= Null_Iir then - return; - end if; - Param_Type := Get_Type (Param); - case Get_Kind (Param_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - null; - when others => - return; - end case; - Res_Type := Get_Return_Type (Func); - if Get_Base_Type (Get_Element_Subtype (Param_Type)) - /= Get_Base_Type (Res_Type) - then - return; - end if; - -- FUNC can be a resolution function. - Info := Get_Info (Func); - Info.Subprg_Resolv := new Subprg_Resolv_Info; - end Check_Resolution_Function; - procedure Translate_Resolution_Function (Func : Iir; Block : Iir) is -- Type of the resolution function parameter. @@ -10592,8 +10585,10 @@ package body Translation is else Info := Add_Info (El, Kind_Subprg); Chap2.Translate_Subprogram_Interfaces (El); - if Get_Kind (El) = Iir_Kind_Function_Declaration then - Check_Resolution_Function (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration + and then Get_Resolution_Function_Flag (El) + then + Info.Subprg_Resolv := new Subprg_Resolv_Info; end if; end if; when Iir_Kind_Function_Body @@ -12044,8 +12039,34 @@ package body Translation is Finish_If_Stmt (If_Blk); end Check_Bound_Error; + -- Return TRUE if an array whose index type is RNG_TYPE indexed by + -- an expression of type EXPR_TYPE needs a bound check. + function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) + return Boolean + is + Rng : Iir; + begin + -- No check if the expression has the type of the index. + if Expr_Type = Rng_Type then + return False; + end if; + + -- No check for 'Range or 'Reverse_Range. + Rng := Get_Range_Constraint (Expr_Type); + if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute + or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) + and then Get_Type (Rng) = Rng_Type + then + return False; + end if; + + return True; + end Need_Index_Check; + + function Translate_Index_To_Offset (Range_Ptr : O_Dnode; Index : O_Enode; + Index_Expr : Iir; Index_Type : Iir; Loc : Iir) return O_Enode @@ -12059,7 +12080,7 @@ package body Translation is Bound_Node : O_Dnode; Index_Info : Type_Info_Acc; begin - Index_Info := Get_Info (Index_Type); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); Res := Create_Temp (Ghdl_Index_Type); @@ -12098,20 +12119,22 @@ package body Translation is Ghdl_Index_Type)); -- Check bounds. - Cond1 := New_Compare_Op - (ON_Lt, - New_Obj_Value (Off), - New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), - 0)), - Ghdl_Bool_Type); - - Cond2 := New_Compare_Op - (ON_Ge, - New_Obj_Value (Res), - New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), - Index_Info.T.Range_Length), - Ghdl_Bool_Type); - Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + if Need_Index_Check (Get_Type (Index_Expr), Index_Type) then + Cond1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Off), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + + Cond2 := New_Compare_Op + (ON_Ge, + New_Obj_Value (Res), + New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), + Index_Info.T.Range_Length), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + end if; Close_Temp; @@ -12250,8 +12273,7 @@ package body Translation is R := Translate_Index_To_Offset (M2Dp (Range_Ptr), Chap7.Translate_Expression (Index, Ibasetype), - Ibasetype, - Index); + Index, Itype, Index); when Type_Mode_Array => -- BASE is a thin array. R := Translate_Thin_Index_Offset (Itype, Dim, Index); @@ -12340,11 +12362,11 @@ package body Translation is Index_Type := Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), 0); + Kind := Get_Object_Kind (Prefix); + -- Evaluate slice bounds. Chap3.Create_Array_Subtype (Slice_Type, True); - Kind := Get_Object_Kind (Prefix); - Prefix_Info := Get_Info (Prefix_Type); Slice_Info := Get_Info (Slice_Type); @@ -12545,7 +12567,6 @@ package body Translation is end case; --Finish_If_Stmt (If_Blk); - end Translate_Slice_Name; function Translate_Interface_Name @@ -13403,7 +13424,8 @@ package body Translation is Formal_Base := Get_Base_Name (Formal); case Get_Kind (Formal_Base) is - when Iir_Kind_Constant_Interface_Declaration => + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => return Translate_Expression (Actual, Get_Type (Formal_Base)); when Iir_Kind_Signal_Interface_Declaration => return Translate_Implicit_Conv @@ -15757,34 +15779,93 @@ package body Translation is end case; end Translate_Expression; --- procedure Translate_Range_Expression --- (Res : O_Lnode; Expr : Iir; Range_Type : Iir) --- is --- T_Info : Type_Info_Acc; --- begin --- T_Info := Get_Info (Range_Type); --- Open_Temp; --- New_Assign_Stmt --- (New_Selected_Element (Res, T_Info.T.Range_Left), --- Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); --- New_Assign_Stmt --- (New_Selected_Element (Res, T_Info.T.Range_Right), --- Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); --- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Dir), --- Chap7.Translate_Static_Range_Dir (Expr)); --- if T_Info.T.Range_Length /= O_Fnode_Null then --- Open_Temp; --- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Length), --- Chap7.Translate_Range_Expression_Length (Expr)); --- Close_Temp; --- end if; --- Close_Temp; --- end Translate_Range_Expression; + -- Check if RNG is of the form: + -- 1 to T'length + -- or T'Length downto 1 + -- or 0 to T'length - 1 + -- or T'Length - 1 downto 0 + -- In either of these cases, return T'Length + function Is_Length_Range_Expression (Rng : Iir_Range_Expression) + return Iir + is + -- Pattern of a bound. + type Length_Pattern is + ( + Pat_Unknown, + Pat_Length, + Pat_Length_1, -- Length - 1 + Pat_1, + Pat_0 + ); + Length_Attr : Iir := Null_Iir; + + -- Classify the bound. + -- Set LENGTH_ATTR is the pattern is Pat_Length. + function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) + return Length_Pattern + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Length_Array_Attribute => + Length_Attr := Expr; + return Pat_Length; + when Iir_Kind_Integer_Literal => + case Get_Value (Expr) is + when 0 => + return Pat_0; + when 1 => + return Pat_1; + when others => + return Pat_Unknown; + end case; + when Iir_Kind_Substraction_Operator => + if not Recurse then + return Pat_Unknown; + end if; + if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length + and then + Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 + then + return Pat_Length_1; + else + return Pat_Unknown; + end if; + when others => + return Pat_Unknown; + end case; + end Get_Length_Pattern; + Left_Pat, Right_Pat : Length_Pattern; + begin + Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); + if Left_Pat = Pat_Unknown then + return Null_Iir; + end if; + Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); + if Right_Pat = Pat_Unknown then + return Null_Iir; + end if; + case Get_Direction (Rng) is + when Iir_To => + if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) + or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) + then + return Length_Attr; + end if; + when Iir_Downto => + if (Left_Pat = Pat_Length and Right_Pat = Pat_1) + or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) + then + return Length_Attr; + end if; + end case; + return Null_Iir; + end Is_Length_Range_Expression; procedure Translate_Range_Expression_Ptr (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) is T_Info : Type_Info_Acc; + Length_Attr : Iir; begin T_Info := Get_Info (Range_Type); Open_Temp; @@ -15804,17 +15885,26 @@ package body Translation is T_Info.T.Range_Length), New_Lit (Translate_Static_Range_Length (Expr))); else - Open_Temp; - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Length), - Compute_Range_Length - (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Left), - New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Right), - Get_Direction (Expr))); - Close_Temp; + Length_Attr := Is_Length_Range_Expression (Expr); + if Length_Attr = Null_Iir then + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Compute_Range_Length + (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Right), + Get_Direction (Expr))); + Close_Temp; + else + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Chap14.Translate_Length_Array_Attribute + (Length_Attr, Null_Iir)); + end if; end if; end if; Close_Temp; @@ -24406,20 +24496,24 @@ package body Translation is New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Bounds)); for I in Mode_Value .. Mode_Signal loop - if I = Mode_Signal and then not Get_Signal_Type_Flag (Atype) then - Val := Get_Null_Loc; - else - case Info.Type_Mode is - when Type_Mode_Array => + case Info.Type_Mode is + when Type_Mode_Array => + if Info.Ortho_Type (I) /= O_Tnode_Null then Val := New_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, New_Sizeof (Info.Ortho_Type (I), Ghdl_Index_Type)); - when Type_Mode_Ptr_Array => + else + Val := Get_Null_Loc; + end if; + when Type_Mode_Ptr_Array => + if Info.C.Size_Var (I) /= null then Val := Var_Acc_To_Loc (Info.C.Size_Var (I)); - when others => - Error_Kind ("generate_array_subtype_definition", Atype); - end case; - end if; + else + Val := Get_Null_Loc; + end if; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; New_Record_Aggr_El (Aggr, Val); end loop; diff --git a/xtools/Makefile b/xtools/Makefile index 0704f99..72df567 100644 --- a/xtools/Makefile +++ b/xtools/Makefile @@ -1,19 +1,19 @@ --- 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. +# 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. all: check_iirs check_iirs: force |