831 lines
25 KiB
OCaml
831 lines
25 KiB
OCaml
(*
|
|
|
|
Our assembler is an all-at-once, buffer-in-memory job, very simple
|
|
minded. I have 1gb of memory on my laptop: I don't expect to ever
|
|
emit a program that large with this code.
|
|
|
|
It is based on the 'frag' type, which has a variant for every major
|
|
type of machine-blob we know how to write (bytes, zstrings, BSS
|
|
blocks, words of various sorts).
|
|
|
|
A frag can contain symbolic references between the sub-parts of
|
|
it. These are accomplished through ref cells we call fixups, and a
|
|
2-pass (resolution and writing) process defined recursively over
|
|
the frag structure.
|
|
|
|
Fixups are defined by wrapping a frag in a DEF pseudo-frag with
|
|
a fixup attached. This will record information about the wrapped
|
|
frag -- positions and sizes -- in the fixup during resolution.
|
|
|
|
We say "positions" and "sizes" there, in plural, because both a
|
|
file number and a memory number is recorded for each concept.
|
|
|
|
File numbers refer to positions and sizes in the file we're
|
|
generating, and are based on the native int type for the host
|
|
platform -- usually 31 or 62 bits -- whereas the expressions that
|
|
*use* position fixups tend to promote them up to 32 or 64 bits
|
|
somehow. On a 32 bit platform, you can't generate output buffers
|
|
with 64-bit positions (ocaml limitation!)
|
|
|
|
Memory numbers are 64 bit, always, and refer to sizes and positions
|
|
of frags when they are loaded into memory in the target. When
|
|
you're generating code for a 32-bit target, or using a memory
|
|
number in a context that's less than 64 bits, the value is
|
|
range-checked and truncated. But in all other respects, we imagine
|
|
a 32-bit address space is just the prefix of the continuing 64-bit
|
|
address space. If you need to pin an object at a particular place
|
|
from the point 2^32-1, say, you will need to do arithmetic and use
|
|
the MEMPOS pseudo-frag, that sets the current memory position as
|
|
it's being processed.
|
|
|
|
Fixups can be *used* anywhere else in the frag tree, as many times
|
|
as you like. If you try to write an unresolved fixup, the emitter
|
|
faults. When you specify the use of a fixup, you need to specify
|
|
whether you want to use its file size, file position, memory size,
|
|
or memory position.
|
|
|
|
Positions, addresses, sizes and such, of course, are in bytes.
|
|
|
|
Expressions are evaluated to an int64 (signed), even if the
|
|
expression is an int32 or less. Depending on how you use the result
|
|
of the expression, a range check error may fire (for example, if
|
|
the expression evaluates to -2^24 and you're emitting a word16).
|
|
|
|
Word endianness is per-file. At the moment this seems acceptable.
|
|
|
|
Because we want to be *very specific* about the time and place
|
|
arithmetic promotions occur, we define two separate expression-tree
|
|
types (with the same polymorphic constructors) and two separate
|
|
evaluation functions, with an explicit operator for marking the
|
|
promotion-points.
|
|
|
|
*)
|
|
|
|
open Common;;
|
|
open Fmt;;
|
|
|
|
let log (sess:Session.sess) =
|
|
Session.log "asm"
|
|
sess.Session.sess_log_asm
|
|
sess.Session.sess_log_out
|
|
;;
|
|
|
|
let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
|
|
if sess.Session.sess_log_asm
|
|
then thunk ()
|
|
else ()
|
|
;;
|
|
|
|
exception Bad_fit of string;;
|
|
exception Undef_sym of string;;
|
|
|
|
type ('a, 'b) expr =
|
|
IMM of 'a
|
|
| ADD of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| SUB of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| MUL of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| DIV of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| REM of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| MAX of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| ALIGN of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| SLL of (('a, 'b) expr) * int
|
|
| SLR of (('a, 'b) expr) * int
|
|
| SAR of (('a, 'b) expr) * int
|
|
| AND of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| XOR of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| OR of (('a, 'b) expr) * (('a, 'b) expr)
|
|
| NOT of (('a, 'b) expr)
|
|
| NEG of (('a, 'b) expr)
|
|
| F_POS of fixup
|
|
| F_SZ of fixup
|
|
| M_POS of fixup
|
|
| M_SZ of fixup
|
|
| EXT of 'b
|
|
|
|
type expr32 = (int32, int) expr
|
|
;;
|
|
|
|
type expr64 = (int64, expr32) expr
|
|
;;
|
|
|
|
|
|
let rec eval32 (e:expr32)
|
|
: int32 =
|
|
let chop64 kind name v =
|
|
let x = Int64.to_int32 v in
|
|
if (Int64.compare v (Int64.of_int32 x)) = 0 then
|
|
x
|
|
else raise (Bad_fit (kind
|
|
^ " fixup "
|
|
^ name
|
|
^ " overflowed 32 bits in eval32: "
|
|
^ Int64.to_string v))
|
|
in
|
|
let expandInt _ _ v = Int32.of_int v in
|
|
let checkdef kind name v inj =
|
|
match v with
|
|
None ->
|
|
raise (Undef_sym (kind ^ " fixup " ^ name
|
|
^ " undefined in eval32"))
|
|
| Some x -> inj kind name x
|
|
in
|
|
match e with
|
|
IMM i -> i
|
|
| ADD (a, b) -> Int32.add (eval32 a) (eval32 b)
|
|
| SUB (a, b) -> Int32.sub (eval32 a) (eval32 b)
|
|
| MUL (a, b) -> Int32.mul (eval32 a) (eval32 b)
|
|
| DIV (a, b) -> Int32.div (eval32 a) (eval32 b)
|
|
| REM (a, b) -> Int32.rem (eval32 a) (eval32 b)
|
|
| MAX (a, b) -> i32_max (eval32 a) (eval32 b)
|
|
| ALIGN (a, b) -> i32_align (eval32 a) (eval32 b)
|
|
| SLL (a, b) -> Int32.shift_left (eval32 a) b
|
|
| SLR (a, b) -> Int32.shift_right_logical (eval32 a) b
|
|
| SAR (a, b) -> Int32.shift_right (eval32 a) b
|
|
| AND (a, b) -> Int32.logand (eval32 a) (eval32 b)
|
|
| XOR (a, b) -> Int32.logxor (eval32 a) (eval32 b)
|
|
| OR (a, b) -> Int32.logor (eval32 a) (eval32 b)
|
|
| NOT a -> Int32.lognot (eval32 a)
|
|
| NEG a -> Int32.neg (eval32 a)
|
|
| F_POS f ->
|
|
checkdef "file position"
|
|
f.fixup_name f.fixup_file_pos expandInt
|
|
| F_SZ f ->
|
|
checkdef "file size"
|
|
f.fixup_name f.fixup_file_sz expandInt
|
|
| M_POS f ->
|
|
checkdef "mem position"
|
|
f.fixup_name f.fixup_mem_pos chop64
|
|
| M_SZ f ->
|
|
checkdef "mem size" f.fixup_name f.fixup_mem_sz chop64
|
|
| EXT i -> Int32.of_int i
|
|
;;
|
|
|
|
let rec eval64 (e:expr64)
|
|
: int64 =
|
|
let checkdef kind name v inj =
|
|
match v with
|
|
None ->
|
|
raise (Undef_sym (kind ^ " fixup '"
|
|
^ name ^ "' undefined in eval64"))
|
|
| Some x -> inj x
|
|
in
|
|
match e with
|
|
IMM i -> i
|
|
| ADD (a, b) -> Int64.add (eval64 a) (eval64 b)
|
|
| SUB (a, b) -> Int64.sub (eval64 a) (eval64 b)
|
|
| MUL (a, b) -> Int64.mul (eval64 a) (eval64 b)
|
|
| DIV (a, b) -> Int64.div (eval64 a) (eval64 b)
|
|
| REM (a, b) -> Int64.rem (eval64 a) (eval64 b)
|
|
| MAX (a, b) -> i64_max (eval64 a) (eval64 b)
|
|
| ALIGN (a, b) -> i64_align (eval64 a) (eval64 b)
|
|
| SLL (a, b) -> Int64.shift_left (eval64 a) b
|
|
| SLR (a, b) -> Int64.shift_right_logical (eval64 a) b
|
|
| SAR (a, b) -> Int64.shift_right (eval64 a) b
|
|
| AND (a, b) -> Int64.logand (eval64 a) (eval64 b)
|
|
| XOR (a, b) -> Int64.logxor (eval64 a) (eval64 b)
|
|
| OR (a, b) -> Int64.logor (eval64 a) (eval64 b)
|
|
| NOT a -> Int64.lognot (eval64 a)
|
|
| NEG a -> Int64.neg (eval64 a)
|
|
| F_POS f ->
|
|
checkdef "file position"
|
|
f.fixup_name f.fixup_file_pos Int64.of_int
|
|
| F_SZ f ->
|
|
checkdef "file size"
|
|
f.fixup_name f.fixup_file_sz Int64.of_int
|
|
| M_POS f ->
|
|
checkdef "mem position"
|
|
f.fixup_name f.fixup_mem_pos (fun x -> x)
|
|
| M_SZ f ->
|
|
checkdef "mem size"
|
|
f.fixup_name f.fixup_mem_sz (fun x -> x)
|
|
| EXT e -> Int64.of_int32 (eval32 e)
|
|
;;
|
|
|
|
let rec string_of_expr64 (e64:expr64) : string =
|
|
let bin op a b =
|
|
Printf.sprintf "(%s %s %s)" (string_of_expr64 a) op (string_of_expr64 b)
|
|
in
|
|
let bini op a b =
|
|
Printf.sprintf "(%s %s %d)" (string_of_expr64 a) op b
|
|
in
|
|
match e64 with
|
|
IMM i when (i64_lt i 0L) -> Printf.sprintf "-0x%Lx" (Int64.neg i)
|
|
| IMM i -> Printf.sprintf "0x%Lx" i
|
|
| ADD (a,b) -> bin "+" a b
|
|
| SUB (a,b) -> bin "-" a b
|
|
| MUL (a,b) -> bin "*" a b
|
|
| DIV (a,b) -> bin "/" a b
|
|
| REM (a,b) -> bin "%" a b
|
|
| MAX (a,b) ->
|
|
Printf.sprintf "(max %s %s)"
|
|
(string_of_expr64 a) (string_of_expr64 b)
|
|
| ALIGN (a,b) ->
|
|
Printf.sprintf "(align %s %s)"
|
|
(string_of_expr64 a) (string_of_expr64 b)
|
|
| SLL (a,b) -> bini "<<" a b
|
|
| SLR (a,b) -> bini ">>" a b
|
|
| SAR (a,b) -> bini ">>>" a b
|
|
| AND (a,b) -> bin "&" a b
|
|
| XOR (a,b) -> bin "xor" a b
|
|
| OR (a,b) -> bin "|" a b
|
|
| NOT a -> Printf.sprintf "(not %s)" (string_of_expr64 a)
|
|
| NEG a -> Printf.sprintf "-%s" (string_of_expr64 a)
|
|
| F_POS f -> Printf.sprintf "<%s>.fpos" f.fixup_name
|
|
| F_SZ f -> Printf.sprintf "<%s>.fsz" f.fixup_name
|
|
| M_POS f -> Printf.sprintf "<%s>.mpos" f.fixup_name
|
|
| M_SZ f -> Printf.sprintf "<%s>.msz" f.fixup_name
|
|
| EXT _ -> "??ext??"
|
|
;;
|
|
|
|
type frag =
|
|
MARK (* MARK == 'PAD (IMM 0L)' *)
|
|
| SEQ of frag array
|
|
| PAD of int
|
|
| BSS of int64
|
|
| MEMPOS of int64
|
|
| BYTE of int
|
|
| BYTES of int array
|
|
| CHAR of char
|
|
| STRING of string
|
|
| ZSTRING of string
|
|
| ULEB128 of expr64
|
|
| SLEB128 of expr64
|
|
| WORD of (ty_mach * expr64)
|
|
| ALIGN_FILE of (int * frag)
|
|
| ALIGN_MEM of (int * frag)
|
|
| DEF of (fixup * frag)
|
|
| RELAX of relaxation
|
|
|
|
and relaxation =
|
|
{ relax_options: frag array;
|
|
relax_choice: int ref; }
|
|
;;
|
|
|
|
|
|
let rec fmt_frag (ff:Format.formatter) (f:frag) : unit =
|
|
match f with
|
|
MARK -> fmt ff "MARK"
|
|
| SEQ fs -> fmt_bracketed_arr_sep "[" "]" ", " fmt_frag ff fs
|
|
| PAD i -> fmt ff "PAD(%d)" i
|
|
| BSS i -> fmt ff "BSZ(%Ld)" i
|
|
| MEMPOS i -> fmt ff "MEMPOS(%Ld)" i
|
|
| BYTE i -> fmt ff "0x%x" i
|
|
| BYTES iz ->
|
|
fmt ff "BYTES";
|
|
fmt_bracketed_arr_sep "(" ")" ", "
|
|
(fun ff i -> fmt ff "0x%x" i) ff iz
|
|
| CHAR c -> fmt ff "CHAR(%s)" (Char.escaped c)
|
|
| STRING s -> fmt ff "STRING(%s)" (String.escaped s)
|
|
| ZSTRING s -> fmt ff "ZSTRING(%s)" (String.escaped s)
|
|
| ULEB128 e -> fmt ff "ULEB128(%s)" (string_of_expr64 e)
|
|
| SLEB128 e -> fmt ff "SLEB128(%s)" (string_of_expr64 e)
|
|
| WORD (tm, e) ->
|
|
fmt ff "%s:%s"
|
|
(string_of_ty_mach tm) (string_of_expr64 e)
|
|
| ALIGN_FILE (i, f) ->
|
|
fmt ff "ALIGN_FILE(%d, " i;
|
|
fmt_frag ff f;
|
|
fmt ff ")"
|
|
| ALIGN_MEM (i, f) ->
|
|
fmt ff "ALIGN_MEM(%d, " i;
|
|
fmt_frag ff f;
|
|
fmt ff ")"
|
|
| DEF (fix, f) ->
|
|
fmt ff "DEF(%s, " fix.fixup_name;
|
|
fmt_frag ff f;
|
|
fmt ff ")"
|
|
| RELAX r ->
|
|
fmt ff "RELAX(";
|
|
fmt_arr_sep ", " fmt_frag ff r.relax_options
|
|
;;
|
|
|
|
let sprintf_frag = Fmt.sprintf_fmt fmt_frag;;
|
|
|
|
exception Relax_more of relaxation;;
|
|
|
|
let new_relaxation (frags:frag array) =
|
|
RELAX { relax_options = frags;
|
|
relax_choice = ref ((Array.length frags) - 1); }
|
|
;;
|
|
|
|
|
|
let rec write_frag
|
|
~(sess:Session.sess)
|
|
~(lsb0:bool)
|
|
~(buf:Buffer.t)
|
|
~(frag:frag)
|
|
: unit =
|
|
let relax = Queue.create () in
|
|
let bump_relax r =
|
|
iflog sess (fun _ ->
|
|
log sess "bumping relaxation to position %d"
|
|
((!(r.relax_choice)) - 1));
|
|
r.relax_choice := (!(r.relax_choice)) - 1;
|
|
if !(r.relax_choice) < 0
|
|
then bug () "relaxation ran out of options"
|
|
in
|
|
let rec loop _ =
|
|
Queue.clear relax;
|
|
Buffer.clear buf;
|
|
resolve_frag_full relax frag;
|
|
lower_frag ~sess ~lsb0 ~buf ~relax ~frag;
|
|
if Queue.is_empty relax
|
|
then ()
|
|
else
|
|
begin
|
|
iflog sess (fun _ -> log sess "relaxing");
|
|
Queue.iter bump_relax relax;
|
|
loop ()
|
|
end
|
|
in
|
|
loop ()
|
|
|
|
|
|
and resolve_frag_full (relax:relaxation Queue.t) (frag:frag)
|
|
: unit =
|
|
let file_pos = ref 0 in
|
|
let mem_pos = ref 0L in
|
|
let bump i =
|
|
mem_pos := Int64.add (!mem_pos) (Int64.of_int i);
|
|
file_pos := (!file_pos) + i
|
|
in
|
|
|
|
let uleb (e:expr64) : unit =
|
|
let rec loop value =
|
|
let value = Int64.shift_right_logical value 7 in
|
|
if value = 0L
|
|
then bump 1
|
|
else
|
|
begin
|
|
bump 1;
|
|
loop value
|
|
end
|
|
in
|
|
loop (eval64 e)
|
|
in
|
|
|
|
let sleb (e:expr64) : unit =
|
|
let rec loop value =
|
|
let byte = Int64.logand value 0xf7L in
|
|
let value = Int64.shift_right value 7 in
|
|
let signbit = Int64.logand byte 0x40L in
|
|
if (((value = 0L) && (signbit = 0L)) ||
|
|
((value = -1L) && (signbit = 0x40L)))
|
|
then bump 1
|
|
else
|
|
begin
|
|
bump 1;
|
|
loop value
|
|
end
|
|
in
|
|
loop (eval64 e)
|
|
in
|
|
let rec resolve_frag it =
|
|
match it with
|
|
| MARK -> ()
|
|
| SEQ frags -> Array.iter resolve_frag frags
|
|
| PAD i -> bump i
|
|
| BSS i -> mem_pos := Int64.add (!mem_pos) i
|
|
| MEMPOS i -> mem_pos := i
|
|
| BYTE _ -> bump 1
|
|
| BYTES ia -> bump (Array.length ia)
|
|
| CHAR _ -> bump 1
|
|
| STRING s -> bump (String.length s)
|
|
| ZSTRING s -> bump ((String.length s) + 1)
|
|
| ULEB128 e -> uleb e
|
|
| SLEB128 e -> sleb e
|
|
| WORD (mach,_) -> bump (bytes_of_ty_mach mach)
|
|
| ALIGN_FILE (n, frag) ->
|
|
let spill = (!file_pos) mod n in
|
|
let pad = (n - spill) mod n in
|
|
file_pos := (!file_pos) + pad;
|
|
(*
|
|
* NB: aligning the file *causes* likewise alignment of
|
|
* memory, since we implement "file alignment" by
|
|
* padding!
|
|
*)
|
|
mem_pos := Int64.add (!mem_pos) (Int64.of_int pad);
|
|
resolve_frag frag
|
|
|
|
| ALIGN_MEM (n, frag) ->
|
|
let n64 = Int64.of_int n in
|
|
let spill = Int64.rem (!mem_pos) n64 in
|
|
let pad = Int64.rem (Int64.sub n64 spill) n64 in
|
|
mem_pos := Int64.add (!mem_pos) pad;
|
|
resolve_frag frag
|
|
|
|
| DEF (f, i) ->
|
|
let fpos1 = !file_pos in
|
|
let mpos1 = !mem_pos in
|
|
resolve_frag i;
|
|
f.fixup_file_pos <- Some fpos1;
|
|
f.fixup_mem_pos <- Some mpos1;
|
|
f.fixup_file_sz <- Some ((!file_pos) - fpos1);
|
|
f.fixup_mem_sz <- Some (Int64.sub (!mem_pos) mpos1)
|
|
|
|
| RELAX rel ->
|
|
begin
|
|
try
|
|
resolve_frag rel.relax_options.(!(rel.relax_choice))
|
|
with
|
|
Bad_fit _ -> Queue.add rel relax
|
|
end
|
|
in
|
|
resolve_frag frag
|
|
|
|
and lower_frag
|
|
~(sess:Session.sess)
|
|
~(lsb0:bool)
|
|
~(buf:Buffer.t)
|
|
~(relax:relaxation Queue.t)
|
|
~(frag:frag)
|
|
: unit =
|
|
let byte (i:int) =
|
|
if i < 0
|
|
then raise (Bad_fit "byte underflow")
|
|
else
|
|
if i > 255
|
|
then raise (Bad_fit "byte overflow")
|
|
else Buffer.add_char buf (Char.chr i)
|
|
in
|
|
|
|
let uleb (e:expr64) : unit =
|
|
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
|
|
let rec loop value =
|
|
let byte = Int64.logand value 0x7fL in
|
|
let value = Int64.shift_right_logical value 7 in
|
|
if value = 0L
|
|
then emit1 byte
|
|
else
|
|
begin
|
|
emit1 (Int64.logor byte 0x80L);
|
|
loop value
|
|
end
|
|
in
|
|
loop (eval64 e)
|
|
in
|
|
|
|
let sleb (e:expr64) : unit =
|
|
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
|
|
let rec loop value =
|
|
let byte = Int64.logand value 0x7fL in
|
|
let value = Int64.shift_right value 7 in
|
|
let signbit = Int64.logand byte 0x40L in
|
|
if (((value = 0L) && (signbit = 0L)) ||
|
|
((value = -1L) && (signbit = 0x40L)))
|
|
then emit1 byte
|
|
else
|
|
begin
|
|
emit1 (Int64.logor byte 0x80L);
|
|
loop value
|
|
end
|
|
in
|
|
loop (eval64 e)
|
|
in
|
|
|
|
let word (nbytes:int) (signed:bool) (e:expr64) =
|
|
let i = eval64 e in
|
|
|
|
(*
|
|
FIXME:
|
|
|
|
We should really base the entire assembler and memory-position
|
|
system on Big_int.big_int, but in ocaml the big_int type lacks,
|
|
oh, just about every useful function (no format string spec, no
|
|
bitwise ops, blah blah) so it's useless; we're stuck on int64
|
|
for bootstrapping.
|
|
|
|
For the time being we're just going to require you to represent
|
|
those few unsigned 64 bit terms you have in mind via their
|
|
signed bit pattern. Suboptimal but it's the best we can do.
|
|
*)
|
|
|
|
let (top,bot) =
|
|
if nbytes >= 8
|
|
then
|
|
if signed
|
|
then (Int64.max_int,Int64.min_int)
|
|
else (Int64.max_int,0L)
|
|
else
|
|
if signed
|
|
then
|
|
let bound = (Int64.shift_left 1L ((8 * nbytes) - 1)) in
|
|
(Int64.sub bound 1L, Int64.neg bound)
|
|
else
|
|
let bound = (Int64.shift_left 1L (8 * nbytes)) in
|
|
(Int64.sub bound 1L, 0L)
|
|
in
|
|
|
|
let mask1 = Int64.logand 0xffL in
|
|
let shift = Int64.shift_right_logical in
|
|
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
|
|
if Int64.compare i bot = (-1)
|
|
then raise (Bad_fit ("word underflow: "
|
|
^ (Int64.to_string i)
|
|
^ " into "
|
|
^ (string_of_int nbytes)
|
|
^ (if signed then " signed" else " unsigned")
|
|
^ " bytes"))
|
|
else
|
|
if Int64.compare i top = 1
|
|
then raise (Bad_fit ("word overflow: "
|
|
^ (Int64.to_string i)
|
|
^ " into "
|
|
^ (string_of_int nbytes)
|
|
^ (if signed then " signed" else " unsigned")
|
|
^ " bytes"))
|
|
else
|
|
if lsb0
|
|
then
|
|
for n = 0 to (nbytes - 1) do
|
|
emit1 (mask1 (shift i (8*n)))
|
|
done
|
|
else
|
|
for n = (nbytes - 1) downto 0 do
|
|
emit1 (mask1 (shift i (8*n)))
|
|
done
|
|
in
|
|
match frag with
|
|
MARK -> ()
|
|
|
|
| SEQ frags ->
|
|
Array.iter
|
|
begin
|
|
fun frag ->
|
|
lower_frag ~sess ~lsb0 ~buf ~relax ~frag
|
|
end frags
|
|
|
|
| PAD c ->
|
|
for i = 1 to c do
|
|
Buffer.add_char buf '\x00'
|
|
done
|
|
|
|
| BSS _ -> ()
|
|
|
|
| MEMPOS _ -> ()
|
|
|
|
| BYTE i -> byte i
|
|
|
|
| BYTES bs ->
|
|
iflog sess (fun _ -> log sess "lowering %d bytes"
|
|
(Array.length bs));
|
|
Array.iter byte bs
|
|
|
|
| CHAR c ->
|
|
iflog sess (fun _ -> log sess "lowering char: %c" c);
|
|
Buffer.add_char buf c
|
|
|
|
| STRING s ->
|
|
iflog sess (fun _ -> log sess "lowering string: %s" s);
|
|
Buffer.add_string buf s
|
|
|
|
| ZSTRING s ->
|
|
iflog sess (fun _ -> log sess "lowering zstring: %s" s);
|
|
Buffer.add_string buf s;
|
|
byte 0
|
|
|
|
| ULEB128 e -> uleb e
|
|
| SLEB128 e -> sleb e
|
|
|
|
| WORD (m,e) ->
|
|
iflog sess
|
|
(fun _ ->
|
|
log sess "lowering word %s"
|
|
(string_of_ty_mach m));
|
|
word (bytes_of_ty_mach m) (mach_is_signed m) e
|
|
|
|
| ALIGN_FILE (n, frag) ->
|
|
let spill = (Buffer.length buf) mod n in
|
|
let pad = (n - spill) mod n in
|
|
for i = 1 to pad do
|
|
Buffer.add_char buf '\x00'
|
|
done;
|
|
lower_frag sess lsb0 buf relax frag
|
|
|
|
| ALIGN_MEM (_, i) -> lower_frag sess lsb0 buf relax i
|
|
| DEF (f, i) ->
|
|
iflog sess (fun _ -> log sess "lowering fixup: %s" f.fixup_name);
|
|
lower_frag sess lsb0 buf relax i;
|
|
|
|
| RELAX rel ->
|
|
begin
|
|
try
|
|
lower_frag sess lsb0 buf relax
|
|
rel.relax_options.(!(rel.relax_choice))
|
|
with
|
|
Bad_fit _ -> Queue.add rel relax
|
|
end
|
|
;;
|
|
|
|
let fold_flags (f:'a -> int64) (flags:'a list) : int64 =
|
|
List.fold_left (Int64.logor) 0x0L (List.map f flags)
|
|
;;
|
|
|
|
let write_out_frag sess lsb0 frag =
|
|
let buf = Buffer.create 0xffff in
|
|
let file = Session.filename_of sess.Session.sess_out in
|
|
let out = open_out_bin file in
|
|
write_frag ~sess ~lsb0 ~buf ~frag;
|
|
Buffer.output_buffer out buf;
|
|
flush out;
|
|
close_out out;
|
|
Unix.chmod file 0o755
|
|
;;
|
|
|
|
(* Asm-reader stuff for loading info back from mapped files. *)
|
|
(*
|
|
* Unfortunately the ocaml Bigarray interface takes 'int' indices, so
|
|
* f.e. can't do 64-bit offsets / files when running on a 32bit platform.
|
|
* Despite the fact that we can possibly produce them. Sigh. Yet another
|
|
* "bootstrap compiler limitation".
|
|
*)
|
|
type asm_reader =
|
|
{
|
|
asm_seek: int -> unit;
|
|
asm_get_u32: unit -> int;
|
|
asm_get_u16: unit -> int;
|
|
asm_get_u8: unit -> int;
|
|
asm_get_uleb: unit -> int;
|
|
asm_get_zstr: unit -> string;
|
|
asm_get_zstr_padded: int -> string;
|
|
asm_get_off: unit -> int;
|
|
asm_adv: int -> unit;
|
|
asm_adv_u32: unit -> unit;
|
|
asm_adv_u16: unit -> unit;
|
|
asm_adv_u8: unit -> unit;
|
|
asm_adv_zstr: unit -> unit;
|
|
asm_close: unit -> unit;
|
|
}
|
|
;;
|
|
|
|
type mmap_arr =
|
|
(int, Bigarray.int8_unsigned_elt, Bigarray.c_layout)
|
|
Bigarray.Array1.t
|
|
;;
|
|
|
|
let new_asm_reader (sess:Session.sess) (s:filename) : asm_reader =
|
|
iflog sess (fun _ -> log sess "opening file %s" s);
|
|
let fd = Unix.openfile s [ Unix.O_RDONLY ] 0 in
|
|
let arr = (Bigarray.Array1.map_file
|
|
fd ~pos:0L
|
|
Bigarray.int8_unsigned
|
|
Bigarray.c_layout
|
|
false (-1))
|
|
in
|
|
let tmp = ref Nativeint.zero in
|
|
let buf = Buffer.create 16 in
|
|
let off = ref 0 in
|
|
let is_open = ref true in
|
|
let get_word_as_int (nbytes:int) : int =
|
|
assert (!is_open);
|
|
let lsb0 = true in
|
|
tmp := Nativeint.zero;
|
|
if lsb0
|
|
then
|
|
for j = nbytes-1 downto 0 do
|
|
tmp := Nativeint.shift_left (!tmp) 8;
|
|
tmp := Nativeint.logor (!tmp) (Nativeint.of_int arr.{(!off) + j})
|
|
done
|
|
else
|
|
for j = 0 to nbytes-1 do
|
|
tmp := Nativeint.shift_left (!tmp) 8;
|
|
tmp := Nativeint.logor (!tmp) (Nativeint.of_int arr.{(!off) + j})
|
|
done;
|
|
off := (!off) + nbytes;
|
|
Nativeint.to_int (!tmp)
|
|
in
|
|
let get_zstr_padded pad_opt =
|
|
assert (!is_open);
|
|
let i = ref (!off) in
|
|
Buffer.clear buf;
|
|
let buflen_ok _ =
|
|
match pad_opt with
|
|
None -> true
|
|
| Some pad -> (Buffer.length buf) < pad
|
|
in
|
|
while arr.{!i} != 0 && (buflen_ok()) do
|
|
Buffer.add_char buf (Char.chr arr.{!i});
|
|
incr i
|
|
done;
|
|
begin
|
|
match pad_opt with
|
|
None -> off := (!off) + (Buffer.length buf) + 1
|
|
| Some pad ->
|
|
begin
|
|
assert ((Buffer.length buf) <= pad);
|
|
off := (!off) + pad
|
|
end
|
|
end;
|
|
Buffer.contents buf
|
|
in
|
|
let bump i =
|
|
assert (!is_open);
|
|
off := (!off) + i
|
|
in
|
|
{
|
|
asm_seek = (fun i -> off := i);
|
|
asm_get_u32 = (fun _ -> get_word_as_int 4);
|
|
asm_get_u16 = (fun _ -> get_word_as_int 2);
|
|
asm_get_u8 = (fun _ -> get_word_as_int 1);
|
|
asm_get_uleb =
|
|
begin
|
|
fun _ ->
|
|
let rec loop result shift =
|
|
let byte = arr.{!off} in
|
|
incr off;
|
|
let result = result lor ((byte land 0x7f) lsl shift) in
|
|
if (byte land 0x80) = 0
|
|
then result
|
|
else loop result (shift+7)
|
|
in
|
|
loop 0 0
|
|
end;
|
|
asm_get_zstr = (fun _ -> get_zstr_padded None);
|
|
asm_get_zstr_padded = (fun pad -> get_zstr_padded (Some pad));
|
|
asm_get_off = (fun _ -> !off);
|
|
asm_adv = bump;
|
|
asm_adv_u32 = (fun _ -> bump 4);
|
|
asm_adv_u16 = (fun _ -> bump 2);
|
|
asm_adv_u8 = (fun _ -> bump 1);
|
|
asm_adv_zstr = (fun _ -> while arr.{!off} != 0
|
|
do incr off done);
|
|
asm_close = (fun _ ->
|
|
assert (!is_open);
|
|
Unix.close fd;
|
|
is_open := false)
|
|
}
|
|
;;
|
|
|
|
|
|
(*
|
|
* Metadata note-section encoding / decoding.
|
|
*
|
|
* Since the only object format that defines a "note" section at all is
|
|
* ELF, we model the contents of the metadata section on ELF's
|
|
* notes. But the same blob of data is stuck into PE and Mach-O files
|
|
* too.
|
|
*
|
|
* The format is essentially just the ELF note format:
|
|
*
|
|
* <un-padded-size-of-name:u32>
|
|
* <size-of-desc:u32>
|
|
* <type-code=0:u32>
|
|
* <name="rust":zstr>
|
|
* <0-pad to 4-byte boundary>
|
|
* <n=meta-count:u32>
|
|
* <k1:zstr> <v1:zstr>
|
|
* ...
|
|
* <kn:zstr> <vn:zstr>
|
|
* <0-pad to 4-byte boundary>
|
|
*
|
|
*)
|
|
let note_rust_frags (meta:(Ast.ident * string) array) : frag =
|
|
let desc_fixup = new_fixup ".rust.note metadata" in
|
|
let desc =
|
|
DEF (desc_fixup,
|
|
SEQ [|
|
|
WORD (TY_u32, IMM (Int64.of_int (Array.length meta)));
|
|
SEQ (Array.map
|
|
(fun (k,v) -> SEQ [| ZSTRING k; ZSTRING v; |])
|
|
meta);
|
|
ALIGN_FILE (4, MARK) |])
|
|
in
|
|
let name = "rust" in
|
|
let ty = 0L in
|
|
let padded_name = SEQ [| ZSTRING name;
|
|
ALIGN_FILE (4, MARK) |]
|
|
in
|
|
let name_sz = IMM (Int64.of_int ((String.length name) + 1)) in
|
|
SEQ [| WORD (TY_u32, name_sz);
|
|
WORD (TY_u32, F_SZ desc_fixup);
|
|
WORD (TY_u32, IMM ty);
|
|
padded_name;
|
|
desc;|]
|
|
;;
|
|
|
|
let read_rust_note (ar:asm_reader) : (Ast.ident * string) array =
|
|
ar.asm_adv_u32 ();
|
|
ar.asm_adv_u32 ();
|
|
assert ((ar.asm_get_u32 ()) = 0);
|
|
let rust_name = ar.asm_get_zstr_padded 8 in
|
|
assert (rust_name = "rust");
|
|
let n = ar.asm_get_u32() in
|
|
let meta = Queue.create () in
|
|
for i = 1 to n
|
|
do
|
|
let k = ar.asm_get_zstr() in
|
|
let v = ar.asm_get_zstr() in
|
|
Queue.add (k,v) meta
|
|
done;
|
|
queue_to_arr meta
|
|
;;
|
|
|
|
(*
|
|
* Local Variables:
|
|
* fill-column: 78;
|
|
* indent-tabs-mode: nil
|
|
* buffer-file-coding-system: utf-8-unix
|
|
* compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
|
|
* End:
|
|
*)
|