(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Disassembler for executable and .cmo object files *)

open Obj
open Printf
open Config
open Asttypes
open Lambda
open Emitcode
open Opcodes
open Opnames

(* Read signed and unsigned integers *)

let inputu ic =
  let b1 = input_byte ic in
  let b2 = input_byte ic in
  let b3 = input_byte ic in
  let b4 = input_byte ic in
  (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1

let inputs ic =
  let b1 = input_byte ic in
  let b2 = input_byte ic in
  let b3 = input_byte ic in
  let b4 = input_byte ic in
  let b4' = if b4 >= 128 then b4-256 else b4 in
  (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1

(* Global variables *)

type global_table_entry =
    Empty
  | Global of Ident.t
  | Constant of Obj.t

let start = ref 0                             (* Position of beg. of code *)
let reloc = ref ([] : (reloc_info * int) list)  (* Relocation table *)
let globals = ref ([||] : global_table_entry array) (* Global List.map *)
let objfile = ref false               (* true if dumping a .zo *)

(* Print a structured constant *)

let rec print_struct_const = function
    Const_base(Const_int i) ->
      printf "%d" i
  | Const_base(Const_float f) ->
      printf "%s" f
  | Const_base(Const_string s) ->
      printf "\"%s\"" (String.escaped s)
  | Const_base(Const_char c) ->
      printf "'%s'" (Char.escaped c)
  | Const_pointer n ->
      printf "%da" n
  | Const_block(tag, args) ->
      printf "<%d>" tag;
      begin match args with
        [] -> ()
      | [a1] ->
          printf "("; print_struct_const a1; printf ")"
      | a1::al ->
          printf "("; print_struct_const a1;
          List.iter (fun a -> printf ", "; print_struct_const a) al;
          printf ")"
      end
  | Const_float_array a ->
      printf "floatarray"

(* Print an obj *)

let rec print_obj x =
  if Obj.is_block x then begin
    match Obj.tag x with
      252 ->                            (* string *)
        printf "\"%s\"" (String.escaped (Obj.magic x : string))
    | 253 ->                            (* float *)
        printf "%.12g" (Obj.magic x : float)
    | _ ->
        printf "<%d>" (Obj.tag x);
        begin match Obj.size x with
          0 -> ()
        | 1 ->
            printf "("; print_obj (Obj.field x 0); printf ")"
        | n ->
            printf "("; print_obj (Obj.field x 0);
            for i = 1 to n - 1 do
              printf ", "; print_obj (Obj.field x i)
            done;
            printf ")"
        end
  end else
    printf "%d" (Obj.magic x : int)

(* Current position in input file *)

let currpos ic =
  pos_in ic - !start

(* Access in the relocation table *)

let rec rassoc key = function
    [] -> raise Not_found
  | (a,b) :: l -> if b = key then a else rassoc key l

let find_reloc ic =
  rassoc (pos_in ic - !start) !reloc

(* Symbolic printing of global names, etc *)

let print_getglobal_name ic =
  if !objfile then begin
    begin try
      match find_reloc ic with
          Reloc_getglobal id -> print_string (Ident.name id)
        | Reloc_literal sc -> print_struct_const sc
        | _ -> print_string "<wrong reloc>"
    with Not_found ->
      print_string "<no reloc>"
    end;
    inputu ic; ()
  end
  else begin
    let n = inputu ic in
    if n >= Array.length !globals
    then print_string "<global table overflow>"
    else match !globals.(n) with
           Global id -> print_string(Ident.name id)
         | Constant obj -> print_obj obj
         | _ -> print_string "???"
  end

let print_setglobal_name ic =
  if !objfile then begin
    begin try
      match find_reloc ic with
        Reloc_setglobal id -> print_string (Ident.name id)
      | _ -> print_string "<wrong reloc>"
    with Not_found ->
      print_string "<no reloc>"
    end;
    inputu ic; ()
  end
  else begin
    let n = inputu ic in
    if n >= Array.length !globals
    then print_string "<global table overflow>"
    else match !globals.(n) with
           Global id -> print_string(Ident.name id)
         | _ -> print_string "???"
  end

let print_primitive ic =
  if !objfile then begin
    begin try
      match find_reloc ic with
        Reloc_primitive s -> print_string s
      | _ -> print_string "<wrong reloc>"
    with Not_found ->
      print_string "<no reloc>"
    end;
    inputu ic; ()
  end
  else begin
    let n = inputu ic in
    if n >= Array.length Runtimedef.builtin_primitives
    then print_string(string_of_int n)
    else print_string(Runtimedef.builtin_primitives.(n))
  end

(* Disassemble one instruction *)

let currpc ic =
  currpos ic / 4

let print_instr ic =
  print_int (currpc ic); print_string "\t";
  let op = inputu ic in
  print_string
    (if op >= Array.length names_of_instructions then "???"
     else names_of_instructions.(op));
  print_string " ";
  (* One unsigned int *)
  if op == opATOM or op == opPUSHATOM 
  or op == opMAKEBLOCK1 or op == opMAKEBLOCK2 or op == opMAKEBLOCK3
  or op == opACC or op == opPUSHACC or op == opPOP or op == opASSIGN
  or op == opENVACC or op == opPUSHENVACC
  or op == opAPPLY or op == opAPPTERM1 or op == opAPPTERM2 or op == opAPPTERM3
  or op == opRETURN or op == opGRAB or op == opGETFIELD or op == opSETFIELD
  or op == opDUMMY then
    (print_int (inputu ic))
  (* One signed int *)
  else if op == opCONSTINT or op == opPUSHCONSTINT
  or op == opOFFSETINT or op == opOFFSETREF then
    (print_int (inputs ic))
  (* Two unsigned constants *)
  else if op == opAPPTERM or op == opMAKEBLOCK then
    (print_int (inputu ic); print_string ", "; print_int(inputu ic))
  (* One displacement *)
  else if op == opPUSH_RETADDR or op == opBRANCH or op == opBRANCHIF
  or op == opBRANCHIFNOT or op == opPUSHTRAP then
    (let p = currpc ic in print_int (p + inputs ic))
  (* One size, one displacement *)
  else if op == opCLOSURE or op == opCLOSUREREC then
    (print_int (inputu ic); print_string ", ";
     let p = currpc ic in print_int (p + inputs ic))
  (* getglobal *)
  else if op == opGETGLOBAL or op == opPUSHGETGLOBAL then
    (print_getglobal_name ic)
  (* getglobal + unsigned *)
  else if op == opGETGLOBALFIELD or op == opPUSHGETGLOBALFIELD then
    (print_getglobal_name ic; print_string ", "; print_int (inputu ic))
  (* setglobal *)
  else if op == opSETGLOBAL then
    (print_setglobal_name ic)
  (* primitive *)
  else if op == opC_CALL1 or op == opC_CALL2
       or op == opC_CALL3 or op == opC_CALL4
       or op == opC_CALL5 then
    (print_primitive ic)
  (* unsigned + primitive *)
  else if op == opC_CALLN then
    (print_int(inputu ic); print_string ", "; print_primitive ic)
  (* switch *)
  else if op == opSWITCH then
    (let n = inputu ic in
     let orig = currpc ic in
     for i = 0 to (n land 0xFFFF) - 1 do
       print_string "\n\tint "; print_int i; print_string " -> ";
       print_int(orig + inputs ic)
     done;
     for i = 0 to (n lsr 16) - 1 do
       print_string "\n\ttag "; print_int i; print_string " -> ";
       print_int(orig + inputs ic)
     done)
  (* default *)
  else ();
  print_string "\n"

(* Disassemble a block of code *)

let print_code ic len =
  start := pos_in ic;
  let stop = !start + len in
  while pos_in ic < stop do print_instr ic done

(* Dump relocation info *)

let print_reloc (info, pos) =
  printf "\t%d\t(%d)\t" pos (pos/4);
  match info with
    Reloc_literal sc -> print_struct_const sc; printf "\n"
  | Reloc_getglobal id -> printf "require\t%s\n" (Ident.name id)
  | Reloc_setglobal id -> printf "provide\t%s\n" (Ident.name id)
  | Reloc_primitive s -> printf "prim\t%s\n" s

(* Print a .zo file *)

let dump_obj filename ic =
  let buffer = String.create (String.length cmo_magic_number) in
  really_input ic buffer 0 (String.length cmo_magic_number);
  if buffer <> cmo_magic_number then begin
    prerr_endline "Not an object file"; exit 2
  end;
  let cu_pos = input_binary_int ic in
  seek_in ic cu_pos;
  let cu = (input_value ic : compilation_unit) in
  reloc := cu.cu_reloc;
  seek_in ic cu.cu_pos;
  print_code ic cu.cu_codesize

(* Print an executable file *)

exception Not_exec

let dump_exe ic =
  seek_in ic (in_channel_length ic - 12);
  if (let buff = String.create 12 in input ic buff 0 12; buff)
     <> exec_magic_number
  then raise Not_exec;
  let trailer_pos = in_channel_length ic - 28 in
  seek_in ic trailer_pos;
  let code_size = input_binary_int ic in
  let data_size = input_binary_int ic in
  let symbol_size = input_binary_int ic in
  let debug_size = input_binary_int ic in
  seek_in ic (trailer_pos - debug_size - symbol_size - data_size);
  let init_data = (input_value ic : Obj.t array) in
  globals := Array.create (Array.length init_data) Empty;
  for i = 0 to Array.length init_data - 1 do
    !globals.(i) <- Constant (init_data.(i))
  done;
  if symbol_size > 0 then begin
    let (_, sym_table) = (input_value ic : int * (Ident.t, int) Tbl.t) in
    Tbl.iter (fun id pos -> !globals.(pos) <- Global id) sym_table
  end;
  seek_in ic
    (trailer_pos - debug_size - symbol_size - data_size - code_size);
  print_code ic code_size

let main() =
  for i = 1 to Array.length Sys.argv - 1 do
    let ic = open_in_bin Sys.argv.(i) in
    begin try
      objfile := false; dump_exe ic
    with Not_exec ->
      objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic
    end;
    close_in ic
  done;
  exit 0

let _ = Printexc.catch main (); exit 0