-- Mcode back-end for ortho - Internal tree dumper.
-- 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.Text_IO; use Ada.Text_IO;
with Ortho_Code.Debug;
with Ortho_Code.Consts;
with Ortho_Code.Decls;
with Ortho_Code.Types;
with Ortho_Code.Flags;
with Ortho_Ident;
with Interfaces;
package body Ortho_Code.Disps is
procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode);
procedure Disp_Expr (Expr : O_Enode);
procedure Disp_Indent (Indent : Natural)
is
begin
Put ((1 .. 2 * Indent => ' '));
end Disp_Indent;
procedure Disp_Ident (Id : O_Ident)
is
use Ortho_Ident;
begin
Put (Get_String (Id));
end Disp_Ident;
procedure Disp_Storage (Storage : O_Storage) is
begin
case Storage is
when O_Storage_External =>
Put ("external");
when O_Storage_Public =>
Put ("public");
when O_Storage_Private =>
Put ("private");
when O_Storage_Local =>
Put ("local");
end case;
end Disp_Storage;
procedure Disp_Label (Label : O_Enode)
is
N : Int32;
begin
case Get_Expr_Kind (Label) is
when OE_Label =>
Put ("label");
N := Int32 (Label);
when OE_Loop =>
Put ("loop");
N := Int32 (Label);
when OE_BB =>
Put ("BB");
N := Get_BB_Number (Label);
when others =>
raise Program_Error;
end case;
Put (Int32'Image (N));
Put (":");
end Disp_Label;
procedure Disp_Call (Call : O_Enode)
is
Arg : O_Enode;
begin
Decls.Disp_Decl_Name (Get_Call_Subprg (Call));
Arg := Get_Arg_Link (Call);
if Arg /= O_Enode_Null then
Put (" (");
loop
Disp_Expr (Get_Expr_Operand (Arg));
Arg := Get_Arg_Link (Arg);
exit when Arg = O_Enode_Null;
Put (", ");
end loop;
Put (")");
end if;
end Disp_Call;
procedure Put_Trim (Str : String) is
begin
if Str (Str'First) = ' ' then
Put (Str (Str'First + 1 .. Str'Last));
else
Put (Str);
end if;
end Put_Trim;
procedure Disp_Typed_Lit (Lit : O_Cnode; Val : String)
is
use Ortho_Code.Consts;
begin
Disp_Type (Get_Const_Type (Lit));
Put ("'[");
Put_Trim (Val);
Put (']');
end Disp_Typed_Lit;
procedure Disp_Lit (Lit : O_Cnode)
is
use Interfaces;
use Ortho_Code.Consts;
begin
case Get_Const_Kind (Lit) is
when OC_Unsigned =>
Disp_Typed_Lit (Lit, Unsigned_64'Image (Get_Const_U64 (Lit)));
when OC_Signed =>
Disp_Typed_Lit (Lit, Integer_64'Image (Get_Const_I64 (Lit)));
when OC_Subprg_Address =>
Disp_Type (Get_Const_Type (Lit));
Put ("'subprg_addr (");
Decls.Disp_Decl_Name (Get_Const_Decl (Lit));
Put (")");
when OC_Address =>
Disp_Type (Get_Const_Type (Lit));
Put ("'address (");
Decls.Disp_Decl_Name (Get_Const_Decl (Lit));
Put (")");
when OC_Sizeof =>
Disp_Type (Get_Const_Type (Lit));
Put ("'sizeof (");
Disp_Type (Get_Sizeof_Type (Lit));
Put (")");
when OC_Null =>
Disp_Type (Get_Const_Type (Lit));
Put ("'[null]");
when OC_Lit =>
declare
L : O_Cnode;
begin
L := Types.Get_Type_Enum_Lit
(Get_Const_Type (Lit), Get_Lit_Value (Lit));
Disp_Typed_Lit
(Lit, Ortho_Ident.Get_String (Get_Lit_Ident (L)));
end;
when OC_Array =>
Put ('{');
for I in 1 .. Get_Const_Aggr_Length (Lit) loop
if I /= 1 then
Put (", ");
end if;
Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1));
end loop;
Put ('}');
when OC_Record =>
declare
use Ortho_Code.Types;
F : O_Fnode;
begin
F := Get_Type_Record_Fields (Get_Const_Type (Lit));
Put ('{');
for I in 1 .. Get_Const_Aggr_Length (Lit) loop
if I /= 1 then
Put (", ");
end if;
Put ('.');
Disp_Ident (Get_Field_Ident (F));
Put (" = ");
Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1));
F := Get_Field_Chain (F);
end loop;
Put ('}');
end;
when OC_Union =>
Put ('{');
Put ('.');
Disp_Ident (Types.Get_Field_Ident (Get_Const_Union_Field (Lit)));
Put ('=');
Disp_Lit (Get_Const_Union_Value (Lit));
Put ('}');
when others =>
Put ("*lit " & OC_Kind'Image (Get_Const_Kind (Lit)) & '*');
end case;
end Disp_Lit;
procedure Disp_Expr (Expr : O_Enode)
is
Kind : OE_Kind;
begin
Kind := Get_Expr_Kind (Expr);
case Kind is
when OE_Const =>
case Get_Expr_Mode (Expr) is
when Mode_I8
| Mode_I16
| Mode_I32 =>
Put_Trim (Int32'Image (To_Int32 (Get_Expr_Low (Expr))));
when Mode_U8
| Mode_U16
| Mode_U32 =>
Put_Trim (Uns32'Image (Get_Expr_Low (Expr)));
when others =>
Put ("const:");
Debug.Disp_Mode (Get_Expr_Mode (Expr));
end case;
when OE_Lit =>
Disp_Lit (Get_Expr_Lit (Expr));
when OE_Case_Expr =>
Put ("{case}");
when OE_Kind_Dyadic
| OE_Kind_Cmp
| OE_Add
| OE_Mul
| OE_Shl =>
Put ("(");
Disp_Expr (Get_Expr_Left (Expr));
Put (' ');
case Kind is
when OE_Eq =>
Put ('=');
when OE_Neq =>
Put ("/=");
when OE_Lt =>
Put ("<");
when OE_Gt =>
Put (">");
when OE_Ge =>
Put (">=");
when OE_Le =>
Put ("<=");
when OE_Add =>
Put ('+');
when OE_Mul =>
Put ('*');
when OE_Add_Ov =>
Put ("+#");
when OE_Sub_Ov =>
Put ("-#");
when OE_Mul_Ov =>
Put ("*#");
when OE_Shl =>
Put ("<<");
when OE_And =>
Put ("and");
when OE_Or =>
Put ("or");
when others =>
Put (OE_Kind'Image (Kind));
end case;
Put (' ');
Disp_Expr (Get_Expr_Right (Expr));
Put (")");
when OE_Not =>
Put ("not ");
Disp_Expr (Get_Expr_Operand (Expr));
when OE_Neg_Ov =>
Put ("neg ");
Disp_Expr (Get_Expr_Operand (Expr));
when OE_Abs_Ov =>
Put ("abs ");
Disp_Expr (Get_Expr_Operand (Expr));
when OE_Indir =>
declare
Op : O_Enode;
begin
Op := Get_Expr_Operand (Expr);
case Get_Expr_Kind (Op) is
when OE_Addrg
| OE_Addrl =>
Decls.Disp_Decl_Name (Get_Addr_Object (Op));
when others =>
--Put ("*");
Disp_Expr (Op);
end case;
end;
when OE_Addrl
| OE_Addrg =>
-- Put ('@');
Decls.Disp_Decl_Name (Get_Addr_Object (Expr));
when OE_Call =>
Disp_Call (Expr);
when OE_Alloca =>
Put ("alloca (");
Disp_Expr (Get_Expr_Operand (Expr));
Put (")");
when OE_Conv =>
Disp_Type (Get_Conv_Type (Expr));
Put ("'conv (");
Disp_Expr (Get_Expr_Operand (Expr));
Put (")");
when OE_Conv_Ptr =>
Disp_Type (Get_Conv_Type (Expr));
Put ("'address (");
Disp_Expr (Get_Expr_Operand (Expr));
Put (")");
when OE_Typed =>
Disp_Type (Get_Conv_Type (Expr));
Put ("'");
-- Note: there is always parenthesis around comparison.
Disp_Expr (Get_Expr_Operand (Expr));
when OE_Record_Ref =>
Disp_Expr (Get_Expr_Operand (Expr));
Put (".");
Disp_Ident (Types.Get_Field_Ident (Get_Ref_Field (Expr)));
when OE_Access_Ref =>
Disp_Expr (Get_Expr_Operand (Expr));
Put (".all");
when OE_Index_Ref =>
Disp_Expr (Get_Expr_Operand (Expr));
Put ('[');
Disp_Expr (Get_Ref_Index (Expr));
Put (']');
when OE_Slice_Ref =>
Disp_Expr (Get_Expr_Operand (Expr));
Put ('[');
Disp_Expr (Get_Ref_Index (Expr));
Put ("...]");
when OE_Get_Stack =>
Put ("%sp");
when OE_Get_Frame =>
Put ("%fp");
when others =>
Put_Line (Standard_Error, "disps.disp_expr: unknown expr "
& OE_Kind'Image (Kind));
end case;
end Disp_Expr;
procedure Disp_Fields (Indent : Natural; Atype : O_Tnode)
is
use Types;
Nbr : Uns32;
F : O_Fnode;
begin
Nbr := Get_Type_Record_Nbr_Fields (Atype);
F := Get_Type_Record_Fields (Atype);
for I in 1 .. Nbr loop
Disp_Indent (Indent);
Disp_Ident (Get_Field_Ident (F));
Put (": ");
Disp_Type (Get_Field_Type (F));
Put (";");
New_Line;
F := Get_Field_Chain (F);
end loop;
end Disp_Fields;
procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False)
is
use Types;
Kind : OT_Kind;
Decl : O_Dnode;
begin
if not Force then
Decl := Decls.Get_Type_Decl (Atype);
if Decl /= O_Dnode_Null then
Decls.Disp_Decl_Name (Decl);
return;
end if;
end if;
Kind := Get_Type_Kind (Atype);
case Kind is
when OT_Signed =>
Put ("signed (");
Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype)));
Put (")");
when OT_Unsigned =>
Put ("unsigned (");
Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype)));
Put (")");
when OT_Float =>
Put ("float");
when OT_Access =>
Put ("access");
declare
Acc_Type : O_Tnode;
begin
Acc_Type := Get_Type_Access_Type (Atype);
if Acc_Type /= O_Tnode_Null then
Put (' ');
Disp_Type (Acc_Type);
end if;
end;
when OT_Ucarray =>
Put ("array [");
Disp_Type (Get_Type_Ucarray_Index (Atype));
Put ("] of ");
Disp_Type (Get_Type_Ucarray_Element (Atype));
when OT_Subarray =>
Put ("subarray ");
Disp_Type (Get_Type_Subarray_Base (Atype));
Put ("[");
Put_Trim (Uns32'Image (Get_Type_Subarray_Length (Atype)));
Put ("]");
when OT_Record =>
Put_Line ("record");
Disp_Fields (1, Atype);
Put ("end record");
when OT_Union =>
Put_Line ("union");
Disp_Fields (1, Atype);
Put ("end union");
when OT_Boolean =>
declare
Lit : O_Cnode;
begin
Put ("boolean {");
Lit := Get_Type_Bool_False (Atype);
Disp_Ident (Consts.Get_Lit_Ident (Lit));
Put (", ");
Lit := Get_Type_Bool_True (Atype);
Disp_Ident (Consts.Get_Lit_Ident (Lit));
Put ("}");
end;
when OT_Enum =>
declare
use Consts;
Lit : O_Cnode;
begin
Put ("enum {");
Lit := Get_Type_Enum_Lits (Atype);
for I in 1 .. Get_Type_Enum_Nbr_Lits (Atype) loop
if I /= 1 then
Put (", ");
end if;
Disp_Ident (Get_Lit_Ident (Lit));
Put (" =");
Put (Uns32'Image (I - 1));
Lit := Get_Lit_Chain (Lit);
end loop;
Put ('}');
end;
when OT_Complete =>
Put ("-- complete: ");
Disp_Type (Get_Type_Complete_Type (Atype));
end case;
end Disp_Type;
procedure Disp_Decl_Storage (Decl : O_Dnode) is
begin
Disp_Storage (Decls.Get_Decl_Storage (Decl));
Put (' ');
end Disp_Decl_Storage;
procedure Disp_Subprg_Decl (Indent : Natural; Decl : O_Dnode)
is
use Decls;
Kind : OD_Kind;
Inter : O_Dnode;
begin
Disp_Decl_Storage (Decl);
Kind := Get_Decl_Kind (Decl);
case Kind is
when OD_Function =>
Put ("function ");
when OD_Procedure =>
Put ("procedure ");
when others =>
raise Program_Error;
end case;
Disp_Decl_Name (Decl);
Inter := Get_Subprg_Interfaces (Decl);
Put (" (");
New_Line;
if Inter /= O_Dnode_Null then
loop
Disp_Indent (Indent + 1);
Disp_Decl_Name (Inter);
Put (": ");
Disp_Type (Get_Decl_Type (Inter));
Inter := Get_Interface_Chain (Inter);
exit when Inter = O_Dnode_Null;
Put (";");
New_Line;
end loop;
else
Disp_Indent (Indent + 1);
end if;
Put (")");
if Kind = OD_Function then
New_Line;
Disp_Indent (Indent + 1);
Put ("return ");
Disp_Type (Get_Decl_Type (Decl));
end if;
end Disp_Subprg_Decl;
procedure Disp_Decl (Indent : Natural;
Decl : O_Dnode;
Nl : Boolean := False)
is
use Decls;
Kind : OD_Kind;
Dtype : O_Tnode;
begin
Kind := Get_Decl_Kind (Decl);
if Kind = OD_Interface then
return;
end if;
Disp_Indent (Indent);
case Kind is
when OD_Type =>
Dtype := Get_Decl_Type (Decl);
Put ("type ");
Disp_Decl_Name (Decl);
Put (" is ");
Disp_Type (Dtype, True);
Put_Line (";");
when OD_Local
| OD_Var =>
Disp_Decl_Storage (Decl);
Put ("var ");
Disp_Decl_Name (Decl);
Put (" : ");
Dtype := Get_Decl_Type (Decl);
Disp_Type (Dtype);
if True then
Put (" {size="
& Uns32'Image (Types.Get_Type_Size (Dtype)) & "}");
end if;
Put_Line (";");
when OD_Const =>
Disp_Decl_Storage (Decl);
Put ("constant ");
Disp_Decl_Name (Decl);
Put (" : ");
Disp_Type (Get_Decl_Type (Decl));
Put_Line (";");
when OD_Const_Val =>
Put ("constant ");
Disp_Decl_Name (Get_Val_Decl (Decl));
Put (" := ");
Disp_Lit (Get_Val_Val (Decl));
Put_Line (";");
when OD_Function
| OD_Procedure =>
Disp_Subprg_Decl (Indent, Decl);
Put_Line (";");
when OD_Interface =>
null;
when OD_Body =>
-- Put ("body ");
Disp_Subprg_Decl (Indent, Get_Body_Decl (Decl));
-- Disp_Decl_Name (Get_Body_Decl (Decl));
New_Line;
Disp_Subprg (Indent, Get_Body_Stmt (Decl));
when OD_Block | OD_Subprg_Ext =>
null;
end case;
if Nl then
New_Line;
end if;
end Disp_Decl;
procedure Disp_Stmt (Indent : in out Natural; Stmt : O_Enode)
is
use Decls;
Expr : O_Enode;
begin
case Get_Expr_Kind (Stmt) is
when OE_Beg =>
Disp_Indent (Indent);
Put_Line ("declare");
declare
Last : O_Dnode;
Decl : O_Dnode;
begin
Decl := Get_Block_Decls (Stmt);
Last := Get_Block_Last (Decl);
Decl := Decl + 1;
while Decl <= Last loop
case Get_Decl_Kind (Decl) is
when OD_Block =>
Decl := Get_Block_Last (Decl) + 1;
when others =>
Disp_Decl (Indent + 1, Decl, False);
Decl := Decl + 1;
end case;
end loop;
end;
Disp_Indent (Indent);
Put_Line ("begin");
Indent := Indent + 1;
when OE_End =>
Indent := Indent - 1;
Disp_Indent (Indent);
Put_Line ("end;");
when OE_Line =>
Disp_Indent (Indent);
Put_Line ("--#" & Int32'Image (Get_Expr_Line_Number (Stmt)));
when OE_BB =>
Disp_Indent (Indent);
Put_Line ("# BB" & Int32'Image (Get_BB_Number (Stmt)));
when OE_Asgn =>
Disp_Indent (Indent);
Disp_Expr (Get_Assign_Target (Stmt));
Put (" := ");
Disp_Expr (Get_Expr_Operand (Stmt));
Put_Line (";");
when OE_Call =>
Disp_Indent (Indent);
Disp_Call (Stmt);
Put_Line (";");
when OE_Jump_F =>
Disp_Indent (Indent);
Put ("jump ");
Disp_Label (Get_Jump_Label (Stmt));
Put (" if not ");
Disp_Expr (Get_Expr_Operand (Stmt));
New_Line;
when OE_Jump_T =>
Disp_Indent (Indent);
Put ("jump ");
Disp_Label (Get_Jump_Label (Stmt));
Put (" if ");
Disp_Expr (Get_Expr_Operand (Stmt));
New_Line;
when OE_Jump =>
Disp_Indent (Indent);
Put ("jump ");
Disp_Label (Get_Jump_Label (Stmt));
New_Line;
when OE_Label =>
Disp_Indent (Indent);
Disp_Label (Stmt);
New_Line;
when OE_Ret =>
Disp_Indent (Indent);
Put ("return");
Expr := Get_Expr_Operand (Stmt);
if Expr /= O_Enode_Null then
Put (" ");
Disp_Expr (Expr);
end if;
Put_Line (";");
when OE_Set_Stack =>
Disp_Indent (Indent);
Put ("%sp := ");
Disp_Expr (Get_Expr_Operand (Stmt));
Put_Line (";");
when OE_Leave =>
Disp_Indent (Indent);
Put_Line ("# leave");
when OE_If =>
Disp_Indent (Indent);
Put ("if ");
Disp_Expr (Get_Expr_Operand (Stmt));
Put (" then");
New_Line;
Indent := Indent + 1;
when OE_Else =>
Disp_Indent (Indent - 1);
Put ("else");
New_Line;
when OE_Endif =>
Indent := Indent - 1;
Disp_Indent (Indent);
Put_Line ("end if;");
when OE_Loop =>
Disp_Indent (Indent);
Disp_Label (Stmt);
New_Line;
Indent := Indent + 1;
when OE_Exit =>
Disp_Indent (Indent);
Put ("exit ");
Disp_Label (Get_Jump_Label (Stmt));
Put (";");
New_Line;
when OE_Next =>
Disp_Indent (Indent);
Put ("next ");
Disp_Label (Get_Jump_Label (Stmt));
Put (";");
New_Line;
when OE_Eloop =>
Indent := Indent - 1;
Disp_Indent (Indent);
Put_Line ("end loop;");
when OE_Case =>
Disp_Indent (Indent);
Put ("case ");
Disp_Expr (Get_Expr_Operand (Stmt));
Put (" is");
New_Line;
if Debug.Flag_Debug_Hli then
Indent := Indent + 2;
end if;
when OE_Case_Branch =>
Disp_Indent (Indent - 1);
Put ("when ");
declare
C : O_Enode;
L, H : O_Enode;
begin
C := Get_Case_Branch_Choice (Stmt);
loop
L := Get_Expr_Left (C);
H := Get_Expr_Right (C);
if L = O_Enode_Null then
Put ("others");
else
Disp_Expr (L);
if H /= O_Enode_Null then
Put (" ... ");
Disp_Expr (H);
end if;
end if;
C := Get_Case_Choice_Link (C);
exit when C = O_Enode_Null;
New_Line;
Disp_Indent (Indent - 1);
Put (" | ");
end loop;
Put (" =>");
New_Line;
end;
when OE_Case_End =>
Indent := Indent - 2;
Disp_Indent (Indent);
Put ("end case;");
New_Line;
when others =>
Put_Line (Standard_Error, "debug.disp_stmt: unknown statement " &
OE_Kind'Image (Get_Expr_Kind (Stmt)));
end case;
end Disp_Stmt;
procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode)
is
Stmt : O_Enode;
N_Ident : Natural := Ident;
begin
Stmt := S_Entry;
loop
Stmt := Get_Stmt_Link (Stmt);
Disp_Stmt (N_Ident, Stmt);
exit when Get_Expr_Kind (Stmt) = OE_Leave;
end loop;
end Disp_Subprg;
Last_Decl : O_Dnode := O_Dnode_First;
procedure Disp_Decls_Until (Last : O_Dnode; Nl : Boolean := False) is
begin
while Last_Decl <= Last loop
Disp_Decl (0, Last_Decl, Nl);
Last_Decl := Last_Decl + 1;
end loop;
end Disp_Decls_Until;
procedure Disp_Subprg (Subprg : Subprogram_Data_Acc)
is
use Decls;
begin
Disp_Decls_Until (Subprg.D_Body, True);
if Get_Decl_Kind (Last_Decl) /= OD_Block then
raise Program_Error;
end if;
if Debug.Flag_Debug_Keep then
-- If nodes are kept, the next declaration to be displayed (at top
-- level) is the one that follow the subprogram block.
Last_Decl := Get_Block_Last (Last_Decl) + 1;
else
-- If nodes are not kept, this subprogram block will be freed, and
-- the next declaration is the block itself.
Last_Decl := Subprg.D_Body;
end if;
end Disp_Subprg;
procedure Init is
begin
Flags.Flag_Type_Name := True;
end Init;
procedure Finish is
begin
Disp_Decls_Until (Decls.Get_Decl_Last, True);
end Finish;
end Ortho_Code.Disps;