Skip to content

Compiler: refactor constants #787

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
hhugo merged 1 commit into from
May 1, 2019
+34 −45
Merged

Compiler: refactor constants #787

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
40 changes: 17 additions & 23 deletions compiler/lib/ocaml_compiler.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,39 +18,33 @@

open Stdlib

let rec obj_of_const =
let rec constant_of_const : _ -> Code.constant =
let open Lambda in
let open Asttypes in
function
| Const_base (Const_int i) -> Obj.repr i
| Const_base (Const_char c) -> Obj.repr c
| Const_base (Const_string (s,_)) -> Obj.repr s
| Const_base (Const_float s) -> Obj.repr (float_of_string s)
| Const_base (Const_int32 i) -> Obj.repr i
| Const_base (Const_int64 i) -> Obj.repr i
| Const_base (Const_nativeint i) -> Obj.repr i
| Const_immstring s -> Obj.repr s
| Const_base (Const_int i) -> Int (Int32.of_int i)
| Const_base (Const_char c) -> Int (Int32.of_int (Char.code c))
| Const_base (Const_string (s,_)) -> String s
| Const_base (Const_float s) -> Float (float_of_string s)
| Const_base (Const_int32 i) -> Int i
| Const_base (Const_int64 i) -> Int64 i
| Const_base (Const_nativeint i) -> Int (Nativeint.to_int32 i)
| Const_immstring s -> IString s
| Const_float_array sl ->
let l = List.map ~f:float_of_string sl in
Obj.repr (Array.of_list l)
let l = List.map ~f:(fun f -> Code.Float (float_of_string f)) sl in
Tuple (Obj.double_array_tag, Array.of_list l)
#ifdef BUCKLESCRIPT
| Const_pointer (i,_) ->
Obj.repr i
Int (Int32.of_int i)
| Const_block (tag,_,l) ->
let b = Obj.new_block tag (List.length l) in
List.iteri (fun i x ->
Obj.set_field b i (obj_of_const x)
) l;
b
let l = Array.of_list (List.map l ~f:constant_of_const) in
Tuple (tag, l)
#else
| Const_pointer i ->
Obj.repr i
Int (Int32.of_int i)
| Const_block (tag,l) ->
let b = Obj.new_block tag (List.length l) in
List.iteri ~f:(fun i x ->
Obj.set_field b i (obj_of_const x)
) l;
b
let l = Array.of_list (List.map l ~f:constant_of_const) in
Tuple (tag, l)
#endif

let rec find_loc_in_summary ident' = function
Expand Down
2 changes: 1 addition & 1 deletion compiler/lib/ocaml_compiler.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,7 @@
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)

val obj_of_const : Lambda.structured_constant -> Obj.t
val constant_of_const : Lambda.structured_constant -> Code.constant

val find_loc_in_summary : Ident.t -> Env.summary -> Location.t option

Expand Down
37 changes: 16 additions & 21 deletions compiler/lib/parse_bytecode.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -333,7 +333,7 @@ end
module Constants : sig
val parse : Obj.t -> Code.constant

val inlined : Obj.t -> bool
val inlined : Code.constant -> bool
end = struct
let same_custom x y = Obj.field x 0 == Obj.field (Obj.repr y) 0

Expand Down Expand Up @@ -376,12 +376,13 @@ end = struct
if i' <> i then warn_overflow (Printf.sprintf "0x%x (%d)" i i) i32;
Int i32

let inlined x =
(not (Obj.is_block x))
||
let tag = Obj.tag x in
tag = Obj.double_tag
|| (tag = Obj.custom_tag && (same_custom x 0l || same_custom x 0n))
let inlined = function
| String _ | IString _ -> false
| Float _ -> true
| Float_array _ -> false
| Int64 _ -> false
| Tuple _ -> false
| Int _ -> true
end

(* Globals *)
Expand All @@ -391,7 +392,7 @@ type globals =
; mutable is_exported : bool array
; mutable named_value : string option array
; mutable override : (Var.t -> Code.instr list -> Var.t * Code.instr list) option array
; constants : Obj.t array
; constants : Code.constant array
; primitives : string array }

let make_globals size constants primitives =
Expand Down Expand Up @@ -658,7 +659,7 @@ let get_global state instrs i =
if i < Array.length g.constants && Constants.inlined g.constants.(i)
then
let x, state = State.fresh_var state in
let cst = Constants.parse g.constants.(i) in
let cst = g.constants.(i) in
x, state, Let (x, Constant cst) :: instrs
else (
g.is_const.(i) <- true;
Expand Down Expand Up @@ -2049,6 +2050,7 @@ let from_exe
let code = really_input_string ic code_size in
ignore (seek_section toc ic "DATA");
let init_data : Obj.t array = input_value ic in
let init_data = Array.map ~f:Constants.parse init_data in
ignore (seek_section toc ic "SYMB");
let orig_symbols : Ocaml_compiler.Symtable.GlobalMap.t = input_value ic in
ignore (seek_section toc ic "CRCS");
Expand Down Expand Up @@ -2127,7 +2129,7 @@ let from_exe
match globals.vars.(i) with
| Some x when globals.is_const.(i) ->
let l = register_global globals i l in
Let (x, Constant (Constants.parse globals.constants.(i))) :: l
Let (x, Constant globals.constants.(i)) :: l
| _ -> l)
in
let body =
Expand Down Expand Up @@ -2219,7 +2221,7 @@ module Reloc = struct

type t =
{ mutable pos : int
; mutable constants : Obj.t list
; mutable constants : Code.constant list
; mutable step2_started : bool
; names : (string, int) Hashtbl.t
; primitives : (string, int) Hashtbl.t }
Expand All @@ -2239,7 +2241,7 @@ module Reloc = struct
List.iter compunit.cu_primitives ~f:(fun name ->
Hashtbl.add t.primitives name (Hashtbl.length t.primitives));
let slot_for_literal sc =
t.constants <- Ocaml_compiler.obj_of_const sc :: t.constants;
t.constants <- Ocaml_compiler.constant_of_const sc :: t.constants;
let pos = t.pos in
t.pos <- succ t.pos;
pos
Expand Down Expand Up @@ -2281,14 +2283,7 @@ module Reloc = struct
Hashtbl.iter (fun name i -> a.(i) <- name) t.primitives;
a

let constants t =
let len = List.length t.constants in
let a = Array.make len (Obj.repr 0) in
List.iteri t.constants ~f:(fun i o -> a.(len - 1 - i) <- o);
(* WARNING: [Obj.t array] is dangerous.
Make sure we don't end up with an unboxed float array. *)
assert (Obj.tag (Obj.repr a) = 0);
a
let constants t = Array.of_list (List.rev t.constants)

let make_globals t =
let primitives = primitives t in
Expand Down Expand Up @@ -2324,7 +2319,7 @@ let from_compilation_units ~includes:_ ~toplevel ~debug ~debug_data l =
match globals.named_value.(i) with
| None ->
let l = register_global globals i l in
let cst = Constants.parse globals.constants.(i) in
let cst = globals.constants.(i) in
(match cst, Code.Var.get_name x with
| (String str | IString str), None ->
Code.Var.name x (Printf.sprintf "cst_%s" str)
Expand Down