-- Iir to ortho translator.
-- Copyright (C) 2002 - 2014 Tristan Gingold
--
-- GHDL is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 2, or (at your option) any later
-- version.
--
-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Name_Table;
with Std_Names;
with Std_Package; use Std_Package;
with Errorout; use Errorout;
with Sem_Inst;
with Nodes_Meta;
with Iirs_Utils; use Iirs_Utils;
with Trans.Chap3;
with Trans.Chap4;
with Trans.Chap5;
with Trans.Chap6;
with Trans.Chap8;
with Trans.Rtis;
with Trans_Decls; use Trans_Decls;
with Translation; use Translation;
package body Trans.Chap2 is
use Trans.Subprgs;
use Trans.Helpers;
procedure Elab_Package (Spec : Iir_Package_Declaration);
type Name_String_Xlat_Array is array (Name_Id range <>) of
String (1 .. 4);
Operator_String_Xlat : constant
Name_String_Xlat_Array (Std_Names.Name_Id_Operators) :=
(Std_Names.Name_Op_Equality => "OPEq",
Std_Names.Name_Op_Inequality => "OPNe",
Std_Names.Name_Op_Less => "OPLt",
Std_Names.Name_Op_Less_Equal => "OPLe",
Std_Names.Name_Op_Greater => "OPGt",
Std_Names.Name_Op_Greater_Equal => "OPGe",
Std_Names.Name_Op_Plus => "OPPl",
Std_Names.Name_Op_Minus => "OPMi",
Std_Names.Name_Op_Mul => "OPMu",
Std_Names.Name_Op_Div => "OPDi",
Std_Names.Name_Op_Exp => "OPEx",
Std_Names.Name_Op_Concatenation => "OPCc",
Std_Names.Name_Op_Condition => "OPCd",
Std_Names.Name_Op_Match_Equality => "OPQe",
Std_Names.Name_Op_Match_Inequality => "OPQi",
Std_Names.Name_Op_Match_Less => "OPQL",
Std_Names.Name_Op_Match_Less_Equal => "OPQl",
Std_Names.Name_Op_Match_Greater => "OPQG",
Std_Names.Name_Op_Match_Greater_Equal => "OPQg");
-- Set the identifier prefix with the subprogram identifier and
-- overload number if any.
procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type)
is
Id : Name_Id;
begin
-- FIXME: name_shift_operators, name_logical_operators,
-- name_word_operators, name_mod, name_rem
Id := Get_Identifier (Spec);
if Id in Std_Names.Name_Id_Operators then
Push_Identifier_Prefix
(Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec));
else
Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec));
end if;
end Push_Subprg_Identifier;
procedure Translate_Subprogram_Interfaces (Spec : Iir)
is
Inter : Iir;
Mark : Id_Mark_Type;
begin
-- Set the identifier prefix with the subprogram identifier and
-- overload number if any.
Push_Subprg_Identifier (Spec, Mark);
-- Translate interface types.
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
Chap3.Translate_Object_Subtype (Inter);
Inter := Get_Chain (Inter);
end loop;
Pop_Identifier_Prefix (Mark);
end Translate_Subprogram_Interfaces;
procedure Elab_Subprogram_Interfaces (Spec : Iir)
is
Inter : Iir;
begin
-- Translate interface types.
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
Chap3.Elab_Object_Subtype (Get_Type (Inter));
Inter := Get_Chain (Inter);
end loop;
end Elab_Subprogram_Interfaces;
-- Return the type of a subprogram interface.
-- Return O_Tnode_Null if the parameter is passed through the
-- interface record.
function Translate_Interface_Type (Inter : Iir) return O_Tnode
is
Mode : Object_Kind_Type;
Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter));
begin
case Get_Kind (Inter) is
when Iir_Kind_Interface_Constant_Declaration
| Iir_Kind_Interface_Variable_Declaration
| Iir_Kind_Interface_File_Declaration =>
Mode := Mode_Value;
when Iir_Kind_Interface_Signal_Declaration =>
Mode := Mode_Signal;
when others =>
Error_Kind ("translate_interface_type", Inter);
end case;
case Tinfo.Type_Mode is
when Type_Mode_Unknown =>
raise Internal_Error;
when Type_Mode_By_Value =>
return Tinfo.Ortho_Type (Mode);
when Type_Mode_By_Copy
| Type_Mode_By_Ref =>
return Tinfo.Ortho_Ptr_Type (Mode);
end case;
end Translate_Interface_Type;
procedure Translate_Subprogram_Declaration (Spec : Iir)
is
Info : constant Subprg_Info_Acc := Get_Info (Spec);
Is_Func : constant Boolean :=
Get_Kind (Spec) = Iir_Kind_Function_Declaration;
Inter : Iir;
Inter_Type : Iir;
Arg_Info : Ortho_Info_Acc;
Tinfo : Type_Info_Acc;
Interface_List : O_Inter_List;
Has_Result_Record : Boolean;
El_List : O_Element_List;
Mark : Id_Mark_Type;
Rtype : Iir;
Id : O_Ident;
Storage : O_Storage;
Foreign : Foreign_Info_Type := Foreign_Bad;
begin
-- Set the identifier prefix with the subprogram identifier and
-- overload number if any.
Push_Subprg_Identifier (Spec, Mark);
if Get_Foreign_Flag (Spec) then
-- Special handling for foreign subprograms.
Foreign := Translate_Foreign_Id (Spec);
case Foreign.Kind is
when Foreign_Unknown =>
Id := Create_Identifier;
when Foreign_Intrinsic =>
Id := Create_Identifier;
when Foreign_Vhpidirect =>
Id := Get_Identifier
(Name_Table.Nam_Buffer (Foreign.Subprg_First
.. Foreign.Subprg_Last));
end case;
Storage := O_Storage_External;
else
Id := Create_Identifier;
Storage := Global_Storage;
end if;
if Is_Func then
-- If the result of a function is a composite type for ortho,
-- the result is allocated by the caller and an access to it is
-- given to the function.
Rtype := Get_Return_Type (Spec);
Info.Use_Stack2 := False;
Tinfo := Get_Info (Rtype);
if Is_Composite (Tinfo) then
Start_Procedure_Decl (Interface_List, Id, Storage);
New_Interface_Decl
(Interface_List, Info.Res_Interface,
Get_Identifier ("RESULT"),
Tinfo.Ortho_Ptr_Type (Mode_Value));
-- Furthermore, if the result type is unconstrained, the
-- function will allocate it on a secondary stack.
if not Is_Fully_Constrained_Type (Rtype) then
Info.Use_Stack2 := True;
end if;
else
-- Normal function.
Start_Function_Decl
(Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value));
Info.Res_Interface := O_Dnode_Null;
end if;
else
-- Create info for each interface of the procedure.
-- For parameters passed via copy and that needs a copy-out,
-- gather them in a record. An access to the record is then
-- passed to the procedure.
Has_Result_Record := False;
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
Arg_Info := Add_Info (Inter, Kind_Interface);
Inter_Type := Get_Type (Inter);
Tinfo := Get_Info (Inter_Type);
if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
and then Get_Mode (Inter) in Iir_Out_Modes
and then Tinfo.Type_Mode not in Type_Mode_By_Ref
and then Tinfo.Type_Mode /= Type_Mode_File
then
-- This interface is done via the result record.
-- Note: file passed through variables are vhdl87 files,
-- which are initialized at elaboration and thus
-- behave like an IN parameter.
if not Has_Result_Record then
-- Create the record.
Start_Record_Type (El_List);
Has_Result_Record := True;
end if;
-- Add a field to the record.
New_Record_Field (El_List, Arg_Info.Interface_Field,
Create_Identifier_Without_Prefix (Inter),
Tinfo.Ortho_Type (Mode_Value));
else
Arg_Info.Interface_Field := O_Fnode_Null;
end if;
Inter := Get_Chain (Inter);
end loop;
if Has_Result_Record then
-- Declare the record type and an access to the record.
Finish_Record_Type (El_List, Info.Res_Record_Type);
New_Type_Decl (Create_Identifier ("RESTYPE"),
Info.Res_Record_Type);
Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type);
New_Type_Decl (Create_Identifier ("RESPTR"),
Info.Res_Record_Ptr);
else
Info.Res_Interface := O_Dnode_Null;
end if;
Start_Procedure_Decl (Interface_List, Id, Storage);
if Has_Result_Record then
-- Add the record parameter.
New_Interface_Decl (Interface_List, Info.Res_Interface,
Get_Identifier ("RESULT"),
Info.Res_Record_Ptr);
end if;
end if;
-- Instance parameter if any.
if not Get_Foreign_Flag (Spec) then
Subprgs.Create_Subprg_Instance (Interface_List, Spec);
end if;
-- Translate interfaces.
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
if Is_Func then
-- Create the info.
Arg_Info := Add_Info (Inter, Kind_Interface);
Arg_Info.Interface_Field := O_Fnode_Null;
else
-- The info was already created (just above)
Arg_Info := Get_Info (Inter);
end if;
if Arg_Info.Interface_Field = O_Fnode_Null then
-- Not via the RESULT parameter.
Arg_Info.Interface_Type := Translate_Interface_Type (Inter);
New_Interface_Decl
(Interface_List, Arg_Info.Interface_Node,
Create_Identifier_Without_Prefix (Inter),
Arg_Info.Interface_Type);
end if;
Inter := Get_Chain (Inter);
end loop;
Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func);
-- Call the hook for foreign subprograms.
if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then
Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func);
end if;
Save_Local_Identifier (Info.Subprg_Local_Id);
Pop_Identifier_Prefix (Mark);
end Translate_Subprogram_Declaration;
-- Return TRUE iff subprogram specification SPEC is translated in an
-- ortho function.
function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean
is
begin
if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
return False;
end if;
if Get_Info (Spec).Res_Interface /= O_Dnode_Null then
return False;
end if;
return True;
end Is_Subprogram_Ortho_Function;
-- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely
-- (or even implicitely by translation) a subprogram.
function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean
is
Decl : Iir;
Atype : Iir;
begin
Decl := Get_Declaration_Chain (Subprg_Body);
while Decl /= Null_Iir loop
case Get_Kind (Decl) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
return True;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
-- The declaration preceed the body.
raise Internal_Error;
when Iir_Kind_Type_Declaration
| Iir_Kind_Anonymous_Type_Declaration =>
Atype := Get_Type_Definition (Decl);
case Iir_Kinds_Type_And_Subtype_Definition
(Get_Kind (Atype)) is
when Iir_Kinds_Scalar_Type_Definition =>
null;
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Access_Subtype_Definition =>
null;
when Iir_Kind_File_Type_Definition =>
return True;
when Iir_Kind_Protected_Type_Declaration =>
raise Internal_Error;
when Iir_Kinds_Composite_Type_Definition =>
-- At least for "=".
return True;
when Iir_Kind_Incomplete_Type_Definition =>
null;
end case;
when others =>
null;
end case;
Decl := Get_Chain (Decl);
end loop;
return False;
end Has_Nested_Subprograms;
procedure Translate_Subprogram_Body (Subprg : Iir)
is
Spec : constant Iir := Get_Subprogram_Specification (Subprg);
Info : constant Ortho_Info_Acc := Get_Info (Spec);
Old_Subprogram : Iir;
Mark : Id_Mark_Type;
Final : Boolean;
Is_Ortho_Func : Boolean;
-- Set for a public method. In this case, the lock must be acquired
-- and retained.
Is_Prot : Boolean := False;
-- True if the body has local (nested) subprograms.
Has_Nested : Boolean;
Frame_Ptr_Type : O_Tnode;
Upframe_Field : O_Fnode;
Frame : O_Dnode;
Frame_Ptr : O_Dnode;
Has_Return : Boolean;
Prev_Subprg_Instances : Subprgs.Subprg_Instance_Stack;
begin
-- Do not translate body for foreign subprograms.
if Get_Foreign_Flag (Spec) then
return;
end if;
-- Check if there are nested subprograms to unnest. In that case,
-- a frame record is created, which is less efficient than the
-- use of local variables.
if Flag_Unnest_Subprograms then
Has_Nested := Has_Nested_Subprograms (Subprg);
else
Has_Nested := False;
end if;
-- Set the identifier prefix with the subprogram identifier and
-- overload number if any.
Push_Subprg_Identifier (Spec, Mark);
Restore_Local_Identifier (Info.Subprg_Local_Id);
if Has_Nested then
-- Unnest subprograms.
-- Create an instance for the local declarations.
Push_Instance_Factory (Info.Subprg_Frame_Scope'Access);
Add_Subprg_Instance_Field (Upframe_Field);
if Info.Res_Record_Ptr /= O_Tnode_Null then
Info.Res_Record_Var :=
Create_Var (Create_Var_Identifier ("RESULT"),
Info.Res_Record_Ptr);
end if;
-- Create fields for parameters.
-- FIXME: do it only if they are referenced in nested
-- subprograms.
declare
Inter : Iir;
Inter_Info : Inter_Info_Acc;
begin
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
Inter_Info := Get_Info (Inter);
if Inter_Info.Interface_Node /= O_Dnode_Null then
Inter_Info.Interface_Field :=
Add_Instance_Factory_Field
(Create_Identifier_Without_Prefix (Inter),
Inter_Info.Interface_Type);
end if;
Inter := Get_Chain (Inter);
end loop;
end;
Chap4.Translate_Declaration_Chain (Subprg);
Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access);
New_Type_Decl (Create_Identifier ("_FRAMETYPE"),
Get_Scope_Type (Info.Subprg_Frame_Scope));
Declare_Scope_Acc
(Info.Subprg_Frame_Scope,
Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type);
Rtis.Generate_Subprogram_Body (Subprg);
-- Local frame
Subprgs.Push_Subprg_Instance
(Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type,
Wki_Upframe, Prev_Subprg_Instances);
-- Link to previous frame
Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field
(Prev_Subprg_Instances, Upframe_Field);
Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
-- Link to previous frame
Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field
(Prev_Subprg_Instances, Upframe_Field);
-- Local frame
Subprgs.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances);
end if;
-- Create the body
Start_Subprogram_Body (Info.Ortho_Func);
Start_Subprg_Instance_Use (Spec);
-- Variables will be created on the stack.
Push_Local_Factory;
-- Code has access to local (and outer) variables.
-- FIXME: this is not necessary if Has_Nested is set
Subprgs.Clear_Subprg_Instance (Prev_Subprg_Instances);
-- There is a local scope for temporaries.
Open_Local_Temp;
if not Has_Nested then
Chap4.Translate_Declaration_Chain (Subprg);
Rtis.Generate_Subprogram_Body (Subprg);
Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
else
New_Var_Decl (Frame, Wki_Frame, O_Storage_Local,
Get_Scope_Type (Info.Subprg_Frame_Scope));
New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"),
O_Storage_Local, Frame_Ptr_Type);
New_Assign_Stmt (New_Obj (Frame_Ptr),
New_Address (New_Obj (Frame), Frame_Ptr_Type));
-- FIXME: use direct reference (ie Frame instead of Frame_Ptr)
Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr);
-- Set UPFRAME.
Subprgs.Set_Subprg_Instance_Field
(Frame_Ptr, Upframe_Field, Info.Subprg_Instance);
if Info.Res_Record_Type /= O_Tnode_Null then
-- Initialize the RESULT field
New_Assign_Stmt (Get_Var (Info.Res_Record_Var),
New_Obj_Value (Info.Res_Interface));
-- Do not reference the RESULT field in the subprogram body,
-- directly reference the RESULT parameter.
-- FIXME: has a flag (see below for parameters).
Info.Res_Record_Var := Null_Var;
end if;
-- Copy parameters to FRAME.
declare
Inter : Iir;
Inter_Info : Inter_Info_Acc;
begin
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
Inter_Info := Get_Info (Inter);
if Inter_Info.Interface_Node /= O_Dnode_Null then
New_Assign_Stmt
(New_Selected_Element (New_Obj (Frame),
Inter_Info.Interface_Field),
New_Obj_Value (Inter_Info.Interface_Node));
-- Forget the reference to the field in FRAME, so that
-- this subprogram will directly reference the parameter
-- (and not its copy in the FRAME).
Inter_Info.Interface_Field := O_Fnode_Null;
end if;
Inter := Get_Chain (Inter);
end loop;
end;
end if;
-- Init out parameters passed by value/copy.
declare
Inter : Iir;
Inter_Type : Iir;
Type_Info : Type_Info_Acc;
begin
Inter := Get_Interface_Declaration_Chain (Spec);
while Inter /= Null_Iir loop
if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
and then Get_Mode (Inter) = Iir_Out_Mode
then
Inter_Type := Get_Type (Inter);
Type_Info := Get_Info (Inter_Type);
if (Type_Info.Type_Mode in Type_Mode_By_Value
or Type_Info.Type_Mode in Type_Mode_By_Copy)
and then Type_Info.Type_Mode /= Type_Mode_File
then
Chap4.Init_Object
(Chap6.Translate_Name (Inter), Inter_Type);
end if;
end if;
Inter := Get_Chain (Inter);
end loop;
end;
Chap4.Elab_Declaration_Chain (Subprg, Final);
-- 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
-- result.
Is_Prot := Is_Subprogram_Method (Spec);
if Final or Is_Prot then
if Is_Prot then
-- Lock the object.
Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
Ghdl_Protected_Enter);
end if;
Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec);
if Is_Ortho_Func then
New_Var_Decl
(Info.Subprg_Result, Get_Identifier ("RESULT"),
O_Storage_Local,
Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value));
end if;
Start_Loop_Stmt (Info.Subprg_Exit);
end if;
Old_Subprogram := Current_Subprogram;
Current_Subprogram := Spec;
Has_Return := Chap8.Translate_Statements_Chain_Has_Return
(Get_Sequential_Statement_Chain (Subprg));
Current_Subprogram := Old_Subprogram;
if Final or Is_Prot then
-- Create a barrier to catch missing return statement.
if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
New_Exit_Stmt (Info.Subprg_Exit);
else
if not Has_Return then
-- Missing return
Chap6.Gen_Program_Error
(Subprg, Chap6.Prg_Err_Missing_Return);
end if;
end if;
Finish_Loop_Stmt (Info.Subprg_Exit);
Chap4.Final_Declaration_Chain (Subprg, False);
if Is_Prot then
-- Unlock the object.
Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
Ghdl_Protected_Leave);
end if;
if Is_Ortho_Func then
New_Return_Stmt (New_Obj_Value (Info.Subprg_Result));
end if;
else
if Get_Kind (Spec) = Iir_Kind_Function_Declaration
and then not Has_Return
then
-- Missing return
Chap6.Gen_Program_Error
(Subprg, Chap6.Prg_Err_Missing_Return);
end if;
end if;
if Has_Nested then
Clear_Scope (Info.Subprg_Frame_Scope);
end if;
Subprgs.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances);
Close_Local_Temp;
Pop_Local_Factory;
Finish_Subprg_Instance_Use (Spec);
Finish_Subprogram_Body;
Pop_Identifier_Prefix (Mark);
end Translate_Subprogram_Body;
procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration)
is
Header : constant Iir := Get_Package_Header (Decl);
Info : Ortho_Info_Acc;
Interface_List : O_Inter_List;
Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack;
begin
Info := Add_Info (Decl, Kind_Package);
-- Translate declarations.
if Is_Uninstantiated_Package (Decl) then
-- Create an instance for the spec.
Push_Instance_Factory (Info.Package_Spec_Scope'Access);
Chap4.Translate_Generic_Chain (Header);
Chap4.Translate_Declaration_Chain (Decl);
Info.Package_Elab_Var := Create_Var
(Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
Pop_Instance_Factory (Info.Package_Spec_Scope'Access);
-- Name the spec instance and create a pointer.
New_Type_Decl (Create_Identifier ("SPECINSTTYPE"),
Get_Scope_Type (Info.Package_Spec_Scope));
Declare_Scope_Acc (Info.Package_Spec_Scope,
Create_Identifier ("SPECINSTPTR"),
Info.Package_Spec_Ptr_Type);
-- Create an instance and its pointer for the body.
Chap2.Declare_Inst_Type_And_Ptr
(Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type);
-- Each subprogram has a body instance argument.
Subprgs.Push_Subprg_Instance
(Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
Wki_Instance, Prev_Subprg_Instance);
else
Chap4.Translate_Declaration_Chain (Decl);
Info.Package_Elab_Var := Create_Var
(Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
end if;
-- Translate subprograms declarations.
Chap4.Translate_Declaration_Chain_Subprograms (Decl);
-- Declare elaborator for the body.
Start_Procedure_Decl
(Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage);
Subprgs.Add_Subprg_Instance_Interfaces
(Interface_List, Info.Package_Elab_Body_Instance);
Finish_Subprogram_Decl
(Interface_List, Info.Package_Elab_Body_Subprg);
if Is_Uninstantiated_Package (Decl) then
Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
-- The spec elaborator has a spec instance argument.
Subprgs.Push_Subprg_Instance
(Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type,
Wki_Instance, Prev_Subprg_Instance);
end if;
Start_Procedure_Decl
(Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage);
Subprgs.Add_Subprg_Instance_Interfaces
(Interface_List, Info.Package_Elab_Spec_Instance);
Finish_Subprogram_Decl
(Interface_List, Info.Package_Elab_Spec_Subprg);
if Flag_Rti then
-- Generate RTI.
Rtis.Generate_Unit (Decl);
end if;
if Global_Storage = O_Storage_Public then
-- Create elaboration procedure for the spec
Elab_Package (Decl);
end if;
if Is_Uninstantiated_Package (Decl) then
Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
end if;
Save_Local_Identifier (Info.Package_Local_Id);
end Translate_Package_Declaration;
procedure Translate_Package_Body (Decl : Iir_Package_Body)
is
Spec : constant Iir_Package_Declaration := Get_Package (Decl);
Info : constant Ortho_Info_Acc := Get_Info (Spec);
Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack;
begin
-- Translate declarations.
if Is_Uninstantiated_Package (Spec) then
Push_Instance_Factory (Info.Package_Body_Scope'Access);
Info.Package_Spec_Field := Add_Instance_Factory_Field
(Get_Identifier ("SPEC"),
Get_Scope_Type (Info.Package_Spec_Scope));
Chap4.Translate_Declaration_Chain (Decl);
Pop_Instance_Factory (Info.Package_Body_Scope'Access);
if Global_Storage = O_Storage_External then
return;
end if;
else
-- May be called during elaboration to generate RTI.
if Global_Storage = O_Storage_External then
return;
end if;
Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id);
Chap4.Translate_Declaration_Chain (Decl);
end if;
if Flag_Rti then
Rtis.Generate_Unit (Decl);
end if;
if Is_Uninstantiated_Package (Spec) then
Subprgs.Push_Subprg_Instance
(Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
Wki_Instance, Prev_Subprg_Instance);
Set_Scope_Via_Field (Info.Package_Spec_Scope,
Info.Package_Spec_Field,
Info.Package_Body_Scope'Access);
end if;
Chap4.Translate_Declaration_Chain_Subprograms (Decl);
if Is_Uninstantiated_Package (Spec) then
Clear_Scope (Info.Package_Spec_Scope);
Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
end if;
Elab_Package_Body (Spec, Decl);
end Translate_Package_Body;
procedure Elab_Package (Spec : Iir_Package_Declaration)
is
Info : constant Ortho_Info_Acc := Get_Info (Spec);
Final : Boolean;
Constr : O_Assoc_List;
pragma Unreferenced (Final);
begin
Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg);
Push_Local_Factory;
Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
Elab_Dependence (Get_Design_Unit (Spec));
if not Is_Uninstantiated_Package (Spec)
and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit
then
-- Register the top level package. This is done dynamically, as
-- we know only during elaboration that the design depends on a
-- package (a package maybe referenced by an entity which is never
-- instantiated due to generate statements).
Start_Association (Constr, Ghdl_Rti_Add_Package);
New_Association
(Constr,
New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const)));
New_Procedure_Call (Constr);
end if;
Open_Temp;
Chap4.Elab_Declaration_Chain (Spec, Final);
Close_Temp;
Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
Pop_Local_Factory;
Finish_Subprogram_Body;
end Elab_Package;
procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir)
is
Info : constant Ortho_Info_Acc := Get_Info (Spec);
If_Blk : O_If_Block;
Constr : O_Assoc_List;
Final : Boolean;
begin
Start_Subprogram_Body (Info.Package_Elab_Body_Subprg);
Push_Local_Factory;
Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
if Is_Uninstantiated_Package (Spec) then
Set_Scope_Via_Field (Info.Package_Spec_Scope,
Info.Package_Spec_Field,
Info.Package_Body_Scope'Access);
end if;
-- If the package was already elaborated, return now,
-- else mark the package as elaborated.
Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var)));
New_Return_Stmt;
New_Else_Stmt (If_Blk);
New_Assign_Stmt (Get_Var (Info.Package_Elab_Var),
New_Lit (Ghdl_Bool_True_Node));
Finish_If_Stmt (If_Blk);
-- Elab Spec.
Start_Association (Constr, Info.Package_Elab_Spec_Subprg);
Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance);
New_Procedure_Call (Constr);
if Bod /= Null_Iir then
Elab_Dependence (Get_Design_Unit (Bod));
Open_Temp;
Chap4.Elab_Declaration_Chain (Bod, Final);
Close_Temp;
end if;
if Is_Uninstantiated_Package (Spec) then
Clear_Scope (Info.Package_Spec_Scope);
end if;
Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
Pop_Local_Factory;
Finish_Subprogram_Body;
end Elab_Package_Body;
procedure Instantiate_Iir_Info (N : Iir);
procedure Instantiate_Iir_Chain_Info (Chain : Iir)
is
N : Iir;
begin
N := Chain;
while N /= Null_Iir loop
Instantiate_Iir_Info (N);
N := Get_Chain (N);
end loop;
end Instantiate_Iir_Chain_Info;
procedure Instantiate_Iir_List_Info (L : Iir_List)
is
El : Iir;
begin
case L is
when Null_Iir_List
| Iir_List_All
| Iir_List_Others =>
return;
when others =>
for I in Natural loop
El := Get_Nth_Element (L, I);
exit when El = Null_Iir;
Instantiate_Iir_Info (El);
end loop;
end case;
end Instantiate_Iir_List_Info;
procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is
begin
case Src.Kind is
when Kind_Type =>
Dest.all := (Kind => Kind_Type,
Type_Mode => Src.Type_Mode,
Type_Incomplete => Src.Type_Incomplete,
Type_Locally_Constrained =>
Src.Type_Locally_Constrained,
C => null,
Ortho_Type => Src.Ortho_Type,
Ortho_Ptr_Type => Src.Ortho_Ptr_Type,
Type_Transient_Chain => Null_Iir,
T => Src.T,
Type_Rti => Src.Type_Rti);
pragma Assert (Src.C = null);
pragma Assert (Src.Type_Transient_Chain = Null_Iir);
when Kind_Object =>
pragma Assert (Src.Object_Driver = Null_Var);
pragma Assert (Src.Object_Function = O_Dnode_Null);
Dest.all :=
(Kind => Kind_Object,
Object_Static => Src.Object_Static,
Object_Var => Instantiate_Var (Src.Object_Var),
Object_Driver => Null_Var,
Object_Rti => Src.Object_Rti,
Object_Function => O_Dnode_Null);
when Kind_Subprg =>
Dest.Subprg_Frame_Scope :=
Instantiate_Var_Scope (Src.Subprg_Frame_Scope);
Dest.all :=
(Kind => Kind_Subprg,
Use_Stack2 => Src.Use_Stack2,
Ortho_Func => Src.Ortho_Func,
Res_Interface => Src.Res_Interface,
Res_Record_Var => Instantiate_Var (Src.Res_Record_Var),
Res_Record_Type => Src.Res_Record_Type,
Res_Record_Ptr => Src.Res_Record_Ptr,
Subprg_Frame_Scope => Dest.Subprg_Frame_Scope,
Subprg_Instance => Instantiate_Subprg_Instance
(Src.Subprg_Instance),
Subprg_Resolv => null,
Subprg_Local_Id => Src.Subprg_Local_Id,
Subprg_Exit => Src.Subprg_Exit,
Subprg_Result => Src.Subprg_Result);
when Kind_Interface =>
Dest.all := (Kind => Kind_Interface,
Interface_Node => Src.Interface_Node,
Interface_Field => Src.Interface_Field,
Interface_Type => Src.Interface_Type);
when Kind_Index =>
Dest.all := (Kind => Kind_Index,
Index_Field => Src.Index_Field);
when Kind_Expr =>
Dest.all := (Kind => Kind_Expr,
Expr_Node => Src.Expr_Node);
when others =>
raise Internal_Error;
end case;
end Copy_Info;
procedure Instantiate_Iir_Info (N : Iir) is
begin
-- Nothing to do for null node.
if N = Null_Iir then
return;
end if;
declare
use Nodes_Meta;
Kind : constant Iir_Kind := Get_Kind (N);
Fields : constant Fields_Array := Get_Fields (Kind);
F : Fields_Enum;
Orig : constant Iir := Sem_Inst.Get_Origin (N);
pragma Assert (Orig /= Null_Iir);
Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig);
Info : Ortho_Info_Acc;
begin
if Orig_Info /= null then
Info := Add_Info (N, Orig_Info.Kind);
Copy_Info (Info, Orig_Info);
case Info.Kind is
when Kind_Subprg =>
Push_Instantiate_Var_Scope
(Info.Subprg_Frame_Scope'Access,
Orig_Info.Subprg_Frame_Scope'Access);
when others =>
null;
end case;
end if;
for I in Fields'Range loop
F := Fields (I);
case Get_Field_Type (F) is
when Type_Iir =>
case Get_Field_Attribute (F) is
when Attr_None =>
Instantiate_Iir_Info (Get_Iir (N, F));
when Attr_Ref =>
null;
when Attr_Maybe_Ref =>
if not Get_Is_Ref (N) then
Instantiate_Iir_Info (Get_Iir (N, F));
end if;
when Attr_Chain =>
Instantiate_Iir_Chain_Info (Get_Iir (N, F));
when Attr_Chain_Next =>
null;
when Attr_Of_Ref =>
raise Internal_Error;
end case;
when Type_Iir_List =>
case Get_Field_Attribute (F) is
when Attr_None =>
Instantiate_Iir_List_Info (Get_Iir_List (N, F));
when Attr_Ref
| Attr_Of_Ref =>
null;
when others =>
raise Internal_Error;
end case;
when Type_PSL_NFA
| Type_PSL_Node =>
-- TODO
raise Internal_Error;
when Type_Date_Type
| Type_Date_State_Type
| Type_Time_Stamp_Id =>
-- Can this happen ?
raise Internal_Error;
when Type_String8_Id
| Type_Source_Ptr
| Type_Base_Type
| Type_Iir_Constraint
| Type_Iir_Mode
| Type_Iir_Index32
| Type_Iir_Int64
| Type_Boolean
| Type_Iir_Staticness
| Type_Iir_All_Sensitized
| Type_Iir_Signal_Kind
| Type_Tri_State_Type
| Type_Iir_Pure_State
| Type_Iir_Delay_Mechanism
| Type_Iir_Predefined_Functions
| Type_Iir_Direction
| Type_Location_Type
| Type_Iir_Int32
| Type_Int32
| Type_Iir_Fp64
| Type_Token_Type
| Type_Name_Id =>
null;
end case;
end loop;
if Info /= null then
case Info.Kind is
when Kind_Subprg =>
Pop_Instantiate_Var_Scope
(Info.Subprg_Frame_Scope'Access);
when others =>
null;
end case;
end if;
end;
end Instantiate_Iir_Info;
procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir)
is
Inter : Iir;
Orig : Iir;
Orig_Info : Ortho_Info_Acc;
Info : Ortho_Info_Acc;
begin
Inter := Chain;
while Inter /= Null_Iir loop
case Get_Kind (Inter) is
when Iir_Kind_Interface_Constant_Declaration =>
Orig := Sem_Inst.Get_Origin (Inter);
Orig_Info := Get_Info (Orig);
Info := Add_Info (Inter, Orig_Info.Kind);
Copy_Info (Info, Orig_Info);
when Iir_Kind_Interface_Package_Declaration =>
null;
when others =>
raise Internal_Error;
end case;
Inter := Get_Chain (Inter);
end loop;
end Instantiate_Iir_Generic_Chain_Info;
-- Add info for an interface_package_declaration or a
-- package_instantiation_declaration
procedure Instantiate_Info_Package (Inst : Iir)
is
Spec : constant Iir :=
Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec);
Info : Ortho_Info_Acc;
begin
Info := Add_Info (Inst, Kind_Package_Instance);
-- Create the info instances.
Push_Instantiate_Var_Scope
(Info.Package_Instance_Spec_Scope'Access,
Pkg_Info.Package_Spec_Scope'Access);
Push_Instantiate_Var_Scope
(Info.Package_Instance_Body_Scope'Access,
Pkg_Info.Package_Body_Scope'Access);
Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst));
Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst));
Pop_Instantiate_Var_Scope
(Info.Package_Instance_Body_Scope'Access);
Pop_Instantiate_Var_Scope
(Info.Package_Instance_Spec_Scope'Access);
end Instantiate_Info_Package;
procedure Translate_Package_Instantiation_Declaration (Inst : Iir)
is
Spec : constant Iir :=
Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec);
Info : Ortho_Info_Acc;
Interface_List : O_Inter_List;
Constr : O_Assoc_List;
begin
Instantiate_Info_Package (Inst);
Info := Get_Info (Inst);
-- FIXME: if the instantiation occurs within a package declaration,
-- the variable must be declared extern (and public in the body).
Info.Package_Instance_Body_Var := Create_Var
(Create_Var_Identifier (Inst),
Get_Scope_Type (Pkg_Info.Package_Body_Scope));
-- FIXME: this is correct only for global instantiation, and only if
-- there is only one.
Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope,
Get_Var_Label (Info.Package_Instance_Body_Var));
Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope,
Pkg_Info.Package_Spec_Field,
Info.Package_Instance_Body_Scope'Access);
-- Declare elaboration procedure
Start_Procedure_Decl
(Interface_List, Create_Identifier ("ELAB"), Global_Storage);
-- Chap2.Add_Subprg_Instance_Interfaces
-- (Interface_List, Info.Package_Instance_Elab_Instance);
Finish_Subprogram_Decl
(Interface_List, Info.Package_Instance_Elab_Subprg);
if Global_Storage /= O_Storage_Public then
return;
end if;
-- Elaborator:
Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg);
-- Chap2.Start_Subprg_Instance_Use
-- (Info.Package_Instance_Elab_Instance);
Elab_Dependence (Get_Design_Unit (Inst));
Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
Get_Var_Label (Info.Package_Instance_Body_Var));
Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope,
Pkg_Info.Package_Spec_Field,
Pkg_Info.Package_Body_Scope'Access);
Chap5.Elab_Generic_Map_Aspect (Inst);
Clear_Scope (Pkg_Info.Package_Spec_Scope);
Clear_Scope (Pkg_Info.Package_Body_Scope);
-- Call the elaborator of the generic. The generic must be
-- temporary associated with the instance variable.
Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg);
Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
Get_Var_Label (Info.Package_Instance_Body_Var));
Add_Subprg_Instance_Assoc
(Constr, Pkg_Info.Package_Elab_Body_Instance);
Clear_Scope (Pkg_Info.Package_Body_Scope);
New_Procedure_Call (Constr);
-- Chap2.Finish_Subprg_Instance_Use
-- (Info.Package_Instance_Elab_Instance);
Finish_Subprogram_Body;
end Translate_Package_Instantiation_Declaration;
procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration)
is
Info : Ortho_Info_Acc;
If_Blk : O_If_Block;
Constr : O_Assoc_List;
begin
-- Std.Standard is pre-elaborated.
if Pkg = Standard_Package then
return;
end if;
-- Nothing to do for uninstantiated package.
if Is_Uninstantiated_Package (Pkg) then
return;
end if;
-- Call the package elaborator only if not already elaborated.
Info := Get_Info (Pkg);
Start_If_Stmt
(If_Blk,
New_Monadic_Op (ON_Not,
New_Value (Get_Var (Info.Package_Elab_Var))));
-- Elaborates only non-elaborated packages.
Start_Association (Constr, Info.Package_Elab_Body_Subprg);
New_Procedure_Call (Constr);
Finish_If_Stmt (If_Blk);
end Elab_Dependence_Package;
procedure Elab_Dependence_Package_Instantiation (Pkg : Iir)
is
Info : constant Ortho_Info_Acc := Get_Info (Pkg);
Constr : O_Assoc_List;
begin
Start_Association (Constr, Info.Package_Instance_Elab_Subprg);
New_Procedure_Call (Constr);
end Elab_Dependence_Package_Instantiation;
procedure Elab_Dependence (Design_Unit: Iir_Design_Unit)
is
Depend_List : Iir_Design_Unit_List;
Design : Iir;
Library_Unit: Iir;
begin
Depend_List := Get_Dependence_List (Design_Unit);
for I in Natural loop
Design := Get_Nth_Element (Depend_List, I);
exit when Design = Null_Iir;
if Get_Kind (Design) = Iir_Kind_Design_Unit then
Library_Unit := Get_Library_Unit (Design);
case Get_Kind (Library_Unit) is
when Iir_Kind_Package_Declaration =>
Elab_Dependence_Package (Library_Unit);
when Iir_Kind_Package_Instantiation_Declaration =>
Elab_Dependence_Package_Instantiation (Library_Unit);
when Iir_Kind_Entity_Declaration =>
-- FIXME: architecture already elaborates its entity.
null;
when Iir_Kind_Configuration_Declaration =>
null;
when Iir_Kind_Architecture_Body =>
null;
when Iir_Kind_Package_Body =>
-- A package instantiation depends on the body.
null;
when others =>
Error_Kind ("elab_dependence", Library_Unit);
end case;
end if;
end loop;
end Elab_Dependence;
procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc;
Ptr_Type : out O_Tnode) is
begin
Predeclare_Scope_Type (Scope.all, Create_Identifier ("INSTTYPE"));
Declare_Scope_Acc
(Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type);
end Declare_Inst_Type_And_Ptr;
end Trans.Chap2;