717 lines
25 KiB
OCaml
717 lines
25 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Pierre Chambart, OCamlPro *)
|
|
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
|
(* *)
|
|
(* Copyright 2013--2016 OCamlPro SAS *)
|
|
(* Copyright 2014--2016 Jane Street Group LLC *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file ../LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
|
|
|
|
module U = Flambda_utils
|
|
|
|
type 'a boxed_int =
|
|
| Int32 : int32 boxed_int
|
|
| Int64 : int64 boxed_int
|
|
| Nativeint : nativeint boxed_int
|
|
|
|
type value_string = {
|
|
(* CR-soon mshinwell: use variant *)
|
|
contents : string option; (* None if unknown or mutable *)
|
|
size : int;
|
|
}
|
|
|
|
type value_float_array_contents =
|
|
| Contents of float option array
|
|
| Unknown_or_mutable
|
|
|
|
type value_float_array = {
|
|
contents : value_float_array_contents;
|
|
size : int;
|
|
}
|
|
|
|
type unknown_because_of =
|
|
| Unresolved_symbol of Symbol.t
|
|
| Other
|
|
|
|
type t = {
|
|
descr : descr;
|
|
var : Variable.t option;
|
|
symbol : (Symbol.t * int option) option;
|
|
}
|
|
|
|
and descr =
|
|
| Value_block of Tag.t * t array
|
|
| Value_int of int
|
|
| Value_char of char
|
|
| Value_constptr of int
|
|
| Value_float of float
|
|
| Value_boxed_int : 'a boxed_int * 'a -> descr
|
|
| Value_set_of_closures of value_set_of_closures
|
|
| Value_closure of value_closure
|
|
| Value_string of value_string
|
|
| Value_float_array of value_float_array
|
|
| Value_unknown of unknown_because_of
|
|
| Value_bottom
|
|
| Value_extern of Export_id.t
|
|
| Value_symbol of Symbol.t
|
|
| Value_unresolved of Symbol.t (* No description was found for this symbol *)
|
|
|
|
and value_closure = {
|
|
set_of_closures : t;
|
|
closure_id : Closure_id.t;
|
|
}
|
|
|
|
and value_set_of_closures = {
|
|
function_decls : Flambda.function_declarations;
|
|
bound_vars : t Var_within_closure.Map.t;
|
|
invariant_params : Variable.Set.t Variable.Map.t lazy_t;
|
|
size : int option Variable.Map.t lazy_t;
|
|
specialised_args : Flambda.specialised_to Variable.Map.t;
|
|
freshening : Freshening.Project_var.t;
|
|
}
|
|
|
|
let descr t = t.descr
|
|
|
|
let print_value_set_of_closures ppf
|
|
{ function_decls = { funs }; invariant_params; freshening; _ } =
|
|
Format.fprintf ppf "(set_of_closures:@ %a invariant_params=%a freshening=%a)"
|
|
(fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs
|
|
(Variable.Map.print Variable.Set.print) (Lazy.force invariant_params)
|
|
Freshening.Project_var.print freshening
|
|
|
|
let rec print_descr ppf = function
|
|
| Value_int i -> Format.pp_print_int ppf i
|
|
| Value_char c -> Format.fprintf ppf "%c" c
|
|
| Value_constptr i -> Format.fprintf ppf "%ia" i
|
|
| Value_block (tag,fields) ->
|
|
let p ppf fields =
|
|
Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in
|
|
Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields
|
|
| Value_unknown reason ->
|
|
begin match reason with
|
|
| Unresolved_symbol symbol ->
|
|
Format.fprintf ppf "?(due to unresolved symbol '%a')" Symbol.print symbol
|
|
| Other -> Format.fprintf ppf "?"
|
|
end;
|
|
| Value_bottom -> Format.fprintf ppf "bottom"
|
|
| Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id
|
|
| Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym
|
|
| Value_closure { set_of_closures; closure_id; } ->
|
|
Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id
|
|
print set_of_closures
|
|
| Value_set_of_closures set_of_closures ->
|
|
print_value_set_of_closures ppf set_of_closures
|
|
| Value_unresolved sym ->
|
|
Format.fprintf ppf "(unresolved %a)" Symbol.print sym
|
|
| Value_float f -> Format.pp_print_float ppf f
|
|
| Value_string { contents; size } -> begin
|
|
match contents with
|
|
| None ->
|
|
Format.fprintf ppf "string %i" size
|
|
| Some s ->
|
|
let s =
|
|
if size > 10
|
|
then String.sub s 0 8 ^ "..."
|
|
else s
|
|
in
|
|
Format.fprintf ppf "string %i %S" size s
|
|
end
|
|
| Value_float_array float_array ->
|
|
begin match float_array.contents with
|
|
| Unknown_or_mutable ->
|
|
Format.fprintf ppf "float_array %i" float_array.size
|
|
| Contents _ ->
|
|
Format.fprintf ppf "float_array_imm %i" float_array.size
|
|
end
|
|
| Value_boxed_int (t, i) ->
|
|
match t with
|
|
| Int32 -> Format.fprintf ppf "%li" i
|
|
| Int64 -> Format.fprintf ppf "%Li" i
|
|
| Nativeint -> Format.fprintf ppf "%ni" i
|
|
|
|
and print ppf { descr; var; symbol; } =
|
|
let print ppf = function
|
|
| None -> Symbol.print_opt ppf None
|
|
| Some (sym, None) -> Symbol.print ppf sym
|
|
| Some (sym, Some field) ->
|
|
Format.fprintf ppf "%a.(%i)" Symbol.print sym field
|
|
in
|
|
Format.fprintf ppf "{ descr=%a var=%a symbol=%a }"
|
|
print_descr descr
|
|
Variable.print_opt var
|
|
print symbol
|
|
|
|
let approx descr = { descr; var = None; symbol = None }
|
|
|
|
let augment_with_variable t var = { t with var = Some var }
|
|
let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) }
|
|
let augment_with_symbol_field t symbol field =
|
|
match t.symbol with
|
|
| None -> { t with symbol = Some (symbol, Some field) }
|
|
| Some _ -> t
|
|
let replace_description t descr = { t with descr }
|
|
|
|
let value_unknown reason = approx (Value_unknown reason)
|
|
let value_int i = approx (Value_int i)
|
|
let value_char i = approx (Value_char i)
|
|
let value_constptr i = approx (Value_constptr i)
|
|
let value_float f = approx (Value_float f)
|
|
let value_boxed_int bi i = approx (Value_boxed_int (bi,i))
|
|
|
|
let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol
|
|
value_set_of_closures closure_id =
|
|
let approx_set_of_closures =
|
|
{ descr = Value_set_of_closures value_set_of_closures;
|
|
var = set_of_closures_var;
|
|
symbol = Misc.may_map (fun s -> s, None) set_of_closures_symbol;
|
|
}
|
|
in
|
|
let value_closure =
|
|
{ set_of_closures = approx_set_of_closures;
|
|
closure_id;
|
|
}
|
|
in
|
|
{ descr = Value_closure value_closure;
|
|
var = closure_var;
|
|
symbol = None;
|
|
}
|
|
|
|
let create_value_set_of_closures
|
|
~(function_decls : Flambda.function_declarations) ~bound_vars
|
|
~invariant_params ~specialised_args ~freshening =
|
|
let size =
|
|
lazy (
|
|
let functions = Variable.Map.keys function_decls.funs in
|
|
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
|
|
let params = Variable.Set.of_list function_decl.params in
|
|
let free_vars =
|
|
Variable.Set.diff
|
|
(Variable.Set.diff function_decl.free_variables params)
|
|
functions
|
|
in
|
|
let num_free_vars = Variable.Set.cardinal free_vars in
|
|
let max_size =
|
|
Inlining_cost.maximum_interesting_size_of_function_body
|
|
num_free_vars
|
|
in
|
|
Inlining_cost.lambda_smaller' function_decl.body ~than:max_size)
|
|
function_decls.funs)
|
|
in
|
|
{ function_decls;
|
|
bound_vars;
|
|
invariant_params;
|
|
size;
|
|
specialised_args;
|
|
freshening;
|
|
}
|
|
|
|
let update_freshening_of_value_set_of_closures value_set_of_closures
|
|
~freshening =
|
|
(* CR-someday mshinwell: We could maybe check that [freshening] is
|
|
reasonable. *)
|
|
{ value_set_of_closures with freshening; }
|
|
|
|
let value_set_of_closures ?set_of_closures_var value_set_of_closures =
|
|
{ descr = Value_set_of_closures value_set_of_closures;
|
|
var = set_of_closures_var;
|
|
symbol = None;
|
|
}
|
|
|
|
let value_block t b = approx (Value_block (t, b))
|
|
let value_extern ex = approx (Value_extern ex)
|
|
let value_symbol sym =
|
|
{ (approx (Value_symbol sym)) with symbol = Some (sym, None) }
|
|
let value_bottom = approx Value_bottom
|
|
let value_unresolved sym = approx (Value_unresolved sym)
|
|
|
|
let value_string size contents = approx (Value_string {size; contents })
|
|
let value_mutable_float_array ~size =
|
|
approx (Value_float_array { contents = Unknown_or_mutable; size; } )
|
|
let value_immutable_float_array contents =
|
|
let size = Array.length contents in
|
|
approx (Value_float_array { contents = Contents contents; size; } )
|
|
|
|
let name_expr_fst (named, thing) ~name =
|
|
(Flambda_utils.name_expr named ~name), thing
|
|
|
|
let make_const_int_named n : Flambda.named * t =
|
|
Const (Int n), value_int n
|
|
let make_const_int (n : int) =
|
|
let name =
|
|
match n with
|
|
| 0 -> "const_zero"
|
|
| 1 -> "const_one"
|
|
| _ -> "const_int"
|
|
in
|
|
name_expr_fst (make_const_int_named n) ~name
|
|
|
|
let make_const_char_named n : Flambda.named * t =
|
|
Const (Char n), value_char n
|
|
let make_const_char n =
|
|
name_expr_fst (make_const_char_named n) ~name:"const_char"
|
|
|
|
let make_const_ptr_named n : Flambda.named * t =
|
|
Const (Const_pointer n), value_constptr n
|
|
let make_const_ptr (n : int) =
|
|
let name =
|
|
match n with
|
|
| 0 -> "const_ptr_zero"
|
|
| 1 -> "const_ptr_one"
|
|
| _ -> "const_ptr"
|
|
in
|
|
name_expr_fst (make_const_ptr_named n) ~name
|
|
|
|
let make_const_bool_named b : Flambda.named * t =
|
|
make_const_ptr_named (if b then 1 else 0)
|
|
let make_const_bool b =
|
|
name_expr_fst (make_const_bool_named b) ~name:"const_bool"
|
|
|
|
let make_const_float_named f : Flambda.named * t =
|
|
Allocated_const (Float f), value_float f
|
|
let make_const_float f =
|
|
name_expr_fst (make_const_float_named f) ~name:"const_float"
|
|
|
|
let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi)
|
|
: Flambda.named * t =
|
|
let c : Allocated_const.t =
|
|
match t with
|
|
| Int32 -> Int32 i
|
|
| Int64 -> Int64 i
|
|
| Nativeint -> Nativeint i
|
|
in
|
|
Allocated_const c, value_boxed_int t i
|
|
let make_const_boxed_int t i =
|
|
name_expr_fst (make_const_boxed_int_named t i) ~name:"const_boxed_int"
|
|
|
|
type simplification_summary =
|
|
| Nothing_done
|
|
| Replaced_term
|
|
|
|
type simplification_result = Flambda.t * simplification_summary * t
|
|
type simplification_result_named = Flambda.named * simplification_summary * t
|
|
|
|
let simplify t (lam : Flambda.t) : simplification_result =
|
|
if Effect_analysis.no_effects lam then
|
|
match t.descr with
|
|
| Value_int n ->
|
|
let const, approx = make_const_int n in
|
|
const, Replaced_term, approx
|
|
| Value_char n ->
|
|
let const, approx = make_const_char n in
|
|
const, Replaced_term, approx
|
|
| Value_constptr n ->
|
|
let const, approx = make_const_ptr n in
|
|
const, Replaced_term, approx
|
|
| Value_float f ->
|
|
let const, approx = make_const_float f in
|
|
const, Replaced_term, approx
|
|
| Value_boxed_int (t, i) ->
|
|
let const, approx = make_const_boxed_int t i in
|
|
const, Replaced_term, approx
|
|
| Value_symbol sym ->
|
|
U.name_expr (Symbol sym) ~name:"symbol", Replaced_term, t
|
|
| Value_string _ | Value_float_array _
|
|
| Value_block _ | Value_set_of_closures _ | Value_closure _
|
|
| Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ ->
|
|
lam, Nothing_done, t
|
|
else
|
|
lam, Nothing_done, t
|
|
|
|
let simplify_named t (named : Flambda.named) : simplification_result_named =
|
|
if Effect_analysis.no_effects_named named then
|
|
match t.descr with
|
|
| Value_int n ->
|
|
let const, approx = make_const_int_named n in
|
|
const, Replaced_term, approx
|
|
| Value_char n ->
|
|
let const, approx = make_const_char_named n in
|
|
const, Replaced_term, approx
|
|
| Value_constptr n ->
|
|
let const, approx = make_const_ptr_named n in
|
|
const, Replaced_term, approx
|
|
| Value_float f ->
|
|
let const, approx = make_const_float_named f in
|
|
const, Replaced_term, approx
|
|
| Value_boxed_int (t, i) ->
|
|
let const, approx = make_const_boxed_int_named t i in
|
|
const, Replaced_term, approx
|
|
| Value_symbol sym ->
|
|
Symbol sym, Replaced_term, t
|
|
| Value_string _ | Value_float_array _
|
|
| Value_block _ | Value_set_of_closures _ | Value_closure _
|
|
| Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ ->
|
|
named, Nothing_done, t
|
|
else
|
|
named, Nothing_done, t
|
|
|
|
(* CR-soon mshinwell: bad name. This function and its call site in
|
|
[Inline_and_simplify] is also messy. *)
|
|
let simplify_var t : (Flambda.named * t) option =
|
|
match t.descr with
|
|
| Value_int n -> Some (make_const_int_named n)
|
|
| Value_char n -> Some (make_const_char_named n)
|
|
| Value_constptr n -> Some (make_const_ptr_named n)
|
|
| Value_float f -> Some (make_const_float_named f)
|
|
| Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i)
|
|
| Value_symbol sym -> Some (Symbol sym, t)
|
|
| Value_string _ | Value_float_array _
|
|
| Value_block _ | Value_set_of_closures _ | Value_closure _
|
|
| Value_unknown _ | Value_bottom | Value_extern _
|
|
| Value_unresolved _ ->
|
|
match t.symbol with
|
|
| Some (sym, None) -> Some (Symbol sym, t)
|
|
| Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t)
|
|
| None -> None
|
|
|
|
let join_summaries summary ~replaced_by_var_or_symbol =
|
|
match replaced_by_var_or_symbol, summary with
|
|
| true, Nothing_done
|
|
| true, Replaced_term
|
|
| false, Replaced_term -> Replaced_term
|
|
| false, Nothing_done -> Nothing_done
|
|
|
|
let simplify_using_env t ~is_present_in_env flam =
|
|
let replaced_by_var_or_symbol, flam =
|
|
match t.var with
|
|
| Some var when is_present_in_env var -> true, Flambda.Var var
|
|
| _ ->
|
|
match t.symbol with
|
|
| Some (sym, None) -> true,
|
|
U.name_expr (Symbol sym) ~name:"symbol"
|
|
| Some (sym, Some field) ->
|
|
true, U.name_expr (Read_symbol_field (sym, field)) ~name:"symbol_field"
|
|
| None -> false, flam
|
|
in
|
|
let const, summary, approx = simplify t flam in
|
|
const, join_summaries summary ~replaced_by_var_or_symbol, approx
|
|
|
|
let simplify_named_using_env t ~is_present_in_env named =
|
|
let replaced_by_var_or_symbol, named =
|
|
match t.var with
|
|
| Some var when is_present_in_env var ->
|
|
true, Flambda.Expr (Var var)
|
|
| _ ->
|
|
match t.symbol with
|
|
| Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named)
|
|
| Some (sym, Some field) ->
|
|
true, Flambda.Read_symbol_field (sym, field)
|
|
| None -> false, named
|
|
in
|
|
let const, summary, approx = simplify_named t named in
|
|
const, join_summaries summary ~replaced_by_var_or_symbol, approx
|
|
|
|
let simplify_var_to_var_using_env t ~is_present_in_env =
|
|
match t.var with
|
|
| Some var when is_present_in_env var -> Some var
|
|
| _ -> None
|
|
|
|
let known t =
|
|
match t.descr with
|
|
| Value_unresolved _
|
|
| Value_unknown _ -> false
|
|
| Value_string _ | Value_float_array _
|
|
| Value_bottom | Value_block _ | Value_int _ | Value_char _
|
|
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
|
|
| Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true
|
|
|
|
let useful t =
|
|
match t.descr with
|
|
| Value_unresolved _ | Value_unknown _ | Value_bottom -> false
|
|
| Value_string _ | Value_float_array _ | Value_block _ | Value_int _
|
|
| Value_char _ | Value_constptr _ | Value_set_of_closures _
|
|
| Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _
|
|
| Value_symbol _ -> true
|
|
|
|
let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts
|
|
|
|
let is_definitely_immutable t =
|
|
match t.descr with
|
|
| Value_string { contents = Some _ }
|
|
| Value_block _ | Value_int _ | Value_char _ | Value_constptr _
|
|
| Value_set_of_closures _ | Value_float _ | Value_boxed_int _
|
|
| Value_closure _ -> true
|
|
| Value_string { contents = None } | Value_float_array _
|
|
| Value_unresolved _ | Value_unknown _ | Value_bottom -> false
|
|
| Value_extern _ | Value_symbol _ -> assert false
|
|
|
|
type get_field_result =
|
|
| Ok of t
|
|
| Unreachable
|
|
|
|
let get_field t ~field_index:i : get_field_result =
|
|
match t.descr with
|
|
| Value_block (_tag, fields) ->
|
|
if i >= 0 && i < Array.length fields then begin
|
|
Ok fields.(i)
|
|
end else begin
|
|
(* This (unfortunately) cannot be a fatal error; it can happen if a
|
|
.cmx file is missing. However for debugging the compiler this can
|
|
be a useful point to put a [Misc.fatal_errorf]. *)
|
|
Unreachable
|
|
end
|
|
(* CR-someday mshinwell: This should probably return Unreachable in more
|
|
cases. I added a couple more. *)
|
|
| Value_bottom
|
|
| Value_int _ | Value_char _ | Value_constptr _ ->
|
|
(* Something seriously wrong is happening: either the user is doing
|
|
something exceptionally unsafe, or it is an unreachable branch.
|
|
We consider this as unreachable and mark the result accordingly. *)
|
|
Ok value_bottom
|
|
| Value_float_array _ ->
|
|
(* For the moment we return "unknown" even for immutable arrays, since
|
|
it isn't possible for user code to project from an immutable array. *)
|
|
(* CR-someday mshinwell: If Leo's array's patch lands, then we can
|
|
change this, although it's probably not Pfield that is used to
|
|
do the projection. *)
|
|
Ok (value_unknown Other)
|
|
| Value_string _ | Value_float _ | Value_boxed_int _ ->
|
|
(* The user is doing something unsafe. *)
|
|
Unreachable
|
|
| Value_set_of_closures _ | Value_closure _
|
|
(* This is used by [CamlinternalMod]. *)
|
|
| Value_symbol _ | Value_extern _ ->
|
|
(* These should have been resolved. *)
|
|
Ok (value_unknown Other)
|
|
| Value_unknown reason ->
|
|
Ok (value_unknown reason)
|
|
| Value_unresolved sym ->
|
|
(* We don't know anything, but we must remember that it comes
|
|
from another compilation unit in case it contains a closure. *)
|
|
Ok (value_unresolved sym)
|
|
|
|
type checked_approx_for_block =
|
|
| Wrong
|
|
| Ok of Tag.t * t array
|
|
|
|
let check_approx_for_block t =
|
|
match t.descr with
|
|
| Value_block (tag, fields) ->
|
|
Ok (tag, fields)
|
|
| Value_bottom
|
|
| Value_int _ | Value_char _ | Value_constptr _
|
|
| Value_float_array _
|
|
| Value_string _ | Value_float _ | Value_boxed_int _
|
|
| Value_set_of_closures _ | Value_closure _
|
|
| Value_symbol _ | Value_extern _
|
|
| Value_unknown _
|
|
| Value_unresolved _ ->
|
|
Wrong
|
|
|
|
let descrs approxs = List.map (fun v -> v.descr) approxs
|
|
|
|
let equal_boxed_int (type t1) (type t2)
|
|
(bi1:t1 boxed_int) (i1:t1)
|
|
(bi2:t2 boxed_int) (i2:t2) =
|
|
match bi1, bi2 with
|
|
| Int32, Int32 -> Int32.equal i1 i2
|
|
| Int64, Int64 -> Int64.equal i1 i2
|
|
| Nativeint, Nativeint -> Nativeint.equal i1 i2
|
|
| _ -> false
|
|
|
|
(* Closures and set of closures descriptions cannot be merged.
|
|
|
|
let f x =
|
|
let g y -> x + y in
|
|
g
|
|
in
|
|
let v =
|
|
if ...
|
|
then f 1
|
|
else f 2
|
|
in
|
|
v 3
|
|
|
|
The approximation for [f 1] and [f 2] could both contain the
|
|
description of [g]. But if [f] where inlined, a new [g] would
|
|
be created in each branch, leading to incompatible description.
|
|
And we must never make the descrition for a function less
|
|
precise that it used to be: its information are needed for
|
|
rewriting [Project_var] and [Project_closure] constructions
|
|
in [Flambdainline.loop]
|
|
*)
|
|
let rec meet_descr d1 d2 = match d1, d2 with
|
|
| Value_int i, Value_int j when i = j ->
|
|
d1
|
|
| Value_constptr i, Value_constptr j when i = j ->
|
|
d1
|
|
| Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 ->
|
|
d1
|
|
| Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 ->
|
|
d1
|
|
| Value_float i, Value_float j when i = j ->
|
|
d1
|
|
| Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when
|
|
equal_boxed_int bi1 i1 bi2 i2 ->
|
|
d1
|
|
| Value_block (tag1, a1), Value_block (tag2, a2)
|
|
when tag1 = tag2 && Array.length a1 = Array.length a2 ->
|
|
Value_block (tag1, Array.mapi (fun i v -> meet v a2.(i)) a1)
|
|
| _ -> Value_unknown Other
|
|
|
|
and meet a1 a2 =
|
|
match a1, a2 with
|
|
| { descr = Value_bottom }, a
|
|
| a, { descr = Value_bottom } -> a
|
|
| _ ->
|
|
let var =
|
|
match a1.var, a2.var with
|
|
| None, _ | _, None -> None
|
|
| Some v1, Some v2 ->
|
|
if Variable.equal v1 v2
|
|
then Some v1
|
|
else None
|
|
in
|
|
let symbol =
|
|
match a1.symbol, a2.symbol with
|
|
| None, _ | _, None -> None
|
|
| Some (v1, field1), Some (v2, field2) ->
|
|
if Symbol.equal v1 v2
|
|
then match field1, field2 with
|
|
| None, None -> a1.symbol
|
|
| Some f1, Some f2 when f1 = f2 ->
|
|
a1.symbol
|
|
| _ -> None
|
|
else None
|
|
in
|
|
{ descr = meet_descr a1.descr a2.descr;
|
|
var;
|
|
symbol }
|
|
|
|
(* Given a set-of-closures approximation and a closure ID, apply any
|
|
freshening specified in the approximation to the closure ID, and return
|
|
that new closure ID. A fatal error is produced if the new closure ID
|
|
does not correspond to a function declaration in the given approximation. *)
|
|
let freshen_and_check_closure_id
|
|
(value_set_of_closures : value_set_of_closures) closure_id =
|
|
let closure_id =
|
|
Freshening.Project_var.apply_closure_id
|
|
value_set_of_closures.freshening closure_id
|
|
in
|
|
try
|
|
ignore (Flambda_utils.find_declaration closure_id
|
|
value_set_of_closures.function_decls);
|
|
closure_id
|
|
with Not_found ->
|
|
Misc.fatal_error (Format.asprintf
|
|
"Function %a not found in the set of closures@ %a@.%a@."
|
|
Closure_id.print closure_id
|
|
print_value_set_of_closures value_set_of_closures
|
|
Flambda.print_function_declarations value_set_of_closures.function_decls)
|
|
|
|
type checked_approx_for_set_of_closures =
|
|
| Wrong
|
|
| Unresolved of Symbol.t
|
|
| Unknown
|
|
| Unknown_because_of_unresolved_symbol of Symbol.t
|
|
| Ok of Variable.t option * value_set_of_closures
|
|
|
|
let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures =
|
|
match t.descr with
|
|
| Value_unresolved symbol -> Unresolved symbol
|
|
| Value_unknown (Unresolved_symbol symbol) ->
|
|
Unknown_because_of_unresolved_symbol symbol
|
|
| Value_set_of_closures value_set_of_closures ->
|
|
(* Note that [var] might be [None]; we might be reaching the set of
|
|
closures via approximations only, with the variable originally bound
|
|
to the set now out of scope. *)
|
|
Ok (t.var, value_set_of_closures)
|
|
| Value_closure _ | Value_block _ | Value_int _ | Value_char _
|
|
| Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _
|
|
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
|
|
| Value_symbol _ ->
|
|
Wrong
|
|
|
|
type strict_checked_approx_for_set_of_closures =
|
|
| Wrong
|
|
| Ok of Variable.t option * value_set_of_closures
|
|
|
|
let strict_check_approx_for_set_of_closures t
|
|
: strict_checked_approx_for_set_of_closures =
|
|
match check_approx_for_set_of_closures t with
|
|
| Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures)
|
|
| Wrong | Unresolved _
|
|
| Unknown | Unknown_because_of_unresolved_symbol _ -> Wrong
|
|
|
|
type checked_approx_for_closure_allowing_unresolved =
|
|
| Wrong
|
|
| Unresolved of Symbol.t
|
|
| Unknown
|
|
| Unknown_because_of_unresolved_symbol of Symbol.t
|
|
| Ok of value_closure * Variable.t option
|
|
* Symbol.t option * value_set_of_closures
|
|
|
|
let check_approx_for_closure_allowing_unresolved t
|
|
: checked_approx_for_closure_allowing_unresolved =
|
|
match t.descr with
|
|
| Value_closure value_closure ->
|
|
begin match value_closure.set_of_closures.descr with
|
|
| Value_set_of_closures value_set_of_closures ->
|
|
let symbol = match value_closure.set_of_closures.symbol with
|
|
| Some (symbol, None) -> Some symbol
|
|
| None | Some (_, Some _) -> None
|
|
in
|
|
Ok (value_closure, value_closure.set_of_closures.var,
|
|
symbol, value_set_of_closures)
|
|
| Value_unresolved _
|
|
| Value_closure _ | Value_block _ | Value_int _ | Value_char _
|
|
| Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _
|
|
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
|
|
| Value_symbol _ ->
|
|
Wrong
|
|
end
|
|
| Value_unknown (Unresolved_symbol symbol) ->
|
|
Unknown_because_of_unresolved_symbol symbol
|
|
| Value_unresolved symbol -> Unresolved symbol
|
|
| Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _
|
|
| Value_constptr _ | Value_float _ | Value_boxed_int _
|
|
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
|
|
| Value_symbol _ ->
|
|
Wrong
|
|
(* CR-soon mshinwell: This should be unwound once the reason for a value
|
|
being unknown can be correctly propagated through the export info. *)
|
|
| Value_unknown Other -> Unknown
|
|
|
|
type checked_approx_for_closure =
|
|
| Wrong
|
|
| Ok of value_closure * Variable.t option
|
|
* Symbol.t option * value_set_of_closures
|
|
|
|
let check_approx_for_closure t : checked_approx_for_closure =
|
|
match check_approx_for_closure_allowing_unresolved t with
|
|
| Ok (value_closure, set_of_closures_var, set_of_closures_symbol,
|
|
value_set_of_closures) ->
|
|
Ok (value_closure, set_of_closures_var, set_of_closures_symbol,
|
|
value_set_of_closures)
|
|
| Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_symbol _ ->
|
|
Wrong
|
|
|
|
let approx_for_bound_var value_set_of_closures var =
|
|
try
|
|
Var_within_closure.Map.find var value_set_of_closures.bound_vars
|
|
with
|
|
| Not_found ->
|
|
Misc.fatal_errorf "The set-of-closures approximation %a@ does not \
|
|
bind the variable %a@.%s@."
|
|
print_value_set_of_closures value_set_of_closures
|
|
Var_within_closure.print var
|
|
(Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))
|
|
|
|
let check_approx_for_float t : float option =
|
|
match t.descr with
|
|
| Value_float f -> Some f
|
|
| Value_unresolved _
|
|
| Value_unknown _ | Value_string _ | Value_float_array _
|
|
| Value_bottom | Value_block _ | Value_int _ | Value_char _
|
|
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
|
|
| Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
|
|
None
|