3108 lines
116 KiB
Diff
3108 lines
116 KiB
Diff
From 658145e4aa9a3eb7263012b39c7483241af5b1b3 Mon Sep 17 00:00:00 2001
|
|
From: "Richard W.M. Jones" <rjones@redhat.com>
|
|
Date: Tue, 29 May 2012 20:50:42 +0100
|
|
Subject: [PATCH 7/8] New ARM backend, written by Benedikt Meurer (PR#5433).
|
|
|
|
Backported from upstream sources to 3.12.1 by RWMJ.
|
|
|
|
Includes svn rev 12548 to fix invalid generation of Thumb-2 branch
|
|
instruction TBH (upstream PR#5623, RHBZ#821153).
|
|
---
|
|
asmcomp/amd64/selection.ml | 14 +-
|
|
asmcomp/arm/arch.ml | 152 +++++++-
|
|
asmcomp/arm/emit.mlp | 857 ++++++++++++++++++++++++++++--------------
|
|
asmcomp/arm/proc.ml | 185 ++++++---
|
|
asmcomp/arm/reload.ml | 4 +-
|
|
asmcomp/arm/scheduling.ml | 80 ++--
|
|
asmcomp/arm/selection.ml | 343 ++++++++++-------
|
|
asmcomp/i386/selection.ml | 14 +-
|
|
asmcomp/power/selection.ml | 2 +-
|
|
asmcomp/power64/selection.ml | 2 +-
|
|
asmcomp/selectgen.ml | 13 +-
|
|
asmcomp/selectgen.mli | 2 +-
|
|
asmcomp/sparc/selection.ml | 2 +-
|
|
asmrun/arm.S | 544 ++++++++++++++++-----------
|
|
asmrun/signals_osdep.h | 2 +-
|
|
configure | 11 +-
|
|
16 files changed, 1485 insertions(+), 742 deletions(-)
|
|
|
|
diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
|
|
index f0546cf..5d9f6fa 100644
|
|
--- a/asmcomp/amd64/selection.ml
|
|
+++ b/asmcomp/amd64/selection.ml
|
|
@@ -121,7 +121,7 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
|
|
|
|
method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
|
|
|
|
-method select_addressing exp =
|
|
+method select_addressing chunk exp =
|
|
let (a, d) = select_addr exp in
|
|
(* PR#4625: displacement must be a signed 32-bit immediate *)
|
|
if d < -0x8000_0000 || d > 0x7FFF_FFFF
|
|
@@ -157,7 +157,7 @@ method! select_operation op args =
|
|
match op with
|
|
(* Recognize the LEA instruction *)
|
|
Caddi | Cadda | Csubi | Csuba ->
|
|
- begin match self#select_addressing (Cop(op, args)) with
|
|
+ begin match self#select_addressing Word (Cop(op, args)) with
|
|
(Iindexed d, _) -> super#select_operation op args
|
|
| (Iindexed2 0, _) -> super#select_operation op args
|
|
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
|
@@ -191,7 +191,7 @@ method! select_operation op args =
|
|
begin match args with
|
|
[loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
|
|
when loc = loc' && self#is_immediate n ->
|
|
- let (addr, arg) = self#select_addressing loc in
|
|
+ let (addr, arg) = self#select_addressing Word loc in
|
|
(Ispecific(Ioffset_loc(n, addr)), [arg])
|
|
| _ ->
|
|
super#select_operation op args
|
|
@@ -202,12 +202,12 @@ method! select_operation op args =
|
|
|
|
method select_floatarith commutative regular_op mem_op args =
|
|
match args with
|
|
- [arg1; Cop(Cload (Double|Double_u), [loc2])] ->
|
|
- let (addr, arg2) = self#select_addressing loc2 in
|
|
+ [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] ->
|
|
+ let (addr, arg2) = self#select_addressing chunk loc2 in
|
|
(Ispecific(Ifloatarithmem(mem_op, addr)),
|
|
[arg1; arg2])
|
|
- | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative ->
|
|
- let (addr, arg1) = self#select_addressing loc1 in
|
|
+ | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative ->
|
|
+ let (addr, arg1) = self#select_addressing chunk loc1 in
|
|
(Ispecific(Ifloatarithmem(mem_op, addr)),
|
|
[arg2; arg1])
|
|
| [arg1; arg2] ->
|
|
diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml
|
|
index 998fa4b..c4aca8d 100644
|
|
--- a/asmcomp/arm/arch.ml
|
|
+++ b/asmcomp/arm/arch.ml
|
|
@@ -1,25 +1,98 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
+(* Benedikt Meurer, University of Siegen *)
|
|
(* *)
|
|
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
|
-(* en Automatique. All rights reserved. This file is distributed *)
|
|
-(* under the terms of the Q Public License version 1.0. *)
|
|
+(* Copyright 1998 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: arch.ml 5304 2002-11-29 15:03:37Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
(* Specific operations for the ARM processor *)
|
|
|
|
open Misc
|
|
open Format
|
|
|
|
+type abi = EABI | EABI_VFP
|
|
+type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7
|
|
+type fpu = Soft | VFPv3_D16 | VFPv3
|
|
+
|
|
+let abi =
|
|
+ match Config.system with
|
|
+ "linux_eabi" -> EABI
|
|
+ | "linux_eabihf" -> EABI_VFP
|
|
+ | _ -> assert false
|
|
+
|
|
+let string_of_arch = function
|
|
+ ARMv4 -> "armv4"
|
|
+ | ARMv5 -> "armv5"
|
|
+ | ARMv5TE -> "armv5te"
|
|
+ | ARMv6 -> "armv6"
|
|
+ | ARMv6T2 -> "armv6t2"
|
|
+ | ARMv7 -> "armv7"
|
|
+
|
|
+let string_of_fpu = function
|
|
+ Soft -> "soft"
|
|
+ | VFPv3_D16 -> "vfpv3-d16"
|
|
+ | VFPv3 -> "vfpv3"
|
|
+
|
|
(* Machine-specific command-line options *)
|
|
|
|
-let command_line_options = []
|
|
+let (arch, fpu, thumb) =
|
|
+ let (def_arch, def_fpu, def_thumb) =
|
|
+ begin match abi, Config.model with
|
|
+ (* Defaults for architecture, FPU and Thumb *)
|
|
+ EABI, "armv5" -> ARMv5, Soft, false
|
|
+ | EABI, "armv5te" -> ARMv5TE, Soft, false
|
|
+ | EABI, "armv6" -> ARMv6, Soft, false
|
|
+ | EABI, "armv6t2" -> ARMv6T2, Soft, false
|
|
+ | EABI, "armv7" -> ARMv7, Soft, false
|
|
+ | EABI, _ -> ARMv4, Soft, false
|
|
+ | EABI_VFP, _ -> ARMv7, VFPv3_D16, true
|
|
+ end in
|
|
+ (ref def_arch, ref def_fpu, ref def_thumb)
|
|
+
|
|
+let pic_code = ref false
|
|
+
|
|
+let farch spec =
|
|
+ arch := (match spec with
|
|
+ "armv4" when abi <> EABI_VFP -> ARMv4
|
|
+ | "armv5" when abi <> EABI_VFP -> ARMv5
|
|
+ | "armv5te" when abi <> EABI_VFP -> ARMv5TE
|
|
+ | "armv6" when abi <> EABI_VFP -> ARMv6
|
|
+ | "armv6t2" when abi <> EABI_VFP -> ARMv6T2
|
|
+ | "armv7" -> ARMv7
|
|
+ | spec -> raise (Arg.Bad spec))
|
|
+
|
|
+let ffpu spec =
|
|
+ fpu := (match spec with
|
|
+ "soft" when abi <> EABI_VFP -> Soft
|
|
+ | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16
|
|
+ | "vfpv3" when abi = EABI_VFP -> VFPv3
|
|
+ | spec -> raise (Arg.Bad spec))
|
|
+
|
|
+let command_line_options =
|
|
+ [ "-farch", Arg.String farch,
|
|
+ "<arch> Select the ARM target architecture"
|
|
+ ^ " (default: " ^ (string_of_arch !arch) ^ ")";
|
|
+ "-ffpu", Arg.String ffpu,
|
|
+ "<fpu> Select the floating-point hardware"
|
|
+ ^ " (default: " ^ (string_of_fpu !fpu) ^ ")";
|
|
+ "-fPIC", Arg.Set pic_code,
|
|
+ " Generate position-independent machine code";
|
|
+ "-fno-PIC", Arg.Clear pic_code,
|
|
+ " Generate position-dependent machine code";
|
|
+ "-fthumb", Arg.Set thumb,
|
|
+ " Enable Thumb/Thumb-2 code generation"
|
|
+ ^ (if !thumb then " (default)" else "");
|
|
+ "-fno-thumb", Arg.Clear thumb,
|
|
+ " Disable Thumb/Thumb-2 code generation"
|
|
+ ^ (if not !thumb then " (default" else "")]
|
|
|
|
(* Addressing modes *)
|
|
|
|
@@ -37,6 +110,14 @@ type specific_operation =
|
|
Ishiftarith of arith_operation * int
|
|
| Ishiftcheckbound of int
|
|
| Irevsubimm of int
|
|
+ | Imuladd (* multiply and add *)
|
|
+ | Imulsub (* multiply and subtract *)
|
|
+ | Inegmulf (* floating-point negate and multiply *)
|
|
+ | Imuladdf (* floating-point multiply and add *)
|
|
+ | Inegmuladdf (* floating-point negate, multiply and add *)
|
|
+ | Imulsubf (* floating-point multiply and subtract *)
|
|
+ | Inegmulsubf (* floating-point negate, multiply and subtract *)
|
|
+ | Isqrtf (* floating-point square root *)
|
|
|
|
and arith_operation =
|
|
Ishiftadd
|
|
@@ -51,6 +132,10 @@ let size_addr = 4
|
|
let size_int = 4
|
|
let size_float = 8
|
|
|
|
+(* Behavior of division *)
|
|
+
|
|
+let division_crashes_on_overflow = false
|
|
+
|
|
(* Operations on addressing modes *)
|
|
|
|
let identity_addressing = Iindexed 0
|
|
@@ -84,3 +169,56 @@ let print_specific_operation printreg op ppf arg =
|
|
fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1)
|
|
| Irevsubimm n ->
|
|
fprintf ppf "%i %s %a" n "-" printreg arg.(0)
|
|
+ | Imuladd ->
|
|
+ fprintf ppf "(%a * %a) + %a"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Imulsub ->
|
|
+ fprintf ppf "-(%a * %a) + %a"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Inegmulf ->
|
|
+ fprintf ppf "-f (%a *f %a)"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ | Imuladdf ->
|
|
+ fprintf ppf "%a +f (%a *f %a)"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Inegmuladdf ->
|
|
+ fprintf ppf "%a -f (%a *f %a)"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Imulsubf ->
|
|
+ fprintf ppf "(-f %a) +f (%a *f %a)"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Inegmulsubf ->
|
|
+ fprintf ppf "(-f %a) -f (%a *f %a)"
|
|
+ printreg arg.(0)
|
|
+ printreg arg.(1)
|
|
+ printreg arg.(2)
|
|
+ | Isqrtf ->
|
|
+ fprintf ppf "sqrtf %a"
|
|
+ printreg arg.(0)
|
|
+
|
|
+(* Recognize immediate operands *)
|
|
+
|
|
+(* Immediate operands are 8-bit immediate values, zero-extended,
|
|
+ and rotated right by 0 ... 30 bits.
|
|
+ In Thumb/Thumb-2 mode we utilize 26 ... 30. *)
|
|
+
|
|
+let is_immediate n =
|
|
+ let n = ref n in
|
|
+ let s = ref 0 in
|
|
+ let m = if !thumb then 24 else 30 in
|
|
+ while (!s <= m && Int32.logand !n 0xffl <> !n) do
|
|
+ n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30);
|
|
+ s := !s + 2
|
|
+ done;
|
|
+ !s <= m
|
|
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
|
|
index a4b2241..f8db396 100644
|
|
--- a/asmcomp/arm/emit.mlp
|
|
+++ b/asmcomp/arm/emit.mlp
|
|
@@ -1,16 +1,17 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
+(* Benedikt Meurer, University of Siegen *)
|
|
(* *)
|
|
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
|
-(* en Automatique. All rights reserved. This file is distributed *)
|
|
-(* under the terms of the Q Public License version 1.0. *)
|
|
+(* Copyright 1998 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: emit.mlp 10293 2010-04-22 09:33:18Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
(* Emission of ARM assembly code *)
|
|
|
|
@@ -33,16 +34,28 @@ let fastcode_flag = ref true
|
|
let emit_label lbl =
|
|
emit_string ".L"; emit_int lbl
|
|
|
|
-(* Output a symbol *)
|
|
+let emit_data_label lbl =
|
|
+ emit_string ".Ld"; emit_int lbl
|
|
+
|
|
+(* Symbols *)
|
|
|
|
let emit_symbol s =
|
|
Emitaux.emit_symbol '$' s
|
|
|
|
+let emit_call s =
|
|
+ if !Clflags.dlcode || !pic_code
|
|
+ then `bl {emit_symbol s}(PLT)`
|
|
+ else `bl {emit_symbol s}`
|
|
+
|
|
+let emit_jump s =
|
|
+ if !Clflags.dlcode || !pic_code
|
|
+ then `b {emit_symbol s}(PLT)`
|
|
+ else `b {emit_symbol s}`
|
|
+
|
|
(* Output a pseudo-register *)
|
|
|
|
-let emit_reg r =
|
|
- match r.loc with
|
|
- | Reg r -> emit_string (register_name r)
|
|
+let emit_reg = function
|
|
+ {loc = Reg r} -> emit_string (register_name r)
|
|
| _ -> fatal_error "Emit_arm.emit_reg"
|
|
|
|
(* Layout of the stack frame *)
|
|
@@ -53,14 +66,23 @@ let frame_size () =
|
|
let sz =
|
|
!stack_offset +
|
|
4 * num_stack_slots.(0) +
|
|
+ 8 * num_stack_slots.(1) +
|
|
+ 8 * num_stack_slots.(2) +
|
|
(if !contains_calls then 4 else 0)
|
|
in Misc.align sz 8
|
|
|
|
let slot_offset loc cl =
|
|
match loc with
|
|
- Incoming n -> frame_size() + n
|
|
- | Local n -> !stack_offset + n * 4
|
|
- | Outgoing n -> n
|
|
+ Incoming n ->
|
|
+ assert (n >= 0);
|
|
+ frame_size() + n
|
|
+ | Local n ->
|
|
+ if cl = 0
|
|
+ then !stack_offset + n * 4
|
|
+ else !stack_offset + num_stack_slots.(0) * 4 + n * 8
|
|
+ | Outgoing n ->
|
|
+ assert (n >= 0);
|
|
+ n
|
|
|
|
(* Output a stack reference *)
|
|
|
|
@@ -79,20 +101,13 @@ let emit_addressing addr r n =
|
|
|
|
(* Record live pointers at call points *)
|
|
|
|
-type frame_descr =
|
|
- { fd_lbl: int; (* Return address *)
|
|
- fd_frame_size: int; (* Size of stack frame *)
|
|
- fd_live_offset: int list } (* Offsets/regs of live addresses *)
|
|
-
|
|
-let frame_descriptors = ref([] : frame_descr list)
|
|
-
|
|
-let record_frame live =
|
|
+let 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
|
|
+ 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
|
|
| _ -> ())
|
|
@@ -100,18 +115,57 @@ let record_frame live =
|
|
frame_descriptors :=
|
|
{ fd_lbl = lbl;
|
|
fd_frame_size = frame_size();
|
|
- fd_live_offset = !live_offset } :: !frame_descriptors;
|
|
- `{emit_label lbl}:`
|
|
-
|
|
-let emit_frame fd =
|
|
- ` .word {emit_label fd.fd_lbl} + 4\n`;
|
|
- ` .short {emit_int fd.fd_frame_size}\n`;
|
|
- ` .short {emit_int (List.length fd.fd_live_offset)}\n`;
|
|
- List.iter
|
|
- (fun n ->
|
|
- ` .short {emit_int n}\n`)
|
|
- fd.fd_live_offset;
|
|
- ` .align 2\n`
|
|
+ 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}: {emit_call "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}: {emit_call "caml_ml_array_bound_error"}\n`;
|
|
+ `{emit_label bd.bd_frame_lbl}:\n`
|
|
+
|
|
+(* Negate a comparison *)
|
|
+
|
|
+let negate_integer_comparison = function
|
|
+ Isigned cmp -> Isigned(negate_comparison cmp)
|
|
+ | Iunsigned cmp -> Iunsigned(negate_comparison cmp)
|
|
|
|
(* Names of various instructions *)
|
|
|
|
@@ -121,22 +175,13 @@ let name_for_comparison = function
|
|
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
|
|
| Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
|
|
|
|
-let name_for_float_comparison cmp neg =
|
|
- match cmp with
|
|
- Ceq -> if neg then "ne" else "eq"
|
|
- | Cne -> if neg then "eq" else "ne"
|
|
- | Cle -> if neg then "hi" else "ls"
|
|
- | Cge -> if neg then "lt" else "ge"
|
|
- | Clt -> if neg then "pl" else "mi"
|
|
- | Cgt -> if neg then "le" else "gt"
|
|
-
|
|
let name_for_int_operation = function
|
|
Iadd -> "add"
|
|
| Isub -> "sub"
|
|
| Imul -> "mul"
|
|
- | Iand -> "and"
|
|
- | Ior -> "orr"
|
|
- | Ixor -> "eor"
|
|
+ | Iand -> "and"
|
|
+ | Ior -> "orr"
|
|
+ | Ixor -> "eor"
|
|
| _ -> assert false
|
|
|
|
let name_for_shift_operation = function
|
|
@@ -145,60 +190,54 @@ let name_for_shift_operation = function
|
|
| Iasr -> "asr"
|
|
| _ -> assert false
|
|
|
|
-let name_for_shift_int_operation = function
|
|
- Ishiftadd -> "add"
|
|
- | Ishiftsub -> "sub"
|
|
- | Ishiftsubrev -> "rsb"
|
|
-
|
|
-(* Recognize immediate operands *)
|
|
-
|
|
-(* Immediate operands are 8-bit immediate values, zero-extended, and rotated
|
|
- right by 0, 2, 4, ... 30 bits.
|
|
- We check only with 8-bit values shifted left 0 to 24 bits. *)
|
|
-
|
|
-let rec is_immed n shift =
|
|
- shift <= 24 &&
|
|
- (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n
|
|
- || is_immed n (shift + 2))
|
|
-
|
|
-let is_immediate n = is_immed n 0
|
|
-
|
|
(* General functional to decompose a non-immediate integer constant
|
|
- into 8-bit chunks shifted left 0 ... 24 bits *)
|
|
+ into 8-bit chunks shifted left 0 ... 30 bits. *)
|
|
|
|
let decompose_intconst n fn =
|
|
let i = ref n in
|
|
let shift = ref 0 in
|
|
let ninstr = ref 0 in
|
|
- while !i <> 0n do
|
|
- if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then
|
|
+ while !i <> 0l do
|
|
+ if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then
|
|
shift := !shift + 2
|
|
else begin
|
|
- let mask = Nativeint.shift_left 0xFFn !shift in
|
|
- let bits = Nativeint.logand !i mask in
|
|
- fn bits;
|
|
+ let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in
|
|
+ i := Int32.sub !i bits;
|
|
shift := !shift + 8;
|
|
- i := Nativeint.sub !i bits;
|
|
- incr ninstr
|
|
+ incr ninstr;
|
|
+ fn bits
|
|
end
|
|
done;
|
|
!ninstr
|
|
|
|
(* Load an integer constant into a register *)
|
|
|
|
-let emit_intconst r n =
|
|
- let nr = Nativeint.lognot n in
|
|
+let emit_intconst dst n =
|
|
+ let nr = Int32.lognot n in
|
|
if is_immediate n then begin
|
|
- ` mov {emit_reg r}, #{emit_nativeint n}\n`; 1
|
|
+ (* Use movs here to enable 16-bit T1 encoding *)
|
|
+ ` movs {emit_reg dst}, #{emit_int32 n}\n`; 1
|
|
end else if is_immediate nr then begin
|
|
- ` mvn {emit_reg r}, #{emit_nativeint nr}\n`; 1
|
|
+ ` mvn {emit_reg dst}, #{emit_int32 nr}\n`; 1
|
|
+ end else if !arch > ARMv6 then begin
|
|
+ let nl = Int32.logand 0xffffl n in
|
|
+ let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in
|
|
+ if nh = 0l then begin
|
|
+ ` movw {emit_reg dst}, #{emit_int32 nl}\n`; 1
|
|
+ end else if Int32.logand nl 0xffl = nl then begin
|
|
+ ` movs {emit_reg dst}, #{emit_int32 nl}\n`;
|
|
+ ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2
|
|
+ end else begin
|
|
+ ` movw {emit_reg dst}, #{emit_int32 nl}\n`;
|
|
+ ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2
|
|
+ end
|
|
end else begin
|
|
let first = ref true in
|
|
decompose_intconst n
|
|
(fun bits ->
|
|
if !first
|
|
- then ` mov {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n`
|
|
- else ` add {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`;
|
|
+ then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n`
|
|
+ else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`;
|
|
first := false)
|
|
end
|
|
|
|
@@ -206,46 +245,105 @@ let emit_intconst r n =
|
|
|
|
let emit_stack_adjustment instr n =
|
|
if n <= 0 then 0 else
|
|
- decompose_intconst (Nativeint.of_int n)
|
|
+ decompose_intconst (Int32.of_int n)
|
|
(fun bits ->
|
|
- ` {emit_string instr} sp, sp, #{emit_nativeint bits}\n`)
|
|
+ ` {emit_string instr} sp, sp, #{emit_int32 bits}\n`)
|
|
|
|
(* Name of current function *)
|
|
let function_name = ref ""
|
|
(* Entry point for tail recursive calls *)
|
|
let tailrec_entry_point = ref 0
|
|
-(* Table of symbols referenced *)
|
|
-let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
|
-(* Table of floating-point literals *)
|
|
-let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
|
-(* Total space (in word) occupied by pending literals *)
|
|
+(* Pending floating-point literals *)
|
|
+let float_literals = ref ([] : (string * label) list)
|
|
+(* Pending relative references to the global offset table *)
|
|
+let gotrel_literals = ref ([] : (label * label) list)
|
|
+(* Pending symbol literals *)
|
|
+let symbol_literals = ref ([] : (string * label) list)
|
|
+(* Total space (in words) occupied by pending literals *)
|
|
let num_literals = ref 0
|
|
|
|
-(* Label a symbol or float constant *)
|
|
-let label_constant tbl s size =
|
|
+(* Label a floating-point literal *)
|
|
+let float_literal f =
|
|
try
|
|
- Hashtbl.find tbl s
|
|
+ List.assoc f !float_literals
|
|
with Not_found ->
|
|
let lbl = new_label() in
|
|
- Hashtbl.add tbl s lbl;
|
|
- num_literals := !num_literals + size;
|
|
+ num_literals := !num_literals + 2;
|
|
+ float_literals := (f, lbl) :: !float_literals;
|
|
lbl
|
|
|
|
-(* Emit all pending constants *)
|
|
-
|
|
-let emit_constants () =
|
|
- Hashtbl.iter
|
|
- (fun s lbl ->
|
|
- `{emit_label lbl}: .word {emit_symbol s}\n`)
|
|
- symbol_constants;
|
|
- Hashtbl.iter
|
|
- (fun s lbl ->
|
|
- `{emit_label lbl}: .double {emit_string s}\n`)
|
|
- float_constants;
|
|
- Hashtbl.clear symbol_constants;
|
|
- Hashtbl.clear float_constants;
|
|
+(* Label a GOTREL literal *)
|
|
+let gotrel_literal l =
|
|
+ let lbl = new_label() in
|
|
+ num_literals := !num_literals + 1;
|
|
+ gotrel_literals := (l, lbl) :: !gotrel_literals;
|
|
+ lbl
|
|
+
|
|
+(* Label a symbol literal *)
|
|
+let symbol_literal s =
|
|
+ try
|
|
+ List.assoc s !symbol_literals
|
|
+ with Not_found ->
|
|
+ let lbl = new_label() in
|
|
+ num_literals := !num_literals + 1;
|
|
+ symbol_literals := (s, lbl) :: !symbol_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}: .double {emit_string f}\n`)
|
|
+ !float_literals;
|
|
+ float_literals := []
|
|
+ end;
|
|
+ if !symbol_literals <> [] then begin
|
|
+ let offset = if !thumb then 4 else 8 in
|
|
+ let suffix = if !pic_code then "(GOT)" else "" in
|
|
+ ` .align 2\n`;
|
|
+ List.iter
|
|
+ (fun (l, lbl) ->
|
|
+ `{emit_label lbl}: .word _GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`)
|
|
+ !gotrel_literals;
|
|
+ List.iter
|
|
+ (fun (s, lbl) ->
|
|
+ `{emit_label lbl}: .word {emit_symbol s}{emit_string suffix}\n`)
|
|
+ !symbol_literals;
|
|
+ gotrel_literals := [];
|
|
+ symbol_literals := []
|
|
+ end;
|
|
num_literals := 0
|
|
|
|
+(* Emit code to load the address of a symbol *)
|
|
+
|
|
+let emit_load_symbol_addr dst s =
|
|
+ if !pic_code then begin
|
|
+ let lbl_pic = new_label() in
|
|
+ let lbl_got = gotrel_literal lbl_pic in
|
|
+ let lbl_sym = symbol_literal s in
|
|
+ (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml),
|
|
+ so use r12 as temporary scratch register unless the destination is
|
|
+ r12, then we use r3 instead. *)
|
|
+ let tmp = if dst.loc = Reg 8 (*r12*)
|
|
+ then phys_reg 3 (*r3*)
|
|
+ else phys_reg 8 (*r12*) in
|
|
+ ` ldr {emit_reg tmp}, {emit_label lbl_got}\n`;
|
|
+ ` ldr {emit_reg dst}, {emit_label lbl_sym}\n`;
|
|
+ `{emit_label lbl_pic}: add {emit_reg tmp}, pc, {emit_reg tmp}\n`;
|
|
+ ` ldr {emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`;
|
|
+ 4
|
|
+ end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin
|
|
+ ` movw {emit_reg dst}, #:lower16:{emit_symbol s}\n`;
|
|
+ ` movt {emit_reg dst}, #:upper16:{emit_symbol s}\n`;
|
|
+ 2
|
|
+ end else begin
|
|
+ let lbl = symbol_literal s in
|
|
+ ` ldr {emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`;
|
|
+ 1
|
|
+ end
|
|
+
|
|
(* Output the assembly code for an instruction *)
|
|
|
|
let emit_instr i =
|
|
@@ -254,40 +352,76 @@ let emit_instr i =
|
|
| Lop(Imove | Ispill | Ireload) ->
|
|
let src = i.arg.(0) and dst = i.res.(0) in
|
|
if src.loc = dst.loc then 0 else begin
|
|
- match (src, dst) with
|
|
- {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
|
|
- ` mov {emit_reg dst}, {emit_reg src}\n`; 1
|
|
- | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
|
|
- ` str {emit_reg src}, {emit_stack dst}\n`; 1
|
|
- | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
|
|
- ` ldr {emit_reg dst}, {emit_stack src}\n`; 1
|
|
+ begin match (src, dst) with
|
|
+ {loc = Reg _; typ = Float}, {loc = Reg _} ->
|
|
+ ` fcpyd {emit_reg dst}, {emit_reg src}\n`
|
|
+ | {loc = Reg _}, {loc = Reg _} ->
|
|
+ ` mov {emit_reg dst}, {emit_reg src}\n`
|
|
+ | {loc = Reg _; typ = Float}, _ ->
|
|
+ ` fstd {emit_reg src}, {emit_stack dst}\n`
|
|
+ | {loc = Reg _}, _ ->
|
|
+ ` str {emit_reg src}, {emit_stack dst}\n`
|
|
+ | {typ = Float}, _ ->
|
|
+ ` fldd {emit_reg dst}, {emit_stack src}\n`
|
|
| _ ->
|
|
- assert false
|
|
+ ` ldr {emit_reg dst}, {emit_stack src}\n`
|
|
+ end; 1
|
|
end
|
|
| Lop(Iconst_int n) ->
|
|
- emit_intconst i.res.(0) n
|
|
- | Lop(Iconst_float s) ->
|
|
- let bits = Int64.bits_of_float (float_of_string s) in
|
|
- let high_bits = Int64.to_nativeint (Int64.shift_right_logical bits 32)
|
|
- and low_bits = Int64.to_nativeint bits in
|
|
- if is_immediate low_bits && is_immediate high_bits then begin
|
|
- ` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`;
|
|
- ` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`;
|
|
- 2
|
|
+ emit_intconst i.res.(0) (Nativeint.to_int32 n)
|
|
+ | Lop(Iconst_float f) when !fpu = Soft ->
|
|
+ ` @ {emit_string f}\n`;
|
|
+ let bits = Int64.bits_of_float (float_of_string f) in
|
|
+ let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32)
|
|
+ and low_bits = Int64.to_int32 bits in
|
|
+ if is_immediate low_bits || is_immediate high_bits then begin
|
|
+ let ninstr_low = emit_intconst i.res.(0) low_bits
|
|
+ and ninstr_high = emit_intconst i.res.(1) high_bits in
|
|
+ ninstr_low + ninstr_high
|
|
end else begin
|
|
- let lbl = label_constant float_constants s 2 in
|
|
- ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`;
|
|
+ let lbl = float_literal f in
|
|
+ ` ldr {emit_reg i.res.(0)}, {emit_label lbl}\n`;
|
|
` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
|
|
2
|
|
end
|
|
+ | Lop(Iconst_float f) ->
|
|
+ let encode imm =
|
|
+ let sg = Int64.to_int (Int64.shift_right_logical imm 63) in
|
|
+ let ex = Int64.to_int (Int64.shift_right_logical imm 52) in
|
|
+ let ex = (ex land 0x7ff) - 1023 in
|
|
+ let mn = Int64.logand imm 0xfffffffffffffL in
|
|
+ if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4
|
|
+ then
|
|
+ None
|
|
+ else begin
|
|
+ let mn = Int64.to_int (Int64.shift_right_logical mn 48) in
|
|
+ if mn land 0x0f <> mn then
|
|
+ None
|
|
+ else
|
|
+ let ex = ((ex + 3) land 0x07) lxor 0x04 in
|
|
+ Some((sg lsl 7) lor (ex lsl 4) lor mn)
|
|
+ end in
|
|
+ begin match encode (Int64.bits_of_float (float_of_string f)) with
|
|
+ None ->
|
|
+ let lbl = float_literal f in
|
|
+ ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`
|
|
+ | Some imm8 ->
|
|
+ ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n`
|
|
+ end; 1
|
|
| Lop(Iconst_symbol s) ->
|
|
- let lbl = label_constant symbol_constants s 1 in
|
|
- ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1
|
|
+ emit_load_symbol_addr i.res.(0) s
|
|
| Lop(Icall_ind) ->
|
|
- ` mov lr, pc\n`;
|
|
- `{record_frame i.live} bx {emit_reg i.arg.(0)}\n`; 2
|
|
+ if !arch >= ARMv5 then begin
|
|
+ ` blx {emit_reg i.arg.(0)}\n`;
|
|
+ `{record_frame i.live i.dbg}\n`; 1
|
|
+ end else begin
|
|
+ ` mov lr, pc\n`;
|
|
+ ` bx {emit_reg i.arg.(0)}\n`;
|
|
+ `{record_frame i.live i.dbg}\n`; 2
|
|
+ end
|
|
| Lop(Icall_imm s) ->
|
|
- `{record_frame i.live} bl {emit_symbol s}\n`; 1
|
|
+ ` {emit_call s}\n`;
|
|
+ `{record_frame i.live i.dbg}\n`; 1
|
|
| Lop(Itailcall_ind) ->
|
|
let n = frame_size() in
|
|
if !contains_calls then
|
|
@@ -303,17 +437,16 @@ let emit_instr i =
|
|
if !contains_calls then
|
|
` ldr lr, [sp, #{emit_int (n-4)}]\n`;
|
|
let ninstr = emit_stack_adjustment "add" n in
|
|
- ` b {emit_symbol s}\n`;
|
|
+ ` {emit_jump s}\n`;
|
|
2 + ninstr
|
|
end
|
|
- | Lop(Iextcall(s, alloc)) ->
|
|
- if alloc then begin
|
|
- let lbl = label_constant symbol_constants s 1 in
|
|
- ` ldr r12, {emit_label lbl} @ {emit_symbol s}\n`;
|
|
- `{record_frame i.live} bl caml_c_call\n`; 2
|
|
- end else begin
|
|
- ` bl {emit_symbol s}\n`; 1
|
|
- end
|
|
+ | Lop(Iextcall(s, false)) ->
|
|
+ ` {emit_call s}\n`; 1
|
|
+ | Lop(Iextcall(s, true)) ->
|
|
+ let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in
|
|
+ ` {emit_call "caml_c_call"}\n`;
|
|
+ `{record_frame i.live i.dbg}\n`;
|
|
+ 1 + ninstr
|
|
| Lop(Istackoffset n) ->
|
|
assert (n mod 8 = 0);
|
|
let ninstr =
|
|
@@ -322,16 +455,28 @@ let emit_instr i =
|
|
else emit_stack_adjustment "add" (-n) in
|
|
stack_offset := !stack_offset + n;
|
|
ninstr
|
|
- | Lop(Iload((Double | Double_u), addr)) ->
|
|
- let addr' = offset_addressing addr 4 in
|
|
- if i.res.(0).loc <> i.arg.(0).loc then begin
|
|
- ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
|
|
- ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`
|
|
- end else begin
|
|
- ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`;
|
|
- ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
|
|
- end;
|
|
- 2
|
|
+ | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 ->
|
|
+ ` flds s14, {emit_addressing addr i.arg 0}\n`;
|
|
+ ` fcvtds {emit_reg i.res.(0)}, s14\n`; 2
|
|
+ | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft ->
|
|
+ (* Use LDM or LDRD if possible *)
|
|
+ begin match i.res.(0), i.res.(1), addr with
|
|
+ {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
|
|
+ when rt < rt2 ->
|
|
+ ` ldm {emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1
|
|
+ | {loc = Reg rt}, {loc = Reg rt2}, addr
|
|
+ when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
|
|
+ ` ldrd {emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1
|
|
+ | _ ->
|
|
+ let addr' = offset_addressing addr 4 in
|
|
+ if i.res.(0).loc <> i.arg.(0).loc then begin
|
|
+ ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
|
|
+ ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`
|
|
+ end else begin
|
|
+ ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`;
|
|
+ ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
|
|
+ end; 2
|
|
+ end
|
|
| Lop(Iload(size, addr)) ->
|
|
let r = i.res.(0) in
|
|
let instr =
|
|
@@ -340,65 +485,114 @@ let emit_instr i =
|
|
| Byte_signed -> "ldrsb"
|
|
| Sixteen_unsigned -> "ldrh"
|
|
| Sixteen_signed -> "ldrsh"
|
|
+ | Double
|
|
+ | Double_u -> "fldd"
|
|
| _ (* 32-bit quantities *) -> "ldr" in
|
|
- ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`;
|
|
- 1
|
|
- | Lop(Istore((Double | Double_u), addr)) ->
|
|
- let addr' = offset_addressing addr 4 in
|
|
- ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`;
|
|
- ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`;
|
|
- 2
|
|
+ ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1
|
|
+ | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 ->
|
|
+ ` fcvtsd s14, {emit_reg i.arg.(0)}\n`;
|
|
+ ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2
|
|
+ | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft ->
|
|
+ (* Use STM or STRD if possible *)
|
|
+ begin match i.arg.(0), i.arg.(1), addr with
|
|
+ {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
|
|
+ when rt < rt2 ->
|
|
+ ` stm {emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1
|
|
+ | {loc = Reg rt}, {loc = Reg rt2}, addr
|
|
+ when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
|
|
+ ` strd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1
|
|
+ | _ ->
|
|
+ let addr' = offset_addressing addr 4 in
|
|
+ ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`;
|
|
+ ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2
|
|
+ end
|
|
| Lop(Istore(size, addr)) ->
|
|
let r = i.arg.(0) in
|
|
let instr =
|
|
match size with
|
|
- Byte_unsigned | Byte_signed -> "strb"
|
|
- | Sixteen_unsigned | Sixteen_signed -> "strh"
|
|
+ Byte_unsigned
|
|
+ | Byte_signed -> "strb"
|
|
+ | Sixteen_unsigned
|
|
+ | Sixteen_signed -> "strh"
|
|
+ | Double
|
|
+ | Double_u -> "fstd"
|
|
| _ (* 32-bit quantities *) -> "str" in
|
|
- ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`;
|
|
- 1
|
|
+ ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
|
|
| Lop(Ialloc n) ->
|
|
+ let lbl_frame = record_frame_label i.live i.dbg in
|
|
if !fastcode_flag then begin
|
|
- let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in
|
|
- ` sub alloc_ptr, alloc_ptr, r12\n`;
|
|
+ let lbl_redo = new_label() in
|
|
+ `{emit_label lbl_redo}:`;
|
|
+ let ninstr = decompose_intconst
|
|
+ (Int32.of_int n)
|
|
+ (fun i ->
|
|
+ ` sub alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in
|
|
` cmp alloc_ptr, alloc_limit\n`;
|
|
- `{record_frame i.live} blcc caml_call_gc\n`;
|
|
` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
|
|
- 4 + ni
|
|
- end else if n = 8 || n = 12 || n = 16 then begin
|
|
- `{record_frame i.live} bl caml_alloc{emit_int ((n-4)/4)}\n`;
|
|
- ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2
|
|
+ let lbl_call_gc = new_label() in
|
|
+ ` bcc {emit_label lbl_call_gc}\n`;
|
|
+ call_gc_sites :=
|
|
+ { gc_lbl = lbl_call_gc;
|
|
+ gc_return_lbl = lbl_redo;
|
|
+ gc_frame_lbl = lbl_frame } :: !call_gc_sites;
|
|
+ 3 + ninstr
|
|
end else begin
|
|
- let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in
|
|
- `{record_frame i.live} bl caml_allocN\n`;
|
|
- ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
|
|
- 2 + ni
|
|
+ let ninstr =
|
|
+ begin match n with
|
|
+ 8 -> ` {emit_call "caml_alloc1"}\n`; 1
|
|
+ | 12 -> ` {emit_call "caml_alloc2"}\n`; 1
|
|
+ | 16 -> ` {emit_call "caml_alloc3"}\n`; 1
|
|
+ | _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in
|
|
+ ` {emit_call "caml_allocN"}\n`; 1 + ninstr
|
|
+ end in
|
|
+ `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
|
|
+ 1 + ninstr
|
|
end
|
|
| Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
|
|
let shift = name_for_shift_operation op in
|
|
` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1
|
|
| Lop(Iintop(Icomp cmp)) ->
|
|
- let comp = name_for_comparison cmp in
|
|
+ let compthen = name_for_comparison cmp in
|
|
+ let compelse = name_for_comparison (negate_integer_comparison cmp) in
|
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
- ` mov {emit_reg i.res.(0)}, #0\n`;
|
|
- ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3
|
|
- | Lop(Iintop(Icheckbound)) ->
|
|
+ ` ite {emit_string compthen}\n`;
|
|
+ ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`;
|
|
+ ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4
|
|
+ | Lop(Iintop_imm(Icomp cmp, n)) ->
|
|
+ let compthen = name_for_comparison cmp in
|
|
+ let compelse = name_for_comparison (negate_integer_comparison cmp) in
|
|
+ ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
+ ` ite {emit_string compthen}\n`;
|
|
+ ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`;
|
|
+ ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4
|
|
+ | Lop(Iintop Icheckbound) ->
|
|
+ let lbl = bound_error_label i.dbg in
|
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
- ` blls caml_ml_array_bound_error\n`; 2
|
|
+ ` bls {emit_label lbl}\n`; 2
|
|
+ | Lop(Iintop_imm(Icheckbound, n)) ->
|
|
+ let lbl = bound_error_label i.dbg in
|
|
+ ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
+ ` bls {emit_label lbl}\n`; 2
|
|
+ | 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`;
|
|
+ ` bcs {emit_label lbl}\n`; 2
|
|
| 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`; 1
|
|
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
|
|
| Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
let r = i.res.(0) in
|
|
` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`;
|
|
- if n <= 256 then
|
|
+ if n <= 256 then begin
|
|
+ ` it lt\n`;
|
|
` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n`
|
|
- else begin
|
|
+ end else begin
|
|
+ ` itt lt\n`;
|
|
` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
|
|
` sublt {emit_reg r}, {emit_reg r}, #1\n`
|
|
end;
|
|
- ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4
|
|
+ ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5
|
|
| Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
|
|
let l = Misc.log2 n in
|
|
let a = i.arg.(0) in
|
|
@@ -409,40 +603,71 @@ let emit_instr i =
|
|
` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`;
|
|
` bpl {emit_label lbl}\n`;
|
|
` cmp {emit_reg r}, #0\n`;
|
|
+ ` it ne\n`;
|
|
` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
|
|
- `{emit_label lbl}:\n`; 6
|
|
+ `{emit_label lbl}:\n`; 7
|
|
| Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) ->
|
|
let shift = name_for_shift_operation op in
|
|
` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1
|
|
- | Lop(Iintop_imm(Icomp cmp, n)) ->
|
|
- let comp = name_for_comparison cmp in
|
|
- ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
- ` mov {emit_reg i.res.(0)}, #0\n`;
|
|
- ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3
|
|
- | Lop(Iintop_imm(Icheckbound, n)) ->
|
|
- ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
|
- ` blls caml_ml_array_bound_error\n`; 2
|
|
| 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`; 1
|
|
- | Lop(Inegf) -> (* argument and result in (r0, r1) *)
|
|
- ` eor r1, r1, #0x80000000\n`; 1
|
|
- | Lop(Iabsf) -> (* argument and result in (r0, r1) *)
|
|
- ` bic r1, r1, #0x80000000\n`; 1
|
|
- | Lop(Ifloatofint | Iintoffloat | Iaddf | Isubf | Imulf | Idivf) ->
|
|
- assert false
|
|
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
|
|
+ | Lop(Iabsf | Inegf as op) when !fpu = Soft ->
|
|
+ let instr = (match op with
|
|
+ Iabsf -> "bic"
|
|
+ | Inegf -> "eor"
|
|
+ | _ -> assert false) in
|
|
+ ` {emit_string instr} {emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1
|
|
+ | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) ->
|
|
+ let instr = (match op with
|
|
+ Iabsf -> "fabsd"
|
|
+ | Inegf -> "fnegd"
|
|
+ | Ispecific Isqrtf -> "fsqrtd"
|
|
+ | _ -> assert false) in
|
|
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
|
|
+ | Lop(Ifloatofint) ->
|
|
+ ` fmsr s14, {emit_reg i.arg.(0)}\n`;
|
|
+ ` fsitod {emit_reg i.res.(0)}, s14\n`; 2
|
|
+ | Lop(Iintoffloat) ->
|
|
+ ` ftosizd s14, {emit_reg i.arg.(0)}\n`;
|
|
+ ` fmrs {emit_reg i.res.(0)}, s14\n`; 2
|
|
+ | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
|
|
+ let instr = (match op with
|
|
+ Iaddf -> "faddd"
|
|
+ | Isubf -> "fsubd"
|
|
+ | Imulf -> "fmuld"
|
|
+ | Idivf -> "fdivd"
|
|
+ | Ispecific Inegmulf -> "fnmuld"
|
|
+ | _ -> assert false) in
|
|
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
+ 1
|
|
+ | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
|
|
+ let instr = (match op with
|
|
+ Imuladdf -> "fmacd"
|
|
+ | Inegmuladdf -> "fnmacd"
|
|
+ | Imulsubf -> "fmscd"
|
|
+ | Inegmulsubf -> "fnmscd"
|
|
+ | _ -> assert false) in
|
|
+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`;
|
|
+ 1
|
|
| Lop(Ispecific(Ishiftarith(op, shift))) ->
|
|
- let instr = name_for_shift_int_operation op in
|
|
- ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
|
|
+ let instr = (match op with
|
|
+ Ishiftadd -> "add"
|
|
+ | Ishiftsub -> "sub"
|
|
+ | Ishiftsubrev -> "rsb") 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`;
|
|
1
|
|
- | Lop(Ispecific(Ishiftcheckbound shift)) ->
|
|
- ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
|
|
- ` blcs caml_ml_array_bound_error\n`; 2
|
|
| Lop(Ispecific(Irevsubimm n)) ->
|
|
` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
|
|
+ | Lop(Ispecific(Imuladd | Imulsub as op)) ->
|
|
+ let instr = (match op with
|
|
+ Imuladd -> "mla"
|
|
+ | Imulsub -> "mls"
|
|
+ | _ -> 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`; 1
|
|
| Lreloadretaddr ->
|
|
let n = frame_size() in
|
|
` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1
|
|
@@ -458,29 +683,41 @@ let emit_instr i =
|
|
begin match tst with
|
|
Itruetest ->
|
|
` cmp {emit_reg i.arg.(0)}, #0\n`;
|
|
- ` bne {emit_label lbl}\n`
|
|
+ ` bne {emit_label lbl}\n`; 2
|
|
| Ifalsetest ->
|
|
` cmp {emit_reg i.arg.(0)}, #0\n`;
|
|
- ` beq {emit_label lbl}\n`
|
|
+ ` beq {emit_label lbl}\n`; 2
|
|
| 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`
|
|
+ ` b{emit_string comp} {emit_label lbl}\n`; 2
|
|
| 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`
|
|
+ ` b{emit_string comp} {emit_label lbl}\n`; 2
|
|
| Ifloattest(cmp, neg) ->
|
|
- assert false
|
|
+ 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
|
|
+ ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
|
+ ` fmstat\n`;
|
|
+ ` b{emit_string comp} {emit_label lbl}\n`; 3
|
|
| Ioddtest ->
|
|
` tst {emit_reg i.arg.(0)}, #1\n`;
|
|
- ` bne {emit_label lbl}\n`
|
|
+ ` bne {emit_label lbl}\n`; 2
|
|
| Ieventest ->
|
|
` tst {emit_reg i.arg.(0)}, #1\n`;
|
|
- ` beq {emit_label lbl}\n`
|
|
- end;
|
|
- 2
|
|
- | Lcondbranch3(lbl0, lbl1, lbl2) ->
|
|
+ ` beq {emit_label lbl}\n`; 2
|
|
+ end
|
|
+ | Lcondbranch3(lbl0, lbl1, lbl2) ->
|
|
` cmp {emit_reg i.arg.(0)}, #1\n`;
|
|
begin match lbl0 with
|
|
None -> ()
|
|
@@ -495,108 +732,144 @@ let emit_instr i =
|
|
| Some lbl -> ` bgt {emit_label lbl}\n`
|
|
end;
|
|
4
|
|
- | Lswitch jumptbl ->
|
|
- ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
|
|
- ` mov r0, r0\n`; (* nop *)
|
|
- for i = 0 to Array.length jumptbl - 1 do
|
|
- ` .word {emit_label jumptbl.(i)}\n`
|
|
- done;
|
|
+ | Lswitch jumptbl ->
|
|
+ if !arch > ARMv6 && !thumb then begin
|
|
+ (* The Thumb-2 TBH instruction supports only forward branches,
|
|
+ so we need to generate appropriate trampolines for all labels
|
|
+ that appear before this switch instruction (PR#5623) *)
|
|
+ let tramtbl = Array.copy jumptbl in
|
|
+ ` tbh [pc, {emit_reg i.arg.(0)}, lsl #1]\n`;
|
|
+ for j = 0 to Array.length tramtbl - 1 do
|
|
+ let rec label i =
|
|
+ match i.desc with
|
|
+ Lend -> new_label()
|
|
+ | Llabel lbl when lbl = tramtbl.(j) -> lbl
|
|
+ | _ -> label i.next in
|
|
+ tramtbl.(j) <- label i.next;
|
|
+ ` .short ({emit_label tramtbl.(j)}-.)/2+{emit_int j}\n`
|
|
+ done;
|
|
+ (* Generate the necessary trampolines *)
|
|
+ for j = 0 to Array.length tramtbl - 1 do
|
|
+ if tramtbl.(j) <> jumptbl.(j) then
|
|
+ `{emit_label tramtbl.(j)}: b {emit_label jumptbl.(j)}\n`
|
|
+ done
|
|
+ end else if not !pic_code then begin
|
|
+ ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
|
|
+ ` nop\n`;
|
|
+ for j = 0 to Array.length jumptbl - 1 do
|
|
+ ` .word {emit_label jumptbl.(j)}\n`
|
|
+ done
|
|
+ end else begin
|
|
+ (* Slightly slower, but position-independent *)
|
|
+ ` add pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`;
|
|
+ ` nop\n`;
|
|
+ for j = 0 to Array.length jumptbl - 1 do
|
|
+ ` b {emit_label jumptbl.(j)}\n`
|
|
+ done
|
|
+ end;
|
|
2 + Array.length jumptbl
|
|
| Lsetuptrap lbl ->
|
|
` bl {emit_label lbl}\n`; 1
|
|
| Lpushtrap ->
|
|
stack_offset := !stack_offset + 8;
|
|
- ` stmfd sp!, \{trap_ptr, lr}\n`;
|
|
+ ` push \{trap_ptr, lr}\n`;
|
|
` mov trap_ptr, sp\n`; 2
|
|
| Lpoptrap ->
|
|
- ` ldmfd sp!, \{trap_ptr, lr}\n`;
|
|
+ ` pop \{trap_ptr, lr}\n`;
|
|
stack_offset := !stack_offset - 8; 1
|
|
| Lraise ->
|
|
- ` mov sp, trap_ptr\n`;
|
|
- ` ldmfd sp!, \{trap_ptr, pc}\n`; 2
|
|
+ if !Clflags.debug then begin
|
|
+ ` {emit_call "caml_raise_exn"}\n`;
|
|
+ `{record_frame Reg.Set.empty i.dbg}\n`; 1
|
|
+ end else begin
|
|
+ ` mov sp, trap_ptr\n`;
|
|
+ ` pop \{trap_ptr, pc}\n`; 2
|
|
+ end
|
|
|
|
(* Emission of an instruction sequence *)
|
|
|
|
-let no_fallthrough = function
|
|
- Lop(Itailcall_ind | Itailcall_imm _) -> true
|
|
- | Lreturn -> true
|
|
- | Lbranch _ -> true
|
|
- | Lswitch _ -> true
|
|
- | Lraise -> true
|
|
- | _ -> false
|
|
-
|
|
let rec emit_all ninstr i =
|
|
if i.desc = Lend then () else begin
|
|
let n = emit_instr i in
|
|
let ninstr' = ninstr + n in
|
|
- let limit = 511 - !num_literals in
|
|
- if ninstr' >= limit - 64 && no_fallthrough i.desc then begin
|
|
- emit_constants();
|
|
+ (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
|
|
+ let limit = (if !fpu >= VFPv3_D16 && !float_literals <> []
|
|
+ then 127
|
|
+ else 511) in
|
|
+ let limit = limit - !num_literals in
|
|
+ if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin
|
|
+ emit_literals();
|
|
emit_all 0 i.next
|
|
- end else
|
|
- if ninstr' >= limit then begin
|
|
+ end else if !num_literals != 0 && ninstr' >= limit then begin
|
|
let lbl = new_label() in
|
|
` b {emit_label lbl}\n`;
|
|
- emit_constants();
|
|
+ emit_literals();
|
|
`{emit_label lbl}:\n`;
|
|
emit_all 0 i.next
|
|
end else
|
|
emit_all ninstr' i.next
|
|
end
|
|
|
|
+(* Emission of the profiling prelude *)
|
|
+
|
|
+let emit_profile() =
|
|
+ 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 := [];
|
|
+ gotrel_literals := [];
|
|
+ symbol_literals := [];
|
|
stack_offset := 0;
|
|
- Hashtbl.clear symbol_constants;
|
|
- Hashtbl.clear float_constants;
|
|
+ call_gc_sites := [];
|
|
+ bound_error_sites := [];
|
|
` .text\n`;
|
|
` .align 2\n`;
|
|
- ` .global {emit_symbol fundecl.fun_name}\n`;
|
|
+ ` .globl {emit_symbol fundecl.fun_name}\n`;
|
|
+ if !arch > ARMv6 && !thumb then
|
|
+ ` .thumb\n`
|
|
+ else
|
|
+ ` .arm\n`;
|
|
` .type {emit_symbol fundecl.fun_name}, %function\n`;
|
|
`{emit_symbol fundecl.fun_name}:\n`;
|
|
+ if !Clflags.gprofile then emit_profile();
|
|
let n = frame_size() in
|
|
ignore(emit_stack_adjustment "sub" n);
|
|
if !contains_calls then
|
|
` str lr, [sp, #{emit_int(n - 4)}]\n`;
|
|
`{emit_label !tailrec_entry_point}:\n`;
|
|
emit_all 0 fundecl.fun_body;
|
|
- emit_constants()
|
|
+ emit_literals();
|
|
+ List.iter emit_call_gc !call_gc_sites;
|
|
+ List.iter emit_call_bound_error !bound_error_sites;
|
|
+ ` .type {emit_symbol fundecl.fun_name}, %function\n`;
|
|
+ ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`
|
|
|
|
(* Emission of data *)
|
|
|
|
let emit_item = function
|
|
- Cglobal_symbol s ->
|
|
- ` .global {emit_symbol s}\n`;
|
|
- | Cdefine_symbol s ->
|
|
- `{emit_symbol s}:\n`
|
|
- | Cdefine_label lbl ->
|
|
- `{emit_label (100000 + lbl)}:\n`
|
|
- | Cint8 n ->
|
|
- ` .byte {emit_int n}\n`
|
|
- | Cint16 n ->
|
|
- ` .short {emit_int n}\n`
|
|
- | Cint32 n ->
|
|
- ` .word {emit_nativeint n}\n`
|
|
- | Cint n ->
|
|
- ` .word {emit_nativeint n}\n`
|
|
- | Csingle f ->
|
|
- emit_float32_directive ".long" f
|
|
- | Cdouble f ->
|
|
- emit_float64_split_directive ".long" f
|
|
- | Csymbol_address s ->
|
|
- ` .word {emit_symbol s}\n`
|
|
- | Clabel_address lbl ->
|
|
- ` .word {emit_label (100000 + 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`
|
|
+ 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_int32 (Nativeint.to_int32 n)}\n`
|
|
+ | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n`
|
|
+ | Csingle f -> ` .single {emit_string f}\n`
|
|
+ | Cdouble f -> ` .double {emit_string f}\n`
|
|
+ | Csymbol_address s -> ` .word {emit_symbol s}\n`
|
|
+ | Clabel_address lbl -> ` .word {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`;
|
|
@@ -605,32 +878,62 @@ let data l =
|
|
(* Beginning / end of an assembly file *)
|
|
|
|
let begin_assembly() =
|
|
- `trap_ptr .req r11\n`;
|
|
- `alloc_ptr .req r8\n`;
|
|
- `alloc_limit .req r10\n`;
|
|
+ ` .syntax unified\n`;
|
|
+ begin match !arch with
|
|
+ | ARMv4 -> ` .arch armv4t\n`
|
|
+ | ARMv5 -> ` .arch armv5t\n`
|
|
+ | ARMv5TE -> ` .arch armv5te\n`
|
|
+ | ARMv6 -> ` .arch armv6\n`
|
|
+ | ARMv6T2 -> ` .arch armv6t2\n`
|
|
+ | ARMv7 -> ` .arch armv7-a\n`
|
|
+ end;
|
|
+ begin match !fpu with
|
|
+ Soft -> ` .fpu softvfp\n`
|
|
+ | VFPv3_D16 -> ` .fpu vfpv3-d16\n`
|
|
+ | VFPv3 -> ` .fpu vfpv3\n`
|
|
+ end;
|
|
+ `trap_ptr .req r8\n`;
|
|
+ `alloc_ptr .req r10\n`;
|
|
+ `alloc_limit .req r11\n`;
|
|
let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
|
|
` .data\n`;
|
|
- ` .global {emit_symbol lbl_begin}\n`;
|
|
+ ` .globl {emit_symbol lbl_begin}\n`;
|
|
`{emit_symbol lbl_begin}:\n`;
|
|
let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
|
|
` .text\n`;
|
|
- ` .global {emit_symbol lbl_begin}\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`;
|
|
- ` .global {emit_symbol lbl_end}\n`;
|
|
+ ` .globl {emit_symbol lbl_end}\n`;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
let lbl_end = Compilenv.make_symbol (Some "data_end") in
|
|
` .data\n`;
|
|
- ` .global {emit_symbol lbl_end}\n`;
|
|
+ ` .globl {emit_symbol lbl_end}\n`;
|
|
`{emit_symbol lbl_end}:\n`;
|
|
- ` .word 0\n`;
|
|
+ ` .long 0\n`;
|
|
let lbl = Compilenv.make_symbol (Some "frametable") in
|
|
- ` .data\n`;
|
|
- ` .global {emit_symbol lbl}\n`;
|
|
+ ` .globl {emit_symbol lbl}\n`;
|
|
`{emit_symbol lbl}:\n`;
|
|
- ` .word {emit_int (List.length !frame_descriptors)}\n`;
|
|
- List.iter emit_frame !frame_descriptors;
|
|
- frame_descriptors := []
|
|
+ emit_frames
|
|
+ { efa_label = (fun lbl ->
|
|
+ ` .type {emit_label lbl}, %function\n`;
|
|
+ ` .word {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 -> ` .word {emit_int n}\n`);
|
|
+ efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`);
|
|
+ efa_label_rel = (fun lbl ofs ->
|
|
+ ` .word {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_eabihf" | "linux_eabi" ->
|
|
+ (* Mark stack as non-executable *)
|
|
+ ` .section .note.GNU-stack,\"\",%progbits\n`
|
|
+ | _ -> ()
|
|
+ end
|
|
diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
|
|
index e56ac6e..aed2b01 100644
|
|
--- a/asmcomp/arm/proc.ml
|
|
+++ b/asmcomp/arm/proc.ml
|
|
@@ -1,16 +1,17 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
+(* Benedikt Meurer, University of Siegen *)
|
|
(* *)
|
|
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
|
-(* en Automatique. All rights reserved. This file is distributed *)
|
|
-(* under the terms of the Q Public License version 1.0. *)
|
|
+(* Copyright 1998 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: proc.ml 9252 2009-05-04 13:46:46Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
(* Description of the ARM processor *)
|
|
|
|
@@ -26,32 +27,56 @@ let word_addressed = false
|
|
|
|
(* Registers available for register allocation *)
|
|
|
|
-(* Register map:
|
|
- r0 - r3 general purpose (not preserved by C)
|
|
- r4 - r7 general purpose (preserved)
|
|
- r8 allocation pointer (preserved)
|
|
- r9 platform register, usually reserved
|
|
- r10 allocation limit (preserved)
|
|
- r11 trap pointer (preserved)
|
|
- r12 general purpose (not preserved by C)
|
|
- r13 stack pointer
|
|
- r14 return address
|
|
- r15 program counter
|
|
+(* Integer register map:
|
|
+ r0 - r3 general purpose (not preserved)
|
|
+ r4 - r7 general purpose (preserved)
|
|
+ r8 trap pointer (preserved)
|
|
+ r9 platform register, usually reserved
|
|
+ r10 allocation pointer (preserved)
|
|
+ r11 allocation limit (preserved)
|
|
+ r12 intra-procedural scratch register (not preserved)
|
|
+ r13 stack pointer
|
|
+ r14 return address
|
|
+ r15 program counter
|
|
+ Floatinng-point register map (VFPv3):
|
|
+ d0 - d7 general purpose (not preserved)
|
|
+ d8 - d15 general purpose (preserved)
|
|
+ d16 - d31 generat purpose (not preserved), VFPv3 only
|
|
*)
|
|
|
|
-let int_reg_name = [|
|
|
- "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12"
|
|
-|]
|
|
+let int_reg_name =
|
|
+ [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |]
|
|
+
|
|
+let float_reg_name =
|
|
+ [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7";
|
|
+ "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15";
|
|
+ "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23";
|
|
+ "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |]
|
|
+
|
|
+(* We have three register classes:
|
|
+ 0 for integer registers
|
|
+ 1 for VFPv3-D16
|
|
+ 2 for VFPv3
|
|
+ This way we can choose between VFPv3-D16 and VFPv3
|
|
+ at (ocamlopt) runtime using command line switches.
|
|
+*)
|
|
|
|
-let num_register_classes = 1
|
|
+let num_register_classes = 3
|
|
|
|
-let register_class r = assert (r.typ <> Float); 0
|
|
+let register_class r =
|
|
+ match (r.typ, !fpu) with
|
|
+ (Int | Addr), _ -> 0
|
|
+ | Float, VFPv3_D16 -> 1
|
|
+ | Float, _ -> 2
|
|
|
|
-let num_available_registers = [| 9 |]
|
|
+let num_available_registers =
|
|
+ [| 9; 16; 32 |]
|
|
|
|
-let first_available_register = [| 0 |]
|
|
+let first_available_register =
|
|
+ [| 0; 100; 100 |]
|
|
|
|
-let register_name r = int_reg_name.(r)
|
|
+let register_name r =
|
|
+ if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
|
|
|
|
let rotate_registers = true
|
|
|
|
@@ -59,25 +84,34 @@ let rotate_registers = true
|
|
|
|
let hard_int_reg =
|
|
let v = Array.create 9 Reg.dummy in
|
|
- for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done;
|
|
+ for i = 0 to 8 do
|
|
+ v.(i) <- Reg.at_location Int (Reg i)
|
|
+ done;
|
|
+ v
|
|
+
|
|
+let hard_float_reg =
|
|
+ let v = Array.create 32 Reg.dummy in
|
|
+ for i = 0 to 31 do
|
|
+ v.(i) <- Reg.at_location Float (Reg(100 + i))
|
|
+ done;
|
|
v
|
|
|
|
-let all_phys_regs = hard_int_reg
|
|
+let all_phys_regs =
|
|
+ Array.append hard_int_reg hard_float_reg
|
|
|
|
-let phys_reg n = all_phys_regs.(n)
|
|
+let phys_reg n =
|
|
+ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
|
|
|
|
let stack_slot slot ty =
|
|
- assert (ty <> Float);
|
|
Reg.at_location ty (Stack slot)
|
|
|
|
(* Calling conventions *)
|
|
|
|
-(* XXX float types have already been expanded into pairs of integers.
|
|
- So we cannot align these floats. See if that causes a problem. *)
|
|
-
|
|
-let calling_conventions first_int last_int make_stack arg =
|
|
+let calling_conventions
|
|
+ first_int last_int first_float last_float make_stack arg =
|
|
let loc = Array.create (Array.length arg) Reg.dummy in
|
|
let int = ref first_int in
|
|
+ let float = ref first_float in
|
|
let ofs = ref 0 in
|
|
for i = 0 to Array.length arg - 1 do
|
|
match arg.(i).typ with
|
|
@@ -90,37 +124,86 @@ let calling_conventions first_int last_int make_stack arg =
|
|
ofs := !ofs + size_int
|
|
end
|
|
| Float ->
|
|
- assert false
|
|
+ assert (abi = EABI_VFP);
|
|
+ assert (!fpu >= VFPv3_D16);
|
|
+ if !float <= last_float then begin
|
|
+ loc.(i) <- phys_reg !float;
|
|
+ incr float
|
|
+ end else begin
|
|
+ ofs := Misc.align !ofs size_float;
|
|
+ loc.(i) <- stack_slot (make_stack !ofs) Float;
|
|
+ ofs := !ofs + size_float
|
|
+ end
|
|
done;
|
|
- (loc, Misc.align !ofs 8)
|
|
+ (loc, Misc.align !ofs 8) (* keep stack 8-aligned *)
|
|
|
|
let incoming ofs = Incoming ofs
|
|
let outgoing ofs = Outgoing ofs
|
|
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
|
|
|
+(* OCaml calling convention:
|
|
+ first integer args in r0...r7
|
|
+ first float args in d0...d15 (EABI+VFP)
|
|
+ remaining args on stack.
|
|
+ Return values in r0...r7 or d0...d15. *)
|
|
+
|
|
let loc_arguments arg =
|
|
- calling_conventions 0 7 outgoing arg
|
|
+ calling_conventions 0 7 100 115 outgoing arg
|
|
let loc_parameters arg =
|
|
- let (loc, ofs) = calling_conventions 0 7 incoming arg in loc
|
|
+ let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc
|
|
let loc_results res =
|
|
- let (loc, ofs) = calling_conventions 0 7 not_supported res in loc
|
|
+ let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc
|
|
+
|
|
+(* C calling convention:
|
|
+ first integer args in r0...r3
|
|
+ first float args in d0...d7 (EABI+VFP)
|
|
+ remaining args on stack.
|
|
+ Return values in r0...r1 or d0. *)
|
|
|
|
let loc_external_arguments arg =
|
|
- calling_conventions 0 3 outgoing arg
|
|
+ calling_conventions 0 3 100 107 outgoing arg
|
|
let loc_external_results res =
|
|
- let (loc, ofs) = calling_conventions 0 1 not_supported res in loc
|
|
+ let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc
|
|
|
|
let loc_exn_bucket = phys_reg 0
|
|
|
|
(* Registers destroyed by operations *)
|
|
|
|
-let destroyed_at_c_call = (* r4-r7 preserved *)
|
|
- Array.of_list(List.map phys_reg [0;1;2;3;8])
|
|
+let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *)
|
|
+ Array.of_list (List.map
|
|
+ phys_reg
|
|
+ [7;8;
|
|
+ 116;116;118;119;120;121;122;123;
|
|
+ 124;125;126;127;128;129;130;131])
|
|
+
|
|
+let destroyed_at_c_call =
|
|
+ Array.of_list (List.map
|
|
+ phys_reg
|
|
+ (match abi with
|
|
+ EABI -> (* r4-r7 preserved *)
|
|
+ [0;1;2;3;8;
|
|
+ 100;101;102;103;104;105;106;107;
|
|
+ 108;109;110;111;112;113;114;115;
|
|
+ 116;116;118;119;120;121;122;123;
|
|
+ 124;125;126;127;128;129;130;131]
|
|
+ | EABI_VFP -> (* r4-r7, d8-d15 preserved *)
|
|
+ [0;1;2;3;8;
|
|
+ 100;101;102;103;104;105;106;107;
|
|
+ 116;116;118;119;120;121;122;123;
|
|
+ 124;125;126;127;128;129;130;131]))
|
|
|
|
let destroyed_at_oper = function
|
|
- Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
|
- | Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
|
- | Iop(Ialloc(_)) -> [|phys_reg 8|] (* r12 destroyed *)
|
|
+ Iop(Icall_ind | Icall_imm _ )
|
|
+ | Iop(Iextcall(_, true)) ->
|
|
+ all_phys_regs
|
|
+ | Iop(Iextcall(_, false)) ->
|
|
+ destroyed_at_c_call
|
|
+ | Iop(Ialloc n) ->
|
|
+ destroyed_at_alloc
|
|
+ | Iop(Iconst_symbol _) when !pic_code ->
|
|
+ [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *)
|
|
+ | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) ->
|
|
+ [|phys_reg 107|] (* d7 (s14-s15) destroyed *)
|
|
| _ -> [||]
|
|
|
|
let destroyed_at_raise = all_phys_regs
|
|
@@ -128,15 +211,16 @@ let destroyed_at_raise = all_phys_regs
|
|
(* Maximal register pressure *)
|
|
|
|
let safe_register_pressure = function
|
|
- Iextcall(_, _) -> 4
|
|
+ Iextcall(_, _) -> 5
|
|
| _ -> 9
|
|
+
|
|
let max_register_pressure = function
|
|
- Iextcall(_, _) -> [| 4 |]
|
|
- | _ -> [| 9 |]
|
|
+ Iextcall(_, _) -> [| 5; 9; 9 |]
|
|
+ | _ -> [| 9; 16; 32 |]
|
|
|
|
(* Layout of the stack *)
|
|
|
|
-let num_stack_slots = [| 0 |]
|
|
+let num_stack_slots = [| 0; 0; 0 |]
|
|
let contains_calls = ref false
|
|
|
|
(* Calling the assembler *)
|
|
@@ -144,6 +228,3 @@ let contains_calls = ref false
|
|
let assemble_file infile outfile =
|
|
Ccomp.command (Config.asm ^ " -o " ^
|
|
Filename.quote outfile ^ " " ^ Filename.quote infile)
|
|
-
|
|
-open Clflags;;
|
|
-open Config;;
|
|
diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml
|
|
index 0917438..c5b137a 100644
|
|
--- a/asmcomp/arm/reload.ml
|
|
+++ b/asmcomp/arm/reload.ml
|
|
@@ -1,6 +1,6 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
@@ -10,7 +10,7 @@
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
(* Reloading for the ARM *)
|
|
|
|
diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml
|
|
index 930e1bc..4b47733 100644
|
|
--- a/asmcomp/arm/scheduling.ml
|
|
+++ b/asmcomp/arm/scheduling.ml
|
|
@@ -1,51 +1,79 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
+(* Benedikt Meurer, University of Siegen *)
|
|
(* *)
|
|
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
-(* en Automatique. All rights reserved. This file is distributed *)
|
|
-(* under the terms of the Q Public License version 1.0. *)
|
|
+(* Copyright 1998 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: scheduling.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
+open Arch
|
|
open Mach
|
|
|
|
-(* Instruction scheduling for the Sparc *)
|
|
+(* Instruction scheduling for the ARM *)
|
|
|
|
-class scheduler = object
|
|
+class scheduler = object(self)
|
|
|
|
-inherit Schedgen.scheduler_generic
|
|
+inherit Schedgen.scheduler_generic as super
|
|
|
|
-(* Scheduling -- based roughly on the Strong ARM *)
|
|
+(* Scheduling -- based roughly on the ARM11 (ARMv6) *)
|
|
|
|
method oper_latency = function
|
|
- Ireload -> 2
|
|
- | Iload(_, _) -> 2
|
|
- | Iconst_symbol _ -> 2 (* turned into a load *)
|
|
- | Iconst_float _ -> 2 (* turned into a load *)
|
|
- | Iintop(Imul) -> 3
|
|
- | Iintop_imm(Imul, _) -> 3
|
|
- (* No data available for floatops, let's make educated guesses *)
|
|
- | Iaddf -> 3
|
|
- | Isubf -> 3
|
|
- | Imulf -> 5
|
|
- | Idivf -> 15
|
|
+ (* Loads have a latency of two cycles in general *)
|
|
+ Iconst_symbol _
|
|
+ | Iconst_float _
|
|
+ | Iload(_, _)
|
|
+ | Ireload
|
|
+ | Ifloatofint (* mcr/mrc count as memory access *)
|
|
+ | Iintoffloat -> 2
|
|
+ (* Multiplys have a latency of two cycles *)
|
|
+ | Iintop Imul
|
|
+ | Ispecific(Imuladd | Imulsub) -> 2
|
|
+ (* VFP instructions *)
|
|
+ | Iaddf
|
|
+ | Isubf
|
|
+ | Idivf
|
|
+ | Imulf | Ispecific Inegmulf
|
|
+ | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)
|
|
+ | Ispecific Isqrtf
|
|
+ | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2
|
|
+ (* Everything else *)
|
|
| _ -> 1
|
|
|
|
-(* Issue cycles. Rough approximations *)
|
|
+method! is_checkbound = function
|
|
+ Ispecific(Ishiftcheckbound _) -> true
|
|
+ | op -> super#is_checkbound op
|
|
+
|
|
+(* Issue cycles. Rough approximations *)
|
|
|
|
method oper_issue_cycles = function
|
|
Ialloc _ -> 4
|
|
- | Iintop(Icomp _) -> 3
|
|
- | Iintop(Icheckbound) -> 2
|
|
- | Iintop_imm(Idiv, _) -> 4
|
|
- | Iintop_imm(Imod, _) -> 6
|
|
+ | Iintop(Ilsl | Ilsr | Iasr) -> 2
|
|
+ | Iintop(Icomp _)
|
|
| Iintop_imm(Icomp _, _) -> 3
|
|
+ | Iintop(Icheckbound)
|
|
| Iintop_imm(Icheckbound, _) -> 2
|
|
+ | Ispecific(Ishiftcheckbound _) -> 3
|
|
+ | Iintop_imm(Idiv, _) -> 4
|
|
+ | Iintop_imm(Imod, _) -> 6
|
|
+ | Iintop Imul
|
|
+ | Ispecific(Imuladd | Imulsub) -> 2
|
|
+ (* VFP instructions *)
|
|
+ | Iaddf
|
|
+ | Isubf -> 7
|
|
+ | Imulf
|
|
+ | Ispecific Inegmulf -> 9
|
|
+ | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17
|
|
+ | Idivf
|
|
+ | Ispecific Isqrtf -> 27
|
|
+ | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4
|
|
+ (* Everything else *)
|
|
| _ -> 1
|
|
|
|
end
|
|
diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml
|
|
index f09d146..94d0367 100644
|
|
--- a/asmcomp/arm/selection.ml
|
|
+++ b/asmcomp/arm/selection.ml
|
|
@@ -1,54 +1,77 @@
|
|
(***********************************************************************)
|
|
(* *)
|
|
-(* Objective Caml *)
|
|
+(* OCaml *)
|
|
(* *)
|
|
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
+(* Benedikt Meurer, University of Siegen *)
|
|
(* *)
|
|
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
|
-(* en Automatique. All rights reserved. This file is distributed *)
|
|
-(* under the terms of the Q Public License version 1.0. *)
|
|
+(* Copyright 1998 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
-(* $Id: selection.ml 10295 2010-04-22 12:39:40Z xleroy $ *)
|
|
+(* $Id$ *)
|
|
|
|
(* Instruction selection for the ARM processor *)
|
|
|
|
-open Misc
|
|
-open Cmm
|
|
-open Reg
|
|
open Arch
|
|
-open Proc
|
|
+open Cmm
|
|
open Mach
|
|
+open Misc
|
|
+open Proc
|
|
+open Reg
|
|
|
|
-(* Immediate operands are 8-bit immediate values, zero-extended, and rotated
|
|
- right by 0, 2, 4, ... 30 bits.
|
|
- To avoid problems with Caml's 31-bit arithmetic,
|
|
- we check only with 8-bit values shifted left 0 to 22 bits. *)
|
|
-
|
|
-let rec is_immed n shift =
|
|
- if shift > 22 then false
|
|
- else if n land (0xFF lsl shift) = n then true
|
|
- else is_immed n (shift + 2)
|
|
+let is_offset chunk n =
|
|
+ match chunk with
|
|
+ (* VFPv3 load/store have -1020 to 1020 *)
|
|
+ Single | Double | Double_u
|
|
+ when !fpu >= VFPv3_D16 ->
|
|
+ n >= -1020 && n <= 1020
|
|
+ (* ARM load/store byte/word have -4095 to 4095 *)
|
|
+ | Byte_unsigned | Byte_signed
|
|
+ | Thirtytwo_unsigned | Thirtytwo_signed
|
|
+ | Word | Single
|
|
+ when not !thumb ->
|
|
+ n >= -4095 && n <= 4095
|
|
+ (* Thumb-2 load/store have -255 to 4095 *)
|
|
+ | _ when !arch > ARMv6 && !thumb ->
|
|
+ n >= -255 && n <= 4095
|
|
+ (* Everything else has -255 to 255 *)
|
|
+ | _ ->
|
|
+ n >= -255 && n <= 255
|
|
|
|
-(* We have 12-bit + sign byte offsets for word accesses,
|
|
- 8-bit + sign word offsets for float accesses,
|
|
- and 8-bit + sign byte offsets for bytes and shorts.
|
|
- Use lowest common denominator. *)
|
|
+let is_intconst = function
|
|
+ Cconst_int _ -> true
|
|
+ | _ -> false
|
|
|
|
-let is_offset n = n < 256 && n > -256
|
|
+(* Special constraints on operand and result registers *)
|
|
|
|
-let is_intconst = function Cconst_int n -> true | _ -> false
|
|
+exception Use_default
|
|
|
|
-(* Soft emulation of float comparisons *)
|
|
+let r1 = phys_reg 1
|
|
|
|
-let float_comparison_function = function
|
|
- | Ceq -> "__eqdf2"
|
|
- | Cne -> "__nedf2"
|
|
- | Clt -> "__ltdf2"
|
|
- | Cle -> "__ledf2"
|
|
- | Cgt -> "__gtdf2"
|
|
- | Cge -> "__gedf2"
|
|
+let pseudoregs_for_operation op arg res =
|
|
+ match op with
|
|
+ (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm
|
|
+ and rd must be different. We deal with this by pretending that rm
|
|
+ is also a result of the mul / mla operation. *)
|
|
+ Iintop Imul | Ispecific Imuladd when !arch < ARMv6 ->
|
|
+ (arg, [| res.(0); arg.(0) |])
|
|
+ (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *)
|
|
+ | Iabsf | Inegf when !fpu = Soft ->
|
|
+ ([|res.(0); arg.(1)|], res)
|
|
+ (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *)
|
|
+ | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) ->
|
|
+ let arg' = Array.copy arg in
|
|
+ arg'.(0) <- res.(0);
|
|
+ (arg', res)
|
|
+ (* We use __aeabi_idivmod for Cmodi only, and hence we care only
|
|
+ for the remainder in r1, so fix up the destination register. *)
|
|
+ | Iextcall("__aeabi_idivmod", false) ->
|
|
+ (arg, [|r1|])
|
|
+ (* Other instructions are regular *)
|
|
+ | _ -> raise Use_default
|
|
|
|
(* Instruction selection *)
|
|
class selector = object(self)
|
|
@@ -56,23 +79,32 @@ class selector = object(self)
|
|
inherit Selectgen.selector_generic as super
|
|
|
|
method! regs_for tyv =
|
|
- (* Expand floats into pairs of integer registers *)
|
|
- let nty = Array.length tyv in
|
|
- let rec expand i =
|
|
- if i >= nty then [] else begin
|
|
- match tyv.(i) with
|
|
- | Float -> Int :: Int :: expand (i+1)
|
|
- | ty -> ty :: expand (i+1)
|
|
- end in
|
|
- Reg.createv (Array.of_list (expand 0))
|
|
+ Reg.createv (if !fpu = Soft then begin
|
|
+ (* Expand floats into pairs of integer registers *)
|
|
+ let rec expand = function
|
|
+ [] -> []
|
|
+ | Float :: tyl -> Int :: Int :: expand tyl
|
|
+ | ty :: tyl -> ty :: expand tyl in
|
|
+ Array.of_list (expand (Array.to_list tyv))
|
|
+ end else begin
|
|
+ tyv
|
|
+ end)
|
|
|
|
method is_immediate n =
|
|
- n land 0xFF = n || is_immed n 2
|
|
+ is_immediate (Int32.of_int n)
|
|
+
|
|
+method! is_simple_expr = function
|
|
+ (* inlined floating-point ops are simple if their arguments are *)
|
|
+ | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 ->
|
|
+ List.for_all self#is_simple_expr args
|
|
+ | e -> super#is_simple_expr e
|
|
|
|
-method select_addressing = function
|
|
- Cop(Cadda, [arg; Cconst_int n]) when is_offset n ->
|
|
+method select_addressing chunk = function
|
|
+ | Cop(Cadda, [arg; Cconst_int n])
|
|
+ when is_offset chunk n ->
|
|
(Iindexed n, arg)
|
|
- | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset n ->
|
|
+ | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])])
|
|
+ when is_offset chunk n ->
|
|
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
|
| arg ->
|
|
(Iindexed 0, arg)
|
|
@@ -91,109 +123,146 @@ method select_shift_arith op shiftop shiftrevop args =
|
|
| [Cop(Casr, [arg1; Cconst_int n]); arg2]
|
|
when n > 0 && n < 32 && not(is_intconst arg1) ->
|
|
(Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1])
|
|
- | _ ->
|
|
- super#select_operation op args
|
|
+ | args ->
|
|
+ begin match super#select_operation op args with
|
|
+ (* Recognize multiply and add *)
|
|
+ (Iintop Iadd, [Cop(Cmuli, args); arg3])
|
|
+ | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args ->
|
|
+ begin match self#select_operation Cmuli args with
|
|
+ (Iintop Imul, [arg1; arg2]) ->
|
|
+ (Ispecific Imuladd, [arg1; arg2; arg3])
|
|
+ | _ -> op_args
|
|
+ end
|
|
+ (* Recognize multiply and subtract *)
|
|
+ | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args
|
|
+ when !arch > ARMv6 ->
|
|
+ begin match self#select_operation Cmuli args with
|
|
+ (Iintop Imul, [arg1; arg2]) ->
|
|
+ (Ispecific Imulsub, [arg1; arg2; arg3])
|
|
+ | _ -> op_args
|
|
+ end
|
|
+ | op_args -> op_args
|
|
+ end
|
|
|
|
method! select_operation op args =
|
|
- match op with
|
|
- Cadda | Caddi ->
|
|
- begin match args with
|
|
- [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) ->
|
|
- (Iintop_imm(Isub, -n), [arg1])
|
|
- | _ ->
|
|
- self#select_shift_arith op Ishiftadd Ishiftadd args
|
|
- end
|
|
- | Csuba | Csubi ->
|
|
- begin match args with
|
|
- [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) ->
|
|
- (Iintop_imm(Iadd, -n), [arg1])
|
|
- | [Cconst_int n; arg2] when self#is_immediate n ->
|
|
- (Ispecific(Irevsubimm n), [arg2])
|
|
- | _ ->
|
|
- self#select_shift_arith op Ishiftsub Ishiftsubrev args
|
|
- end
|
|
- | Cmuli -> (* no multiply immediate *)
|
|
+ match (op, args) with
|
|
+ (* Recognize special shift arithmetic *)
|
|
+ ((Cadda | Caddi), [arg; Cconst_int n])
|
|
+ when n < 0 && self#is_immediate (-n) ->
|
|
+ (Iintop_imm(Isub, -n), [arg])
|
|
+ | ((Cadda | Caddi as op), args) ->
|
|
+ self#select_shift_arith op Ishiftadd Ishiftadd args
|
|
+ | ((Csuba | Csubi), [arg; Cconst_int n])
|
|
+ when n < 0 && self#is_immediate (-n) ->
|
|
+ (Iintop_imm(Iadd, -n), [arg])
|
|
+ | ((Csuba | Csubi), [Cconst_int n; arg])
|
|
+ when self#is_immediate n ->
|
|
+ (Ispecific(Irevsubimm n), [arg])
|
|
+ | ((Csuba | Csubi as op), args) ->
|
|
+ self#select_shift_arith op Ishiftsub Ishiftsubrev args
|
|
+ | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2])
|
|
+ when n > 0 && n < 32 && not(is_intconst arg2) ->
|
|
+ (Ispecific(Ishiftcheckbound n), [arg1; arg2])
|
|
+ (* ARM does not support immediate operands for multiplication *)
|
|
+ | (Cmuli, args) ->
|
|
(Iintop Imul, args)
|
|
- | Cdivi ->
|
|
- begin match args with
|
|
- [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
|
- (Iintop_imm(Idiv, n), [arg1])
|
|
- | _ ->
|
|
- (Iextcall("__divsi3", false), args)
|
|
- end
|
|
- | Cmodi ->
|
|
- begin match args with
|
|
- [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
|
- (Iintop_imm(Imod, n), [arg1])
|
|
- | _ ->
|
|
- (Iextcall("__modsi3", false), args)
|
|
- end
|
|
- | Ccheckbound _ ->
|
|
- begin match args with
|
|
- [Cop(Clsr, [arg1; Cconst_int n]); arg2]
|
|
- when n > 0 && n < 32 && not(is_intconst arg2) ->
|
|
- (Ispecific(Ishiftcheckbound n), [arg1; arg2])
|
|
- | _ ->
|
|
- super#select_operation op args
|
|
- end
|
|
- (* Turn floating-point operations into library function calls *)
|
|
- | Caddf -> (Iextcall("__adddf3", false), args)
|
|
- | Csubf -> (Iextcall("__subdf3", false), args)
|
|
- | Cmulf -> (Iextcall("__muldf3", false), args)
|
|
- | Cdivf -> (Iextcall("__divdf3", false), args)
|
|
- | Cfloatofint -> (Iextcall("__floatsidf", false), args)
|
|
- | Cintoffloat -> (Iextcall("__fixdfsi", false), args)
|
|
- | Ccmpf comp ->
|
|
- (Iintop_imm(Icomp(Isigned comp), 0),
|
|
- [Cop(Cextcall(float_comparison_function comp,
|
|
- typ_int, false, Debuginfo.none),
|
|
- args)])
|
|
+ (* Turn integer division/modulus into runtime ABI calls *)
|
|
+ | (Cdivi, [arg; Cconst_int n])
|
|
+ when n = 1 lsl Misc.log2 n ->
|
|
+ (Iintop_imm(Idiv, n), [arg])
|
|
+ | (Cdivi, args) ->
|
|
+ (Iextcall("__aeabi_idiv", false), args)
|
|
+ | (Cmodi, [arg; Cconst_int n])
|
|
+ when n = 1 lsl Misc.log2 n ->
|
|
+ (Iintop_imm(Imod, n), [arg])
|
|
+ | (Cmodi, args) ->
|
|
+ (* See above for fix up of return register *)
|
|
+ (Iextcall("__aeabi_idivmod", false), args)
|
|
+ (* Turn floating-point operations into runtime ABI calls for softfp *)
|
|
+ | (op, args) when !fpu = Soft -> self#select_operation_softfp op args
|
|
+ (* Select operations for VFPv3 *)
|
|
+ | (op, args) -> self#select_operation_vfpv3 op args
|
|
+
|
|
+method private select_operation_softfp op args =
|
|
+ match (op, args) with
|
|
+ (* Turn floating-point operations into runtime ABI calls *)
|
|
+ | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args)
|
|
+ | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args)
|
|
+ | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args)
|
|
+ | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args)
|
|
+ | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args)
|
|
+ | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args)
|
|
+ | (Ccmpf comp, args) ->
|
|
+ let func = (match comp with
|
|
+ Cne (* there's no __aeabi_dcmpne *)
|
|
+ | Ceq -> "__aeabi_dcmpeq"
|
|
+ | Clt -> "__aeabi_dcmplt"
|
|
+ | Cle -> "__aeabi_dcmple"
|
|
+ | Cgt -> "__aeabi_dcmpgt"
|
|
+ | Cge -> "__aeabi_dcmpge") in
|
|
+ let comp = (match comp with
|
|
+ Cne -> Ceq (* eq 0 => false *)
|
|
+ | _ -> Cne (* ne 0 => true *)) in
|
|
+ (Iintop_imm(Icomp(Iunsigned comp), 0),
|
|
+ [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)])
|
|
(* Add coercions around loads and stores of 32-bit floats *)
|
|
- | Cload Single ->
|
|
- (Iextcall("__extendsfdf2", false), [Cop(Cload Word, args)])
|
|
- | Cstore Single ->
|
|
- begin match args with
|
|
- | [arg1; arg2] ->
|
|
- let arg2' =
|
|
- Cop(Cextcall("__truncdfsf2", typ_int, false, Debuginfo.none),
|
|
- [arg2]) in
|
|
- self#select_operation (Cstore Word) [arg1; arg2']
|
|
- | _ -> assert false
|
|
- end
|
|
+ | (Cload Single, args) ->
|
|
+ (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)])
|
|
+ | (Cstore Single, [arg1; arg2]) ->
|
|
+ let arg2' =
|
|
+ Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none),
|
|
+ [arg2]) in
|
|
+ self#select_operation (Cstore Word) [arg1; arg2']
|
|
(* Other operations are regular *)
|
|
- | _ -> super#select_operation op args
|
|
+ | (op, args) -> super#select_operation op args
|
|
+
|
|
+method private select_operation_vfpv3 op args =
|
|
+ match (op, args) with
|
|
+ (* Recognize floating-point negate and multiply *)
|
|
+ (Cnegf, [Cop(Cmulf, args)]) ->
|
|
+ (Ispecific Inegmulf, args)
|
|
+ (* Recognize floating-point multiply and add *)
|
|
+ | (Caddf, [arg; Cop(Cmulf, args)])
|
|
+ | (Caddf, [Cop(Cmulf, args); arg]) ->
|
|
+ (Ispecific Imuladdf, arg :: args)
|
|
+ (* Recognize floating-point negate, multiply and subtract *)
|
|
+ | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)])
|
|
+ | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) ->
|
|
+ (Ispecific Inegmulsubf, arg :: args)
|
|
+ (* Recognize floating-point negate, multiply and add *)
|
|
+ | (Csubf, [arg; Cop(Cmulf, args)]) ->
|
|
+ (Ispecific Inegmuladdf, arg :: args)
|
|
+ (* Recognize multiply and subtract *)
|
|
+ | (Csubf, [Cop(Cmulf, args); arg]) ->
|
|
+ (Ispecific Imulsubf, arg :: args)
|
|
+ (* Recognize floating-point square root *)
|
|
+ | (Cextcall("sqrt", _, false, _), args) ->
|
|
+ (Ispecific Isqrtf, args)
|
|
+ (* Other operations are regular *)
|
|
+ | (op, args) -> super#select_operation op args
|
|
|
|
method! select_condition = function
|
|
- | Cop(Ccmpf cmp, args) ->
|
|
- (Iinttest_imm(Isigned cmp, 0),
|
|
- Cop(Cextcall(float_comparison_function cmp,
|
|
- typ_int, false, Debuginfo.none),
|
|
- args))
|
|
+ (* Turn floating-point comparisons into runtime ABI calls *)
|
|
+ Cop(Ccmpf _ as op, args) when !fpu = Soft ->
|
|
+ begin match self#select_operation_softfp op args with
|
|
+ (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg)
|
|
+ | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg)
|
|
+ | _ -> assert false
|
|
+ end
|
|
| expr ->
|
|
super#select_condition expr
|
|
|
|
-(* Deal with some register irregularities:
|
|
-
|
|
-1- In mul rd, rm, rs, the registers rm and rd must be different.
|
|
- We deal with this by pretending that rm is also a result of the mul
|
|
- operation.
|
|
-
|
|
-2- For Inegf and Iabsf, force arguments and results in (r0, r1);
|
|
- this simplifies code generation later.
|
|
-*)
|
|
+(* Deal with some register constraints *)
|
|
|
|
method! insert_op_debug op dbg rs rd =
|
|
- match op with
|
|
- | Iintop(Imul) ->
|
|
- self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd
|
|
- | Iabsf | Inegf ->
|
|
- let r = [| phys_reg 0; phys_reg 1 |] in
|
|
- self#insert_moves rs r;
|
|
- self#insert_debug (Iop op) dbg r r;
|
|
- self#insert_moves r rd;
|
|
- rd
|
|
- | _ ->
|
|
- super#insert_op_debug op dbg rs rd
|
|
+ try
|
|
+ let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
|
|
+ self#insert_moves rs rsrc;
|
|
+ self#insert_debug (Iop op) dbg rsrc rdst;
|
|
+ self#insert_moves rdst rd;
|
|
+ rd
|
|
+ with Use_default ->
|
|
+ super#insert_op_debug op dbg rs rd
|
|
|
|
end
|
|
|
|
diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
|
|
index 1700bf3..827a63d 100644
|
|
--- a/asmcomp/i386/selection.ml
|
|
+++ b/asmcomp/i386/selection.ml
|
|
@@ -168,7 +168,7 @@ method! is_simple_expr e =
|
|
| _ ->
|
|
super#is_simple_expr e
|
|
|
|
-method select_addressing exp =
|
|
+method select_addressing chunk exp =
|
|
match select_addr exp with
|
|
(Asymbol s, d) ->
|
|
(Ibased(s, d), Ctuple [])
|
|
@@ -200,7 +200,7 @@ method! select_operation op args =
|
|
match op with
|
|
(* Recognize the LEA instruction *)
|
|
Caddi | Cadda | Csubi | Csuba ->
|
|
- begin match self#select_addressing (Cop(op, args)) with
|
|
+ begin match self#select_addressing Word (Cop(op, args)) with
|
|
(Iindexed d, _) -> super#select_operation op args
|
|
| (Iindexed2 0, _) -> super#select_operation op args
|
|
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
|
@@ -233,7 +233,7 @@ method! select_operation op args =
|
|
begin match args with
|
|
[loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
|
|
when loc = loc' ->
|
|
- let (addr, arg) = self#select_addressing loc in
|
|
+ let (addr, arg) = self#select_addressing Word loc in
|
|
(Ispecific(Ioffset_loc(n, addr)), [arg])
|
|
| _ ->
|
|
super#select_operation op args
|
|
@@ -250,11 +250,11 @@ method! select_operation op args =
|
|
method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
|
|
match args with
|
|
[arg1; Cop(Cload chunk, [loc2])] ->
|
|
- let (addr, arg2) = self#select_addressing loc2 in
|
|
+ let (addr, arg2) = self#select_addressing chunk loc2 in
|
|
(Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)),
|
|
[arg1; arg2])
|
|
| [Cop(Cload chunk, [loc1]); arg2] ->
|
|
- let (addr, arg1) = self#select_addressing loc1 in
|
|
+ let (addr, arg1) = self#select_addressing chunk loc1 in
|
|
(Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)),
|
|
[arg2; arg1])
|
|
| [arg1; arg2] ->
|
|
@@ -295,10 +295,10 @@ method select_push exp =
|
|
| Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
|
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
|
| Cop(Cload Word, [loc]) ->
|
|
- let (addr, arg) = self#select_addressing loc in
|
|
+ let (addr, arg) = self#select_addressing Word loc in
|
|
(Ispecific(Ipush_load addr), arg)
|
|
| Cop(Cload Double_u, [loc]) ->
|
|
- let (addr, arg) = self#select_addressing loc in
|
|
+ let (addr, arg) = self#select_addressing Double_u loc in
|
|
(Ispecific(Ipush_load_float addr), arg)
|
|
| _ -> (Ispecific(Ipush), exp)
|
|
|
|
diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml
|
|
index ed15efb..0532d6b 100644
|
|
--- a/asmcomp/power/selection.ml
|
|
+++ b/asmcomp/power/selection.ml
|
|
@@ -52,7 +52,7 @@ inherit Selectgen.selector_generic as super
|
|
|
|
method is_immediate n = (n <= 32767) && (n >= -32768)
|
|
|
|
-method select_addressing exp =
|
|
+method select_addressing chunk exp =
|
|
match select_addr exp with
|
|
(Asymbol s, d) ->
|
|
(Ibased(s, d), Ctuple [])
|
|
diff --git a/asmcomp/power64/selection.ml b/asmcomp/power64/selection.ml
|
|
index 7b8e2a4..d2325e1 100644
|
|
--- a/asmcomp/power64/selection.ml
|
|
+++ b/asmcomp/power64/selection.ml
|
|
@@ -52,7 +52,7 @@ inherit Selectgen.selector_generic as super
|
|
|
|
method is_immediate n = (n <= 32767) && (n >= -32768)
|
|
|
|
-method select_addressing exp =
|
|
+method select_addressing chunk exp =
|
|
match select_addr exp with
|
|
(Asymbol s, d) ->
|
|
(Ibased(s, d), Ctuple [])
|
|
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
|
|
index 2fc40f7..0bc9efb 100644
|
|
--- a/asmcomp/selectgen.ml
|
|
+++ b/asmcomp/selectgen.ml
|
|
@@ -204,7 +204,7 @@ method virtual is_immediate : int -> bool
|
|
(* Selection of addressing modes *)
|
|
|
|
method virtual select_addressing :
|
|
- Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
|
+ Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
|
|
|
(* Default instruction selection for stores (of words) *)
|
|
|
|
@@ -219,10 +219,10 @@ method select_operation op args =
|
|
| (Capply(ty, dbg), _) -> (Icall_ind, args)
|
|
| (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args)
|
|
| (Cload chunk, [arg]) ->
|
|
- let (addr, eloc) = self#select_addressing arg in
|
|
+ let (addr, eloc) = self#select_addressing chunk arg in
|
|
(Iload(chunk, addr), [eloc])
|
|
| (Cstore chunk, [arg1; arg2]) ->
|
|
- let (addr, eloc) = self#select_addressing arg1 in
|
|
+ let (addr, eloc) = self#select_addressing chunk arg1 in
|
|
if chunk = Word then begin
|
|
let (op, newarg2) = self#select_store addr arg2 in
|
|
(op, [newarg2; eloc])
|
|
@@ -366,7 +366,7 @@ method insert_move src dst =
|
|
self#insert (Iop Imove) [|src|] [|dst|]
|
|
|
|
method insert_moves src dst =
|
|
- for i = 0 to Array.length src - 1 do
|
|
+ for i = 0 to min (Array.length src) (Array.length dst) - 1 do
|
|
self#insert_move src.(i) dst.(i)
|
|
done
|
|
|
|
@@ -490,9 +490,8 @@ method emit_expr env exp =
|
|
let (loc_arg, stack_ofs) =
|
|
self#emit_extcall_args env new_args in
|
|
let rd = self#regs_for ty in
|
|
- let loc_res = Proc.loc_external_results rd in
|
|
- self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg
|
|
- loc_arg loc_res;
|
|
+ let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg
|
|
+ loc_arg (Proc.loc_external_results rd) in
|
|
self#insert_move_results loc_res rd stack_ofs;
|
|
Some rd
|
|
| Ialloc _ ->
|
|
diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
|
|
index ae53cda..69dae6d 100644
|
|
--- a/asmcomp/selectgen.mli
|
|
+++ b/asmcomp/selectgen.mli
|
|
@@ -26,7 +26,7 @@ class virtual selector_generic : object
|
|
(* Must be defined to indicate whether a constant is a suitable
|
|
immediate operand to arithmetic instructions *)
|
|
method virtual select_addressing :
|
|
- Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
|
+ Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
|
(* Must be defined to select addressing modes *)
|
|
method is_simple_expr: Cmm.expression -> bool
|
|
(* Can be overridden to reflect special extcalls known to be pure *)
|
|
diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml
|
|
index 82758dc..c1f30fd 100644
|
|
--- a/asmcomp/sparc/selection.ml
|
|
+++ b/asmcomp/sparc/selection.ml
|
|
@@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super
|
|
|
|
method is_immediate n = (n <= 4095) && (n >= -4096)
|
|
|
|
-method select_addressing = function
|
|
+method select_addressing chunk = function
|
|
Cconst_symbol s ->
|
|
(Ibased(s, 0), Ctuple [])
|
|
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
|
diff --git a/asmrun/arm.S b/asmrun/arm.S
|
|
index 1313e9c..6482956 100644
|
|
--- a/asmrun/arm.S
|
|
+++ b/asmrun/arm.S
|
|
@@ -1,286 +1,411 @@
|
|
/***********************************************************************/
|
|
/* */
|
|
-/* Objective Caml */
|
|
+/* OCaml */
|
|
/* */
|
|
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
|
|
+/* Benedikt Meurer, University of Siegen */
|
|
/* */
|
|
-/* Copyright 1998 Institut National de Recherche en Informatique et */
|
|
-/* en Automatique. All rights reserved. This file is distributed */
|
|
-/* under the terms of the GNU Library General Public License, with */
|
|
-/* the special exception on linking described in file ../LICENSE. */
|
|
+/* Copyright 1998 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 GNU */
|
|
+/* Library General Public License, with the special exception on */
|
|
+/* linking described in file ../LICENSE. */
|
|
/* */
|
|
/***********************************************************************/
|
|
|
|
-/* $Id: arm.S 9252 2009-05-04 13:46:46Z xleroy $ */
|
|
+/* $Id$ */
|
|
|
|
/* Asm part of the runtime system, ARM processor */
|
|
+/* Must be preprocessed by cpp */
|
|
|
|
-trap_ptr .req r11
|
|
-alloc_ptr .req r8
|
|
-alloc_limit .req r10
|
|
-
|
|
+ .syntax unified
|
|
.text
|
|
+#if defined(SYS_linux_eabihf)
|
|
+ .arch armv7-a
|
|
+ .fpu vfpv3-d16
|
|
+ .thumb
|
|
+#elif defined(SYS_linux_eabi)
|
|
+ .arch armv4t
|
|
+ .arm
|
|
+
|
|
+ /* Compatibility macros */
|
|
+ .macro blx reg
|
|
+ mov lr, pc
|
|
+ bx \reg
|
|
+ .endm
|
|
+ .macro cbz reg, lbl
|
|
+ cmp \reg, #0
|
|
+ beq \lbl
|
|
+ .endm
|
|
+ .macro vpop regs
|
|
+ .endm
|
|
+ .macro vpush regs
|
|
+ .endm
|
|
+#endif
|
|
+
|
|
+trap_ptr .req r8
|
|
+alloc_ptr .req r10
|
|
+alloc_limit .req r11
|
|
+
|
|
+/* Support for profiling with gprof */
|
|
+
|
|
+#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi))
|
|
+#define PROFILE \
|
|
+ push {lr}; \
|
|
+ bl __gnu_mcount_nc
|
|
+#else
|
|
+#define PROFILE
|
|
+#endif
|
|
|
|
/* Allocation functions and GC interface */
|
|
|
|
- .globl caml_call_gc
|
|
+ .globl caml_system__code_begin
|
|
+caml_system__code_begin:
|
|
+
|
|
+ .align 2
|
|
+ .globl caml_call_gc
|
|
.type caml_call_gc, %function
|
|
caml_call_gc:
|
|
- /* Record return address and desired size */
|
|
- /* Can use alloc_limit as a temporary since it will be reloaded by
|
|
- invoke_gc */
|
|
- ldr alloc_limit, .Lcaml_last_return_address
|
|
- str lr, [alloc_limit, #0]
|
|
- ldr alloc_limit, .Lcaml_requested_size
|
|
- str r12, [alloc_limit, #0]
|
|
- /* Branch to shared GC code */
|
|
- bl .Linvoke_gc
|
|
- /* Finish allocation */
|
|
- ldr r12, .Lcaml_requested_size
|
|
- ldr r12, [r12, #0]
|
|
- sub alloc_ptr, alloc_ptr, r12
|
|
+ PROFILE
|
|
+ /* Record return address */
|
|
+ ldr r12, =caml_last_return_address
|
|
+ str lr, [r12]
|
|
+.Lcaml_call_gc:
|
|
+ /* Record lowest stack address */
|
|
+ ldr r12, =caml_bottom_of_stack
|
|
+ str sp, [r12]
|
|
+ /* Save caller floating-point registers on the stack */
|
|
+ vpush {d0-d7}
|
|
+ /* Save integer registers and return address on the stack */
|
|
+ push {r0-r7,r12,lr}
|
|
+ /* Store pointer to saved integer registers in caml_gc_regs */
|
|
+ ldr r12, =caml_gc_regs
|
|
+ str sp, [r12]
|
|
+ /* Save current allocation pointer for debugging purposes */
|
|
+ ldr alloc_limit, =caml_young_ptr
|
|
+ str alloc_ptr, [alloc_limit]
|
|
+ /* Save trap pointer in case an exception is raised during GC */
|
|
+ ldr r12, =caml_exception_pointer
|
|
+ str trap_ptr, [r12]
|
|
+ /* Call the garbage collector */
|
|
+ bl caml_garbage_collection
|
|
+ /* Restore integer registers and return address from the stack */
|
|
+ pop {r0-r7,r12,lr}
|
|
+ /* Restore floating-point registers from the stack */
|
|
+ vpop {d0-d7}
|
|
+ /* Reload new allocation pointer and limit */
|
|
+ /* alloc_limit still points to caml_young_ptr */
|
|
+ ldr r12, =caml_young_limit
|
|
+ ldr alloc_ptr, [alloc_limit]
|
|
+ ldr alloc_limit, [r12]
|
|
+ /* Return to caller */
|
|
bx lr
|
|
+ .type caml_call_gc, %function
|
|
+ .size caml_call_gc, .-caml_call_gc
|
|
|
|
- .globl caml_alloc1
|
|
+ .align 2
|
|
+ .globl caml_alloc1
|
|
.type caml_alloc1, %function
|
|
caml_alloc1:
|
|
- sub alloc_ptr, alloc_ptr, #8
|
|
+ PROFILE
|
|
+.Lcaml_alloc1:
|
|
+ sub alloc_ptr, alloc_ptr, 8
|
|
cmp alloc_ptr, alloc_limit
|
|
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
|
|
- /* Record return address */
|
|
- ldr r12, .Lcaml_last_return_address
|
|
- str lr, [r12, #0]
|
|
- /* Invoke GC */
|
|
- bl .Linvoke_gc
|
|
+ bcc 1f
|
|
+ bx lr
|
|
+1: /* Record return address */
|
|
+ ldr r7, =caml_last_return_address
|
|
+ str lr, [r7]
|
|
+ /* Call GC (preserves r7) */
|
|
+ bl .Lcaml_call_gc
|
|
+ /* Restore return address */
|
|
+ ldr lr, [r7]
|
|
/* Try again */
|
|
- b caml_alloc1
|
|
+ b .Lcaml_alloc1
|
|
+ .type caml_alloc1, %function
|
|
+ .size caml_alloc1, .-caml_alloc1
|
|
|
|
- .globl caml_alloc2
|
|
+ .align 2
|
|
+ .globl caml_alloc2
|
|
.type caml_alloc2, %function
|
|
caml_alloc2:
|
|
- sub alloc_ptr, alloc_ptr, #12
|
|
+ PROFILE
|
|
+.Lcaml_alloc2:
|
|
+ sub alloc_ptr, alloc_ptr, 12
|
|
cmp alloc_ptr, alloc_limit
|
|
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
|
|
- /* Record return address */
|
|
- ldr r12, .Lcaml_last_return_address
|
|
- str lr, [r12, #0]
|
|
- /* Invoke GC */
|
|
- bl .Linvoke_gc
|
|
+ bcc 1f
|
|
+ bx lr
|
|
+1: /* Record return address */
|
|
+ ldr r7, =caml_last_return_address
|
|
+ str lr, [r7]
|
|
+ /* Call GC (preserves r7) */
|
|
+ bl .Lcaml_call_gc
|
|
+ /* Restore return address */
|
|
+ ldr lr, [r7]
|
|
/* Try again */
|
|
- b caml_alloc2
|
|
+ b .Lcaml_alloc2
|
|
+ .type caml_alloc2, %function
|
|
+ .size caml_alloc2, .-caml_alloc2
|
|
|
|
- .globl caml_alloc3
|
|
+ .align 2
|
|
+ .globl caml_alloc3
|
|
.type caml_alloc3, %function
|
|
caml_alloc3:
|
|
- sub alloc_ptr, alloc_ptr, #16
|
|
+ PROFILE
|
|
+.Lcaml_alloc3:
|
|
+ sub alloc_ptr, alloc_ptr, 16
|
|
cmp alloc_ptr, alloc_limit
|
|
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
|
|
- /* Record return address */
|
|
- ldr r12, .Lcaml_last_return_address
|
|
- str lr, [r12, #0]
|
|
- /* Invoke GC */
|
|
- bl .Linvoke_gc
|
|
+ bcc 1f
|
|
+ bx lr
|
|
+1: /* Record return address */
|
|
+ ldr r7, =caml_last_return_address
|
|
+ str lr, [r7]
|
|
+ /* Call GC (preserves r7) */
|
|
+ bl .Lcaml_call_gc
|
|
+ /* Restore return address */
|
|
+ ldr lr, [r7]
|
|
/* Try again */
|
|
- b caml_alloc3
|
|
+ b .Lcaml_alloc3
|
|
+ .type caml_alloc3, %function
|
|
+ .size caml_alloc3, .-caml_alloc3
|
|
|
|
- .globl caml_allocN
|
|
+ .align 2
|
|
+ .globl caml_allocN
|
|
.type caml_allocN, %function
|
|
caml_allocN:
|
|
- sub alloc_ptr, alloc_ptr, r12
|
|
+ PROFILE
|
|
+.Lcaml_allocN:
|
|
+ sub alloc_ptr, alloc_ptr, r7
|
|
cmp alloc_ptr, alloc_limit
|
|
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
|
|
- /* Record return address and desired size */
|
|
- /* Can use alloc_limit as a temporary since it will be reloaded by
|
|
- invoke_gc */
|
|
- ldr alloc_limit, .Lcaml_last_return_address
|
|
- str lr, [alloc_limit, #0]
|
|
- ldr alloc_limit, .Lcaml_requested_size
|
|
- str r12, [alloc_limit, #0]
|
|
- /* Invoke GC */
|
|
- bl .Linvoke_gc
|
|
+ bcc 1f
|
|
+ bx lr
|
|
+1: /* Record return address */
|
|
+ ldr r12, =caml_last_return_address
|
|
+ str lr, [r12]
|
|
+ /* Call GC (preserves r7) */
|
|
+ bl .Lcaml_call_gc
|
|
+ /* Restore return address */
|
|
+ ldr r12, =caml_last_return_address
|
|
+ ldr lr, [r12]
|
|
/* Try again */
|
|
- ldr r12, .Lcaml_requested_size
|
|
- ldr r12, [r12, #0]
|
|
- b caml_allocN
|
|
-
|
|
-/* Shared code to invoke the GC */
|
|
-.Linvoke_gc:
|
|
- /* Record lowest stack address */
|
|
- ldr r12, .Lcaml_bottom_of_stack
|
|
- str sp, [r12, #0]
|
|
- /* Save integer registers and return address on stack */
|
|
- stmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12,lr}
|
|
- /* Store pointer to saved integer registers in caml_gc_regs */
|
|
- ldr r12, .Lcaml_gc_regs
|
|
- str sp, [r12, #0]
|
|
- /* Save current allocation pointer for debugging purposes */
|
|
- ldr r12, .Lcaml_young_ptr
|
|
- str alloc_ptr, [r12, #0]
|
|
- /* Save trap pointer in case an exception is raised during GC */
|
|
- ldr r12, .Lcaml_exception_pointer
|
|
- str trap_ptr, [r12, #0]
|
|
- /* Call the garbage collector */
|
|
- bl caml_garbage_collection
|
|
- /* Restore the registers from the stack */
|
|
- ldmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12}
|
|
- /* Reload return address */
|
|
- ldr r12, .Lcaml_last_return_address
|
|
- ldr lr, [r12, #0]
|
|
- /* Reload new allocation pointer and allocation limit */
|
|
- ldr r12, .Lcaml_young_ptr
|
|
- ldr alloc_ptr, [r12, #0]
|
|
- ldr r12, .Lcaml_young_limit
|
|
- ldr alloc_limit, [r12, #0]
|
|
- /* Return to caller */
|
|
- ldr r12, [sp], #4
|
|
- bx r12
|
|
+ b .Lcaml_allocN
|
|
+ .type caml_allocN, %function
|
|
+ .size caml_allocN, .-caml_allocN
|
|
|
|
-/* Call a C function from Caml */
|
|
-/* Function to call is in r12 */
|
|
+/* Call a C function from OCaml */
|
|
+/* Function to call is in r7 */
|
|
|
|
- .globl caml_c_call
|
|
+ .align 2
|
|
+ .globl caml_c_call
|
|
.type caml_c_call, %function
|
|
caml_c_call:
|
|
+ PROFILE
|
|
+ /* Record lowest stack address and return address */
|
|
+ ldr r5, =caml_last_return_address
|
|
+ ldr r6, =caml_bottom_of_stack
|
|
+ str lr, [r5]
|
|
+ str sp, [r6]
|
|
/* Preserve return address in callee-save register r4 */
|
|
mov r4, lr
|
|
- /* Record lowest stack address and return address */
|
|
- ldr r5, .Lcaml_last_return_address
|
|
- ldr r6, .Lcaml_bottom_of_stack
|
|
- str lr, [r5, #0]
|
|
- str sp, [r6, #0]
|
|
- /* Make the exception handler and alloc ptr available to the C code */
|
|
- ldr r6, .Lcaml_young_ptr
|
|
- ldr r7, .Lcaml_exception_pointer
|
|
- str alloc_ptr, [r6, #0]
|
|
- str trap_ptr, [r7, #0]
|
|
+ /* Make the exception handler alloc ptr available to the C code */
|
|
+ ldr r5, =caml_young_ptr
|
|
+ ldr r6, =caml_exception_pointer
|
|
+ str alloc_ptr, [r5]
|
|
+ str trap_ptr, [r6]
|
|
/* Call the function */
|
|
- mov lr, pc
|
|
- bx r12
|
|
+ blx r7
|
|
/* Reload alloc ptr and alloc limit */
|
|
- ldr r5, .Lcaml_young_limit
|
|
- ldr alloc_ptr, [r6, #0] /* r6 still points to caml_young_ptr */
|
|
- ldr alloc_limit, [r5, #0]
|
|
+ ldr r6, =caml_young_limit
|
|
+ ldr alloc_ptr, [r5] /* r5 still points to caml_young_ptr */
|
|
+ ldr alloc_limit, [r6]
|
|
/* Return */
|
|
bx r4
|
|
+ .type caml_c_call, %function
|
|
+ .size caml_c_call, .-caml_c_call
|
|
|
|
-/* Start the Caml program */
|
|
+/* Start the OCaml program */
|
|
|
|
- .globl caml_start_program
|
|
+ .align 2
|
|
+ .globl caml_start_program
|
|
.type caml_start_program, %function
|
|
caml_start_program:
|
|
- ldr r12, .Lcaml_program
|
|
+ PROFILE
|
|
+ ldr r12, =caml_program
|
|
|
|
/* Code shared with caml_callback* */
|
|
-/* Address of Caml code to call is in r12 */
|
|
-/* Arguments to the Caml code are in r0...r3 */
|
|
+/* Address of OCaml code to call is in r12 */
|
|
+/* Arguments to the OCaml code are in r0...r3 */
|
|
|
|
.Ljump_to_caml:
|
|
/* Save return address and callee-save registers */
|
|
- stmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr} /* 8-alignment */
|
|
+ vpush {d8-d15}
|
|
+ push {r4-r8,r10,r11,lr} /* 8-byte alignment */
|
|
/* Setup a callback link on the stack */
|
|
- sub sp, sp, #4*4 /* 8-alignment */
|
|
- ldr r4, .Lcaml_bottom_of_stack
|
|
- ldr r4, [r4, #0]
|
|
- str r4, [sp, #0]
|
|
- ldr r4, .Lcaml_last_return_address
|
|
- ldr r4, [r4, #0]
|
|
- str r4, [sp, #4]
|
|
- ldr r4, .Lcaml_gc_regs
|
|
- ldr r4, [r4, #0]
|
|
- str r4, [sp, #8]
|
|
- /* Setup a trap frame to catch exceptions escaping the Caml code */
|
|
- sub sp, sp, #4*2
|
|
- ldr r4, .Lcaml_exception_pointer
|
|
- ldr r4, [r4, #0]
|
|
- str r4, [sp, #0]
|
|
- ldr r4, .LLtrap_handler
|
|
- str r4, [sp, #4]
|
|
+ sub sp, sp, 4*4 /* 8-byte alignment */
|
|
+ ldr r4, =caml_bottom_of_stack
|
|
+ ldr r5, =caml_last_return_address
|
|
+ ldr r6, =caml_gc_regs
|
|
+ ldr r4, [r4]
|
|
+ ldr r5, [r5]
|
|
+ ldr r6, [r6]
|
|
+ str r4, [sp, 0]
|
|
+ str r5, [sp, 4]
|
|
+ str r6, [sp, 8]
|
|
+ /* Setup a trap frame to catch exceptions escaping the OCaml code */
|
|
+ sub sp, sp, 2*4
|
|
+ ldr r6, =caml_exception_pointer
|
|
+ ldr r5, =.Ltrap_handler
|
|
+ ldr r4, [r6]
|
|
+ str r4, [sp, 0]
|
|
+ str r5, [sp, 4]
|
|
mov trap_ptr, sp
|
|
/* Reload allocation pointers */
|
|
- ldr r4, .Lcaml_young_ptr
|
|
- ldr alloc_ptr, [r4, #0]
|
|
- ldr r4, .Lcaml_young_limit
|
|
- ldr alloc_limit, [r4, #0]
|
|
- /* Call the Caml code */
|
|
- mov lr, pc
|
|
- bx r12
|
|
+ ldr r4, =caml_young_ptr
|
|
+ ldr alloc_ptr, [r4]
|
|
+ ldr r4, =caml_young_limit
|
|
+ ldr alloc_limit, [r4]
|
|
+ /* Call the OCaml code */
|
|
+ blx r12
|
|
.Lcaml_retaddr:
|
|
/* Pop the trap frame, restoring caml_exception_pointer */
|
|
- ldr r4, .Lcaml_exception_pointer
|
|
- ldr r5, [sp, #0]
|
|
- str r5, [r4, #0]
|
|
- add sp, sp, #2 * 4
|
|
+ ldr r4, =caml_exception_pointer
|
|
+ ldr r5, [sp, 0]
|
|
+ str r5, [r4]
|
|
+ add sp, sp, 2*4
|
|
/* Pop the callback link, restoring the global variables */
|
|
.Lreturn_result:
|
|
- ldr r4, .Lcaml_bottom_of_stack
|
|
- ldr r5, [sp, #0]
|
|
- str r5, [r4, #0]
|
|
- ldr r4, .Lcaml_last_return_address
|
|
- ldr r5, [sp, #4]
|
|
- str r5, [r4, #0]
|
|
- ldr r4, .Lcaml_gc_regs
|
|
- ldr r5, [sp, #8]
|
|
- str r5, [r4, #0]
|
|
- add sp, sp, #4*4
|
|
+ ldr r4, =caml_bottom_of_stack
|
|
+ ldr r5, [sp, 0]
|
|
+ str r5, [r4]
|
|
+ ldr r4, =caml_last_return_address
|
|
+ ldr r5, [sp, 4]
|
|
+ str r5, [r4]
|
|
+ ldr r4, =caml_gc_regs
|
|
+ ldr r5, [sp, 8]
|
|
+ str r5, [r4]
|
|
+ add sp, sp, 4*4
|
|
/* Update allocation pointer */
|
|
- ldr r4, .Lcaml_young_ptr
|
|
- str alloc_ptr, [r4, #0]
|
|
+ ldr r4, =caml_young_ptr
|
|
+ str alloc_ptr, [r4]
|
|
/* Reload callee-save registers and return */
|
|
- ldmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr}
|
|
- bx lr
|
|
+ pop {r4-r8,r10,r11,lr}
|
|
+ vpop {d8-d15}
|
|
+ bx lr
|
|
+ .type .Lcaml_retaddr, %function
|
|
+ .size .Lcaml_retaddr, .-.Lcaml_retaddr
|
|
+ .type caml_start_program, %function
|
|
+ .size caml_start_program, .-caml_start_program
|
|
+
|
|
+/* The trap handler */
|
|
|
|
- /* The trap handler */
|
|
+ .align 2
|
|
.Ltrap_handler:
|
|
/* Save exception pointer */
|
|
- ldr r4, .Lcaml_exception_pointer
|
|
- str trap_ptr, [r4, #0]
|
|
+ ldr r12, =caml_exception_pointer
|
|
+ str trap_ptr, [r12]
|
|
/* Encode exception bucket as an exception result */
|
|
- orr r0, r0, #2
|
|
+ orr r0, r0, 2
|
|
/* Return it */
|
|
b .Lreturn_result
|
|
+ .type .Ltrap_handler, %function
|
|
+ .size .Ltrap_handler, .-.Ltrap_handler
|
|
+
|
|
+/* Raise an exception from OCaml */
|
|
+
|
|
+ .align 2
|
|
+ .globl caml_raise_exn
|
|
+caml_raise_exn:
|
|
+ PROFILE
|
|
+ /* Test if backtrace is active */
|
|
+ ldr r1, =caml_backtrace_active
|
|
+ ldr r1, [r1]
|
|
+ cbz r1, 1f
|
|
+ /* Preserve exception bucket in callee-save register r4 */
|
|
+ mov r4, r0
|
|
+ /* Stash the backtrace */
|
|
+ mov r1, lr /* arg2: pc of raise */
|
|
+ mov r2, sp /* arg3: sp of raise */
|
|
+ mov r3, trap_ptr /* arg4: sp of handler */
|
|
+ bl caml_stash_backtrace
|
|
+ /* Restore exception bucket */
|
|
+ mov r0, r4
|
|
+1: /* Cut stack at current trap handler */
|
|
+ mov sp, trap_ptr
|
|
+ /* Pop previous handler and addr of trap, and jump to it */
|
|
+ pop {trap_ptr, pc}
|
|
+ .type caml_raise_exn, %function
|
|
+ .size caml_raise_exn, .-caml_raise_exn
|
|
|
|
/* Raise an exception from C */
|
|
|
|
- .globl caml_raise_exception
|
|
+ .align 2
|
|
+ .globl caml_raise_exception
|
|
.type caml_raise_exception, %function
|
|
caml_raise_exception:
|
|
- /* Reload Caml allocation pointers */
|
|
- ldr r12, .Lcaml_young_ptr
|
|
- ldr alloc_ptr, [r12, #0]
|
|
- ldr r12, .Lcaml_young_limit
|
|
- ldr alloc_limit, [r12, #0]
|
|
- /* Cut stack at current trap handler */
|
|
- ldr r12, .Lcaml_exception_pointer
|
|
- ldr sp, [r12, #0]
|
|
+ PROFILE
|
|
+ /* Reload trap ptr, alloc ptr and alloc limit */
|
|
+ ldr trap_ptr, =caml_exception_pointer
|
|
+ ldr alloc_ptr, =caml_young_ptr
|
|
+ ldr alloc_limit, =caml_young_limit
|
|
+ ldr trap_ptr, [trap_ptr]
|
|
+ ldr alloc_ptr, [alloc_ptr]
|
|
+ ldr alloc_limit, [alloc_limit]
|
|
+ /* Test if backtrace is active */
|
|
+ ldr r1, =caml_backtrace_active
|
|
+ ldr r1, [r1]
|
|
+ cbz r1, 1f
|
|
+ /* Preserve exception bucket in callee-save register r4 */
|
|
+ mov r4, r0
|
|
+ ldr r1, =caml_last_return_address /* arg2: pc of raise */
|
|
+ ldr r1, [r1]
|
|
+ ldr r2, =caml_bottom_of_stack /* arg3: sp of raise */
|
|
+ ldr r2, [r2]
|
|
+ mov r3, trap_ptr /* arg4: sp of handler */
|
|
+ bl caml_stash_backtrace
|
|
+ /* Restore exception bucket */
|
|
+ mov r0, r4
|
|
+1: /* Cut stack at current trap handler */
|
|
+ mov sp, trap_ptr
|
|
/* Pop previous handler and addr of trap, and jump to it */
|
|
- ldmfd sp!, {trap_ptr, pc}
|
|
+ pop {trap_ptr, pc}
|
|
+ .type caml_raise_exception, %function
|
|
+ .size caml_raise_exception, .-caml_raise_exception
|
|
|
|
-/* Callback from C to Caml */
|
|
+/* Callback from C to OCaml */
|
|
|
|
- .globl caml_callback_exn
|
|
+ .align 2
|
|
+ .globl caml_callback_exn
|
|
.type caml_callback_exn, %function
|
|
caml_callback_exn:
|
|
+ PROFILE
|
|
/* Initial shuffling of arguments (r0 = closure, r1 = first arg) */
|
|
mov r12, r0
|
|
- mov r0, r1 /* r0 = first arg */
|
|
- mov r1, r12 /* r1 = closure environment */
|
|
- ldr r12, [r12, #0] /* code pointer */
|
|
+ mov r0, r1 /* r0 = first arg */
|
|
+ mov r1, r12 /* r1 = closure environment */
|
|
+ ldr r12, [r12] /* code pointer */
|
|
b .Ljump_to_caml
|
|
+ .type caml_callback_exn, %function
|
|
+ .size caml_callback_exn, .-caml_callback_exn
|
|
|
|
- .globl caml_callback2_exn
|
|
+ .align 2
|
|
+ .globl caml_callback2_exn
|
|
.type caml_callback2_exn, %function
|
|
caml_callback2_exn:
|
|
+ PROFILE
|
|
/* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */
|
|
mov r12, r0
|
|
- mov r0, r1 /* r0 = first arg */
|
|
- mov r1, r2 /* r1 = second arg */
|
|
- mov r2, r12 /* r2 = closure environment */
|
|
- ldr r12, .Lcaml_apply2
|
|
+ mov r0, r1 /* r0 = first arg */
|
|
+ mov r1, r2 /* r1 = second arg */
|
|
+ mov r2, r12 /* r2 = closure environment */
|
|
+ ldr r12, =caml_apply2
|
|
b .Ljump_to_caml
|
|
+ .type caml_callback2_exn, %function
|
|
+ .size caml_callback2_exn, .-caml_callback2_exn
|
|
|
|
- .globl caml_callback3_exn
|
|
+ .align 2
|
|
+ .globl caml_callback3_exn
|
|
.type caml_callback3_exn, %function
|
|
caml_callback3_exn:
|
|
+ PROFILE
|
|
/* Initial shuffling of arguments */
|
|
/* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */
|
|
mov r12, r0
|
|
@@ -288,43 +413,36 @@ caml_callback3_exn:
|
|
mov r1, r2 /* r1 = second arg */
|
|
mov r2, r3 /* r2 = third arg */
|
|
mov r3, r12 /* r3 = closure environment */
|
|
- ldr r12, .Lcaml_apply3
|
|
+ ldr r12, =caml_apply3
|
|
b .Ljump_to_caml
|
|
+ .type caml_callback3_exn, %function
|
|
+ .size caml_callback3_exn, .-caml_callback3_exn
|
|
|
|
- .globl caml_ml_array_bound_error
|
|
+ .align 2
|
|
+ .globl caml_ml_array_bound_error
|
|
.type caml_ml_array_bound_error, %function
|
|
caml_ml_array_bound_error:
|
|
- /* Load address of [caml_array_bound_error] in r12 */
|
|
- ldr r12, .Lcaml_array_bound_error
|
|
+ PROFILE
|
|
+ /* Load address of [caml_array_bound_error] in r7 */
|
|
+ ldr r7, =caml_array_bound_error
|
|
/* Call that function */
|
|
b caml_c_call
|
|
+ .type caml_ml_array_bound_error, %function
|
|
+ .size caml_ml_array_bound_error, .-caml_ml_array_bound_error
|
|
|
|
-/* Global references */
|
|
-
|
|
-.Lcaml_last_return_address: .word caml_last_return_address
|
|
-.Lcaml_bottom_of_stack: .word caml_bottom_of_stack
|
|
-.Lcaml_gc_regs: .word caml_gc_regs
|
|
-.Lcaml_young_ptr: .word caml_young_ptr
|
|
-.Lcaml_young_limit: .word caml_young_limit
|
|
-.Lcaml_exception_pointer: .word caml_exception_pointer
|
|
-.Lcaml_program: .word caml_program
|
|
-.LLtrap_handler: .word .Ltrap_handler
|
|
-.Lcaml_apply2: .word caml_apply2
|
|
-.Lcaml_apply3: .word caml_apply3
|
|
-.Lcaml_array_bound_error: .word caml_array_bound_error
|
|
-.Lcaml_requested_size: .word caml_requested_size
|
|
-
|
|
- .data
|
|
-caml_requested_size:
|
|
- .word 0
|
|
+ .globl caml_system__code_end
|
|
+caml_system__code_end:
|
|
|
|
/* GC roots for callback */
|
|
|
|
.data
|
|
- .globl caml_system__frametable
|
|
+ .align 2
|
|
+ .globl caml_system__frametable
|
|
caml_system__frametable:
|
|
.word 1 /* one descriptor */
|
|
.word .Lcaml_retaddr /* return address into callback */
|
|
.short -1 /* negative frame size => use callback link */
|
|
.short 0 /* no roots */
|
|
.align 2
|
|
+ .type caml_system__frametable, %object
|
|
+ .size caml_system__frametable, .-caml_system__frametable
|
|
diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
|
|
index 1e91327..732f3a0 100644
|
|
--- a/asmrun/signals_osdep.h
|
|
+++ b/asmrun/signals_osdep.h
|
|
@@ -78,7 +78,7 @@
|
|
|
|
/****************** ARM, Linux */
|
|
|
|
-#elif defined(TARGET_arm) && defined (SYS_linux)
|
|
+#elif defined(TARGET_arm) && (defined (SYS_linux_eabi) || defined(SYS_linux_eabihf))
|
|
|
|
#include <sys/ucontext.h>
|
|
|
|
diff --git a/configure b/configure
|
|
index 6ed0a9c..4e07c92 100755
|
|
--- a/configure
|
|
+++ b/configure
|
|
@@ -636,6 +636,7 @@ if test $withsharedlibs = "yes"; then
|
|
i[345]86-*-netbsd*) natdynlink=true;;
|
|
x86_64-*-netbsd*) natdynlink=true;;
|
|
i386-*-gnu0.3) natdynlink=true;;
|
|
+ arm*-*-linux*) natdynlink=true;;
|
|
esac
|
|
fi
|
|
|
|
@@ -691,8 +692,13 @@ case "$host" in
|
|
powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;;
|
|
powerpc-*-darwin*) arch=power; system=rhapsody
|
|
if $arch64; then model=ppc64; else model=ppc; fi;;
|
|
- arm*-*-linux*) arch=arm; system=linux;;
|
|
- arm*-*-gnu*) arch=arm; system=gnu;;
|
|
+ arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;;
|
|
+ armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;;
|
|
+ armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;;
|
|
+ armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;;
|
|
+ armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;;
|
|
+ armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;;
|
|
+ arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;;
|
|
ia64-*-linux*) arch=ia64; system=linux;;
|
|
ia64-*-gnu*) arch=ia64; system=gnu;;
|
|
ia64-*-freebsd*) arch=ia64; system=freebsd;;
|
|
@@ -804,6 +810,7 @@ case "$arch,$model,$system" in
|
|
case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
|
|
amd64,*,linux) profiling='prof';;
|
|
amd64,*,gnu) profiling='prof';;
|
|
+ arm,*,linux*) profiling='prof';;
|
|
*) profiling='noprof';;
|
|
esac
|
|
|
|
--
|
|
1.7.10.1
|
|
|