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$ *)
  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 (* Record live pointers at call points *)
  97
  98 type frame_descr =
  99   { fd_lbl: int;                        (* Return address *)
 100     fd_frame_size: int;                 (* Size of stack frame *)
 101     fd_live_offset: int list;           (* Offsets/regs of live addresses *)
 102     fd_debuginfo: Debuginfo.t }         (* Location, if any *)
 103
 104 let frame_descriptors = ref([] : frame_descr list)
 105
 106 type emit_frame_actions =
 107   { efa_label: int -> unit;
 108     efa_16: int -> unit;
 109     efa_32: int32 -> unit;
 110     efa_word: int -> unit;
 111     efa_align: int -> unit;
 112     efa_label_rel: int -> int32 -> unit;
 113     efa_def_label: int -> unit;
 114     efa_string: string -> unit }
 115
 116 let emit_frames a =
 117   let filenames = Hashtbl.create 7 in
 118   let lbl_filenames = ref 200000 in
 119   let label_filename name =
 120     try
 121       Hashtbl.find filenames name
 122     with Not_found ->
 123       let lbl = !lbl_filenames in
 124       Hashtbl.add filenames name lbl;
 125       incr lbl_filenames;
 126       lbl in
 127   let emit_frame fd =
 128     a.efa_label fd.fd_lbl;
 129     a.efa_16 (if fd.fd_debuginfo == Debuginfo.none
 130               then fd.fd_frame_size
 131               else fd.fd_frame_size + 1);
 132     a.efa_16 (List.length fd.fd_live_offset);
 133     List.iter a.efa_16 fd.fd_live_offset;
 134     a.efa_align Arch.size_addr;
 135     if fd.fd_debuginfo != Debuginfo.none then begin
 136       let d = fd.fd_debuginfo in
 137       let line = min 0xFFFFF d.dinfo_line
 138       and char_start = min 0xFF d.dinfo_char_start
 139       and char_end = min 0x3FF d.dinfo_char_end
 140       and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in
 141       let info =
 142         Int64.add (Int64.shift_left (Int64.of_int line) 44) (
 143         Int64.add (Int64.shift_left (Int64.of_int char_start) 36) (
 144         Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
 145                   (Int64.of_int kind))) in
 146       a.efa_label_rel
 147         (label_filename d.dinfo_file)
 148         (Int64.to_int32 info);
 149       a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
 150     end in
 151   let emit_filename name lbl =
 152     a.efa_def_label lbl;
 153     a.efa_string name;
 154     a.efa_align Arch.size_addr in
 155   a.efa_word (List.length !frame_descriptors);
 156   List.iter emit_frame !frame_descriptors;
 157   Hashtbl.iter emit_filename filenames;
 158   frame_descriptors := []