emit.mlp

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Emission of HP PA-RISC assembly code *)

(* Must come before open Reg... *)
module StringSet =
  Set.Make(struct
    type t = string
    let compare = compare
  end)

open Location
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

(* Layout of the stack *)
(* Always keep the stack 8-aligned. *)

let stack_offset = ref 0

let frame_size () =
  let size =
    !stack_offset +
    4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
    (if !contains_calls then 4 else 0) in
  Misc.align size 8

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

(* Output a label *)

let emit_label lbl =
  emit_string "L$"; emit_int lbl

(* Output a symbol *)

let emit_symbol s =
  Emitaux.emit_symbol '$' s

(* Output a pseudo-register *)

let emit_reg r =
  match r.loc with
    Reg r -> emit_string (register_name r)
  | _ -> assert false

(* Output low address / high address prefixes *)

let low_prefix = "RR%"
let high_prefix = "LR%"

let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *)

let emit_int_low n = emit_string low_prefix; emit_int n
let emit_int_high n = emit_string high_prefix; emit_int n

let emit_nativeint_low n = emit_string low_prefix; emit_nativeint n
let emit_nativeint_high n = emit_string high_prefix; emit_nativeint n

let emit_symbol_low s =
  `RR%{emit_symbol s}-$global$`

let load_symbol_high s =
  `	addil	LR%{emit_symbol s}-$global$, %r27\n`

let load_symbol_offset_high s ofs =
  `	addil	LR%{emit_symbol s}-$global$+{emit_int ofs}, %r27\n`

(* Record imported and defined symbols *)

let used_symbols = ref StringSet.empty
let defined_symbols = ref StringSet.empty
let called_symbols = ref StringSet.empty

let use_symbol s =
  used_symbols := StringSet.add s !used_symbols
let define_symbol s =
  defined_symbols := StringSet.add s !defined_symbols
let call_symbol s =
  used_symbols := StringSet.add s !used_symbols;
  called_symbols := StringSet.add s !called_symbols

(* An external symbol is code if either it is branched to, or
   it is one of the caml_apply* caml_curry* caml_tuplify* special functions. *)

let code_imports = ["caml_apply"; "caml_curry"; "caml_tuplify"]

let match_prefix s pref =
  String.length s >= String.length pref
  && String.sub s 0 (String.length pref) = pref

let emit_import s =
  if not(StringSet.mem s !defined_symbols) then begin
    `	.import	{emit_symbol s}`;
    if StringSet.mem s !called_symbols
    || List.exists (match_prefix s) code_imports
    then `, code\n`
    else `, data\n`
  end

let emit_imports () =
  StringSet.iter emit_import !used_symbols;
  used_symbols := StringSet.empty;
  defined_symbols := StringSet.empty;
  called_symbols := StringSet.empty

(* Output an integer load / store *)

let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *)

let is_offset_native n = 
  n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192)

let emit_load instr addr arg dst =
  match addr with
    Ibased(s, 0) ->
        use_symbol s;
        load_symbol_high s;
        `	{emit_string instr}	{emit_symbol_low s}(%r1), {emit_reg dst}\n`
  | Ibased(s, ofs) ->
        use_symbol s;
        load_symbol_offset_high s ofs;
        `	{emit_string instr}	{emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n`
  | Iindexed ofs ->
      if is_offset ofs then
        `	{emit_string instr}	{emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}\n`
      else begin
        `	addil	{emit_int_high ofs}, {emit_reg arg.(0)}\n`;
        `	{emit_string instr}	{emit_int_low ofs}(%r1), {emit_reg dst}\n`
      end

let emit_store instr addr arg src =
  match addr with
    Ibased(s, 0) ->
        use_symbol s;
        load_symbol_high s;
        `	{emit_string instr}	{emit_reg src}, {emit_symbol_low s}(%r1)\n`
  | Ibased(s, ofs) ->
        use_symbol s;
        load_symbol_offset_high s ofs;
        `	{emit_string instr}	{emit_reg src}, {emit_symbol_low s}+{emit_int ofs}(%r1)\n`
  | Iindexed ofs ->
      if is_offset ofs then
        `	{emit_string instr}	{emit_reg src}, {emit_int ofs}({emit_reg arg.(1)})\n`
      else begin
        `	addil	{emit_int_high ofs}, {emit_reg arg.(0)}\n`;
        `	{emit_string instr}	{emit_reg src}, {emit_int_low ofs}(%r1)\n`
      end

(* Output a floating-point load / store *)

let emit_float_load addr arg dst doubleword =
  match addr with
    Ibased(s, 0) ->
        use_symbol s;
        load_symbol_high s;
        `	ldo	{emit_symbol_low s}(%r1), %r1\n`;
        `	fldws	0(%r1), {emit_reg dst}L\n`;
        if doubleword then
          `	fldws	4(%r1), {emit_reg dst}R\n`
  | Ibased(s, ofs) ->
        use_symbol s;
        load_symbol_offset_high s ofs;
        `	ldo	{emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`;
        `	fldws	0(%r1), {emit_reg dst}L\n`;
        if doubleword then
          `	fldws	4(%r1), {emit_reg dst}R\n`
  | Iindexed ofs ->
      if is_immediate ofs && (is_immediate (ofs+4) || not doubleword)
      then begin
        `	fldws	{emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}L\n`;
        if doubleword then
          `	fldws	{emit_int (ofs+4)}({emit_reg arg.(0)}), {emit_reg dst}R\n`
      end else begin
        if is_offset ofs then
          `	ldo	{emit_int ofs}({emit_reg arg.(0)}), %r1\n`
        else begin
          `	addil	{emit_int_high ofs}, {emit_reg arg.(0)}\n`;
          `	ldo	{emit_int_low ofs}(%r1), %r1\n`
        end;
        `	fldws	0(%r1), {emit_reg dst}L\n`;
        if doubleword then
          `	fldws	4(%r1), {emit_reg dst}R\n`
      end

let emit_float_store addr arg src doubleword =
  match addr with
    Ibased(s, 0) ->
        use_symbol s;
        load_symbol_high s;
        `	ldo	{emit_symbol_low s}(%r1), %r1\n`;
        `	fstws	{emit_reg src}L, 0(%r1)\n`;
        if doubleword then
          `	fstws	{emit_reg src}R, 4(%r1)\n`
  | Ibased(s, ofs) ->
        use_symbol s;
        load_symbol_offset_high s ofs;
        `	ldo	{emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`;
        `	fstws	{emit_reg src}L, 0(%r1)\n`;
        if doubleword then
          `	fstws	{emit_reg src}R, 4(%r1)\n`
  | Iindexed ofs ->
      if is_immediate ofs && (is_immediate (ofs+4) || not doubleword)
      then begin
        `	fstws	{emit_reg src}L, {emit_int ofs}({emit_reg arg.(1)})\n`;
        if doubleword then
          `	fstws	{emit_reg src}R, {emit_int(ofs+4)}({emit_reg arg.(1)})\n`
      end else begin
        if is_offset ofs then
          `	ldo	{emit_int ofs}({emit_reg arg.(1)}), %r1\n`
        else begin
          `	addil	{emit_int_high ofs}, {emit_reg arg.(1)}\n`;
          `	ldo	{emit_int_low ofs}(%r1), %r1\n`
        end;
        `	fstws	{emit_reg src}L, 0(%r1)\n`;
        if doubleword then
          `	fstws	{emit_reg src}R, 4(%r1)\n`
      end

(* Output an align directive. *)

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

(* 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 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;
  `{emit_label lbl}:\n`

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

(* Record floating-point constants *)

let float_constants = ref ([] : (int * string) list)

let emit_float_constants () =
  if Config.system = "hpux" then begin
    `	.space	$TEXT$\n`;
    `	.subspa	$LIT$\n`
  end else
    `	.text\n`;
  emit_align 8;
  List.iter
    (fun (lbl, cst) ->
      `{emit_label lbl}:`;
      emit_float64_split_directive ".long" cst)
    !float_constants;
  float_constants := []

(* Describe the registers used to pass arguments to a C function *)

let describe_call arg =
  `	.CALL	RTNVAL=NO`;
  let pos = ref 0 in
  for i = 0 to Array.length arg - 1 do
    if !pos < 4 then begin
      match arg.(i).typ with
        Float -> `, ARGW{emit_int !pos}=FR, ARGW{emit_int(!pos + 1)}=FU`;
                 pos := !pos + 2
      | _     -> `, ARGW{emit_int !pos}=GR`;
                 pos := !pos + 1
    end
  done;
  `\n`

(* Output a function call *)

let emit_call s retreg =
  call_symbol s;
  `	bl	{emit_symbol s}, {emit_string retreg}\n`

(* Names of various instructions *)

let name_for_int_operation = function
    Iadd -> "add"
  | Isub -> "sub"
  | Iand -> "and"
  | Ior -> "or"
  | Ixor -> "xor"
  | _ -> assert false

let name_for_float_operation = function
    Iaddf -> "fadd,dbl"
  | Isubf -> "fsub,dbl"
  | Imulf -> "fmpy,dbl"
  | Idivf -> "fdiv,dbl"
  | _ -> assert false

let name_for_specific_operation = function
    Ishift1add -> "sh1add"
  | Ishift2add -> "sh2add"
  | Ishift3add -> "sh3add"

let name_for_int_comparison = function
    Isigned Ceq -> "="      | Isigned Cne -> "<>"
  | Isigned Cle -> "<="     | Isigned Cgt -> ">"
  | Isigned Clt -> "<"      | Isigned Cge -> ">="
  | Iunsigned Ceq -> "="    | Iunsigned Cne -> "<>"
  | Iunsigned Cle -> "<<="  | Iunsigned Cgt -> ">>"
  | Iunsigned Clt -> "<<"   | Iunsigned Cge -> ">>="

let name_for_float_comparison cmp neg =
  match cmp with
    Ceq -> if neg then "=" else "!="
  | Cne -> if neg then "!=" else "="
  | Cle -> if neg then "<=" else "!<="
  | Cgt -> if neg then ">" else "!>"
  | Clt -> if neg then "<" else "!<"
  | Cge -> if neg then ">=" else "!>="

let negate_int_comparison = function
    Isigned cmp -> Isigned(Cmm.negate_comparison cmp)
  | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp)

let swap_int_comparison = function
    Isigned cmp -> Isigned(Cmm.swap_comparison cmp)
  | Iunsigned cmp -> Iunsigned(Cmm.swap_comparison cmp)


(* 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 rec emit_instr i dslot =
    match i.desc with
      Lend -> ()
    | Lop(Imove | Ispill | Ireload) ->
        let src = i.arg.(0) and dst = i.res.(0) in
        begin match (src, dst) with
            {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
              `	copy	{emit_reg src}, {emit_reg dst}\n`
          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
              `	fcpy,dbl {emit_reg src}, {emit_reg dst}\n`
          | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
              let ofs = slot_offset sd 0 in
              `	stw	{emit_reg src}, {emit_int ofs}(%r30)\n`
          | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
              let ofs = slot_offset sd 1 in
              if is_immediate ofs then
              `	fstds   {emit_reg src}, {emit_int ofs}(%r30)\n`
              else begin
              `	ldo	{emit_int ofs}(%r30), %r1\n`;
              `	fstds	{emit_reg src}, 0(%r1)\n`
              end
          | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
              let ofs = slot_offset ss 0 in
              `	ldw	{emit_int ofs}(%r30), {emit_reg dst}\n`
          | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
              let ofs = slot_offset ss 1 in
              if is_immediate ofs then
              `	fldds	{emit_int ofs}(%r30), {emit_reg dst}\n`
              else begin
              `	ldo	{emit_int ofs}(%r30), %r1\n`;
              `	fldds	0(%r1), {emit_reg dst}\n`
              end
          | (_, _) ->
              assert false
        end
    | Lop(Iconst_int n) ->
        if is_offset_native n then
          `	ldi	{emit_nativeint n}, {emit_reg i.res.(0)}\n`
        else begin
          `	ldil	{emit_nativeint_high n}, {emit_reg i.res.(0)}\n`;
          `	ldo	{emit_nativeint_low n}({emit_reg i.res.(0)}), {emit_reg i.res.(0)}\n`
        end
    | Lop(Iconst_float s) ->
        let lbl = new_label() in
        float_constants := (lbl, s) :: !float_constants;
        `	ldil	{emit_string high_prefix}{emit_label lbl}, %r1\n`;
        `	ldo	{emit_string low_prefix}{emit_label lbl}(%r1), %r1\n`;
        `	fldds	0(%r1), {emit_reg i.res.(0)}\n`
    | Lop(Iconst_symbol s) ->
        use_symbol s;
        load_symbol_high s;
        `	ldo	{emit_symbol_low s}(%r1), {emit_reg i.res.(0)}\n`
    | Lop(Icall_ind) ->
        `	ble	0(4, {emit_reg i.arg.(0)})\n`; (* retaddr in %r31 *)
        `	copy	%r31, %r2\n`; (* in delay slot: save retaddr in %r2 *)
        record_frame i.live
    | Lop(Icall_imm s) ->
        emit_call s "%r2";
        fill_delay_slot dslot;
        record_frame i.live
    | Lop(Itailcall_ind) ->
        let n = frame_size() in
        `	bv	0({emit_reg i.arg.(0)})\n`;
        if !contains_calls (* in delay slot *)
        then `	ldwm	{emit_int(-n)}(%r30), %r2\n`
        else `	ldo	{emit_int(-n)}(%r30), %r30\n`
    | Lop(Itailcall_imm s) ->
        let n = frame_size() in
        if s = !function_name then begin
          `	b,n	{emit_label !tailrec_entry_point}\n`
        end else begin
          emit_call s "%r0";
          if !contains_calls (* in delay slot *)
          then `	ldwm	{emit_int(-n)}(%r30), %r2\n`
          else `	ldo	{emit_int(-n)}(%r30), %r30\n`
        end
    | Lop(Iextcall(s, alloc)) ->
        call_symbol s;
        if alloc then begin
          `	ldil	LR%{emit_symbol s}, %r22\n`;
          describe_call i.arg;
          emit_call "caml_c_call" "%r2";
          `	ldo	RR%{emit_symbol s}(%r22), %r22\n`;  (* in delay slot *)
          record_frame i.live
        end else begin
          describe_call i.arg;
          emit_call s "%r2";
          fill_delay_slot dslot
        end
    | Lop(Istackoffset n) ->
        `	ldo	{emit_int n}(%r30), %r30\n`;
        stack_offset := !stack_offset + n
    | Lop(Iload(chunk, addr)) ->
	let dest = i.res.(0) in
        begin match chunk with
          Byte_unsigned ->
            emit_load "ldb" addr i.arg dest
        | Byte_signed ->
            emit_load "ldb" addr i.arg dest;
            `	extrs	{emit_reg dest}, 31, 8, {emit_reg dest}\n`
        | Sixteen_unsigned ->
            emit_load "ldh" addr i.arg dest
        | Sixteen_signed ->
            emit_load "ldh" addr i.arg dest;
            `	extrs	{emit_reg dest}, 31, 16, {emit_reg dest}\n`
        | Single ->
            emit_float_load addr i.arg dest false;
            `	fcnvff,sgl,dbl {emit_reg dest}L, {emit_reg dest}\n`
        | Double | Double_u ->
            emit_float_load addr i.arg dest true
        | _ ->
            emit_load "ldw" addr i.arg dest
        end
    | Lop(Istore(chunk, addr)) ->
        let src = i.arg.(0) in
        begin match chunk with
          Byte_unsigned | Byte_signed ->
            emit_store "stb" addr i.arg src
        | Sixteen_unsigned | Sixteen_signed ->
            emit_store "sth" addr i.arg src
        | Single ->
            `	fcnvff,dbl,sgl	{emit_reg src}, %fr31L\n`;
            emit_float_store addr i.arg (phys_reg 127) (* %fr31 *) false
        | Double | Double_u ->
            emit_float_store addr i.arg src true
        | _ ->
            emit_store "stw" addr i.arg src
        end
    | Lop(Ialloc n) ->
        if !fastcode_flag then begin
          let lbl_cont = new_label() in
          `	ldw	0(%r4), %r1\n`;
          `	ldo	{emit_int (-n)}(%r3), %r3\n`;
          `	comb,>>= %r3, %r1, {emit_label lbl_cont}\n`;
          `	addi	4, %r3, {emit_reg i.res.(0)}\n`; (* in delay slot *)
          emit_call "caml_call_gc" "%r2";
          (* Cannot use %r1 to pass size, since clobbered by glue call code *)
          `	ldi	{emit_int n}, %r29\n`; (* in delay slot *)
          record_frame i.live;
          `	addi	4, %r3, {emit_reg i.res.(0)}\n`;
          `{emit_label lbl_cont}:\n`
        end else begin
          emit_call "caml_allocN" "%r2";
          (* Cannot use %r1 either *)
          `	ldi	{emit_int n}, %r29\n`; (* in delay slot *)
          record_frame i.live;
          `	addi	4, %r3, {emit_reg i.res.(0)}\n`
        end
    | Lop(Iintop Imul) ->
        `	stws,ma	{emit_reg i.arg.(0)}, 8(%r30)\n`;
        `	stw	{emit_reg i.arg.(1)}, -4(%r30)\n`;
        `	fldws	-8(%r30), %fr31L\n`;
        `	fldws	-4(%r30), %fr31R\n`;
        `	xmpyu	%fr31L, %fr31R, %fr31\n`;
        `	fstws	%fr31R, -8(%r30)\n`; (* poor scheduling *)
        `	ldws,mb	-8(%r30), {emit_reg i.res.(0)}\n`
    | Lop(Iintop Idiv) ->
        (* Arguments are assumed to be in %r26 and %r25, result in %r29 *)
        `	bl	$$divI, %r31\n`;
        fill_delay_slot dslot
    | Lop(Iintop Imod) ->
        (* Arguments are assumed to be in %r26 and %r25, result in %r29 *)
        `	bl	$$remI, %r31\n`;
        fill_delay_slot dslot
    | Lop(Iintop Ilsl) ->
        `	subi	31, {emit_reg i.arg.(1)}, %r1\n`;
        `	mtsar	%r1\n`;
        `	zvdep	{emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n`
    | Lop(Iintop Ilsr) ->
        `	mtsar	{emit_reg i.arg.(1)}\n`;
        `	vshd	%r0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop Iasr) ->
        `	subi	31, {emit_reg i.arg.(1)}, %r1\n`;
        `	mtsar	%r1\n`;
        `	vextrs	{emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n`
    | Lop(Iintop(Icomp cmp)) ->
        let comp = name_for_int_comparison(negate_int_comparison cmp) in
        `	comclr,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
        `	ldi	1, {emit_reg i.res.(0)}\n`
    | Lop(Iintop Icheckbound) ->
        if !range_check_trap = 0 then range_check_trap := new_label();
        `	comclr,>> {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %r0\n`;
        `	b,n	{emit_label !range_check_trap}\n`
    | Lop(Iintop op) ->
        let instr = name_for_int_operation op in
        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Iadd, n)) ->
        `	addi	{emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Isub, n)) ->
        `	addi	{emit_int(-n)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Idiv, n)) ->
        let l = Misc.log2 n in
        `	comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`;
	if not (l = 0) then
          `	zdepi	-1, 31, {emit_int l}, %r1\n`
	else
	  `	xor	%r1, %r1, %r1\n`;
        `	add	{emit_reg i.arg.(0)}, %r1, %r1\n`;
        `	extrs	%r1, {emit_int(31-l)}, {emit_int(32-l)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Imod, n)) ->
        let l = Misc.log2 n in
        `	comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`;
	if not (l = 0) then
          `	zdepi	-1, 31, {emit_int l}, %r1\n`
	else
	  `	xor	%r1, %r1, %r1\n`;
        `	add	{emit_reg i.arg.(0)}, %r1, %r1\n`;
        `	depi	0, 31, {emit_int l}, %r1\n`;
        `	sub	{emit_reg i.arg.(0)}, %r1, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Ilsl, n)) ->
        let n = n land 31 in
        `	zdep	{emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Ilsr, n)) ->
        let n = n land 31 in
        `	extru	{emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Iasr, n)) ->
        let n = n land 31 in
        `	extrs	{emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Icomp cmp, n)) ->
        let comp = name_for_int_comparison(negate_int_comparison(swap_int_comparison cmp)) in
        `	comiclr,{emit_string comp} {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
        `	ldi	1, {emit_reg i.res.(0)}\n`
    | Lop(Iintop_imm(Icheckbound, n)) ->
        if !range_check_trap = 0 then range_check_trap := new_label();
        `	comiclr,<< {emit_int n}, {emit_reg i.arg.(0)}, %r0\n`;
        `	b,n	{emit_label !range_check_trap}\n`
    | Lop(Iintop_imm(op, n)) ->
        assert false
    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
        let instr = name_for_float_operation op in
        `	{emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lop(Inegf) ->
        `	fsub,dbl 0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Iabsf) ->
        `	fabs,dbl {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
    | Lop(Ifloatofint) ->
        `	stws,ma	{emit_reg i.arg.(0)}, 8(%r30)\n`;
        `	fldws,mb -8(%r30), %fr31L\n`;
        `	fcnvxf,sgl,dbl %fr31L, {emit_reg i.res.(0)}\n`
    | Lop(Iintoffloat) ->
        `	fcnvfxt,dbl,sgl {emit_reg i.arg.(0)}, %fr31L\n`;
        `	fstws,ma %fr31L, 8(%r30)\n`;
        `	ldws,mb	-8(%r30), {emit_reg i.res.(0)}\n`
    | Lop(Ispecific sop) ->
        let instr = name_for_specific_operation sop in
        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
    | Lreloadretaddr ->
        let n = frame_size() in
        `	ldw	{emit_int(-n)}(%r30), %r2\n`
    | Lreturn ->
        let n = frame_size() in
        `	bv	0(%r2)\n`;
        `	ldo	{emit_int(-n)}(%r30), %r30\n` (* in delay slot *)
    | Llabel lbl ->
        `{emit_label lbl}:\n`
    | Lbranch lbl ->
        begin match dslot with
            None ->
              `	b,n	{emit_label lbl}\n`
          | Some i ->
              `	b	{emit_label lbl}\n`;
              emit_instr i None
        end
    | Lcondbranch(tst, lbl) ->
        begin match tst with
          Itruetest ->
            emit_comib "<>" "=" 0 i.arg lbl dslot
        | Ifalsetest ->
            emit_comib "=" "<>" 0 i.arg lbl dslot
        | Iinttest cmp ->
            let comp = name_for_int_comparison cmp
            and negcomp =
              name_for_int_comparison(negate_int_comparison cmp) in
            emit_comb comp negcomp i.arg lbl dslot
        | Iinttest_imm(cmp, n) ->
            let scmp = swap_int_comparison cmp in
            let comp = name_for_int_comparison scmp
            and negcomp =
              name_for_int_comparison(negate_int_comparison scmp) in
            emit_comib comp negcomp n i.arg lbl dslot
        | Ifloattest(cmp, neg) ->
            let comp = name_for_float_comparison cmp neg in
            `	fcmp,dbl,{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
            `	ftest\n`;
            `	b	{emit_label lbl}\n`;
            fill_delay_slot dslot
        | Ioddtest ->
            emit_comib "OD" "EV" 0 i.arg lbl dslot
        | Ieventest ->
            emit_comib "EV" "OD" 0 i.arg lbl dslot
        end
  | Lcondbranch3(lbl0, lbl1, lbl2) ->
        begin match lbl0 with
          None -> ()
        | Some lbl -> emit_comib "=" "<>" 0 i.arg lbl None
        end;
        begin match lbl1 with
          None -> ()
        | Some lbl -> emit_comib "=" "<>" 1 i.arg lbl None
        end;
        begin match lbl2 with
          None -> ()
        | Some lbl -> emit_comib "=" "<>" 2 i.arg lbl None
        end
    | Lswitch jumptbl ->
        `	blr	{emit_reg i.arg.(0)}, 0\n`;
        fill_delay_slot dslot;
        for i = 0 to Array.length jumptbl - 1 do
          `	b	{emit_label jumptbl.(i)}\n`;
          `	nop\n`
        done
    | Lsetuptrap lbl ->
        `	bl	{emit_label lbl}, %r1\n`;
        fill_delay_slot dslot
    | Lpushtrap ->
        stack_offset := !stack_offset + 8;
        `	stws,ma	%r5, 8(%r30)\n`;
        `	stw	%r1, -4(%r30)\n`;
        `	copy	%r30, %r5\n`
    | Lpoptrap ->
        `	ldws,mb	-8(%r30), %r5\n`;
        stack_offset := !stack_offset - 8
    | Lraise ->
        `	ldw	-4(%r5), %r1\n`;
        `	copy	%r5, %r30\n`;
        `	bv	0(%r1)\n`;
        `	ldws,mb	-8(%r30), %r5\n` (* in delay slot *)

and fill_delay_slot = function
    None -> `	nop\n`
  | Some i -> emit_instr i None

and emit_delay_slot = function
    None -> ()
  | Some i -> emit_instr i None

and emit_comb comp negcomp arg lbl dslot =
  if lbl >= 0 then begin
    `	comb,{emit_string comp}	{emit_reg arg.(0)}, {emit_reg arg.(1)}, {emit_label lbl}\n`;
    fill_delay_slot dslot
  end else begin
    emit_delay_slot dslot;
    `	comclr,{emit_string negcomp}	{emit_reg arg.(0)}, {emit_reg arg.(1)}, %r0\n`;
    `	b,n	{emit_label (-lbl)}\n`
  end

and emit_comib comp negcomp cst arg lbl dslot =
  if lbl >= 0 then begin
    `	comib,{emit_string comp}	{emit_int cst}, {emit_reg arg.(0)}, {emit_label lbl}\n`;
    fill_delay_slot dslot
  end else begin
    emit_delay_slot dslot;
    `	comiclr,{emit_string negcomp}	{emit_int cst}, {emit_reg arg.(0)}, %r0\n`;
    `	b,n	{emit_label (-lbl)}\n`
  end

(* Checks if a pseudo-instruction expands to exactly one machine instruction
   that does not branch. *)

let is_one_instr i =
  match i.desc with
    Lop op ->
      begin match op with
        Imove | Ispill | Ireload ->
          begin match (i.arg.(0), i.res.(0)) with
            ({typ = Float; loc = Stack s}, _) -> is_immediate(slot_offset s 1)
          | (_, {typ = Float; loc = Stack s}) -> is_immediate(slot_offset s 1)
          | (_, _) -> true
          end
      | Iconst_int n -> is_offset_native n
      | Istackoffset _ -> true
      | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_offset n
      | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_offset n
      | Iintop(Iadd | Isub | Iand | Ior | Ixor) -> true
      | Iintop_imm((Iadd | Isub | Ilsl | Ilsr | Iasr), _) -> true
      | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf -> true
      | Ispecific _ -> true
      | _ -> false
      end
  | Lreloadretaddr -> true
  | _ -> false

let no_interference res arg =
  try
    for i = 0 to Array.length arg - 1 do
      for j = 0 to Array.length res - 1 do
        if arg.(i).loc = res.(j).loc then raise Exit
      done
    done;
    true
  with Exit ->
    false

(* Emit a sequence of instructions, trying to fill delay slots for branches *)

let rec emit_all i =
  match i with
    {desc = Lend} -> ()
  | {next = {desc = Lop(Icall_imm _)
                  | Lop(Iextcall(_, false))
                  | Lop(Iintop(Idiv | Imod))
                  | Lbranch _
                  | Lsetuptrap _ }}
    when is_one_instr i ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | {next = {desc = Lcondbranch(_, _) | Lswitch _}}
    when is_one_instr i & no_interference i.res i.next.arg ->
      emit_instr i.next (Some i);
      emit_all i.next.next
  | _ ->
      emit_instr i None;
      emit_all i.next

(* Estimate the size of an instruction, in actual HPPA instructions *)

let is_float_stack r =
  match r with {loc = Stack _; typ = Float} -> true | _ -> false

let sizeof_instr i =
  match i.desc with
    Lend -> 0
  | Lop op ->
      begin match op with
        Imove | Ispill | Ireload ->
          if is_float_stack i.arg.(0) || is_float_stack i.res.(0)
          then 2 (* ldo/fxxx *) else 1
      | Iconst_int n ->
          if is_offset_native n then 1 else 2 (* ldi or ldil/ldo *)
      | Iconst_float _ -> 3 (* ldil/ldo/fldds *)
      | Iconst_symbol _ -> 2 (* addil/ldo *)
      | Icall_ind -> 2 (* ble/copy *)
      | Icall_imm _ -> 2 (* bl/nop *)
      | Itailcall_ind -> 2 (* bv/ldwm *)
      | Itailcall_imm _ -> 2 (* bl/ldwm *)
      | Iextcall(_, alloc) ->
          if alloc then 3 (* ldil/bl/ldo *) else 2 (* bl/nop *)
      | Istackoffset _ -> 1 (* ldo *)
      | Iload(chunk, addr) ->
          if i.res.(0).typ = Float
          then 4 (* addil/ldo/fldws/fldws *)
          else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2)
             + (match chunk with Byte_signed -> 1 | Sixteen_signed -> 1 | _ -> 0)
      | Istore(chunk, addr) ->
          if i.arg.(0).typ = Float
          then 4 (* addil/ldo/fstws/fstws *)
          else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2)
      | Ialloc _ -> if !fastcode_flag then 7 else 3
      | Iintop Imul -> 7
      | Iintop(Idiv | Imod) -> 3 (* ldil/ble/nop *)
      | Iintop Ilsl -> 3 (* subi/mtsar/zvdep *)
      | Iintop Ilsr -> 2 (* mtsar/vshd *)
      | Iintop Iasr -> 3 (* subi/mtsar/vextrs *)
      | Iintop(Icomp _) -> 2 (* comclr/ldi *)
      | Iintop Icheckbound -> 2 (* comclr/b,n *)
      | Iintop _ -> 1
      | Iintop_imm(Idiv, _) -> 4 (* comclr/zdepi/add/extrs *)
      | Iintop_imm(Imod, _) -> 5 (* comclr/zdepi/add/extrs/sub *)
      | Iintop_imm(Icomp _, _) -> 2 (* comiclr/ldi *)
      | Iintop_imm(Icheckbound, _) -> 2 (* comiclr/b,n *)
      | Iintop_imm(_, _) -> 1
      | Ifloatofint -> 3 (* stws,ma/fldws,mb/fcnvxf *)
      | Iintoffloat -> 3 (* fcnfxt/fstws/ldws *)
      | _ (* Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ispecific _ *) -> 1
      end
  | Lreloadretaddr -> 1
  | Lreturn -> 2
  | Llabel _ -> 0
  | Lbranch _ -> 1 (* b,n *)
  | Lcondbranch(Ifloattest(_, _), _) -> 4 (* fcmp/ftest/b/nop *)
  | Lcondbranch(_, _) -> 2 (* comb/nop or comclr/b,n *)
  | Lcondbranch3(_, _, _) -> 6 (* worst case: three comib/nop or comclr/b,n *)
  | Lswitch tbl -> 2 + 2 * Array.length tbl (* blr/nop b/nop *)
  | Lsetuptrap _ -> 2 (* bl/nop *)
  | Lpushtrap -> 3 (* stws,ma/stw/copy *)
  | Lpoptrap -> 1 (* ldws,mb *)
  | Lraise -> 4 (* ldw/copy/bv/ldws,mb *)

(* Estimate the position of all labels in function body
   and rewrite long conditional branches with a negative label. *)

let fixup_cond_branches funbody =
  let label_position =
    (Hashtbl.create 87 : (label, int) Hashtbl.t) in
  let rec estimate_labels pos i =
    match i.desc with
      Lend -> ()
    | Llabel lbl ->
        Hashtbl.add label_position lbl pos; estimate_labels pos i.next
    | _ -> estimate_labels (pos + sizeof_instr i) i.next in
  let long_branch currpos lbl =
    try
      let displ = Hashtbl.find label_position lbl - currpos in
      (* Branch offset is stored in 12 bits, giving a range of
         -2048 to +2047. Here, we allow 10% error in estimating
         the code positions. *)
      displ < -1843 || displ > 1842
    with Not_found ->
      assert false in
  let rec fix_branches pos i =
    match i.desc with
      Lend -> ()
    | Lcondbranch(tst, lbl) ->
        if long_branch pos lbl then i.desc <- Lcondbranch(tst, -lbl);
        fix_branches (pos + sizeof_instr i) i.next
    | Lcondbranch3(opt1, opt2, opt3) ->
        let fix_opt = function
          None -> None
        | Some lbl -> Some(if long_branch pos lbl then -lbl else lbl) in
        i.desc <- Lcondbranch3(fix_opt opt1, fix_opt opt2, fix_opt opt3);
        fix_branches (pos + sizeof_instr i) i.next
    | _ ->
        fix_branches (pos + sizeof_instr i) i.next in
  estimate_labels 0 funbody;
  fix_branches 0 funbody

(* Emission of a function declaration *)

let fundecl fundecl =
  fixup_cond_branches fundecl.fun_body;
  function_name := fundecl.fun_name;
  fastcode_flag := fundecl.fun_fast;
  tailrec_entry_point := new_label();
  stack_offset := 0;
  float_constants := [];
  define_symbol fundecl.fun_name;
  range_check_trap := 0;
  let n = frame_size() in
  begin match Config.system with
  | "hpux" ->
    `	.code\n`;
    `	.align	4\n`;
    `	.export	{emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`;
    `{emit_symbol fundecl.fun_name}:\n`;
    `	.proc\n`;
    if !contains_calls then
      `	.callinfo frame={emit_int n}, calls, save_rp\n`
    else
      `	.callinfo frame={emit_int n}, no_calls\n`;
    `	.entry\n`
  | "linux" | "gnu" ->
    `	.text\n`;
    `	.align	8\n`;
    `	.globl	{emit_symbol fundecl.fun_name}\n`;
    `{emit_symbol fundecl.fun_name}:\n`
  | _ ->
    assert false
  end;
  if !contains_calls then
    `	stwm	%r2, {emit_int n}(%r30)\n`
  else if n > 0 then
    `	ldo	{emit_int n}(%r30), %r30\n`;
  `{emit_label !tailrec_entry_point}:\n`;
  emit_all fundecl.fun_body;
  if !range_check_trap > 0 then begin
    `{emit_label !range_check_trap}:\n`;
    emit_call "caml_ml_array_bound_error" "%r31";
    `	nop\n`
  end;
  if Config.system = "hpux"then begin
    `	.exit\n`;
    `	.procend\n`
  end;
  emit_float_constants()

(* Emission of data *)

let declare_global s =
  define_symbol s;
  if Config.system = "hpux"
  then `	.export	{emit_symbol s}, data\n`
  else `	.globl	{emit_symbol s}\n`

let emit_item = function
    Cglobal_symbol s ->
      declare_global s
  | Cdefine_symbol s ->
      define_symbol s;
      `{emit_symbol s}:\n`
  | Cdefine_label lbl ->
      `{emit_label (lbl + 100000)}:\n`
  | Cint8 n ->
      `	.byte	{emit_int n}\n`
  | Cint16 n ->
      `	.short	{emit_int n}\n`
  | Cint32 n ->
      `	.long	{emit_nativeint n}\n`
  | Cint n ->
      `	.long	{emit_nativeint n}\n`
  | Csingle f ->
      emit_float32_directive ".long" f
  | Cdouble f ->
      emit_float64_split_directive ".long" f
  | Csymbol_address s ->
      use_symbol s;
      `	.long	{emit_symbol s}\n`
  | Clabel_address lbl ->
      `	.long	{emit_label(lbl + 100000)}\n`
  | Cstring s ->
      emit_string_directive "	.ascii	" s
  | Cskip n ->
      if n > 0 then
        if Config.system = "hpux"
        then `	.block	{emit_int n}\n`
        else `	.space	{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() =
  if Config.system = "hpux" then begin
    `	.space $PRIVATE$\n`;
    `	.subspa $DATA$,quad=1,align=8,access=31\n`;
    `	.subspa $BSS$,quad=1,align=8,access=31,zero,sort=82\n`;
    `	.space $TEXT$\n`;
    `	.subspa $LIT$,quad=0,align=8,access=44\n`;
    `	.subspa $CODE$,quad=0,align=8,access=44,code_only\n`;
    `	.import $global$, data\n`;
    `	.import $$divI, millicode\n`;
    `	.import $$remI, millicode\n`
  end;
  used_symbols := StringSet.empty;
  defined_symbols := StringSet.empty;
  called_symbols := StringSet.empty;
  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
  `	.data\n`;
  declare_global lbl_begin;
  `{emit_symbol lbl_begin}:\n`;
  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
  `	.code\n`;
  declare_global lbl_begin;
  `{emit_symbol lbl_begin}:\n`


let end_assembly() =
  `	.code\n`;
  let lbl_end = Compilenv.make_symbol (Some "code_end") in
  declare_global lbl_end;
  `{emit_symbol lbl_end}:\n`;
  `	.data\n`;
  let lbl_end = Compilenv.make_symbol (Some "data_end") in
  declare_global lbl_end;
  `{emit_symbol lbl_end}:\n`;
  `	.long	0\n`;
  let lbl = Compilenv.make_symbol (Some "frametable") in
  declare_global lbl;
  `{emit_symbol lbl}:\n`;
  `	.long	{emit_int (List.length !frame_descriptors)}\n`;
  List.iter emit_frame !frame_descriptors;
  frame_descriptors := [];
  emit_imports()