diff --git a/src/Compiler/Backend/ClosConvEnv.sml b/src/Compiler/Backend/ClosConvEnv.sml index 1266e3742..6a70710a5 100644 --- a/src/Compiler/Backend/ClosConvEnv.sml +++ b/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 diff --git a/src/Compiler/Backend/SubstAndSimplify.sml b/src/Compiler/Backend/SubstAndSimplify.sml index cf0279661..c8df73b3c 100644 --- a/src/Compiler/Backend/SubstAndSimplify.sml +++ b/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, diff --git a/src/Compiler/Regions/AtInf.sml b/src/Compiler/Regions/AtInf.sml index 4b514d243..8b7d06c9f 100644 --- a/src/Compiler/Regions/AtInf.sml +++ b/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,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)) = @@ -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) diff --git a/src/Compiler/Regions/DropRegions.sml b/src/Compiler/Regions/DropRegions.sml index 9b205b873..fa2793cee 100644 --- a/src/Compiler/Regions/DropRegions.sml +++ b/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 diff --git a/src/Compiler/Regions/EFFECT.sig b/src/Compiler/Regions/EFFECT.sig index 3e399c78e..651a47b85 100644 --- a/src/Compiler/Regions/EFFECT.sig +++ b/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 diff --git a/src/Compiler/Regions/EffVarEnv.sml b/src/Compiler/Regions/EffVarEnv.sml deleted file mode 100644 index d427d34e3..000000000 --- a/src/Compiler/Regions/EffVarEnv.sml +++ /dev/null @@ -1,5 +0,0 @@ -structure EffVarEnv= - OrderFinMap(struct - type t = Effect.effect - val lt = Effect.lt_eps_or_rho - end) diff --git a/src/Compiler/Regions/Effect.sml b/src/Compiler/Regions/Effect.sml index 9871185fc..c8f9efc92 100644 --- a/src/Compiler/Regions/Effect.sml +++ b/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 (* diff --git a/src/Compiler/Regions/LocallyLiveVariables.sml b/src/Compiler/Regions/LocallyLiveVariables.sml index b7646e6c8..caf458ddc 100644 --- a/src/Compiler/Regions/LocallyLiveVariables.sml +++ b/src/Compiler/Regions/LocallyLiveVariables.sml @@ -66,7 +66,6 @@ struct fun findLvar pred (liveset as (lvarset,_)) = Lvarset.findLvar pred lvarset - fun norm lvarset = lvarset fun fromList lvars = Lvarset.lvarsetof(lvars) @@ -75,10 +74,9 @@ struct (*******************************************) type liveset = lvarset * Excon.excon list - fun norm_liveset (lvarset, excons) = (norm lvarset, excons) fun layout_liveset (liveset) = - case norm_liveset liveset of + case liveset of (lvarset, excons) => PrettyPrint.NODE{start = "{", finish = "}", indent =1, childsep = PrettyPrint.RIGHT",", children = map (PrettyPrint.LEAF o Lvars.pr_lvar) (Lvarset.members lvarset) @ @@ -223,11 +221,11 @@ struct VAR{lvar,...} => (cp_triv_exp e, (singleton lvar, [])) | INTEGER(i,t,NONE) => (cp_triv_exp e, empty_liveset) - | INTEGER(i,t,SOME a) => (INTEGER(i,t,SOME(a, norm_liveset liveset)), empty_liveset) + | INTEGER(i,t,SOME a) => (INTEGER(i,t,SOME(a, liveset)), empty_liveset) | WORD(i,t,NONE) => (cp_triv_exp e, empty_liveset) - | WORD(i,t,SOME a) => (WORD(i,t,SOME(a, norm_liveset liveset)), empty_liveset) - | STRING(s,place) => (STRING(s, (place, norm_liveset liveset)), empty_liveset) - | REAL(r,place) => (REAL(r, (place, norm_liveset liveset)), empty_liveset) + | WORD(i,t,SOME a) => (WORD(i,t,SOME(a, liveset)), empty_liveset) + | STRING(s,place) => (STRING(s, (place, liveset)), empty_liveset) + | REAL(r,place) => (REAL(r, (place, liveset)), empty_liveset) | F64 r => (cp_triv_exp e, empty_liveset) | UB_RECORD(trs) => let val children = map (fn tr => llv(tr, liveset)) trs @@ -241,7 +239,7 @@ struct delete_lvars(freeInBody, map #1 pat) in (FN{pat=pat,body = body',free = free, - alloc = (p, norm_liveset(union_llv(liveset, for_closure)))}, + alloc = (p, union_llv(liveset, for_closure))}, for_closure) end | LETREGION{B,rhos,body} => @@ -267,7 +265,7 @@ struct val localFree = diff_llv(union_llv(freeInRhs, freeInScope), boundByLhs) in - (FIX{free =free, shared_clos = (rho, norm_liveset(union_llv(localFree, liveset))), + (FIX{free =free, shared_clos = (rho, union_llv(localFree, liveset)), functions = map(fn({lvar,occ,tyvars,rhos,epss,Type,rhos_formals, bound_but_never_written_into, @@ -285,9 +283,8 @@ struct rhos_actuals, other},meta,phi,psi), tr2) => (* equation 23 and 24 in popl 96 paper *) let - val liveset = norm_liveset liveset val (tr2',live_tr2) = llv(tr2, liveset) - val liveset_fx = norm_liveset(union_llv(live_tr2,add_lvar(liveset, f))) (* see equation 24 *) + val liveset_fx = union_llv(live_tr2,add_lvar(liveset, f)) (* see equation 24 *) in (APP(ck,sr,TR(VAR{lvar=f,il=il,plain_arreffs=plain_arreffs, fix_bound=true, (* see (24) *) @@ -315,7 +312,6 @@ struct (* non-empty list of actual regions: has to be primitive lvar *) (case Lvars.primitive lvar of SOME _ => let - val liveset = norm_liveset liveset val (tr2',live_tr2) = llv(tr2, liveset) in (APP(ck,sr,TR(VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs, @@ -336,7 +332,7 @@ struct | EXCEPTION(excon,b,mu,rho,tr1) => let val (tr1',freeInScope) = llv(tr1, liveset) in - (EXCEPTION(excon,b,mu,(rho,norm_liveset(liveset)),tr1'), + (EXCEPTION(excon,b,mu,(rho,liveset),tr1'), delete_excon(freeInScope, excon)) end @@ -393,14 +389,14 @@ struct end | CON0{con,il,aux_regions,alloc=NONE} => - let val livehere = norm_liveset liveset + let val livehere = liveset in (CON0{con=con,il=il,aux_regions= map (fn rho => (rho,livehere)) aux_regions, alloc = NONE}, empty_liveset) end | CON0{con,il,aux_regions,alloc=SOME alloc} => - let val livehere = norm_liveset liveset + let val livehere = liveset in (CON0{con=con,il=il,aux_regions= map (fn rho => (rho,livehere)) aux_regions, alloc = SOME(alloc,livehere)}, @@ -409,14 +405,14 @@ struct | CON1({con,il,alloc=NONE},tr1) => (* tr1 is trivial *) let val (tr1',freeInArgs) = llv(tr1, liveset) - val livehere = norm_liveset(union_llv(liveset, freeInArgs)) + val livehere = union_llv(liveset, freeInArgs) in (CON1({con=con,il=il,alloc=NONE}, tr1'), freeInArgs) end | CON1({con,il,alloc=SOME alloc},tr1) => (* tr1 is trivial *) let val (tr1',freeInArgs) = llv(tr1, liveset) - val livehere = norm_liveset(union_llv(liveset, freeInArgs)) + val livehere = union_llv(liveset, freeInArgs) in (CON1({con=con,il=il,alloc=SOME(alloc,livehere)}, tr1'), freeInArgs) @@ -429,7 +425,7 @@ struct | EXCON(excon,NONE) => (EXCON(excon,NONE), empty_liveset) | EXCON(excon,SOME(rho,tr1)) => (* tr1 trivial *) let val (tr1', free_tr1) = llv(tr1, liveset) - in (EXCON(excon,SOME((rho, norm_liveset(union_llv(liveset,free_tr1))),tr1')), + in (EXCON(excon,SOME((rho, union_llv(liveset,free_tr1)),tr1')), add_excon(free_tr1,excon)) end | DEEXCON(excon,tr1) => (* tr1 trivial *) @@ -440,7 +436,7 @@ struct | RECORD(SOME rho, trs) => (* elements of trs trivial *) let val children = map (fn tr => llv(tr, liveset)) trs val freeInArgs = union_many(map #2 children) - in (RECORD(SOME(rho,norm_liveset(union_llv(freeInArgs, liveset))), map #1 children), + in (RECORD(SOME(rho,union_llv(freeInArgs, liveset)), map #1 children), freeInArgs) end | RECORD(NONE, nil) => (RECORD(NONE, nil), empty_liveset) @@ -456,7 +452,7 @@ struct end | REF(rho,tr1) => (* tr1 trivial *) let val (tr1', free_tr1) = llv(tr1, liveset) - in (REF((rho,norm_liveset(union_llv(free_tr1, liveset))), tr1'), + in (REF((rho,union_llv(free_tr1, liveset)), tr1'), free_tr1) end | ASSIGN(tr1,tr2) => (* tr1 and tr2 trivial *) @@ -482,7 +478,7 @@ struct let val children = map (fn tr => llv(tr, liveset)) trs val freeInChildren = union_many(map #2 children) - val liveset_here = norm_liveset(union_llv(freeInChildren, liveset)) + val liveset_here = union_llv(freeInChildren, liveset) in (CCALL ({name = name, mu_result = mu_result, rhos_for_result = @@ -496,17 +492,16 @@ struct let val children = map (fn tr => llv(tr, liveset)) trs val freeInArgs = union_many(map #2 children) in - (BLOCKF64((rho,norm_liveset(union_llv(freeInArgs, liveset))), map #1 children), + (BLOCKF64((rho,union_llv(freeInArgs, liveset)), map #1 children), freeInArgs) end - | SCRATCHMEM(n,a) => (SCRATCHMEM(n,(a, norm_liveset liveset)), empty_liveset) + | SCRATCHMEM(n,a) => (SCRATCHMEM(n,(a, liveset)), empty_liveset) | EXPORT(i,tr1) => let val (tr1', free_in_tr1) = llv(tr1,liveset) in (EXPORT(i,tr1'), free_in_tr1) end | RESET_REGIONS({force,regions_for_resetting,...}, tr1) => (* tr1 is trivial *) let - val liveset = norm_liveset liveset val (tr1', free_tr1) = llv(tr1, liveset) in (RESET_REGIONS({force=force, diff --git a/src/Compiler/Regions/Mul.sml b/src/Compiler/Regions/Mul.sml index b7c54ba68..c07569856 100644 --- a/src/Compiler/Regions/Mul.sml +++ b/src/Compiler/Regions/Mul.sml @@ -1,5 +1,5 @@ -structure Mul: MUL = +structure Mul : MUL = struct structure Eff = Effect structure Lam = LambdaExp @@ -7,7 +7,7 @@ struct structure RSE = RegionStatEnv structure PP = PrettyPrint structure QM_EffVarEnv = - QuasiEnv(structure OFinMap = EffVarEnv + QuasiEnv(structure OFinMap = Eff.Map val key = Effect.key_of_eps_or_rho val eq = Effect.eq_effect) @@ -99,7 +99,7 @@ struct val empty_mularefmap = GlobalEffVarEnv.empty val initial_mularefmap = let val _ = Eff.eval_phis [Eff.toplevel_arreff] - val mulef = map (fn ae => (ae,INF)) (Eff.represents Eff.toplevel_arreff) + val mulef = map (fn ae => (ae,INF)) (Eff.represents_no_gets Eff.toplevel_arreff) val mularef = (Eff.toplevel_arreff,mulef) in GlobalEffVarEnv.add(Eff.toplevel_arreff, ref mularef, GlobalEffVarEnv.empty) end diff --git a/src/Compiler/Regions/MulInf.sml b/src/Compiler/Regions/MulInf.sml index 9479ea41d..81eef351e 100644 --- a/src/Compiler/Regions/MulInf.sml +++ b/src/Compiler/Regions/MulInf.sml @@ -584,7 +584,7 @@ struct (* Psi records multiplicities for effect variables that are * bound locally within the program unit or are exported from * the program unit. Psi is a quasi-map (i.e., partly imperative)*) - let val Phi = map (fn eps => (eps, Eff.represents eps)) + let val Phi = map (fn eps => (eps, Eff.represents_no_gets eps)) ( (*Eff.toplevel_arreff :: ;mael 2004-03-31*) (List.filter Eff.is_arrow_effect effects)) val _ = if test then say " made Phi, now constructing the map Psi..." else () in makezero_Phi Phi diff --git a/src/Compiler/Regions/PhysSizeInf.sml b/src/Compiler/Regions/PhysSizeInf.sml index c3f6b01fe..0a6e65cac 100644 --- a/src/Compiler/Regions/PhysSizeInf.sml +++ b/src/Compiler/Regions/PhysSizeInf.sml @@ -1,7 +1,7 @@ structure PhysSizeInf: PHYS_SIZE_INF = struct - structure RegvarFinMap = EffVarEnv + structure RegvarFinMap = Effect.Map structure PP = PrettyPrint structure LvarMap = Lvars.Map diff --git a/src/Compiler/Regions/RegFlow.sml b/src/Compiler/Regions/RegFlow.sml index 9119e75be..8a4f27806 100644 --- a/src/Compiler/Regions/RegFlow.sml +++ b/src/Compiler/Regions/RegFlow.sml @@ -1,6 +1,6 @@ (* Region Flow Analysis: first pass of Storage Mode Analysis *) -structure RegFlow: REG_FLOW = +structure RegFlow : REG_FLOW = struct structure Eff = Effect structure PP = PrettyPrint @@ -17,14 +17,13 @@ struct type exp = (place, place*mul, qmularefset ref)MulExp.LambdaExp type trip = (place, place*mul, qmularefset ref)MulExp.trip - (* ---------------------------------------------------------------------- *) (* General Abbreviations *) (* ---------------------------------------------------------------------- *) fun log s = TextIO.output(!Flags.log,s ^ "\n") - fun device(s) = TextIO.output(!Flags.log, s) - fun dump(t) = PrettyPrint.outputTree(device, t, !Flags.colwidth) + fun device s = TextIO.output(!Flags.log, s) + fun dump t = PrettyPrint.outputTree(device, t, !Flags.colwidth) fun die errmsg = Crash.impossible ("RegFlow." ^ errmsg) fun unimplemented x = Crash.unimplemented ("RegFlow." ^ x) @@ -41,31 +40,28 @@ struct (* Utility functions *) (* ---------------------------------------------------------------------- *) - fun footnote(x,y) = x + fun footnote (x,y) = x infix footnote fun noSome x errmsg = - case x of - NONE => die errmsg - | SOME y => y - + case x of + NONE => die errmsg + | SOME y => y fun equal_places' p q = Eff.eq_effect(p,q) - (* ---------------------------------------------------------------------- *) (* Region-flow Graphs *) (* ---------------------------------------------------------------------- *) type nodeVal = effect - fun eq_nodeVal(p1, p2) = Eff.eq_effect(p1,p2) + fun eq_nodeVal (p1,p2) = Eff.eq_effect(p1,p2) - fun key_of_node(nodeVal) = Eff.key_of_eps_or_rho nodeVal + fun key_of_node nodeVal = Eff.key_of_eps_or_rho nodeVal fun pp_nodeVal p = PP.flatten1(Eff.layout_effect p) - exception Find fun find [] x = raise Find | find ((x',y)::rest) x = if eq_nodeVal(x,x') then y else find rest x @@ -74,22 +70,20 @@ struct datatype graph = NODE of nodeVal * visited ref * graph list ref - fun reachable(n) = - let - fun reachable(NODE(p,v,ref L), acc) = - if !v then acc - else - (v := true; - reachable_edges(L, p:: acc)) - and reachable_edges ([],acc) = acc - | reachable_edges (n::rest,acc) = reachable_edges(rest, reachable(n,acc)) - - fun revisit(NODE(p,v,ref L)) = - if !v then (v:= false; List.app revisit L) - else () + fun nodeVal (NODE (p,_,_)) = p - in - reachable (n, []) footnote revisit n + fun reachable n = + let fun reachable (NODE(p,v,ref L), acc) = + if !v then acc + else (v := true; + reachable_edges(L, p::acc)) + and reachable_edges ([],acc) = acc + | reachable_edges (n::rest,acc) = reachable_edges(rest, reachable(n,acc)) + + fun revisit (NODE(p,v,ref L)) = + if !v then (v:= false; List.app revisit L) + else () + in reachable (n, []) footnote revisit n end fun eq_graph (NODE(p1,v1,r1))(NODE(p2,v2,r2)) = @@ -99,90 +93,68 @@ struct val regmap_size = 1000 - abstype regmap = REGMAP of (nodeVal * graph)list Array.array + abstype regmap = REGMAP of graph list Array.array (* hash table from keys (nodeVal mod regmap_size) to buckets of nodes with the same hash key *) with - fun array_of(ref(REGMAP a)) = a + fun array_of (ref(REGMAP a)) = a val R = ref(REGMAP(Array.array(regmap_size, []))) fun lookup_assoc p [] = NONE - | lookup_assoc p ((p', graph)::rest) = - if eq_nodeVal(p,p') then SOME graph - else lookup_assoc p rest + | lookup_assoc p (g::rest) = + if eq_nodeVal(p,nodeVal g) then SOME g + else lookup_assoc p rest - fun lookup_R p : graph option= - (* lookup p first in the binary tree and then in the association list *) + fun lookup_R p : graph option = + (* lookup p first in the array and then in the association list *) lookup_assoc p (Array.sub(array_of R, key_of_node p mod regmap_size)) - fun new_graph(p) = NODE(p, ref false, ref[]) + fun new_graph p = NODE(p, ref false, ref[]) fun lookup_R_with_insert (p: nodeVal) = let val i = key_of_node p mod regmap_size val l = Array.sub(array_of R, i) - in - (case lookup_assoc p l of - SOME g => g - | NONE => (*insert (p, new_graph p) in association list *) - let val g = new_graph(p) - in Array.update(array_of R, i, (p,g)::l); - g - end) + in case lookup_assoc p l of + SOME g => g + | NONE => (*insert (p, new_graph p) in association list *) + let val g = new_graph p + in Array.update(array_of R, i, g::l) + ; g + end end + (* add_node_iter p: add p to graph, if it has not been added already*) fun add_node_iter p = (lookup_R_with_insert p; ()) - fun add_edge_graph_iter(p: nodeVal, (g as NODE(p',_,_)): graph) = - case lookup_R p of - SOME (NODE(_,_, r' as (ref subG))) => - r':= (if (List.exists (eq_graph g) subG) then subG - else - ((*log ("adding edge from " ^ (pp_nodeVal p) ^ " to " - ^ (pp_nodeVal p') ^ "\n");*) - g::subG)) - | NONE => - Crash.impossible ("add_edge_graph_iter: can't find node " ^ pp_nodeVal p) + fun add_edge_graph_iter (p: nodeVal, (g as NODE(p',_,_)): graph) = + case lookup_R p of + SOME (NODE(_,_, r' as ref subG)) => + r':= (if (List.exists (eq_graph g) subG) then subG + else + ((*log ("adding edge from " ^ (pp_nodeVal p) ^ " to " + ^ (pp_nodeVal p') ^ "\n");*) + g::subG)) + | NONE => + Crash.impossible ("add_edge_graph_iter: can't find node " ^ pp_nodeVal p) (* add edge from node labelled by p, which must exist, to node labelled q (which may be created) *) - fun add_edge_iter(p: nodeVal, q: nodeVal) = - add_edge_graph_iter(p, lookup_R_with_insert q) - - (* connecting a region variable to a global region variable - with the same runtime type *) + fun add_edge_iter (p: nodeVal, q: nodeVal) = + add_edge_graph_iter(p, lookup_R_with_insert q) - fun connect_to_global rho : unit= - case Eff.get_place_ty rho of - SOME Eff.STRING_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_string) - | SOME Eff.PAIR_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_pair) - | SOME Eff.ARRAY_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_array) - | SOME Eff.REF_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_ref) - | SOME Eff.TRIPLE_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_triple) - | SOME Eff.TOP_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_top) - | SOME Eff.BOT_RT => (add_edge_iter(rho,Eff.toplevel_region_withtype_bot); - add_edge_iter(rho,Eff.toplevel_region_withtype_string); - add_edge_iter(rho,Eff.toplevel_region_withtype_pair); - add_edge_iter(rho,Eff.toplevel_region_withtype_array); - add_edge_iter(rho,Eff.toplevel_region_withtype_ref); - add_edge_iter(rho,Eff.toplevel_region_withtype_triple); - add_edge_iter(rho,Eff.toplevel_region_withtype_top)) - | NONE => die "connect_to_global" - - - fun init_regmap() = R:= REGMAP(Array.array(regmap_size, [])) + fun init_regmap () = R := REGMAP(Array.array(regmap_size, [])) (* find the places that are reachable from the place p *) fun reachable_in_graph_with_insertion p = foldl (fn (nodeVal, acc: place list) => - if Eff.is_rho nodeVal then nodeVal :: acc else acc) - [] - (reachable(lookup_R_with_insert p)) + if Eff.is_rho nodeVal then nodeVal :: acc else acc) + [] + (reachable(lookup_R_with_insert p)) (* Find the places in the graph reachable from any place or arrow effect in the list ps *) - fun reachable_with_insertion ps = let fun reachable (node as NODE(p,v,ref L), acc) = if !v then acc @@ -195,10 +167,10 @@ struct loop (pr, reachable(lookup_R_with_insert p, acc)) val reachableNodes = loop (ps, []) in - foldl (fn (NODE(nodeVal, v, _), acc : place list) => - (v := false; - if Eff.is_rho nodeVal then nodeVal :: acc else acc)) - [] reachableNodes + foldl (fn (NODE(nodeVal, v, _), acc : place list) => + (v := false; + if Eff.is_rho nodeVal then nodeVal :: acc else acc)) + [] reachableNodes end end (*abstype*) @@ -207,20 +179,22 @@ struct (* Creating a Region Flow Graph *) (* ---------------------------------------------------------------------- *) - fun insert(arreff): unit = (* assuming arreff = eps.phi, insert(arreff) makes + fun insert arreff : unit = (* assuming arreff = eps.phi, insert(arreff) makes an edge from eps to every region and effect variable which occurs free in phi *) let - val children = Eff.represents arreff + val children = Eff.represents_with_gets arreff handle ex => die ("insert " ^ pp_nodeVal arreff) + val children = map (fn e => if Eff.is_put e orelse Eff.is_get e orelse Eff.is_mut e then Eff.rho_of e else e) + children in (* make sure arreff is inserted *) - add_node_iter(arreff); + add_node_iter arreff; List.app (fn child => - if Eff.is_rho child orelse - Eff.is_arrow_effect child - then add_edge_iter(arreff, child) - else ()) children + if Eff.is_rho child orelse + Eff.is_arrow_effect child + then add_edge_iter(arreff, child) + else ()) children end local @@ -232,7 +206,7 @@ struct exception FRAME_NOT_FOUND - fun find(TR(e,_,_,_)) = find_exp e + fun find (TR(e,_,_,_)) = find_exp e and find_exp e = let fun find_sw(SWITCH(_,branches,otherwise)) = @@ -261,10 +235,7 @@ struct fun mk_graph0 trip = let - val exported = find trip handle FRAME_NOT_FOUND => die "frame not found" - fun is_exported lvar = List.exists (fn lvar_frame => Lvars.eq(lvar, lvar_frame)) exported - - fun mk_graph_exp(e: exp): unit = + fun mk_graph_exp (e: exp): unit = case e of FIX {free, shared_clos, functions, scope} => let @@ -273,16 +244,8 @@ struct bound_but_never_written_into, other,bind} = let - val _ = List.app insert formal_arreffs - (*val _ = log("lvar = " ^ Lvars.pr_lvar lvar ^ ":" ^ Int.toString(length formal_regvars)) *) - - (* region-polymorphic functions which are exported must have their formal - region parameters connected to global regions with the same runtime type. - This is necessary for soundness of the analysis across program units. - *) - fun deal_with_one_instance il = let val (actual_rhos, actual_epss, taus) = RType.un_il il in @@ -300,13 +263,9 @@ struct handle BasisCompat.ListPair.UnequalLengths => die "deal_with_one_instance (2)"); List.app insert actual_epss - end - in List.app add_node_iter formal_regvars; - if is_exported lvar then List.app connect_to_global formal_regvars - else (); List.app add_node_iter formal_arreffs; List.app deal_with_one_instance instances; mk_graph bind diff --git a/src/Compiler/Regions/RegionStatEnv.sml b/src/Compiler/Regions/RegionStatEnv.sml index f54521dd5..80ad9352f 100644 --- a/src/Compiler/Regions/RegionStatEnv.sml +++ b/src/Compiler/Regions/RegionStatEnv.sml @@ -330,7 +330,7 @@ structure RegionStatEnv: REGION_STAT_ENV = dump(E.layout_effect_deep(node)); die "mkConeToplevel.closure.node not arrow effect or get/put effect") end) - acc (E.represents rho_eps) (* very nasty bug fixed; the two arguments to foldL were the wrong way around; mads *) + acc (E.represents_no_gets rho_eps) (* very nasty bug fixed; the two arguments to foldL were the wrong way around; mads *) else if E.is_rho rho_eps then rho_eps :: acc else acc end) @@ -362,7 +362,7 @@ structure RegionStatEnv: REGION_STAT_ENV = dump(E.layout_effect_deep(node)); die "mkConeToplevel.closure.node not arrow effect or get/put effect") ) - acc (E.represents rho_eps) + acc (E.represents_no_gets rho_eps) else if E.is_rho rho_eps then rho_eps :: acc else acc ) diff --git a/src/Compiler/regions.mlb b/src/Compiler/regions.mlb index 8bf03b594..4af353e2a 100644 --- a/src/Compiler/regions.mlb +++ b/src/Compiler/regions.mlb @@ -46,7 +46,6 @@ in in Regions/RegionExp.sml local open Pickle in Regions/RegionStatEnv.sml end end - Regions/EffVarEnv.sml ../Common/QUASI_ENV.sml local open Pickle in ../Common/QuasiEnv.sml end local open Edlib Pickle CompilerObjects in Regions/Mul.sml end diff --git a/test/all.tst b/test/all.tst index 4ab46f405..2aded784b 100644 --- a/test/all.tst +++ b/test/all.tst @@ -183,4 +183,5 @@ foldbug.sml seltuptup.sml poll.sml enum-eq.sml -stringconcat.sml noopt (* check transformation of calls to argument-transformed functions *) \ No newline at end of file +stringconcat.sml noopt (* check transformation of calls to argument-transformed functions *) +sma.sml noopt (* storage mode error - issue #208 *) \ No newline at end of file diff --git a/test/sma.sml b/test/sma.sml new file mode 100644 index 000000000..687825c66 --- /dev/null +++ b/test/sma.sml @@ -0,0 +1,16 @@ +local +fun pr s = (print s; print "\n") + +fun f (g: unit -> unit) : string = + let val y : string = implode [#"H", #"i"] + in g() + ; y + end + +fun run () : unit = + pr let val x : string = implode [#"H", #"e", #"j"] + in if false then x else f (fn () => pr x) + end +in +val () = run() +end diff --git a/test/sma.sml.out.ok b/test/sma.sml.out.ok new file mode 100644 index 000000000..155899c79 --- /dev/null +++ b/test/sma.sml.out.ok @@ -0,0 +1,2 @@ +Hej +Hi