path: root/src/boot/llvm/lltrans.ml

(*
 * LLVM translator.
 *)

open Common;;
open Transutil;;

let log cx = Session.log "trans"
  cx.Semant.ctxt_sess.Session.sess_log_trans
  cx.Semant.ctxt_sess.Session.sess_log_out
;;

let trans_crate
    (sem_cx:Semant.ctxt)
    (llctx:Llvm.llcontext)
    (sess:Session.sess)
    (crate:Ast.crate)
    : Llvm.llmodule =

  let iflog thunk =
    if sess.Session.sess_log_trans
    then thunk ()
    else ()
  in

  (* Helpers for adding metadata. *)
  let (dbg_mdkind:int) = Llvm.mdkind_id llctx "dbg" in
  let set_dbg_metadata (inst:Llvm.llvalue) (md:Llvm.llvalue) : unit =
    Llvm.set_metadata inst dbg_mdkind md
  in
  let md_str (s:string) : Llvm.llvalue = Llvm.mdstring llctx s in
  let md_node (vals:Llvm.llvalue array) : Llvm.llvalue =
    Llvm.mdnode llctx vals
  in
  let const_i32 (i:int) : Llvm.llvalue =
    Llvm.const_int (Llvm.i32_type llctx) i
  in
  let const_i1 (i:int) : Llvm.llvalue =
    Llvm.const_int (Llvm.i1_type llctx) i
  in
  let llvm_debug_version : int = 0x8 lsl 16 in
  let const_dw_tag (tag:Dwarf.dw_tag) : Llvm.llvalue =
    const_i32 (llvm_debug_version lor (Dwarf.dw_tag_to_int tag))
  in

  (* Translation of our node_ids into LLVM identifiers, which are strings. *)
  let next_anon_llid = ref 0 in
  let num_llid num klass = Printf.sprintf "%s%d" klass num in
  let anon_llid klass =
    let llid = num_llid !next_anon_llid klass in
    next_anon_llid := !next_anon_llid + 1;
    llid
  in
  let node_llid (node_id_opt:node_id option) : (string -> string) =
    match node_id_opt with
        None -> anon_llid
      | Some (Node num) -> num_llid num
  in

  (*
   * Returns a bogus value for use in stub code that hasn't been implemented
   * yet.
   *
   * TODO: On some joyous day, remove me.
   *)
  let bogus = Llvm.const_null (Llvm.i32_type llctx) in
  let bogus_ptr = Llvm.const_null (Llvm.pointer_type (Llvm.i32_type llctx)) in

  let llnilty = Llvm.array_type (Llvm.i1_type llctx) 0 in
  let llnil = Llvm.const_array (Llvm.i1_type llctx) [| |] in

  let ty_of_item = Hashtbl.find sem_cx.Semant.ctxt_all_item_types in
  let ty_of_slot n = Semant.slot_ty (Semant.get_slot sem_cx n) in

  let filename = Session.filename_of sess.Session.sess_in in
  let llmod = Llvm.create_module llctx filename in

  let (abi:Llabi.abi) = Llabi.declare_abi llctx llmod in
  let (crate_ptr:Llvm.llvalue) =
    Llvm.declare_global abi.Llabi.crate_ty "rust_crate" llmod
  in

  let (void_ty:Llvm.lltype) = Llvm.void_type llctx in
  let (word_ty:Llvm.lltype) = abi.Llabi.word_ty in
  let (wordptr_ty:Llvm.lltype) = Llvm.pointer_type word_ty in
  let (task_ty:Llvm.lltype) = abi.Llabi.task_ty in
  let (task_ptr_ty:Llvm.lltype) = Llvm.pointer_type task_ty in
  let fn_ty (out:Llvm.lltype) (args:Llvm.lltype array) : Llvm.lltype =
    Llvm.function_type out args
  in

  let imm (i:int64) : Llvm.llvalue =
    Llvm.const_int word_ty (Int64.to_int i)
  in

  let asm_glue = Llasm.get_glue llctx llmod abi sess in

  let llty_str llty =
    Llvm.string_of_lltype llty
  in

  let llval_str llv =
    let ts = llty_str (Llvm.type_of llv) in
      match Llvm.value_name llv with
          "" ->
            Printf.sprintf "<anon=%s>" ts
        | s -> Printf.sprintf "<%s=%s>" s ts
  in

  let llvals_str llvals =
    (String.concat ", "
       (Array.to_list
          (Array.map llval_str llvals)))
  in

  let build_call callee args rvid builder =
    iflog
      begin
        fun _ ->
          let name = Llvm.value_name callee in
          log sem_cx "build_call: %s(%s)" name (llvals_str args);
          log sem_cx "build_call: typeof(%s) = %s"
            name (llty_str (Llvm.type_of callee))
      end;
    Llvm.build_call callee args rvid builder
  in

  (* Upcall translation *)

  let extern_upcalls = Hashtbl.create 0 in
  let trans_upcall
      (llbuilder:Llvm.llbuilder)
      (lltask:Llvm.llvalue)
      (name:string)
      (lldest:Llvm.llvalue option)
      (llargs:Llvm.llvalue array) =
    let n = Array.length llargs in
    let llglue = asm_glue.Llasm.asm_upcall_glues.(n) in
    let llupcall = htab_search_or_add extern_upcalls name
      begin
        fun _ ->
          let args_ty =
            Array.append
              [| task_ptr_ty |]
              (Array.init n (fun i -> Llvm.type_of llargs.(i)))
          in
          let out_ty = match lldest with
              None -> void_ty
            | Some v -> Llvm.type_of v
          in
          let fty = fn_ty out_ty args_ty in
            (* 
             * NB: At this point it actually doesn't matter what type
             * we gave the upcall function, as we're just going to
             * pointercast it to a word and pass it to the upcall-glue
             * for now. But possibly in the future it might matter if
             * we develop a proper upcall calling convention.
             *)
            Llvm.declare_function name fty llmod
      end
    in
      (* Cast everything to plain words so we can hand off to the glue. *)
    let llupcall = Llvm.const_pointercast llupcall word_ty in
    let llargs =
      Array.map
        (fun arg ->
           Llvm.build_pointercast arg word_ty
             (anon_llid "arg") llbuilder)
        llargs
    in
    let llallargs = Array.append [| lltask; llupcall |] llargs in
    let llid = anon_llid "rv" in
    let llrv = build_call llglue llallargs llid llbuilder in
      Llvm.set_instruction_call_conv Llvm.CallConv.c llrv;
      match lldest with
          None -> ()
        | Some lldest ->
            let lldest =
              Llvm.build_pointercast lldest wordptr_ty "" llbuilder
            in
              ignore (Llvm.build_store llrv lldest llbuilder);
  in

  let upcall
      (llbuilder:Llvm.llbuilder)
      (lltask:Llvm.llvalue)
      (name:string)
      (lldest:Llvm.llvalue option)
      (llargs:Llvm.llvalue array)
      : unit =
    trans_upcall llbuilder lltask name lldest llargs
  in

  let trans_free
      (llbuilder:Llvm.llbuilder)
      (lltask:Llvm.llvalue)
      (src:Llvm.llvalue)
      : unit =
    upcall llbuilder lltask "upcall_free" None [| src; const_i32 0 |]
  in

  (*
   * let trans_malloc (llbuilder:Llvm.llbuilder)
   *                  (dst:Llvm.llvalue) (nbytes:int64) : unit =
   *   upcall llbuilder "upcall_malloc" (Some dst) [| imm nbytes |]
   * in
   *)

  (* Type translation *)

  let lltys = Hashtbl.create 0 in

  let trans_mach_ty (mty:ty_mach) : Llvm.lltype =
    let tycon =
      match mty with
          TY_u8 | TY_i8 -> Llvm.i8_type
        | TY_u16 | TY_i16 -> Llvm.i16_type
        | TY_u32 | TY_i32 -> Llvm.i32_type
        | TY_u64 | TY_i64 -> Llvm.i64_type
        | TY_f32 -> Llvm.float_type
        | TY_f64 -> Llvm.double_type
    in
      tycon llctx
  in


  let rec trans_ty_full (ty:Ast.ty) : Llvm.lltype =
    let p t = Llvm.pointer_type t in
    let s ts = Llvm.struct_type llctx ts in
    let opaque _ = Llvm.opaque_type llctx in
    let vec_body_ty _ =
      s [| word_ty; word_ty; word_ty; (opaque()) |]
    in
    let rc_opaque_ty =
      s [| word_ty; (opaque()) |]
    in
    match ty with
        Ast.TY_any -> opaque ()
      | Ast.TY_nil -> llnilty
      | Ast.TY_bool -> Llvm.i1_type llctx
      | Ast.TY_mach mty -> trans_mach_ty mty
      | Ast.TY_int -> word_ty
      | Ast.TY_uint -> word_ty
      | Ast.TY_char -> Llvm.i32_type llctx
      | Ast.TY_vec _
      | Ast.TY_str -> p (vec_body_ty())

      | Ast.TY_fn tfn ->
          let (tsig, _) = tfn in
          let lloutptr = p (trans_slot None tsig.Ast.sig_output_slot) in
          let lltaskty = p abi.Llabi.task_ty in
          let llins = Array.map (trans_slot None) tsig.Ast.sig_input_slots in
            fn_ty void_ty (Array.append [| lloutptr; lltaskty |] llins)

      | Ast.TY_tup slots ->
          s (Array.map trans_ty slots)

      | Ast.TY_rec entries ->
          s (Array.map (fun (_, e) -> trans_ty e) entries)

      | Ast.TY_constrained (ty', _) -> trans_ty ty'

      | Ast.TY_chan _ | Ast.TY_port _ | Ast.TY_task  ->
          p rc_opaque_ty

      | Ast.TY_exterior t ->
          (* FIXME: wrong, this needs to point to a refcounted cell. *)
          p (trans_ty t)

      | Ast.TY_mutable t ->
          (* FIXME: No idea if 'mutable' translates to LLVM-type. *)
          (trans_ty t)

      | Ast.TY_native _ ->
          word_ty

      | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_idx _
      | Ast.TY_obj _ | Ast.TY_type -> (opaque()) (* TODO *)

      | Ast.TY_param _ | Ast.TY_named _ ->
          bug () "unresolved type in lltrans"

  and trans_ty t =
    htab_search_or_add lltys t (fun _ -> trans_ty_full t)

  (* Translates the type of a slot into the corresponding LLVM type. If the
   * id_opt parameter is specified, then the type will be fetched from the
   * context. *)
  and trans_slot (id_opt:node_id option) (slot:Ast.slot) : Llvm.lltype =
    let ty =
      match id_opt with
          Some id -> ty_of_slot id
        | None -> Semant.slot_ty slot
    in
    let base_llty = trans_ty ty in
      match slot.Ast.slot_mode with
        | Ast.MODE_alias _ ->
            Llvm.pointer_type base_llty
        | Ast.MODE_interior _ -> base_llty
  in

  let get_element_ptr
      (llbuilder:Llvm.llbuilder)
      (ptr:Llvm.llvalue)
      (i:int)
      : Llvm.llvalue =
    (* 
     * GEP takes a first-index of zero. Because it must! And this is
     * sufficiently surprising that the GEP FAQ exists. And you must
     * read it.
     *)
    let deref_ptr = Llvm.const_int (Llvm.i32_type llctx) 0 in
    let idx = Llvm.const_int (Llvm.i32_type llctx) i in
      Llvm.build_gep ptr [| deref_ptr; idx |] (anon_llid "gep") llbuilder
  in

  let free_ty
      (llbuilder:Llvm.llbuilder)
      (lltask:Llvm.llvalue)
      (ty:Ast.ty)
      (ptr:Llvm.llvalue)
      : unit =
    match ty with
        Ast.TY_port _
      | Ast.TY_chan _
      | Ast.TY_task -> bug () "unimplemented ty in Lltrans.free_ty"
      | _ -> trans_free llbuilder lltask ptr
  in

  let rec iter_ty_parts_full
      (llbuilder:Llvm.llbuilder ref)
      (ty:Ast.ty)
      (dst_ptr:Llvm.llvalue)
      (src_ptr:Llvm.llvalue)
      (f:(Llvm.llvalue
          -> Llvm.llvalue
            -> Ast.ty
              -> (Ast.ty_iso option)
                -> unit))
      (curr_iso:Ast.ty_iso option)
      : unit =

    (* NB: must deref llbuilder at call-time; don't curry this. *)
    let gep p i = get_element_ptr (!llbuilder) p i in

    match ty with
        Ast.TY_rec entries ->
          iter_rec_parts gep dst_ptr src_ptr entries f curr_iso

      | Ast.TY_tup tys ->
          iter_tup_parts gep dst_ptr src_ptr tys f curr_iso

      | Ast.TY_tag _
      | Ast.TY_iso _
      | Ast.TY_fn _
      | Ast.TY_obj _ ->
          bug () "unimplemented ty in Lltrans.iter_ty_parts_full"

      | _ -> ()

  and iter_ty_parts
      (llbuilder:Llvm.llbuilder ref)
      (ty:Ast.ty)
      (ptr:Llvm.llvalue)
      (f:Llvm.llvalue -> Ast.ty -> (Ast.ty_iso option) -> unit)
      (curr_iso:Ast.ty_iso option)
      : unit =
    iter_ty_parts_full llbuilder ty ptr ptr
      (fun _ src_ptr slot curr_iso -> f src_ptr slot curr_iso)
      curr_iso

  and drop_ty
      (llbuilder:Llvm.llbuilder ref)
      (lltask:Llvm.llvalue)
      (ptr:Llvm.llvalue)
      (ty:Ast.ty)
      (curr_iso:Ast.ty_iso option)
      : unit =
    iter_ty_parts llbuilder ty ptr (drop_ty llbuilder lltask) curr_iso

  and drop_slot
      (llbuilder:Llvm.llbuilder ref)
      (lltask:Llvm.llvalue)
      (slot_ptr:Llvm.llvalue)
      (slot:Ast.slot)
      (curr_iso:Ast.ty_iso option)
      : unit =

    let llfn = Llvm.block_parent (Llvm.insertion_block (!llbuilder)) in
    let llty = trans_slot None slot in
    let ty = Semant.slot_ty slot in

    let new_block klass =
      let llblock = Llvm.append_block llctx (anon_llid klass) llfn in
      let llbuilder = Llvm.builder_at_end llctx llblock in
        (llblock, llbuilder)
    in

    let if_ptr_in_slot_not_null
        (inner:Llvm.llvalue -> Llvm.llbuilder -> Llvm.llbuilder)
        (llbuilder:Llvm.llbuilder)
        : Llvm.llbuilder =
      let ptr = Llvm.build_load slot_ptr (anon_llid "tmp") llbuilder in
      let null = Llvm.const_pointer_null llty in
      let test =
        Llvm.build_icmp Llvm.Icmp.Ne null ptr (anon_llid "nullp") llbuilder
      in
      let (llthen, llthen_builder) = new_block "then" in
      let (llnext, llnext_builder) = new_block "next" in
        ignore (Llvm.build_cond_br test llthen llnext llbuilder);
        let llthen_builder = inner ptr llthen_builder in
          ignore (Llvm.build_br llnext llthen_builder);
          llnext_builder
    in

    let decr_refcnt_and_if_zero
        (rc_elt:int)
        (inner:Llvm.llvalue -> Llvm.llbuilder -> Llvm.llbuilder)
        (ptr:Llvm.llvalue)
        (llbuilder:Llvm.llbuilder)
        : Llvm.llbuilder  =
      let rc_ptr = get_element_ptr llbuilder ptr rc_elt in
      let rc = Llvm.build_load rc_ptr (anon_llid "rc") llbuilder in
      let rc = Llvm.build_sub rc (imm 1L) (anon_llid "tmp") llbuilder in
      let _ = Llvm.build_store rc rc_ptr llbuilder in
        log sem_cx "rc type: %s" (llval_str rc);
      let test =
        Llvm.build_icmp Llvm.Icmp.Eq
          rc (imm 0L) (anon_llid "zerop") llbuilder
      in
      let (llthen, llthen_builder) = new_block "then" in
      let (llnext, llnext_builder) = new_block "next" in
        ignore (Llvm.build_cond_br test llthen llnext llbuilder);
        let llthen_builder = inner ptr llthen_builder in
          ignore (Llvm.build_br llnext llthen_builder);
          llnext_builder
    in

    let free_and_null_out_slot
        (ptr:Llvm.llvalue)
        (llbuilder:Llvm.llbuilder)
        : Llvm.llbuilder =
      free_ty llbuilder lltask ty ptr;
      let null = Llvm.const_pointer_null llty in
        ignore (Llvm.build_store null slot_ptr llbuilder);
        llbuilder
    in

      begin
          match slot_mem_ctrl slot with
              MEM_rc_struct
            | MEM_gc ->
                llbuilder :=
                  if_ptr_in_slot_not_null
                    (decr_refcnt_and_if_zero
                       Abi.exterior_rc_slot_field_refcnt
                       free_and_null_out_slot)
                    (!llbuilder)

            | MEM_rc_opaque ->
                llbuilder :=
                  if_ptr_in_slot_not_null
                    (decr_refcnt_and_if_zero
                       Abi.exterior_rc_slot_field_refcnt
                       free_and_null_out_slot)
                    (!llbuilder)

            | MEM_interior when Semant.type_is_structured ty ->
                (* FIXME: to handle recursive types, need to call drop
                   glue here, not inline. *)
                drop_ty llbuilder lltask slot_ptr ty curr_iso

            | _ -> ()
        end
  in

  let (llitems:(node_id, Llvm.llvalue) Hashtbl.t) = Hashtbl.create 0 in
  let declare_mod_item
      (name:Ast.ident)
      { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id }
      : unit =
    let full_name = Semant.item_str sem_cx id in
    let line_num =
      match Session.get_span sess id with
          None -> 0
        | Some span ->
            let (_, line, _) = span.lo in
              line
    in
      match item with
          Ast.MOD_ITEM_fn _ ->
            let llty = trans_ty (ty_of_item id) in
            let llfn = Llvm.declare_function ("_rust_" ^ name) llty llmod in
            let meta =
              md_node
                [|
                  const_dw_tag Dwarf.DW_TAG_subprogram;
                  const_i32 0; (* unused *)
                  const_i32 0; (* context metadata llvalue *)
                  md_str name;
                  md_str full_name;
                  md_str full_name;
                  const_i32 0; (* file metadata llvalue *)
                  const_i32 line_num;
                  const_i32 0; (* type descriptor metadata llvalue *)
                  const_i1 1;  (* flag: local to compile unit? *)
                  const_i1 1;  (* flag: defined in compile unit? *)
                |]
            in
              Llvm.set_function_call_conv Llvm.CallConv.c llfn;
              Hashtbl.add llitems id llfn;

              (* FIXME: Adding metadata does not work yet. . *)
              let _ = fun _ -> set_dbg_metadata llfn meta in
                ()

        | _ -> () (* TODO *)
  in

  let trans_fn
      ({
        Ast.fn_input_slots = (header_slots:Ast.header_slots);
        Ast.fn_body = (body:Ast.block)
      }:Ast.fn)
      (fn_id:node_id)
      : unit =
    let llfn = Hashtbl.find llitems fn_id in
    let lloutptr = Llvm.param llfn 0 in
    let lltask = Llvm.param llfn 1 in

    (* LLVM requires that functions be grouped into basic blocks terminated by
     * terminator instructions, while our AST is less strict. So we have to do
     * a little trickery here to wrangle the statement sequence into LLVM's
     * format. *)

    let new_block id_opt klass =
      let llblock = Llvm.append_block llctx (node_llid id_opt klass) llfn in
      let llbuilder = Llvm.builder_at_end llctx llblock in
      (llblock, llbuilder)
    in

    (* Build up the slot-to-llvalue mapping, allocating space along the
     * way. *)
    let slot_to_llvalue = Hashtbl.create 0 in
    let (_, llinitbuilder) = new_block None "init" in

    (* Allocate space for arguments (needed because arguments are lvalues in
     * Rust), and store them in the slot-to-llvalue mapping. *)
    let n_implicit_args = 2 in
    let build_arg idx llargval =
      if idx >= n_implicit_args
      then
        let ({ id = id }, ident) = header_slots.(idx - 2) in
        Llvm.set_value_name ident llargval;
        let llarg =
          let llty = Llvm.type_of llargval in
          Llvm.build_alloca llty (ident ^ "_ptr") llinitbuilder
        in
        ignore (Llvm.build_store llargval llarg llinitbuilder);
        Hashtbl.add slot_to_llvalue id llarg
    in
    Array.iteri build_arg (Llvm.params llfn);

    (* Allocate space for all the blocks' slots.
     * and zero the exteriors. *)
    let init_block (block_id:node_id) : unit =
      let init_slot
          (key:Ast.slot_key)
          (slot_id:node_id)
          (slot:Ast.slot)
          : unit =
        let name = Ast.sprintf_slot_key () key in
        let llty = trans_slot (Some slot_id) slot in
        let llptr = Llvm.build_alloca llty name llinitbuilder in
          begin
            match slot_mem_ctrl slot with
                MEM_rc_struct
              | MEM_rc_opaque
              | MEM_gc ->
                  ignore (Llvm.build_store
                            (Llvm.const_pointer_null llty)
                            llptr llinitbuilder);
              | _ -> ()
          end;
          Hashtbl.add slot_to_llvalue slot_id llptr
      in
        iter_block_slots sem_cx block_id init_slot
    in

    let exit_block
        (llbuilder:Llvm.llbuilder)
        (block_id:node_id)
        : Llvm.llbuilder =
      let r = ref llbuilder in
        iter_block_slots sem_cx block_id
          begin
            fun _ slot_id slot ->
              if (not (Semant.slot_is_obj_state sem_cx slot_id))
              then
                let ptr = Hashtbl.find slot_to_llvalue slot_id in
                  drop_slot r lltask ptr slot None
          end;
        !r
    in

    List.iter init_block (Hashtbl.find sem_cx.Semant.ctxt_frame_blocks fn_id);

    let static_str (s:string) : Llvm.llvalue =
      Llvm.define_global (anon_llid "str") (Llvm.const_stringz llctx s) llmod
    in


    (* Translates a list of AST statements to a sequence of LLVM instructions.
     * The supplied "terminate" function appends the appropriate terminator
     * instruction to the instruction stream. It may or may not be called,
     * depending on whether the AST contains a terminating instruction
     * explicitly. *)
    let rec trans_stmts
        (block_id:node_id)
        (llbuilder:Llvm.llbuilder)
        (stmts:Ast.stmt list)
        (terminate:(Llvm.llbuilder -> node_id -> unit))
        : unit =
      let trans_literal
          (lit:Ast.lit)
          : Llvm.llvalue =
        match lit with
            Ast.LIT_nil -> llnil
          | Ast.LIT_bool value ->
            Llvm.const_int (Llvm.i1_type llctx) (if value then 1 else 0)
          | Ast.LIT_mach (mty, value, _) ->
            let llty = trans_mach_ty mty in
            Llvm.const_of_int64 llty value (mach_is_signed mty)
          | Ast.LIT_int (value, _) ->
            Llvm.const_of_int64 (Llvm.i32_type llctx) value true
          | Ast.LIT_uint (value, _) ->
            Llvm.const_of_int64 (Llvm.i32_type llctx) value false
          | Ast.LIT_char ch ->
            Llvm.const_int (Llvm.i32_type llctx) ch
      in

      (* Translates an lval by reference into the appropriate pointer
       * value. *)
      let trans_lval (lval:Ast.lval) : Llvm.llvalue =
        iflog (fun _ -> log sem_cx "trans_lval: %a" Ast.sprintf_lval lval);
        match lval with
            Ast.LVAL_base { id = base_id } ->
              let id =
                Hashtbl.find sem_cx.Semant.ctxt_lval_to_referent base_id
              in
              let referent = Hashtbl.find sem_cx.Semant.ctxt_all_defns id in
              begin
                match referent with
                    Semant.DEFN_slot _ -> Hashtbl.find slot_to_llvalue id
                  | Semant.DEFN_item _ -> Hashtbl.find llitems id
                  | _ -> bogus_ptr (* TODO *)
              end
          | Ast.LVAL_ext _ -> bogus_ptr (* TODO *)
      in

      let trans_atom (atom:Ast.atom) : Llvm.llvalue =
        iflog (fun _ -> log sem_cx "trans_atom: %a" Ast.sprintf_atom atom);
        match atom with
            Ast.ATOM_literal { node = lit } -> trans_literal lit
          | Ast.ATOM_lval lval ->
              Llvm.build_load (trans_lval lval) (anon_llid "tmp") llbuilder
      in

      let trans_binary_expr
          ((op:Ast.binop), (lhs:Ast.atom), (rhs:Ast.atom))
          : Llvm.llvalue =
        (* Evaluate the operands in the proper order. *)
        let (lllhs, llrhs) =
          match op with
              Ast.BINOP_or | Ast.BINOP_and | Ast.BINOP_eq | Ast.BINOP_ne
                  | Ast.BINOP_lt | Ast.BINOP_le | Ast.BINOP_ge | Ast.BINOP_gt
                  | Ast.BINOP_lsl | Ast.BINOP_lsr | Ast.BINOP_asr
                  | Ast.BINOP_add | Ast.BINOP_sub | Ast.BINOP_mul
                  | Ast.BINOP_div | Ast.BINOP_mod | Ast.BINOP_xor ->
                (trans_atom lhs, trans_atom rhs)
            | Ast.BINOP_send ->
                let llrhs = trans_atom rhs in
                let lllhs = trans_atom lhs in
                (lllhs, llrhs)
        in
        let llid = anon_llid "expr" in
        match op with
            Ast.BINOP_eq ->
              (* TODO: equality works on more than just integers *)
              Llvm.build_icmp Llvm.Icmp.Eq lllhs llrhs llid llbuilder

            (* TODO: signed/unsigned distinction, floating point *)
          | Ast.BINOP_add -> Llvm.build_add lllhs llrhs llid llbuilder
          | Ast.BINOP_sub -> Llvm.build_sub lllhs llrhs llid llbuilder
          | Ast.BINOP_mul -> Llvm.build_mul lllhs llrhs llid llbuilder
          | Ast.BINOP_div -> Llvm.build_sdiv lllhs llrhs llid llbuilder
          | Ast.BINOP_mod -> Llvm.build_srem lllhs llrhs llid llbuilder

          | _ -> bogus (* TODO *)
      in

      let trans_unary_expr _ = bogus in (* TODO *)

      let trans_expr (expr:Ast.expr) : Llvm.llvalue =
        iflog (fun _ -> log sem_cx "trans_expr: %a" Ast.sprintf_expr expr);
        match expr with
            Ast.EXPR_binary binexp -> trans_binary_expr binexp
          | Ast.EXPR_unary unexp -> trans_unary_expr unexp
          | Ast.EXPR_atom atom -> trans_atom atom
      in

      let trans_log_str (atom:Ast.atom) : unit =
        upcall llbuilder lltask "upcall_log_str" None [| trans_atom atom |]
      in

      let trans_log_int (atom:Ast.atom) : unit =
        upcall llbuilder lltask "upcall_log_int" None [| trans_atom atom |]
      in

      let trans_fail
          (llbuilder:Llvm.llbuilder)
          (lltask:Llvm.llvalue)
          (reason:string)
          (stmt_id:node_id)
          : unit =
        let (file, line, _) =
          match Session.get_span sem_cx.Semant.ctxt_sess stmt_id with
              None -> ("<none>", 0, 0)
            | Some sp -> sp.lo
        in
        upcall llbuilder lltask "upcall_fail" None [|
          static_str reason;
          static_str file;
          Llvm.const_int (Llvm.i32_type llctx) line
        |];
        ignore (Llvm.build_unreachable llbuilder)
      in

      (* FIXME: this may be irrelevant; possibly LLVM will wind up
       * using GOT and such wherever it needs to to achieve PIC
       * data.
       *)
      (*
        let crate_rel (v:Llvm.llvalue) : Llvm.llvalue =
        let v_int = Llvm.const_pointercast v word_ty in
        let c_int = Llvm.const_pointercast crate_ptr word_ty in
        Llvm.const_sub v_int c_int
        in
      *)

      match stmts with
          [] -> terminate llbuilder block_id
        | head::tail ->

            iflog (fun _ ->
                     log sem_cx "trans_stmt: %a" Ast.sprintf_stmt head);

            let trans_tail_with_builder llbuilder' : unit =
              trans_stmts block_id llbuilder' tail terminate
            in
            let trans_tail () = trans_tail_with_builder llbuilder in

            match head.node with
                Ast.STMT_init_tup (dest, atoms) ->
                  let zero = const_i32 0 in
                  let lldest = trans_lval dest in
                  let trans_tup_atom idx atom =
                    let indices = [| zero; const_i32 idx |] in
                    let gep_id = anon_llid "init_tup_gep" in
                    let ptr =
                      Llvm.build_gep lldest indices gep_id llbuilder
                    in
                    ignore (Llvm.build_store (trans_atom atom) ptr llbuilder)
                  in
                  Array.iteri trans_tup_atom atoms;
                  trans_tail ()

              | Ast.STMT_copy (dest, src) ->
                  let llsrc = trans_expr src in
                  let lldest = trans_lval dest in
                  ignore (Llvm.build_store llsrc lldest llbuilder);
                  trans_tail ()

              | Ast.STMT_call (dest, fn, args) ->
                  let llargs = Array.map trans_atom args in
                  let lldest = trans_lval dest in
                  let llfn = trans_lval fn in
                  let llallargs = Array.append [| lldest; lltask |] llargs in
                  let llrv = build_call llfn llallargs "" llbuilder in
                    Llvm.set_instruction_call_conv Llvm.CallConv.c llrv;
                    trans_tail ()

              | Ast.STMT_if sif ->
                  let llexpr = trans_expr sif.Ast.if_test in
                  let (llnext, llnextbuilder) = new_block None "next" in
                  let branch_to_next llbuilder' _ =
                    ignore (Llvm.build_br llnext llbuilder')
                  in
                  let llthen = trans_block sif.Ast.if_then branch_to_next in
                  let llelse =
                    match sif.Ast.if_else with
                        None -> llnext
                      | Some if_else -> trans_block if_else branch_to_next
                  in
                  ignore (Llvm.build_cond_br llexpr llthen llelse llbuilder);
                  trans_tail_with_builder llnextbuilder

              | Ast.STMT_ret atom_opt ->
                  begin
                    match atom_opt with
                        None -> ()
                      | Some atom ->
                          ignore (Llvm.build_store (trans_atom atom)
                                    lloutptr llbuilder)
                  end;
                  let llbuilder = exit_block llbuilder block_id in
                    ignore (Llvm.build_ret_void llbuilder)

              | Ast.STMT_fail ->
                  trans_fail llbuilder lltask "explicit failure" head.id

              | Ast.STMT_log a ->
                  begin
                    match Semant.atom_type sem_cx a with
                        (* NB: If you extend this, be sure to update the
                         * typechecking code in type.ml as well. *)
                        Ast.TY_str -> trans_log_str a
                      | Ast.TY_int | Ast.TY_uint | Ast.TY_bool | Ast.TY_char
                      | Ast.TY_mach (TY_u8) | Ast.TY_mach (TY_u16)
                      | Ast.TY_mach (TY_u32) | Ast.TY_mach (TY_i8)
                      | Ast.TY_mach (TY_i16) | Ast.TY_mach (TY_i32) ->
                          trans_log_int a
                      | _ -> Semant.bugi sem_cx head.id
                          "unimplemented logging type"
                  end;
                  trans_tail ()

              | Ast.STMT_check_expr expr ->
                  let llexpr = trans_expr expr in
                  let (llfail, llfailbuilder) = new_block None "fail" in
                  let reason = Fmt.fmt_to_str Ast.fmt_expr expr in
                  trans_fail llfailbuilder lltask reason head.id;
                  let (llok, llokbuilder) = new_block None "ok" in
                  ignore (Llvm.build_cond_br llexpr llok llfail llbuilder);
                  trans_tail_with_builder llokbuilder

              | Ast.STMT_init_str (dst, str) ->
                  let d = trans_lval dst in
                  let s = static_str str in
                  let len =
                    Llvm.const_int word_ty ((String.length str) + 1)
                  in
                    upcall llbuilder lltask "upcall_new_str"
                      (Some d) [| s; len |];
                    trans_tail ()

              | _ -> trans_stmts block_id llbuilder tail terminate

    (* 
     * Translates an AST block to one or more LLVM basic blocks and returns
     * the first basic block. The supplied callback is expected to add a
     * terminator instruction.
     *)

    and trans_block
        ({ node = (stmts:Ast.stmt array); id = id }:Ast.block)
        (terminate:Llvm.llbuilder -> node_id -> unit)
        : Llvm.llbasicblock =
      let (llblock, llbuilder) = new_block (Some id) "bb" in
        trans_stmts id llbuilder (Array.to_list stmts) terminate;
        llblock
    in

    (* "Falling off the end" of a function needs to turn into an explicit
     * return instruction. *)
    let default_terminate llbuilder block_id =
      let llbuilder = exit_block llbuilder block_id in
        ignore (Llvm.build_ret_void llbuilder)
    in

    (* Build up the first body block, and link it to the end of the
     * initialization block. *)
    let llbodyblock = (trans_block body default_terminate) in
      ignore (Llvm.build_br llbodyblock llinitbuilder)
  in

  let trans_mod_item
      (_:Ast.ident)
      { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id }
      : unit =
    match item with
        Ast.MOD_ITEM_fn fn -> trans_fn fn id
      | _ -> ()
  in

  let exit_task_glue =
    (* The exit-task glue does not get called.
     * 
     * Rather, control arrives at it by *returning* to the first
     * instruction of it, when control falls off the end of the task's
     * root function.
     * 
     * There is a "fake" frame set up by the runtime, underneath us,
     * that we find ourselves in. This frame has the shape of a frame
     * entered with 2 standard arguments (outptr + taskptr), then a
     * retpc and N callee-saves sitting on the stack; all this is under
     * ebp. Then there are 2 *outgoing* args at sp[0] and sp[1].
     * 
     * All these are fake except the taskptr, which is the one bit we
     * want. So we construct an equally fake cdecl llvm signature here
     * to crudely *get* the taskptr that's sitting 2 words up from sp,
     * and pass it to upcall_exit.
     * 
     * The latter never returns.
     *)
    let llty = fn_ty void_ty [| task_ptr_ty |] in
    let llfn = Llvm.declare_function "rust_exit_task_glue" llty llmod in
    let lltask = Llvm.param llfn 0 in
    let llblock = Llvm.append_block llctx "body" llfn in
    let llbuilder = Llvm.builder_at_end llctx llblock in
      trans_upcall llbuilder lltask "upcall_exit" None [||];
      ignore (Llvm.build_ret_void llbuilder);
      llfn
  in

    try
      let crate' = crate.node in
      let items = snd (crate'.Ast.crate_items) in
        Hashtbl.iter declare_mod_item items;
        Hashtbl.iter trans_mod_item items;
        Llfinal.finalize_module
          llctx llmod abi asm_glue exit_task_glue crate_ptr;
        llmod
    with e -> Llvm.dispose_module llmod; raise e
;;

(*
 * 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:
 *)