path: root/asmcomp/emit_m68k.mlp

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Emission of Motorola 68020 assembly code (MIT syntax) *)

open Misc
open Cmm
open Arch
open Proc
open Reg
open Mach
open Linearize
open Emitaux

(* Tradeoff between code size and code speed *)

let fastcode_flag = ref true

let stack_offset = ref 0

(* Layout of the stack frame *)

let frame_size () =                     (* includes return address *)
  !stack_offset +
  4 * (num_stack_slots.(0) + num_stack_slots.(1)) +
  8 * num_stack_slots.(2) +
  4 (* return address *)

let slot_offset loc cl =
  match loc with
    Incoming n -> frame_size() + n
  | Local n ->
      if cl = 0
      then !stack_offset + n * 4
      else if cl = 1
      then !stack_offset + num_stack_slots.(0) * 4 + n * 4
      else !stack_offset +
           (num_stack_slots.(0) + num_stack_slots.(1)) * 4 + n * 8
  | Outgoing n -> n

(* Output a symbol *)

let emit_symbol s =
  emit_char '_'; Emitaux.emit_symbol '$' s

(* Output a label *)

let emit_label lbl =
  emit_char 'L'; emit_int lbl

(* Output an align directive *)

let emit_align n =
  `	.align	{emit_int n}\n`

(* Output a pseudo-register *)

let emit_reg = function
    { loc = Reg r } ->
      emit_string (register_name r)
  | { loc = Stack s } as r ->
      let ofs = slot_offset s (register_class r) in
      if ofs = 0
      then `a7@`
      else `a7@({emit_int ofs})`
  | { loc = Unknown } ->
      fatal_error "Emit_m68k.emit_reg"

(* Check if the given register is an address register *)

let is_address_reg = function { loc = Reg _; typ = Addr } -> true | _ -> false

(* Check if the given register overlaps (same location) with the given
   array of registers *)

let register_overlap reg arr =
  try
    for i = 0 to Array.length arr - 1 do
      if reg.loc = arr.(i).loc then raise Exit
    done;
    false
  with Exit ->
    true

(* Output a suffix for a floating-point instruction -- either .x if
   the argument is a register or .d if it's in memory. *)

let emit_float_size r =
  match r.loc with
    Reg _ -> `x`
  | _ -> `d`

let emit_float_size2 r1 r2 =
  match (r1.loc, r2.loc) with
    (Reg _, Reg _) -> `x`
  | _ -> `d`

(* Output an addressing mode *)

let emit_displacement d =
  if d <> 0 then `{emit_int d}, `

let emit_addressing addr r n =
  match addr with
    Ibased(s, d) ->
      `{emit_symbol s}`;
      if d <> 0 then ` + {emit_int d}`
  | Iindexed d ->
      `{emit_reg r.(n)}@`;
      if d <> 0 then `({emit_int d})`
  | Iindexed2 d ->
      `{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l)`
  | Iscaled(scale, d) ->
      `@({emit_int d}, {emit_reg r.(n)}:l:{emit_int scale})`
  | Iindexed2scaled(scale, d) ->
      `{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l:{emit_int scale})`

(* Record live pointers at call points *)

type frame_descr =
  { fd_lbl: int;                        (* Return address *)
    fd_frame_size: int;                 (* Size of stack frame *)
    fd_live_offset: int list }          (* Offsets/regs of live addresses *)

let frame_descriptors = ref([] : frame_descr list)

let record_frame_label live =
  let lbl = new_label() in
  let live_offset = ref [] in
  Reg.Set.iter
    (function
        {typ = Addr; loc = Reg r} ->
          live_offset := ((r lsl 1) + 1) :: !live_offset
      | {typ = Addr; loc = Stack s} as reg ->
          live_offset := slot_offset s (register_class reg) :: !live_offset
      | _ -> ())
    live;
  frame_descriptors :=
    { fd_lbl = lbl;
      fd_frame_size = frame_size();
      fd_live_offset = !live_offset } :: !frame_descriptors;
  lbl

let record_frame live =
  let lbl = record_frame_label live in `{emit_label lbl}:\n`

let emit_frame fd =
  `	.long	{emit_label fd.fd_lbl}\n`;
  `	.word	{emit_int fd.fd_frame_size}\n`;
  `	.word	{emit_int (List.length fd.fd_live_offset)}\n`;
  List.iter
    (fun n ->
      `	.word	{emit_int n}\n`)
    fd.fd_live_offset;
  emit_align 4

(* Names for instructions *)

let instr_for_intop = function
    Iadd -> "addl"
  | Isub -> "subl"
  | Imul -> "mulsl"
  | Idiv -> "divsl"
  | Iand -> "andl"
  | Ior -> "orl"
  | Ixor -> "eorl"
  | Ilsl -> "lsll"
  | Ilsr -> "lsrl"
  | Iasr -> "asrl"
  | _ -> fatal_error "Emit_m68k: instr_for_intop"

let instr_for_floatop = function
    Inegf -> "fneg"
  | Iabsf -> "fabs"
  | Iaddf -> "fadd"
  | Isubf -> "fsub"
  | Imulf -> "fmul"
  | Idivf -> "fdiv"
  | _ -> fatal_error "Emit_m68k: instr_for_floatop"

let name_for_cond_branch = function
    Isigned Ceq -> "eq"    | Isigned Cne -> "ne"
  | Isigned Cle -> "le"    | Isigned Cgt -> "gt"
  | Isigned Clt -> "lt"    | Isigned Cge -> "ge"
  | Iunsigned Ceq -> "eq"  | Iunsigned Cne -> "ne"
  | Iunsigned Cle -> "ls"  | Iunsigned Cgt -> "hi"
  | Iunsigned Clt -> "cs"  | Iunsigned Cge -> "cc"
    
let name_for_float_cond_branch cond neg =
  match cond with
    Ceq -> if neg then "ne" else "eq"
  | Cne -> if neg then "eq" else "ne"
  | Cle -> if neg then "ugt" else "ole"
  | Cgt -> if neg then "ule" else "ogt"
  | Clt -> if neg then "uge" else "olt"
  | Cge -> if neg then "ult" else "oge"

(* Emit an immediate move in the given data register *)

let emit_move_immediate n dreg =
  if n >= -128 && n < 128
  then `	moveq	#{emit_int n}, {emit_string dreg}\n`
  else `	movel	#{emit_int n}, {emit_string dreg}\n`

(* Offset the stack by the given amount of bytes *)

let output_stack_offset n =
  if n > 0 && n <= 8 then
    `	subql	#{emit_int(n)}, a7\n`
  else if n < 0 && n >= -8 then
    `	addql	#{emit_int(-n)}, a7\n`
  else
    `	addw	#{emit_int(-n)}, a7\n`

(* Deallocate the stack frame before a return or tail call *)

let output_epilogue () =
  let n = frame_size() - 4 in
  if n > 0 then output_stack_offset (-n)

(* Record the state of the condition codes *)

type condition_code = CCundefined | CCreflect of Reg.t

let cc_state = ref CCundefined

let undef_cc () =
  cc_state := CCundefined

let set_cc reg =
  cc_state := CCreflect reg

let output_test reg =
  match !cc_state with
    CCreflect r when r.loc = reg.loc -> ()
  | _ ->
      `	tstl	{emit_reg reg}\n`;
      cc_state := CCreflect reg

(* Output the assembly code for an instruction *)

(* Name of current function *)
let function_name = ref ""
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
(* Label of trap for out-of-range accesses *)
let range_check_trap = ref 0

let emit_instr i =
    match i.desc with
      Lend -> ()
    | Lop(Imove | Ispill | Ireload) ->
        let src = i.arg.(0) and dst = i.res.(0) in
        if src.loc <> dst.loc then begin
          match (src, dst) with
            ({typ = Float; loc = Stack ss}, {loc = Stack sd}) ->
              let os = slot_offset ss 2 in
              let od = slot_offset sd 2 in
              `	movel	({emit_int os}, a7), ({emit_int od}, a7)\n`;
              `	movel	({emit_int (os+4)}, a7), ({emit_int (od+4)}, a7)\n`;
              undef_cc()
          | ({typ = Float}, _) ->
              `	fmove{emit_float_size2 src dst}	{emit_reg src}, {emit_reg dst}\n`
          | (_, _) ->
              `	movel	{emit_reg src}, {emit_reg dst}\n`;
              set_cc dst
        end
    | Lop(Iconst_int n) ->
        begin match i.res.(0) with
          {typ = Addr; loc = Reg _} ->
            if n >= -32768 && n < 32768 then
              `	movew	#{emit_int n}, {emit_reg i.res.(0)}\n`
            else
              `	movel	#{emit_int n}, {emit_reg i.res.(0)}\n`
        | _ when n = 0 ->
            `	clrl	{emit_reg i.res.(0)}\n`;
            set_cc i.res.(0)
        | {typ = Int; loc = Reg _} when n >= -128 && n < 128 ->
            `	moveq	#{emit_int n}, {emit_reg i.res.(0)}\n`;
            set_cc i.res.(0)
        | _ ->
            `	movel	#{emit_int n}, {emit_reg i.res.(0)}\n`;
            set_cc i.res.(0)
        end
    | Lop(Iconst_float s) ->
        let f = float_of_string s in
        if f = 0.0 then
          `	fmovecr	#0x0F, {emit_reg i.res.(0)}\n`
        else if f = 1.0 then
          `	fmovecr	#0x32, {emit_reg i.res.(0)}\n`
        else
          `	fmoved	#0r{emit_string s}, {emit_reg i.res.(0)}\n`
    | Lop(Iconst_symbol s) ->
        `	lea	{emit_symbol s}, {emit_reg i.res.(0)}\n`
    | Lop(Icall_ind) ->
        `	jbsr	{emit_reg i.arg.(0)}@\n`;
        record_frame i.live;
        undef_cc()
    | Lop(Icall_imm s) ->
        `	jbsr	{emit_symbol s}\n`;
        record_frame i.live;
        undef_cc()
    | Lop(Itailcall_ind) ->
        output_epilogue();
        `	jmp	{emit_reg i.arg.(0)}@\n`;
        undef_cc()
    | Lop(Itailcall_imm s) ->
        if s = !function_name then
          `	bra	{emit_label !tailrec_entry_point}\n`
        else begin
          output_epilogue();
          `	jmp	{emit_symbol s}\n`
        end;
        undef_cc()
    | Lop(Iextcall(s, alloc)) ->
        if alloc then begin
          `	lea	{emit_symbol s}, a0\n`;
          `	jbsr	{emit_symbol "caml_c_call"}\n`;
          record_frame i.live
        end else begin
          `	jbsr	{emit_symbol s}\n`
        end;
        if Array.length i.res > 0 && i.res.(0).typ = Float then begin
          `	movel	d1, a7@-\n`;
          `	movel	d0, a7@-\n`;
          `	fmoved	a7@+, {emit_reg i.res.(0)}\n`
        end;
        undef_cc()
    | Lop(Istackoffset n) ->
        output_stack_offset n;
        stack_offset := !stack_offset + n;
        undef_cc()
    | Lop(Iload(chunk, addr)) ->
        let dest = i.res.(0) in
        begin match dest.typ with
          Int | Addr ->
            begin match chunk with
              Word ->
                `	movel	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
            | Byte_unsigned when not (register_overlap dest i.arg) ->
                `	clrl	{emit_reg dest}\n`;
                `	moveb	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
            | Byte_unsigned ->
                `	moveb	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
                `	andl	#0xFF, {emit_reg dest}\n`
            | Byte_signed ->
                `	moveb	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
                `	extbl	{emit_reg dest}\n`
            | Sixteen_unsigned when not (register_overlap dest i.arg) ->
                `	clrl	{emit_reg dest}\n`;
                `	movew	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
            | Sixteen_unsigned ->
                `	movew	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
                `	andl	#0xFFFF, {emit_reg dest}\n`
            | Sixteen_signed ->
                `	movew	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
                `	extl	{emit_reg dest}\n`
            end;
            set_cc dest
        | Float ->
            `	fmoved	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
        end
    | Lop(Istore(chunk, addr)) ->
        let src = i.arg.(0) in
        let instr =
          match src.typ with
            Int ->
              begin match chunk with
                Word -> "movel"
              | Byte_unsigned | Byte_signed -> "moveb"
              | Sixteen_unsigned | Sixteen_signed -> "movew"
              end
          | Addr -> "movel"
          | Float -> "fmoved" in
        `	{emit_string instr}	{emit_reg src}, {emit_addressing addr i.arg 1}\n`;
        undef_cc()
    | Lop(Ialloc n) ->
        if !fastcode_flag then begin
          let lbl_frame = record_frame_label i.live in
          `	subl	#{emit_int n}, d6\n`;
          `	cmpl	{emit_symbol "young_limit"}, d6\n`;
          `	bcc	{emit_label lbl_frame}\n`;
          emit_move_immediate n "d5";
          `	jbsr	{emit_symbol "caml_call_gc"}\n`;
          `{emit_label lbl_frame}:	movel	d6, {emit_reg i.res.(0)}\n`;
          `	addql	#4, {emit_reg i.res.(0)}\n`
        end else begin
          begin match n with
            8  -> `	jbsr	{emit_symbol "caml_alloc1"}\n`
          | 12 -> `	jbsr	{emit_symbol "caml_alloc2"}\n`
          | 16 -> `	jbsr	{emit_symbol "caml_alloc3"}\n`
          | _  -> emit_move_immediate n "d5";
                  `	jbsr	{emit_symbol "caml_alloc"}\n`
          end;
          `{record_frame i.live}	movel	d6, {emit_reg i.res.(0)}\n`;
          `	addql	#4, {emit_reg i.res.(0)}\n`
        end;
        undef_cc()
    | Lop(Iintop(Icomp cmp)) ->
        `	cmpl	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
        let b = name_for_cond_branch cmp in
        `	s{emit_string b}	{emit_reg i.res.(0)}\n`;
        `	negb	{emit_reg i.res.(0)}\n`;
        `	extbl	{emit_reg i.res.(0)}\n`;
        set_cc i.res.(0)
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        `	cmpl	#{emit_int n}, {emit_reg i.arg.(0)}\n`;
        let b = name_for_cond_branch cmp in
        `	s{emit_string b}	{emit_reg i.res.(0)}\n`;
        `	negb	{emit_reg i.res.(0)}\n`;
        `	extbl	{emit_reg i.res.(0)}\n`;
        set_cc i.res.(0)
    | Lop(Iintop Icheckbound) ->
        if !range_check_trap = 0 then range_check_trap := new_label();
        `	cmpl	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
        `	bls	{emit_label !range_check_trap}\n`
    | Lop(Iintop_imm(Icheckbound, n)) ->
        if !range_check_trap = 0 then range_check_trap := new_label();
        `	cmpl	#{emit_int n}, {emit_reg i.arg.(0)}\n`;
        `	bls	{emit_label !range_check_trap}\n`
    | Lop(Iintop_imm(Iadd, n)) -> 
        let dest = i.res.(0) in
        begin match dest with
          {loc = Reg _} when n > 0 && n <= 8 ->
            `	addql	#{emit_int n}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        | {loc = Reg _} when n < 0 && n >= -8 ->
            `	subql	#{emit_int(-n)}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        | _ ->
            `	addl	#{emit_int n}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        end
    | Lop(Iintop_imm(Isub, n)) -> 
        let dest = i.res.(0) in
        begin match dest with
          {loc = Reg _} when n > 0 && n <= 8 ->
            `	subql	#{emit_int n}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        | {loc = Reg _} when n < 0 && n >= -8 ->
            `	addql	#{emit_int(-n)}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        | _ ->
            `	subl	#{emit_int n}, {emit_reg dest}\n`;
            set_cc i.res.(0)
        end
    | Lop(Iintop_imm(Idiv, n)) when n = 1 lsl (Misc.log2 n) ->
        let l = Misc.log2 n in
        let lbl = new_label() in
        output_test i.arg.(0);
        `	bge	{emit_label lbl}\n`;
        `	addl	#{emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
        `{emit_label lbl}:`;
        if l <= 8 then
          `	asrl	#{emit_int l}, {emit_reg i.arg.(0)}\n`
        else begin
          `	moveq	#{emit_int l}, d5\n`;
          `	asrl	d0, {emit_reg i.arg.(0)}\n`
        end;
        set_cc i.res.(0)
    | Lop(Iintop Imod) ->
        `	movel	{emit_reg i.arg.(0)}, d5\n`;
        `	divsll	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}:d5\n`;
        undef_cc()
    | Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) ->
        let l = Misc.log2 n in
        let lbl = new_label() in
        `	movel	{emit_reg i.arg.(0)}, d5\n`;
          `	bge	{emit_label lbl}\n`;
          `	addl	#{emit_int(n-1)}, d5\n`;
          `{emit_label lbl}:	andl	#{emit_int(-n)}, d5\n`;
          `	subl	d5, {emit_reg i.arg.(0)}\n`;
        set_cc i.res.(0)
    | Lop(Iintop_imm(Imod, n)) ->
        `	movel	{emit_reg i.arg.(0)}, d5\n`;
        `	divsll	#{emit_int n}, {emit_reg i.res.(0)}:d5\n`;
        undef_cc()
    | Lop(Iintop op) ->
        (* We have i.arg.(0) = i.res.(0) *)
        `	{emit_string(instr_for_intop op)}	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
        set_cc i.res.(0)
    | Lop(Iintop_imm(op, n)) ->
        (* We have i.arg.(0) = i.res.(0) *)
        `	{emit_string(instr_for_intop op)}	#{emit_int n}, {emit_reg i.res.(0)}\n`;
        set_cc i.res.(0)
    | Lop(Inegf | Iabsf as floatop) ->
        `	{emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(0)}	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
        `	{emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(1)}	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Ifloatofint) ->
        `	fmovel	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintoffloat) ->
        `	fintrz{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, fp0\n`;
        `	fmovel	fp0, {emit_reg i.res.(0)}\n`;
        undef_cc()
    | Lop(Ispecific(Ilea addr)) ->
        `	lea	{emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
    | Lop(Ispecific(Istore_int(n, addr))) ->
        if n = 0 then
          `	clrl	{emit_addressing addr i.arg 0}\n`
        else
          `	movel	#{emit_int n}, {emit_addressing addr i.arg 0}\n`;
        undef_cc()
    | Lop(Ispecific(Istore_symbol(s, addr))) ->
        `	movel	#{emit_symbol s}, {emit_addressing addr i.arg 0}\n`;
        undef_cc()
    | Lop(Ispecific(Ipush)) ->
        (* Push arguments in reverse order *)
        for n = Array.length i.arg - 1 downto 0 do
          let r = i.arg.(n) in
          match r with
            {loc = Reg _; typ = Float} ->
              `	fmoved	{emit_reg r}, a7@-\n`;
              stack_offset := !stack_offset + 8
          | {loc = Stack sl; typ = Float} ->
              let ofs = slot_offset sl 2 in
              `	movel	({emit_int(ofs + 4)}, a7), a7@-\n`;
              `	movel	({emit_int(ofs + 4)}, a7), a7@-\n`;
              stack_offset := !stack_offset + 8
          | _ ->
              `	movel	{emit_reg r}, a7@-\n`;
              stack_offset := !stack_offset + 4
        done;
        undef_cc()
    | Lop(Ispecific(Ipush_int n)) ->
        `	movel	#{emit_int n}, a7@-\n`;
        stack_offset := !stack_offset + 4;
        undef_cc()
    | Lop(Ispecific(Ipush_symbol s)) ->
        `	pea	{emit_symbol s}\n`;
        stack_offset := !stack_offset + 4;
        undef_cc()
    | Lop(Ispecific(Ipush_load addr)) ->
        `	movel	{emit_addressing addr i.arg 0}, a7@-\n`;
        stack_offset := !stack_offset + 4;
        undef_cc()
    | Lop(Ispecific(Ipush_load_float addr)) ->
        `	movel	{emit_addressing (offset_addressing addr 4) i.arg 0}, a7@-\n`;
        `	movel	{emit_addressing addr i.arg 0}, a7@-\n`;
        stack_offset := !stack_offset + 8;
        undef_cc()
    | Lreloadretaddr ->
        ()
    | Lreturn ->
        output_epilogue();
        `	rts\n`;
        undef_cc()
    | Llabel lbl ->
        `{emit_label lbl}:\n`;
        undef_cc()
    | Lbranch lbl ->
        `	bra	{emit_label lbl}\n`
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            output_test i.arg.(0);
            `	bne	{emit_label lbl}\n`
        | Ifalsetest ->
            output_test i.arg.(0);
            `	beq	{emit_label lbl}\n`
        | Iinttest cmp ->
            `	cmpl	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
            let b = name_for_cond_branch cmp in
            `	b{emit_string b}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, 0) ->
            output_test i.arg.(0);
            let b = name_for_cond_branch cmp in
            `	b{emit_string b}	{emit_label lbl}\n`
        | Iinttest_imm(cmp, n) ->
            `	cmpl	#{emit_int n}, {emit_reg i.arg.(0)}\n`;
            let b = name_for_cond_branch cmp in
            `	b{emit_string b}	{emit_label lbl}\n`
        | Ifloattest(cmp, neg) ->
            `	fcmp{emit_float_size2 i.arg.(0) i.arg.(1)}	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
            let b = name_for_float_cond_branch cmp neg in
            `	fb{emit_string b}	{emit_label lbl}\n`
        | Ioddtest ->
            begin match i.arg.(0) with
              {typ = Addr; loc = Reg _} as arg ->
                `	movel	{emit_reg arg}, d5\n`;
                `	btst	#0, d5\n`
            | arg ->
                `	btst	#0, {emit_reg arg}\n`
            end;
            `	bne	{emit_label lbl}\n`
        | Ieventest ->
            begin match i.arg.(0) with
              {typ = Addr; loc = Reg _} as arg ->
                `	movel	{emit_reg arg}, d5\n`;
                `	btst	#0, d5\n`
            | arg ->
                `	btst	#0, {emit_reg arg}\n`
            end;
            `	beq	{emit_label lbl}\n`
        end;
        undef_cc()
    | Lcondbranch3(lbl0, lbl1, lbl2) ->
        `	cmpl	#1, {emit_reg i.arg.(0)}\n`;
        begin match lbl0 with
          None -> ()
        | Some lbl -> `	blt	{emit_label lbl}\n`
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> `	beq	{emit_label lbl}\n`
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> `	bgt	{emit_label lbl}\n`
        end;
        undef_cc()
    | Lswitch jumptbl ->
        let lbl_load = new_label() in
        let lbl_table = new_label() in
        `{emit_label lbl_load}:	movew	pc@({emit_label lbl_table}-{emit_label lbl_load}-2:b, {emit_reg i.arg.(0)}:l:2), d0\n`;
        `	jmp	pc@(2, d0:w)\n`;
        `{emit_label lbl_table}:`;
        for i = 0 to Array.length jumptbl - 1 do
          `	.word	{emit_label jumptbl.(i)} - {emit_label lbl_table}\n`
        done;
        undef_cc()
    | Lsetuptrap lbl ->
        `	bsr	{emit_label lbl}\n`
    | Lpushtrap ->
        `	movel	d7, a7@-\n`;
        `	movel	a7, d7\n`;
        stack_offset := !stack_offset + 8;
        undef_cc()
    | Lpoptrap ->
        `	movel	a7@+, d7\n`;
        `	addql	#4, a7\n`;
        stack_offset := !stack_offset - 8;
        undef_cc()
    | Lraise ->
        `	movel	d7, a7\n`;
        `	movel	a7@+, d7\n`;
        `	rts\n`

let rec emit_all i =
  match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next

(* Emission of a function declaration *)

let fundecl fundecl =
  function_name := fundecl.fun_name;
  fastcode_flag := fundecl.fun_fast;
  tailrec_entry_point := new_label();
  stack_offset := 0;
  range_check_trap := 0;
  undef_cc();
  `	.text\n`;
  `	.globl	{emit_symbol fundecl.fun_name}\n`;
  `{emit_symbol fundecl.fun_name}:\n`;
  let n = frame_size() - 4 in
  if n > 0 then output_stack_offset n;
  `{emit_label !tailrec_entry_point}:\n`;
  emit_all fundecl.fun_body;
  if !range_check_trap > 0 then
    `{emit_label !range_check_trap}:	jbsr	{emit_symbol "array_bound_error"}\n`

(* Emission of data *)

let emit_item = function
    Cdefine_symbol s ->
      `	.globl	{emit_symbol s}\n`;
      `{emit_symbol s}:\n`
  | Cdefine_label lbl ->
      `{emit_label (10000 + lbl)}:\n`
  | Cint8 n ->
      `	.byte	{emit_int n}\n`
  | Cint16 n ->
      `	.word	{emit_int n}\n`
  | Cint n ->
      `	.long	{emit_int n}\n`
  | Cintlit n ->
      `	.long	{emit_string n}\n`
  | Cfloat f ->
      `	.double	0r{emit_string f}\n`
  | Csymbol_address s ->
      `	.long	{emit_symbol s}\n`
  | Clabel_address lbl ->
      `	.long	{emit_label (10000 + lbl)}\n`
  | Cstring s ->
      emit_string_directive "	.ascii	" s
  | Cskip n ->
      if n > 0 then `	.skip	{emit_int n}\n`
  | Calign n ->
      emit_align n

let data l =
  `	.data\n`;
  List.iter emit_item l

(* Beginning / end of an assembly file *)

let begin_assembly() =
  let lbl_begin = Compilenv.current_unit_name() ^ "_begin" in
  `	.data\n`;
  `	.globl	{emit_symbol lbl_begin}\n`;
  `{emit_symbol lbl_begin}:\n`

let end_assembly() =
  `	.data\n`;
  let lbl_end = Compilenv.current_unit_name() ^ "_end" in
  `	.globl	{emit_symbol lbl_end}\n`;
  `{emit_symbol lbl_end}:\n`;
  `	.long	0\n`;
  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
  `	.globl	{emit_symbol lbl}\n`;
  `{emit_symbol lbl}:\n`;
  `	.long	{emit_int (List.length !frame_descriptors)}\n`;
  List.iter emit_frame !frame_descriptors;
  frame_descriptors := []