l4/pkg/ocaml/contrib/asmcomp/power/emit.mlp

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: emit.mlp 9475 2009-12-16 10:04:38Z xleroy $ *)
  14
  15 (* Emission of PowerPC assembly code *)
  16
  17 module StringSet = Set.Make(struct type t = string let compare = compare end)
  18
  19 open Location
  20 open Misc
  21 open Cmm
  22 open Arch
  23 open Proc
  24 open Reg
  25 open Mach
  26 open Linearize
  27 open Emitaux
  28
  29 (* Layout of the stack.  The stack is kept 16-aligned. *)
  30
  31 let stack_offset = ref 0
  32
  33 let frame_size () =
  34   let size =
  35     !stack_offset +                     (* Trap frame, outgoing parameters *)
  36     size_int * num_stack_slots.(0) +    (* Local int variables *)
  37     size_float * num_stack_slots.(1) +  (* Local float variables *)
  38     (if !contains_calls then size_int else 0) in (* The return address *)
  39   Misc.align size 16
  40
  41 let slot_offset loc cls =
  42   match loc with
  43     Local n ->
  44       if cls = 0
  45       then !stack_offset + num_stack_slots.(1) * size_float + n * size_int
  46       else !stack_offset + n * size_float
  47   | Incoming n -> frame_size() + n
  48   | Outgoing n -> n
  49
  50 (* Whether stack backtraces are supported *)
  51
  52 let supports_backtraces =
  53   match Config.system with
  54   | "rhapsody" -> true
  55   | _ -> false
  56
  57 (* Output a symbol *)
  58
  59 let emit_symbol =
  60   match Config.system with
  61   | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s)
  62   | "rhapsody"    -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s)
  63   | _ -> assert false
  64
  65 (* Output a label *)
  66
  67 let label_prefix =
  68   match Config.system with
  69   | "elf" | "bsd" -> ".L"
  70   | "rhapsody" -> "L"
  71   | _ -> assert false
  72
  73 let emit_label lbl =
  74   emit_string label_prefix; emit_int lbl
  75
  76 (* Section switching *)
  77
  78 let data_space =
  79   match Config.system with
  80   | "elf" | "bsd" -> "  .section \".data\"\n"
  81   | "rhapsody"    -> "  .data\n"
  82   | _ -> assert false
  83
  84 let code_space =
  85   match Config.system with
  86   | "elf" | "bsd" -> "  .section \".text\"\n"
  87   | "rhapsody"    -> "  .text\n"
  88   | _ -> assert false
  89
  90 let rodata_space =
  91   match Config.system with
  92   | "elf" | "bsd" -> "  .section \".rodata\"\n"
  93   | "rhapsody"    -> "  .const\n"
  94   | _ -> assert false
  95
  96 (* Names of instructions that differ in 32 and 64-bit modes *)
  97
  98 let lg = if ppc64 then "ld" else "lwz"
  99 let stg = if ppc64 then "std" else "stw"
 100 let lwa = if ppc64 then "lwa" else "lwz"
 101 let cmpg = if ppc64 then "cmpd" else "cmpw"
 102 let cmplg = if ppc64 then "cmpld" else "cmplw"
 103 let datag = if ppc64 then ".quad" else ".long"
 104 let aligng = if ppc64 then 3 else 2
 105 let mullg = if ppc64 then "mulld" else "mullw"
 106 let divg = if ppc64 then "divd" else "divw"
 107 let tglle = if ppc64 then "tdlle" else "twlle"
 108 let sragi = if ppc64 then "sradi" else "srawi"
 109 let slgi = if ppc64 then "sldi" else "slwi"
 110 let fctigz = if ppc64 then "fctidz" else "fctiwz"
 111
 112 (* Output a pseudo-register *)
 113
 114 let emit_reg r =
 115   match r.loc with
 116     Reg r -> emit_string (register_name r)
 117   | _ -> fatal_error "Emit.emit_reg"
 118
 119 let use_full_regnames =
 120   Config.system = "rhapsody"
 121
 122 let emit_gpr r =
 123   if use_full_regnames then emit_char 'r';
 124   emit_int r
 125
 126 let emit_fpr r =
 127   if use_full_regnames then emit_char 'f';
 128   emit_int r
 129
 130 let emit_ccr r =
 131   if use_full_regnames then emit_string "cr";
 132   emit_int r
 133
 134 (* Output a stack reference *)
 135
 136 let emit_stack r =
 137   match r.loc with
 138     Stack s ->
 139       let ofs = slot_offset s (register_class r) in `{emit_int ofs}({emit_gpr 1})`
 140   | _ -> fatal_error "Emit.emit_stack"
 141
 142 (* Split a 32-bit integer constants in two 16-bit halves *)
 143
 144 let low n = n land 0xFFFF
 145 let high n = n asr 16
 146
 147 let nativelow n = Nativeint.to_int n land 0xFFFF
 148 let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16)
 149
 150 let is_immediate n =
 151   n <= 32767 && n >= -32768
 152
 153 let is_native_immediate n =
 154   n <= 32767n && n >= -32768n
 155
 156 (* Output a "upper 16 bits" or "lower 16 bits" operator. *)
 157
 158 let emit_upper emit_fun arg =
 159   match Config.system with
 160   | "elf" | "bsd" ->
 161       emit_fun arg; emit_string "@ha"
 162   | "rhapsody" ->
 163       emit_string "ha16("; emit_fun arg; emit_string ")"
 164   | _ -> assert false
 165
 166 let emit_lower emit_fun arg =
 167   match Config.system with
 168   | "elf" | "bsd" ->
 169       emit_fun arg; emit_string "@l"
 170   | "rhapsody" ->
 171       emit_string "lo16("; emit_fun arg; emit_string ")"
 172   | _ -> assert false
 173
 174 (* Output a load or store operation *)
 175
 176 let emit_symbol_offset (s, d) =
 177   emit_symbol s;
 178   if d > 0 then `+`;
 179   if d <> 0 then emit_int d
 180
 181 let valid_offset instr ofs =
 182   ofs land 3 = 0 || (instr <> "ld" && instr <> "std")
 183
 184 let emit_load_store instr addressing_mode addr n arg =
 185   match addressing_mode with
 186     Ibased(s, d) ->
 187       ` addis   {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`;
 188       ` {emit_string instr}     {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n`
 189   | Iindexed ofs ->
 190       if is_immediate ofs && valid_offset instr ofs then
 191         `       {emit_string instr}     {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
 192       else begin
 193         `       lis     {emit_gpr 0}, {emit_int(high ofs)}\n`;
 194         if low ofs <> 0 then
 195           `     ori     {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`;
 196         `       {emit_string instr}x    {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n`
 197       end
 198   | Iindexed2 ->
 199       ` {emit_string instr}x    {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n`
 200
 201 (* After a comparison, extract the result as 0 or 1 *)
 202
 203 let emit_set_comp cmp res =
 204   `     mfcr    {emit_gpr 0}\n`;
 205   let bitnum =
 206     match cmp with
 207       Ceq | Cne -> 2
 208     | Cgt | Cle -> 1
 209     | Clt | Cge -> 0 in
 210 `       rlwinm  {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`;
 211   begin match cmp with
 212     Cne | Cle | Cge -> `        xori    {emit_reg res}, {emit_reg res}, 1\n`
 213   | _ -> ()
 214   end
 215
 216 (* Record live pointers at call points *)
 217
 218 let record_frame live dbg =
 219   let lbl = new_label() in
 220   let live_offset = ref [] in
 221   Reg.Set.iter
 222     (function
 223         {typ = Addr; loc = Reg r} ->
 224           live_offset := (r lsl 1) + 1 :: !live_offset
 225       | {typ = Addr; loc = Stack s} as reg ->
 226           live_offset := slot_offset s (register_class reg) :: !live_offset
 227       | _ -> ())
 228     live;
 229   frame_descriptors :=
 230     { fd_lbl = lbl;
 231       fd_frame_size = frame_size();
 232       fd_live_offset = !live_offset;
 233       fd_debuginfo = dbg } :: !frame_descriptors;
 234   `{emit_label lbl}:\n`
 235
 236 (* Record floating-point and large integer literals *)
 237
 238 let float_literals = ref ([] : (string * int) list)
 239 let int_literals = ref ([] : (nativeint * int) list)
 240
 241 (* Record external C functions to be called in a position-independent way
 242    (for MacOSX) *)
 243
 244 let pic_externals = (Config.system = "rhapsody")
 245
 246 let external_functions = ref StringSet.empty
 247
 248 let emit_external s =
 249   `     .non_lazy_symbol_pointer\n`;
 250   `L{emit_symbol s}$non_lazy_ptr:\n`;
 251   `     .indirect_symbol {emit_symbol s}\n`;
 252   `     {emit_string datag}     0\n`
 253
 254 (* Names for conditional branches after comparisons *)
 255
 256 let branch_for_comparison = function
 257     Ceq -> "beq" | Cne -> "bne"
 258   | Cle -> "ble" | Cgt -> "bgt"
 259   | Cge -> "bge" | Clt -> "blt"
 260
 261 let name_for_int_comparison = function
 262     Isigned cmp -> (cmpg, branch_for_comparison cmp)
 263   | Iunsigned cmp -> (cmplg, branch_for_comparison cmp)
 264
 265 (* Names for various instructions *)
 266
 267 let name_for_intop = function
 268     Iadd -> "add"
 269   | Imul -> if ppc64 then "mulld" else "mullw"
 270   | Idiv -> if ppc64 then "divd" else "divw"
 271   | Iand -> "and"
 272   | Ior  -> "or"
 273   | Ixor -> "xor"
 274   | Ilsl -> if ppc64 then "sld" else "slw"
 275   | Ilsr -> if ppc64 then "srd" else "srw"
 276   | Iasr -> if ppc64 then "srad" else "sraw"
 277   | _ -> Misc.fatal_error "Emit.Intop"
 278
 279 let name_for_intop_imm = function
 280     Iadd -> "addi"
 281   | Imul -> "mulli"
 282   | Iand -> "andi."
 283   | Ior  -> "ori"
 284   | Ixor -> "xori"
 285   | Ilsl -> if ppc64 then "sldi" else "slwi"
 286   | Ilsr -> if ppc64 then "srdi" else "srwi"
 287   | Iasr -> if ppc64 then "sradi" else "srawi"
 288   | _ -> Misc.fatal_error "Emit.Intop_imm"
 289
 290 let name_for_floatop1 = function
 291     Inegf -> "fneg"
 292   | Iabsf -> "fabs"
 293   | _ -> Misc.fatal_error "Emit.Iopf1"
 294
 295 let name_for_floatop2 = function
 296     Iaddf -> "fadd"
 297   | Isubf -> "fsub"
 298   | Imulf -> "fmul"
 299   | Idivf -> "fdiv"
 300   | _ -> Misc.fatal_error "Emit.Iopf2"
 301
 302 let name_for_specific = function
 303     Imultaddf -> "fmadd"
 304   | Imultsubf -> "fmsub"
 305   | _ -> Misc.fatal_error "Emit.Ispecific"
 306
 307 (* Name of current function *)
 308 let function_name = ref ""
 309 (* Entry point for tail recursive calls *)
 310 let tailrec_entry_point = ref 0
 311 (* Names of functions defined in the current file *)
 312 let defined_functions = ref StringSet.empty
 313 (* Label of glue code for calling the GC *)
 314 let call_gc_label = ref 0
 315
 316 (* Fixup conditional branches that exceed hardware allowed range *)
 317
 318 let load_store_size = function
 319     Ibased(s, d) -> 2
 320   | Iindexed ofs -> if is_immediate ofs then 1 else 3
 321   | Iindexed2 -> 1
 322
 323 let instr_size = function
 324     Lend -> 0
 325   | Lop(Imove | Ispill | Ireload) -> 1
 326   | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2
 327   | Lop(Iconst_float s) -> 2
 328   | Lop(Iconst_symbol s) -> 2
 329   | Lop(Icall_ind) -> 2
 330   | Lop(Icall_imm s) -> 1
 331   | Lop(Itailcall_ind) -> 5
 332   | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4
 333   | Lop(Iextcall(s, true)) -> 3
 334   | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1
 335   | Lop(Istackoffset n) -> 1
 336   | Lop(Iload(chunk, addr)) ->
 337       if chunk = Byte_signed
 338       then load_store_size addr + 1
 339       else load_store_size addr
 340   | Lop(Istore(chunk, addr)) -> load_store_size addr
 341   | Lop(Ialloc n) -> 4
 342   | Lop(Ispecific(Ialloc_far n)) -> 5
 343   | Lop(Iintop Imod) -> 3
 344   | Lop(Iintop(Icomp cmp)) -> 4
 345   | Lop(Iintop op) -> 1
 346   | Lop(Iintop_imm(Idiv, n)) -> 2
 347   | Lop(Iintop_imm(Imod, n)) -> 4
 348   | Lop(Iintop_imm(Icomp cmp, n)) -> 4
 349   | Lop(Iintop_imm(op, n)) -> 1
 350   | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1
 351   | Lop(Ifloatofint) -> 9
 352   | Lop(Iintoffloat) -> 4
 353   | Lop(Ispecific sop) -> 1
 354   | Lreloadretaddr -> 2
 355   | Lreturn -> 2
 356   | Llabel lbl -> 0
 357   | Lbranch lbl -> 1
 358   | Lcondbranch(tst, lbl) -> 2
 359   | Lcondbranch3(lbl0, lbl1, lbl2) ->
 360       1 + (if lbl0 = None then 0 else 1)
 361         + (if lbl1 = None then 0 else 1)
 362         + (if lbl2 = None then 0 else 1)
 363   | Lswitch jumptbl -> 8
 364   | Lsetuptrap lbl -> 1
 365   | Lpushtrap -> 4
 366   | Lpoptrap -> 2
 367   | Lraise -> 6
 368
 369 let label_map code =
 370   let map = Hashtbl.create 37 in
 371   let rec fill_map pc instr =
 372     match instr.desc with
 373       Lend -> (pc, map)
 374     | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next
 375     | op -> fill_map (pc + instr_size op) instr.next
 376   in fill_map 0 code
 377
 378 let max_branch_offset = 8180
 379 (* 14-bit signed offset in words.  Remember to cut some slack
 380    for multi-word instructions where the branch can be anywhere in
 381    the middle.  12 words of slack is plenty. *)
 382
 383 let branch_overflows map pc_branch lbl_dest =
 384   let pc_dest = Hashtbl.find map lbl_dest in
 385   let delta = pc_dest - (pc_branch + 1) in
 386   delta <= -max_branch_offset || delta >= max_branch_offset
 387
 388 let opt_branch_overflows map pc_branch opt_lbl_dest =
 389   match opt_lbl_dest with
 390     None -> false
 391   | Some lbl_dest -> branch_overflows map pc_branch lbl_dest
 392
 393 let fixup_branches codesize map code =
 394   let expand_optbranch lbl n arg next =
 395     match lbl with
 396       None -> next
 397     | Some l ->
 398         instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l))
 399                    arg [||] next in
 400   let rec fixup did_fix pc instr =
 401     match instr.desc with
 402       Lend -> did_fix
 403     | Lcondbranch(test, lbl) when branch_overflows map pc lbl ->
 404         let lbl2 = new_label() in
 405         let cont =
 406           instr_cons (Lbranch lbl) [||] [||]
 407             (instr_cons (Llabel lbl2) [||] [||] instr.next) in
 408         instr.desc <- Lcondbranch(invert_test test, lbl2);
 409         instr.next <- cont;
 410         fixup true (pc + 2) instr.next
 411     | Lcondbranch3(lbl0, lbl1, lbl2)
 412       when opt_branch_overflows map pc lbl0
 413         || opt_branch_overflows map pc lbl1
 414         || opt_branch_overflows map pc lbl2 ->
 415         let cont =
 416           expand_optbranch lbl0 0 instr.arg
 417             (expand_optbranch lbl1 1 instr.arg
 418               (expand_optbranch lbl2 2 instr.arg instr.next)) in
 419         instr.desc <- cont.desc;
 420         instr.next <- cont.next;
 421         fixup true pc instr
 422     | Lop(Ialloc n) when codesize - pc >= max_branch_offset ->
 423         instr.desc <- Lop(Ispecific(Ialloc_far n));
 424         fixup true (pc + 4) instr.next
 425     | op ->
 426         fixup did_fix (pc + instr_size op) instr.next
 427   in fixup false 0 code
 428
 429 (* Iterate branch expansion till all conditional branches are OK *)
 430
 431 let rec branch_normalization code =
 432   let (codesize, map) = label_map code in
 433   if codesize >= max_branch_offset && fixup_branches codesize map code
 434   then branch_normalization code
 435   else ()
 436
 437
 438 (* Output the assembly code for an instruction *)
 439
 440 let rec emit_instr i dslot =
 441     match i.desc with
 442       Lend -> ()
 443     | Lop(Imove | Ispill | Ireload) ->
 444         let src = i.arg.(0) and dst = i.res.(0) in
 445         if src.loc <> dst.loc then begin
 446            match (src, dst) with
 447               {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
 448                 `       mr      {emit_reg dst}, {emit_reg src}\n`
 449             | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
 450                 `       fmr     {emit_reg dst}, {emit_reg src}\n`
 451             | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
 452                 `       {emit_string stg}       {emit_reg src}, {emit_stack dst}\n`
 453             | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
 454                 `       stfd    {emit_reg src}, {emit_stack dst}\n`
 455             | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
 456                 `       {emit_string lg}        {emit_reg dst}, {emit_stack src}\n`
 457             | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
 458                 `       lfd     {emit_reg dst}, {emit_stack src}\n`
 459             | (_, _) ->
 460                 fatal_error "Emit: Imove"
 461         end
 462     | Lop(Iconst_int n) ->
 463         if is_native_immediate n then
 464           `     li      {emit_reg i.res.(0)}, {emit_nativeint n}\n`
 465         else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin
 466           `     lis     {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`;
 467           if nativelow n <> 0 then
 468             `   ori     {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n`
 469         end else begin
 470           let lbl = new_label() in
 471           int_literals := (n, lbl) :: !int_literals;
 472           `     addis   {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
 473           `     {emit_string lg}        {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
 474         end
 475     | Lop(Iconst_float s) ->
 476         let lbl = new_label() in
 477         float_literals := (s, lbl) :: !float_literals;
 478         `       addis   {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
 479         `       lfd     {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
 480     | Lop(Iconst_symbol s) ->
 481         `       addis   {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`;
 482         `       addi    {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n`
 483     | Lop(Icall_ind) ->
 484         `       mtctr   {emit_reg i.arg.(0)}\n`;
 485         `       bctrl\n`;
 486         record_frame i.live i.dbg
 487     | Lop(Icall_imm s) ->
 488         `       bl      {emit_symbol s}\n`;
 489         record_frame i.live i.dbg
 490     | Lop(Itailcall_ind) ->
 491         let n = frame_size() in
 492         `       mtctr   {emit_reg i.arg.(0)}\n`;
 493         if !contains_calls then begin
 494           `     {emit_string lg}        {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`;
 495           `     addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
 496           `     mtlr    {emit_gpr 11}\n`
 497         end else begin
 498           if n > 0 then
 499             `   addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`
 500         end;
 501         `       bctr\n`
 502     | Lop(Itailcall_imm s) ->
 503         if s = !function_name then
 504           `     b       {emit_label !tailrec_entry_point}\n`
 505         else begin
 506           let n = frame_size() in
 507           if !contains_calls then begin
 508             `   {emit_string lg}        {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`;
 509             `   addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
 510             `   mtlr    {emit_gpr 11}\n`
 511           end else begin
 512             if n > 0 then
 513               ` addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`
 514           end;
 515           `     b       {emit_symbol s}\n`
 516         end
 517     | Lop(Iextcall(s, alloc)) ->
 518         if alloc then begin
 519           if pic_externals then begin
 520             external_functions := StringSet.add s !external_functions;
 521             `   addis   {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`;
 522             `   {emit_string lg}        {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`
 523           end else begin
 524             `   addis   {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`;
 525             `   addi    {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n`
 526           end;
 527           `     bl      {emit_symbol "caml_c_call"}\n`;
 528           record_frame i.live i.dbg
 529         end else begin
 530           if pic_externals then begin
 531             external_functions := StringSet.add s !external_functions;
 532             `   addis   {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`;
 533             `   {emit_string lg}        {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`;
 534             `   mtctr   {emit_gpr 11}\n`;
 535             `   bctrl\n`
 536           end else
 537           `     bl      {emit_symbol s}\n`
 538         end
 539     | Lop(Istackoffset n) ->
 540         `       addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`;
 541         stack_offset := !stack_offset + n
 542     | Lop(Iload(chunk, addr)) ->
 543         let loadinstr =
 544           match chunk with
 545             Byte_unsigned -> "lbz"
 546           | Byte_signed -> "lbz"
 547           | Sixteen_unsigned -> "lhz"
 548           | Sixteen_signed -> "lha"
 549           | Thirtytwo_unsigned -> "lwz"
 550           | Thirtytwo_signed -> if ppc64 then "lwa" else "lwz"
 551           | Word -> lg
 552           | Single -> "lfs"
 553           | Double | Double_u -> "lfd" in
 554         emit_load_store loadinstr addr i.arg 0 i.res.(0);
 555         if chunk = Byte_signed then
 556           `     extsb   {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 557     | Lop(Istore(chunk, addr)) ->
 558         let storeinstr =
 559           match chunk with
 560             Byte_unsigned | Byte_signed -> "stb"
 561           | Sixteen_unsigned | Sixteen_signed -> "sth"
 562           | Thirtytwo_unsigned | Thirtytwo_signed -> "stw"
 563           | Word -> stg
 564           | Single -> "stfs"
 565           | Double | Double_u -> "stfd" in
 566         emit_load_store storeinstr addr i.arg 1 i.arg.(0)
 567     | Lop(Ialloc n) ->
 568         if !call_gc_label = 0 then call_gc_label := new_label();
 569         `       addi    {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`;
 570         `       {emit_string cmplg}     {emit_gpr 31}, {emit_gpr 30}\n`;
 571         `       addi    {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`;
 572         `       bltl    {emit_label !call_gc_label}\n`;
 573         record_frame i.live Debuginfo.none
 574     | Lop(Ispecific(Ialloc_far n)) ->
 575         if !call_gc_label = 0 then call_gc_label := new_label();
 576         let lbl = new_label() in
 577         `       addi    {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`;
 578         `       {emit_string cmplg}     {emit_gpr 31}, {emit_gpr 30}\n`;
 579         `       bge     {emit_label lbl}\n`;
 580         `       bl      {emit_label !call_gc_label}\n`;
 581         record_frame i.live Debuginfo.none;
 582         `{emit_label lbl}:      addi    {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`
 583     | Lop(Iintop Isub) ->               (* subfc has swapped arguments *)
 584         `       subfc   {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
 585     | Lop(Iintop Imod) ->
 586         `       {emit_string divg}      {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 587         `       {emit_string mullg}     {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`;
 588         `       subfc   {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
 589     | Lop(Iintop(Icomp cmp)) ->
 590         begin match cmp with
 591           Isigned c ->
 592             `   {emit_string cmpg}      {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 593             emit_set_comp c i.res.(0)
 594         | Iunsigned c ->
 595             `   {emit_string cmplg}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 596             emit_set_comp c i.res.(0)
 597         end
 598     | Lop(Iintop Icheckbound) ->
 599         if !Clflags.debug && supports_backtraces then
 600           record_frame Reg.Set.empty i.dbg;
 601         `       {emit_string tglle}   {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
 602     | Lop(Iintop op) ->
 603         let instr = name_for_intop op in
 604         `       {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
 605     | Lop(Iintop_imm(Isub, n)) ->
 606         `       addi    {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
 607     | Lop(Iintop_imm(Idiv, n)) ->       (* n is guaranteed to be a power of 2 *)
 608         let l = Misc.log2 n in
 609         `       {emit_string sragi}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
 610         `       addze   {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 611     | Lop(Iintop_imm(Imod, n)) ->       (* n is guaranteed to be a power of 2 *)
 612         let l = Misc.log2 n in
 613         `       {emit_string sragi}     {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
 614         `       addze   {emit_gpr 0}, {emit_gpr 0}\n`;
 615         `       {emit_string slgi}      {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`;
 616         `       subfc   {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
 617     | Lop(Iintop_imm(Icomp cmp, n)) ->
 618         begin match cmp with
 619           Isigned c ->
 620             `   {emit_string cmpg}i     {emit_reg i.arg.(0)}, {emit_int n}\n`;
 621             emit_set_comp c i.res.(0)
 622         | Iunsigned c ->
 623             `   {emit_string cmplg}i    {emit_reg i.arg.(0)}, {emit_int n}\n`;
 624             emit_set_comp c i.res.(0)
 625         end
 626     | Lop(Iintop_imm(Icheckbound, n)) ->
 627         if !Clflags.debug && supports_backtraces then
 628           record_frame Reg.Set.empty i.dbg;
 629         `       {emit_string tglle}i   {emit_reg i.arg.(0)}, {emit_int n}\n`
 630     | Lop(Iintop_imm(op, n)) ->
 631         let instr = name_for_intop_imm op in
 632         `       {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
 633     | Lop(Inegf | Iabsf as op) ->
 634         let instr = name_for_floatop1 op in
 635         `       {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
 636     | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
 637         let instr = name_for_floatop2 op in
 638         `       {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
 639     | Lop(Ifloatofint) ->
 640         if ppc64 then begin
 641           `     stdu    {emit_reg i.arg.(0)}, -16({emit_gpr 1})\n`;
 642           `     lfd     {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`;
 643           `     addi    {emit_gpr 1}, {emit_gpr 1}, 16\n`;
 644           `     fcfid   {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 645         end else begin
 646           let lbl = new_label() in
 647           float_literals := ("4.503601774854144e15", lbl) :: !float_literals;
 648           (* That float above represents 0x4330000080000000 *)
 649           `     addis   {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
 650           `     lfd     {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`;
 651           `     lis     {emit_gpr 0}, 0x4330\n`;
 652           `     stwu    {emit_gpr 0}, -16({emit_gpr 1})\n`;
 653           `     xoris   {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`;
 654           `     stw     {emit_gpr 0}, 4({emit_gpr 1})\n`;
 655           `     lfd     {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`;
 656           `     addi    {emit_gpr 1}, {emit_gpr 1}, 16\n`;
 657           `     fsub    {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n`
 658         end
 659     | Lop(Iintoffloat) ->
 660         let ofs = if ppc64 then 0 else 4 in
 661         `       {emit_string fctigz}    {emit_fpr 0}, {emit_reg i.arg.(0)}\n`;
 662         `       stfdu   {emit_fpr 0}, -16({emit_gpr 1})\n`;
 663         `       {emit_string lg}        {emit_reg i.res.(0)}, {emit_int ofs}({emit_gpr 1})\n`;
 664         `       addi    {emit_gpr 1}, {emit_gpr 1}, 16\n`
 665     | Lop(Ispecific sop) ->
 666         let instr = name_for_specific sop in
 667         `       {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
 668     | Lreloadretaddr ->
 669         let n = frame_size() in
 670         `       {emit_string lg}        {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`;
 671         `       mtlr    {emit_gpr 11}\n`
 672     | Lreturn ->
 673         let n = frame_size() in
 674         if n > 0 then
 675           `     addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`;
 676         `       blr\n`
 677     | Llabel lbl ->
 678         `{emit_label lbl}:\n`
 679     | Lbranch lbl ->
 680         `       b       {emit_label lbl}\n`
 681     | Lcondbranch(tst, lbl) ->
 682         begin match tst with
 683           Itruetest ->
 684             `   {emit_string cmpg}i     {emit_reg i.arg.(0)}, 0\n`;
 685             emit_delay dslot;
 686             `   bne     {emit_label lbl}\n`
 687         | Ifalsetest ->
 688             `   {emit_string cmpg}i     {emit_reg i.arg.(0)}, 0\n`;
 689             emit_delay dslot;
 690             `   beq     {emit_label lbl}\n`
 691         | Iinttest cmp ->
 692             let (comp, branch) = name_for_int_comparison cmp in
 693             `   {emit_string comp}      {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 694             emit_delay dslot;
 695             `   {emit_string branch}    {emit_label lbl}\n`
 696         | Iinttest_imm(cmp, n) ->
 697             let (comp, branch) = name_for_int_comparison cmp in
 698             `   {emit_string comp}i     {emit_reg i.arg.(0)}, {emit_int n}\n`;
 699             emit_delay dslot;
 700             `   {emit_string branch}    {emit_label lbl}\n`
 701         | Ifloattest(cmp, neg) ->
 702             `   fcmpu   {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 703             (* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
 704             let (bitnum, negtst) =
 705               match cmp with
 706                 Ceq -> (2, neg)
 707               | Cne -> (2, not neg)
 708               | Cle -> `        cror    3, 0, 2\n`; (* lt or eq *)
 709                        (3, neg)
 710               | Cgt -> (1, neg)
 711               | Cge -> `        cror    3, 1, 2\n`; (* gt or eq *)
 712                        (3, neg)
 713               | Clt -> (0, neg) in
 714             emit_delay dslot;
 715             if negtst
 716             then `      bf      {emit_int bitnum}, {emit_label lbl}\n`
 717             else `      bt      {emit_int bitnum}, {emit_label lbl}\n`
 718         | Ioddtest ->
 719             `   andi.   {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`;
 720             emit_delay dslot;
 721             `   bne     {emit_label lbl}\n`
 722         | Ieventest ->
 723             `   andi.   {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`;
 724             emit_delay dslot;
 725             `   beq     {emit_label lbl}\n`
 726         end
 727     | Lcondbranch3(lbl0, lbl1, lbl2) ->
 728         `       {emit_string cmpg}i     {emit_reg i.arg.(0)}, 1\n`;
 729         emit_delay dslot;
 730         begin match lbl0 with
 731           None -> ()
 732         | Some lbl -> ` blt     {emit_label lbl}\n`
 733         end;
 734         begin match lbl1 with
 735           None -> ()
 736         | Some lbl -> ` beq     {emit_label lbl}\n`
 737         end;
 738         begin match lbl2 with
 739           None -> ()
 740         | Some lbl -> ` bgt     {emit_label lbl}\n`
 741         end
 742     | Lswitch jumptbl ->
 743         let lbl = new_label() in
 744         `       addis   {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
 745         `       addi    {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label lbl}\n`;
 746         `       {emit_string slgi}      {emit_gpr 0}, {emit_reg i.arg.(0)}, 2\n`;
 747         `       {emit_string lwa}x      {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`;
 748         `       add     {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`;
 749         `       mtctr   {emit_gpr 0}\n`;
 750         `       bctr\n`;
 751         emit_string rodata_space;
 752         `{emit_label lbl}:`;
 753         for i = 0 to Array.length jumptbl - 1 do
 754           `     .long   {emit_label jumptbl.(i)} - {emit_label lbl}\n`
 755         done;
 756         emit_string code_space
 757     | Lsetuptrap lbl ->
 758         `       bl      {emit_label lbl}\n`
 759     | Lpushtrap ->
 760         stack_offset := !stack_offset + 16;
 761         `       mflr    {emit_gpr 0}\n`;
 762         `       {emit_string stg}u      {emit_gpr 0}, -16({emit_gpr 1})\n`;
 763         `       {emit_string stg}       {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`;
 764         `       mr      {emit_gpr 29}, {emit_gpr 1}\n`
 765     | Lpoptrap ->
 766         `       {emit_string lg}        {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`;
 767         `       addi    {emit_gpr 1}, {emit_gpr 1}, 16\n`;
 768         stack_offset := !stack_offset - 16
 769     | Lraise ->
 770         if !Clflags.debug && supports_backtraces then begin
 771           `     bl      {emit_symbol "caml_raise_exn"}\n`;
 772           record_frame Reg.Set.empty i.dbg
 773         end else begin
 774           `     {emit_string lg}        {emit_gpr 0}, 0({emit_gpr 29})\n`;
 775           `     mr      {emit_gpr 1}, {emit_gpr 29}\n`;
 776           `     mtlr    {emit_gpr 0}\n`;
 777           `     {emit_string lg}        {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`;
 778           `     addi    {emit_gpr 1}, {emit_gpr 1}, 16\n`;
 779           `     blr\n`
 780         end
 781
 782 and emit_delay = function
 783     None -> ()
 784   | Some i -> emit_instr i None
 785
 786 (* Checks if a pseudo-instruction expands to instructions
 787    that do not branch and do not affect CR0 nor R12. *)
 788
 789 let is_simple_instr i =
 790   match i.desc with
 791     Lop op ->
 792       begin match op with
 793         Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind |
 794         Iextcall(_, _) -> false
 795       | Ialloc(_) -> false
 796       | Iintop(Icomp _) -> false
 797       | Iintop_imm(Iand, _) -> false
 798       | Iintop_imm(Icomp _, _) -> false
 799       | _ -> true
 800       end
 801   | Lreloadretaddr -> true
 802   | _ -> false
 803
 804 let no_interference res arg =
 805   try
 806     for i = 0 to Array.length arg - 1 do
 807       for j = 0 to Array.length res - 1 do
 808         if arg.(i).loc = res.(j).loc then raise Exit
 809       done
 810     done;
 811     true
 812   with Exit ->
 813     false
 814
 815 (* Emit a sequence of instructions, trying to fill delay slots for branches *)
 816
 817 let rec emit_all i =
 818   match i with
 819     {desc = Lend} -> ()
 820   | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}}
 821     when is_simple_instr i & no_interference i.res i.next.arg ->
 822       emit_instr i.next (Some i);
 823       emit_all i.next.next
 824   | _ ->
 825       emit_instr i None;
 826       emit_all i.next
 827
 828 (* Emission of a function declaration *)
 829
 830 let fundecl fundecl =
 831   function_name := fundecl.fun_name;
 832   defined_functions := StringSet.add fundecl.fun_name !defined_functions;
 833   tailrec_entry_point := new_label();
 834   stack_offset := 0;
 835   call_gc_label := 0;
 836   float_literals := [];
 837   int_literals := [];
 838   if Config.system = "rhapsody"
 839   && not !Clflags.output_c_object
 840   && is_generic_function fundecl.fun_name
 841   then (* PR#4690 *)
 842     `   .private_extern {emit_symbol fundecl.fun_name}\n`
 843   else
 844   `     .globl  {emit_symbol fundecl.fun_name}\n`;
 845   begin match Config.system with
 846   | "elf" | "bsd" ->
 847       ` .type   {emit_symbol fundecl.fun_name}, @function\n`
 848   | _ -> ()
 849   end;
 850   emit_string code_space;
 851   `     .align  2\n`;
 852   `{emit_symbol fundecl.fun_name}:\n`;
 853   let n = frame_size() in
 854   if !contains_calls then begin
 855     `   mflr    {emit_gpr 0}\n`;
 856     `   addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`;
 857     `   {emit_string stg}       {emit_gpr 0}, {emit_int(n - size_addr)}({emit_gpr 1})\n`
 858   end else begin
 859     if n > 0 then
 860       ` addi    {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`
 861   end;
 862   `{emit_label !tailrec_entry_point}:\n`;
 863   branch_normalization fundecl.fun_body;
 864   emit_all fundecl.fun_body;
 865   (* Emit the glue code to call the GC *)
 866   if !call_gc_label > 0 then begin
 867     `{emit_label !call_gc_label}:\n`;
 868     `   b       {emit_symbol "caml_call_gc"}\n`
 869   end;
 870   (* Emit the numeric literals *)
 871   if !float_literals <> [] || !int_literals <> [] then begin
 872     emit_string rodata_space;
 873     `   .align  3\n`;
 874     List.iter
 875       (fun (f, lbl) ->
 876         `{emit_label lbl}:`;
 877         if ppc64
 878         then emit_float64_directive ".quad" f
 879         else emit_float64_split_directive ".long" f)
 880       !float_literals;
 881     List.iter
 882       (fun (n, lbl) ->
 883         `{emit_label lbl}:      {emit_string datag}     {emit_nativeint n}\n`)
 884       !int_literals
 885   end
 886
 887 (* Emission of data *)
 888
 889 let declare_global_data s =
 890   `     .globl  {emit_symbol s}\n`;
 891   if Config.system = "elf" || Config.system = "bsd" then
 892     `   .type   {emit_symbol s}, @object\n`
 893
 894 let emit_item = function
 895     Cglobal_symbol s ->
 896       declare_global_data s
 897   | Cdefine_symbol s ->
 898       `{emit_symbol s}:\n`;
 899   | Cdefine_label lbl ->
 900       `{emit_label (lbl + 100000)}:\n`
 901   | Cint8 n ->
 902       ` .byte   {emit_int n}\n`
 903   | Cint16 n ->
 904       ` .short  {emit_int n}\n`
 905   | Cint32 n ->
 906       ` .long   {emit_nativeint n}\n`
 907   | Cint n ->
 908       ` {emit_string datag}     {emit_nativeint n}\n`
 909   | Csingle f ->
 910       emit_float32_directive ".long" f
 911   | Cdouble f ->
 912       if ppc64
 913       then emit_float64_directive ".quad" f
 914       else emit_float64_split_directive ".long" f
 915   | Csymbol_address s ->
 916       ` {emit_string datag}     {emit_symbol s}\n`
 917   | Clabel_address lbl ->
 918       ` {emit_string datag}     {emit_label (lbl + 100000)}\n`
 919   | Cstring s ->
 920       emit_bytes_directive "    .byte   " s
 921   | Cskip n ->
 922       if n > 0 then `   .space  {emit_int n}\n`
 923   | Calign n ->
 924       ` .align  {emit_int (Misc.log2 n)}\n`
 925
 926 let data l =
 927   emit_string data_space;
 928   List.iter emit_item l
 929
 930 (* Beginning / end of an assembly file *)
 931
 932 let begin_assembly() =
 933   defined_functions := StringSet.empty;
 934   external_functions := StringSet.empty;
 935   (* Emit the beginning of the segments *)
 936   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
 937   emit_string data_space;
 938   declare_global_data lbl_begin;
 939   `{emit_symbol lbl_begin}:\n`;
 940   let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
 941   emit_string code_space;
 942   declare_global_data lbl_begin;
 943   `{emit_symbol lbl_begin}:\n`
 944
 945 let end_assembly() =
 946   if pic_externals then
 947     (* Emit the pointers to external functions *)
 948     StringSet.iter emit_external !external_functions;
 949   (* Emit the end of the segments *)
 950   emit_string code_space;
 951   let lbl_end = Compilenv.make_symbol (Some "code_end") in
 952   declare_global_data lbl_end;
 953   `{emit_symbol lbl_end}:\n`;
 954   `     .long   0\n`;
 955   emit_string data_space;
 956   let lbl_end = Compilenv.make_symbol (Some "data_end") in
 957   declare_global_data lbl_end;
 958   `{emit_symbol lbl_end}:\n`;
 959   `     {emit_string datag}     0\n`;
 960   (* Emit the frame descriptors *)
 961   emit_string rodata_space;
 962   let lbl = Compilenv.make_symbol (Some "frametable") in
 963   declare_global_data lbl;
 964   `{emit_symbol lbl}:\n`;
 965   emit_frames
 966     { efa_label = (fun l -> `   {emit_string datag}     {emit_label l}\n`);
 967       efa_16 = (fun n -> `      .short  {emit_int n}\n`);
 968       efa_32 = (fun n -> `      .long   {emit_int32 n}\n`);
 969       efa_word = (fun n -> `    {emit_string datag}     {emit_int n}\n`);
 970       efa_align = (fun n -> `   .align  {emit_int (Misc.log2 n)}\n`);
 971       efa_label_rel = (fun lbl ofs ->
 972                            `    .long   ({emit_label lbl} - .) + {emit_int32 ofs}\n`);
 973       efa_def_label = (fun l -> `{emit_label l}:\n`);
 974       efa_string = (fun s -> emit_bytes_directive "     .byte   " (s ^ "\000"))
 975      }