1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Benedikt Meurer, University of Siegen *)
(* *)
(* Copyright 2013 Institut National de Recherche en Informatique *)
(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *)
(* reserved. This file is distributed under the terms of the Q *)
(* Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Emission of ARM assembly code, 64-bit mode *)
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
(* Names for special regs *)
let reg_trap_ptr = phys_reg 23
let reg_alloc_ptr = phys_reg 24
let reg_alloc_limit = phys_reg 25
let reg_tmp1 = phys_reg 26
let reg_tmp2 = phys_reg 27
let reg_x15 = phys_reg 15
(* Output a label *)
let emit_label lbl =
emit_string ".L"; emit_int lbl
let emit_data_label lbl =
emit_string ".Ld"; emit_int lbl
(* Symbols *)
let emit_symbol s =
Emitaux.emit_symbol '$' s
(* Output a pseudo-register *)
let emit_reg = function
{loc = Reg r} -> emit_string (register_name r)
| _ -> fatal_error "Emit.emit_reg"
(* Likewise, but with the 32-bit name of the register *)
let int_reg_name_w =
[| "w0"; "w1"; "w2"; "w3"; "w4"; "w5"; "w6"; "w7";
"w8"; "w9"; "w10"; "w11"; "w12"; "w13"; "w14"; "w15";
"w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25";
"w26"; "w27"; "w28"; "w16"; "w17" |]
let emit_wreg = function
{loc = Reg r} -> emit_string int_reg_name_w.(r)
| _ -> fatal_error "Emit.emit_wreg"
(* Layout of the stack frame *)
let stack_offset = ref 0
let frame_size () =
let sz =
!stack_offset +
8 * num_stack_slots.(0) +
8 * num_stack_slots.(1) +
(if !contains_calls then 8 else 0)
in Misc.align sz 16
let slot_offset loc cl =
match loc with
Incoming n ->
assert (n >= 0);
frame_size() + n
| Local n ->
!stack_offset +
(if cl = 0
then n * 8
else num_stack_slots.(0) * 8 + n * 8)
| Outgoing n ->
assert (n >= 0);
n
(* Output a stack reference *)
let emit_stack r =
match r.loc with
| Stack s ->
let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
| _ -> fatal_error "Emit.emit_stack"
(* Output an addressing mode *)
let emit_symbol_offset s ofs =
emit_symbol s;
if ofs > 0 then `+{emit_int ofs}`
else if ofs < 0 then `-{emit_int (-ofs)}`
else ()
let emit_addressing addr r =
match addr with
| Iindexed ofs ->
`[{emit_reg r}, #{emit_int ofs}]`
| Ibased(s, ofs) ->
`[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]`
(* Record live pointers at call points *)
let record_frame_label live dbg =
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;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
let record_frame live dbg =
let lbl = record_frame_label live dbg in `{emit_label lbl}:`
(* Record calls to the GC -- we've moved them out of the way *)
type gc_call =
{ gc_lbl: label; (* Entry label *)
gc_return_lbl: label; (* Where to branch after GC *)
gc_frame_lbl: label } (* Label of frame descriptor *)
let call_gc_sites = ref ([] : gc_call list)
let emit_call_gc gc =
`{emit_label gc.gc_lbl}: bl {emit_symbol "caml_call_gc"}\n`;
`{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n`
(* Record calls to caml_ml_array_bound_error.
In debug mode, we maintain one call to caml_ml_array_bound_error
per bound check site. Otherwise, we can share a single call. *)
type bound_error_call =
{ bd_lbl: label; (* Entry label *)
bd_frame_lbl: label } (* Label of frame descriptor *)
let bound_error_sites = ref ([] : bound_error_call list)
let bound_error_label dbg =
if !Clflags.debug || !bound_error_sites = [] then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label Reg.Set.empty dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error;
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
lbl_bound_error
end else begin
let bd = List.hd !bound_error_sites in bd.bd_lbl
end
let emit_call_bound_error bd =
`{emit_label bd.bd_lbl}: bl {emit_symbol "caml_ml_array_bound_error"}\n`;
`{emit_label bd.bd_frame_lbl}:\n`
(* Names of various instructions *)
let name_for_comparison = function
| Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
| Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
| Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
let name_for_int_operation = function
| Iadd -> "add"
| Isub -> "sub"
| Imul -> "mul"
| Idiv -> "sdiv"
| Iand -> "and"
| Ior -> "orr"
| Ixor -> "eor"
| Ilsl -> "lsl"
| Ilsr -> "lsr"
| Iasr -> "asr"
| _ -> assert false
(* Load an integer constant into a register *)
let emit_intconst dst n =
let rec emit_pos first shift =
if shift < 0 then begin
if first then ` mov {emit_reg dst}, xzr\n`
end else begin
let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
if s = 0n then emit_pos first (shift - 16) else begin
if first then
` movz {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`
else
` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
emit_pos false (shift - 16)
end
end
and emit_neg first shift =
if shift < 0 then begin
if first then ` movn {emit_reg dst}, #0\n`
end else begin
let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
if s = 0xFFFFn then emit_neg first (shift - 16) else begin
if first then
` movn {emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n`
else
` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
emit_neg false (shift - 16)
end
end
in
if n < 0n then emit_neg true 48 else emit_pos true 48
let num_instructions_for_intconst n =
let num_instructions = ref 0 in
let rec count_pos first shift =
if shift < 0 then begin
if first then incr num_instructions
end else begin
let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
if s = 0n then count_pos first (shift - 16) else begin
incr num_instructions;
count_pos false (shift - 16)
end
end
and count_neg first shift =
if shift < 0 then begin
if first then incr num_instructions
end else begin
let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
if s = 0xFFFFn then count_neg first (shift - 16) else begin
incr num_instructions;
count_neg false (shift - 16)
end
end
in
if n < 0n then count_neg true 48 else count_pos true 48;
!num_instructions
(* Recognize float constants appropriate for FMOV dst, #fpimm instruction:
"a normalized binary floating point encoding with 1 sign bit, 4
bits of fraction and a 3-bit exponent" *)
let is_immediate_float bits =
let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in
let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in
exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant
(* Adjust sp (up or down) by the given byte amount *)
let emit_stack_adjustment n =
let instr = if n < 0 then "sub" else "add" in
let m = abs n in
assert (m < 0x1_000_000);
let ml = m land 0xFFF and mh = m land 0xFFF_000 in
if mh <> 0 then ` {emit_string instr} sp, sp, #{emit_int mh}\n`;
if ml <> 0 then ` {emit_string instr} sp, sp, #{emit_int ml}\n`;
if n <> 0 then cfi_adjust_cfa_offset (-n)
(* Deallocate the stack frame and reload the return address
before a return or tail call *)
let output_epilogue f =
let n = frame_size() in
if !contains_calls then
` ldr x30, [sp, #{emit_int (n-8)}]\n`;
if n > 0 then
emit_stack_adjustment n;
f();
(* reset CFA back because function body may continue *)
if n > 0 then cfi_adjust_cfa_offset n
(* Name of current function *)
let function_name = ref ""
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
(* Pending floating-point literals *)
let float_literals = ref ([] : (int64 * label) list)
(* Label a floating-point literal *)
let float_literal f =
try
List.assoc f !float_literals
with Not_found ->
let lbl = new_label() in
float_literals := (f, lbl) :: !float_literals;
lbl
(* Emit all pending literals *)
let emit_literals() =
if !float_literals <> [] then begin
` .align 3\n`;
List.iter
(fun (f, lbl) ->
`{emit_label lbl}:`; emit_float64_directive ".quad" f)
!float_literals;
float_literals := []
end
(* Emit code to load the address of a symbol *)
let emit_load_symbol_addr dst s =
if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin
` adrp {emit_reg dst}, {emit_symbol s}\n`;
` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n`
end else begin
` adrp {emit_reg dst}, :got:{emit_symbol s}\n`;
` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n`
end
(* The following functions are used for calculating the sizes of the
call GC and bounds check points emitted out-of-line from the function
body. See branch_relaxation.mli. *)
let num_call_gc_and_check_bound_points instr =
let rec loop instr ((call_gc, check_bound) as totals) =
match instr.desc with
| Lend -> totals
| Lop (Ialloc _) when !fastcode_flag ->
loop instr.next (call_gc + 1, check_bound)
| Lop (Iintop Icheckbound)
| Lop (Iintop_imm (Icheckbound, _))
| Lop (Ispecific (Ishiftcheckbound _)) ->
let check_bound =
(* When not in debug mode, there is at most one check-bound point. *)
if not !Clflags.debug then 1
else check_bound + 1
in
loop instr.next (call_gc, check_bound)
(* The following four should never be seen, since this function is run
before branch relaxation. *)
| Lop (Ispecific (Ifar_alloc _))
| Lop (Ispecific Ifar_intop_checkbound)
| Lop (Ispecific (Ifar_intop_imm_checkbound _))
| Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false
| _ -> loop instr.next totals
in
loop instr (0, 0)
let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound =
if num_call_gc < 1 && num_check_bound < 1 then 0
else begin
let size_of_call_gc = 2 in
let size_of_check_bound = 1 in
let size_of_last_thing =
(* Call-GC points come before check-bound points. *)
if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc
in
let total_size =
size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound
in
let max_offset = total_size - size_of_last_thing in
assert (max_offset >= 0);
max_offset
end
module BR = Branch_relaxation.Make (struct
(* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we
assume we will never exceed this. It would seem to be most likely to
occur for branches between functions; in this case, the linker should be
able to insert veneers anyway. (See section 4.6.7 of the document
"ELF for the ARM 64-bit architecture (AArch64)".) *)
type distance = int
module Cond_branch = struct
type t = TB | CB | Bcc
let all = [TB; CB; Bcc]
(* AArch64 instructions are 32 bits wide, so [distance] in this module
means units of 32-bit words. *)
let max_displacement = function
| TB -> 32 * 1024 / 4 (* +/- 32Kb *)
| CB | Bcc -> 1 * 1024 * 1024 / 4 (* +/- 1Mb *)
let classify_instr = function
| Lop (Ialloc _)
| Lop (Iintop Icheckbound)
| Lop (Iintop_imm (Icheckbound, _))
| Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc
(* The various "far" variants in [specific_operation] don't need to
return [Some] here, since their code sequences never contain any
conditional branches that might need relaxing. *)
| Lcondbranch (Itruetest, _)
| Lcondbranch (Ifalsetest, _) -> Some CB
| Lcondbranch (Iinttest _, _)
| Lcondbranch (Iinttest_imm _, _)
| Lcondbranch (Ifloattest _, _) -> Some Bcc
| Lcondbranch (Ioddtest, _)
| Lcondbranch (Ieventest, _) -> Some TB
| Lcondbranch3 _ -> Some Bcc
| _ -> None
end
let offset_pc_at_branch = 0
let epilogue_size () =
if !contains_calls then 3 else 2
let instr_size = function
| Lend -> 0
| Lop (Imove | Ispill | Ireload) -> 1
| Lop (Iconst_int n | Iconst_blockheader n) ->
num_instructions_for_intconst n
| Lop (Iconst_float _) -> 2
| Lop (Iconst_symbol _) -> 2
| Lop (Icall_ind) -> 1
| Lop (Icall_imm _) -> 1
| Lop (Itailcall_ind) -> epilogue_size ()
| Lop (Itailcall_imm s) ->
if s = !function_name then 1 else epilogue_size ()
| Lop (Iextcall (_, false)) -> 1
| Lop (Iextcall (_, true)) -> 3
| Lop (Istackoffset _) -> 2
| Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) ->
let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in
based + begin match size with Single -> 2 | _ -> 1 end
| Lop (Ialloc _) when !fastcode_flag -> 4
| Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5
| Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) ->
begin match num_words with
| 16 | 24 | 32 -> 1
| _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words)
end
| Lop (Iintop (Icomp _)) -> 2
| Lop (Iintop_imm (Icomp _, _)) -> 2
| Lop (Iintop Icheckbound) -> 2
| Lop (Ispecific Ifar_intop_checkbound) -> 3
| Lop (Iintop_imm (Icheckbound, _)) -> 2
| Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3
| Lop (Ispecific (Ishiftcheckbound _)) -> 2
| Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3
| Lop (Iintop Imod) -> 2
| Lop (Iintop Imulh) -> 1
| Lop (Iintop _) -> 1
| Lop (Iintop_imm _) -> 1
| Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1
| Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1
| Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1
| Lop (Ispecific (Ishiftarith _)) -> 1
| Lop (Ispecific (Imuladd | Imulsub)) -> 1
| Lop (Ispecific (Ibswap 16)) -> 2
| Lop (Ispecific (Ibswap _)) -> 1
| Lreloadretaddr -> 0
| Lreturn -> epilogue_size ()
| Llabel _ -> 0
| Lbranch _ -> 1
| Lcondbranch (tst, _) ->
begin match tst with
| Itruetest -> 1
| Ifalsetest -> 1
| Iinttest _ -> 2
| Iinttest_imm _ -> 2
| Ifloattest _ -> 2
| Ioddtest -> 1
| Ieventest -> 1
end
| Lcondbranch3 (lbl0, lbl1, lbl2) ->
1 + begin match lbl0 with None -> 0 | Some _ -> 1 end
+ begin match lbl1 with None -> 0 | Some _ -> 1 end
+ begin match lbl2 with None -> 0 | Some _ -> 1 end
| Lswitch jumptbl -> 3 + Array.length jumptbl
| Lsetuptrap _ -> 2
| Lpushtrap -> 3
| Lpoptrap -> 1
| Lraise k ->
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> 1
| false, _
| true, Lambda.Raise_notrace -> 4
end
let relax_allocation ~num_words =
Lop (Ispecific (Ifar_alloc num_words))
let relax_intop_checkbound () =
Lop (Ispecific Ifar_intop_checkbound)
let relax_intop_imm_checkbound ~bound =
Lop (Ispecific (Ifar_intop_imm_checkbound bound))
let relax_specific_op = function
| Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift))
| _ -> assert false
end)
(* Output the assembly code for allocation. *)
let assembly_code_for_allocation i ~n ~far =
let lbl_frame = record_frame_label i.live i.dbg in
if !fastcode_flag then begin
let lbl_redo = new_label() in
let lbl_call_gc = new_label() in
`{emit_label lbl_redo}:`;
` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`;
` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`;
` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`;
if not far then begin
` b.lo {emit_label lbl_call_gc}\n`
end else begin
let lbl = new_label () in
` b.cs {emit_label lbl}\n`;
` b {emit_label lbl_call_gc}\n`;
`{emit_label lbl}:\n`
end;
call_gc_sites :=
{ gc_lbl = lbl_call_gc;
gc_return_lbl = lbl_redo;
gc_frame_lbl = lbl_frame } :: !call_gc_sites
end else begin
begin match n with
| 16 -> ` bl {emit_symbol "caml_alloc1"}\n`
| 24 -> ` bl {emit_symbol "caml_alloc2"}\n`
| 32 -> ` bl {emit_symbol "caml_alloc3"}\n`
| _ -> emit_intconst reg_x15 (Nativeint.of_int n);
` bl {emit_symbol "caml_allocN"}\n`
end;
`{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`
end
(* Output the assembly code for an instruction *)
let emit_instr i =
emit_debug_info i.dbg;
match i.desc with
| Lend -> ()
| Lop(Imove | Ispill | Ireload) ->
let src = i.arg.(0) and dst = i.res.(0) in
if src.loc <> dst.loc then begin
match (src, dst) with
| {loc = Reg _; typ = Float}, {loc = Reg _} ->
` fmov {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg _}, {loc = Reg _} ->
` mov {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg _}, {loc = Stack _} ->
` str {emit_reg src}, {emit_stack dst}\n`
| {loc = Stack _}, {loc = Reg _} ->
` ldr {emit_reg dst}, {emit_stack src}\n`
| _ ->
assert false
end
| Lop(Iconst_int n | Iconst_blockheader n) ->
emit_intconst i.res.(0) n
| Lop(Iconst_float f) ->
let b = Int64.bits_of_float f in
if b = 0L then
` fmov {emit_reg i.res.(0)}, xzr\n`
else if is_immediate_float b then
` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n`
else begin
let lbl = float_literal b in
` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`;
` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
end
| Lop(Iconst_symbol s) ->
emit_load_symbol_addr i.res.(0) s
| Lop(Icall_ind) ->
` blr {emit_reg i.arg.(0)}\n`;
`{record_frame i.live i.dbg}\n`
| Lop(Icall_imm s) ->
` bl {emit_symbol s}\n`;
`{record_frame i.live i.dbg}\n`
| Lop(Itailcall_ind) ->
output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`)
| Lop(Itailcall_imm s) ->
if s = !function_name then
` b {emit_label !tailrec_entry_point}\n`
else
output_epilogue (fun () -> ` b {emit_symbol s}\n`)
| Lop(Iextcall(s, false)) ->
` bl {emit_symbol s}\n`
| Lop(Iextcall(s, true)) ->
emit_load_symbol_addr reg_x15 s;
` bl {emit_symbol "caml_c_call"}\n`;
`{record_frame i.live i.dbg}\n`
| Lop(Istackoffset n) ->
assert (n mod 16 = 0);
emit_stack_adjustment (-n);
stack_offset := !stack_offset + n
| Lop(Iload(size, addr)) ->
let dst = i.res.(0) in
let base =
match addr with
| Iindexed ofs -> i.arg.(0)
| Ibased(s, ofs) ->
` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
reg_tmp1 in
begin match size with
| Byte_unsigned ->
` ldrb {emit_wreg dst}, {emit_addressing addr base}\n`
| Byte_signed ->
` ldrsb {emit_reg dst}, {emit_addressing addr base}\n`
| Sixteen_unsigned ->
` ldrh {emit_wreg dst}, {emit_addressing addr base}\n`
| Sixteen_signed ->
` ldrsh {emit_reg dst}, {emit_addressing addr base}\n`
| Thirtytwo_unsigned ->
` ldr {emit_wreg dst}, {emit_addressing addr base}\n`
| Thirtytwo_signed ->
` ldrsw {emit_reg dst}, {emit_addressing addr base}\n`
| Single ->
` ldr s7, {emit_addressing addr base}\n`;
` fcvt {emit_reg dst}, s7\n`
| Word | Double | Double_u ->
` ldr {emit_reg dst}, {emit_addressing addr base}\n`
end
| Lop(Istore(size, addr, _)) ->
let src = i.arg.(0) in
let base =
match addr with
| Iindexed ofs -> i.arg.(1)
| Ibased(s, ofs) ->
` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
reg_tmp1 in
begin match size with
| Byte_unsigned | Byte_signed ->
` strb {emit_wreg src}, {emit_addressing addr base}\n`
| Sixteen_unsigned | Sixteen_signed ->
` strh {emit_wreg src}, {emit_addressing addr base}\n`
| Thirtytwo_unsigned | Thirtytwo_signed ->
` str {emit_wreg src}, {emit_addressing addr base}\n`
| Single ->
` fcvt s7, {emit_reg src}\n`;
` str s7, {emit_addressing addr base}\n`;
| Word | Double | Double_u ->
` str {emit_reg src}, {emit_addressing addr base}\n`
end
| Lop(Ialloc n) ->
assembly_code_for_allocation i ~n ~far:false
| Lop(Ispecific (Ifar_alloc n)) ->
assembly_code_for_allocation i ~n ~far:true
| Lop(Iintop(Icomp cmp)) ->
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
| Lop(Iintop_imm(Icomp cmp, n)) ->
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
| Lop(Iintop Icheckbound) ->
let lbl = bound_error_label i.dbg in
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` b.ls {emit_label lbl}\n`
| Lop(Ispecific Ifar_intop_checkbound) ->
let lbl = bound_error_label i.dbg in
let lbl2 = new_label () in
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` b.hi {emit_label lbl2}\n`;
` b {emit_label lbl}\n`;
`{emit_label lbl2}:\n`;
| Lop(Iintop_imm(Icheckbound, n)) ->
let lbl = bound_error_label i.dbg in
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
` b.ls {emit_label lbl}\n`
| Lop(Ispecific(Ifar_intop_imm_checkbound bound)) ->
let lbl = bound_error_label i.dbg in
let lbl2 = new_label () in
` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`;
` b.hi {emit_label lbl2}\n`;
` b {emit_label lbl}\n`;
`{emit_label lbl2}:\n`;
| Lop(Ispecific(Ishiftcheckbound shift)) ->
let lbl = bound_error_label i.dbg in
` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
` b.cs {emit_label lbl}\n`
| Lop(Ispecific(Ifar_shiftcheckbound shift)) ->
let lbl = bound_error_label i.dbg in
let lbl2 = new_label () in
` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
` b.lo {emit_label lbl2}\n`;
` b {emit_label lbl}\n`;
`{emit_label lbl2}:\n`;
| Lop(Iintop Imod) ->
` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
| Lop(Iintop Imulh) ->
` smulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
| Lop(Iintop op) ->
let instr = name_for_int_operation op in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
| Lop(Iintop_imm(op, n)) ->
let instr = name_for_int_operation op in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`
| Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) ->
let instr = (match op with
| Ifloatofint -> "scvtf"
| Iintoffloat -> "fcvtzs"
| Iabsf -> "fabs"
| Inegf -> "fneg"
| Ispecific Isqrtf -> "fsqrt"
| _ -> assert false) in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
| Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
let instr = (match op with
| Iaddf -> "fadd"
| Isubf -> "fsub"
| Imulf -> "fmul"
| Idivf -> "fdiv"
| Ispecific Inegmulf -> "fnmul"
| _ -> assert false) in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
| Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
let instr = (match op with
| Imuladdf -> "fmadd"
| Inegmuladdf -> "fnmadd"
| Imulsubf -> "fmsub"
| Inegmulsubf -> "fnmsub"
| _ -> assert false) in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n`
| Lop(Ispecific(Ishiftarith(op, shift))) ->
let instr = (match op with
Ishiftadd -> "add"
| Ishiftsub -> "sub") in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
if shift >= 0
then `, lsl #{emit_int shift}\n`
else `, asr #{emit_int (-shift)}\n`
| Lop(Ispecific(Imuladd | Imulsub as op)) ->
let instr = (match op with
Imuladd -> "madd"
| Imulsub -> "msub"
| _ -> assert false) in
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
| Lop(Ispecific(Ibswap size)) ->
begin match size with
| 16 ->
` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`;
` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n`
| 32 ->
` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`
| 64 ->
` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
| _ ->
assert false
end
| Lreloadretaddr ->
()
| Lreturn ->
output_epilogue (fun () -> ` ret\n`)
| Llabel lbl ->
`{emit_label lbl}:\n`
| Lbranch lbl ->
` b {emit_label lbl}\n`
| Lcondbranch(tst, lbl) ->
begin match tst with
| Itruetest ->
` cbnz {emit_reg i.arg.(0)}, {emit_label lbl}\n`
| Ifalsetest ->
` cbz {emit_reg i.arg.(0)}, {emit_label lbl}\n`
| Iinttest cmp ->
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
let comp = name_for_comparison cmp in
` b.{emit_string comp} {emit_label lbl}\n`
| Iinttest_imm(cmp, n) ->
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
let comp = name_for_comparison cmp in
` b.{emit_string comp} {emit_label lbl}\n`
| Ifloattest(cmp, neg) ->
let comp = (match (cmp, neg) with
| (Ceq, false) | (Cne, true) -> "eq"
| (Cne, false) | (Ceq, true) -> "ne"
| (Clt, false) -> "cc"
| (Clt, true) -> "cs"
| (Cle, false) -> "ls"
| (Cle, true) -> "hi"
| (Cgt, false) -> "gt"
| (Cgt, true) -> "le"
| (Cge, false) -> "ge"
| (Cge, true) -> "lt") in
` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` b.{emit_string comp} {emit_label lbl}\n`
| Ioddtest ->
` tbnz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
| Ieventest ->
` tbz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
end
| Lcondbranch3(lbl0, lbl1, lbl2) ->
` cmp {emit_reg i.arg.(0)}, #1\n`;
begin match lbl0 with
None -> ()
| Some lbl -> ` b.lt {emit_label lbl}\n`
end;
begin match lbl1 with
None -> ()
| Some lbl -> ` b.eq {emit_label lbl}\n`
end;
begin match lbl2 with
None -> ()
| Some lbl -> ` b.gt {emit_label lbl}\n`
end
| Lswitch jumptbl ->
let lbltbl = new_label() in
` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`;
` br {emit_reg reg_tmp1}\n`;
`{emit_label lbltbl}:`;
for j = 0 to Array.length jumptbl - 1 do
` b {emit_label jumptbl.(j)}\n`
done
(* Alternative:
let lbltbl = new_label() in
` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`;
` add {emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`;
` br {emit_reg reg_tmp1}\n`;
`{emit_label lbltbl}:\n`;
for j = 0 to Array.length jumptbl - 1 do
` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n`
done
*)
| Lsetuptrap lbl ->
let lblnext = new_label() in
` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`;
` b {emit_label lbl}\n`;
`{emit_label lblnext}:\n`
| Lpushtrap ->
stack_offset := !stack_offset + 16;
` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`;
` str {emit_reg reg_tmp1}, [sp, #8]\n`;
cfi_adjust_cfa_offset 16;
` mov {emit_reg reg_trap_ptr}, sp\n`
| Lpoptrap ->
` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`;
cfi_adjust_cfa_offset (-16);
stack_offset := !stack_offset - 16
| Lraise k ->
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` bl {emit_symbol "caml_raise_exn"}\n`;
`{record_frame Reg.Set.empty i.dbg}\n`
| false, _
| true, Lambda.Raise_notrace ->
` mov sp, {emit_reg reg_trap_ptr}\n`;
` ldr {emit_reg reg_tmp1}, [sp, #8]\n`;
` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`;
` br {emit_reg reg_tmp1}\n`
end
(* Emission of an instruction sequence *)
let rec emit_all i =
if i.desc = Lend then () else (emit_instr i; emit_all i.next)
(* Emission of the profiling prelude *)
let emit_profile() = () (* TODO *)
(*
match Config.system with
"linux_eabi" | "linux_eabihf" ->
` push \{lr}\n`;
` {emit_call "__gnu_mcount_nc"}\n`
| _ -> ()
*)
(* Emission of a function declaration *)
let fundecl fundecl =
function_name := fundecl.fun_name;
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
float_literals := [];
stack_offset := 0;
call_gc_sites := [];
bound_error_sites := [];
` .text\n`;
` .align 3\n`;
` .globl {emit_symbol fundecl.fun_name}\n`;
` .type {emit_symbol fundecl.fun_name}, %function\n`;
`{emit_symbol fundecl.fun_name}:\n`;
emit_debug_info fundecl.fun_dbg;
cfi_startproc();
if !Clflags.gprofile then emit_profile();
let n = frame_size() in
if n > 0 then
emit_stack_adjustment (-n);
if !contains_calls then begin
cfi_offset ~reg:30 (* return address *) ~offset:(-8);
` str x30, [sp, #{emit_int (n-8)}]\n`
end;
`{emit_label !tailrec_entry_point}:\n`;
let num_call_gc, num_check_bound =
num_call_gc_and_check_bound_points fundecl.fun_body
in
let max_out_of_line_code_offset =
max_out_of_line_code_offset fundecl.fun_body ~num_call_gc
~num_check_bound
in
BR.relax fundecl.fun_body ~max_out_of_line_code_offset;
emit_all fundecl.fun_body;
List.iter emit_call_gc !call_gc_sites;
List.iter emit_call_bound_error !bound_error_sites;
assert (List.length !call_gc_sites = num_call_gc);
assert (List.length !bound_error_sites = num_check_bound);
cfi_endproc();
` .type {emit_symbol fundecl.fun_name}, %function\n`;
` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`;
emit_literals()
(* Emission of data *)
let emit_item = function
| Cglobal_symbol s -> ` .globl {emit_symbol s}\n`;
| Cdefine_symbol s -> `{emit_symbol s}:\n`
| Cdefine_label lbl -> `{emit_data_label lbl}:\n`
| Cint8 n -> ` .byte {emit_int n}\n`
| Cint16 n -> ` .short {emit_int n}\n`
| Cint32 n -> ` .long {emit_nativeint n}\n`
| Cint n -> ` .quad {emit_nativeint n}\n`
| Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
| Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f)
| Csymbol_address s -> ` .quad {emit_symbol s}\n`
| Clabel_address lbl -> ` .quad {emit_data_label lbl}\n`
| Cstring s -> emit_string_directive " .ascii " s
| Cskip n -> if n > 0 then ` .space {emit_int n}\n`
| Calign n -> ` .align {emit_int(Misc.log2 n)}\n`
let data l =
` .data\n`;
` .align 3\n`;
List.iter emit_item l
(* Beginning / end of an assembly file *)
let begin_assembly() =
reset_debug_info();
` .file \"{emit_string (String.escaped !Location.input_name)}\"\n`;
let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
` .data\n`;
` .globl {emit_symbol lbl_begin}\n`;
`{emit_symbol lbl_begin}:\n`;
let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
` .text\n`;
` .globl {emit_symbol lbl_begin}\n`;
`{emit_symbol lbl_begin}:\n`
let end_assembly () =
let lbl_end = Compilenv.make_symbol (Some "code_end") in
` .text\n`;
` .globl {emit_symbol lbl_end}\n`;
`{emit_symbol lbl_end}:\n`;
let lbl_end = Compilenv.make_symbol (Some "data_end") in
` .data\n`;
` .globl {emit_symbol lbl_end}\n`;
`{emit_symbol lbl_end}:\n`;
` .long 0\n`;
let lbl = Compilenv.make_symbol (Some "frametable") in
` .globl {emit_symbol lbl}\n`;
`{emit_symbol lbl}:\n`;
emit_frames
{ efa_label = (fun lbl ->
` .type {emit_label lbl}, %function\n`;
` .quad {emit_label lbl}\n`);
efa_16 = (fun n -> ` .short {emit_int n}\n`);
efa_32 = (fun n -> ` .long {emit_int32 n}\n`);
efa_word = (fun n -> ` .quad {emit_int n}\n`);
efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`);
efa_label_rel = (fun lbl ofs ->
` .long {emit_label lbl} - . + {emit_int32 ofs}\n`);
efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
efa_string = (fun s -> emit_string_directive " .asciz " s) };
` .type {emit_symbol lbl}, %object\n`;
` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`;
begin match Config.system with
| "linux" ->
(* Mark stack as non-executable *)
` .section .note.GNU-stack,\"\",%progbits\n`
| _ -> ()
end
|