1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Pierre Chambart, OCamlPro *) 6(* Mark Shinwell and Leo White, Jane Street Europe *) 7(* *) 8(* Copyright 2013--2016 OCamlPro SAS *) 9(* Copyright 2014--2016 Jane Street Group LLC *) 10(* *) 11(* All rights reserved. This file is distributed under the terms of *) 12(* the GNU Lesser General Public License version 2.1, with the *) 13(* special exception on linking described in the file LICENSE. *) 14(* *) 15(**************************************************************************) 16 17[@@@ocaml.warning "+a-4-9-30-40-41-42"] 18 19type allocation_point = 20 | Symbol of Symbol.t 21 | Variable of Variable.t 22 23type allocated_const = 24 | Normal of Allocated_const.t 25 | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list 26 | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t 27 28type constant_defining_value = 29 | Allocated_const of allocated_const 30 | Block of Tag.t * Variable.t list 31 | Set_of_closures of Flambda.set_of_closures 32 | Project_closure of Flambda.project_closure 33 | Move_within_set_of_closures of Flambda.move_within_set_of_closures 34 | Project_var of Flambda.project_var 35 | Field of Variable.t * int 36 | Symbol_field of Symbol.t * int 37 | Const of Flambda.const 38 | Symbol of Symbol.t 39 | Variable of Variable.t 40 41type initialize_symbol_field = Variable.t option 42 43type definitions = { 44 variable : constant_defining_value Variable.Tbl.t; 45 initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; 46 symbol : Flambda.constant_defining_value Symbol.Tbl.t; 47} 48 49let print_constant_defining_value ppf = function 50 | Allocated_const (Normal const) -> Allocated_const.print ppf const 51 | Allocated_const (Array (_, _, vars)) -> 52 Format.fprintf ppf "[| %a |]" 53 (Format.pp_print_list Variable.print) vars 54 | Allocated_const (Duplicate_array (_, _, var)) -> 55 Format.fprintf ppf "dup_array(%a)" Variable.print var 56 | Block (tag, vars) -> 57 Format.fprintf ppf "[|%a: %a|]" 58 Tag.print tag 59 (Format.pp_print_list Variable.print) vars 60 | Set_of_closures set -> Flambda.print_set_of_closures ppf set 61 | Project_closure project -> Flambda.print_project_closure ppf project 62 | Move_within_set_of_closures move -> 63 Flambda.print_move_within_set_of_closures ppf move 64 | Project_var project -> Flambda.print_project_var ppf project 65 | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field 66 | Symbol_field (sym, field) -> 67 Format.fprintf ppf "%a.(%d)" Symbol.print sym field 68 | Const const -> Flambda.print_const ppf const 69 | Symbol symbol -> Symbol.print ppf symbol 70 | Variable var -> Variable.print ppf var 71 72let rec resolve_definition 73 (definitions: definitions) 74 (var: Variable.t) 75 (def: constant_defining_value) 76 ~the_dead_constant : allocation_point = 77 match def with 78 | Allocated_const _ 79 | Block _ 80 | Set_of_closures _ 81 | Project_closure _ 82 | Const _ 83 | Move_within_set_of_closures _ -> 84 Variable var 85 | Project_var {var} -> 86 fetch_variable definitions (Var_within_closure.unwrap var) 87 ~the_dead_constant 88 | Variable v -> 89 fetch_variable definitions v 90 ~the_dead_constant 91 | Symbol sym -> Symbol sym 92 | Field (v, n) -> 93 begin match fetch_variable definitions v ~the_dead_constant with 94 | Symbol s -> 95 fetch_symbol_field definitions s n ~the_dead_constant 96 | Variable v -> 97 fetch_variable_field definitions v n ~the_dead_constant 98 end 99 | Symbol_field (symbol, field) -> 100 fetch_symbol_field definitions symbol field ~the_dead_constant 101 102and fetch_variable 103 (definitions: definitions) 104 (var: Variable.t) 105 ~the_dead_constant : allocation_point = 106 match Variable.Tbl.find definitions.variable var with 107 | exception Not_found -> Variable var 108 | def -> resolve_definition definitions var def ~the_dead_constant 109 110and fetch_variable_field 111 (definitions: definitions) 112 (var: Variable.t) 113 (field: int) 114 ~the_dead_constant : allocation_point = 115 match Variable.Tbl.find definitions.variable var with 116 | Block (_, fields) -> 117 begin match List.nth fields field with 118 | exception Not_found -> Symbol the_dead_constant 119 | v -> fetch_variable definitions v ~the_dead_constant 120 end 121 | exception Not_found -> 122 Misc.fatal_errorf "No definition for field access to %a" Variable.print var 123 | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> 124 (* Must have been resolved *) 125 assert false 126 | Const _ | Allocated_const _ 127 | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> 128 Symbol the_dead_constant 129 130and fetch_symbol_field 131 (definitions: definitions) 132 (sym: Symbol.t) 133 (field: int) 134 ~the_dead_constant : allocation_point = 135 match Symbol.Tbl.find definitions.symbol sym with 136 | Block (_, fields) -> 137 begin match List.nth fields field with 138 | exception Not_found -> Symbol the_dead_constant 139 | Symbol s -> Symbol s 140 | Const _ -> Symbol sym 141 end 142 | exception Not_found -> 143 begin match Symbol.Tbl.find definitions.initialize_symbol sym with 144 | fields -> 145 begin match List.nth fields field with 146 | None -> 147 Misc.fatal_errorf "Constant field access to an inconstant %a" 148 Symbol.print sym 149 | Some v -> 150 fetch_variable definitions v ~the_dead_constant 151 end 152 | exception Not_found -> 153 Misc.fatal_errorf "No definition for field access to %a" 154 Symbol.print sym 155 end 156 | Allocated_const _ | Set_of_closures _ | Project_closure _ -> 157 Symbol the_dead_constant 158 159let run variable initialize_symbol symbol ~the_dead_constant = 160 let definitions = { variable; initialize_symbol; symbol; } in 161 Variable.Tbl.fold (fun var definition result -> 162 let definition = 163 resolve_definition definitions var definition ~the_dead_constant 164 in 165 Variable.Map.add var definition result) 166 definitions.variable 167 Variable.Map.empty 168