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

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1998 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 9314 2009-07-15 12:14:39Z xleroy $ *)
  14
  15 (* Emission of ARM assembly code *)
  16
  17 open Location
  18 open Misc
  19 open Cmm
  20 open Arch
  21 open Proc
  22 open Reg
  23 open Mach
  24 open Linearize
  25 open Emitaux
  26
  27 (* Tradeoff between code size and code speed *)
  28
  29 let fastcode_flag = ref true
  30
  31 (* Output a label *)
  32
  33 let emit_label lbl =
  34   emit_string ".L"; emit_int lbl
  35
  36 (* Output a symbol *)
  37
  38 let emit_symbol s =
  39   Emitaux.emit_symbol '$' s
  40
  41 (* Output a pseudo-register *)
  42
  43 let emit_reg r =
  44   match r.loc with
  45     Reg r -> emit_string (register_name r)
  46   | _ -> fatal_error "Emit_arm.emit_reg"
  47
  48 (* Output the next register after the given pseudo-register *)
  49
  50 let emit_next_reg r =
  51   match r.loc with
  52     Reg r -> emit_string (register_name(r + 1))
  53   | _ -> fatal_error "Emit_arm.emit_next_reg"
  54
  55 (* Layout of the stack frame *)
  56
  57 let stack_offset = ref 0
  58
  59 let frame_size () =
  60   !stack_offset +
  61   4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
  62   (if !contains_calls then 4 else 0)
  63
  64 let slot_offset loc cl =
  65   match loc with
  66     Incoming n -> frame_size() + n
  67   | Local n ->
  68       if cl = 0
  69       then !stack_offset + num_stack_slots.(1) * 8 + n * 4
  70       else !stack_offset + n * 8
  71   | Outgoing n -> n
  72
  73 (* Output a stack reference *)
  74
  75 let emit_stack r =
  76   match r.loc with
  77     Stack s ->
  78       let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
  79   | _ -> fatal_error "Emit_arm.emit_stack"
  80
  81 (* Output an addressing mode *)
  82
  83 let emit_addressing addr r n =
  84   match addr with
  85     Iindexed ofs ->
  86       `[{emit_reg r.(n)}, #{emit_int ofs}]`
  87
  88 (* Record live pointers at call points *)
  89
  90 type frame_descr =
  91   { fd_lbl: int;                        (* Return address *)
  92     fd_frame_size: int;                 (* Size of stack frame *)
  93     fd_live_offset: int list }          (* Offsets/regs of live addresses *)
  94
  95 let frame_descriptors = ref([] : frame_descr list)
  96
  97 let record_frame live =
  98   let lbl = new_label() in
  99   let live_offset = ref [] in
 100   Reg.Set.iter
 101     (function
 102         {typ = Addr; loc = Reg r} ->
 103           live_offset := (r lsl 1) + 1 :: !live_offset
 104       | {typ = Addr; loc = Stack s} as reg ->
 105           live_offset := slot_offset s (register_class reg) :: !live_offset
 106       | _ -> ())
 107     live;
 108   frame_descriptors :=
 109     { fd_lbl = lbl;
 110       fd_frame_size = frame_size();
 111       fd_live_offset = !live_offset } :: !frame_descriptors;
 112   `{emit_label lbl}:`
 113
 114 let emit_frame fd =
 115   `     .word   {emit_label fd.fd_lbl} + 4\n`;
 116   `     .short  {emit_int fd.fd_frame_size}\n`;
 117   `     .short  {emit_int (List.length fd.fd_live_offset)}\n`;
 118   List.iter
 119     (fun n ->
 120       ` .short  {emit_int n}\n`)
 121     fd.fd_live_offset;
 122   `     .align  2\n`
 123
 124 (* Names of various instructions *)
 125
 126 let name_for_comparison = function
 127     Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
 128   | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
 129   | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
 130   | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
 131
 132 let name_for_float_comparison cmp neg =
 133   match cmp with
 134     Ceq -> if neg then "ne" else "eq"
 135   | Cne -> if neg then "eq" else "ne"
 136   | Cle -> if neg then "hi" else "ls"
 137   | Cge -> if neg then "lt" else "ge"
 138   | Clt -> if neg then "pl" else "mi"
 139   | Cgt -> if neg then "le" else "gt"
 140
 141 let name_for_int_operation = function
 142     Iadd -> "add"
 143   | Isub -> "sub"
 144   | Imul -> "mul"
 145   | Iand  -> "and"
 146   | Ior   -> "orr"
 147   | Ixor  -> "eor"
 148   | _ -> assert false
 149
 150 let name_for_shift_operation = function
 151     Ilsl -> "lsl"
 152   | Ilsr -> "lsr"
 153   | Iasr -> "asr"
 154   | _ -> assert false
 155
 156 let name_for_shift_int_operation = function
 157     Ishiftadd -> "add"
 158   | Ishiftsub -> "sub"
 159   | Ishiftsubrev -> "rsb"
 160
 161 let name_for_float_operation = function
 162     Inegf -> "mnfd"
 163   | Iabsf -> "absd"
 164   | Iaddf -> "adfd"
 165   | Isubf -> "sufd"
 166   | Imulf -> "mufd"
 167   | Idivf -> "dvfd"
 168   | Ifloatofint -> "fltd"
 169   | Iintoffloat -> "fixz"
 170   | _ -> assert false
 171
 172 (* Recognize immediate operands *)
 173
 174 (* Immediate operands are 8-bit immediate values, zero-extended, and rotated
 175    right by 0, 2, 4, ... 30 bits.
 176    We check only with 8-bit values shifted left 0 to 24 bits. *)
 177
 178 let rec is_immed n shift =
 179   shift <= 24 &&
 180   (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n
 181    || is_immed n (shift + 2))
 182
 183 let is_immediate n = is_immed n 0
 184
 185 (* General functional to decompose a non-immediate integer constant
 186    into 8-bit chunks shifted left 0 ... 24 bits *)
 187
 188 let decompose_intconst n fn =
 189   let i = ref n in
 190   let shift = ref 0 in
 191   let ninstr = ref 0 in
 192   while !i <> 0n do
 193     if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then
 194       shift := !shift + 2
 195     else begin
 196       let mask = Nativeint.shift_left 0xFFn !shift in
 197       let bits = Nativeint.logand !i mask in
 198       fn bits;
 199       shift := !shift + 8;
 200       i := Nativeint.sub !i bits;
 201       incr ninstr
 202     end
 203   done;
 204   !ninstr
 205
 206 (* Emit a non-immediate integer constant *)
 207
 208 let emit_complex_intconst r n =
 209   let first = ref true in
 210   decompose_intconst n
 211     (fun bits ->
 212       if !first
 213       then `    mov     {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n`
 214       else `    add     {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`;
 215       first := false)
 216
 217 (* Adjust sp (up or down) by the given byte amount *)
 218
 219 let emit_stack_adjustment instr n =
 220   if n <= 0 then 0 else
 221     decompose_intconst (Nativeint.of_int n)
 222       (fun bits ->
 223         `       {emit_string instr}     sp, sp, #{emit_nativeint bits}\n`)
 224
 225 (* Adjust alloc_ptr down by the given byte amount *)
 226
 227 let emit_alloc_decrement n =
 228   decompose_intconst (Nativeint.of_int n)
 229     (fun bits ->
 230        `        sub     alloc_ptr, alloc_ptr, #{emit_nativeint bits}\n`)
 231
 232 (* Name of current function *)
 233 let function_name = ref ""
 234 (* Entry point for tail recursive calls *)
 235 let tailrec_entry_point = ref 0
 236 (* Table of symbols referenced *)
 237 let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
 238 (* Table of floating-point literals *)
 239 let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
 240 (* Total space (in word) occupied by pending literals *)
 241 let num_literals = ref 0
 242 (* True if we've at least one pending float literal *)
 243 let pending_float = ref false
 244
 245 (* Label a symbol or float constant *)
 246 let label_constant tbl s size =
 247   try
 248     Hashtbl.find tbl s
 249   with Not_found ->
 250     let lbl = new_label() in
 251     Hashtbl.add tbl s lbl;
 252     num_literals := !num_literals + size;
 253     lbl
 254
 255 (* Emit all pending constants *)
 256
 257 let emit_constants () =
 258   Hashtbl.iter
 259     (fun s lbl ->
 260       `{emit_label lbl}:        .word   {emit_symbol s}\n`)
 261     symbol_constants;
 262   Hashtbl.iter
 263     (fun s lbl ->
 264       `{emit_label lbl}:        .double {emit_string s}\n`)
 265     float_constants;
 266   Hashtbl.clear symbol_constants;
 267   Hashtbl.clear float_constants;
 268   num_literals := 0;
 269   pending_float := false
 270
 271 (* Output the assembly code for an instruction *)
 272
 273 let emit_instr i =
 274     match i.desc with
 275       Lend -> 0
 276     | Lop(Imove | Ispill | Ireload) ->
 277         let src = i.arg.(0) and dst = i.res.(0) in
 278         if src.loc = dst.loc then 0 else begin
 279           match (src, dst) with
 280             {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
 281               ` mov     {emit_reg dst}, {emit_reg src}\n`; 1
 282           | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
 283               ` mvfd    {emit_reg dst}, {emit_reg src}\n`; 1
 284           | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Int|Addr} ->
 285               ` stfd    {emit_reg src}, [sp, #-8]!\n`;
 286               ` ldmfd   sp!, \{{emit_reg dst}, {emit_next_reg dst}}\n`; 2
 287           | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
 288               ` str     {emit_reg src}, {emit_stack dst}\n`; 1
 289           | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
 290               ` stfd    {emit_reg src}, {emit_stack dst}\n`; 1
 291           | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
 292               ` ldr     {emit_reg dst}, {emit_stack src}\n`; 1
 293           | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
 294               ` ldfd    {emit_reg dst}, {emit_stack src}\n`; 1
 295           | _ ->
 296               assert false
 297         end
 298     | Lop(Iconst_int n) ->
 299         let r = i.res.(0) in
 300         let nr = Nativeint.lognot n in
 301         if is_immediate n then begin
 302           `     mov     {emit_reg r}, #{emit_nativeint n}\n`; 1
 303         end else if is_immediate nr then begin
 304           `     mvn     {emit_reg r}, #{emit_nativeint nr}\n`; 1
 305         end else
 306           emit_complex_intconst r n
 307     | Lop(Iconst_float s) ->
 308         begin match Int64.bits_of_float (float_of_string s) with
 309         | 0x0000_0000_0000_0000L ->       (* +0.0 *)
 310           `     mvfd    {emit_reg i.res.(0)}, #0.0\n`
 311         | _ ->
 312           let lbl = label_constant float_constants s 2 in
 313           pending_float := true;
 314           `     ldfd    {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`
 315         end;
 316         1
 317     | Lop(Iconst_symbol s) ->
 318         let lbl = label_constant symbol_constants s 1 in
 319         `       ldr     {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1
 320     | Lop(Icall_ind) ->
 321         `       mov     lr, pc\n`;
 322         `{record_frame i.live}  mov     pc, {emit_reg i.arg.(0)}\n`; 2
 323     | Lop(Icall_imm s) ->
 324         `{record_frame i.live}  bl      {emit_symbol s}\n`; 1
 325     | Lop(Itailcall_ind) ->
 326         let n = frame_size() in
 327         if !contains_calls then
 328           `     ldr     lr, [sp, #{emit_int (n-4)}]\n`;
 329         ignore (emit_stack_adjustment "add" n);
 330         `       mov     pc, {emit_reg i.arg.(0)}\n`; 3
 331     | Lop(Itailcall_imm s) ->
 332         if s = !function_name then begin
 333           `     b       {emit_label !tailrec_entry_point}\n`; 1
 334         end else begin
 335           let n = frame_size() in
 336           if !contains_calls then
 337             `   ldr     lr, [sp, #{emit_int (n-4)}]\n`;
 338           ignore (emit_stack_adjustment "add" n);
 339           `     b       {emit_symbol s}\n`; 3
 340         end
 341     | Lop(Iextcall(s, alloc)) ->
 342         if alloc then begin
 343           let lbl = label_constant symbol_constants s 1 in
 344           `     ldr     r10, {emit_label lbl} @ {emit_symbol s}\n`;
 345           `{record_frame i.live}        bl      caml_c_call\n`; 2
 346         end else begin
 347           `     bl      {emit_symbol s}\n`; 1
 348         end
 349     | Lop(Istackoffset n) ->
 350         let ninstr =
 351           if n >= 0
 352           then emit_stack_adjustment "sub" n
 353           else emit_stack_adjustment "add" (-n) in
 354         stack_offset := !stack_offset + n;
 355         ninstr
 356     | Lop(Iload(Single, addr)) ->
 357         let r = i.res.(0) in
 358         `       ldfs    {emit_reg       r}, {emit_addressing addr i.arg 0}\n`;
 359         `       mvfd    {emit_reg       r}, {emit_reg r}\n`;
 360         2
 361     | Lop(Iload(size, addr)) ->
 362         let r = i.res.(0) in
 363         let instr =
 364           match size with
 365             Byte_unsigned -> "ldrb"
 366           | Byte_signed -> "ldrsb"
 367           | Sixteen_unsigned -> "ldrh"
 368           | Sixteen_signed -> "ldrsh"
 369           | Double | Double_u -> "ldfd"
 370           | _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "ldr" in
 371         `       {emit_string    instr}     {emit_reg r}, {emit_addressing addr i.arg 0}\n`;
 372         1
 373     | Lop(Istore(Single, addr)) ->
 374         let r = i.arg.(0) in
 375         `       mvfs    f7,     {emit_reg r}\n`;
 376         `       stfs    f7,     {emit_addressing addr i.arg 1}\n`;
 377         2
 378     | Lop(Istore(size, addr)) ->
 379         let r = i.arg.(0) in
 380         let instr =
 381           match size with
 382             Byte_unsigned | Byte_signed -> "strb"
 383           | Sixteen_unsigned | Sixteen_signed -> "strh"
 384           | Double | Double_u -> "stfd"
 385           | _ (* Word | Thirtytwo_signed | Thirtytwo_unsigned *) -> "str" in
 386         `       {emit_string    instr}     {emit_reg r}, {emit_addressing addr i.arg 1}\n`;
 387         1
 388     | Lop(Ialloc n) ->
 389         if !fastcode_flag then begin
 390           `     ldr     r10, [alloc_limit, #0]\n`;
 391           let ni = emit_alloc_decrement n in
 392           `     cmp     alloc_ptr, r10\n`;
 393           `{record_frame i.live}        blcc    caml_call_gc\n`;
 394           `     add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
 395           4 + ni
 396         end else if n = 8 || n = 12 || n = 16 then begin
 397             `{record_frame i.live}      bl      caml_alloc{emit_int ((n-4)/4)}\n`;
 398             `   add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2
 399         end else begin
 400             let nn = Nativeint.of_int n in
 401             let ni =
 402               if is_immediate nn then begin
 403                 `       mov     r10, #{emit_int n}\n`; 1
 404               end else
 405                 emit_complex_intconst (phys_reg 8 (*r10*)) nn in
 406             `{record_frame i.live}      bl      caml_allocN\n`;
 407             `   add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
 408             2 + ni
 409         end
 410     | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
 411         let shift = name_for_shift_operation op in
 412         `       mov     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1
 413     | Lop(Iintop(Icomp cmp)) ->
 414         let comp = name_for_comparison cmp in
 415         `       cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 416         `       mov     {emit_reg i.res.(0)}, #0\n`;
 417         `       mov{emit_string comp}   {emit_reg i.res.(0)}, #1\n`; 3
 418     | Lop(Iintop(Icheckbound)) ->
 419         `       cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 420         `       blls    caml_ml_array_bound_error\n`; 2
 421     | Lop(Iintop op) ->
 422         let instr = name_for_int_operation op in
 423         `       {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
 424     | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *)
 425         let l = Misc.log2 n in
 426         let r = i.res.(0) in
 427         `       movs    {emit_reg r}, {emit_reg i.arg.(0)}\n`;
 428         if n <= 256 then
 429           `     addlt   {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n`
 430         else begin
 431           `     addlt   {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
 432           `     sublt   {emit_reg r}, {emit_reg r}, #1\n`
 433         end;
 434         `       mov     {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4
 435     | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
 436         let l = Misc.log2 n in
 437         let a = i.arg.(0) in
 438         let r = i.res.(0) in
 439         let lbl = new_label() in
 440         `       cmp     {emit_reg a}, #0\n`;
 441         `       mov     {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`;
 442         `       mov     {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`;
 443         `       bpl     {emit_label lbl}\n`;
 444         `       cmp     {emit_reg r}, #0\n`;
 445         `       subne   {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
 446         `{emit_label lbl}:\n`; 6
 447     | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) ->
 448         let shift = name_for_shift_operation op in
 449         `       mov     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1
 450     | Lop(Iintop_imm(Icomp cmp, n)) ->
 451         let comp = name_for_comparison cmp in
 452         `       cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
 453         `       mov     {emit_reg i.res.(0)}, #0\n`;
 454         `       mov{emit_string comp}   {emit_reg i.res.(0)}, #1\n`; 3
 455     | Lop(Iintop_imm(Icheckbound, n)) ->
 456         `       cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
 457         `       blls    caml_ml_array_bound_error\n`; 2
 458     | Lop(Iintop_imm(op, n)) ->
 459         let instr = name_for_int_operation op in
 460         `       {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
 461     | Lop(Inegf | Iabsf | Ifloatofint | Iintoffloat as op) ->
 462         let instr = name_for_float_operation op in
 463         `       {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
 464     | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
 465         let instr = name_for_float_operation op in
 466         `       {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
 467     | Lop(Ispecific(Ishiftarith(op, shift))) ->
 468         let instr = name_for_shift_int_operation op in
 469         `       {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
 470         if shift >= 0
 471         then `, lsl #{emit_int shift}\n`
 472         else `, asr #{emit_int (-shift)}\n`;
 473         1
 474     | Lop(Ispecific(Ishiftcheckbound shift)) ->
 475         `       cmp     {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
 476         `       blcs    caml_ml_array_bound_error\n`; 2
 477     | Lop(Ispecific(Irevsubimm n)) ->
 478         `       rsb     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
 479     | Lreloadretaddr ->
 480         let n = frame_size() in
 481         `       ldr     lr, [sp, #{emit_int(n-4)}]\n`; 1
 482     | Lreturn ->
 483         let n = frame_size() in
 484         ignore(emit_stack_adjustment "add" n);
 485         `       mov     pc, lr\n`; 2
 486     | Llabel lbl ->
 487         `{emit_label lbl}:\n`; 0
 488     | Lbranch lbl ->
 489         `       b       {emit_label lbl}\n`; 1
 490     | Lcondbranch(tst, lbl) ->
 491         begin match tst with
 492           Itruetest ->
 493             `   cmp     {emit_reg i.arg.(0)}, #0\n`;
 494             `   bne     {emit_label lbl}\n`
 495         | Ifalsetest ->
 496             `   cmp     {emit_reg i.arg.(0)}, #0\n`;
 497             `   beq     {emit_label lbl}\n`
 498         | Iinttest cmp ->
 499             `   cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
 500             let comp = name_for_comparison cmp in
 501             `   b{emit_string   comp}     {emit_label lbl}\n`
 502         | Iinttest_imm(cmp, n) ->
 503             `   cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
 504             let comp = name_for_comparison cmp in
 505             `   b{emit_string   comp}     {emit_label lbl}\n`
 506         | Ifloattest(cmp, neg) ->
 507             begin match cmp with
 508               Ceq | Cne ->
 509                 `       cmf     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
 510             | _ ->
 511                 `       cmfe    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
 512             end;
 513             let comp = name_for_float_comparison cmp neg in
 514             `   b{emit_string   comp}     {emit_label lbl}\n`
 515         | Ioddtest ->
 516             `   tst     {emit_reg i.arg.(0)}, #1\n`;
 517             `   bne     {emit_label lbl}\n`
 518         | Ieventest ->
 519             `   tst     {emit_reg i.arg.(0)}, #1\n`;
 520             `   beq     {emit_label lbl}\n`
 521         end;
 522         2
 523   | Lcondbranch3(lbl0, lbl1, lbl2) ->
 524         `       cmp     {emit_reg i.arg.(0)}, #1\n`;
 525         begin match lbl0 with
 526           None -> ()
 527         | Some lbl -> ` blt     {emit_label lbl}\n`
 528         end;
 529         begin match lbl1 with
 530           None -> ()
 531         | Some lbl -> ` beq     {emit_label lbl}\n`
 532         end;
 533         begin match lbl2 with
 534           None -> ()
 535         | Some lbl -> ` bgt     {emit_label lbl}\n`
 536         end;
 537         4
 538   | Lswitch jumptbl ->
 539         `       ldr     pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
 540         `       mov     r0, r0\n`;      (* nop *)
 541         for i = 0 to Array.length jumptbl - 1 do
 542           `     .word   {emit_label jumptbl.(i)}\n`
 543         done;
 544         2 + Array.length jumptbl
 545     | Lsetuptrap lbl ->
 546         `       bl      {emit_label lbl}\n`; 1
 547     | Lpushtrap ->
 548         stack_offset := !stack_offset + 8;
 549         `       stmfd   sp!, \{trap_ptr, lr}\n`;
 550         `       mov     trap_ptr, sp\n`; 2
 551     | Lpoptrap ->
 552         `       ldmfd   sp!, \{trap_ptr, lr}\n`;
 553         stack_offset := !stack_offset - 8; 1
 554     | Lraise ->
 555         `       mov     sp, trap_ptr\n`;
 556         `       ldmfd   sp!, \{trap_ptr, pc}\n`; 2
 557
 558 (* Emission of an instruction sequence *)
 559
 560 let no_fallthrough = function
 561     Lop(Itailcall_ind | Itailcall_imm _) -> true
 562   | Lreturn -> true
 563   | Lbranch _ -> true
 564   | Lswitch _ -> true
 565   | Lraise -> true
 566   | _ -> false
 567
 568 let rec emit_all ninstr i =
 569   if i.desc = Lend then () else begin
 570     let n = emit_instr i in
 571     let ninstr' = ninstr + n in
 572     let limit = (if !pending_float then 127 else 511) - !num_literals in
 573     if ninstr' >= limit - 32 && no_fallthrough i.desc then begin
 574       emit_constants();
 575       emit_all 0 i.next
 576     end else
 577     if ninstr' >= limit then begin
 578       let lbl = new_label() in
 579       ` b       {emit_label lbl}\n`;
 580       emit_constants();
 581       `{emit_label lbl}:\n`;
 582       emit_all 0 i.next
 583     end else
 584       emit_all ninstr' i.next
 585   end
 586
 587 (* Emission of a function declaration *)
 588
 589 let fundecl fundecl =
 590   function_name := fundecl.fun_name;
 591   fastcode_flag := fundecl.fun_fast;
 592   tailrec_entry_point := new_label();
 593   stack_offset := 0;
 594   Hashtbl.clear symbol_constants;
 595   Hashtbl.clear float_constants;
 596   `     .text\n`;
 597   `     .align  0\n`;
 598   `     .global {emit_symbol fundecl.fun_name}\n`;
 599   `{emit_symbol fundecl.fun_name}:\n`;
 600   let n = frame_size() in
 601   ignore(emit_stack_adjustment "sub" n);
 602   if !contains_calls then
 603     `   str     lr, [sp, #{emit_int(n - 4)}]\n`;
 604   `{emit_label !tailrec_entry_point}:\n`;
 605   emit_all 0 fundecl.fun_body;
 606   emit_constants()
 607
 608 (* Emission of data *)
 609
 610 let emit_item = function
 611     Cglobal_symbol s ->
 612       ` .global {emit_symbol s}\n`;
 613   | Cdefine_symbol s ->
 614       `{emit_symbol s}:\n`
 615   | Cdefine_label lbl ->
 616       `{emit_label (10000 + lbl)}:\n`
 617   | Cint8 n ->
 618       ` .byte   {emit_int n}\n`
 619   | Cint16 n ->
 620       ` .short  {emit_int n}\n`
 621   | Cint32 n ->
 622       ` .word   {emit_nativeint n}\n`
 623   | Cint n ->
 624       ` .word   {emit_nativeint n}\n`
 625   | Csingle f ->
 626       ` .float  {emit_string    f}\n`
 627   | Cdouble f ->
 628       (* FIXME: this version of the ARM port is mixed-endian, so we
 629          use .double instead of emit_float64_directive.  The next
 630          version is little-endian, so we'll use emit_float64 then. *)
 631       ` .align  0\n`;
 632       ` .double {emit_string f}\n`
 633   | Csymbol_address s ->
 634       ` .word   {emit_symbol s}\n`
 635   | Clabel_address lbl ->
 636       ` .word   {emit_label (10000 + lbl)}\n`
 637   | Cstring s ->
 638       emit_string_directive "   .ascii  " s
 639   | Cskip n ->
 640       if n > 0 then `   .space  {emit_int n}\n`
 641   | Calign n ->
 642       ` .align  {emit_int(Misc.log2 n)}\n`
 643
 644 let data l =
 645   `     .data\n`;
 646   List.iter emit_item l
 647
 648 (* Beginning / end of an assembly file *)
 649
 650 let begin_assembly() =
 651   `trap_ptr     .req    r11\n`;
 652   `alloc_ptr    .req    r8\n`;
 653   `alloc_limit  .req    r9\n`;
 654   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
 655   `     .data\n`;
 656   `     .global {emit_symbol lbl_begin}\n`;
 657   `{emit_symbol lbl_begin}:\n`;
 658   let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
 659   `     .text\n`;
 660   `     .global {emit_symbol lbl_begin}\n`;
 661   `{emit_symbol lbl_begin}:\n`
 662
 663 let end_assembly () =
 664   let lbl_end = Compilenv.make_symbol (Some "code_end") in
 665   `     .text\n`;
 666   `     .global {emit_symbol lbl_end}\n`;
 667   `{emit_symbol lbl_end}:\n`;
 668   let lbl_end = Compilenv.make_symbol (Some "data_end") in
 669   `     .data\n`;
 670   `     .global {emit_symbol lbl_end}\n`;
 671   `{emit_symbol lbl_end}:\n`;
 672   `     .word   0\n`;
 673   let lbl = Compilenv.make_symbol (Some "frametable") in
 674   `     .data\n`;
 675   `     .global {emit_symbol lbl}\n`;
 676   `{emit_symbol lbl}:\n`;
 677   `     .word   {emit_int (List.length !frame_descriptors)}\n`;
 678   List.iter emit_frame !frame_descriptors;
 679   frame_descriptors := []