l4/pkg/ocaml/contrib/asmcomp/emitaux.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: emitaux.ml 9314 2009-07-15 12:14:39Z xleroy $ *)
  14
  15 (* Common functions for emitting assembly code *)
  16
  17 open Debuginfo
  18 open Cmm
  19 open Reg
  20 open Linearize
  21
  22 let output_channel = ref stdout
  23
  24 let emit_string s = output_string !output_channel s
  25
  26 let emit_int n = output_string !output_channel (string_of_int n)
  27
  28 let emit_char c = output_char !output_channel c
  29
  30 let emit_nativeint n = output_string !output_channel (Nativeint.to_string n)
  31
  32 let emit_printf fmt =
  33   Printf.fprintf !output_channel fmt
  34
  35 let emit_int32 n = emit_printf "0x%lx" n
  36
  37 let emit_symbol esc s =
  38   for i = 0 to String.length s - 1 do
  39     let c = s.[i] in
  40     match c with
  41       'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
  42         output_char !output_channel c
  43     | _ ->
  44         Printf.fprintf !output_channel "%c%02x" esc (Char.code c)
  45   done
  46
  47 let emit_string_literal s =
  48   let last_was_escape = ref false in
  49   emit_string "\"";
  50   for i = 0 to String.length s - 1 do
  51     let c = s.[i] in
  52     if c >= '0' && c <= '9' then
  53       if !last_was_escape
  54       then Printf.fprintf !output_channel "\\%o" (Char.code c)
  55       else output_char !output_channel c
  56     else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin
  57       output_char !output_channel c;
  58       last_was_escape := false
  59     end else begin
  60       Printf.fprintf !output_channel "\\%o" (Char.code c);
  61       last_was_escape := true
  62     end
  63   done;
  64   emit_string "\""
  65
  66 let emit_string_directive directive s =
  67   let l = String.length s in
  68   if l = 0 then ()
  69   else if l < 80 then begin
  70     emit_string directive;
  71     emit_string_literal s;
  72     emit_char '\n'
  73   end else begin
  74     let i = ref 0 in
  75     while !i < l do
  76       let n = min (l - !i) 80 in
  77       emit_string directive;
  78       emit_string_literal (String.sub s !i n);
  79       emit_char '\n';
  80       i := !i + n
  81     done
  82   end
  83
  84 let emit_bytes_directive directive s =
  85    let pos = ref 0 in
  86    for i = 0 to String.length s - 1 do
  87      if !pos = 0
  88      then emit_string directive
  89      else emit_char ',';
  90      emit_int(Char.code s.[i]);
  91      incr pos;
  92      if !pos >= 16 then begin emit_char '\n'; pos := 0 end
  93    done;
  94    if !pos > 0 then emit_char '\n'
  95
  96 (* PR#4813: assemblers do strange things with float literals indeed,
  97    so we convert to IEEE representation ourselves and emit float
  98    literals as 32- or 64-bit integers. *)
  99
 100 let emit_float64_directive directive f =
 101   let x = Int64.bits_of_float (float_of_string f) in
 102   emit_printf "\t%s\t0x%Lx\n" directive x
 103
 104 let emit_float64_split_directive directive f =
 105   let x = Int64.bits_of_float (float_of_string f) in
 106   let lo = Int64.logand x 0xFFFF_FFFFL
 107   and hi = Int64.shift_right_logical x 32 in
 108   emit_printf "\t%s\t0x%Lx, 0x%Lx\n"
 109     directive
 110     (if Arch.big_endian then hi else lo)
 111     (if Arch.big_endian then lo else hi)
 112
 113 let emit_float32_directive directive f =
 114   let x = Int32.bits_of_float (float_of_string f) in
 115   emit_printf "\t%s\t0x%lx\n" directive x
 116
 117 (* Record live pointers at call points *)
 118
 119 type frame_descr =
 120   { fd_lbl: int;                        (* Return address *)
 121     fd_frame_size: int;                 (* Size of stack frame *)
 122     fd_live_offset: int list;           (* Offsets/regs of live addresses *)
 123     fd_debuginfo: Debuginfo.t }         (* Location, if any *)
 124
 125 let frame_descriptors = ref([] : frame_descr list)
 126
 127 type emit_frame_actions =
 128   { efa_label: int -> unit;
 129     efa_16: int -> unit;
 130     efa_32: int32 -> unit;
 131     efa_word: int -> unit;
 132     efa_align: int -> unit;
 133     efa_label_rel: int -> int32 -> unit;
 134     efa_def_label: int -> unit;
 135     efa_string: string -> unit }
 136
 137 let emit_frames a =
 138   let filenames = Hashtbl.create 7 in
 139   let lbl_filenames = ref 200000 in
 140   let label_filename name =
 141     try
 142       Hashtbl.find filenames name
 143     with Not_found ->
 144       let lbl = !lbl_filenames in
 145       Hashtbl.add filenames name lbl;
 146       incr lbl_filenames;
 147       lbl in
 148   let emit_frame fd =
 149     a.efa_label fd.fd_lbl;
 150     a.efa_16 (if fd.fd_debuginfo == Debuginfo.none
 151               then fd.fd_frame_size
 152               else fd.fd_frame_size + 1);
 153     a.efa_16 (List.length fd.fd_live_offset);
 154     List.iter a.efa_16 fd.fd_live_offset;
 155     a.efa_align Arch.size_addr;
 156     if fd.fd_debuginfo != Debuginfo.none then begin
 157       let d = fd.fd_debuginfo in
 158       let line = min 0xFFFFF d.dinfo_line
 159       and char_start = min 0xFF d.dinfo_char_start
 160       and char_end = min 0x3FF d.dinfo_char_end
 161       and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in
 162       let info =
 163         Int64.add (Int64.shift_left (Int64.of_int line) 44) (
 164         Int64.add (Int64.shift_left (Int64.of_int char_start) 36) (
 165         Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
 166                   (Int64.of_int kind))) in
 167       a.efa_label_rel
 168         (label_filename d.dinfo_file)
 169         (Int64.to_int32 info);
 170       a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
 171     end in
 172   let emit_filename name lbl =
 173     a.efa_def_label lbl;
 174     a.efa_string name;
 175     a.efa_align Arch.size_addr in
 176   a.efa_word (List.length !frame_descriptors);
 177   List.iter emit_frame !frame_descriptors;
 178   Hashtbl.iter emit_filename filenames;
 179   frame_descriptors := []
 180
 181 (* Detection of functions that can be duplicated between a DLL and
 182    the main program (PR#4690) *)
 183
 184 let isprefix s1 s2 =
 185   String.length s1 <= String.length s2
 186   && String.sub s2 0 (String.length s1) = s1
 187
 188 let is_generic_function name =
 189   List.exists
 190     (fun p -> isprefix p name)
 191     ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
 192