(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)


open Format
open Asttypes
open Clambda

module V = Backend_var
module VP = Backend_var.With_provenance

let mutable_flag = function
  | Mutable-> "[mut]"
  | Immutable -> ""

let value_kind =
  let open Lambda in
  function
  | Pgenval -> ""
  | Pintval -> ":int"
  | Pfloatval -> ":float"
  | Pboxedintval Pnativeint -> ":nativeint"
  | Pboxedintval Pint32 -> ":int32"
  | Pboxedintval Pint64 -> ":int64"

let rec structured_constant ppf = function
  | Uconst_float x -> fprintf ppf "%F" x
  | Uconst_int32 x -> fprintf ppf "%ldl" x
  | Uconst_int64 x -> fprintf ppf "%LdL" x
  | Uconst_nativeint x -> fprintf ppf "%ndn" x
  | Uconst_block (tag, l) ->
      fprintf ppf "block(%i" tag;
      List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
      fprintf ppf ")"
  | Uconst_float_array [] ->
      fprintf ppf "floatarray()"
  | Uconst_float_array (f1 :: fl) ->
      fprintf ppf "floatarray(%F" f1;
      List.iter (fun f -> fprintf ppf ",%F" f) fl;
      fprintf ppf ")"
  | Uconst_string s -> fprintf ppf "%S" s
  | Uconst_closure(clos, sym, fv) ->
      let funs ppf =
        List.iter (fprintf ppf "@ %a" one_fun) in
      let sconsts ppf scl =
        List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
      fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv

and one_fun ppf f =
  let idents ppf =
    List.iter
      (fun (x, k) ->
         fprintf ppf "@ %a%a"
           VP.print x
           Printlambda.value_kind k
      )
  in
  fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
    f.label (value_kind f.return) f.arity idents f.params lam f.body

and phantom_defining_expr ppf = function
  | Uphantom_const const -> uconstant ppf const
  | Uphantom_var var -> Ident.print ppf var
  | Uphantom_offset_var { var; offset_in_words; } ->
    Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words
  | Uphantom_read_field { var; field; } ->
    Format.fprintf ppf "%a[%d]" Backend_var.print var field
  | Uphantom_read_symbol_field { sym; field; } ->
    Format.fprintf ppf "%s[%d]" sym field
  | Uphantom_block { tag; fields; } ->
    Format.fprintf ppf "[%d: " tag;
    List.iter (fun field ->
        Format.fprintf ppf "%a; " Backend_var.print field)
      fields;
    Format.fprintf ppf "]"

and phantom_defining_expr_opt ppf = function
  | None -> Format.fprintf ppf "DEAD"
  | Some expr -> phantom_defining_expr ppf expr

and uconstant ppf = function
  | Uconst_ref (s, Some c) ->
      fprintf ppf "%S=%a" s structured_constant c
  | Uconst_ref (s, None) -> fprintf ppf "%S"s
  | Uconst_int i -> fprintf ppf "%i" i

and lam ppf = function
  | Uvar id ->
      V.print ppf id
  | Uconst c -> uconstant ppf c
  | Udirect_apply(f, largs, _) ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
  | Ugeneric_apply(lfun, largs, _) ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
  | Uclosure(clos, fv) ->
      let funs ppf =
        List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in
      let lams ppf =
        List.iter (fprintf ppf "@ %a" lam) in
      fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
  | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
  | Ulet(mut, kind, id, arg, body) ->
      let rec letbody ul = match ul with
        | Ulet(mut, kind, id, arg, body) ->
            fprintf ppf "@ @[<2>%a%s%s@ %a@]"
              VP.print id
              (mutable_flag mut) (value_kind kind) lam arg;
            letbody body
        | _ -> ul in
      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%s%s@ %a@]"
        VP.print id (mutable_flag mut)
          (value_kind kind) lam arg;
      let expr = letbody body in
      fprintf ppf ")@]@ %a)@]" lam expr
  | Uphantom_let (id, defining_expr, body) ->
      let rec letbody ul = match ul with
        | Uphantom_let (id, defining_expr, body) ->
            fprintf ppf "@ @[<2>%a@ %a@]"
              Backend_var.With_provenance.print id
              phantom_defining_expr_opt defining_expr;
            letbody body
        | _ -> ul in
      fprintf ppf "@[<2>(phantom_let@ @[<hv 1>(@[<2>%a@ %a@]"
        Backend_var.With_provenance.print id
        phantom_defining_expr_opt defining_expr;
      let expr = letbody body in
      fprintf ppf ")@]@ %a)@]" lam expr
  | Uletrec(id_arg_list, body) ->
      let bindings ppf id_arg_list =
        let spc = ref false in
        List.iter
          (fun (id, l) ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<2>%a@ %a@]"
              VP.print id
              lam l)
          id_arg_list in
      fprintf ppf
        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
  | Uprim(prim, largs, _) ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(%a%a)@]"
        Printclambda_primitives.primitive prim lams largs
  | Uswitch(larg, sw, _dbg) ->
      let print_case tag index i ppf =
        for j = 0 to Array.length index - 1 do
          if index.(j) = i then fprintf ppf "case %s %i:" tag j
        done in
      let print_cases tag index cases ppf =
        for i = 0 to Array.length cases - 1 do
          fprintf ppf "@ @[<2>%t@ %a@]"
            (print_case tag index i) sequence cases.(i)
        done in
      let switch ppf sw =
        print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ;
        print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf  in
      fprintf ppf
       "@[<v 0>@[<2>(switch@ %a@ @]%a)@]"
        lam larg switch sw
  | Ustringswitch(larg,sw,d) ->
      let switch ppf sw =
        let spc = ref false in
        List.iter
          (fun (s,l) ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>case \"%s\":@ %a@]"
              (String.escaped s) lam l)
          sw ;
        begin match d with
        | Some d ->
            if !spc then fprintf ppf "@ " else spc := true;
            fprintf ppf "@[<hv 1>default:@ %a@]" lam d
        | None -> ()
        end in
      fprintf ppf
        "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw
  | Ustaticfail (i, ls)  ->
      let lams ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
  | Ucatch(i, vars, lbody, lhandler) ->
      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
        lam lbody i
        (fun ppf vars ->
           List.iter
             (fun (x, k) ->
                fprintf ppf " %a%a"
                 VP.print x
                 Printlambda.value_kind k
             )
             vars
        )
        vars
        lam lhandler
  | Utrywith(lbody, param, lhandler) ->
      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
        lam lbody VP.print param lam lhandler
  | Uifthenelse(lcond, lif, lelse) ->
      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
  | Usequence(l1, l2) ->
      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
  | Uwhile(lcond, lbody) ->
      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
  | Ufor(param, lo, hi, dir, body) ->
      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
       VP.print param lam lo
       (match dir with Upto -> "to" | Downto -> "downto")
       lam hi lam body
  | Uassign(id, expr) ->
      fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr
  | Usend (k, met, obj, largs, _) ->
      let args ppf largs =
        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
      let kind =
        if k = Lambda.Self then "self"
        else if k = Lambda.Cached then "cache"
        else "" in
      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
  | Uunreachable ->
      fprintf ppf "unreachable"

and sequence ppf ulam = match ulam with
  | Usequence(l1, l2) ->
      fprintf ppf "%a@ %a" sequence l1 sequence l2
  | _ -> lam ppf ulam

let clambda ppf ulam =
  fprintf ppf "%a@." lam ulam


let rec approx ppf = function
    Value_closure(fundesc, a) ->
      Format.fprintf ppf "@[<2>function %s@ arity %i"
        fundesc.fun_label fundesc.fun_arity;
      if fundesc.fun_closed then begin
        Format.fprintf ppf "@ (closed)"
      end;
      if fundesc.fun_inline <> None then begin
        Format.fprintf ppf "@ (inline)"
      end;
      Format.fprintf ppf "@ -> @ %a@]" approx a
  | Value_tuple a ->
      let tuple ppf a =
        for i = 0 to Array.length a - 1 do
          if i > 0 then Format.fprintf ppf ";@ ";
          Format.fprintf ppf "%i: %a" i approx a.(i)
        done in
      Format.fprintf ppf "@[<hov 1>(%a)@]" tuple a
  | Value_unknown ->
      Format.fprintf ppf "_"
  | Value_const c ->
      fprintf ppf "@[const(%a)@]" uconstant c
  | Value_global_field (s, i) ->
      fprintf ppf "@[global(%s,%i)@]" s i