(**************************************************************************)
(*  The CDuce compiler                                                    *)
(*  Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team               *)
(*  Copyright CNRS,INRIA, 2003,2004 (see LICENSE for details)             *)
(**************************************************************************)

open Location
open Ident

type stub_ml
let stub_ml = ref (fun cu ty_env c_env -> None, [| |])


module C = Types.CompUnit

exception InconsistentCrc of C.t
exception Loop of C.t
exception InvalidObject of string
exception CannotOpen of string
exception NoImplementation of C.t

type t = {
  typing: Typer.t;
  compile: Compile.env;
  code: Lambda.code_item list;
  types: Types.t array;
  has_ext: bool;

  mutable digest: Digest.t option;
  vals: Value.t array;
  mutable exts: Value.t array;
  mutable depends: C.t list;
  mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];

  mutable stub : stub_ml option
}

let mk ((typing,compile,code),types,ext) =
  { typing = typing;
    compile = compile;
    code = code;
    types = types;
    has_ext = ext;
    digest = None;
    vals = Array.make (Compile.global_size compile) Value.Absent;
    exts = [| |];
    depends = [];
    status = `Unevaluated;
    stub = None
  }

let magic = "CDUCE:compunit:00005"

let obj_path = ref [ "" ]

let tbl = C.Tbl.create ()

let find id =
  try C.Tbl.find tbl id
  with Not_found -> assert false

let serialize s cu =
  Serialize.Put.magic s magic;
  Typer.serialize s cu.typing;
  Compile.serialize s cu.compile;
  Lambda.Put.codes s cu.code;
  Serialize.Put.array Types.serialize s cu.types;
  Serialize.Put.bool s cu.has_ext

let deserialize s =
  Serialize.Get.magic s magic;
  let typing = Typer.deserialize s in
  let compile = Compile.deserialize s in
  let code = Lambda.Get.codes s in
  let types = Serialize.Get.array Types.deserialize s in
  let ext = Serialize.Get.bool s in
  mk ((typing,compile,code),types,ext)

(*
let serialize_dep=
  Serialize.Put.list 
    (Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)

let deserialize_dep =
  Serialize.Get.list
    (Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
*)


let has_obj n =
  let base = Encodings.Utf8.to_string n ^ ".cdo" in
  List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path

let find_obj id = 
  let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in
  let p = 
    List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
  Filename.concat p base

let save name id out =
  protect_op "Save compilation unit";

  let cu = find id in

  C.enter id;
  let raw = Serialize.Put.run serialize cu in
  let depend = C.close_serialize () in
  C.leave ();

(*
  print_endline "Dependencies:";
  List.iter (fun x -> print_endline (object_filename x)) depend;
  flush stdout;
*)
  let depend = 
    try List.map 
      (fun id ->
	 match (C.Tbl.find tbl id).digest with
	   | Some d -> (C.value id, d)
	   | None -> assert false
      ) depend
    with Not_found -> assert false in

(*  let depend = Serialize.Put.run serialize_dep depend in *)
  let digest = Digest.string raw in
  let oc = open_out out in
  Marshal.to_channel oc (name,digest,depend,raw,cu.stub) [];
  close_out oc
  
  
let check_digest id exp digest =
  match digest with
    | Some x ->
	if exp <> x then 
	  raise (InconsistentCrc id)
    | None -> 
	assert false

let loop = C.Tbl.create ()
let check_loop id = 
  try 
    C.Tbl.find loop id;
    raise (Loop id)
  with Not_found -> 
    C.Tbl.add loop id ()

let depends = ref []
let during_compile = ref false

let show ppf id t v =
  match id with
    | Some id ->
	Format.fprintf ppf "@[val %a : @[%a@]@."
	Ident.print id
	Types.Print.print t 
    | None -> ()



let rec compile verbose name id src =
  check_loop id;
  protect_op "Compile external file";
  let ic = 
    if src = "" then (Location.push_source `Stream; stdin)
    else
      try Location.push_source (`File src); open_in src
      with Sys_error _ -> raise (CannotOpen src) in
  let input = Stream.of_channel ic in
  let p = 
    try Parser.prog input 
    with
    | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
    | Stdpp.Exc_located ((i,j), e) -> 
	raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
  in
  if src <> "" then close_in ic;
  during_compile := true;
  C.enter id;
  let show =
    if verbose 
    then Some (show Format.std_formatter)
    else None in
  let (ty_env,c_env,_) as cu =
    Compile.comp_unit 
      ?show
      Builtin.env
      (Compile.empty id)
      p
  in
  let stub,types = !stub_ml name ty_env c_env in
  let ext = Externals.has () in
  let cu = mk (cu,types,ext) in
  cu.stub <- stub;
  C.Tbl.add tbl id cu;
  C.leave ();
  during_compile := false;
  cu.depends <- !depends;
  depends := []

let rec load id =
  protect_op "Load compiled compilation unit";
  try 
    C.Tbl.find tbl id
  with Not_found ->
(*    Printf.eprintf "load %s: start\n" (object_filename id);
    flush stderr; *)

    let obj = 
      try find_obj id
      with Not_found -> raise (NoImplementation id) in
    let ic = 
      try open_in obj
      with Sys_error _ -> raise (CannotOpen obj) in

    let (name, dig, depend, raw, stub) = 
      try Marshal.from_channel ic
      with Failure _ | End_of_file -> raise (InvalidObject obj) in

    close_in ic;
(*    let depend = Serialize.Get.run deserialize_dep depend in *)
    check_loop id;
    if !during_compile then depends := id :: !depends;
    load_from_string id raw dig depend

and load_check id exp =
  let cu = load id in
  check_digest id exp cu.digest

and load_from_string id raw dig depend =
  List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
  C.enter id;
  let cu = Serialize.Get.run deserialize raw in
  C.leave ();
  cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
  C.Tbl.add tbl id cu;
  Typer.register_types id cu.typing;
  cu.digest <- Some dig;
  cu

let load_from_string id raw dig depend =
  if C.Tbl.mem tbl id then failwith "Librarian: unit already loaded";
  load_from_string id raw dig depend

let register_unit id raw dig depend =
  let id = C.mk (Ident.U.mk id) in
  let depend = List.map (fun (x,y) -> (Ident.U.mk x,y)) depend in
  ignore (load_from_string id raw dig depend);
  id

let load_unit id dig =
  let id = C.mk (Ident.U.mk id) in
  ignore (load_check id dig);
  id

let rec run id =
  let cu = find id in
  match cu.status with
    | `Unevaluated -> 
	if cu.has_ext && (Array.length cu.exts = 0) then
	  failwith
	    ("Librarian.run. This module needs externals:" ^ 
	     (U.to_string (C.value id)));
	List.iter run cu.depends;
	cu.status <- `Evaluating;
	Eval.code_items cu.code;
	cu.status <- `Evaluated
(*
	Compile.dump Format.std_formatter cu.compile;
	Array.iter (fun v ->
		      Format.fprintf Format.std_formatter "%a@."
		      Value.print v) vals;
*)
    | `Evaluating -> 
(*
	failwith 
	("Librarian.run. Already running:" ^ (U.to_string (C.value id)))
*)
	()
    | `Evaluated -> ()
  
let import id = ignore (load id)

let import_check id chk = ignore (load_check id chk)

let import_and_run id = import id; run id

let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
let static_externals = Hashtbl.create 17
let register_static_external n v = 
  Hashtbl.add static_externals n v

let get_builtins () =
  List.sort Pervasives.compare 
    (Hashtbl.fold (fun n _ accu  -> n::accu) static_externals [])

let () =
  Typer.from_comp_unit := (fun cu -> (load cu).typing);
  Typer.has_comp_unit := has_obj;
  Typer.has_static_external :=  Hashtbl.mem static_externals;
  Compile.from_comp_unit := (fun cu -> (load cu).compile);
  Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
  Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
  Eval.get_external := (fun cu i -> (load cu).exts.(i));
  Eval.get_builtin := Hashtbl.find static_externals
    

let set_externals cu a = (load cu).exts <- a

let registered_types cu = (load cu).types

