l4/pkg/ocaml/ocaml/contrib/bytecomp/emitcode.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: emitcode.ml 8930 2008-07-24 05:35:22Z frisch $ *)
  14
  15 (* Generation of bytecode + relocation information *)
  16
  17 open Config
  18 open Misc
  19 open Asttypes
  20 open Lambda
  21 open Instruct
  22 open Opcodes
  23 open Cmo_format
  24
  25 (* Buffering of bytecode *)
  26
  27 let out_buffer = ref(String.create 1024)
  28 and out_position = ref 0
  29
  30 let out_word b1 b2 b3 b4 =
  31   let p = !out_position in
  32   if p >= String.length !out_buffer then begin
  33     let len = String.length !out_buffer in
  34     let new_buffer = String.create (2 * len) in
  35     String.blit !out_buffer 0 new_buffer 0 len;
  36     out_buffer := new_buffer
  37   end;
  38   String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
  39   String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
  40   String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
  41   String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
  42   out_position := p + 4
  43
  44 let out opcode =
  45   out_word opcode 0 0 0
  46
  47
  48 exception AsInt
  49
  50 let const_as_int = function
  51   | Const_base(Const_int i) -> i
  52   | Const_base(Const_char c) -> Char.code c
  53   | Const_pointer i -> i
  54   | _ -> raise AsInt
  55
  56 let is_immed i = immed_min <= i && i <= immed_max
  57 let is_immed_const k =
  58   try
  59     is_immed (const_as_int k)
  60   with
  61   | AsInt -> false
  62
  63
  64 let out_int n =
  65   out_word n (n asr 8) (n asr 16) (n asr 24)
  66
  67 let out_const c =
  68   try
  69     out_int (const_as_int c)
  70   with
  71   | AsInt -> Misc.fatal_error "Emitcode.const_as_int"
  72
  73
  74 (* Handling of local labels and backpatching *)
  75
  76 type label_definition =
  77     Label_defined of int
  78   | Label_undefined of (int * int) list
  79
  80 let label_table  = ref ([| |] : label_definition array)
  81
  82 let extend_label_table needed =
  83   let new_size = ref(Array.length !label_table) in
  84   while needed >= !new_size do new_size := 2 * !new_size done;
  85   let new_table = Array.create !new_size (Label_undefined []) in
  86   Array.blit !label_table 0 new_table 0 (Array.length !label_table);
  87   label_table := new_table
  88
  89 let backpatch (pos, orig) =
  90   let displ = (!out_position - orig) asr 2 in
  91   !out_buffer.[pos] <- Char.unsafe_chr displ;
  92   !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
  93   !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
  94   !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
  95
  96 let define_label lbl =
  97   if lbl >= Array.length !label_table then extend_label_table lbl;
  98   match (!label_table).(lbl) with
  99     Label_defined _ ->
 100       fatal_error "Emitcode.define_label"
 101   | Label_undefined patchlist ->
 102       List.iter backpatch patchlist;
 103       (!label_table).(lbl) <- Label_defined !out_position
 104
 105 let out_label_with_orig orig lbl =
 106   if lbl >= Array.length !label_table then extend_label_table lbl;
 107   match (!label_table).(lbl) with
 108     Label_defined def ->
 109       out_int((def - orig) asr 2)
 110   | Label_undefined patchlist ->
 111       (!label_table).(lbl) <-
 112          Label_undefined((!out_position, orig) :: patchlist);
 113       out_int 0
 114
 115 let out_label l = out_label_with_orig !out_position l
 116
 117 (* Relocation information *)
 118
 119 let reloc_info = ref ([] : (reloc_info * int) list)
 120
 121 let enter info =
 122   reloc_info := (info, !out_position) :: !reloc_info
 123
 124 let slot_for_literal sc =
 125   enter (Reloc_literal sc);
 126   out_int 0
 127 and slot_for_getglobal id =
 128   enter (Reloc_getglobal id);
 129   out_int 0
 130 and slot_for_setglobal id =
 131   enter (Reloc_setglobal id);
 132   out_int 0
 133 and slot_for_c_prim name =
 134   enter (Reloc_primitive name);
 135   out_int 0
 136
 137 (* Debugging events *)
 138
 139 let events = ref ([] : debug_event list)
 140
 141 let record_event ev =
 142   ev.ev_pos <- !out_position;
 143   events := ev :: !events
 144
 145 (* Initialization *)
 146
 147 let init () =
 148   out_position := 0;
 149   label_table := Array.create 16 (Label_undefined []);
 150   reloc_info := [];
 151   events := []
 152
 153 (* Emission of one instruction *)
 154
 155 let emit_comp = function
 156 | Ceq -> out opEQ    | Cneq -> out opNEQ
 157 | Clt -> out opLTINT | Cle -> out opLEINT
 158 | Cgt -> out opGTINT | Cge -> out opGEINT
 159
 160 and emit_branch_comp = function
 161 | Ceq -> out opBEQ    | Cneq -> out opBNEQ
 162 | Clt -> out opBLTINT | Cle -> out opBLEINT
 163 | Cgt -> out opBGTINT | Cge -> out opBGEINT
 164
 165 let emit_instr = function
 166     Klabel lbl -> define_label lbl
 167   | Kacc n ->
 168       if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
 169   | Kenvacc n ->
 170       if n >= 1 && n <= 4
 171       then out(opENVACC1 + n - 1)
 172       else (out opENVACC; out_int n)
 173   | Kpush ->
 174       out opPUSH
 175   | Kpop n ->
 176       out opPOP; out_int n
 177   | Kassign n ->
 178       out opASSIGN; out_int n
 179   | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl
 180   | Kapply n ->
 181       if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
 182   | Kappterm(n, sz) ->
 183       if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
 184                else (out opAPPTERM; out_int n; out_int sz)
 185   | Kreturn n -> out opRETURN; out_int n
 186   | Krestart -> out opRESTART
 187   | Kgrab n -> out opGRAB; out_int n
 188   | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl
 189   | Kclosurerec(lbls, n) ->
 190       out opCLOSUREREC; out_int (List.length lbls); out_int n;
 191       let org = !out_position in
 192       List.iter (out_label_with_orig org) lbls
 193   | Koffsetclosure ofs ->
 194       if ofs = -2 || ofs = 0 || ofs = 2
 195       then out (opOFFSETCLOSURE0 + ofs / 2)
 196       else (out opOFFSETCLOSURE; out_int ofs)
 197   | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q
 198   | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
 199   | Kconst sc ->
 200       begin match sc with
 201         Const_base(Const_int i) when is_immed i ->
 202           if i >= 0 && i <= 3
 203           then out (opCONST0 + i)
 204           else (out opCONSTINT; out_int i)
 205       | Const_base(Const_char c) ->
 206           out opCONSTINT; out_int (Char.code c)
 207       | Const_pointer i ->
 208           if i >= 0 && i <= 3
 209           then out (opCONST0 + i)
 210           else (out opCONSTINT; out_int i)
 211       | Const_block(t, []) ->
 212           if t = 0 then out opATOM0 else (out opATOM; out_int t)
 213       | _ ->
 214           out opGETGLOBAL; slot_for_literal sc
 215       end
 216   | Kmakeblock(n, t) ->
 217       if n = 0 then
 218         if t = 0 then out opATOM0 else (out opATOM; out_int t)
 219       else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
 220       else (out opMAKEBLOCK; out_int n; out_int t)
 221   | Kgetfield n ->
 222       if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
 223   | Ksetfield n ->
 224       if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
 225   | Kmakefloatblock(n) ->
 226       if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n)
 227   | Kgetfloatfield n -> out opGETFLOATFIELD; out_int n
 228   | Ksetfloatfield n -> out opSETFLOATFIELD; out_int n
 229   | Kvectlength -> out opVECTLENGTH
 230   | Kgetvectitem -> out opGETVECTITEM
 231   | Ksetvectitem -> out opSETVECTITEM
 232   | Kgetstringchar -> out opGETSTRINGCHAR
 233   | Ksetstringchar -> out opSETSTRINGCHAR
 234   | Kbranch lbl -> out opBRANCH; out_label lbl
 235   | Kbranchif lbl -> out opBRANCHIF; out_label lbl
 236   | Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
 237   | Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl
 238   | Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
 239   | Kswitch(tbl_const, tbl_block) ->
 240       out opSWITCH;
 241       out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
 242       let org = !out_position in
 243       Array.iter (out_label_with_orig org) tbl_const;
 244       Array.iter (out_label_with_orig org) tbl_block
 245   | Kboolnot -> out opBOOLNOT
 246   | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
 247   | Kpoptrap -> out opPOPTRAP
 248   | Kraise -> out opRAISE
 249   | Kcheck_signals -> out opCHECK_SIGNALS
 250   | Kccall(name, n) ->
 251       if n <= 5
 252       then (out (opC_CALL1 + n - 1); slot_for_c_prim name)
 253       else (out opC_CALLN; out_int n; slot_for_c_prim name)
 254   | Knegint -> out opNEGINT  | Kaddint -> out opADDINT
 255   | Ksubint -> out opSUBINT  | Kmulint -> out opMULINT
 256   | Kdivint -> out opDIVINT  | Kmodint -> out opMODINT
 257   | Kandint -> out opANDINT  | Korint -> out opORINT
 258   | Kxorint -> out opXORINT  | Klslint -> out opLSLINT
 259   | Klsrint -> out opLSRINT  | Kasrint -> out opASRINT
 260   | Kintcomp c -> emit_comp c
 261   | Koffsetint n -> out opOFFSETINT; out_int n
 262   | Koffsetref n -> out opOFFSETREF; out_int n
 263   | Kisint -> out opISINT
 264   | Kisout -> out opULTINT
 265   | Kgetmethod -> out opGETMETHOD
 266   | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
 267   | Kgetdynmet -> out opGETDYNMET
 268   | Kevent ev -> record_event ev
 269   | Kstop -> out opSTOP
 270
 271 (* Emission of a list of instructions. Include some peephole optimization. *)
 272
 273 let rec emit = function
 274     [] -> ()
 275   (* Peephole optimizations *)
 276 (* optimization of integer tests *)
 277   | Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem
 278       when is_immed_const k ->
 279         emit_branch_comp c ;
 280         out_const k ;
 281         out_label lbl ;
 282         emit rem
 283   | Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem
 284       when is_immed_const k ->
 285         emit_branch_comp (negate_comparison c) ;
 286         out_const k ;
 287         out_label lbl ;
 288         emit rem
 289 (* same for range tests *)
 290   | Kpush::Kconst k::Kisout::Kbranchif lbl::rem
 291       when is_immed_const k ->
 292         out opBULTINT ;
 293         out_const k ;
 294         out_label lbl ;
 295         emit rem
 296   | Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem
 297       when is_immed_const k ->
 298         out opBUGEINT ;
 299         out_const k ;
 300         out_label lbl ;
 301         emit rem
 302 (* Some special case of push ; i ; ret generated by the match compiler *)
 303   | Kpush :: Kacc 0 :: Kreturn m :: c ->
 304       emit (Kreturn (m-1) :: c)
 305 (* General push then access scheme *)
 306   | Kpush :: Kacc n :: c ->
 307       if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
 308       emit c
 309   | Kpush :: Kenvacc n :: c ->
 310       if n >= 1 && n < 4
 311       then out(opPUSHENVACC1 + n - 1)
 312       else (out opPUSHENVACC; out_int n);
 313       emit c
 314   | Kpush :: Koffsetclosure ofs :: c ->
 315       if ofs = -2 || ofs = 0 || ofs = 2
 316       then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
 317       else (out opPUSHOFFSETCLOSURE; out_int ofs);
 318       emit c
 319   | Kpush :: Kgetglobal id :: Kgetfield n :: c ->
 320       out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
 321   | Kpush :: Kgetglobal id :: c ->
 322       out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
 323   | Kpush :: Kconst sc :: c ->
 324       begin match sc with
 325         Const_base(Const_int i) when is_immed i ->
 326           if i >= 0 && i <= 3
 327           then out (opPUSHCONST0 + i)
 328           else (out opPUSHCONSTINT; out_int i)
 329       | Const_base(Const_char c) ->
 330           out opPUSHCONSTINT; out_int(Char.code c)
 331       | Const_pointer i ->
 332           if i >= 0 && i <= 3
 333           then out (opPUSHCONST0 + i)
 334           else (out opPUSHCONSTINT; out_int i)
 335       | Const_block(t, []) ->
 336           if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
 337       | _ ->
 338           out opPUSHGETGLOBAL; slot_for_literal sc
 339       end;
 340       emit c
 341   | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
 342     (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
 343       emit (Kpush :: instr1 :: instr2 :: ev :: c)
 344   | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
 345     (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
 346       emit (Kpush :: instr :: ev :: c)
 347   | Kgetglobal id :: Kgetfield n :: c ->
 348       out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
 349   (* Default case *)
 350   | instr :: c ->
 351       emit_instr instr; emit c
 352
 353 (* Emission to a file *)
 354
 355 let to_file outchan unit_name code =
 356   init();
 357   output_string outchan cmo_magic_number;
 358   let pos_depl = pos_out outchan in
 359   output_binary_int outchan 0;
 360   let pos_code = pos_out outchan in
 361   emit code;
 362   output outchan !out_buffer 0 !out_position;
 363   let (pos_debug, size_debug) =
 364     if !Clflags.debug then begin
 365       let p = pos_out outchan in
 366       output_value outchan !events;
 367       (p, pos_out outchan - p)
 368     end else
 369       (0, 0) in
 370   let compunit =
 371     { cu_name = unit_name;
 372       cu_pos = pos_code;
 373       cu_codesize = !out_position;
 374       cu_reloc = List.rev !reloc_info;
 375       cu_imports = Env.imported_units();
 376       cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations;
 377       cu_force_link = false;
 378       cu_debug = pos_debug;
 379       cu_debugsize = size_debug } in
 380   init();                               (* Free out_buffer and reloc_info *)
 381   Btype.cleanup_abbrev ();              (* Remove any cached abbreviation
 382                                            expansion before saving *)
 383   let pos_compunit = pos_out outchan in
 384   output_value outchan compunit;
 385   seek_out outchan pos_depl;
 386   output_binary_int outchan pos_compunit
 387
 388 (* Emission to a memory block *)
 389
 390 let to_memory init_code fun_code =
 391   init();
 392   emit init_code;
 393   emit fun_code;
 394   let code = Meta.static_alloc !out_position in
 395   String.unsafe_blit !out_buffer 0 code 0 !out_position;
 396   let reloc = List.rev !reloc_info
 397   and code_size = !out_position in
 398   init();
 399   (code, code_size, reloc)
 400
 401 (* Emission to a file for a packed library *)
 402
 403 let to_packed_file outchan code =
 404   init();
 405   emit code;
 406   output outchan !out_buffer 0 !out_position;
 407   let reloc = !reloc_info in
 408   init();
 409   reloc