diff options
Diffstat (limited to 'ortho/mcode/binary_file.adb')
| -rw-r--r-- | ortho/mcode/binary_file.adb | 985 |
1 files changed, 985 insertions, 0 deletions
diff --git a/ortho/mcode/binary_file.adb b/ortho/mcode/binary_file.adb new file mode 100644 index 0000000..58c5a79 --- /dev/null +++ b/ortho/mcode/binary_file.adb @@ -0,0 +1,985 @@ +-- Binary file 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 System; +with System.Storage_Elements; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Characters.Latin_1; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with GNAT.Table; +with Hex_Images; use Hex_Images; +with Disassemble; + +package body Binary_File is + Cur_Sect : Section_Acc := null; + + HT : Character renames Ada.Characters.Latin_1.HT; + + function To_Byte_Array_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Byte_Array_Acc); + + -- Resize a section to SIZE bytes. + procedure Resize (Sect : Section_Acc; Size : Pc_Type) + is + begin + Sect.Data_Max := Size; + Memsegs.Resize (Sect.Seg, Natural (Size)); + Sect.Data := To_Byte_Array_Acc (Memsegs.Get_Address (Sect.Seg)); + end Resize; + + function Get_Scope (Sym : Symbol) return Symbol_Scope is + begin + return Symbols.Table (Sym).Scope; + end Get_Scope; + + procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope) is + begin + Symbols.Table (Sym).Scope := Scope; + end Set_Scope; + + function Get_Section (Sym : Symbol) return Section_Acc is + begin + return Symbols.Table (Sym).Section; + end Get_Section; + + procedure Set_Section (Sym : Symbol; Sect : Section_Acc) is + begin + Symbols.Table (Sym).Section := Sect; + end Set_Section; + + function Get_Number (Sym : Symbol) return Natural is + begin + return Symbols.Table (Sym).Number; + end Get_Number; + + procedure Set_Number (Sym : Symbol; Num : Natural) is + begin + Symbols.Table (Sym).Number := Num; + end Set_Number; + + function Get_Relocs (Sym : Symbol) return Reloc_Acc is + begin + return Symbols.Table (Sym).Relocs; + end Get_Relocs; + + procedure Set_Relocs (Sym : Symbol; Reloc : Reloc_Acc) is + begin + Symbols.Table (Sym).Relocs := Reloc; + end Set_Relocs; + + function Get_Name (Sym : Symbol) return O_Ident is + begin + return Symbols.Table (Sym).Name; + end Get_Name; + + function Get_Used (Sym : Symbol) return Boolean is + begin + return Symbols.Table (Sym).Used; + end Get_Used; + + procedure Set_Used (Sym : Symbol; Val : Boolean) is + begin + Symbols.Table (Sym).Used := Val; + end Set_Used; + + function Get_Symbol_Value (Sym : Symbol) return Pc_Type is + begin + return Symbols.Table (Sym).Value; + end Get_Symbol_Value; + + procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type) is + begin + Symbols.Table (Sym).Value := Val; + end Set_Symbol_Value; + + function S_Defined (Sym : Symbol) return Boolean is + begin + return Get_Scope (Sym) /= Sym_Undef; + end S_Defined; + + function S_Local (Sym : Symbol) return Boolean is + begin + return Get_Scope (Sym) = Sym_Local; + end S_Local; + + procedure Create_Section (Sect : out Section_Acc; + Name : String; Flags : Section_Flags) + is + begin + Sect := new Section_Type'(Next => null, + Flags => Flags, + Name => new String'(Name), + Link => null, + Align => 2, + Esize => 0, + Pc => 0, + Insn_Pc => 0, + Data => null, + Data_Max => 0, + First_Reloc => null, + Last_Reloc => null, + Nbr_Relocs => 0, + Number => 0, + Seg => Memsegs.Create, + Vaddr => 0); + if (Flags and Section_Zero) = 0 then + -- Allocate memory for the segment, unless BSS. + Resize (Sect, 8192); + end if; + if (Flags and Section_Strtab) /= 0 then + Sect.Align := 0; + end if; + if Section_Chain = null then + Section_Chain := Sect; + else + Section_Last.Next := Sect; + end if; + Section_Last := Sect; + Nbr_Sections := Nbr_Sections + 1; + end Create_Section; + + procedure Sect_Prealloc (Sect : Section_Acc; L : Pc_Type) + is + New_Max : Pc_Type; + begin + if Sect.Pc + L < Sect.Data_Max then + return; + end if; + New_Max := Sect.Data_Max; + loop + New_Max := New_Max * 2; + exit when Sect.Pc + L < New_Max; + end loop; + Resize (Sect, New_Max); + end Sect_Prealloc; + + procedure Merge_Section (Dest : Section_Acc; Src : in out Section_Acc) + is + Rel : Reloc_Acc; + begin + -- Sanity checks. + if Src = null or else Dest = Src then + raise Program_Error; + end if; + + Rel := Src.First_Reloc; + + if Rel /= null then + -- Move relocs. + if Dest.Last_Reloc = null then + Dest.First_Reloc := Rel; + Dest.Last_Reloc := Rel; + else + Dest.Last_Reloc.Sect_Next := Rel; + Dest.Last_Reloc := Rel; + end if; + Dest.Nbr_Relocs := Dest.Nbr_Relocs + Src.Nbr_Relocs; + + + -- Reloc reloc, since the pc has changed. + while Rel /= null loop + Rel.Addr := Rel.Addr + Dest.Pc; + Rel := Rel.Sect_Next; + end loop; + end if; + + if Src.Pc > 0 then + Sect_Prealloc (Dest, Src.Pc); + Dest.Data (Dest.Pc .. Dest.Pc + Src.Pc - 1) := + Src.Data (0 .. Src.Pc - 1); + Dest.Pc := Dest.Pc + Src.Pc; + end if; + + Memsegs.Delete (Src.Seg); + Src.Pc := 0; + Src.Data_Max := 0; + Src.Data := null; + Src.First_Reloc := null; + Src.Last_Reloc := null; + Src.Nbr_Relocs := 0; + + -- Remove from section_chain. + if Section_Chain = Src then + Section_Chain := Src.Next; + else + declare + Sect : Section_Acc; + begin + Sect := Section_Chain; + while Sect.Next /= Src loop + Sect := Sect.Next; + end loop; + Sect.Next := Src.Next; + if Section_Last = Src then + Section_Last := Sect; + end if; + end; + end if; + Nbr_Sections := Nbr_Sections - 1; + end Merge_Section; + + procedure Set_Section_Info (Sect : Section_Acc; + Link : Section_Acc; + Align : Natural; + Esize : Natural) + is + begin + Sect.Link := Link; + Sect.Align := Align; + Sect.Esize := Esize; + end Set_Section_Info; + + procedure Set_Current_Section (Sect : Section_Acc) is + begin + -- If the current section does not change, this is a no-op. + if Cur_Sect = Sect then + return; + end if; + + if Dump_Asm then + Put_Line (HT & ".section """ & Sect.Name.all & """"); + end if; + Cur_Sect := Sect; + end Set_Current_Section; + + function Get_Current_Pc return Pc_Type is + begin + return Cur_Sect.Pc; + end Get_Current_Pc; + + function Get_Pc (Sect : Section_Acc) return Pc_Type is + begin + return Sect.Pc; + end Get_Pc; + + + procedure Prealloc (L : Pc_Type) is + begin + Sect_Prealloc (Cur_Sect, L); + end Prealloc; + + procedure Start_Insn is + begin + -- Check there is enough memory for the next instruction. + Sect_Prealloc (Cur_Sect, 16); + if Cur_Sect.Insn_Pc /= 0 then + -- end_insn was not called. + raise Program_Error; + end if; + Cur_Sect.Insn_Pc := Cur_Sect.Pc; + end Start_Insn; + + procedure Get_Symbol_At_Addr (Addr : System.Address; + Line : in out String; + Line_Len : in out Natural) + is + use System; + use System.Storage_Elements; + Off : Pc_Type; + Reloc : Reloc_Acc; + begin + -- Check if addr is in the current section. + if Addr < Cur_Sect.Data (0)'Address + or else Addr > Cur_Sect.Data (Cur_Sect.Pc)'Address + then + raise Program_Error; + --return; + end if; + Off := Pc_Type + (To_Integer (Addr) - To_Integer (Cur_Sect.Data (0)'Address)); + + -- Find a relocation at OFF. + Reloc := Cur_Sect.First_Reloc; + while Reloc /= null loop + if Reloc.Addr = Off then + declare + Str : String := Get_Symbol_Name (Reloc.Sym); + begin + Line (Line'First .. Line'First + Str'Length - 1) := Str; + Line_Len := Line_Len + Str'Length; + return; + end; + end if; + Reloc := Reloc.Sect_Next; + end loop; + end Get_Symbol_At_Addr; + + procedure End_Insn + is + Str : String (1 .. 128); + Len : Natural; + Insn_Len : Natural; + begin + --if Insn_Pc = 0 then + -- -- start_insn was not called. + -- raise Program_Error; + --end if; + if Debug_Hex then + Put (HT); + Put ('#'); + for I in Cur_Sect.Insn_Pc .. Cur_Sect.Pc - 1 loop + Put (' '); + Put (Hex_Image (Unsigned_8 (Cur_Sect.Data (I)))); + end loop; + New_Line; + end if; + + if Dump_Asm then + Disassemble.Disassemble_Insn + (Cur_Sect.Data (Cur_Sect.Insn_Pc)'Address, + Unsigned_32 (Cur_Sect.Insn_Pc), + Str, Len, Insn_Len, + Get_Symbol_At_Addr'Access); + Put (HT); + Put_Line (Str (1 .. Len)); + end if; + --if Natural (Cur_Pc - Insn_Pc) /= Insn_Len then + -- raise Program_Error; + --end if; + Cur_Sect.Insn_Pc := 0; + end End_Insn; + + procedure Gen_B8 (B : Byte) is + begin + Cur_Sect.Data (Cur_Sect.Pc) := B; + Cur_Sect.Pc := Cur_Sect.Pc + 1; + end Gen_B8; + + procedure Gen_B16 (B0, B1 : Byte) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := B0; + Cur_Sect.Data (Cur_Sect.Pc + 1) := B1; + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_B16; + + procedure Gen_Le8 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc) := Byte (B and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 1; + end Gen_Le8; + + procedure Gen_Le16 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 0) and 16#Ff#); + Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 8) and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_Le16; + + procedure Gen_Be16 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 8) and 16#Ff#); + Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 0) and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_Be16; + + procedure Write_B8 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_8) is + begin + Sect.Data (Pc) := Byte (V); + end Write_B8; + + procedure Write_Be16 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 0) and 16#Ff#); + end Write_Be16; + + procedure Write_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 0) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 2) := Byte (Shift_Right (V, 16) and 16#Ff#); + Sect.Data (Pc + 3) := Byte (Shift_Right (V, 24) and 16#Ff#); + end Write_Le32; + + procedure Write_Be32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 24) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 16) and 16#Ff#); + Sect.Data (Pc + 2) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 3) := Byte (Shift_Right (V, 0) and 16#Ff#); + end Write_Be32; + + procedure Write_16 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) + is + subtype B2 is Byte_Array_Base (0 .. 1); + function To_B2 is new Ada.Unchecked_Conversion + (Source => Unsigned_16, Target => B2); + begin + Sect.Data (Pc + 0 .. Pc + 1) := To_B2 (Unsigned_16 (B)); + end Write_16; + + procedure Write_32 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) + is + subtype B4 is Byte_Array_Base (0 .. 3); + function To_B4 is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => B4); + begin + Sect.Data (Pc + 0 .. Pc + 3) := To_B4 (B); + end Write_32; + + procedure Gen_16 (B : Unsigned_32) is + begin + Write_16 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_16; + + procedure Gen_32 (B : Unsigned_32) is + begin + Write_32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_32; + + function Read_Le32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is + begin + return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 0) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 8) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 16) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 24); + end Read_Le32; + + function Read_Be32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is + begin + return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 24) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 16) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 8) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 0); + end Read_Be32; + + procedure Add_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Write_Le32 (Sect, Pc, V + Read_Le32 (Sect, Pc)); + end Add_Le32; + + procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Le32 (Cur_Sect, Pc, V); + end Patch_Le32; + + procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Be32 (Cur_Sect, Pc, V); + end Patch_Be32; + + procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 2 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Be16 (Cur_Sect, Pc, V); + end Patch_Be16; + + procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8) is + begin + if Pc >= Get_Current_Pc then + raise Program_Error; + end if; + Write_B8 (Cur_Sect, Pc, V); + end Patch_B8; + + procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_32 (Cur_Sect, Pc, V); + end Patch_32; + + procedure Gen_Le32 (B : Unsigned_32) is + begin + Write_Le32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_Le32; + + procedure Gen_Be32 (B : Unsigned_32) is + begin + Write_Be32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_Be32; + + procedure Gen_Data_Le8 (B : Unsigned_32) is + begin + if Dump_Asm then + Put_Line (HT & ".byte 0x" & Hex_Image (Unsigned_8 (B))); + end if; + Gen_Le8 (B); + end Gen_Data_Le8; + + procedure Gen_Data_Le16 (B : Unsigned_32) is + begin + if Dump_Asm then + Put_Line (HT & ".half 0x" & Hex_Image (Unsigned_16 (B))); + end if; + Gen_Le16 (B); + end Gen_Data_Le16; + + procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Dump_Asm then + if Sym = Null_Symbol then + Put_Line (HT & ".word 0x" & Hex_Image (Offset)); + else + if Offset = 0 then + Put_Line (HT & ".word " & Get_Symbol_Name (Sym)); + else + Put_Line (HT & ".word " & Get_Symbol_Name (Sym) & " + " + & Hex_Image (Offset)); + end if; + end if; + end if; + case Arch is + when Arch_X86 => + Gen_X86_32 (Sym, Offset); + when Arch_Sparc => + Gen_Sparc_32 (Sym, Offset); + when others => + raise Program_Error; + end case; + end Gen_Data_32; + + function Create_Symbol (Name : O_Ident) return Symbol + is + begin + Symbols.Append (Symbol_Type'(Section => null, + Value => 0, + Scope => Sym_Undef, + Used => False, + Name => Name, + Relocs => null, + Number => 0)); + return Symbols.Last; + end Create_Symbol; + + Last_Label : Natural := 1; + + function Create_Local_Symbol return Symbol is + begin + Symbols.Append (Symbol_Type'(Section => Cur_Sect, + Value => 0, + Scope => Sym_Local, + Used => False, + Name => O_Ident_Nul, + Relocs => null, + Number => Last_Label)); + + Last_Label := Last_Label + 1; + + return Symbols.Last; + end Create_Local_Symbol; + + function Get_Symbol_Name (Sym : Symbol) return String + is + Res : String (1 .. 10); + N : Natural; + P : Natural; + begin + if S_Local (Sym) then + N := Get_Number (Sym); + P := Res'Last; + loop + Res (P) := Character'Val ((N mod 10) + Character'Pos ('0')); + N := N / 10; + P := P - 1; + exit when N = 0; + end loop; + Res (P) := 'L'; + Res (P - 1) := '.'; + return Res (P - 1 .. Res'Last); + else + if Is_Nul (Get_Name (Sym)) then + return "ANON"; + else + return Get_String (Get_Name (Sym)); + end if; + end if; + end Get_Symbol_Name; + + function Get_Symbol_Name_Length (Sym : Symbol) return Natural + is + N : Natural; + begin + if S_Local (Sym) then + N := 10; + for I in 3 .. 8 loop + if Get_Number (Sym) < N then + return I; + end if; + N := N * 10; + end loop; + raise Program_Error; + else + return Get_String_Length (Get_Name (Sym)); + end if; + end Get_Symbol_Name_Length; + + function Get_Symbol (Name : String) return Symbol is + begin + for I in Symbols.First .. Symbols.Last loop + if Get_Symbol_Name (I) = Name then + return I; + end if; + end loop; + return Null_Symbol; + end Get_Symbol; + + function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type + is + Tmp : Pc_Type; + begin + Tmp := V + 2 ** Align - 1; + return Tmp - (Tmp mod Pc_Type (2 ** Align)); + end Pow_Align; + + procedure Gen_Pow_Align (Align : Natural) is + begin + if Align = 0 then + return; + end if; + if Dump_Asm then + Put_Line (HT & ".align" & Natural'Image (Align)); + end if; + Cur_Sect.Pc := Pow_Align (Cur_Sect.Pc, Align); + end Gen_Pow_Align; + + -- Generate LENGTH bytes set to 0. + procedure Gen_Space (Length : Integer_32) is + begin + if Dump_Asm then + Put_Line (HT & ".space" & Integer_32'Image (Length)); + end if; + Cur_Sect.Pc := Cur_Sect.Pc + Pc_Type (Length); + end Gen_Space; + + procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) + is + use Ada.Text_IO; + begin + case Get_Scope (Sym) is + when Sym_Local => + if Export then + raise Program_Error; + end if; + when Sym_Private + | Sym_Global => + raise Program_Error; + when Sym_Undef => + if Export then + Set_Scope (Sym, Sym_Global); + else + Set_Scope (Sym, Sym_Private); + end if; + end case; + -- Set value/section. + Set_Symbol_Value (Sym, Cur_Sect.Pc); + Set_Section (Sym, Cur_Sect); + + if Dump_Asm then + if Export then + Put_Line (HT & ".globl " & Get_Symbol_Name (Sym)); + end if; + Put (Get_Symbol_Name (Sym)); + Put_Line (":"); + end if; + end Set_Symbol_Pc; + + procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) + is + Reloc : Reloc_Acc; + begin + Reloc := new Reloc_Type'(Kind => Kind, + Done => False, + Sym_Next => Get_Relocs (Sym), + Sect_Next => null, + Addr => Cur_Sect.Pc, + Sym => Sym); + Set_Relocs (Sym, Reloc); + if Cur_Sect.First_Reloc = null then + Cur_Sect.First_Reloc := Reloc; + else + Cur_Sect.Last_Reloc.Sect_Next := Reloc; + end if; + Cur_Sect.Last_Reloc := Reloc; + Cur_Sect.Nbr_Relocs := Cur_Sect.Nbr_Relocs + 1; + end Add_Reloc; + + procedure Gen_X86_Pc32 (Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Pc32); + Gen_Le32 (16#ff_ff_ff_fc#); + end Gen_X86_Pc32; + + procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Disp22); + Gen_Be32 (W); + end Gen_Sparc_Disp22; + + procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Disp30); + Gen_Be32 (W); + end Gen_Sparc_Disp30; + + procedure Gen_Sparc_Hi22 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32) + is + pragma Unreferenced (Off); + begin + Add_Reloc (Sym, Reloc_Hi22); + Gen_Be32 (W); + end Gen_Sparc_Hi22; + + procedure Gen_Sparc_Lo10 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32) + is + pragma Unreferenced (Off); + begin + Add_Reloc (Sym, Reloc_Lo10); + Gen_Be32 (W); + end Gen_Sparc_Lo10; + + function Conv is new Ada.Unchecked_Conversion + (Source => Integer_32, Target => Unsigned_32); + + procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_32); + end if; + Gen_Le32 (Conv (Offset)); + end Gen_X86_32; + + procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_32); + end if; + Gen_Be32 (Conv (Offset)); + end Gen_Sparc_32; + + procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32) + is + pragma Unreferenced (Offset); + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_Ua_32); + end if; + Gen_Be32 (0); + end Gen_Sparc_Ua_32; + + procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32) is + begin + case Arch is + when Arch_X86 => + Gen_X86_32 (Sym, Offset); + when Arch_Sparc => + Gen_Sparc_Ua_32 (Sym, Offset); + when others => + raise Program_Error; + end case; + end Gen_Ua_32; + + procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Ppc_Addr24); + Gen_32 (V); + end Gen_Ppc_24; + + function Get_Symbol_Vaddr (Sym : Symbol) return Unsigned_32 is + begin + return Unsigned_32 (Get_Section (Sym).Vaddr) + + Unsigned_32 (Get_Symbol_Value (Sym)); + end Get_Symbol_Vaddr; + + procedure Write_Left_Be32 (Sect : Section_Acc; + Addr : Pc_Type; + Size : Natural; + Val : Unsigned_32) + is + W : Unsigned_32; + Mask : Unsigned_32; + begin + -- Write value. + Mask := Shift_Left (1, Size) - 1; + W := Read_Be32 (Sect, Addr); + Write_Be32 (Sect, Addr, (W and not Mask) or (Val and Mask)); + end Write_Left_Be32; + + procedure Set_Wdisp (Sect : Section_Acc; + Addr : Pc_Type; + Sym : Symbol; + Size : Natural) + is + D : Unsigned_32; + Mask : Unsigned_32; + begin + D := Get_Symbol_Vaddr (Sym) - + (Unsigned_32 (Sect.Vaddr) + Unsigned_32 (Addr)); + -- Check overflow. + Mask := Shift_Left (1, Size + 2) - 1; + if (D and Shift_Left (1, Size + 1)) = 0 then + if (D and not Mask) /= 0 then + raise Program_Error; + end if; + else + if (D and not Mask) /= not Mask then + raise Program_Error; + end if; + end if; + -- Write value. + Write_Left_Be32 (Sect, Addr, Size, D / 4); + end Set_Wdisp; + + procedure Do_Reloc (Kind : Reloc_Kind; + Sect : Section_Acc; Addr : Pc_Type; Sym : Symbol) + is + begin + if Get_Scope (Sym) = Sym_Undef then + raise Program_Error; + end if; + + case Kind is + when Reloc_32 => + Add_Le32 (Sect, Addr, Get_Symbol_Vaddr (Sym)); + + when Reloc_Pc32 => + Add_Le32 (Sect, Addr, + Get_Symbol_Vaddr (Sym) - + (Unsigned_32 (Sect.Vaddr) + Unsigned_32 (Addr))); + + when Reloc_Disp22 => + Set_Wdisp (Sect, Addr, Sym, 22); + when Reloc_Disp30 => + Set_Wdisp (Sect, Addr, Sym, 30); + when Reloc_Hi22 => + Write_Left_Be32 (Sect, Addr, 22, Get_Symbol_Vaddr (Sym) / 1024); + when Reloc_Lo10 => + Write_Left_Be32 (Sect, Addr, 10, Get_Symbol_Vaddr (Sym)); + when Reloc_Ua_32 => + Write_Be32 (Sect, Addr, Get_Symbol_Vaddr (Sym)); + when Reloc_Ppc_Addr24 => + raise Program_Error; + end case; + end Do_Reloc; + + function Is_Reloc_Relative (Reloc : Reloc_Acc) return Boolean is + begin + case Reloc.Kind is + when Reloc_Pc32 + | Reloc_Disp22 + | Reloc_Disp30 => + return True; + when others => + return False; + end case; + end Is_Reloc_Relative; + + procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc) is + begin + Do_Reloc (Reloc.Kind, Sect, Reloc.Addr, Reloc.Sym); + end Apply_Reloc; + + procedure Do_Intra_Section_Reloc (Sect : Section_Acc) + is + Prev : Reloc_Acc; + Rel : Reloc_Acc; + Next : Reloc_Acc; + begin + Rel := Sect.First_Reloc; + Prev := null; + while Rel /= null loop + Next := Rel.Sect_Next; + if Get_Scope (Rel.Sym) /= Sym_Undef then + Do_Reloc (Rel.Kind, Sect, Rel.Addr, Rel.Sym); + Rel.Done := True; + + if Get_Section (Rel.Sym) = Sect + and then Is_Reloc_Relative (Rel) + then + -- Remove reloc. + Sect.Nbr_Relocs := Sect.Nbr_Relocs - 1; + if Prev = null then + Sect.First_Reloc := Next; + else + Prev.Sect_Next := Next; + end if; + if Next = null then + Sect.Last_Reloc := Prev; + end if; + Free (Rel); + else + Prev := Rel; + end if; + else + Set_Used (Rel.Sym, True); + Prev := Rel; + end if; + Rel := Next; + end loop; + end Do_Intra_Section_Reloc; + + -- Return VAL rounded up to 2 ^ POW. +-- function Align_Pow (Val : Integer; Pow : Natural) return Integer +-- is +-- N : Integer; +-- Tmp : Integer; +-- begin +-- N := 2 ** Pow; +-- Tmp := Val + N - 1; +-- return Tmp - (Tmp mod N); +-- end Align_Pow; + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last)); + end Disp_Stats; + + procedure Finish + is + Sect : Section_Acc; + Rel, N_Rel : Reloc_Acc; + Old_Rel : Reloc_Acc; + begin + Symbols.Free; + Sect := Section_Chain; + while Sect /= null loop + -- Free relocs. + Rel := Sect.First_Reloc; + while Rel /= null loop + N_Rel := Rel.Sect_Next; + Old_Rel := Rel; + Free (Rel); + Rel := N_Rel; + end loop; + Sect.First_Reloc := null; + Sect.Last_Reloc := null; + + Sect := Sect.Next; + end loop; + end Finish; +end Binary_File; |