Skip to content

Commit

Permalink
[typer] replace some mk_mono with spawn_monomorph
Browse files Browse the repository at this point in the history
This doesn't change anything yet and is just to reduce the diff of an eventual PR. The main purpose is that we now have a context.
  • Loading branch information
Simn committed Jul 7, 2020
1 parent 1f9bf47 commit 5fad913
Show file tree
Hide file tree
Showing 12 changed files with 36 additions and 27 deletions.
2 changes: 1 addition & 1 deletion src/context/abstractCast.ml
Original file line number Diff line number Diff line change
Expand Up @@ -115,7 +115,7 @@ let find_array_access_raise ctx a pl e1 e2o p =
match cfl with
| [] -> raise Not_found
| cf :: cfl ->
let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
let monos = List.map (fun _ -> spawn_monomorph ctx p) cf.cf_params in
let map t = apply_params a.a_params pl (apply_params cf.cf_params monos t) in
let check_constraints () =
List.iter2 (fun m (name,t) -> match follow t with
Expand Down
2 changes: 1 addition & 1 deletion src/context/display/displayFields.ml
Original file line number Diff line number Diff line change
Expand Up @@ -54,7 +54,7 @@ let collect_static_extensions ctx items e p =
acc
else begin
let f = { f with cf_type = opt_type f.cf_type } in
let monos = List.map (fun _ -> mk_mono()) f.cf_params in
let monos = List.map (fun _ -> spawn_monomorph ctx p) f.cf_params in
let map = apply_params f.cf_params monos in
match follow (map f.cf_type) with
| TFun((_,_,TType({t_path=["haxe";"macro"], "ExprOf"}, [t])) :: args, ret)
Expand Down
10 changes: 9 additions & 1 deletion src/context/typecore.ml
Original file line number Diff line number Diff line change
Expand Up @@ -176,6 +176,14 @@ let type_expr ?(mode=MGet) ctx e with_type = (!type_expr_ref) ~mode ctx e with_t
let unify_min ctx el = (!unify_min_ref) ctx el
let unify_min_for_type_source ctx el src = (!unify_min_for_type_source_ref) ctx el src

let spawn_monomorph' ctx p =
let mono = Monomorph.create () in
(* ctx.monomorphs.perfunction <- (mono,p) :: ctx.monomorphs.perfunction; *)
mono

let spawn_monomorph ctx p =
TMono (spawn_monomorph' ctx p)

let make_static_this c p =
let ta = mk_anon ~fields:c.cl_statics (ref (Statics c)) in
mk (TTypeExpr (TClassDecl c)) ta p
Expand All @@ -185,7 +193,7 @@ let make_static_field_access c cf t p =
mk (TField (ethis,(FStatic (c,cf)))) t p

let make_static_call ctx c cf map args t p =
let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
let monos = List.map (fun _ -> spawn_monomorph ctx p) cf.cf_params in
let map t = map (apply_params cf.cf_params monos t) in
let ef = make_static_field_access c cf (map cf.cf_type) p in
make_call ctx ef args (map t) p
Expand Down
2 changes: 1 addition & 1 deletion src/typing/calls.ml
Original file line number Diff line number Diff line change
Expand Up @@ -848,7 +848,7 @@ let array_access ctx e1 e2 mode p =
let skip_abstract = fast_eq et at in
loop ~skip_abstract at
| _, _ ->
let pt = mk_mono() in
let pt = spawn_monomorph ctx p in
let t = ctx.t.tarray pt in
begin try
unify_raise ctx et t p
Expand Down
2 changes: 1 addition & 1 deletion src/typing/fields.ml
Original file line number Diff line number Diff line change
Expand Up @@ -325,7 +325,7 @@ let rec type_field cfg ctx e i p mode =
| _ ->
display_error ctx (StringError.string_error i (string_source t) (s_type (print_context()) t ^ " has no field " ^ i)) pfield;
end;
AKExpr (mk (TField (e,FDynamic i)) (mk_mono()) p)
AKExpr (mk (TField (e,FDynamic i)) (spawn_monomorph ctx p) p)
in
let does_forward a stat =
try
Expand Down
2 changes: 1 addition & 1 deletion src/typing/generic.ml
Original file line number Diff line number Diff line change
Expand Up @@ -283,7 +283,7 @@ let rec build_generic ctx c p tl =
t
in
let r = exc_protect ctx (fun r ->
let t = mk_mono() in
let t = spawn_monomorph ctx p in
r := lazy_processing (fun() -> t);
let t0 = f() in
unify_raise ctx t0 t p;
Expand Down
6 changes: 3 additions & 3 deletions src/typing/instanceBuilder.ml
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ let build_macro_type ctx pl p =
) in
let old = ctx.ret in
let t = (match ctx.g.do_macro ctx MMacroType path field args p with
| None -> mk_mono()
| None -> spawn_monomorph ctx p
| Some _ -> ctx.ret
) in
ctx.ret <- old;
Expand All @@ -58,7 +58,7 @@ let build_macro_build ctx c pl cfl p =
let old = ctx.ret,ctx.get_build_infos in
ctx.get_build_infos <- (fun() -> Some (TClassDecl c, pl, cfl));
let t = (match ctx.g.do_macro ctx MMacroType path field args p with
| None -> mk_mono()
| None -> spawn_monomorph ctx p
| Some _ -> ctx.ret
) in
ctx.ret <- fst old;
Expand All @@ -74,7 +74,7 @@ let build_instance ctx mtype p =
if ctx.pass > PBuildClass then ignore(c.cl_build());
let build f s =
let r = exc_protect ctx (fun r ->
let t = mk_mono() in
let t = spawn_monomorph ctx p in
r := lazy_processing (fun() -> t);
let tf = (f()) in
unify_raise ctx tf t p;
Expand Down
2 changes: 1 addition & 1 deletion src/typing/macroContext.ml
Original file line number Diff line number Diff line change
Expand Up @@ -734,7 +734,7 @@ let type_macro ctx mode cpath f (el:Ast.expr list) p =
| MMacroType ->
"ComplexType",(fun () ->
let t = if v = Interp.vnull then
mk_mono()
spawn_monomorph ctx p
else try
let ct = Interp.decode_ctype v in
Typeload.load_complex_type ctx false ct;
Expand Down
2 changes: 1 addition & 1 deletion src/typing/matcher.ml
Original file line number Diff line number Diff line change
Expand Up @@ -176,7 +176,7 @@ module Pattern = struct
let unify_type_pattern ctx mt t p =
let tcl = get_general_module_type ctx mt p in
match tcl with
| TAbstract(a,_) -> unify ctx (TAbstract(a,[mk_mono()])) t p
| TAbstract(a,_) -> unify ctx (TAbstract(a,[spawn_monomorph ctx p])) t p
| _ -> die "" __LOC__

let rec make pctx toplevel t e =
Expand Down
29 changes: 15 additions & 14 deletions src/typing/typer.ml
Original file line number Diff line number Diff line change
Expand Up @@ -165,7 +165,8 @@ let check_error ctx err p = match err with
(* ---------------------------------------------------------------------- *)
(* PASS 3 : type expression & check structure *)

let rec unify_min_raise basic (el:texpr list) : t =
let rec unify_min_raise ctx (el:texpr list) : t =
let basic = ctx.com.basic in
let rec base_types t =
let tl = ref [] in
let rec loop t = (match t with
Expand Down Expand Up @@ -193,7 +194,7 @@ let rec unify_min_raise basic (el:texpr list) : t =
!tl
in
match el with
| [] -> mk_mono()
| [] -> spawn_monomorph ctx null_pos
| [e] -> e.etype
| _ ->
let rec chk_null e = is_null e.etype || is_explicit_null e.etype ||
Expand Down Expand Up @@ -222,7 +223,7 @@ let rec unify_min_raise basic (el:texpr list) : t =
with Unify_error _ ->
true, t
in
let has_error, t = loop (mk_mono()) el in
let has_error, t = loop (spawn_monomorph ctx null_pos) el in
if not has_error then
t
else try
Expand All @@ -246,7 +247,7 @@ let rec unify_min_raise basic (el:texpr list) : t =
raise Not_found
) PMap.empty el in
let fields = PMap.foldi (fun n el acc ->
let t = try unify_min_raise basic el with Unify_error _ -> raise Not_found in
let t = try unify_min_raise ctx el with Unify_error _ -> raise Not_found in
PMap.add n (mk_field n t (List.hd el).epos null_pos) acc
) fields PMap.empty in
mk_anon ~fields (ref Closed)
Expand Down Expand Up @@ -282,7 +283,7 @@ let rec unify_min_raise basic (el:texpr list) : t =
List.hd !common_types

let unify_min ctx el =
try unify_min_raise ctx.com.basic el
try unify_min_raise ctx el
with Error (Unify l,p) ->
if not ctx.untyped then display_error ctx (error_msg (Unify l)) p;
(List.hd el).etype
Expand Down Expand Up @@ -328,7 +329,7 @@ let rec type_ident_raise ctx i p mode =
AKExpr (mk (TConst TSuper) t p)
| "null" ->
if mode = MGet then
AKExpr (null (mk_mono()) p)
AKExpr (null (spawn_monomorph ctx p) p)
else
AKNo i
| _ ->
Expand Down Expand Up @@ -1133,7 +1134,7 @@ and type_unop ctx op flag e p =
let rec loop opl = match opl with
| [] -> raise Not_found
| (op2,flag2,cf) :: opl when op == op2 && flag == flag2 ->
let m = mk_mono() in
let m = spawn_monomorph ctx p in
let tcf = apply_params a.a_params pl (monomorphs cf.cf_params cf.cf_type) in
if Meta.has Meta.Impl cf.cf_meta then begin
if type_iseq (tfun [apply_params a.a_params pl a.a_this] m) tcf then cf,tcf,m else loop opl
Expand Down Expand Up @@ -1948,11 +1949,11 @@ and type_map_declaration ctx e1 el with_type p =
| TInst({cl_path=["haxe";"ds"],"IntMap"},[tv]) -> ctx.t.tint,tv,true
| TInst({cl_path=["haxe";"ds"],"StringMap"},[tv]) -> ctx.t.tstring,tv,true
| TInst({cl_path=["haxe";"ds"],("ObjectMap" | "EnumValueMap")},[tk;tv]) -> tk,tv,true
| _ -> mk_mono(),mk_mono(),false
| _ -> spawn_monomorph ctx p,spawn_monomorph ctx p,false
in
match with_type with
| WithType.WithType(t,_) -> get_map_params t
| _ -> (mk_mono(),mk_mono(),false)
| _ -> (spawn_monomorph ctx p,spawn_monomorph ctx p,false)
in
let keys = Hashtbl.create 0 in
let check_key e_key =
Expand Down Expand Up @@ -1992,7 +1993,7 @@ and type_map_declaration ctx e1 el with_type p =
(e1 :: el_k,e2 :: el_v)
) ([],[]) el_kv in
let unify_min_resume el = try
unify_min_raise ctx.com.basic el
unify_min_raise ctx el
with Error (Unify l,p) when ctx.in_call_args ->
raise (WithTypeError(Unify l,p))
in
Expand Down Expand Up @@ -2166,7 +2167,7 @@ and type_array_decl ctx el with_type p =
| None ->
let el = List.map (fun e -> type_expr ctx e WithType.value) el in
let t = try
unify_min_raise ctx.com.basic el
unify_min_raise ctx el
with Error (Unify l,p) ->
if !allow_array_dynamic || ctx.untyped || ctx.com.display.dms_error_policy = EPIgnore then
t_dynamic
Expand All @@ -2184,7 +2185,7 @@ and type_array_decl ctx el with_type p =
mk (TArrayDecl el) (ctx.t.tarray t) p)

and type_array_comprehension ctx e with_type p =
let v = gen_local ctx (mk_mono()) p in
let v = gen_local ctx (spawn_monomorph ctx p) p in
let et = ref (EConst(Ident "null"),p) in
let comprehension_pos = p in
let rec map_compr (e,p) =
Expand Down Expand Up @@ -2615,7 +2616,7 @@ and type_expr ?(mode=MGet) ctx (e,p) (with_type:WithType.t) =
type_try ctx e1 catches with_type p
| EThrow e ->
let e = type_expr ctx e WithType.value in
mk (TThrow e) (mk_mono()) p
mk (TThrow e) (spawn_monomorph ctx p) p
| ECall (e,el) ->
type_call ~mode ctx e el with_type false p
| ENew (t,el) ->
Expand All @@ -2637,7 +2638,7 @@ and type_expr ?(mode=MGet) ctx (e,p) (with_type:WithType.t) =
}
| ECast (e,None) ->
let e = type_expr ctx e WithType.value in
mk (TCast (e,None)) (mk_mono()) p
mk (TCast (e,None)) (spawn_monomorph ctx p) p
| ECast (e, Some t) ->
type_cast ctx e t p
| EDisplay (e,dk) ->
Expand Down
2 changes: 1 addition & 1 deletion src/typing/typerBase.ml
Original file line number Diff line number Diff line change
Expand Up @@ -122,7 +122,7 @@ let rec type_module_type ctx t tparams p =
let types = (match tparams with None -> Monomorph.spawn_constrained_monos (fun t -> t) e.e_params | Some l -> l) in
mk (TTypeExpr (TEnumDecl e)) (TType (e.e_type,types)) p
| TTypeDecl s ->
let t = apply_params s.t_params (List.map (fun _ -> mk_mono()) s.t_params) s.t_type in
let t = apply_params s.t_params (List.map (fun _ -> spawn_monomorph ctx p) s.t_params) s.t_type in
DeprecationCheck.check_typedef ctx.com s p;
(match follow t with
| TEnum (e,params) ->
Expand Down
2 changes: 1 addition & 1 deletion src/typing/typerDisplay.ml
Original file line number Diff line number Diff line change
Expand Up @@ -150,7 +150,7 @@ let raise_toplevel ctx dk with_type (subject,psubject) =
DisplayToplevel.collect_and_raise ctx (match dk with DKPattern _ -> TKPattern psubject | _ -> TKExpr psubject) with_type (CRToplevel expected_type) (subject,psubject) psubject

let display_dollar_type ctx p make_type =
let mono = mk_mono() in
let mono = spawn_monomorph ctx p in
let doc = doc_from_string "Outputs type of argument as a warning and uses argument as value" in
let arg = ["expression",false,mono] in
begin match ctx.com.display.dms_kind with
Expand Down

0 comments on commit 5fad913

Please sign in to comment.