Initial snarf.

[shack.git] / arch / x86 / util / x86_mir_atom.kupo

(*
   Generate x86 code from an MIR atom expression tree.
   Copyright (C) 2002,2001 Justin David Smith, Caltech

   This program is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2
   of the License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *)


(* Useful modules *)
open Format

open Mir
open Mir_pos
open Mir_exn
open Mir_print

open Symbol
open Sizeof_const

open Frame_type
open X86_runtime
open X86_build
open X86_frame
open X86_mir_env
open X86_inst_type


(* Declare the types of some common variable names used in the
   OCaml code below.  In theory, these declarations can be over-
   ridden by dcl statements when necessary. *)
declarations:
   (* Labels *)
   lbl label;

   (* Operands *)
   op;
   op1;
   op2;
   ohi;
   olo;
   ohi1;
   olo1;
   ohi2;
   olo2;


(* Begin MIR transform code *)
inline_kupo:
begin_ocaml_code`

module Pos = MakePos (struct let name = "X86_mir_atom" end)
open Pos


(* Constants *)
let one32 = Int32.one
let three32 = Int32.of_int 3
let minus_one32 = Int32.of_int (-1)


(* Imports *)
let reg64_lookup { cg_reg64 = reg64 } = reg64_lookup reg64
let fvals_lookup { cg_fvals = fvals } = fvals_lookup fvals


let atom_warning msg =
   eprintf "x86_mir_atom warning:  %s\n" msg


(***  Utilities  ***)


(* int32_ok
   Checks to see if this integer atomclass is int32-manipulation
   friendly.  Bytes and words are generally represented by 32-bit
   ints while in registers, therefore most operations that work
   on int32 can be used unmodified for the int8, int16 cases.  *)
let int32_ok = function
   Rawint.Int8 | Rawint.Int16 | Rawint.Int32 -> true
 | Rawint.Int64 -> false


(* ptr_ok
   Checks to see if the atomclass given is a valid pointer class.
   This function will not consider ACPointerInfix to be a valid
   pointer; such pointers must be converted to real base or offset
   pointers before use.  *)
let ptr_ok = function
   ACFunction _
 | ACPointer _ ->
      true
 | ACInt
 | ACRawInt _
 | ACFloat _
 | ACPoly
 | ACPointerInfix _ ->
      false


(* reorder_atoms
   If the first atom is a constant, then this reorders the atoms
   so that appears as the second atom.  Usually instructions can
   be more easily optimized if constant terms appear as the second
   operand, instead of the first.  *)
let reorder_atoms a1 a2 =
   match a1 with
      AtomInt _
    | AtomRawInt _
    | AtomFloat _  -> a2, a1
    | _            -> a1, a2


(* build_atom_block
   Constructs a block with instructions given, that jumps to the
   next block as determined by running cont on operand v.  This
   is mostly just a shorthand notation for something that will
   be /frequently/ computed...  *)
let build_atom_block debug name insts v cont =
   let blocks, label = cont v in
   let block, label = code_build_dst_block debug name insts label in
      block :: blocks, label


(* add_binop_inst
   Add the instruction to the listbuf. *)
let add_binop_inst cons insts op1 op2 =
   `+insts:
      add_inst `{ cons op1 op2 `};`


(***  Coercions  ***)


(* build_int_of_int32
   Build the int31 representation.  *)
let build_int_of_int32 insts op =
   `+insts:
      sall  op,   $1;
      orl   op,   $1;`


(* build_int32_of_int
   Build an int32 from the int31 representation.  *)
let build_int32_of_int insts op =
   `+insts:
      sarl  op,   $1;`


(* build_nop
   No transformation applied to the operand indicated.  *)
let build_nop insts _ = insts


(* code_int32_of_float_op
   Coerces a floating-point value to an int32 value.  This accomplishes
   the task by loading the value onto the stack, then popping it off as
   a signed integer.  Warning: we only played the signed int game here.
   Op has already been decoded; this constructs a new block.  *)
let code_int32_of_float_op debug coerce op cont =
   let insts, v =
      `new insts -> v:
         new   %v;
         comm_string "Coercing a float to an int32";
         fldt  op;
         fistp float_reg_1;
         modify_listbuf `{ coerce insts (Register float_reg_1) `};
         movl  v,    float_reg_1;`
   in
      build_atom_block debug "coerce_int32_of_float" insts v cont


(* code_float_of_int32_op
   Coerces a signed int32 to a floating-point value.  This accomplishes
   the task by loading the value onto the stack as a signed int, then
   popping it off as a float.  *)
let code_float_of_int32_op debug coerce op cont =
   let insts, v =
      `new insts -> v:
         new   @v;
         comm_string "Coercing an int32 to a float";
         movl  float_reg_1,   op;
         modify_listbuf `{ coerce insts (Register float_reg_1) `};
         fild  float_reg_1;
         fstpt v;`
   in
      build_atom_block debug "coerce_float_of_int32" insts v cont


(* code_int32_of_rawint_op
   Coerces a rawint of any 32-bit precision into a rawint which has
   at most 32-bits of precision.  64-bit values are not permitted
   here.  The operand is already converted when this is called. *)
let code_int32_of_rawint_op pos debug pre signed op cont =
   let pos = string_pos "code_int32_of_rawint_op" pos in
   let mov_extend pre op =
      if signed then
         MOVS (pre, op, op)
      else
         MOVZ (pre, op, op)
   in
   let v = Register (new_symbol_string "coerce") in
   let r =
      match pre with
         Rawint.Int8 ->
            (* Note that for 8-bit source, we must somehow ensure that
               the register used supports 8-bit referencing; the only
               way to do that with the current allocator is pick a
               specific register that is safe for this purpose; I will
               use ECX since that is always getting clobbered... *)
            ecx
       | Rawint.Int16
       | Rawint.Int32
       | Rawint.Int64 ->
            (* For other cases, we can use any hardware register. *)
            new_symbol_string "coerce_tmp"
   in
   let source_string =
      match pre, signed with
         Rawint.Int8,  true  -> "int8"
       | Rawint.Int16, true  -> "int16"
       | Rawint.Int32, true  -> "int32"
       | Rawint.Int64, true  -> "int64"
       | Rawint.Int8,  false -> "uint8"
       | Rawint.Int16, false -> "uint16"
       | Rawint.Int32, false -> "uint32"
       | Rawint.Int64, false -> "uint64"
   in
   let insts = Listbuf.of_list
      [CommentString ("Rawint " ^ source_string ^ " to Int32 coercion");
       code_load_int32 r op]
   in
   let insts =
      match pre with
         Rawint.Int8 ->
            Listbuf.add insts (mov_extend IB (Register r))
       | Rawint.Int16 ->
            Listbuf.add insts (mov_extend IW (Register r))
       | Rawint.Int32 ->
            insts
       | Rawint.Int64 ->
            raise (MirException (pos, InternalError "Int64 cannot be used as a destination here"))
   in
   let insts = Listbuf.add insts (code_store_int32 v r) in
      build_atom_block debug "coerce_int32_of_rawint" insts v cont


(* code_int64_of_float
   Coerces a floating-point value to an int64 value.  This accomplishes
   the task by loading the value onto the stack, then popping it off as
   a signed integer.  Warning: we only played the signed int game here. *)
let rec code_int64_of_float cg pos debug a cont =
   let pos = string_pos "code_int64_of_float" pos in
      code_atom_float cg pos debug a (fun op ->
         let insts, vhi, vlo =
            `new -> vhi, vlo:
               new      %vhi, %vlo;
               comm_string "Coercing a float to an int64";
               fldt     op;
               fistp64  float_reg_1;
               movl     vlo,  float_reg_1;
               movl     vhi,  float_reg_2;`
         in
         let blocks, label = cont vhi vlo in
         let block, label = code_build_dst_block debug "coerce_int64_of_float" insts label in
            block :: blocks, label)


(* code_float_of_int64
   Coerces a signed int64 to a floating-point value.  This accomplishes
   the task by loading the value onto the stack as a signed int, then
   popping it off as a float.  *)
and code_float_of_int64 cg pos debug a cont =
   let pos = string_pos "code_float_of_int64" pos in
      code_atom_int64 cg pos debug a (fun ohi olo ->
         let insts, v =
            `new -> v:
               new      @v;
               comm_string "Coercing an int64 to a float";
               movl     float_reg_1, olo;
               movl     float_reg_2, ohi;
               fild64   float_reg_1;
               fstpt    v;`
         in
            build_atom_block debug "coerce_float_of_int64" insts v cont)


(* code_int32_of_float
   code_float_of_int32
   code_int_of_float
   code_float_of_int
   Toplevel functions for coercing integers to floats and vice versa.  *)
and code_int32_of_float cg pos debug a cont =
   let pos = string_pos "code_int32_of_float" pos in
      code_atom_float cg pos debug a (fun op ->
         code_int32_of_float_op debug build_nop op cont)

and code_float_of_int32 cg pos debug a cont =
   let pos = string_pos "code_float_of_int32" pos in
      code_atom_int32 cg pos debug a (fun op ->
         code_float_of_int32_op debug build_nop op cont)

and code_int_of_float cg pos debug a cont =
   let pos = string_pos "code_int_of_float" pos in
      code_atom_float cg pos debug a (fun op ->
         code_int32_of_float_op debug build_int_of_int32 op cont)

and code_float_of_int cg pos debug a cont =
   let pos = string_pos "code_float_of_int" pos in
      code_atom_int cg pos debug a (fun op ->
         code_float_of_int32_op debug build_int32_of_int op cont)


(* code_int32_of_int
   Coerces a signed int to a rawint value.  *)
and code_int32_of_int cg pos debug a cont =
   let pos = string_pos "code_int32_of_int" pos in
      code_atom_int cg pos debug a (fun op ->
         let insts, v =
            `new -> v:
               new   %v;
               comm_string "Coercing an int to an int32";
               movl  v, op;`
         in
         let insts = build_int32_of_int insts v in
            build_atom_block debug "coerce_int32_of_int" insts v cont)


(* code_int_of_int32
   Coerces a rawint value into a signed ML int.  *)
and code_int_of_int32 cg pos debug a cont =
   let pos = string_pos "code_int_of_int32" pos in
      code_atom_int32 cg pos debug a (fun op ->
         let insts, v =
            `new -> v:
               new   %v;
               comm_string "Coercing an int32 to an int";
               movl  v, op;`
         in
         let insts = build_int_of_int32 insts v in
            build_atom_block debug "coerce_int_of_int32" insts v cont)


(* code_int32_of_rawint
   Coerces a rawint of any precision into a rawint which has
   at most 32-bits of precision.  64-bit result values are
   not permitted here.  NOTE: the resulting type is always
   a 32-bit value which is sign-extended or zero-extended
   appropriately.  *)
and code_int32_of_rawint cg pos debug pre signed a cont =
   let pos = string_pos "code_int32_of_rawint" pos in

   (* coerce_small
      Assuming spre was already a 32-bit value, coerce to whatever...
      Operand has already been converted to an int32-compatible value
      by this point (if coercion from an int64 was necessary to begin
      with).  *)
   let coerce_small op =
      code_int32_of_rawint_op pos debug pre signed op cont
   in

   (* coerce_large
      Assuming spre was a 64-bit value, coerce to a general
      32-bit value before applying the specific coerction to
      dpre. *)
   let coerce_large ohi olo =
      let insts, v =
         `new -> v:
            new   %r,   %v;
            comm_string "Int64 to Int32 coercion";
            movl  r,    olo;
            movl  v,    r;`
      in
         build_atom_block debug "coerce_int32_of_int64" insts v cont
   in

      (* Determine whether we need to chop down a 64-bit value into
         a 32-bit value...  If the latter, we need to cut down the
         64-bit value before continuing... *)
      if int32_ok pre then
         code_atom_int32 cg pos debug a coerce_small
      else
         code_atom_int64 cg pos debug a coerce_large


(* code_int64_of_rawint
   Coerce a rawint value of any precision into a 64-bit value.  *)
and code_int64_of_rawint cg pos debug spre signed a cont =
   if int32_ok spre then
      (* A 32-bit value must be coerced to 64-bits. *)
      code_atom_int32 cg pos debug a (fun op ->
         let insts, vhi, vlo =
            if signed then
               `new -> vhi, vlo:
                  new   %vhi, %vlo;
                  comm_string "Rawint signed coercion to int64 (sign-extend)";
                  movl  eax,  op;
                  cltd;
                  movl  vlo,  eax;
                  movl  vhi,  edx;`
            else
               `new -> vhi, vlo:
                  new   %vhi, %vlo, %r;
                  comm_string "Rawint unsigned coercion to int64 (zero-extend)";
                  movl  r,    op;
                  movl  vlo,  r;
                  movl  vhi,  $0;`
         in
         let blocks, label = cont vhi vlo in
         let block, label = code_build_dst_block debug "coerce_int64_of_int32" insts label in
            block :: blocks, label)
   else
      (* No change in internal representation; ignore *)
      code_atom_int64 cg pos debug a cont


(***  Relative Operations  ***)


(* code_cond_int_op
   See below; this is a more generic form that allows you to
   specify arbitrary operands for the TRUE and FALSE values. *)
and code_cond_int_op debug op cont v op1 op2 tval fval =
   (* Construct success and failure blocks *)
   let blocks, label = cont v in
   let isucc = Listbuf.of_elt (MOV (IL, v, tval)) in
   let ifail = Listbuf.of_elt (MOV (IL, v, fval)) in
   let bsucc, lsucc = code_build_dst_block debug "relop_succ" isucc label in
   let bfail, lfail = code_build_dst_block debug "relop_fail" ifail label in

   (* Construct the comparison operation itself *)
   let build_cmp op1 op2 = CMP (IL, op1, op2) in
   let insts = build_relop_int32 build_cmp Listbuf.empty op op1 op2 lsucc in

   (* Assemble all the blocks together *)
   let block, label = code_build_dst_block debug "relop" insts lfail in
      block :: bfail :: bsucc :: blocks, label


(* code_relop_int_op
   See code_relop_int32; this auxiliary function handles the
   actual conditional code for comparison, but does not do the
   coercions that the higher-level functions require.  *)
and code_relop_int_op debug op cont v op1 op2 =
   let one = ImmediateNumber (OffNumber Int32.one) in
   let zero = ImmediateNumber (OffNumber Int32.zero) in
      code_cond_int_op debug op cont v op1 op2 one zero


(* code_relop_int
   Relations work transparently on ML ints, however we should use
   the special encoder for ML ints to code the atoms themselves.  *)
and code_relop_int cg pos debug op a1 a2 cont =
   let pos = string_pos "code_relop_int" pos in
      code_basic_binop_int cg pos debug a1 a2 (code_relop_int_op debug op cont)


(* code_relop_poly
   Relations work transparently on poly values, however we should use
   the special encoder for poly values to code the atoms themselves.  *)
and code_relop_poly cg pos debug op a1 a2 cont =
   let pos = string_pos "code_relop_poly" pos in
      code_basic_binop_poly cg pos debug a1 a2 (code_relop_int_op debug op cont)


(* code_relop_int32
   Wrapper for the various integer relative operations that you can use.  *)
and code_relop_int32 cg pos debug pre signed op a1 a2 cont =
   let pos = string_pos "code_relop_int32" pos in
      code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
         code_int32_of_rawint_op pos debug pre signed op1 (fun op1 ->
            code_int32_of_rawint_op pos debug pre signed op2 (fun op2 ->
               code_relop_int_op debug op cont v op1 op2)))


(* code_relop_ptr
   Wrapper for operations that compare pointers...  *)
and code_relop_ptr cg pos debug pre signed op a1 a2 cont =
   let pos = string_pos "code_relop_ptr" pos in
      code_atom_ptr_off cg pos debug a1 (fun op1 ->
         code_atom_ptr_off cg pos debug a2 (fun op2 ->
            let v = Register (new_symbol_string "relop_res") in
               code_relop_int_op debug op cont v op1 op2))


(* code_relop_int64
   See code_relop_int32; this does pretty much the same damn thing
   except for 64-bit integers.  A distinguishing feature here is
   the need for a slightly different function structure due to the
   way 64-bit ints are handled.  *)
and code_relop_int64 cg pos debug op a1 a2 cont =
   let pos = string_pos "code_relop_int64" pos in
      code_atom_int64 cg pos debug a1 (fun ohi1 olo1 ->
         code_atom_int64 cg pos debug a2 (fun ohi2 olo2 ->
            (* Construct success and failure blocks *)
            let v = Register (new_symbol_string "relop_res") in
            let blocks, label = cont v in
            let isucc = Listbuf.of_elt (MOV (IL, v, ImmediateNumber (OffNumber Int32.one))) in
            let ifail = Listbuf.of_elt (MOV (IL, v, ImmediateNumber (OffNumber Int32.zero))) in
            let bsucc, lsucc = code_build_dst_block debug "relop_succ" isucc label in
            let bfail, lfail = code_build_dst_block debug "relop_fail" ifail label in

            (* Construct the comparison operation itself *)
            let build_cmp op1 op2 = CMP (IL, op1, op2) in
            let insts = build_relop_int64 build_cmp Listbuf.empty op ohi1 olo1 ohi2 olo2 lsucc lfail in

            (* Assemble all the blocks together *)
            let block, label = code_build_dst_block debug "relop" insts lfail in
               block :: bfail :: bsucc :: blocks, label))


(* code_relop_rawint
   Handles any type of rawint expression. *)
and code_relop_rawint cg pos debug pre signed op a1 a2 cont =
   if int32_ok pre then
      code_relop_int32 cg pos debug pre signed op a1 a2 cont
   else
      code_relop_int64 cg pos debug op a1 a2 cont


(* code_cond_float_op
   See below; this is a more generic form that allows you to
   specify arbitrary operands for the TRUE and FALSE values. *)
and code_cond_float_op debug op cont v op1 op2 tval fval =
   (* Construct success and failure blocks *)
   let blocks, label = cont v in
   let isucc = Listbuf.of_elt (MOV (IL, v, tval)) in
   let ifail = Listbuf.of_elt (MOV (IL, v, fval)) in
   let bsucc, lsucc = code_build_dst_block debug "relop_float_succ" isucc label in
   let bfail, lfail = code_build_dst_block debug "relop_float_fail" ifail label in

   (* Construct the comparison code *)
   let insts = build_relop_float Listbuf.empty op op1 op2 lsucc in
   let block, label = code_build_dst_block debug "relop_float" insts lfail in
      block :: bfail :: bsucc :: blocks, label


(* code_relop_float_op
   Similar to above, but provides default values for T and F.  *)
and code_relop_float_op debug op cont v op1 op2 =
   code_cond_float_op debug op cont v op1 op2 (ImmediateNumber (OffNumber Int32.one)) (ImmediateNumber (OffNumber Int32.zero))


(* code_relop_float
   Similar to the above relops, but this one works for floats.  We cannot
   directly use JCC on floating-point comparisons because they set flags
   in the FP status word, not the main flags.  Furthermore, we're forced
   to load the status word into AX (it's either that or memory) to check
   the flags.  This sucks. *)
and code_relop_float cg pos debug op a1 a2 cont =
   let pos = string_pos "code_relop_float" pos in
      code_basic_binop_float cg pos debug a1 a2 (fun _ op1 op2 ->
         (* The variable generated is a float var; we need an int *)
         let v = Register (new_symbol_string "float_relop_res") in
            code_relop_float_op debug op cont v op1 op2)


(***  Int/Int32 Operations  ***)


(* code_unop_int
   Writes a general-purpose unary operation for 32-bit values.
   cons contains code to build a list of instructions which are
   added to the inst buffer given to it.  Note that cont is
   expected to convert the result into int31 representation!  *)
and code_unop_int cg pos debug a cont cons =
   let pos = string_pos "code_unop_int" pos in
   code_atom_int cg pos debug a (fun op ->
      let insts, v =
         `new insts -> v:
            new   %r,   %v;
            movl  r,    op;
            modify_listbuf `{ cons insts (Register r) `};
            movl  v,    r;`
      in
         build_atom_block debug "unop" insts v cont)


(* code_unop_int32
   Writes a general-purpose unary operation for 32-bit values.
   cons contains code to build the actual inst (single-form).  *)
and code_unop_int32 cg pos debug a cont cons =
   let pos = string_pos "code_unop_int32" pos in
   code_atom_int32 cg pos debug a (fun op ->
      let insts, v =
         `new -> v:
            new   %r,   %v;
            movl  r,    op;
            add_inst `{ cons (Register r) `};
            movl  v,    r;`
      in
         build_atom_block debug "unop" insts v cont)


(* code_mem_header
   Writes code to access a dword in a header (the
   word that contains the index and the tag).  cons contains
   code to build an inst that will return either the index or
   the tag (depending on which you want), it takes the value
   of that header dword as an input.  *)
and code_mem_header_int word cg pos debug a cont cons =
   let pos = string_pos "code_mem_header1" pos in
   code_atom_ptr_base cg pos debug a (fun op ->
      let insts, v =
         `new insts -> v:
            dcl   $word;
            new   %r1,  %r2,  %v;
            movl  r1,   op;
            movl  r2,   *(r1, word);
            modify_listbuf `{ cons insts (Register r2) `};
            movl  v,    r2;`
      in
         build_atom_block debug "mem_header1" insts v cont)


(* code_mem_funindex
   Writes code to access the closure index of a function pointed
   to by the given atom.  The atom MUST point to the beginning of
   an escape version of a function in the program; otherwise, well
   you'll get interesting results for sure.  The index will be
   packaged up into the operand passed to cont.  *)
and code_mem_funindex_int cg pos debug a cont cons =
   let pos = string_pos "code_mem_funindex" pos in
      code_mem_header_int index_word32 cg pos debug a cont cons

and code_mem_funindex_int32 cg pos debug a cont =
   code_mem_funindex_int cg pos debug a cont (fun insts _ -> insts)


(* code_fun_pointer
   Writes code to load the address of the _escape_ version
   of the function indicated by the label v.  An operand to
   the resulting pointer will be passed to cont.  *)
and code_fun_pointer_int32 cg pos debug v cont =
   let pos = string_pos "code_fun_pointer_int32" pos in
   let { cg_esc_funs = esc_funs } = cg in
   let v', _, _ = try SymbolTable.find esc_funs v with
      Not_found -> raise (MirException (pos, UnboundVar v))
   in
   let insts, v'' =
      `new -> v'':
         new   %r,   %v'';
         dcl   lbl v';

         comm_string `{ Printf.sprintf "Function %s escapes to %s" (string_of_symbol v) (string_of_symbol v') `};
         leal  r,    v';
         movl  v'',  r;`
   in
      build_atom_block debug "fun_pointer" insts v'' cont


(* code_basic_binop_int32
   Writes the infrastructure used by most binary operations.  *)
and code_basic_binop_int32 cg pos debug a1 a2 cont =
   let pos = string_pos "code_basic_binop_int32" pos in
   let v = Register (new_symbol_string "binop_res") in
   code_atom_int32 cg pos debug a1 (fun op1 ->
      code_atom_int32 cg pos debug a2 (fun op2 ->
         cont v op1 op2))


(* code_basic_binop_int
   Writes the infrastructure used by most binary operations.  *)
and code_basic_binop_int cg pos debug a1 a2 cont =
   let pos = string_pos "code_basic_binop_int" pos in
   let v = Register (new_symbol_string "binop_res") in
   code_atom_int cg pos debug a1 (fun op1 ->
      code_atom_int cg pos debug a2 (fun op2 ->
         cont v op1 op2))


(* code_basic_binop_poly
   Writes the infrastructure used by most binary operations.  *)
and code_basic_binop_poly cg pos debug a1 a2 cont =
   let pos = string_pos "code_basic_binop_poly" pos in
   let v = Register (new_symbol_string "binop_res") in
   code_atom_poly cg pos debug a1 (fun op1 ->
      code_atom_poly cg pos debug a2 (fun op2 ->
         cont v op1 op2))


(* code_binop_int32
   Writes a general-purpose binary operation for 32-bit values.
   cons contains code to build the actual inst, it takes two
   arguments which will be operands.  Note: the first form is
   some common code which we'll see in a lot of binops, might
   as well list it here.  *)
and code_binop_int_aux cg pos debug a1 a2 cont basic cons =
   let pos = string_pos "code_binop_int_aux" pos in
   basic cg pos debug a1 a2 (fun v op1 op2 ->
      let insts =
         `new insts:
            new   %r;
            dcl   v;
            movl  r,    op1;
            modify_listbuf `{ cons insts (Register r) op2 `};
            movl  v,    r;`
      in
         build_atom_block debug "binop" insts v cont)

and code_binop_int32 cg pos debug a1 a2 cont cons =
   code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int32 (add_binop_inst cons)

and code_binop_int_nowrap cg pos debug a1 a2 cont cons =
   code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int (add_binop_inst cons)


(* code_binop_wrap_int
   Convert the int31 to int32, perform the op, then convert back. *)
and code_binop_int_wrap cg pos debug a1 a2 cont cons =
   code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int (fun insts op1 op2 ->
      `+insts:
         new   %v1,  %v2;
         movl  v1,   op1;
         movl  v2,   op2;
         sarl  v1,   $1;
         sarl  v2,   $1;
         add_inst `{ cons (Register v1) (Register v2) `};
         shll  v1,   $1;
         orl   v1,   $1;
         movl  op1,  v1;`)


(* code_binop_int32_cl
   This is a special form of the above usually used for shl,
   shr instructions.  It indicates that one of the arguments
   must either be ecx (which is the case for shifting), or an
   immediate value.  *)
and code_binop_int_cl_aux cg pos debug a1 a2 cont shift cons =
   let pos = string_pos "code_binop_int32_cl" pos in
   let basic =
      if shift then
         code_basic_binop_int
      else
         code_basic_binop_int32
   in
   basic cg pos debug a1 a2 (fun v op1 op2 ->
      let r = new_symbol_string "binop_tmp" in
      let insts = Listbuf.of_elt (code_load_int32 r op1) in
      let insts =
         match op2 with
            ImmediateNumber (OffNumber i) ->
               if shift then
                  cons insts (Register r) (ImmediateNumber (OffNumber (Int32.shift_right i 1)))
               else
                  cons insts (Register r) op2
          | _ ->
               let insts = Listbuf.add insts (code_load_int32 ecx op2) in
               let insts =
                  if shift then
                     Listbuf.add insts (SAR (IL, Register ecx, ImmediateNumber (OffNumber Int32.one)))
                  else
                     insts
               in
                  cons insts (Register r) (Register ecx)
      in
      let insts = Listbuf.add insts (code_store_int32 v r) in
         build_atom_block debug "binop" insts v cont)

and code_binop_int32_cl cg pos debug a1 a2 cont cons =
   code_binop_int_cl_aux cg pos debug a1 a2 cont false (fun insts op1 op2 ->
      `+insts:
         add_inst `{ cons op1 op2 `};`)

and code_binop_int_cl cg pos debug a1 a2 cont cons =
   code_binop_int_cl_aux cg pos debug a1 a2 cont true (fun insts op1 op2 ->
      `+insts:
         (* op2 has already been shifted appropriately here *)
         sarl  op1,  $1;
         add_inst `{ cons op1 op2 `};
         shll  op1,  $1;
         orl   op1,  $1;`)


(* code_mulop_int32
   MUL has the same funny semantics as the div instructions have.
   This operation only applies to unsigned MUL; signed multiplication
   uses IMUL which accepts two operands (for no apparent reason). *)
and code_mulop_int32 cg pos debug a1 a2 cont =
   let pos = string_pos "code_mulop_int32" pos in
   code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
      (* MUL cannot have an immediate arg *)
      let insts =
         `new:
            new   %r;
            dcl   v;
            movl  r,    op2;
            movl  eax,  op1;
            mull  r;
            movl  v,    eax;`
      in
         build_atom_block debug "mulop" insts v cont)


(* code_divop_int32
   Just like code_mulop_int32, except this form handles both signed
   and unsigned division (based on the inst the cons function builds),
   and it also handles remainders (pass result == eax for division,
   or result == edx for remainder).  I hate the funky div semantics --justins *)
and code_divop_int_aux cg pos debug a1 a2 cont result clop basic cons =
   (* TEMP: The DIVOP code could be seriously improved with Kupo now
            The current structure of the code is very messy though... *)
   let pos = string_pos "code_divop_int_aux" pos in
   basic cg pos debug a1 a2 (fun v op1 op2 ->
      let insts =
         `new insts:
            new   %r;
            dcl   v,  %result;

            (* DIV, IDIV cannot have immediate args *)
            movl  r,    op2;
            movl  eax,  op1;

            (* We have to clear the high-order bits of the numerator *)
            add_inst `{ clop `};
            modify_listbuf `{ cons insts (Register eax) (Register r) `};
            movl  v,    result;`
      in
         build_atom_block debug "divop" insts v cont)

and code_divop_int32 cg pos debug pre signed a1 a2 cont result =
   let clop, cons =
      if signed then
         CLTD, (fun op -> IDIV (IL, op))
      else
         MOV (IL, Register edx, ImmediateNumber (OffNumber Int32.zero)), (fun op -> DIV (IL, op))
   in
   let code_basic_binop_int32 cg pos debug a1 a2 cont =
      code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
         code_int32_of_rawint_op pos debug pre signed op1 (fun op1 ->
            code_int32_of_rawint_op pos debug pre signed op2 (fun op2 ->
               cont v op1 op2)))
   in
      code_divop_int_aux cg pos debug a1 a2 cont result clop code_basic_binop_int32 (fun insts _ op ->
         Listbuf.add insts (cons op))

and code_divop_int cg pos debug a1 a2 cont result clop cons =
   code_divop_int_aux cg pos debug a1 a2 cont result clop code_basic_binop_int (fun insts op1 op2 ->
      `+insts:
         new   %v2;
         dcl   %result;

         movl  v2,      op2;
         sarl  op1,     $1;
         sarl  v2,      $1;
         add_inst `{ cons (Register v2) `};
         shll  result,  $1;
         orl   result,  $1;`)


(* code_let_mem_aux
   References some random garbage in memory.  We need to know the
   exact precision here, so we know how many bytes we are reading
   out of memory.  Note: the first function given is an internal
   form which may be of use to other atom classes as well.  *)
and code_let_mem_aux cg pos debug a1 a2 cons =
   let pos = string_pos "code_let_mem_aux" pos in
   let insts = Listbuf.empty in
   code_atom_ptr_off cg pos debug a1 (fun opptr ->
      let rptr = new_symbol_string "let_mem_aux" in
      let load_insts insts operand =
         let insts = Listbuf.add insts (code_load_int32 rptr opptr) in
            cons operand insts
      in
      match a2 with
         AtomRawInt i ->
            (* Offset is constant *)
            let operand = MemRegOff(rptr, OffNumber (Rawint.to_int32 i)) in
               load_insts insts operand
       | _ ->
            (* Offset in a register; it must be a byte-offset *)
            let rofs = new_symbol_string "let_mem_off" in
            code_atom_int32 cg pos debug a2 (fun oofs ->
               let insts = Listbuf.add insts (code_load_int32 rofs oofs) in
               let operand = MemRegRegOffMul (rptr, rofs, OffNumber Int32.zero, Int32.one) in
                  load_insts insts operand))

(* JDS: Killed JYH's revert, let's try this again.
   JDS: This code can be removed once the next function down is verified. -2002.08.17
   TEMP
and code_let_mem_int cg pos debug a1 a2 cont =
   let pos = string_pos "code_let_mem_int" pos in
   let v = Register (new_symbol_string "let_mem") in
   let load_insts_int operand insts =
      let rval = new_symbol_string "let_mem_tmp" in
      let insts = Listbuf.add_list insts
         [CommentString "Loading an int from memory";
          code_load_int32 rval operand;
          code_store_int32 v rval]
      in
      let blocks, label = cont v in
      let block, label = code_build_dst_block debug "code_let_mem_int" insts label in
         block :: blocks, label
   in
      code_let_mem_aux cg pos debug a1 a2 load_insts_int
 *)

and code_let_mem_int cg pos debug a1 a2 cont =
   let pos = string_pos "code_let_mem_int" pos in
   let v = Register (new_symbol_string "let_mem") in
   let load_insts_int op insts =
      let insts, v =
         `+insts -> v:
            new   %v,   %rval;
            comm_string "Loading an int from memory";
            movl  rval, op;
            movl  v,    rval;`
      in
      let blocks, label = cont v in
      let block, label = code_build_dst_block debug "code_let_mem_int" insts label in
         block :: blocks, label
   in
      code_let_mem_aux cg pos debug a1 a2 load_insts_int

and code_let_mem_int32 cg pos debug int_class a1 a2 cont =
   let pos = string_pos "code_let_mem_int32" pos in
   let load_insts_int32 operand insts =
      let v = Register (new_symbol_string "let_mem") in
      let rval = new_symbol_string "let_mem_tmp" in
      let name, code_load_mem =
         match int_class with
            Rawint.Int8,  false -> "uint8",  code_load_uint8
          | Rawint.Int8,  true  -> "int8",   code_load_int8
          | Rawint.Int16, false -> "uint16", code_load_uint16
          | Rawint.Int16, true  -> "int16",  code_load_int16
          | Rawint.Int32, false -> "uint32", code_load_uint32
          | Rawint.Int32, true  -> "int32",  code_load_int32
          | _ -> raise (MirException (pos, InternalError "code_let_mem_int32"))
      in
      let insts = Listbuf.add_list insts
         [CommentString ("Loading a " ^ name ^ " from memory");
          code_load_mem rval operand;
          code_store_int32 v rval]
      in
      let blocks, label = cont v in
      let block, label = code_build_dst_block debug "code_let_mem_int32" insts label in
         block :: blocks, label
   in
      code_let_mem_aux cg pos debug a1 a2 load_insts_int32


(* code_let_mem_poly
   When a polymorphic value is loaded, we don't know if
   it is an int or a pointer.  check the LSB to test whether it
   is a pointer. *)
and code_let_mem_poly cg pos debug a1 a2 cont =
   let pos = string_pos "code_let_mem_poly" pos in
   let load_insts_poly operand insts =
      let v = Register (new_symbol_string "let_mem_poly") in
      let rval = new_symbol_string "let_mem_poly_tmp" in

      (* Construct the continuation *)
      let blocks, label1 = cont v in

      (* What we do just before the continuation *)
      let insts2 = Listbuf.of_elt (code_store_int32 v rval) in
      let block2, label2 = code_build_dst_block debug "code_let_mem_poly" insts2 label1 in

      (* IF LSB is zero, lookup from the pointer table *)
      let insts3 = Listbuf.of_elt (MOV (IL, Register rval, MemRegRegOffMul (pointer_base, rval, OffNumber Int32.zero, Int32.one))) in
      let block3, label3 = code_build_dst_block debug "code_let_mem_poly" insts3 label2 in

      (* Preprocessing: check the LSB *)
      let insts = Listbuf.add_list insts
         [CommentString "Loading a <poly> from memory";
          code_load_uint32 rval operand;
          TEST (IL, Register rval, ImmediateNumber (OffNumber Int32.one));
          JCC (NEQ, ImmediateLabel label2)]
      in
      let block4, label4 = code_build_dst_block debug "code_let_mem_poly" insts label3 in
         block4 :: block3 :: block2 :: blocks, label4
   in
      code_let_mem_aux cg pos debug a1 a2 load_insts_poly


(* code_binop_int_max
   code_binop_int_min
   code_binop_int32_max
   code_binop_int32_min
   Computes max- and min-code for integer values.  This is more
   optimized than doing the computation in FIR, since we can do
   the branch optimization here.  *)
and code_binop_int_max cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_int_max" pos in
      code_basic_binop_int cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_int_op debug GT cont v op1 op2 op1 op2)

and code_binop_int_min cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_int_min" pos in
      code_basic_binop_int cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_int_op debug LT cont v op1 op2 op1 op2)

and code_binop_int32_max cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_int32_max" pos in
      code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_int_op debug GT cont v op1 op2 op1 op2)

and code_binop_int32_min cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_int32_min" pos in
      code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_int_op debug LT cont v op1 op2 op1 op2)


(* code_atom_int
   Builds blocks to compute the atom expression given.  *)
and code_atom_int cg pos debug a cont =
   let pos = string_pos "code_atom_int" pos in
   match a with
      (* Constants and variables *)
      AtomInt i ->
         cont (code_operand_of_int i)
    | AtomVar (ACInt, v) ->
         cont (Register v)

      (* Illegal operands *)
    | AtomFloat _
    | AtomRawInt _
    | AtomVar _ ->
         raise (MirException (pos, ImplicitCoercion a))

      (* Escaping functions *)
    | AtomFunVar (ac, _) ->
         raise (MirException (pos, ImplicitCoercion2 (ACInt, ac)))

      (* Unary arithmetic & bitwise operations *)
    | AtomUnop (IntOfRawIntOp (pre, _), a) when int32_ok pre ->
         code_int_of_int32 cg pos debug a cont
    | AtomUnop (IntOfFloatOp _, a) ->
         code_int_of_float cg pos debug a cont
    | AtomUnop (IntOfPolyOp, a) ->
         (* Poly values are currently transformed directly to int *)
         (* TEMP: should probably set LSB explicitly here, or have
            SOME sort of safety check?? *)
         code_atom_poly cg pos debug a cont
    | AtomUnop (UMinusOp ACInt, a) ->
         code_unop_int cg pos debug a cont (fun insts op ->
            `+insts:
               negl  op;
               incl  op;`)
    | AtomUnop (NotOp ACInt, a) ->
         code_unop_int cg pos debug a cont (fun insts op ->
            `+insts:
               notl  op;
               incl  op;`)
    | AtomUnop (AbsOp ACInt, a) ->
         (* BUG: this, of course, is wrong, but I don't know how to do a conditional here --jyh *)
         code_unop_int cg pos debug a cont (fun insts op ->
            `+insts:
               notl  op;
               incl  op;`)

      (* Unary memory operations *)
    | AtomUnop (MemIndexOp (_, ACInt), a)
    | AtomUnop (MemFunIndexOp (_, ACInt), a) ->
         code_mem_header_int index_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               add_inst `{ build_shrop_int op (pred index_shift) `};
               andl     op,   index_pred_mask32;
               orl      op,   $1;`)
    | AtomUnop (MemFunArityTagOp (_, ACInt), a) ->
         code_mem_header_int arity_tag_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               add_inst `{ build_shrop_int op (pred arity_tag_shift) `};
               andl     op,   arity_tag_pred_mask32;
               orl      op,   $1;`)
    | AtomUnop (MemTagOp (PtrBlock, ACInt), a) ->
         code_mem_header_int tag_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               add_inst `{ build_shrop_int op (pred tag_shift) `};
               andl     op,   tag_pred_mask32;
               orl      op,   $1;`)
    | AtomUnop (MemSizeOp (PtrAggr, ACInt), a) ->
         code_mem_header_int size_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               add_inst `{ build_shrop_int op (pred size_shift) `};
               andl     op,   size_pred_aggr_mask32;
               orl      op,   $1;`)
    | AtomUnop (MemSizeOp (PtrBlock, ACInt), a) ->
         code_mem_header_int size_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               add_inst `{ build_shrop_int op (pred size_shift) `};
               andl     op,   size_pred_block_mask32;
               orl      op,   $1;`)

      (* Unknown unary *)
    | AtomUnop (_, _) ->
         raise (MirException (pos, NotImplemented "code_atom_int: AtomUnop"))

      (* Binary arithmetic operations *)
    | AtomBinop (PlusOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int (fun insts op1 op2 ->
               `+insts:
                  addl  op1,  op2;
                  decl  op1;`)
    | AtomBinop (MinusOp ACInt, a1, a2) ->
         code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int (fun insts op1 op2 ->
            `+insts:
               subl  op1,  op2;
               incl  op1;`)

      (* Multiply and divide *)
    | AtomBinop (MulOp ACInt, a1, a2) ->
         (* Signed case *)
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_wrap cg pos debug a1 a2 cont (fun op1 op2 -> IMUL (IL, op1, op2))

    | AtomBinop (DivOp ACInt, a1, a2) ->
         (* Signed case *)
         code_divop_int cg pos debug a1 a2 cont eax CLTD (fun op -> IDIV (IL, op))
    | AtomBinop (RemOp ACInt, a1, a2) ->
         (* Signed case *)
         code_divop_int cg pos debug a1 a2 cont edx CLTD (fun op -> IDIV (IL, op))

      (* Binary bitwise operations *)
    | AtomBinop (SlOp ACInt, a1, a2) ->
         (* Signed case *)
         code_binop_int_cl cg pos debug a1 a2 cont (fun op1 op2 -> SAL (IL, op1, op2))
    | AtomBinop (ASrOp ACInt, a1, a2) ->
         (* Signed case *)
         code_binop_int_cl cg pos debug a1 a2 cont (fun op1 op2 -> SAR (IL, op1, op2))
    | AtomBinop (LSrOp ACInt, a1, a2) ->
         (* Unsigned case *)
         code_binop_int_cl cg pos debug a1 a2 cont (fun op1 op2 -> SHR (IL, op1, op2))
    | AtomBinop (AndOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_nowrap cg pos debug a1 a2 cont (fun op1 op2 -> AND (IL, op1, op2))
    | AtomBinop (OrOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_nowrap cg pos debug a1 a2 cont (fun op1 op2 -> OR (IL, op1, op2))
    | AtomBinop (XorOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_aux cg pos debug a1 a2 cont code_basic_binop_int (fun insts op1 op2 ->
               `+insts:
                  xorl  op1,  op2;
                  orl   op1,  $1;`)

      (* Max & Min *)
    | AtomBinop (MaxOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_max cg pos debug a1 a2 cont
    | AtomBinop (MinOp ACInt, a1, a2) ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int_min cg pos debug a1 a2 cont

      (* Binary memory operations *)
    | AtomBinop (MemOp (ACInt, _), a1, a2) ->
         code_let_mem_int cg pos debug a1 a2 cont

      (* Comparative operators *)
    | AtomBinop (CmpOp ACInt, a1, a2) ->
         let gt = AtomBinop (GtOp ACInt, a1, a2) in
         let lt = AtomBinop (LtOp ACInt, a1, a2) in
         let a = AtomBinop (MinusOp (ACRawInt (Rawint.Int32, true)), gt, lt) in
         let a = AtomUnop (IntOfRawIntOp (Rawint.Int32, true), a) in
         let pos = string_pos "code_atom_int_CmpOp" pos in
            code_atom_int cg pos debug a cont

      (* Unknown binary *)
    | AtomBinop (_, _, _) ->
         raise (MirException (pos, NotImplemented "code_atom_int: AtomBinop"))


(* code_atom_int8
   Builds blocks to compute the atom expression given.  *)
and code_atom_int8 cg pos debug signed a cont =
   let pos = string_pos "code_atom_int8" pos in
      code_atom_int32 cg pos debug a (fun op ->
         code_int32_of_rawint_op pos debug Rawint.Int8 signed op cont)


(* code_atom_int16
   Builds blocks to compute the atom expression given.  *)
and code_atom_int16 cg pos debug signed a cont =
   let pos = string_pos "code_atom_int8" pos in
      code_atom_int32 cg pos debug a (fun op ->
         code_int32_of_rawint_op pos debug Rawint.Int16 signed op cont)


(* code_atom_int32
   Builds blocks to compute the atom expression given.  *)
and code_atom_int32 cg pos debug a cont =
   let pos = string_pos "code_atom_int32" pos in
   match a with
      (* Constants and variables *)
      AtomRawInt i when int32_ok (Rawint.precision i) ->
         cont (ImmediateNumber (OffNumber (Rawint.to_int32 i)))
    | AtomVar (ACRawInt (pre, _), v) when int32_ok pre ->
         cont (Register v)

      (* Illegal operands *)
    | AtomInt _
    | AtomFloat _
    | AtomRawInt _
    | AtomVar _
    | AtomFunVar _ ->
         raise (MirException (pos, ImplicitCoercion a))

      (* Unary coercion operators *)
    | AtomUnop (RawIntOfIntOp (pre, _), a) when int32_ok pre ->
         code_int32_of_int cg pos debug a cont
    | AtomUnop (RawIntOfFloatOp (pre, true, _), a) when int32_ok pre ->
         code_int32_of_float cg pos debug a cont
    | AtomUnop (RawIntOfFloatOp (pre, false, _), a) when int32_ok pre ->
         atom_warning "coercion from float to unsigned will be treated as coercion from float to signed, expect range errors";
         code_int32_of_float cg pos debug a cont
    | AtomUnop (RawIntOfRawIntOp (dpre, dsigned, spre, ssigned), a) when int32_ok dpre && dsigned = ssigned ->
         code_int32_of_rawint cg pos debug spre ssigned a cont
    | AtomUnop (RawIntOfRawIntOp (dpre, dsigned, spre, ssigned), a) when int32_ok dpre && dpre = spre ->
         (* sign change with same precision *)
         code_int32_of_rawint cg pos debug spre ssigned a cont
    | AtomUnop (RawIntOfRawIntOp (dpre, dsigned, spre, ssigned), a) when int32_ok dpre && dsigned <> ssigned ->
         atom_warning "in coercions that change signedness, source sign wins in any bit extensions";
         code_int32_of_rawint cg pos debug spre ssigned a cont
    | AtomUnop (Int32OfPointerOp _, a) ->
         (* Reading the raw numerical value of a pointer; this is identity *)
         code_atom_ptr_off cg pos debug a cont

      (* Unary arithmetic & bitwise operations *)
    | AtomUnop (UMinusOp (ACRawInt (pre, _)), a) when int32_ok pre ->
         code_unop_int32 cg pos debug a cont (fun op -> NEG (IL, op))
    | AtomUnop (NotOp (ACRawInt (pre, _)), a) when int32_ok pre ->
         code_unop_int32 cg pos debug a cont (fun op -> NOT (IL, op))

      (* Read bitfields *)
    | AtomUnop (BitFieldOp (pre, true, ofs, len), a) when int32_ok pre ->
         code_atom_int32 cg pos debug a (fun op ->
            let insts, v =
               `new -> v:
                  new   %r, %v;
                  dcl   $len, $ofs;

                  movl  r,    op;
                  sall  r,    $32 - (ofs + len);
                  sarl  r,    $32 - len;
                  movl  v,    r;`
            in
               build_atom_block debug "bitfield" insts v cont)
    | AtomUnop (BitFieldOp (pre, false, ofs, len), a) when int32_ok pre ->
         code_atom_int32 cg pos debug a (fun op ->
            let insts, v =
               `new -> v:
                  new   %r, %v;
                  dcl   $len, $ofs;

                  movl  r,    op;
                  shrl  r,    $ofs;
                  andl  r,    $(pow2 len) - 1;
                  movl  v,    r;`
            in
               build_atom_block debug "bitfield" insts v cont)

      (* Unary memory operations *)
    | AtomUnop (MemIndexOp (_, ACRawInt (pre, _)), a)
    | AtomUnop (MemFunIndexOp (_, ACRawInt (pre, _)), a)
      when int32_ok pre ->
         code_mem_header_int index_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               shrl  op,   $index_shift32;
               andl  op,   $index_mask32;`)
    | AtomUnop (MemFunArityTagOp (_, ACRawInt (pre, _)), a)
      when int32_ok pre ->
         code_mem_header_int arity_tag_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               shrl  op,   $arity_tag_shift32;
               andl  op,   $arity_tag_mask32;`)
    | AtomUnop (MemTagOp (PtrBlock, ACRawInt (pre, _)), a)
      when int32_ok pre ->
         code_mem_header_int tag_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               shrl  op,   $tag_shift32;
               andl  op,   $tag_mask32;`)
    | AtomUnop (MemSizeOp (PtrAggr, ACRawInt (pre, _)), a)
      when int32_ok pre ->
         code_mem_header_int size_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               shrl  op,   $size_shift32;
               andl  op,   $size_aggr_mask32;`)
    | AtomUnop (MemSizeOp (PtrBlock, ACRawInt (pre, _)), a)
      when int32_ok pre ->
         code_mem_header_int size_word32 cg pos debug a cont (fun insts op ->
            `+insts:
               shrl  op,   $size_shift32;
               andl  op,   $size_block_mask32;`)

      (* Unary operations on infix pointers *)
    | AtomUnop (OffsetOfInfixPointerOp _, a) ->
         code_atom_ptr_infix cg pos debug a (fun base offset ->
            let insts, v =
               `new -> v:
                  new   %v;
                  dcl   base, offset;

                  movl  v,    offset;
                  subl  v,    base;`
            in
               build_atom_block debug "base" insts v cont)

      (* Unknown unary *)
    | AtomUnop _ ->
         raise (MirException (pos, NotImplemented "code_atom_int32: AtomUnop"))

      (* Binary arithmetic operations *)
    | AtomBinop (PlusOp (ACRawInt (pre,  _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> ADD (IL, op1, op2))
    | AtomBinop (MinusOp (ACRawInt (pre,  _)), a1, a2) when int32_ok pre ->
         code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> SUB (IL, op1, op2))

      (* Multiply and divide *)
    | AtomBinop (MulOp (ACRawInt (pre, true)), a1, a2) when int32_ok pre ->
         (* Signed case *)
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> IMUL (IL, op1, op2))
    | AtomBinop (MulOp (ACRawInt (pre, false)), a1, a2) when int32_ok pre ->
         (* Unsigned case *)
         let a1, a2 = reorder_atoms a1 a2 in
            code_mulop_int32 cg pos debug a1 a2 cont
    | AtomBinop (DivOp (ACRawInt (pre, signed)), a1, a2) when int32_ok pre ->
         code_divop_int32 cg pos debug pre signed a1 a2 cont eax
    | AtomBinop (RemOp (ACRawInt (pre, signed)), a1, a2) when int32_ok pre ->
         code_divop_int32 cg pos debug pre signed a1 a2 cont edx

      (* Binary bitwise operations *)
    | AtomBinop (SlOp (ACRawInt (pre, true)), a1, a2) when int32_ok pre ->
         (* Signed case *)
         code_binop_int32_cl cg pos debug a1 a2 cont (fun op1 op2 -> SAL (IL, op1, op2))
    | AtomBinop (SlOp (ACRawInt (pre, false)), a1, a2) when int32_ok pre ->
         (* Unsigned case *)
         code_binop_int32_cl cg pos debug a1 a2 cont (fun op1 op2 -> SHL (IL, op1, op2))
    | AtomBinop (ASrOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         (* Signed case *)
         code_binop_int32_cl cg pos debug a1 a2 cont (fun op1 op2 -> SAR (IL, op1, op2))
    | AtomBinop (LSrOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         (* Unsigned case *)
         code_binop_int32_cl cg pos debug a1 a2 cont (fun op1 op2 -> SHR (IL, op1, op2))
    | AtomBinop (AndOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> AND (IL, op1, op2))
    | AtomBinop (OrOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> OR (IL, op1, op2))
    | AtomBinop (XorOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32 cg pos debug a1 a2 cont (fun op1 op2 -> XOR (IL, op1, op2))

      (* Max & Min *)
    | AtomBinop (MaxOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32_max cg pos debug a1 a2 cont
    | AtomBinop (MinOp (ACRawInt (pre, _)), a1, a2) when int32_ok pre ->
         let a1, a2 = reorder_atoms a1 a2 in
            code_binop_int32_min cg pos debug a1 a2 cont

      (* Set bitfields *)
    | AtomBinop (SetBitFieldOp (pre, _, ofs, len), a1, a2) when int32_ok pre ->
         code_basic_binop_int32 cg pos debug a1 a2 (fun v op1 op2 ->
            let insts =
               `new:
                  new   %r1, %r2;
                  dcl   v, $len, $ofs;
                  def   mask = (pow2 len) - 1;

                  movl  r2,   op2;
                  andl  r2,   $mask;
                  shll  r2,   $ofs;
                  movl  r1,   op1;
                  andl  r1,   $~(mask << ofs);
                  orl   r1,   r2;
                  movl  v,    r1;`
            in
               build_atom_block debug "bitfield" insts v cont)

      (* Binary relational operations on poly data.
         Currently you can only check for equivalence. *)
    | AtomBinop (EqOp ACPoly, a1, a2) ->
         code_relop_poly cg pos debug EQ a1 a2 cont
    | AtomBinop (NeqOp ACPoly, a1, a2) ->
         code_relop_poly cg pos debug NEQ a1 a2 cont

      (* Binary relational operations on int *)
    | AtomBinop (EqOp ACInt, a1, a2) ->
         code_relop_int cg pos debug EQ a1 a2 cont
    | AtomBinop (NeqOp ACInt, a1, a2) ->
         code_relop_int cg pos debug NEQ a1 a2 cont
    | AtomBinop (LtOp ACInt, a1, a2) ->
         code_relop_int cg pos debug LT a1 a2 cont
    | AtomBinop (LeOp ACInt, a1, a2) ->
         code_relop_int cg pos debug LE a1 a2 cont
    | AtomBinop (GtOp ACInt, a1, a2) ->
         code_relop_int cg pos debug GT a1 a2 cont
    | AtomBinop (GeOp ACInt, a1, a2) ->
         code_relop_int cg pos debug GE a1 a2 cont

      (* Binary relational operations on floats *)
    | AtomBinop (EqOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug EQ a1 a2 cont
    | AtomBinop (NeqOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug NEQ a1 a2 cont
    | AtomBinop (LtOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug LT a1 a2 cont
    | AtomBinop (LeOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug LE a1 a2 cont
    | AtomBinop (GtOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug GT a1 a2 cont
    | AtomBinop (GeOp (ACFloat _), a1, a2) ->
         code_relop_float cg pos debug GE a1 a2 cont

      (* Binary relational operations on rawint *)
    | AtomBinop (EqOp (ACRawInt (pre, signed)), a1, a2) ->
         code_relop_rawint cg pos debug pre signed EQ a1 a2 cont
    | AtomBinop (NeqOp (ACRawInt (pre, signed)), a1, a2) ->
         code_relop_rawint cg pos debug pre signed NEQ a1 a2 cont
    | AtomBinop (LtOp (ACRawInt (pre, true)), a1, a2) ->
         code_relop_rawint cg pos debug pre true LT a1 a2 cont
    | AtomBinop (LtOp (ACRawInt (pre, false)), a1, a2) ->
         code_relop_rawint cg pos debug pre false ULT a1 a2 cont
    | AtomBinop (LeOp (ACRawInt (pre, true)), a1, a2) ->
         code_relop_rawint cg pos debug pre true LE a1 a2 cont
    | AtomBinop (LeOp (ACRawInt (pre, false)), a1, a2) ->
         code_relop_rawint cg pos debug pre false ULE a1 a2 cont
    | AtomBinop (GtOp (ACRawInt (pre, true)), a1, a2) ->
         code_relop_rawint cg pos debug pre true GT a1 a2 cont
    | AtomBinop (GtOp (ACRawInt (pre, false)), a1, a2) ->
         code_relop_rawint cg pos debug pre false UGT a1 a2 cont
    | AtomBinop (GeOp (ACRawInt (pre, true)), a1, a2) ->
         code_relop_rawint cg pos debug pre true GE a1 a2 cont
    | AtomBinop (GeOp (ACRawInt (pre, false)), a1, a2) ->
         code_relop_rawint cg pos debug pre false UGE a1 a2 cont

      (* Binary relational operations on pointers *)
    | AtomBinop (EqOp (ACPointer _), a1, a2) ->
         code_relop_ptr cg pos debug Rawint.Int32 false EQ a1 a2 cont
    | AtomBinop (NeqOp (ACPointer _), a1, a2) ->
         code_relop_ptr cg pos debug Rawint.Int32 false NEQ a1 a2 cont

      (* Binary memory operations *)
    | AtomBinop (MemOp (ACRawInt (pre, signed), _), a1, a2) when int32_ok pre ->
         code_let_mem_int32 cg pos debug (pre, signed) a1 a2 cont

      (* Unknown binary *)
    | AtomBinop _ ->
         raise (MirException (pos, NotImplemented "code_atom_int32: AtomBinop"))


(* code_atom_poly
   Builds blocks to compute the atom expression given.  Polymorphic
   values are HEAVILY restricted in what operations they can participate
   in; this is a drastic change from earlier policies which let Poly and
   Int32 be used interchangably. *)
and code_atom_poly cg pos debug a cont =
   let pos = string_pos "code_atom_poly" pos in
   match a with
      (* Constants and variables *)
    | AtomVar (ACPoly, v) ->
         cont (Register v)

      (* Illegal operands *)
    | AtomInt _
    | AtomFloat _
    | AtomRawInt _
    | AtomVar _
    | AtomFunVar _ ->
         raise (MirException (pos, ImplicitCoercion a))

      (* Unary coercion operators *)
    | AtomUnop (PolyOfIntOp, a) ->
         (* Coerce ML Int to Int32, but do NOT do the bit-shift *)
         code_atom_int cg pos debug a cont
    | AtomUnop (PolyOfPointerOp _, a)
    | AtomUnop (PolyOfFunctionOp _, a) ->
         (* Coerce a real pointer to Int32; identity operation. *)
         code_atom_ptr_off cg pos debug a cont

      (* Unknown unary *)
    | AtomUnop _ ->
         raise (MirException (pos, NotImplemented "code_atom_int32: AtomUnop"))

      (* Binary memory operations *)
    | AtomBinop (MemOp (ACPoly, _), a1, a2) ->
         code_let_mem_poly cg pos debug a1 a2 cont

      (* Unknown binary *)
    | AtomBinop _ ->
         raise (MirException (pos, NotImplemented "code_atom_int32: AtomBinop"))


(***  Pointer Operations  ***)


(* code_atom_ptr_base
   Builds blocks to compute the atom expression given.  Here the result of
   the atom expression must be a pointer type; furthermore it must point to
   the base of a block in memory. *)
and code_atom_ptr_base cg pos debug a cont =
   let pos = string_pos "code_atom_ptr_base" pos in
      match a with
         AtomVar (ACPointerInfix _, v) ->
            let v, _ = reg64_lookup cg pos v in
               cont (Register v)
       | AtomVar (ac, v) when ptr_ok ac ->
            cont (Register v)

         (* Escaping functions *)
       | AtomFunVar (_, v) ->
            code_fun_pointer_int32 cg pos debug v cont

         (* Coercions to pointer base *)
       | AtomUnop (PointerOfPolyOp _, a)
       | AtomUnop (FunctionOfPolyOp _, a) ->
            code_atom_poly cg pos debug a cont

         (* Infix pointer addition *)
       | AtomUnop (BaseOfInfixPointerOp _, a)
       | AtomBinop (InfixOfBaseOffsetOp _, a, _)
       | AtomBinop (PlusPointerOp _, a, _) ->
            code_atom_ptr_base cg pos debug a cont

         (* Binary memory operations *)
       | AtomBinop (MemOp (ac, _), a1, a2) when ptr_ok ac ->
            code_let_mem_int32 cg pos debug (Rawint.Int32, false) a1 a2 cont

         (* Unknown expression *)
       | AtomInt _
       | AtomFloat _
       | AtomRawInt _
       | AtomVar _
       | AtomUnop _
       | AtomBinop _ ->
            raise (MirException (pos, StringFormatError ("code_atom_ptr_base: expression not implemented",
               (fun buf -> pp_print_atom buf a))))


(* code_atom_ptr_off
   Builds blocks to compute the atom expression given.  Here the result of
   the atom expression must be a pointer type, and it may be an infix int32
   pointer.  WARNING: do NOT use this when getting header fields. This will
   return a real pointer. *)
and code_atom_ptr_off cg pos debug a cont =
   let pos = string_pos "code_atom_ptr_off" pos in
      match a with
         AtomVar (ACPointerInfix _, v) ->
            let _, v = reg64_lookup cg pos v in
               cont (Register v)
       | AtomVar (ac, v) when ptr_ok ac ->
            cont (Register v)

         (* Escaping functions *)
       | AtomFunVar (_, v) ->
            code_fun_pointer_int32 cg pos debug v cont

         (* Coercions to pointer offset.  Note: if the value is polymorphic
            then it is assumed to be a base pointer, not an infix pointer. *)
       | AtomUnop (PointerOfPolyOp _, a)
       | AtomUnop (FunctionOfPolyOp _, a) ->
            code_atom_poly cg pos debug a cont

         (* Infix pointers; note that pointer arithmetic and the infix
            constructor really use the same mechanism since in this case,
            we are only interested in the final offset pointer... *)
       | AtomBinop (InfixOfBaseOffsetOp _, a1, a2)
       | AtomBinop (PlusPointerOp _, a1, a2) ->
            code_atom_ptr_off cg pos debug a1 (fun op1 ->
               code_atom_int32 cg pos debug a2 (fun op2 ->
                  let insts, vlo =
                     `new -> vlo:
                        new   %vlo, %rlo;
                        movl  rlo,  op1;
                        movl  vlo,  rlo;
                        addl  vlo,  op2;`
                  in
                  let blocks, label = cont vlo in
                  let block, label = code_build_dst_block debug "ptr" insts label in
                     block :: blocks, label))

         (* Binary memory operations *)
       | AtomBinop (MemOp (ac, _), a1, a2) when ptr_ok ac ->
            code_let_mem_int32 cg pos debug (Rawint.Int32, false) a1 a2 cont

         (* Unknown expression *)
       | AtomInt _
       | AtomFloat _
       | AtomRawInt _
       | AtomVar _
       | AtomUnop _
       | AtomBinop _ ->
            raise (MirException (pos, StringFormatError ("code_atom_ptr_off: expression not implemented", (fun buf -> pp_print_atom buf a))))


(* code_atom_ptr_infix
   Builds blocks to compute the atom expression given.  Here the result of
   the atom expression must be a pointer offset type, and the continuation
   is given both parts.  *)
and code_atom_ptr_infix cg pos debug a cont =
   let pos = string_pos "code_atom_ptr_infix" pos in
      match a with
         (* Load from a variable *)
         AtomVar (ACPointerInfix _, v) ->
            let vhi, vlo = reg64_lookup cg pos v in
               cont (Register vhi) (Register vlo)

         (* Infix pointer construction.  Note here that we build the
            real pointer offset by using the code_atom_ptr_off mechanism,
            which will take the base/offset we already have and perform
            the pointer arithmetic to make the offset pointer. *)
       | AtomBinop (InfixOfBaseOffsetOp _, a1, a2) ->
            code_atom_ptr_base cg pos debug a1 (fun a1 ->
               code_atom_ptr_off cg pos debug a (fun a2 ->
                  cont a1 a2))

         (* Pointer addition.  In this case, we do the same thing as
            in code_atom_ptr_off, but we have to keep around an already-
            existing base pointer. *)
       | AtomBinop (PlusPointerOp _, a1, a2) ->
            code_atom_ptr_infix cg pos debug a1 (fun ohi olo ->
               code_atom_int32 cg pos debug a2 (fun op ->
                  let insts, vlo =
                     `new -> vlo:
                        new   %vlo, %rlo;

                        movl  rlo,  olo;
                        movl  vlo,  rlo;
                        addl  vlo,  op;`
                  in
                  let blocks, label = cont ohi vlo in
                  let block, label = code_build_dst_block debug "ptr_off" insts label in
                     block :: blocks, label))

         (* Other operations are unknown *)
       | AtomInt _
       | AtomFloat _
       | AtomRawInt _
       | AtomVar _
       | AtomFunVar _
       | AtomUnop _
       | AtomBinop _ ->
            raise (MirException (pos, StringFormatError ("code_atom_ptr_infix: expression not implemented", (fun buf -> pp_print_atom buf a))))


(***  Int64 Operations  ***)


(* code_basic_unop_int64
   Writes wrapper code for a unary 64-bit operation.  *)
and code_basic_unop_int64 cg pos debug a cont cons =
   let pos = string_pos "code_basic_unop_int64" pos in
   code_atom_int64 cg pos debug a (fun ohi olo ->
      (* TEMP: Vars MUST be interned first, unfortunately! *)
      let vhi = Register (new_symbol_string "unop_int64_hi") in
      let vlo = Register (new_symbol_string "unop_int64_lo") in
      let blocks, label = cont vhi vlo in
      let insts =
         `new insts:
            new   %rhi, %rlo;
            dcl   vhi,  vlo;

            movl  rhi,  ohi;
            movl  rlo,  olo;
            modify_listbuf `{ cons insts label (Register rhi) (Register rlo) `};
            movl  vhi,  rhi;
            movl  vlo,  rlo;`
      in
      let block, label = code_build_dst_block debug "unop_int64" insts label in
         block :: blocks, label)


(* code_unop_int64
   Writes a unary 64-bit operation.  *)
and code_unop_int64 cg pos debug a cont conshi conslo =
   let pos = string_pos "code_unop_int64" pos in
   code_basic_unop_int64 cg pos debug a cont (fun insts label ohi olo ->
      `+insts:
         add_inst `{ conslo olo `};
         add_inst `{ conshi ohi `};`)


(* code_basic_binop_int64
   Writes the infrastructure used by several int64 binary operations.  *)
and code_basic_binop_int64 cg pos debug a1 a2 cont cons =
   let pos = string_pos "code_basic_binop_int64" pos in
   code_atom_int64 cg pos debug a1 (fun ohi1 olo1 ->
      code_atom_int64 cg pos debug a2 (fun ohi2 olo2 ->
         (* TEMP: Cannot eliminate explicit var declarations *)
         let vhi = Register (new_symbol_string "binop_int64_hi") in
         let vlo = Register (new_symbol_string "binop_int64_lo") in
         let blocks, label = cont vhi vlo in
         let insts =
            `new insts:
               new   %rhi, %rlo;
               dcl   vhi,  vlo;

               movl  rhi,  ohi1;
               movl  rlo,  olo1;
               modify_listbuf `{ cons insts label (Register rhi) (Register rlo) ohi2 olo2 `};
               movl  vhi,  rhi;
               movl  vlo,  rlo;`
         in
         let block, label = code_build_dst_block debug "binop_int64" insts label in
            block :: blocks, label))


(* code_shift_binop_int64
   Writes the infrastructure required for a 64-bit shift.  *)
and code_shift_binop_int64 cg pos debug a1 a2 cont cons =
   let pos = string_pos "code_basic_binop_int64" pos in
   code_atom_int64 cg pos debug a1 (fun ohi1 olo1 ->
      code_atom_int64 cg pos debug a2 (fun ohi2 olo2 ->
         (* TEMP: Cannot remove explicit var decls here *)
         let vhi = Register (new_symbol_string "binop_int64_hi") in
         let vlo = Register (new_symbol_string "binop_int64_lo") in
         let blocks, label = cont vhi vlo in

         (* Build the code that will patch in/store result *)
         let insts, rhi, rlo =
            `new -> rhi, rlo:
               new   %rhi, %rlo;
               dcl   vhi,  vlo;
               movl  vhi,  rhi;
               movl  vlo,  rlo;`
         in
         let block, label = code_build_dst_block debug "binop_int64" insts label in
         let blocks = block :: blocks in

         (* Build the code to load and shift *)
         let insts =
            `new insts:
               dcl   rhi,  rlo;
               movl  rhi,  ohi1;
               movl  rlo,  olo1;
               modify_listbuf `{ cons insts label rhi rlo ohi2 olo2 `};`
         in
         let block, label = code_build_dst_block debug "binop_int64" insts label in
            block :: blocks, label))


(* code_binop_int64
   Codes a typical binary operator, where conshi and conslo build the
   opcodes for building the high and low 32-bits, respectively.  The
   low-order bits will be built first so the high-order constructor may
   take advantage of such things as the flags set by the low constructor
   (carry, borrow, etc).  *)
and code_binop_int64 cg pos debug a1 a2 cont conshi conslo =
   let pos = string_pos "code_binop_int64" pos in
   code_basic_binop_int64 cg pos debug a1 a2 cont (fun insts label ohi1 olo1 ohi2 olo2 ->
      `+insts:
         new   %rhi2,   %rlo2;
         movl  rlo2,    olo2;
         add_inst `{ conslo olo1 (Register rlo2) `};
         movl  rhi2,    ohi2;
         add_inst `{ conshi ohi1 (Register rhi2) `};`)


(* code_let_mem_int64
   Reads an int64 value from memory.  This simply looks like two int32
   memory read operations, so lets build it up to look that way.  *)
and code_let_mem_int64 cg pos debug aptr aofs cont =
   let pos = string_pos "code_let_mem_int64" pos in
   let int_class = Rawint.Int32, true in
   let offset = Rawint.of_int Rawint.Int32 true sizeof_int32 in
   let alo, ahi = aofs, AtomBinop (PlusOp (ACRawInt (Rawint.Int32, true)), aofs, AtomRawInt offset) in
   code_let_mem_int32 cg pos debug int_class aptr alo (fun vlo ->
      code_let_mem_int32 cg pos debug int_class aptr ahi (fun vhi ->
         cont vhi vlo))


(* code_atom_int64
   Builds blocks to compute the atom expression given.  *)
and code_atom_int64 cg pos debug a cont =
   let pos = string_pos "code_atom_int64" pos in
   match a with
      (* Constants and variables *)
      AtomInt _
    | AtomFunVar _
    | AtomFloat _ ->
         raise (MirException (pos, ImplicitCoercion a))
    | AtomRawInt i when int32_ok (Rawint.precision i) ->
         raise (MirException (pos, ImplicitCoercion a))
    | AtomRawInt i ->
         let i = Rawint.to_int64 i in
         let mask = Int64.pred (Int64.shift_left Int64.one 32) in
         let ihi = Int64.to_int32 (Int64.shift_right_logical i 32) in
         let ilo = Int64.to_int32 (Int64.logand i mask) in
            cont (ImmediateNumber (OffNumber ihi)) (ImmediateNumber (OffNumber ilo))
    | AtomVar (ACRawInt (Rawint.Int64, _), v) ->
         let vhi, vlo = reg64_lookup cg pos v in
            cont (Register vhi) (Register vlo)
    | AtomVar _ ->
         raise (MirException (pos, ImplicitCoercion a))

      (* Unary arithmetic *)
    | AtomUnop (UMinusOp (ACRawInt (Rawint.Int64, signed)), a) ->
         code_basic_unop_int64 cg pos debug a cont (fun insts label ohi olo ->
            `+insts:
               notl  ohi;
               negl  olo;
               sbbl  ohi,  $-1;`)
    | AtomUnop (NotOp (ACRawInt (Rawint.Int64, signed)), a) ->
         let cons op = NOT (IL, op) in
            code_unop_int64 cg pos debug a cont cons cons

      (* Coercions *)
    | AtomUnop (RawIntOfFloatOp (Rawint.Int64, true, _), a) ->
         code_int64_of_float cg pos debug a cont
    | AtomUnop (RawIntOfFloatOp (Rawint.Int64, false, _), a) ->
         atom_warning "coercion from float to unsigned will be treated as coercion from float to signed, expect range errors";
         code_int64_of_float cg pos debug a cont
    | AtomUnop (RawIntOfRawIntOp (Rawint.Int64, dsigned, spre, ssigned), a) when dsigned = ssigned ->
         code_int64_of_rawint cg pos debug spre ssigned a cont
    | AtomUnop (RawIntOfRawIntOp (Rawint.Int64, dsigned, Rawint.Int64, ssigned), a) ->
         (* sign change on same precision *)
         code_int64_of_rawint cg pos debug Rawint.Int64 ssigned a cont
    | AtomUnop (RawIntOfRawIntOp (Rawint.Int64, dsigned, spre, ssigned), a) when dsigned <> ssigned ->
         atom_warning "in coercions that change signedness, source sign wins in any bit extensions";
         code_int64_of_rawint cg pos debug spre ssigned a cont

      (* Unknown unary *)
    | AtomUnop (_, _) ->
         raise (MirException (pos, NotImplemented "code_atom_int64: AtomUnop"))

      (* Binary arithmetic operations *)
    | AtomBinop (PlusOp (ACRawInt (Rawint.Int64, _)), a1, a2) ->
         code_binop_int64 cg pos debug a1 a2 cont (fun op1 op2 -> ADC (IL, op1, op2)) (fun op1 op2 -> ADD (IL, op1, op2))
    | AtomBinop (MinusOp (ACRawInt (Rawint.Int64, _)), a1, a2) ->
         code_binop_int64 cg pos debug a1 a2 cont (fun op1 op2 -> SBB (IL, op1, op2)) (fun op1 op2 -> SUB (IL, op1, op2))
    | AtomBinop (MulOp (ACRawInt (Rawint.Int64, false)), a1, a2) ->
         (* Unsigned multiplication is easier *)
         code_basic_binop_int64 cg pos debug a1 a2 cont (fun insts label ohi1 olo1 ohi2 olo2 ->
            `+insts:
               new   %rhi, %rlo;

               (* Multiply the high-order bits -- here it gets murky *)
               movl  eax,  olo1;
               mull  ohi2;
               movl  rhi,  eax;
               movl  eax,  ohi1;
               mull  olo2;
               addl  rhi,  eax;

               (* Multiply the low-order bits, add carry to rhi *)
               movl  eax,  olo1;
               mull  olo2;
               movl  olo1, eax;
               addl  rhi,  edx;
               movl  ohi1, rhi;`)
    | AtomBinop (MulOp (ACRawInt (Rawint.Int64, true)), a1, a2) ->
         (* Signed multiplication will use the FP stack -- for now *)
         let a1 = AtomUnop (FloatOfRawIntOp (Rawfloat.LongDouble, Rawint.Int64, true), a1) in
         let a2 = AtomUnop (FloatOfRawIntOp (Rawfloat.LongDouble, Rawint.Int64, true), a2) in
         let a  = AtomBinop (MulOp (ACFloat Rawfloat.LongDouble), a1, a2) in
         let a  = AtomUnop  (RawIntOfFloatOp (Rawint.Int64, true, Rawfloat.LongDouble), a) in
            code_atom_int64 cg pos debug a cont
    | AtomBinop (DivOp (ACRawInt (Rawint.Int64, true)), a1, a2) ->
         (* Signed division will use the FP stack -- for now *)
         let a1 = AtomUnop (FloatOfRawIntOp (Rawfloat.LongDouble, Rawint.Int64, true), a1) in
         let a2 = AtomUnop (FloatOfRawIntOp (Rawfloat.LongDouble, Rawint.Int64, true), a2) in
         let a  = AtomBinop (DivOp (ACFloat Rawfloat.LongDouble), a1, a2) in
         let a  = AtomUnop  (RawIntOfFloatOp (Rawint.Int64, true, Rawfloat.LongDouble), a) in
            code_atom_int64 cg pos debug a cont
    | AtomBinop (AndOp (ACRawInt (Rawint.Int64, _)), a1, a2) ->
         let logop op1 op2 = AND (IL, op1, op2) in
            code_binop_int64 cg pos debug a1 a2 cont logop logop
    | AtomBinop (OrOp (ACRawInt (Rawint.Int64, _)), a1, a2) ->
         let logop op1 op2 = OR (IL, op1, op2) in
            code_binop_int64 cg pos debug a1 a2 cont logop logop
    | AtomBinop (XorOp (ACRawInt (Rawint.Int64, _)), a1, a2) ->
         let logop op1 op2 = XOR (IL, op1, op2) in
            code_binop_int64 cg pos debug a1 a2 cont logop logop
    | AtomBinop (SlOp (ACRawInt (Rawint.Int64, signed)), a1, a2) ->
         code_shift_binop_int64 cg pos debug a1 a2 cont (fun insts label ohi1 olo1 ohi2 olo2 ->
            `+insts:
               movl  ecx,  olo2;
               shldl ohi1, olo1, ecx;
               shll  olo1, ecx;
               testl ecx,  $32;
               je    label;
               movl  ohi1, olo1;
               movl  olo1, $0;`)
    | AtomBinop (ASrOp (ACRawInt (Rawint.Int64, signed)), a1, a2) ->
         code_shift_binop_int64 cg pos debug a1 a2 cont (fun insts label ohi1 olo1 ohi2 olo2 ->
            `+insts:
               movl  ecx,  olo2;
               shrdl olo1, ohi1, ecx;
               sarl  ohi1, ecx;
               testl ecx,  $32;
               je    label;
               movl  olo1, ohi1;
               sarl  ohi1, $31;`)
    | AtomBinop (LSrOp (ACRawInt (Rawint.Int64, signed)), a1, a2) ->
         code_shift_binop_int64 cg pos debug a1 a2 cont (fun insts label ohi1 olo1 ohi2 olo2 ->
            `+insts:
               movl  ecx,  olo2;
               shrdl olo1, ohi1, ecx;
               shrl  ohi1, ecx;
               testl ecx,  $32;
               je    label;
               movl  olo1, ohi1;
               movl  ohi1, $0;`)

      (* Binary memory operations *)
    | AtomBinop (MemOp (ACRawInt (Rawint.Int64, _), _), a1, a2) ->
         code_let_mem_int64 cg pos debug a1 a2 cont

      (* Unknown binary *)
    | AtomBinop (_, _, _) ->
         raise (MirException (pos, NotImplemented "code_atom_int64: AtomBinop"))


(***  Floating-point Operations  ***)


(* code_float_const
   Writes the code necessary to load a constant into a floating-point
   register.  This just looks up the label that the constant is stored
   at and substitutes it in the continuation.  *)
and code_float_const cg pos debug f cont =
   let pos = string_pos "code_float_const" pos in
   let f = Rawfloat.to_float80 f in
   let v = fvals_lookup cg pos f in
      cont v


(* code_unop_float
   Writes code for a unary floating-point operation that reads its
   sole input from %st(0) and writes the result to same register.  *)
and code_unop_float cg pos debug a cont cons =
   let pos = string_pos "code_unop_float" pos in
   code_atom_float cg pos debug a (fun op ->
      let insts, v =
         `new -> v:
            new   @v;
            fldt  op;
            add_inst `{ cons `};
            fstpt v;`
      in
         build_atom_block debug "unop" insts v cont)


(* code_basic_binop_float
   Writes the infrastructure used by most binary operations.  *)
and code_basic_binop_float cg pos debug a1 a2 cont =
   let pos = string_pos "code_basic_binop_float" pos in
   let v = FloatRegister (new_symbol_string "binop_res") in
   code_atom_float cg pos debug a1 (fun op1 ->
      code_atom_float cg pos debug a2 (fun op2 ->
         cont v op1 op2))


(* code_binop_float
   Writes a binary operator of two floats, where the binary operation
   in question is a no-operand that reads both values from the stack,
   pops the stack and stores the result in the new top-of-stack.  There
   may be other forms of this function for instructions which must take
   an argument, or require the arguments to be put on stack in reverse
   order.  *)
and code_binop_float cg pos debug a1 a2 cont cons =
   let pos = string_pos "code_binop_float" pos in
   code_basic_binop_float cg pos debug a1 a2 (fun v op1 op2 ->
      let insts, v =
         `new -> v:
            new   @v;
            fldt  op2;        (* This will be %st(1) *)
            fldt  op1;        (* This will be %st(0) *)
            add_inst `{ cons `};
            fstpt v;`
      in
         build_atom_block debug "binop" insts v cont)


(* code_binop_pop_float
   Same as above, but cons doesn't pop the stack, so we do it ourselves.  *)
and code_binop_pop_float cg pos debug a1 a2 cont cons =
   let pos = string_pos "code_binop_pop_float" pos in
   code_basic_binop_float cg pos debug a1 a2 (fun v op1 op2 ->
      let insts, v =
         `new -> v:
            new   @v;
            fldt  op2;        (* This will be %st(1) *)
            fldt  op1;        (* This will be %st(0) *)
            add_inst `{ cons `};
            fstpt v;
            fstpt @st(0);`
      in
         build_atom_block debug "binop" insts v cont)


(* code_let_mem_float
   Reads a floating-point value from memory.  We can mostly reuse
   code that is constructed earlier, only varying the final load
   (which we use the FP stack as an intermediary for, in convenience). *)
and code_let_mem_float cg pos debug float_class a1 a2 cont =
   let pos = string_pos "code_let_mem_float" pos in
   let v = FloatRegister (new_symbol_string "let_mem") in
   let float_class = float_prec float_class in
   let load_insts_float operand insts =
      let insts = Listbuf.add_list insts
         [CommentString "Loading a float from memory";
          FMOVP (FT, v, float_class, operand)]
      in
      let blocks, label = cont v in
      let block, label = code_build_dst_block debug "code_let_mem_float" insts label in
         block :: blocks, label
   in
      code_let_mem_aux cg pos debug a1 a2 load_insts_float


(* code_binop_float_max
   code_binop_float_min
   Computes max- and min-code for floating-point values.  This is
   more optimized than doing the computation in FIR, since we can
   do the branch optimization here.  *)
and code_binop_float_max cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_float_max" pos in
      code_basic_binop_float cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_float_op debug GT cont v op1 op2 op1 op2)

and code_binop_float_min cg pos debug a1 a2 cont =
   let pos = string_pos "code_binop_float_min" pos in
      code_basic_binop_float cg pos debug a1 a2 (fun v op1 op2 ->
         code_cond_float_op debug LT cont v op1 op2 op1 op2)


(* code_atom_float
   Builds blocks to compute the atom expression given.  *)
and code_atom_float cg pos debug a cont =
   let pos = string_pos "code_atom_float" pos in
   match a with
      (* Constants and variables *)
      AtomInt _
    | AtomRawInt _
    | AtomFunVar _ ->
         raise (MirException (pos, ImplicitCoercion a))
    | AtomVar (ACFloat _, v) ->
         cont (FloatRegister v)
    | AtomVar _ ->
         raise (MirException (pos, ImplicitCoercion a))
    | AtomFloat x ->
         code_float_const cg pos debug x cont

      (* Unary arithmetic & bitwise operations *)
    | AtomUnop (UMinusOp (ACFloat _), a) ->
         code_unop_float cg pos debug a cont FCHS
    | AtomUnop (FloatOfRawIntOp (_, pre, true), a) when int32_ok pre ->
         code_float_of_int32 cg pos debug a cont
    | AtomUnop (FloatOfRawIntOp (_, Rawint.Int64, true), a) ->
         code_float_of_int64 cg pos debug a cont

      (* Unary FloatOfFloat is an identity *)
    | AtomUnop (FloatOfFloatOp _, a) ->
         code_atom_float cg pos debug a cont

      (* Unary triginometric and roots *)
    | AtomUnop (SinOp _, a) ->
         code_unop_float cg pos debug a cont FSIN
    | AtomUnop (CosOp _, a) ->
         code_unop_float cg pos debug a cont FCOS
    | AtomUnop (SqrtOp _, a) ->
         code_unop_float cg pos debug a cont FSQRT

      (* Unknown unary *)
    | AtomUnop (_, _) ->
         raise (MirException (pos, NotImplemented "code_atom_float: AtomUnop"))

      (* Addition and subtraction *)
    | AtomBinop (PlusOp (ACFloat _), a1, a2) ->
         code_binop_float cg pos debug a2 a1 cont FADDP
    | AtomBinop (MinusOp (ACFloat _), a1, a2) ->
         code_binop_float cg pos debug a1 a2 cont FSUBP
    | AtomBinop (MulOp (ACFloat _), a1, a2) ->
         code_binop_float cg pos debug a2 a1 cont FMULP
    | AtomBinop (DivOp (ACFloat _), a1, a2) ->
         code_binop_float cg pos debug a1 a2 cont FDIVP
    | AtomBinop (RemOp (ACFloat _), a1, a2) ->
         code_binop_pop_float cg pos debug a1 a2 cont FPREM

      (* Bounds operations *)
    | AtomBinop (MaxOp (ACFloat _), a1, a2) ->
         code_binop_float_max cg pos debug a1 a2 cont
    | AtomBinop (MinOp (ACFloat _), a1, a2) ->
         code_binop_float_min cg pos debug a1 a2 cont

      (* Triginometric operations *)
    | AtomBinop (ATan2Op _, a1, a2) ->
         code_binop_pop_float cg pos debug a1 a2 cont FPATAN

      (* Binary memory operations *)
    | AtomBinop (MemOp (ACFloat fprec, _), a1, a2) ->
         code_let_mem_float cg pos debug fprec a1 a2 cont

      (* Unknown binary *)
    | AtomBinop (_, _, _) ->
         raise (MirException (pos, NotImplemented "code_atom_float: AtomBinop"))


`end_ocaml_code