Skip to content

Modular storage mode analysis #209

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
melsman wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Modular storage mode analysis #209

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
64c50ef
initial work
melsman Mar 19, 2026
43635e2
Potential fix for pull request finding
melsman Mar 19, 2026
31d5de8
fixes
melsman Mar 19, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Compiler/Backend/ClosConvEnv.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ structure ClosConvEnv : CLOS_CONV_ENV =
struct

structure BI = BackendInfo
structure RegvarFinMap = EffVarEnv
structure RegvarFinMap = Effect.Map
structure Labels = AddressLabels
structure PP = PrettyPrint
structure LvarFinMap = Lvars.Map
Expand Down
2 changes: 1 addition & 1 deletion src/Compiler/Backend/SubstAndSimplify.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ functor SubstAndSimplify(structure LineStmt: LINE_STMT
struct
structure PP = PrettyPrint
structure Labels = AddressLabels
structure RegvarFinMap = EffVarEnv
structure RegvarFinMap = Effect.Map
val _ = Flags.add_bool_entry
{long="print_simplified_program", short=NONE, item=ref false,
menu=["Printing of intermediate forms", "print simplified program (LineStmt)"], neg=false,
Expand Down
92 changes: 65 additions & 27 deletions src/Compiler/Regions/AtInf.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,8 +5,6 @@ structure AtInf : AT_INF =
structure PP = PrettyPrint
structure Eff = Effect
structure LLV = LocallyLiveVariables
structure BT = IntStringFinMap
structure RegvarBT = EffVarEnv

(* In the old storage mode analysis an environment was propagated to later
* program units. Since we must assign storage mode attop to regions passed
Expand Down Expand Up @@ -60,8 +58,7 @@ structure AtInf : AT_INF =
fun chat (s : string) = if !Flags.chat then log s else ()

fun show_place p = PP.flatten1(Eff.layout_effect p)
fun show_arreffs epss = concat(map (fn eps => " " ^ show_place eps) epss)
fun show_places rhos = show_arreffs rhos
fun show_places rhos = String.concatWith "," (map show_place rhos)

fun forceATBOT (ATTOP p) = (ATBOT p)
| forceATBOT (ATBOT p) = (ATBOT p)
Expand Down Expand Up @@ -141,27 +138,31 @@ structure AtInf : AT_INF =

datatype rho_desc = LETREGION_BOUND | LETREC_BOUND

abstype regvar_env = REGVAR_ENV of rho_desc RegvarBT.map
abstype regvar_env = REGVAR_ENV of rho_desc Eff.Map.map
with
exception RegvarEnv
val empty_regvar_env = REGVAR_ENV(RegvarBT.empty)
fun declare_regvar_env(x, y, REGVAR_ENV m) = REGVAR_ENV(RegvarBT.add(x,y,m))
fun retrieve_regvar_env(x, REGVAR_ENV m) = case (RegvarBT.lookup m x)
of SOME v => v
val empty_regvar_env = REGVAR_ENV(Eff.Map.empty)
fun declare_regvar_env (x, y, REGVAR_ENV m) = REGVAR_ENV(Eff.Map.add(x,y,m))
fun retrieve_regvar_env (x, REGVAR_ENV m) =
case Eff.Map.lookup m x of
SOME v => v
| NONE => raise RegvarEnv
end

type lvar_env_range = (sigma*place option) * place list
abstype lvar_env =
LVAR_ENV of lvar_env_range BT.map
abstype lvar_env = LVAR_ENV of lvar_env_range Lvars.Map.map
with
exception LvarEnv
val empty_lvar_env = LVAR_ENV(BT.empty)
fun declare_lvar_env (x,y,LVAR_ENV m) = LVAR_ENV(BT.add(Lvars.key x,y,m))
val empty_lvar_env = LVAR_ENV(Lvars.Map.empty)
fun declare_lvar_env (x,y,LVAR_ENV m) = LVAR_ENV(Lvars.Map.add(x,y,m))
fun retrieve_lvar_env (x,LVAR_ENV m) =
case BT.lookup m x of
SOME x => x
| NONE => raise LvarEnv
case Lvars.Map.lookup m x of
SOME x => x
| NONE => raise LvarEnv
fun is_local_lvar_env (x,LVAR_ENV m) =
case Lvars.Map.lookup m x of
SOME _ => true
| NONE => false
end

type excon_env_range = (sigma*place) * place list
Expand Down Expand Up @@ -310,7 +311,7 @@ structure AtInf : AT_INF =
let
(* val _ = Profile.profileOn();*)
fun conflicting_local_lvar lvar : conflict option =
let val lvar_res as (_,lrv) = SME.retrieve_lvar_env(Lvars.key lvar, LE)
let val lvar_res as (_,lrv) = SME.retrieve_lvar_env(lvar, LE)
in case rho_points_into lrv of
SOME (witness: place) => SOME(LVAR_PROBLEM(rho,lvar,lvar_res,witness))
| NONE => NONE
Expand All @@ -324,7 +325,7 @@ structure AtInf : AT_INF =

fun conflicting_local_excon (excon: Excon.excon): conflict option =
let val excon_res as (_,lrv) = SME.retrieve_excon_env(excon, EE)
in case rho_points_into(lrv) of
in case rho_points_into lrv of
SOME (witness: place) => SOME(EXCON_PROBLEM(rho,excon,excon_res,witness))
| _ => NONE
end handle SME.ExconEnv =>
Expand All @@ -346,7 +347,7 @@ structure AtInf : AT_INF =
fun equal_places rho1 rho2 = Eff.eq_effect(rho1,rho2)

fun letregion_bound (rho,sme,liveset): conflict option * place at=
let fun rho_points_into rhos= List.find (equal_places rho) rhos
let fun rho_points_into rhos = List.find (equal_places rho) rhos
in debug1([],liveset);
any_live(rho,sme,liveset,rho_points_into,ATBOT rho)
end
Expand All @@ -357,7 +358,7 @@ structure AtInf : AT_INF =

fun letrec_bound (rho, sme, liveset): conflict option * place at=
let (*val _ = Profile.profileOn();*)
val rho_related = RegFlow.reachable_in_graph_with_insertion (rho)
val rho_related = RegFlow.reachable_in_graph_with_insertion rho
(*val _ = Profile.profileOff();*)
fun rho_points_into lrv = List.find is_visited lrv
in debug1(rho_related,liveset);
Expand Down Expand Up @@ -419,17 +420,21 @@ structure AtInf : AT_INF =
fun mu_to_scheme_and_place (tau:RType.Type, rho_opt : place option) : sigma * place option =
(RType.type_to_scheme tau, rho_opt)

(* traverse a list and apply the supplied function to each element and the other elements *)
fun traverse f nil acc = nil
| traverse f (x::xs) acc = f (x,rev acc @ xs) :: traverse f xs (x::acc)

(********************************)
(* sma0 traverses the program *)
(* and inserts storage modes *)
(********************************)

fun sma0 (pgm0 as PGM{expression=trip,
export_datbinds,
import_vars,
export_vars,
export_basis,
export_Psi}: (place * LLV.liveset, place*mul, qmularefset ref)LambdaPgm)
export_datbinds,
import_vars,
export_vars,
export_basis,
export_Psi}: (place * LLV.liveset, place*mul, qmularefset ref)LambdaPgm)
: (place at, place*mul, unit)LambdaPgm =
let fun sma_trip sme (TR(e, metaType, ateffects, mulef_r)) =
let fun sma_sw sme (SWITCH(tr,choices,opt)) =
Expand All @@ -441,8 +446,41 @@ structure AtInf : AT_INF =
val e' =
(case e
of VAR{lvar,il,plain_arreffs,fix_bound,rhos_actuals=ref actuals,other} =>
let val actuals' = map (which_at sme) actuals (* also liveset here*)
in VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs,
let val actuals' =
if SME.is_local_lvar_env (lvar,#2 sme) then
map (which_at sme) actuals (* also liveset here*)
else
case #2 il of
[_] => (* single arrow effect *)
let fun f (actual as (rho,_),others) =
case which_at sme actual of
actual' as ATTOP _ => actual'
| actual' =>
let val other_rhos = map (fn (r,_) => r) others
in case SME.retrieve_regvar_env(rho,#1 sme) of
SME.LETREGION_BOUND =>
if List.exists (equal_places rho) other_rhos
then ATTOP rho
else actual'
| SME.LETREC_BOUND =>
let val all_other_rhos = map RegFlow.reachable_in_graph_with_insertion other_rhos
val rho_related = RegFlow.reachable_in_graph_with_insertion rho
val () = List.app visit rho_related
val b = List.exists (List.exists is_visited) all_other_rhos
in List.app unvisit rho_related
; (if b then ATTOP rho else actual')
end
end handle SME.RegvarEnv => ATTOP rho
in traverse f actuals nil
end
| _ => ( (if debug_which_at()
then log ("NOT SIMPLE - gives ATTOP for all regargs: " ^ Lvars.pr_lvar lvar
^ "; len(actuals) = " ^ Int.toString (length actuals)
^ "; len(eps) = " ^ Int.toString (length (#2 il))
^ "\n")
else ())
; map (fn (rho, _) => ATTOP rho) actuals)
in VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs,
fix_bound=fix_bound,rhos_actuals=ref actuals',other=()}
end
| INTEGER(n, t, alloc) => INTEGER(n, t, Option.map (which_at sme) alloc)
Expand Down
9 changes: 3 additions & 6 deletions src/Compiler/Regions/DropRegions.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,10 +1,9 @@

structure DropRegions: DROP_REGIONS =
structure DropRegions : DROP_REGIONS =
struct
structure PP = PrettyPrint
structure Eff = Effect
structure RSE = RegionStatEnv

structure LvarMap = Lvars.Map

open MulExp AtInf
Expand Down Expand Up @@ -61,7 +60,7 @@ structure DropRegions: DROP_REGIONS =
fun visit_put_rhos [] = ()
| visit_put_rhos (arreff::arreffs) =
let fun visit_eval_effect effect = if Eff.is_put effect then visit(Eff.rho_of effect) else ()
val _ = List.app visit_eval_effect (Eff.represents arreff)
val _ = List.app visit_eval_effect (Eff.represents_no_gets arreff)
in visit_put_rhos arreffs
end
fun unvisit_bot_rhos [] = ()
Expand Down Expand Up @@ -125,13 +124,11 @@ structure DropRegions: DROP_REGIONS =
val export_env = ref empty




(* -----------------------------------------------------------------
* Environment for Region Variables
* ----------------------------------------------------------------- *)

structure PlaceMap = Eff.PlaceOrEffectMap
structure PlaceMap = Eff.Map

datatype regenv_res = DROPIT | KEEP | LETREGION_INF (*to disable global regions*)
type place = RType.place
Expand Down
7 changes: 4 additions & 3 deletions src/Compiler/Regions/EFFECT.sig
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -247,10 +247,11 @@ signature EFFECT = sig
val topsort : effect list -> effect list
val subgraph : effect list -> effect list

val eval_phis : effect list -> effect list (* returns all nodes in graph *)
val eval_phis : effect list -> effect list (* returns all nodes in graph (for ReML) *)
val check_nodes : {allnodes:effect list, letregions:effect list} -> unit (* check ReML constraints *)

val represents : effect -> effect list
val represents_no_gets : effect -> effect list
val represents_with_gets : effect -> effect list

val reset_cone : cone -> unit
val reset : unit -> unit (* reset list of effect updates; done once pr module *)
Expand All @@ -265,5 +266,5 @@ signature EFFECT = sig
val layoutCone : cone -> StringTree (* sets and clears visited field *)
val layoutEtas : effect list -> StringTree list (* sets and clears visited field *)

structure PlaceOrEffectMap : MONO_FINMAP where type dom = effect
structure Map : MONO_FINMAP where type dom = effect
end
5 changes: 0 additions & 5 deletions src/Compiler/Regions/EffVarEnv.sml
View file
Open in desktop

This file was deleted.

30 changes: 19 additions & 11 deletions src/Compiler/Regions/Effect.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1219,12 +1219,12 @@ struct
; Lf unique_nodes
end

structure PlaceOrEffectMap =
structure Map =
OrderFinMap(struct type t = effect
val lt = lt_eps_or_rho
end)

structure Increments = PlaceOrEffectMap
structure Increments = Map

val globalIncs : delta_phi Increments.map ref = ref Increments.empty

Expand Down Expand Up @@ -2206,7 +2206,7 @@ struct

(* Notice: We also check ReML constraints on atomic effects during this phase *)

structure MultiMerge =
structure MultiMerge : sig val multimerge : effect list list -> effect list end =
struct
(* A multi-way merge can be implemented by keeping a heap
of list of elements to be sorted. The lists in the heap
Expand All @@ -2224,7 +2224,6 @@ struct

structure Heap = Heap(structure HeapInfo = HI)

fun merge (ae1, ae2) = ae1
fun eq (ae1, ae2) = eq_effect(ae1, ae2)

fun makeHeap ll =
Expand All @@ -2242,14 +2241,14 @@ struct
else case Heap.delete_min h of
(l1 as (x1::xs1), h1) =>
if eq(min,x1) then
if Heap.is_empty h1 then merge(min,x1)::xs1
else merge_against(merge(min,x1), insert(xs1, h1))
if Heap.is_empty h1 then min::xs1
else merge_against(min, insert(xs1, h1))
else
if Heap.is_empty h1 then min :: l1
if Heap.is_empty h1 then min::l1
else min :: merge_against(x1, insert(xs1, h1))
| _ => die "merge_against"

fun merge_all h =
fun merge_all h =
if Heap.is_empty h then []
else case Heap.delete_min h of
(x1::xs1, h1) => merge_against(x1, insert(xs1,h1))
Expand Down Expand Up @@ -2474,7 +2473,7 @@ struct
[]
)
| PUT => [n]
| GET => []
| GET => [n]
| MUT => [n]
| _ => (say "bottom_up_eval: unexpected node(1): " ;
say_eps n; say "\n";
Expand Down Expand Up @@ -2503,7 +2502,7 @@ struct
result
end)
| PUT => [n]
| GET => []
| GET => [n]
| MUT => [n]
| RHO _ => []
)
Expand Down Expand Up @@ -2559,13 +2558,22 @@ struct
List.app (check_node letregions) allnodes
handle ? as Report.DeepError _ => raise ?

fun represents eps =
fun represents_no_gets eps =
case G.find_info eps of
EPS{represents = SOME l, ...} =>
List.filter (fn e => not(is_exn e) andalso not(is_mut e) andalso not(is_get e)) l
| _ => (say "No info for eps\n";
say_eps eps;
die ("represents"))

fun represents_with_gets eps =
case G.find_info eps of
EPS{represents = SOME l, ...} =>
List.filter (fn e => not(is_exn e) andalso not(is_mut e)) l
| _ => (say "No info for eps\n";
say_eps eps;
die ("represents"))

end

(*
Expand Down
Loading
Loading