Skip to content

Commit 65034a1

Browse files
gfngfngfngfn
committed
(maybe temporary) fixes about the generalization of value items in modules
1 parent fd016e0 commit 65034a1

File tree

3 files changed

+62
-57
lines changed

3 files changed

+62
-57
lines changed

‎src/frontend/moduleTypechecker.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -719,7 +719,7 @@ and typecheck_binding (config : typecheck_config) (tyenv : Typeenv.t) (utbind :
719719
let ty_cod = (Range.dummy "test-cod", BaseType(UnitType)) in
720720
Poly(Range.dummy "test-func", FuncType(RowEmpty, ty_dom, ty_cod))
721721
in
722-
let* (test_name, pty1, evid, e1) = Typechecker.typecheck_nonrec pre tyenv utletbind in
722+
let* (test_name, pty1, evid, e1) = Typechecker.typecheck_nonrec ~always_polymorphic:true pre tyenv utletbind in
723723
if TypeConv.poly_type_equal pty_expected pty1 then
724724
return ([ BindTest(evid, test_name, e1) ], (OpaqueIDMap.empty, StructSig.empty))
725725
else
@@ -731,7 +731,7 @@ and typecheck_binding (config : typecheck_config) (tyenv : Typeenv.t) (utbind :
731731
let* (rec_or_nonrecs, ssig) =
732732
match valbind with
733733
| UTNonRec(utletbind) ->
734-
let* (varnm, pty1, evid, e1) = Typechecker.typecheck_nonrec pre tyenv utletbind in
734+
let* (varnm, pty1, evid, e1) = Typechecker.typecheck_nonrec ~always_polymorphic:true pre tyenv utletbind in
735735
let ssig =
736736
let ventry =
737737
{

‎src/frontend/typechecker.ml

+59-54
Original file line numberDiff line numberDiff line change
@@ -647,42 +647,61 @@ let rec typecheck (pre : pre) (tyenv : Typeenv.t) ((rng, utastmain) : untyped_ab
647647
Exhchecker.main rng patbrs tyO pre tyenv;
648648
return (PatternMatch(rng, eO, patbrs), beta)
649649

650-
| UTLetIn(UTNonRec(utletbind), utast2) ->
651-
let* (varnm, pty1, evid, e1) = typecheck_nonrec pre tyenv utletbind in
652-
let tyenv =
653-
let ventry =
654-
{
655-
val_type = pty1;
656-
val_name = Some(evid);
657-
val_stage = pre.stage;
658-
}
659-
in
660-
tyenv |> Typeenv.add_value varnm ventry
661-
in
662-
let* (e2, ty2) = typecheck_iter tyenv utast2 in
663-
return (LetNonRecIn(PVariable(evid), e1, e2), ty2)
664-
665-
| UTLetIn(UTRec(utrecbinds), utast2) ->
666-
let* quints = typecheck_letrec pre tyenv utrecbinds in
667-
let (tyenv, recbindacc) =
668-
quints |> List.fold_left (fun (tyenv, recbindacc) quint ->
669-
let (x, pty, evid, recbind) = quint in
670-
let tyenv =
671-
let ventry =
672-
{
673-
val_type = pty;
674-
val_name = Some(evid);
675-
val_stage = pre.stage;
676-
}
650+
| UTLetIn(valbind, utast2) ->
651+
begin
652+
match valbind with
653+
| UTNonRec(utletbind) ->
654+
let* (varnm, pty1, evid, e1) = typecheck_nonrec ~always_polymorphic:false pre tyenv utletbind in
655+
let tyenv =
656+
let ventry =
657+
{
658+
val_type = pty1;
659+
val_name = Some(evid);
660+
val_stage = pre.stage;
661+
}
662+
in
663+
tyenv |> Typeenv.add_value varnm ventry
677664
in
678-
tyenv |> Typeenv.add_value x ventry
679-
in
680-
let recbindacc = Alist.extend recbindacc recbind in
681-
(tyenv, recbindacc)
682-
) (tyenv, Alist.empty)
683-
in
684-
let* (e2, ty2) = typecheck_iter tyenv utast2 in
685-
return (LetRecIn(recbindacc |> Alist.to_list, e2), ty2)
665+
let* (e2, ty2) = typecheck_iter tyenv utast2 in
666+
return (LetNonRecIn(PVariable(evid), e1, e2), ty2)
667+
668+
| UTRec(utrecbinds) ->
669+
let* quints = typecheck_letrec pre tyenv utrecbinds in
670+
let (tyenv, recbindacc) =
671+
quints |> List.fold_left (fun (tyenv, recbindacc) quint ->
672+
let (x, pty, evid, recbind) = quint in
673+
let tyenv =
674+
let ventry =
675+
{
676+
val_type = pty;
677+
val_name = Some(evid);
678+
val_stage = pre.stage;
679+
}
680+
in
681+
tyenv |> Typeenv.add_value x ventry
682+
in
683+
let recbindacc = Alist.extend recbindacc recbind in
684+
(tyenv, recbindacc)
685+
) (tyenv, Alist.empty)
686+
in
687+
let* (e2, ty2) = typecheck_iter tyenv utast2 in
688+
return (LetRecIn(recbindacc |> Alist.to_list, e2), ty2)
689+
690+
| UTMutable(ident, utastI) ->
691+
let* (varnm, pty_ref, evid, eI) = typecheck_let_mutable pre tyenv ident utastI in
692+
let tyenv =
693+
let ventry =
694+
{
695+
val_type = pty_ref;
696+
val_name = Some(evid);
697+
val_stage = pre.stage;
698+
}
699+
in
700+
tyenv |> Typeenv.add_value varnm ventry
701+
in
702+
let* (e2, ty2) = typecheck_iter tyenv utast2 in
703+
return (LetMutableIn(evid, eI, e2), ty2)
704+
end
686705

687706
| UTIfThenElse(utastB, utast1, utast2) ->
688707
let* (eB, tyB) = typecheck_iter tyenv utastB in
@@ -692,11 +711,6 @@ let rec typecheck (pre : pre) (tyenv : Typeenv.t) ((rng, utastmain) : untyped_ab
692711
let* () = unify ty2 ty1 in
693712
return (IfThenElse(eB, e1, e2), ty1)
694713

695-
| UTLetIn(UTMutable(ident, utastI), utastA) ->
696-
let* (tyenvI, evid, eI, _tyI) = typecheck_let_mutable pre tyenv ident utastI in
697-
let* (eA, tyA) = typecheck_iter tyenvI utastA in
698-
return (LetMutableIn(evid, eI, eA), tyA)
699-
700714
| UTOverwrite(ident, utastN) ->
701715
let (rng_var, _) = ident in
702716
let* sub = typecheck_iter tyenv (rng_var, UTContentOf([], ident)) in
@@ -1226,7 +1240,7 @@ and typecheck_letrec (pre : pre) (tyenv : Typeenv.t) (utrecbinds : untyped_let_b
12261240
return tuples
12271241

12281242

1229-
and typecheck_nonrec (pre : pre) (tyenv : Typeenv.t) (utletbind : untyped_let_binding) : (var_name * poly_type * EvalVarID.t * abstract_tree) ok =
1243+
and typecheck_nonrec ~(always_polymorphic : bool) (pre : pre) (tyenv : Typeenv.t) (utletbind : untyped_let_binding) : (var_name * poly_type * EvalVarID.t * abstract_tree) ok =
12301244
let open ResultMonad in
12311245
let
12321246
UTLetBinding{
@@ -1251,7 +1265,7 @@ and typecheck_nonrec (pre : pre) (tyenv : Typeenv.t) (utletbind : untyped_let_bi
12511265
let evid = EvalVarID.fresh ident in
12521266
let* (e1, ty1) = typecheck presub tyenv utast1 in
12531267
let pty1 =
1254-
if is_nonexpansive_expression e1 then
1268+
if always_polymorphic || is_nonexpansive_expression e1 then
12551269
(* If `e1` is polymorphically typeable: *)
12561270
TypeConv.generalize pre.level (TypeConv.erase_range_of_type ty1)
12571271
else
@@ -1261,22 +1275,13 @@ and typecheck_nonrec (pre : pre) (tyenv : Typeenv.t) (utletbind : untyped_let_bi
12611275
return (varnm, pty1, evid, e1)
12621276

12631277

1264-
and typecheck_let_mutable (pre : pre) (tyenv : Typeenv.t) (ident : var_name ranged) (utastI : untyped_abstract_tree) : (Typeenv.t * EvalVarID.t * abstract_tree * mono_type) ok =
1278+
and typecheck_let_mutable (pre : pre) (tyenv : Typeenv.t) (ident : var_name ranged) (utastI : untyped_abstract_tree) : (var_name * poly_type * EvalVarID.t * abstract_tree) ok =
12651279
let open ResultMonad in
12661280
let* (eI, tyI) = typecheck { pre with quantifiability = Unquantifiable; } tyenv utastI in
12671281
let (rng_var, varnm) = ident in
1282+
let pty_ref = TypeConv.lift_poly (rng_var, RefType(tyI)) in
12681283
let evid = EvalVarID.fresh ident in
1269-
let tyenvI =
1270-
let ventry =
1271-
{
1272-
val_type = TypeConv.lift_poly (rng_var, RefType(tyI));
1273-
val_name = Some(evid);
1274-
val_stage = pre.stage;
1275-
}
1276-
in
1277-
tyenv |> Typeenv.add_value varnm ventry
1278-
in
1279-
return (tyenvI, evid, eI, tyI)
1284+
return (varnm, pty_ref, evid, eI)
12801285

12811286

12821287
let main (config : typecheck_config) (stage : stage) (tyenv : Typeenv.t) (utast : untyped_abstract_tree) : (mono_type * abstract_tree) ok =

‎src/frontend/typechecker.mli

+1-1
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ val typecheck : pre -> type_environment -> untyped_abstract_tree -> (abstract_tr
77

88
val typecheck_letrec : pre -> type_environment -> untyped_let_binding list -> ((var_name * poly_type * EvalVarID.t * letrec_binding) list, type_error) result
99

10-
val typecheck_nonrec : pre -> type_environment -> untyped_let_binding -> (var_name * poly_type * EvalVarID.t * abstract_tree, type_error) result
10+
val typecheck_nonrec : always_polymorphic:bool -> pre -> type_environment -> untyped_let_binding -> (var_name * poly_type * EvalVarID.t * abstract_tree, type_error) result
1111

1212
val main : typecheck_config -> stage -> Typeenv.t -> untyped_abstract_tree -> (mono_type * abstract_tree, type_error) result
1313

0 commit comments

Comments
 (0)