open Cil
open Ktciltools
open Kttools
module E = Errormsg
module L = List

type migrate_policy =
  | AutoMigrate
  | NoMigrate

(* Command-line options *)
let defaultMigratePolicy = ref AutoMigrate

let get_hoist_info (var:varinfo) =
List.fold_left 
     ( fun prev attr - > 
        match attr with 
          | Attr ( " hoisted_static " , [ AStr f ; AStr v ] ) - > Some ( f , v ) 
          | _ - > prev ) 
     None
    (fun prev attr -> 
       match attr with
         | Attr ("hoisted_static", [AStr f; AStr v]) -> Some (f, v)
         | _ -> prev) 
    None*) var.vattr

let is_writable (var:varinfo) oc =
  (not (hasAttribute "const" (typeAttrs var.vtype))) &&
    match var.vtype with
      | TFun _ -> (* write out some placeholder function prototypes*) 
                 (output_string oc ("extern  void "^var.vname^"(void);\n")); false
      | TArray (t', _, _) -> 
        (not (hasAttribute "const" (typeAttrs t')))         
      | _ -> true

let get_migrate_policy (var:varinfo) oc =
  if not (is_writable var oc) then
    NoMigrate
  else
    let policy_opt = List.fold_left
      (fun prev attr -> 
        (* TODO: issue errors in the case of contradictory annotations *)
        match attr with
          | Attr ("e_auto_migrate", []) -> Some AutoMigrate
          | Attr ("e_manual_migrate", []) -> Some NoMigrate
          | _ -> prev)
      None
      var.vattr
    in
    option_get_safe policy_opt !defaultMigratePolicy

let do_register_globals (f:file) : unit =
  let process_global ((statics, nonstatics) as prev) g =
    (* Add if not extern or inline *)
    let add_conditionally v =
      if v.vinline then
        prev
      else
        match v.vstorage with
          | NoStorage when (not (L.mem v nonstatics)) -> ([], v :: nonstatics)
| Static when ( not ( L.mem v statics ) ) - > ( v::statics , nonstatics )
          | Extern | _ -> prev
    in
    match g with
      | GVar (v, _, _) -> add_conditionally v
      | GFun (f, _) -> add_conditionally f.svar
      | _ -> prev
  in
  let namespace = lookupNamespace f.globals in
  let (statics, nonstatics) = foldGlobals f process_global ([], []) in
  let file_func_name = "__kitsune_register_symbols" in
  Format.print_string ("Generating static extraction function: " ^ file_func_name ^ "\n");
  let extract_func = emptyFunction file_func_name in
  let lookup_maps = buildLookupMaps f in
  let addr_put = try lookupFunction lookup_maps "kitsune_register_var" 
  with Not_found ->  (makeVarinfo false "kitsune_register_var" charConstPtrType) in
  let migrate_policy_to_carg = function NoMigrate -> zero | AutoMigrate -> one in    
  let extern_outs = open_out_gen [Open_creat; Open_text; Open_append] 0o640 "externfuns.txt" in
let register_static v = 
     let migrate_arg = migrate_policy_to_carg ( get_migrate_policy v extern_outs ) in 
     Format.print_string ( " - Static Identifier : " ^ v.vname ^ " \n " ) ; 
     let  = 
       match get_hoist_info v with 
         | None - > [ mkString v.vname ; zero ; mkString v.vdecl.file ; namespace ] 
         | Some ( func_name ,  ) - > [ mkString  ; mkString func_name ; mkString v.vdecl.file ; namespace ] 
     in 
     mkStmtOneInstr ( Call ( None ,  ( var addr_put ) ,  @ [ (  ( var v ) ) ; SizeOfE ( Lval ( var v ) ) ; migrate_arg ] , locUnknown ) ) 
   in
    let migrate_arg = migrate_policy_to_carg (get_migrate_policy v extern_outs) in
    Format.print_string (" - Static Identifier: " ^ v.vname ^ "\n");
    let name_parts =
      match get_hoist_info v with
        | None -> [mkString v.vname; zero; mkString v.vdecl.file; namespace]
        | Some (func_name, var_name) -> [mkString var_name; mkString func_name; mkString v.vdecl.file; namespace]
    in
    mkStmtOneInstr (Call (None, Lval (var addr_put), name_parts @ [(AddrOf (var v)); SizeOfE (Lval (var v)); migrate_arg], locUnknown))
  in*)
  let register_nonstatic v =
    let migrate_arg = migrate_policy_to_carg (get_migrate_policy v extern_outs) in
    Format.print_string (" - Nonstatic Identifier: " ^ v.vname ^ "\n");
    let name_parts = [mkString v.vname; zero; zero; namespace] in
    mkStmtOneInstr (Call (None, Lval (var addr_put), name_parts @ [(AddrOf (var v)); SizeOfE (Lval (var v)); migrate_arg], locUnknown))
  in
  extract_func.sbody.bstmts <- 
( L.map register_static statics ) @
    (L.map register_nonstatic nonstatics) @ 
    extract_func.sbody.bstmts;
    let oc = open_out_gen [Open_creat; Open_text; Open_append] 0o640 "register_vars.txt" in
    List.map (fun s -> dumpStmt defaultCilPrinter oc 0 s; output_string oc "\n") extract_func.sbody.bstmts;
    close_out oc;

  extract_func.svar.vstorage <- Static;
  close_out extern_outs;
  (*extract_func.svar.vattr <- addAttribute (Attr ("constructor", [])) extract_func.svar.vattr;*)
  f.globals <- f.globals @ [GFun (extract_func, locUnknown)];;

let run = ref false

let feature : featureDescr = {
  fd_name = "globalreg";
  fd_enabled = ref true;
  fd_description = "instruments program to register the addresses of globals with the kitsune runtime";
  fd_extraopt = ["--noautomigrate", Arg.Unit (fun () -> defaultMigratePolicy := NoMigrate), "Disable migrating global and local-static variables"];
  fd_doit = (fun (f:file) -> if not !run then do_register_globals f; run := true);
  fd_post_check = false;
}

let feature_compat : featureDescr = {
  fd_name = "globalreg";
  fd_enabled = ref false;
  fd_description = "instruments program to register the addresses of globals with the kitsune runtime";
  fd_extraopt = ["--automigrate", Arg.Unit (fun () -> defaultMigratePolicy := AutoMigrate), "Enable migrating global and local-static variables"];
  fd_doit = (fun (f:file) -> if not !run then do_register_globals f; run := true);
  fd_post_check = false;
}



 Command-line options 
 write out some placeholder function prototypes
 TODO: issue errors in the case of contradictory annotations 
 Add if not extern or inline 
extract_func.svar.vattr <- addAttribute (Attr ("constructor", [])) extract_func.svar.vattr;
open Cil
open Ktciltools
open Kttools
module E = Errormsg
module L = List

type migrate_policy =
  | AutoMigrate
  | NoMigrate

let defaultMigratePolicy = ref AutoMigrate

let get_hoist_info (var:varinfo) =
List.fold_left 
     ( fun prev attr - > 
        match attr with 
          | Attr ( " hoisted_static " , [ AStr f ; AStr v ] ) - > Some ( f , v ) 
          | _ - > prev ) 
     None
    (fun prev attr -> 
       match attr with
         | Attr ("hoisted_static", [AStr f; AStr v]) -> Some (f, v)
         | _ -> prev) 
    None*) var.vattr

let is_writable (var:varinfo) oc =
  (not (hasAttribute "const" (typeAttrs var.vtype))) &&
    match var.vtype with
                 (output_string oc ("extern  void "^var.vname^"(void);\n")); false
      | TArray (t', _, _) -> 
        (not (hasAttribute "const" (typeAttrs t')))         
      | _ -> true

let get_migrate_policy (var:varinfo) oc =
  if not (is_writable var oc) then
    NoMigrate
  else
    let policy_opt = List.fold_left
      (fun prev attr -> 
        match attr with
          | Attr ("e_auto_migrate", []) -> Some AutoMigrate
          | Attr ("e_manual_migrate", []) -> Some NoMigrate
          | _ -> prev)
      None
      var.vattr
    in
    option_get_safe policy_opt !defaultMigratePolicy

let do_register_globals (f:file) : unit =
  let process_global ((statics, nonstatics) as prev) g =
    let add_conditionally v =
      if v.vinline then
        prev
      else
        match v.vstorage with
          | NoStorage when (not (L.mem v nonstatics)) -> ([], v :: nonstatics)
| Static when ( not ( L.mem v statics ) ) - > ( v::statics , nonstatics )
          | Extern | _ -> prev
    in
    match g with
      | GVar (v, _, _) -> add_conditionally v
      | GFun (f, _) -> add_conditionally f.svar
      | _ -> prev
  in
  let namespace = lookupNamespace f.globals in
  let (statics, nonstatics) = foldGlobals f process_global ([], []) in
  let file_func_name = "__kitsune_register_symbols" in
  Format.print_string ("Generating static extraction function: " ^ file_func_name ^ "\n");
  let extract_func = emptyFunction file_func_name in
  let lookup_maps = buildLookupMaps f in
  let addr_put = try lookupFunction lookup_maps "kitsune_register_var" 
  with Not_found ->  (makeVarinfo false "kitsune_register_var" charConstPtrType) in
  let migrate_policy_to_carg = function NoMigrate -> zero | AutoMigrate -> one in    
  let extern_outs = open_out_gen [Open_creat; Open_text; Open_append] 0o640 "externfuns.txt" in
let register_static v = 
     let migrate_arg = migrate_policy_to_carg ( get_migrate_policy v extern_outs ) in 
     Format.print_string ( " - Static Identifier : " ^ v.vname ^ " \n " ) ; 
     let  = 
       match get_hoist_info v with 
         | None - > [ mkString v.vname ; zero ; mkString v.vdecl.file ; namespace ] 
         | Some ( func_name ,  ) - > [ mkString  ; mkString func_name ; mkString v.vdecl.file ; namespace ] 
     in 
     mkStmtOneInstr ( Call ( None ,  ( var addr_put ) ,  @ [ (  ( var v ) ) ; SizeOfE ( Lval ( var v ) ) ; migrate_arg ] , locUnknown ) ) 
   in
    let migrate_arg = migrate_policy_to_carg (get_migrate_policy v extern_outs) in
    Format.print_string (" - Static Identifier: " ^ v.vname ^ "\n");
    let name_parts =
      match get_hoist_info v with
        | None -> [mkString v.vname; zero; mkString v.vdecl.file; namespace]
        | Some (func_name, var_name) -> [mkString var_name; mkString func_name; mkString v.vdecl.file; namespace]
    in
    mkStmtOneInstr (Call (None, Lval (var addr_put), name_parts @ [(AddrOf (var v)); SizeOfE (Lval (var v)); migrate_arg], locUnknown))
  in*)
  let register_nonstatic v =
    let migrate_arg = migrate_policy_to_carg (get_migrate_policy v extern_outs) in
    Format.print_string (" - Nonstatic Identifier: " ^ v.vname ^ "\n");
    let name_parts = [mkString v.vname; zero; zero; namespace] in
    mkStmtOneInstr (Call (None, Lval (var addr_put), name_parts @ [(AddrOf (var v)); SizeOfE (Lval (var v)); migrate_arg], locUnknown))
  in
  extract_func.sbody.bstmts <- 
( L.map register_static statics ) @
    (L.map register_nonstatic nonstatics) @ 
    extract_func.sbody.bstmts;
    let oc = open_out_gen [Open_creat; Open_text; Open_append] 0o640 "register_vars.txt" in
    List.map (fun s -> dumpStmt defaultCilPrinter oc 0 s; output_string oc "\n") extract_func.sbody.bstmts;
    close_out oc;

  extract_func.svar.vstorage <- Static;
  close_out extern_outs;
  f.globals <- f.globals @ [GFun (extract_func, locUnknown)];;

let run = ref false

let feature : featureDescr = {
  fd_name = "globalreg";
  fd_enabled = ref true;
  fd_description = "instruments program to register the addresses of globals with the kitsune runtime";
  fd_extraopt = ["--noautomigrate", Arg.Unit (fun () -> defaultMigratePolicy := NoMigrate), "Disable migrating global and local-static variables"];
  fd_doit = (fun (f:file) -> if not !run then do_register_globals f; run := true);
  fd_post_check = false;
}

let feature_compat : featureDescr = {
  fd_name = "globalreg";
  fd_enabled = ref false;
  fd_description = "instruments program to register the addresses of globals with the kitsune runtime";
  fd_extraopt = ["--automigrate", Arg.Unit (fun () -> defaultMigratePolicy := AutoMigrate), "Enable migrating global and local-static variables"];
  fd_doit = (fun (f:file) -> if not !run then do_register_globals f; run := true);
  fd_post_check = false;
}


