Skip to content

Commit c723951

Browse files
riaqngoldfirere
riaqn
and
goldfirere
authored
flambda-backend: Generalize unique_to_linear to monadic_to_comonadic (#2351)
* generalize unique_to_linear for variables * generalize unique_to_linear for constants * fix typo Co-authored-by: Richard Eisenberg <[email protected]> --------- Co-authored-by: Richard Eisenberg <[email protected]>
1 parent e132455 commit c723951

File tree

3 files changed

+123
-102
lines changed

3 files changed

+123
-102
lines changed

‎typing/env.ml

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2977,22 +2977,23 @@ let share_mode ~errors ~env ~loc id vmode shared_context =
29772977
(Once_value_used_in (id, shared_context))
29782978
| Ok () -> Mode.Value.join [Mode.Value.min_with_uniqueness Mode.Uniqueness.shared; vmode]
29792979

2980-
let closure_mode ~errors ~env ~loc id vmode closure_context comonadic =
2980+
let closure_mode ~errors ~env ~loc id {Mode.monadic; comonadic}
2981+
closure_context comonadic0 : Mode.Value.l =
29812982
begin
29822983
match
2983-
Mode.Value.Comonadic.submode vmode.Mode.comonadic comonadic
2984+
Mode.Value.Comonadic.submode comonadic comonadic0
29842985
with
29852986
| Error e ->
29862987
may_lookup_error errors loc env
29872988
(Value_used_in_closure (id, e, closure_context))
29882989
| Ok () -> ()
29892990
end;
2990-
let uniqueness =
2991-
Mode.Uniqueness.join
2992-
[ Mode.Value.uniqueness vmode;
2993-
Mode.linear_to_unique (Mode.Value.Comonadic.linearity comonadic) ]
2991+
let monadic =
2992+
Mode.Value.Monadic.join
2993+
[ monadic;
2994+
Mode.Value.comonadic_to_monadic comonadic0 ]
29942995
in
2995-
Mode.Value.join [Mode.Value.min_with_uniqueness uniqueness; vmode]
2996+
{monadic; comonadic}
29962997

29972998
let exclave_mode ~errors ~env ~loc id vmode =
29982999
match

‎typing/mode.ml

Lines changed: 113 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -551,10 +551,16 @@ module Lattices_mono = struct
551551
('a0, 'a1, 'd) morph
552552
-> ('a0 comonadic_with, 'a1 comonadic_with, 'd) morph
553553
(** Lift an morphism on areality to a morphism on the comonadic fragment *)
554-
| Unique_to_linear : (Uniqueness_op.t, Linearity.t, 'l * 'r) morph
555-
(** Returns the linearity dual to the given uniqueness *)
556-
| Linear_to_unique : (Linearity.t, Uniqueness_op.t, 'l * 'r) morph
557-
(** Returns the uniqueness dual to the given linearity *)
554+
| Monadic_to_comonadic_min
555+
: (Monadic_op.t, 'a comonadic_with, 'l * disallowed) morph
556+
(** Dualize the monadic fragment to the comonadic fragment. The areality is set to min. *)
557+
| Comonadic_to_monadic :
558+
'a comonadic_with obj
559+
-> ('a comonadic_with, Monadic_op.t, 'l * 'r) morph
560+
(** Dualize the comonadic fragment to the monadic fragment. The areality axis is ignored. *)
561+
| Monadic_to_comonadic_max
562+
: (Monadic_op.t, 'a comonadic_with, disallowed * 'r) morph
563+
(** Dualize the monadic fragment to the comonadic fragment. The areality is set to max. *)
558564
(* Following is a chain of adjunction (complete and cannot extend in
559565
either direction) *)
560566
| Local_to_regional : (Locality.t, Regionality.t, 'l * disallowed) morph
@@ -585,8 +591,8 @@ module Lattices_mono = struct
585591
let f = allow_left f in
586592
let g = allow_left g in
587593
Compose (f, g)
588-
| Unique_to_linear -> Unique_to_linear
589-
| Linear_to_unique -> Linear_to_unique
594+
| Monadic_to_comonadic_min -> Monadic_to_comonadic_min
595+
| Comonadic_to_monadic a -> Comonadic_to_monadic a
590596
| Local_to_regional -> Local_to_regional
591597
| Locality_as_regionality -> Locality_as_regionality
592598
| Regional_to_local -> Regional_to_local
@@ -607,8 +613,8 @@ module Lattices_mono = struct
607613
let f = allow_right f in
608614
let g = allow_right g in
609615
Compose (f, g)
610-
| Unique_to_linear -> Unique_to_linear
611-
| Linear_to_unique -> Linear_to_unique
616+
| Comonadic_to_monadic a -> Comonadic_to_monadic a
617+
| Monadic_to_comonadic_max -> Monadic_to_comonadic_max
612618
| Global_to_regional -> Global_to_regional
613619
| Locality_as_regionality -> Locality_as_regionality
614620
| Regional_to_local -> Regional_to_local
@@ -632,8 +638,9 @@ module Lattices_mono = struct
632638
let f = disallow_left f in
633639
let g = disallow_left g in
634640
Compose (f, g)
635-
| Unique_to_linear -> Unique_to_linear
636-
| Linear_to_unique -> Linear_to_unique
641+
| Monadic_to_comonadic_min -> Monadic_to_comonadic_min
642+
| Comonadic_to_monadic a -> Comonadic_to_monadic a
643+
| Monadic_to_comonadic_max -> Monadic_to_comonadic_max
637644
| Local_to_regional -> Local_to_regional
638645
| Global_to_regional -> Global_to_regional
639646
| Locality_as_regionality -> Locality_as_regionality
@@ -658,8 +665,9 @@ module Lattices_mono = struct
658665
let f = disallow_right f in
659666
let g = disallow_right g in
660667
Compose (f, g)
661-
| Unique_to_linear -> Unique_to_linear
662-
| Linear_to_unique -> Linear_to_unique
668+
| Monadic_to_comonadic_min -> Monadic_to_comonadic_min
669+
| Comonadic_to_monadic a -> Comonadic_to_monadic a
670+
| Monadic_to_comonadic_max -> Monadic_to_comonadic_max
663671
| Local_to_regional -> Local_to_regional
664672
| Global_to_regional -> Global_to_regional
665673
| Locality_as_regionality -> Locality_as_regionality
@@ -684,8 +692,9 @@ module Lattices_mono = struct
684692
| Compose (f, g) ->
685693
let mid = src dst f in
686694
src mid g
687-
| Unique_to_linear -> Uniqueness_op
688-
| Linear_to_unique -> Linearity
695+
| Monadic_to_comonadic_min -> Monadic_op
696+
| Comonadic_to_monadic src -> src
697+
| Monadic_to_comonadic_max -> Monadic_op
689698
| Local_to_regional -> Locality
690699
| Locality_as_regionality -> Locality
691700
| Global_to_regional -> Locality
@@ -728,8 +737,10 @@ module Lattices_mono = struct
728737
| Join_with c0, Join_with c1 -> if c0 = c1 then Some Refl else None
729738
| Imply c0, Imply c1 -> if c0 = c1 then Some Refl else None
730739
| Subtract c0, Subtract c1 -> if c0 = c1 then Some Refl else None
731-
| Unique_to_linear, Unique_to_linear -> Some Refl
732-
| Linear_to_unique, Linear_to_unique -> Some Refl
740+
| Monadic_to_comonadic_min, Monadic_to_comonadic_min -> Some Refl
741+
| Comonadic_to_monadic a0, Comonadic_to_monadic a1 -> (
742+
match eq_obj a0 a1 with None -> None | Some Refl -> Some Refl)
743+
| Monadic_to_comonadic_max, Monadic_to_comonadic_max -> Some Refl
733744
| Local_to_regional, Local_to_regional -> Some Refl
734745
| Locality_as_regionality, Locality_as_regionality -> Some Refl
735746
| Global_to_regional, Global_to_regional -> Some Refl
@@ -743,7 +754,8 @@ module Lattices_mono = struct
743754
| Map_comonadic f, Map_comonadic g -> (
744755
match equal f g with Some Refl -> Some Refl | None -> None)
745756
| ( ( Id | Proj _ | Max_with _ | Min_with _ | Meet_with _ | Join_with _
746-
| Unique_to_linear | Linear_to_unique | Local_to_regional
757+
| Monadic_to_comonadic_min | Comonadic_to_monadic _
758+
| Monadic_to_comonadic_max | Local_to_regional
747759
| Locality_as_regionality | Global_to_regional | Regional_to_local
748760
| Regional_to_global | Compose _ | Map_comonadic _ | Imply _
749761
| Subtract _ ),
@@ -767,8 +779,9 @@ module Lattices_mono = struct
767779
| Map_comonadic f ->
768780
let dst0 = proj_obj Areality dst in
769781
Format.fprintf ppf "map_comonadic(%a)" (print_morph dst0) f
770-
| Unique_to_linear -> Format.fprintf ppf "unique_to_linear"
771-
| Linear_to_unique -> Format.fprintf ppf "linear_to_unique"
782+
| Monadic_to_comonadic_min -> Format.fprintf ppf "monadic_to_comonadic_min"
783+
| Comonadic_to_monadic _ -> Format.fprintf ppf "comonadic_to_monadic"
784+
| Monadic_to_comonadic_max -> Format.fprintf ppf "monadic_to_comonadic_max"
772785
| Local_to_regional -> Format.fprintf ppf "local_to_regional"
773786
| Regional_to_local -> Format.fprintf ppf "regional_to_local"
774787
| Locality_as_regionality -> Format.fprintf ppf "locality_as_regionality"
@@ -814,6 +827,27 @@ module Lattices_mono = struct
814827

815828
let max_with dst ax a = update ax a (max dst)
816829

830+
let monadic_to_comonadic_min :
831+
type a. a comonadic_with obj -> Monadic_op.t -> a comonadic_with =
832+
fun obj (uniqueness, ()) ->
833+
match obj with
834+
| Comonadic_with_locality -> Locality.min, unique_to_linear uniqueness
835+
| Comonadic_with_regionality -> Regionality.min, unique_to_linear uniqueness
836+
837+
let comonadic_to_monadic :
838+
type a. a comonadic_with obj -> a comonadic_with -> Monadic_op.t =
839+
fun obj (_, linearity) ->
840+
match obj with
841+
| Comonadic_with_locality -> linear_to_unique linearity, ()
842+
| Comonadic_with_regionality -> linear_to_unique linearity, ()
843+
844+
let monadic_to_comonadic_max :
845+
type a. a comonadic_with obj -> Monadic_op.t -> a comonadic_with =
846+
fun obj (uniqueness, ()) ->
847+
match obj with
848+
| Comonadic_with_locality -> Locality.max, unique_to_linear uniqueness
849+
| Comonadic_with_regionality -> Regionality.max, unique_to_linear uniqueness
850+
817851
let rec apply : type a b d. b obj -> (a, b, d) morph -> a -> b =
818852
fun dst f a ->
819853
match f with
@@ -830,8 +864,9 @@ module Lattices_mono = struct
830864
| Join_with c -> join dst c a
831865
| Imply c -> imply dst c a
832866
| Subtract c -> subtract dst c a
833-
| Unique_to_linear -> unique_to_linear a
834-
| Linear_to_unique -> linear_to_unique a
867+
| Monadic_to_comonadic_min -> monadic_to_comonadic_min dst a
868+
| Comonadic_to_monadic src -> comonadic_to_monadic src a
869+
| Monadic_to_comonadic_max -> monadic_to_comonadic_max dst a
835870
| Local_to_regional -> local_to_regional a
836871
| Regional_to_local -> regional_to_local a
837872
| Locality_as_regionality -> locality_as_regionality a
@@ -878,8 +913,9 @@ module Lattices_mono = struct
878913
match ax with
879914
| Areality -> Some (compose dst f (Proj (src', Areality)))
880915
| Linearity -> Some (Proj (src', Linearity)))
881-
| Unique_to_linear, Linear_to_unique -> Some Id
882-
| Linear_to_unique, Unique_to_linear -> Some Id
916+
| Proj _, Monadic_to_comonadic_min -> None
917+
| Proj _, Monadic_to_comonadic_max -> None
918+
| Proj _, Comonadic_to_monadic _ -> None
883919
| Map_comonadic f, Map_comonadic g ->
884920
let dst0 = proj_obj Areality dst in
885921
Some (Map_comonadic (compose dst0 f g))
@@ -912,14 +948,6 @@ module Lattices_mono = struct
912948
(compose dst
913949
(Join_with (locality_as_regionality c))
914950
Locality_as_regionality)
915-
| Unique_to_linear, Meet_with c ->
916-
Some (compose dst (Meet_with (unique_to_linear c)) Unique_to_linear)
917-
| Unique_to_linear, Join_with c ->
918-
Some (compose dst (Join_with (unique_to_linear c)) Unique_to_linear)
919-
| Linear_to_unique, Meet_with c ->
920-
Some (compose dst (Meet_with (linear_to_unique c)) Linear_to_unique)
921-
| Linear_to_unique, Join_with c ->
922-
Some (compose dst (Join_with (linear_to_unique c)) Linear_to_unique)
923951
| Map_comonadic f, Join_with c ->
924952
let dst0 = proj_obj Areality dst in
925953
let areality, linearity = c in
@@ -955,19 +983,19 @@ module Lattices_mono = struct
955983
| Subtract _, _ -> None
956984
| _, Proj _ -> None
957985
| Map_comonadic _, _ -> None
986+
| Monadic_to_comonadic_min, _ -> None
987+
| Monadic_to_comonadic_max, _ -> None
988+
| Comonadic_to_monadic _, _ -> None
958989
| ( Proj _,
959-
( Unique_to_linear | Linear_to_unique | Local_to_regional
960-
| Regional_to_local | Locality_as_regionality | Regional_to_global
961-
| Global_to_regional ) ) ->
990+
( Local_to_regional | Regional_to_local | Locality_as_regionality
991+
| Regional_to_global | Global_to_regional ) ) ->
962992
.
963-
| ( ( Unique_to_linear | Linear_to_unique | Local_to_regional
964-
| Regional_to_local | Locality_as_regionality | Regional_to_global
965-
| Global_to_regional ),
993+
| ( ( Local_to_regional | Regional_to_local | Locality_as_regionality
994+
| Regional_to_global | Global_to_regional ),
966995
Min_with _ ) ->
967996
.
968-
| ( ( Unique_to_linear | Linear_to_unique | Local_to_regional
969-
| Regional_to_local | Locality_as_regionality | Regional_to_global
970-
| Global_to_regional ),
997+
| ( ( Local_to_regional | Regional_to_local | Locality_as_regionality
998+
| Regional_to_global | Global_to_regional ),
971999
Max_with _ ) ->
9721000
.
9731001

@@ -992,8 +1020,8 @@ module Lattices_mono = struct
9921020
Compose (g', f')
9931021
| Join_with c -> Subtract c
9941022
| Imply c -> Meet_with c
995-
| Unique_to_linear -> Linear_to_unique
996-
| Linear_to_unique -> Unique_to_linear
1023+
| Comonadic_to_monadic _ -> Monadic_to_comonadic_min
1024+
| Monadic_to_comonadic_max -> Comonadic_to_monadic dst
9971025
| Global_to_regional -> Regional_to_global
9981026
| Regional_to_global -> Locality_as_regionality
9991027
| Locality_as_regionality -> Regional_to_local
@@ -1018,8 +1046,8 @@ module Lattices_mono = struct
10181046
Compose (g', f')
10191047
| Meet_with c -> Imply c
10201048
| Subtract c -> Join_with c
1021-
| Unique_to_linear -> Linear_to_unique
1022-
| Linear_to_unique -> Unique_to_linear
1049+
| Comonadic_to_monadic _ -> Monadic_to_comonadic_max
1050+
| Monadic_to_comonadic_min -> Comonadic_to_monadic dst
10231051
| Local_to_regional -> Regional_to_local
10241052
| Regional_to_local -> Locality_as_regionality
10251053
| Locality_as_regionality -> Regional_to_global
@@ -1210,12 +1238,6 @@ module Uniqueness = struct
12101238
let zap_to_legacy = zap_to_ceil
12111239
end
12121240

1213-
let unique_to_linear m =
1214-
S.Positive.via_antitone Linearity.Obj.obj C.Unique_to_linear m
1215-
1216-
let linear_to_unique m =
1217-
S.Negative.via_antitone Uniqueness.Obj.obj C.Linear_to_unique m
1218-
12191241
let regional_to_local m =
12201242
S.Positive.via_monotone Locality.Obj.obj C.Regional_to_local m
12211243

@@ -1225,10 +1247,6 @@ let locality_as_regionality m =
12251247
let regional_to_global m =
12261248
S.Positive.via_monotone Locality.Obj.obj C.Regional_to_global m
12271249

1228-
module Const = struct
1229-
let unique_to_linear a = C.unique_to_linear a
1230-
end
1231-
12321250
module Comonadic_with_regionality = struct
12331251
module Const = C.Comonadic_with_regionality
12341252

@@ -1697,6 +1715,10 @@ module Value = struct
16971715
let monadic = Monadic.meet mo in
16981716
{ comonadic; monadic }
16991717

1718+
let comonadic_to_monadic m =
1719+
S.Negative.via_antitone Monadic.Obj.obj
1720+
(Comonadic_to_monadic Comonadic.Obj.obj) m
1721+
17001722
module Const = struct
17011723
type t = Regionality.Const.t * Linearity.Const.t * Uniqueness.Const.t
17021724

@@ -1935,6 +1957,10 @@ module Alloc = struct
19351957
let monadic = Monadic.meet mo in
19361958
{ comonadic; monadic }
19371959

1960+
let monadic_to_comonadic_min m =
1961+
S.Positive.via_antitone Comonadic.Obj.obj Monadic_to_comonadic_min
1962+
(Monadic.disallow_left m)
1963+
19381964
module Const = struct
19391965
type ('loc, 'lin, 'uni) modes =
19401966
{ locality : 'loc;
@@ -2006,26 +2032,31 @@ module Alloc = struct
20062032
{ locality; uniqueness; linearity }
20072033
end
20082034

2035+
let split { locality; linearity; uniqueness } =
2036+
let monadic = uniqueness, () in
2037+
let comonadic = locality, linearity in
2038+
{ comonadic; monadic }
2039+
2040+
let merge { comonadic; monadic } =
2041+
let locality, linearity = comonadic in
2042+
let uniqueness, () = monadic in
2043+
{ locality; linearity; uniqueness }
2044+
20092045
(** See [Alloc.close_over] for explanation. *)
20102046
let close_over m =
2011-
let locality = m.locality in
2012-
(* uniqueness of the returned function is not constrained *)
2013-
let uniqueness = Uniqueness.Const.min in
2014-
let linearity =
2015-
Linearity.Const.join m.linearity
2016-
(* In addition, unique argument make the returning function once.
2017-
In other words, if argument <= unique, returning function >= once.
2018-
That is, returning function >= (dual of argument) *)
2019-
(Const.unique_to_linear m.uniqueness)
2047+
let { monadic; comonadic } = split m in
2048+
let comonadic =
2049+
Comonadic.Const.join comonadic
2050+
(C.monadic_to_comonadic_min Comonadic.Obj.obj monadic)
20202051
in
2021-
{ locality; linearity; uniqueness }
2052+
let monadic = Monadic.Const.min in
2053+
merge { comonadic; monadic }
20222054

20232055
(** See [Alloc.partial_apply] for explanation. *)
20242056
let partial_apply m =
2025-
let locality = m.locality in
2026-
let uniqueness = Uniqueness.Const.min in
2027-
let linearity = m.linearity in
2028-
{ locality; linearity; uniqueness }
2057+
let { comonadic; _ } = split m in
2058+
let monadic = Monadic.Const.min in
2059+
merge { comonadic; monadic }
20292060
end
20302061

20312062
let of_const = Const.of_const
@@ -2054,25 +2085,23 @@ module Alloc = struct
20542085
C]. [comonadic] and [monadic] constutute the mode of [A], and we need to
20552086
give the lower bound mode of [B -> C]. *)
20562087
let close_over { comonadic; monadic } =
2057-
(* If [A] is [local], [B -> C] containining a pointer to [A] must
2058-
be [local] too. *)
2059-
let locality = min_with_locality (Comonadic.locality comonadic) in
2060-
(* [B -> C] is arrow type and thus crosses uniqueness *)
2061-
(* If [A] is [once], [B -> C] containing a pointer to [A] must be [once] too
2062-
*)
2063-
let linearity0 = min_with_linearity (Comonadic.linearity comonadic) in
2064-
(* Moreover, if [A] is [unique], [B -> C] must be [once]. *)
2065-
let linearity1 =
2066-
min_with_linearity (unique_to_linear (Monadic.uniqueness monadic))
2067-
in
2068-
join [locality; linearity0; linearity1]
2088+
let comonadic = Comonadic.disallow_right comonadic in
2089+
(* The comonadic of the returned function is constrained by the monadic of the closed argument via the dualizing morphism. *)
2090+
let comonadic1 = monadic_to_comonadic_min monadic in
2091+
(* It's also constrained by the comonadic of the closed argument. *)
2092+
let comonadic = Comonadic.join [comonadic; comonadic1] in
2093+
(* The returned function crosses all monadic axes that we know of
2094+
(uniqueness/contention). *)
2095+
let monadic = Monadic.disallow_right Monadic.min in
2096+
{ comonadic; monadic }
20692097

20702098
(** Similar to above, but we are given the mode of [A -> B -> C], and need to
20712099
give the lower bound mode of [B -> C]. *)
2072-
let partial_apply alloc_mode =
2073-
(* [B -> C] should be always higher than [A -> B -> C] except the uniqueness
2074-
axis where it's not constrained *)
2075-
meet_with_uniqueness Unique alloc_mode
2100+
let partial_apply { comonadic; _ } =
2101+
(* The returned function crosses all monadic axes that we know of. *)
2102+
let monadic = Monadic.disallow_right Monadic.min in
2103+
let comonadic = Comonadic.disallow_right comonadic in
2104+
{ comonadic; monadic }
20762105
end
20772106

20782107
let alloc_as_value m =

0 commit comments

Comments
 (0)