Modular storage mode analysis

doc/manual/mlkit.tex

@@ -4312,10 +4312,14 @@ \section{Storage Mode Analysis}
 \begin{equation}
 \label{allocpoint}\fw{at}\,\rho
 \end{equation}
-be given.
+be given. Such an allocation point can be associated with the allocation of a
+constant value, an immediate closure, a record value, or the allocation of the
+result of a primitive operation. Another possibility is that the allocation
+point appears as an argument to a region-polymorphic function.
 \bigskip
 
-\noindent{\bf CASE A:} $\rho$ is a global region. Then \fw{attop} is used.
+\noindent{\bf CASE A:} The region $\rho$ is a global region.
+In this case \fw{attop} is used.
 There is a deficiency we have to admit here. The MLKit only puts
 \lstinline{region} bindings around expressions, not around declarations. Thus,
 if one writes

src/Compiler/Backend/ClosConvEnv.sml

@@ -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

src/Compiler/Backend/SubstAndSimplify.sml

@@ -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,

src/Compiler/Regions/AtInf.sml

@@ -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
@@ -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)
@@ -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
@@ -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
@@ -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 =>
@@ -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
@@ -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);
@@ -419,17 +420,51 @@ 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   *)
   (********************************)
 
+  (* For primitives and for calls to simple functions declared non-locally, we use
+     a modular scheme for assigning storage modes:
+        If a region argument is aliased with another argument or a region in the
+        type of a live variable, the region is passed attop. Otherwise:
+         (1) if the region is LETREGION-bound, it is passed atbot
+         (2) if the region is LETREC-bound, it is passed sat
+  *)
+  fun sma_modular_call sme actuals =
+      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 => (* leaf *)
+                         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
+
   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)) =
@@ -441,8 +476,21 @@ 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
+                                     [_] =>  (* SIMPLE: single arrow effect, function is defined elsewhere. *)
+                                     sma_modular_call sme actuals
+                                   | _ => ( (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)
@@ -546,12 +594,14 @@ structure AtInf : AT_INF =
                        EQUAL ({mu_of_arg1=mu_of_arg1, mu_of_arg2=mu_of_arg2},  (* no need for analysis *)
                               sma_trip sme tr1,sma_trip sme tr2)
                      | CCALL ({name, mu_result, rhos_for_result}, trs) =>
-                         CCALL ({name = name, mu_result = mu_result,
-                                 rhos_for_result =
-                                     map (fn ((rho, liveset), i_opt) =>
-                                          (which_at sme (rho, liveset), i_opt))
-                                     rhos_for_result},
-                                map (sma_trip sme) trs)
+                       let val (actuals, iopts) = ListPair.unzip rhos_for_result
+                           val actuals' = sma_modular_call sme actuals
+                           val rhos_for_result' = ListPair.zipEq (actuals',iopts)
+                                                  handle _ => die "ccall.zip"
+                       in CCALL ({name = name, mu_result = mu_result,
+                                  rhos_for_result = rhos_for_result'},
+                                 map (sma_trip sme) trs)
+                       end
                      | BLOCKF64 (alloc, trs) => BLOCKF64(which_at sme alloc,map (sma_trip sme) trs)
                      | SCRATCHMEM (n,alloc) => SCRATCHMEM(n,which_at sme alloc)
                      | EXPORT(i,tr) => EXPORT(i,sma_trip sme tr)

src/Compiler/Regions/DropRegions.sml

@@ -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
@@ -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 [] = ()
@@ -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

src/Compiler/Regions/EFFECT.sig

@@ -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 *)
@@ -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

src/Compiler/Regions/Effect.sml

@@ -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
 
@@ -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
@@ -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 =
@@ -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))
@@ -2474,7 +2473,7 @@ struct
                     []
                    )
               | PUT => [n]
-              | GET => []
+              | GET => [n]
               | MUT => [n]
               | _ => (say "bottom_up_eval: unexpected node(1): "  ;
                       say_eps n; say "\n";
@@ -2503,7 +2502,7 @@ struct
                       result
                     end)
                | PUT => [n]
-               | GET => []
+               | GET => [n]
                | MUT => [n]
                | RHO _ => []
               )
@@ -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
 
 (*