diff options
author | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:14:19 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:14:19 +0100 |
commit | 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 (patch) | |
tree | 575346e529b99e26382b4a06f6ff2caa0b391ab2 /src/ortho/mcode/ortho_code-consts.adb | |
parent | 184a123f91e07c927292d67462561dc84f3a920d (diff) | |
download | ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.gz ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.bz2 ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.zip |
Move sources to src/ subdirectory.
Diffstat (limited to 'src/ortho/mcode/ortho_code-consts.adb')
-rw-r--r-- | src/ortho/mcode/ortho_code-consts.adb | 559 |
1 files changed, 559 insertions, 0 deletions
diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb new file mode 100644 index 000000000..d09a13c34 --- /dev/null +++ b/src/ortho/mcode/ortho_code-consts.adb @@ -0,0 +1,559 @@ +-- Mcode back-end for ortho - Constants handling. +-- Copyright (C) 2006 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with GNAT.Table; +with Ada.Text_IO; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Debug; + +package body Ortho_Code.Consts is + type Cnode_Common is record + Kind : OC_Kind; + Lit_Type : O_Tnode; + end record; + for Cnode_Common use record + Kind at 0 range 0 .. 31; + Lit_Type at 4 range 0 .. 31; + end record; + for Cnode_Common'Size use 64; + + type Cnode_Signed is record + Val : Integer_64; + end record; + for Cnode_Signed'Size use 64; + + type Cnode_Unsigned is record + Val : Unsigned_64; + end record; + for Cnode_Unsigned'Size use 64; + + type Cnode_Float is record + Val : IEEE_Float_64; + end record; + for Cnode_Float'Size use 64; + + type Cnode_Enum is record + Id : O_Ident; + Val : Uns32; + end record; + for Cnode_Enum'Size use 64; + + type Cnode_Addr is record + Decl : O_Dnode; + Pad : Int32; + end record; + for Cnode_Addr'Size use 64; + + type Cnode_Aggr is record + Els : Int32; + Nbr : Int32; + end record; + for Cnode_Aggr'Size use 64; + + type Cnode_Sizeof is record + Atype : O_Tnode; + Pad : Int32; + end record; + for Cnode_Sizeof'Size use 64; + + type Cnode_Union is record + El : O_Cnode; + Field : O_Fnode; + end record; + for Cnode_Union'Size use 64; + + package Cnodes is new GNAT.Table + (Table_Component_Type => Cnode_Common, + Table_Index_Type => O_Cnode, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is + begin + return Cnodes.Table (Cst).Kind; + end Get_Const_Kind; + + function Get_Const_Type (Cst : O_Cnode) return O_Tnode is + begin + return Cnodes.Table (Cst).Lit_Type; + end Get_Const_Type; + + function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64 + is + function To_Cnode_Unsigned is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Unsigned); + begin + return To_Cnode_Unsigned (Cnodes.Table (Cst + 1)).Val; + end Get_Const_U64; + + function Get_Const_I64 (Cst : O_Cnode) return Integer_64 + is + function To_Cnode_Signed is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Signed); + begin + return To_Cnode_Signed (Cnodes.Table (Cst + 1)).Val; + end Get_Const_I64; + + function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64 + is + function To_Cnode_Float is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Float); + begin + return To_Cnode_Float (Cnodes.Table (Cst + 1)).Val; + end Get_Const_F64; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Signed, Target => Cnode_Common); + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Signed, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Signed'(Val => Value))); + return Res; + end New_Signed_Literal; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Unsigned_64, Target => Cnode_Common); + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Unsigned, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Value)); + return Res; + end New_Unsigned_Literal; + +-- function Get_Const_Literal (Cst : O_Cnode) return Uns32 is +-- begin +-- return Cnodes.Table (Cst).Val; +-- end Get_Const_Literal; + + function To_Uns64 is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Uns64); + + function Get_Const_U32 (Cst : O_Cnode) return Uns32 is + begin + return Uns32 (To_Uns64 (Cnodes.Table (Cst + 1))); + end Get_Const_U32; + + function Get_Const_R64 (Cst : O_Cnode) return Uns64 is + begin + return To_Uns64 (Cnodes.Table (Cst + 1)); + end Get_Const_R64; + + function Get_Const_Low (Cst : O_Cnode) return Uns32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return Uns32 (V and 16#Ffff_Ffff#); + end Get_Const_Low; + + function Get_Const_High (Cst : O_Cnode) return Uns32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#); + end Get_Const_High; + + function Get_Const_Low (Cst : O_Cnode) return Int32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return To_Int32 (Uns32 (V and 16#Ffff_Ffff#)); + end Get_Const_Low; + + function Get_Const_High (Cst : O_Cnode) return Int32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return To_Int32 (Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#)); + end Get_Const_High; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode + is + Res : O_Cnode; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Float, Target => Cnode_Common); + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Float, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Float'(Val => Value))); + return Res; + end New_Float_Literal; + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode is + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Null, + Lit_Type => Ltype)); + return Cnodes.Last; + end New_Null_Access; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Addr, Target => Cnode_Common); + + function To_Cnode_Addr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Addr); + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, + Pad => 0))); + return Res; + end New_Global_Unchecked_Address; + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, + Pad => 0))); + return Res; + end New_Global_Address; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Subprg_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Subprg, + Pad => 0))); + return Res; + end New_Subprogram_Address; + + function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is + begin + return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl; + end Get_Const_Decl; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Enum, Target => Cnode_Common); + + function To_Cnode_Enum is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Enum); + + --function Get_Named_Literal_Id (Lit : O_Cnode) return O_Ident is + --begin + -- return To_Cnode_Enum (Cnodes.Table (Lit + 1)).Id; + --end Get_Named_Literal_Id; + + function New_Named_Literal + (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Lit, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Enum'(Id => Id, + Val => Val))); + if Prev /= O_Cnode_Null then + if Prev + 2 /= Res then + raise Syntax_Error; + end if; + end if; + return Res; + end New_Named_Literal; + + function Get_Lit_Ident (L : O_Cnode) return O_Ident is + begin + return To_Cnode_Enum (Cnodes.Table (L + 1)).Id; + end Get_Lit_Ident; + + function Get_Lit_Value (L : O_Cnode) return Uns32 is + begin + return To_Cnode_Enum (Cnodes.Table (L + 1)).Val; + end Get_Lit_Value; + + function Get_Lit_Chain (L : O_Cnode) return O_Cnode is + begin + return L + 2; + end Get_Lit_Chain; + + package Els is new GNAT.Table + (Table_Component_Type => O_Cnode, + Table_Index_Type => Int32, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Aggr, Target => Cnode_Common); + + function To_Cnode_Aggr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Aggr); + + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode) + is + Val : Int32; + Num : Uns32; + begin + Num := Get_Type_Record_Nbr_Fields (Atype); + Val := Els.Allocate (Integer (Num)); + + Cnodes.Append (Cnode_Common'(Kind => OC_Record, + Lit_Type => Atype)); + List := (Res => Cnodes.Last, + Rec_Field => Get_Type_Record_Fields (Atype), + El => Val); + Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, + Nbr => Int32 (Num)))); + end Start_Record_Aggr; + + + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) + is + begin + Els.Table (List.El) := Value; + List.El := List.El + 1; + end New_Record_Aggr_El; + + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode) is + begin + Res := List.Res; + end Finish_Record_Aggr; + + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + is + Val : Int32; + Num : Uns32; + begin + Num := Get_Type_Subarray_Length (Atype); + Val := Els.Allocate (Integer (Num)); + + Cnodes.Append (Cnode_Common'(Kind => OC_Array, + Lit_Type => Atype)); + List := (Res => Cnodes.Last, + El => Val); + Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, + Nbr => Int32 (Num)))); + end Start_Array_Aggr; + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + is + begin + Els.Table (List.El) := Value; + List.El := List.El + 1; + end New_Array_Aggr_El; + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) + is + begin + Res := List.Res; + end Finish_Array_Aggr; + + function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32 is + begin + return To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Nbr; + end Get_Const_Aggr_Length; + + function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode + is + El : Int32; + begin + El := To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Els; + return Els.Table (El + N); + end Get_Const_Aggr_Element; + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + is + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Union, Target => Cnode_Common); + + Res : O_Cnode; + begin + if Debug.Flag_Debug_Hli then + Cnodes.Append (Cnode_Common'(Kind => OC_Union, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Union'(El => Value, + Field => Field))); + return Res; + else + return Value; + end if; + end New_Union_Aggr; + + function To_Cnode_Union is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Union); + + function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode is + begin + return To_Cnode_Union (Cnodes.Table (Cst + 1)).Field; + end Get_Const_Union_Field; + + function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode is + begin + return To_Cnode_Union (Cnodes.Table (Cst + 1)).El; + end Get_Const_Union_Value; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode + is + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Sizeof, Target => Cnode_Common); + + Res : O_Cnode; + begin + if Debug.Flag_Debug_Hli then + Cnodes.Append (Cnode_Common'(Kind => OC_Sizeof, + Lit_Type => Rtype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype, + Pad => 0))); + return Res; + else + return New_Unsigned_Literal + (Rtype, Unsigned_64 (Get_Type_Size (Atype))); + end if; + end New_Sizeof; + + function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode + is + function To_Cnode_Sizeof is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Sizeof); + begin + return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype; + end Get_Sizeof_Type; + + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode + is + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Sizeof, Target => Cnode_Common); + + Res : O_Cnode; + begin + if Debug.Flag_Debug_Hli then + Cnodes.Append (Cnode_Common'(Kind => OC_Alignof, + Lit_Type => Rtype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype, + Pad => 0))); + return Res; + else + return New_Unsigned_Literal + (Rtype, Unsigned_64 (Get_Type_Align_Bytes (Atype))); + end if; + end New_Alignof; + + function Get_Alignof_Type (Cst : O_Cnode) return O_Tnode + is + function To_Cnode_Sizeof is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Sizeof); + begin + return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype; + end Get_Alignof_Type; + + function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode is + begin + if Get_Field_Parent (Field) /= Rec_Type then + raise Syntax_Error; + end if; + return New_Unsigned_Literal + (Rtype, Unsigned_64 (Get_Field_Offset (Field))); + end New_Offsetof; + + procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is + begin + case Get_Const_Kind (Cst) is + when OC_Signed + | OC_Unsigned + | OC_Float => + H := Get_Const_High (Cst); + L := Get_Const_Low (Cst); + when OC_Null => + H := 0; + L := 0; + when OC_Lit => + H := 0; + L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val; + when OC_Array + | OC_Record + | OC_Union + | OC_Sizeof + | OC_Alignof + | OC_Address + | OC_Subprg_Address => + raise Syntax_Error; + end case; + end Get_Const_Bytes; + + procedure Mark (M : out Mark_Type) is + begin + M.Cnode := Cnodes.Last; + M.Els := Els.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Cnodes.Set_Last (M.Cnode); + Els.Set_Last (M.Els); + end Release; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Cnodes: " & O_Cnode'Image (Cnodes.Last)); + Put_Line ("Number of Cnodes-Els: " & Int32'Image (Els.Last)); + end Disp_Stats; + + procedure Finish is + begin + Cnodes.Free; + Els.Free; + end Finish; +end Ortho_Code.Consts; |