open Semant;;
open Common;;

let log cx = Session.log "alias"
  cx.ctxt_sess.Session.sess_log_alias
  cx.ctxt_sess.Session.sess_log_out
;;

let alias_analysis_visitor
    (cx:ctxt)
    (inner:Walk.visitor)
    : Walk.visitor =
  let curr_stmt = Stack.create () in

  let alias_slot (slot_id:node_id) : unit =
    begin
      log cx "noting slot #%d as aliased" (int_of_node slot_id);
      Hashtbl.replace cx.ctxt_slot_aliased slot_id ()
    end
  in

  let alias lval =
    let lv_id = lval_base_id lval in
    let referent = Hashtbl.find cx.ctxt_lval_to_referent lv_id in
      if (referent_is_slot cx referent)
      then alias_slot referent
  in

  let alias_atom at =
    match at with
        Ast.ATOM_lval lv -> alias lv
      | _ -> err None "aliasing literal"
  in

  let alias_call_args dst callee args =
    alias dst;
    let callee_ty = lval_ty cx callee in
      match callee_ty with
          Ast.TY_fn (tsig,_) ->
            Array.iteri
              begin
                fun i slot ->
                  match slot.Ast.slot_mode with
                      Ast.MODE_alias _ ->
                        alias_atom args.(i)
                    | _ -> ()
              end
              tsig.Ast.sig_input_slots
        | _ -> ()
  in

  let visit_stmt_pre s =
    Stack.push s.id curr_stmt;
    begin
      try
        match s.node with
            (* FIXME (issue #26): actually all these *existing* cases
             * can probably go now that we're using Trans.aliasing to
             * form short-term spill-based aliases. Only aliases that
             * survive 'into' a sub-block (those formed during iteration)
             * need to be handled in this module.  *)
            Ast.STMT_call (dst, callee, args)
          | Ast.STMT_spawn (dst, _, callee, args)
            -> alias_call_args dst callee args

          | Ast.STMT_send (_, src) -> alias src
          | Ast.STMT_recv (dst, _) -> alias dst
          | Ast.STMT_init_port (dst) -> alias dst
          | Ast.STMT_init_chan (dst, _) -> alias dst
          | Ast.STMT_init_vec (dst, _) -> alias dst
          | Ast.STMT_init_str (dst, _) -> alias dst
          | Ast.STMT_for_each sfe ->
              let (slot, _) = sfe.Ast.for_each_slot in
                alias_slot slot.id
          | _ -> () (* FIXME (issue #29): plenty more to handle here. *)
      with
          Semant_err (None, msg) ->
            raise (Semant_err ((Some s.id), msg))
    end;
    inner.Walk.visit_stmt_pre s
  in
  let visit_stmt_post s =
    inner.Walk.visit_stmt_post s;
    ignore (Stack.pop curr_stmt);
  in

  let visit_lval_pre lv =
    let slot_id = lval_to_referent cx (lval_base_id lv) in
      if (not (Stack.is_empty curr_stmt)) && (referent_is_slot cx slot_id)
      then
        begin
          let slot_depth = get_slot_depth cx slot_id in
          let stmt_depth = get_stmt_depth cx (Stack.top curr_stmt) in
            if slot_depth <> stmt_depth
            then
              begin
                let _ = assert (slot_depth < stmt_depth) in
                  alias_slot slot_id
              end
        end
  in

    { inner with
        Walk.visit_stmt_pre = visit_stmt_pre;
        Walk.visit_stmt_post = visit_stmt_post;
        Walk.visit_lval_pre = visit_lval_pre
    }
;;

let process_crate
    (cx:ctxt)
    (crate:Ast.crate)
    : unit =
  let path = Stack.create () in
  let passes =
    [|
      (alias_analysis_visitor cx
         Walk.empty_visitor);
    |]
  in
    run_passes cx "alias" path passes (log cx "%s") crate
;;

(*
 * Local Variables:
 * fill-column: 78;
 * indent-tabs-mode: nil
 * buffer-file-coding-system: utf-8-unix
 * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
 * End:
 *)