438 lines
15 KiB
OCaml
438 lines
15 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* Generation of bytecode + relocation information *)
|
|
|
|
open Config
|
|
open Misc
|
|
open Asttypes
|
|
open Lambda
|
|
open Instruct
|
|
open Opcodes
|
|
|
|
|
|
(* Relocation information *)
|
|
|
|
type reloc_info =
|
|
Reloc_literal of structured_constant (* structured constant *)
|
|
| Reloc_getglobal of Ident.t (* reference to a global *)
|
|
| Reloc_setglobal of Ident.t (* definition of a global *)
|
|
| Reloc_primitive of string (* C primitive number *)
|
|
|
|
(* Descriptor for compilation units *)
|
|
|
|
type compilation_unit =
|
|
{ cu_name: string; (* Name of compilation unit *)
|
|
mutable cu_pos: int; (* Absolute position in file *)
|
|
cu_codesize: int; (* Size of code block *)
|
|
cu_reloc: (reloc_info * int) list; (* Relocation information *)
|
|
cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
|
|
cu_primitives: string list; (* Primitives declared inside *)
|
|
mutable cu_force_link: bool; (* Must be linked even if unref'ed *)
|
|
mutable cu_debug: int; (* Position of debugging info, or 0 *)
|
|
cu_debugsize: int } (* Length of debugging info *)
|
|
|
|
(* Descriptor for libraries *)
|
|
|
|
type library =
|
|
{ lib_units: compilation_unit list; (* List of compilation units *)
|
|
lib_custom: bool; (* Requires custom mode linking? *)
|
|
lib_ccobjs: string list; (* C object files needed for -custom *)
|
|
lib_ccopts: string list; (* Extra opts to C compiler *)
|
|
lib_dllibs: string list } (* DLLs needed *)
|
|
|
|
(* Buffering of bytecode *)
|
|
|
|
let out_buffer = ref(String.create 1024)
|
|
and out_position = ref 0
|
|
|
|
let out_word b1 b2 b3 b4 =
|
|
let p = !out_position in
|
|
if p >= String.length !out_buffer then begin
|
|
let len = String.length !out_buffer in
|
|
let new_buffer = String.create (2 * len) in
|
|
String.blit !out_buffer 0 new_buffer 0 len;
|
|
out_buffer := new_buffer
|
|
end;
|
|
String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
|
|
String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
|
|
String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
|
|
String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
|
|
out_position := p + 4
|
|
|
|
let out opcode =
|
|
out_word opcode 0 0 0
|
|
|
|
|
|
exception AsInt
|
|
|
|
let const_as_int = function
|
|
| Const_base(Const_int i) -> i
|
|
| Const_base(Const_char c) -> Char.code c
|
|
| Const_pointer i -> i
|
|
| _ -> raise AsInt
|
|
|
|
let is_immed i = immed_min <= i && i <= immed_max
|
|
let is_immed_const k =
|
|
try
|
|
is_immed (const_as_int k)
|
|
with
|
|
| AsInt -> false
|
|
|
|
|
|
let out_int n =
|
|
out_word n (n asr 8) (n asr 16) (n asr 24)
|
|
|
|
let out_const c =
|
|
try
|
|
out_int (const_as_int c)
|
|
with
|
|
| AsInt -> Misc.fatal_error "Emitcode.const_as_int"
|
|
|
|
|
|
(* Handling of local labels and backpatching *)
|
|
|
|
type label_definition =
|
|
Label_defined of int
|
|
| Label_undefined of (int * int) list
|
|
|
|
let label_table = ref ([| |] : label_definition array)
|
|
|
|
let extend_label_table needed =
|
|
let new_size = ref(Array.length !label_table) in
|
|
while needed >= !new_size do new_size := 2 * !new_size done;
|
|
let new_table = Array.create !new_size (Label_undefined []) in
|
|
Array.blit !label_table 0 new_table 0 (Array.length !label_table);
|
|
label_table := new_table
|
|
|
|
let backpatch (pos, orig) =
|
|
let displ = (!out_position - orig) asr 2 in
|
|
!out_buffer.[pos] <- Char.unsafe_chr displ;
|
|
!out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
|
|
!out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
|
|
!out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
|
|
|
|
let define_label lbl =
|
|
if lbl >= Array.length !label_table then extend_label_table lbl;
|
|
match (!label_table).(lbl) with
|
|
Label_defined _ ->
|
|
fatal_error "Emitcode.define_label"
|
|
| Label_undefined patchlist ->
|
|
List.iter backpatch patchlist;
|
|
(!label_table).(lbl) <- Label_defined !out_position
|
|
|
|
let out_label_with_orig orig lbl =
|
|
if lbl >= Array.length !label_table then extend_label_table lbl;
|
|
match (!label_table).(lbl) with
|
|
Label_defined def ->
|
|
out_int((def - orig) asr 2)
|
|
| Label_undefined patchlist ->
|
|
(!label_table).(lbl) <-
|
|
Label_undefined((!out_position, orig) :: patchlist);
|
|
out_int 0
|
|
|
|
let out_label l = out_label_with_orig !out_position l
|
|
|
|
(* Relocation information *)
|
|
|
|
let reloc_info = ref ([] : (reloc_info * int) list)
|
|
|
|
let enter info =
|
|
reloc_info := (info, !out_position) :: !reloc_info
|
|
|
|
let slot_for_literal sc =
|
|
enter (Reloc_literal sc);
|
|
out_int 0
|
|
and slot_for_getglobal id =
|
|
enter (Reloc_getglobal id);
|
|
out_int 0
|
|
and slot_for_setglobal id =
|
|
enter (Reloc_setglobal id);
|
|
out_int 0
|
|
and slot_for_c_prim name =
|
|
enter (Reloc_primitive name);
|
|
out_int 0
|
|
|
|
(* Debugging events *)
|
|
|
|
let events = ref ([] : debug_event list)
|
|
|
|
let record_event ev =
|
|
ev.ev_pos <- !out_position;
|
|
events := ev :: !events
|
|
|
|
(* Initialization *)
|
|
|
|
let init () =
|
|
out_position := 0;
|
|
label_table := Array.create 16 (Label_undefined []);
|
|
reloc_info := [];
|
|
events := []
|
|
|
|
(* Emission of one instruction *)
|
|
|
|
let emit_comp = function
|
|
| Ceq -> out opEQ | Cneq -> out opNEQ
|
|
| Clt -> out opLTINT | Cle -> out opLEINT
|
|
| Cgt -> out opGTINT | Cge -> out opGEINT
|
|
|
|
and emit_branch_comp = function
|
|
| Ceq -> out opBEQ | Cneq -> out opBNEQ
|
|
| Clt -> out opBLTINT | Cle -> out opBLEINT
|
|
| Cgt -> out opBGTINT | Cge -> out opBGEINT
|
|
|
|
let emit_instr = function
|
|
Klabel lbl -> define_label lbl
|
|
| Kacc n ->
|
|
if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
|
|
| Kenvacc n ->
|
|
if n >= 1 && n <= 4
|
|
then out(opENVACC1 + n - 1)
|
|
else (out opENVACC; out_int n)
|
|
| Kpush ->
|
|
out opPUSH
|
|
| Kpop n ->
|
|
out opPOP; out_int n
|
|
| Kassign n ->
|
|
out opASSIGN; out_int n
|
|
| Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl
|
|
| Kapply n ->
|
|
if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
|
|
| Kappterm(n, sz) ->
|
|
if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
|
|
else (out opAPPTERM; out_int n; out_int sz)
|
|
| Kreturn n -> out opRETURN; out_int n
|
|
| Krestart -> out opRESTART
|
|
| Kgrab n -> out opGRAB; out_int n
|
|
| Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl
|
|
| Kclosurerec(lbls, n) ->
|
|
out opCLOSUREREC; out_int (List.length lbls); out_int n;
|
|
let org = !out_position in
|
|
List.iter (out_label_with_orig org) lbls
|
|
| Koffsetclosure ofs ->
|
|
if ofs = -2 || ofs = 0 || ofs = 2
|
|
then out (opOFFSETCLOSURE0 + ofs / 2)
|
|
else (out opOFFSETCLOSURE; out_int ofs)
|
|
| Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q
|
|
| Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
|
|
| Kconst sc ->
|
|
begin match sc with
|
|
Const_base(Const_int i) when is_immed i ->
|
|
if i >= 0 && i <= 3
|
|
then out (opCONST0 + i)
|
|
else (out opCONSTINT; out_int i)
|
|
| Const_base(Const_char c) ->
|
|
out opCONSTINT; out_int (Char.code c)
|
|
| Const_pointer i ->
|
|
if i >= 0 && i <= 3
|
|
then out (opCONST0 + i)
|
|
else (out opCONSTINT; out_int i)
|
|
| Const_block(t, []) ->
|
|
if t = 0 then out opATOM0 else (out opATOM; out_int t)
|
|
| _ ->
|
|
out opGETGLOBAL; slot_for_literal sc
|
|
end
|
|
| Kmakeblock(n, t) ->
|
|
if n = 0 then
|
|
if t = 0 then out opATOM0 else (out opATOM; out_int t)
|
|
else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
|
|
else (out opMAKEBLOCK; out_int n; out_int t)
|
|
| Kgetfield n ->
|
|
if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
|
|
| Ksetfield n ->
|
|
if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
|
|
| Kmakefloatblock(n) ->
|
|
if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n)
|
|
| Kgetfloatfield n -> out opGETFLOATFIELD; out_int n
|
|
| Ksetfloatfield n -> out opSETFLOATFIELD; out_int n
|
|
| Kvectlength -> out opVECTLENGTH
|
|
| Kgetvectitem -> out opGETVECTITEM
|
|
| Ksetvectitem -> out opSETVECTITEM
|
|
| Kgetstringchar -> out opGETSTRINGCHAR
|
|
| Ksetstringchar -> out opSETSTRINGCHAR
|
|
| Kbranch lbl -> out opBRANCH; out_label lbl
|
|
| Kbranchif lbl -> out opBRANCHIF; out_label lbl
|
|
| Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
|
|
| Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl
|
|
| Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
|
|
| Kswitch(tbl_const, tbl_block) ->
|
|
out opSWITCH;
|
|
out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
|
|
let org = !out_position in
|
|
Array.iter (out_label_with_orig org) tbl_const;
|
|
Array.iter (out_label_with_orig org) tbl_block
|
|
| Kboolnot -> out opBOOLNOT
|
|
| Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
|
|
| Kpoptrap -> out opPOPTRAP
|
|
| Kraise -> out opRAISE
|
|
| Kcheck_signals -> out opCHECK_SIGNALS
|
|
| Kccall(name, n) ->
|
|
if n <= 5
|
|
then (out (opC_CALL1 + n - 1); slot_for_c_prim name)
|
|
else (out opC_CALLN; out_int n; slot_for_c_prim name)
|
|
| Knegint -> out opNEGINT | Kaddint -> out opADDINT
|
|
| Ksubint -> out opSUBINT | Kmulint -> out opMULINT
|
|
| Kdivint -> out opDIVINT | Kmodint -> out opMODINT
|
|
| Kandint -> out opANDINT | Korint -> out opORINT
|
|
| Kxorint -> out opXORINT | Klslint -> out opLSLINT
|
|
| Klsrint -> out opLSRINT | Kasrint -> out opASRINT
|
|
| Kintcomp c -> emit_comp c
|
|
| Koffsetint n -> out opOFFSETINT; out_int n
|
|
| Koffsetref n -> out opOFFSETREF; out_int n
|
|
| Kisint -> out opISINT
|
|
| Kisout -> out opULTINT
|
|
| Kgetmethod -> out opGETMETHOD
|
|
| Kevent ev -> record_event ev
|
|
| Kstop -> out opSTOP
|
|
|
|
(* Emission of a list of instructions. Include some peephole optimization. *)
|
|
|
|
let rec emit = function
|
|
[] -> ()
|
|
(* Peephole optimizations *)
|
|
(* optimization of integer tests *)
|
|
| Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem
|
|
when is_immed_const k ->
|
|
emit_branch_comp c ;
|
|
out_const k ;
|
|
out_label lbl ;
|
|
emit rem
|
|
| Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem
|
|
when is_immed_const k ->
|
|
emit_branch_comp (negate_comparison c) ;
|
|
out_const k ;
|
|
out_label lbl ;
|
|
emit rem
|
|
(* same for range tests *)
|
|
| Kpush::Kconst k::Kisout::Kbranchif lbl::rem
|
|
when is_immed_const k ->
|
|
out opBULTINT ;
|
|
out_const k ;
|
|
out_label lbl ;
|
|
emit rem
|
|
| Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem
|
|
when is_immed_const k ->
|
|
out opBUGEINT ;
|
|
out_const k ;
|
|
out_label lbl ;
|
|
emit rem
|
|
(* Some special case of push ; i ; ret generated by the match compiler *)
|
|
| Kpush :: Kacc 0 :: Kreturn m :: c ->
|
|
emit (Kreturn (m-1) :: c)
|
|
(* General push then access scheme *)
|
|
| Kpush :: Kacc n :: c ->
|
|
if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
|
|
emit c
|
|
| Kpush :: Kenvacc n :: c ->
|
|
if n >= 1 && n < 4
|
|
then out(opPUSHENVACC1 + n - 1)
|
|
else (out opPUSHENVACC; out_int n);
|
|
emit c
|
|
| Kpush :: Koffsetclosure ofs :: c ->
|
|
if ofs = -2 || ofs = 0 || ofs = 2
|
|
then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
|
|
else (out opPUSHOFFSETCLOSURE; out_int ofs);
|
|
emit c
|
|
| Kpush :: Kgetglobal id :: Kgetfield n :: c ->
|
|
out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
|
|
| Kpush :: Kgetglobal id :: c ->
|
|
out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
|
|
| Kpush :: Kconst sc :: c ->
|
|
begin match sc with
|
|
Const_base(Const_int i) when is_immed i ->
|
|
if i >= 0 && i <= 3
|
|
then out (opPUSHCONST0 + i)
|
|
else (out opPUSHCONSTINT; out_int i)
|
|
| Const_base(Const_char c) ->
|
|
out opPUSHCONSTINT; out_int(Char.code c)
|
|
| Const_pointer i ->
|
|
if i >= 0 && i <= 3
|
|
then out (opPUSHCONST0 + i)
|
|
else (out opPUSHCONSTINT; out_int i)
|
|
| Const_block(t, []) ->
|
|
if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
|
|
| _ ->
|
|
out opPUSHGETGLOBAL; slot_for_literal sc
|
|
end;
|
|
emit c
|
|
| Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
|
|
(Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
|
|
emit (Kpush :: instr1 :: instr2 :: ev :: c)
|
|
| Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
|
|
(Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
|
|
emit (Kpush :: instr :: ev :: c)
|
|
| Kgetglobal id :: Kgetfield n :: c ->
|
|
out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
|
|
(* Default case *)
|
|
| instr :: c ->
|
|
emit_instr instr; emit c
|
|
|
|
(* Emission to a file *)
|
|
|
|
let to_file outchan unit_name code =
|
|
init();
|
|
output_string outchan cmo_magic_number;
|
|
let pos_depl = pos_out outchan in
|
|
output_binary_int outchan 0;
|
|
let pos_code = pos_out outchan in
|
|
emit code;
|
|
output outchan !out_buffer 0 !out_position;
|
|
let (pos_debug, size_debug) =
|
|
if !Clflags.debug then begin
|
|
let p = pos_out outchan in
|
|
output_value outchan !events;
|
|
(p, pos_out outchan - p)
|
|
end else
|
|
(0, 0) in
|
|
let compunit =
|
|
{ cu_name = unit_name;
|
|
cu_pos = pos_code;
|
|
cu_codesize = !out_position;
|
|
cu_reloc = List.rev !reloc_info;
|
|
cu_imports = Env.imported_units();
|
|
cu_primitives = !Translmod.primitive_declarations;
|
|
cu_force_link = false;
|
|
cu_debug = pos_debug;
|
|
cu_debugsize = size_debug } in
|
|
init(); (* Free out_buffer and reloc_info *)
|
|
Btype.cleanup_abbrev (); (* Remove any cached abbreviation
|
|
expansion before saving *)
|
|
let pos_compunit = pos_out outchan in
|
|
output_value outchan compunit;
|
|
seek_out outchan pos_depl;
|
|
output_binary_int outchan pos_compunit
|
|
|
|
(* Emission to a memory block *)
|
|
|
|
let to_memory init_code fun_code =
|
|
init();
|
|
emit init_code;
|
|
emit fun_code;
|
|
let code = Meta.static_alloc !out_position in
|
|
String.unsafe_blit !out_buffer 0 code 0 !out_position;
|
|
let reloc = List.rev !reloc_info
|
|
and code_size = !out_position in
|
|
init();
|
|
(code, code_size, reloc)
|
|
|
|
(* Emission to a file for a packed library *)
|
|
|
|
let to_packed_file outchan code =
|
|
init();
|
|
emit code;
|
|
output outchan !out_buffer 0 !out_position;
|
|
let reloc = !reloc_info in
|
|
init();
|
|
reloc
|