diff --git a/src/Compiler/Backend/CLOS_EXP.sml b/src/Compiler/Backend/CLOS_EXP.sml index 913f1e810..cd28d90c7 100644 --- a/src/Compiler/Backend/CLOS_EXP.sml +++ b/src/Compiler/Backend/CLOS_EXP.sml @@ -75,9 +75,9 @@ signature CLOS_EXP = | FNJMP of {opr: ClosExp, args: ClosExp list, clos: ClosExp option} | FNCALL of {opr: ClosExp, args: ClosExp list, clos: ClosExp option} | JMP of {opr: label, args: ClosExp list, reg_vec: ClosExp option, reg_args: ClosExp list, - clos: ClosExp option} + clos: ClosExp option} | FUNCALL of {opr: label, args: ClosExp list, reg_vec: ClosExp option, reg_args: ClosExp list, - clos: ClosExp option} + clos: ClosExp option} | LETREGION of {rhos: binder list, body: ClosExp} | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} | RAISE of ClosExp @@ -95,18 +95,18 @@ signature CLOS_EXP = | ASSIGN of sma * ClosExp * ClosExp | DROP of ClosExp | RESET_REGIONS of {force: bool, - regions_for_resetting: sma list} + regions_for_resetting: sma list} | CCALL of {name: string, - args: ClosExp list, - rhos_for_result : ClosExp list} + args: ClosExp list, + rhos_for_result : ClosExp list} | CCALL_AUTO of {name: string, - args: (ClosExp * foreign_type) list, - res: foreign_type} + args: (ClosExp * foreign_type) list, + res: foreign_type} | EXPORT of {name: string, - clos_lab: label, - arg: ClosExp * foreign_type * foreign_type} + clos_lab: label, + arg: ClosExp * foreign_type * foreign_type} | FRAME of {declared_lvars: {lvar: lvar, label: label} list, - declared_excons: {excon: excon, label: label} list} + declared_excons: {excon: excon, label: label} list} and 'a Switch = SWITCH of ClosExp * ('a * ClosExp) list * ClosExp @@ -134,20 +134,20 @@ signature CLOS_EXP = val enrich : env * env -> bool val match : env * env -> unit val restrict : env * {lvars:lvar list, - cons:con list, - excons:excon list} -> env + cons:con list, + excons:excon list} -> env (* restrict0 : Don't include predeclared regions *) val restrict0 : env * {lvars:lvar list, - cons:con list, - excons:excon list} -> env + cons:con list, + excons:excon list} -> env val pu : env Pickle.pu val cc : env * ((place*pp) at, place*phsize, unit)LambdaPgm -> {main_lab:label, - code:ClosPrg, - env:env, - imports:label list * label list, - exports:label list * label list} + code:ClosPrg, + env:env, + imports:label list * label list, + exports:label list * label list} type StringTree val layout_clos_exp : ClosExp -> StringTree diff --git a/src/Compiler/Backend/ClosExp.sml b/src/Compiler/Backend/ClosExp.sml index 38b2f9df7..8c0ef266b 100644 --- a/src/Compiler/Backend/ClosExp.sml +++ b/src/Compiler/Backend/ClosExp.sml @@ -1,13 +1,13 @@ functor ClosExp(structure CallConv: CALL_CONV where type lvar = Lvars.lvar - structure ClosConvEnv: CLOS_CONV_ENV + structure ClosConvEnv: CLOS_CONV_ENV where type con = Con.con where type place = AtInf.place where type excon = Excon.excon where type lvar = Lvars.lvar where type label = AddressLabels.label - where type phsize = PhysSizeInf.phsize - where type StringTree = PrettyPrint.StringTree - structure BI : BACKEND_INFO) : CLOS_EXP = + where type phsize = PhysSizeInf.phsize + where type StringTree = PrettyPrint.StringTree + structure BI : BACKEND_INFO) : CLOS_EXP = struct structure PP = PrettyPrint structure Labels = AddressLabels @@ -42,7 +42,7 @@ struct fun pp_lvars s lvs = let fun loop nil = () - | loop (lv::lvs) = (print (Lvars.pr_lvar lv); print ","; loop lvs) + | loop (lv::lvs) = (print (Lvars.pr_lvar lv); print ","; loop lvs) in print (s ^ " = ["); loop lvs; print "]\n" end @@ -85,9 +85,9 @@ struct | FNJMP of {opr: ClosExp, args: ClosExp list, clos: ClosExp option} | FNCALL of {opr: ClosExp, args: ClosExp list, clos: ClosExp option} | JMP of {opr: label, args: ClosExp list, reg_vec: ClosExp option, reg_args: ClosExp list, - clos: ClosExp option} + clos: ClosExp option} | FUNCALL of {opr: label, args: ClosExp list, reg_vec: ClosExp option, reg_args: ClosExp list, - clos: ClosExp option} + clos: ClosExp option} | LETREGION of {rhos: binder list, body: ClosExp} | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} | RAISE of ClosExp @@ -105,18 +105,18 @@ struct | ASSIGN of sma * ClosExp * ClosExp | DROP of ClosExp | RESET_REGIONS of {force: bool, - regions_for_resetting: sma list} + regions_for_resetting: sma list} | CCALL of {name: string, - args: ClosExp list, - rhos_for_result : ClosExp list} + args: ClosExp list, + rhos_for_result : ClosExp list} | CCALL_AUTO of {name: string, - args: (ClosExp * foreign_type) list, - res: foreign_type} + args: (ClosExp * foreign_type) list, + res: foreign_type} | EXPORT of {name: string, - clos_lab: label, - arg: ClosExp * foreign_type * foreign_type} + clos_lab: label, + arg: ClosExp * foreign_type * foreign_type} | FRAME of {declared_lvars: {lvar: lvar, label: label} list, - declared_excons: {excon: excon, label: label} list} + declared_excons: {excon: excon, label: label} list} and 'a Switch = SWITCH of ClosExp * ('a * ClosExp) list * ClosExp @@ -166,25 +166,25 @@ struct | layout_f Unit = LEAF "Unit" fun layout_ce_f layout_ce (ce,f) = HNODE{start="",finish="",childsep=RIGHT":", - children=[layout_ce ce, layout_f f]} + children=[layout_ce ce, layout_f f]} fun layout_switch layout_ce pr_const (SWITCH(ce_arg,sels,default)) = - let - fun layout_sels(const,ce_sel) = - NODE{start="",finish="",indent=0, - children=[LEAF (pr_const const), layout_ce ce_sel], - childsep=RIGHT " => "} - val t1 = NODE{start="(case ",finish=" ",indent=2, childsep = NOSEP, - children=[layout_ce ce_arg]} - val t2 = NODE{start="of " ,finish="",indent=4,childsep=LEFT " | ", - children=(map layout_sels sels) @ - [NODE{start="",finish="",indent=0, - children=[LEAF "_",layout_ce default], - childsep=RIGHT " => "}]} - val t3 = NODE{start="",finish=") (*case*) ",indent=3,childsep=NOSEP,children=[t2]} - in - NODE{start = "", finish = "", indent=0, childsep=NOSEP,children=[t1,t3]} - end + let + fun layout_sels(const,ce_sel) = + NODE{start="",finish="",indent=0, + children=[LEAF (pr_const const), layout_ce ce_sel], + childsep=RIGHT " => "} + val t1 = NODE{start="(case ",finish=" ",indent=2, childsep = NOSEP, + children=[layout_ce ce_arg]} + val t2 = NODE{start="of " ,finish="",indent=4,childsep=LEFT " | ", + children=(map layout_sels sels) @ + [NODE{start="",finish="",indent=0, + children=[LEAF "_",layout_ce default], + childsep=RIGHT " => "}]} + val t3 = NODE{start="",finish=") (*case*) ",indent=3,childsep=NOSEP,children=[t2]} + in + NODE{start = "", finish = "", indent=0, childsep=NOSEP,children=[t1,t3]} + end fun layout_ce(VAR lv) = LEAF(Lvars.pr_lvar lv) | layout_ce(RVAR place) = Effect.layout_effect place @@ -199,119 +199,119 @@ struct | layout_ce(PASS_PTR_TO_MEM(sma,i)) = LEAF("MEM(" ^ (flatten1(pr_sma sma)) ^ "," ^ Int.toString i ^ ")") | layout_ce(PASS_PTR_TO_RHO(sma)) = LEAF("PTR(" ^ (flatten1(pr_sma sma)) ^ ")") | layout_ce(UB_RECORD ces) = HNODE{start="<", - finish=">", - childsep=RIGHT ",", - children=map layout_ce ces} + finish=">", + childsep=RIGHT ",", + children=map layout_ce ces} | layout_ce(CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc}) = HNODE{start="[", - finish="]clos " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children=LEAF(Labels.pr_label label):: - map layout_ce (rhos@excons@lvs)} + finish="]clos " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children=LEAF(Labels.pr_label label):: + map layout_ce (rhos@excons@lvs)} | layout_ce(REGVEC_RECORD{elems,alloc}) = HNODE{start="[", - finish="]regvec " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children=map (fn sma => pr_sma sma) elems} + finish="]regvec " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children=map (fn sma => pr_sma sma) elems} | layout_ce(SCLOS_RECORD{elems=(lvs,excons,rhos),alloc}) = HNODE{start="[", - finish="]sclos " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children= map layout_ce (rhos@excons@lvs)} + finish="]sclos " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children= map layout_ce (rhos@excons@lvs)} | layout_ce(RECORD{elems,alloc,tag,maybeuntag}) = HNODE{start="(", - finish=") " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children= map layout_ce elems} + finish=") " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children= map layout_ce elems} | layout_ce(BLOCKF64{elems,alloc,tag}) = HNODE{start="{", - finish="} " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children= map layout_ce elems} + finish="} " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children= map layout_ce elems} | layout_ce(SCRATCHMEM{bytes,alloc,tag}) = LEAF("scratch(" ^ Int.toString bytes ^ flatten1(pr_sma alloc)) | layout_ce(SELECT(i,ce)) = HNODE{start="#" ^ Int.toString i ^ "(", - finish=")", - childsep=NOSEP, - children=[layout_ce ce]} + finish=")", + childsep=NOSEP, + children=[layout_ce ce]} | layout_ce(FNJMP{opr,args,clos}) = let - val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} - val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} - in - NODE{start=flatten1(layout_ce opr) ^ "_fnjmp ", - finish="", childsep=RIGHT " ", - indent=3, - children=[t1,t2]} - end + val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} + val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} + in + NODE{start=flatten1(layout_ce opr) ^ "_fnjmp ", + finish="", childsep=RIGHT " ", + indent=3, + children=[t1,t2]} + end | layout_ce(FNCALL{opr,args,clos}) = let - val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} - val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} - in - NODE{start=flatten1(layout_ce opr) ^ "_fncall ", - finish="", childsep=RIGHT " ", - indent=3, - children=[t1,t2]} - end + val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} + val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} + in + NODE{start=flatten1(layout_ce opr) ^ "_fncall ", + finish="", childsep=RIGHT " ", + indent=3, + children=[t1,t2]} + end | layout_ce(JMP{opr,args,reg_vec,reg_args,clos}) = let - val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} - val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt reg_vec]} - val t3 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce reg_args} - val t4 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} - in - NODE{start=Labels.pr_label opr ^ "_funjmp", - finish="", childsep=RIGHT " ", - indent=3, - children=[t1,t2,t3,t4]} - end + val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} + val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt reg_vec]} + val t3 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce reg_args} + val t4 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} + in + NODE{start=Labels.pr_label opr ^ "_funjmp", + finish="", childsep=RIGHT " ", + indent=3, + children=[t1,t2,t3,t4]} + end | layout_ce(FUNCALL{opr,args,reg_vec,reg_args,clos}) = let - val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} - val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt reg_vec]} - val t3 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce reg_args} - val t4 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} - in - NODE{start=Labels.pr_label opr ^ "_funcall", - finish="", childsep=RIGHT " ", - indent=3, - children=[t1,t2,t3,t4]} - end + val t1 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce args} + val t2 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt reg_vec]} + val t3 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=map layout_ce reg_args} + val t4 = NODE{start="<",finish=">",indent=3,childsep=RIGHT ",",children=[layout_ce_opt clos]} + in + NODE{start=Labels.pr_label opr ^ "_funcall", + finish="", childsep=RIGHT " ", + indent=3, + children=[t1,t2,t3,t4]} + end | layout_ce(LETREGION{rhos=[],body}) = layout_ce body | layout_ce(LETREGION{rhos,body}) = let - val binders = HNODE{start = "", - finish = "", - childsep = RIGHT", ", - children = map (fn b => LEAF(pr_binder b)) rhos} - val t1 = NODE{start="letregion ", - finish="", - childsep=NOSEP, - indent=10, - children=[binders]} - val t2 = NODE{start="in ", - finish="", - childsep=NOSEP, - indent=3, - children=[layout_ce body]} - val t3 = NODE{start="end (*", - finish="*)", - childsep=NOSEP, - indent=6, - children=[HNODE{start="", - finish="", - childsep=RIGHT", ", - children=[binders]}]} - in - NODE{start="",finish="",indent=0,childsep=RIGHT " ",children=[t1,t2,t3]} - end + val binders = HNODE{start = "", + finish = "", + childsep = RIGHT", ", + children = map (fn b => LEAF(pr_binder b)) rhos} + val t1 = NODE{start="letregion ", + finish="", + childsep=NOSEP, + indent=10, + children=[binders]} + val t2 = NODE{start="in ", + finish="", + childsep=NOSEP, + indent=3, + children=[layout_ce body]} + val t3 = NODE{start="end (*", + finish="*)", + childsep=NOSEP, + indent=6, + children=[HNODE{start="", + finish="", + childsep=RIGHT", ", + children=[binders]}]} + in + NODE{start="",finish="",indent=0,childsep=RIGHT " ",children=[t1,t2,t3]} + end | layout_ce(ce as LET{pat: lvar list, bind: ClosExp, scope: ClosExp}) = - let - fun layout_rec(LET{pat,bind,scope}) = - let - val lay_pat = HNODE{start="<",finish=">",childsep=RIGHT ",",children=map (fn lv => LEAF(Lvars.pr_lvar lv)) pat} - val (binds, body) = layout_rec scope - val bind = NODE{start="val ",finish="",childsep=RIGHT " = ",indent=4,children=[lay_pat,layout_ce bind]} - in + let + fun layout_rec(LET{pat,bind,scope}) = + let + val lay_pat = HNODE{start="<",finish=">",childsep=RIGHT ",",children=map (fn lv => LEAF(Lvars.pr_lvar lv)) pat} + val (binds, body) = layout_rec scope + val bind = NODE{start="val ",finish="",childsep=RIGHT " = ",indent=4,children=[lay_pat,layout_ce bind]} + in (bind::binds,body) - end - | layout_rec ce = ([],layout_ce ce) + end + | layout_rec ce = ([],layout_ce ce) val (l, body) = layout_rec ce val bindings = NODE{start="",finish="",childsep=RIGHT "; ",indent = 0,children = l} @@ -324,98 +324,98 @@ struct end | layout_ce(RAISE ce) = PP.LEAF("raise " ^ (flatten1(layout_ce ce))) | layout_ce(HANDLE(ce1,ce2)) = NODE{start="",finish="",childsep=RIGHT " handle ",indent=1, - children=[layout_ce ce1,layout_ce ce2]} + children=[layout_ce ce1,layout_ce ce2]} | layout_ce(SWITCH_I {switch,precision}) = layout_switch layout_ce (IntInf.toString) switch | layout_ce(SWITCH_W {switch,precision}) = layout_switch layout_ce (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | layout_ce(SWITCH_S sw) = layout_switch layout_ce (fn s => s) sw | layout_ce(SWITCH_C sw) = layout_switch layout_ce (fn (con,con_kind) => Con.pr_con con ^ "(" ^ - pr_con_kind con_kind ^ ")") sw + pr_con_kind con_kind ^ ")") sw | layout_ce(SWITCH_E sw) = layout_switch layout_ce Excon.pr_excon sw | layout_ce(CON0{con,con_kind,aux_regions,alloc}) = - HNODE{start=Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")", - finish="] " ^ (flatten1(pr_sma alloc)), - childsep=RIGHT ",", - children=map (fn sma => pr_sma sma) aux_regions} + HNODE{start=Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")", + finish="] " ^ (flatten1(pr_sma alloc)), + childsep=RIGHT ",", + children=map (fn sma => pr_sma sma) aux_regions} | layout_ce(CON1{con,con_kind,alloc,arg}) = - HNODE{start=Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ") ", - finish="" ^ (flatten1(pr_sma alloc)), - childsep=NOSEP, - children=[layout_ce arg]} + HNODE{start=Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ") ", + finish="" ^ (flatten1(pr_sma alloc)), + childsep=NOSEP, + children=[layout_ce arg]} | layout_ce(DECON{con,con_kind,con_exp}) = - LEAF("decon(" ^ Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")," ^ (flatten1(layout_ce con_exp)) ^ ")") + LEAF("decon(" ^ Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")," ^ (flatten1(layout_ce con_exp)) ^ ")") | layout_ce(DEREF ce) = LEAF("!" ^ (flatten1(layout_ce ce))) | layout_ce(REF(sma,ce)) = LEAF("ref " ^ (flatten1(layout_ce ce)) ^ " " ^ (flatten1(pr_sma sma))) | layout_ce(ASSIGN(sma,ce1,ce2)) = HNODE{start="", - finish="", - childsep=RIGHT ":=", - children=[layout_ce ce1,layout_ce ce2]} + finish="", + childsep=RIGHT ":=", + children=[layout_ce ce1,layout_ce ce2]} | layout_ce(DROP ce) = layout_ce ce (* - PP.LEAF("drop " ^ (flatten1(layout_ce ce))) + PP.LEAF("drop " ^ (flatten1(layout_ce ce))) *) | layout_ce(RESET_REGIONS{force=true,regions_for_resetting}) = - HNODE{start="force reset regions", - finish="", - childsep=RIGHT ",", - children=map (fn sma => pr_sma sma) regions_for_resetting} + HNODE{start="force reset regions", + finish="", + childsep=RIGHT ",", + children=map (fn sma => pr_sma sma) regions_for_resetting} | layout_ce(RESET_REGIONS{force=false,regions_for_resetting}) = - HNODE{start="reset regions", - finish="", - childsep=RIGHT ",", - children=map (fn sma => pr_sma sma) regions_for_resetting} + HNODE{start="reset regions", + finish="", + childsep=RIGHT ",", + children=map (fn sma => pr_sma sma) regions_for_resetting} | layout_ce(CCALL{name,args,rhos_for_result}) = - HNODE{start="ccall(\"" ^ name ^ "\", <", - finish=">)", - childsep=RIGHT ",", - children=(map layout_ce rhos_for_result) @ (map layout_ce args)} + HNODE{start="ccall(\"" ^ name ^ "\", <", + finish=">)", + childsep=RIGHT ",", + children=(map layout_ce rhos_for_result) @ (map layout_ce args)} | layout_ce(CCALL_AUTO{name,args,res}) = - HNODE{start="ccall_auto(\"" ^ name ^ "\", <", - finish=">)", - childsep=RIGHT ",", - children=(map (layout_ce_f layout_ce) args) @ [layout_f res]} + HNODE{start="ccall_auto(\"" ^ name ^ "\", <", + finish=">)", + childsep=RIGHT ",", + children=(map (layout_ce_f layout_ce) args) @ [layout_f res]} | layout_ce(EXPORT{name,clos_lab,arg=(ce,ft1,ft2)}) = - HNODE{start="_export(\"" ^ name ^ "\", <", - finish=">)", - childsep=RIGHT ",", - children=[layout_ce ce, layout_f ft1, layout_f ft2]} + HNODE{start="_export(\"" ^ name ^ "\", <", + finish=">)", + childsep=RIGHT ",", + children=[layout_ce ce, layout_f ft1, layout_f ft2]} | layout_ce(FRAME{declared_lvars,declared_excons}) = - NODE{start="{|", - finish="|}", - indent=0, - childsep=RIGHT ",", - children=(map (fn {lvar,label} => LEAF("(" ^ Lvars.pr_lvar lvar ^ "," ^ - Labels.pr_label label ^ ")")) declared_lvars) @ - (map (fn {excon,label} => LEAF("(" ^ Excon.pr_excon excon ^ "," ^ - Labels.pr_label label ^ ")")) declared_excons)} + NODE{start="{|", + finish="|}", + indent=0, + childsep=RIGHT ",", + children=(map (fn {lvar,label} => LEAF("(" ^ Lvars.pr_lvar lvar ^ "," ^ + Labels.pr_label label ^ ")")) declared_lvars) @ + (map (fn {excon,label} => LEAF("(" ^ Excon.pr_excon excon ^ "," ^ + Labels.pr_label label ^ ")")) declared_excons)} and layout_ce_opt (NONE) = LEAF "" | layout_ce_opt (SOME ce) = layout_ce ce and pr_sma(ATTOP_LI(ce,pp)) = NODE{start="attop_li ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(ATTOP_LF(ce,pp)) = NODE{start="attop_lf ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(ATTOP_FI(ce,pp)) = NODE{start="attop_fi ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(ATTOP_FF(ce,pp)) = NODE{start="attop_ff ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(ATBOT_LI(ce,pp)) = NODE{start="atbot_li ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(ATBOT_LF(ce,pp)) = NODE{start="atbot_lf ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(SAT_FI(ce,pp)) = NODE{start="sat_fi ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(SAT_FF(ce,pp)) = NODE{start="sat_ff ",finish=" " ^ pr_pp pp,indent=0, - childsep=NOSEP,children=[layout_ce ce]} + childsep=NOSEP,children=[layout_ce ce]} | pr_sma(IGNORE) = NODE{start="ignore ",finish="",indent=0,childsep=NOSEP,children=[]} fun layout_top_decl' f_string (lab,cc,ce) = NODE{start = f_string ^ Labels.pr_label lab ^ "{" ^ CallConv.pr_cc cc ^ "}=", - finish = "", - indent = 2, - childsep = NOSEP, - children = [layout_ce ce]} + finish = "", + indent = 2, + childsep = NOSEP, + children = [layout_ce ce]} in fun layout_top_decl (FUN triple) = layout_top_decl' "FUN" triple | layout_top_decl (FN triple) = layout_top_decl' "FN" triple @@ -423,12 +423,12 @@ struct fun layout_clos_exp ce = layout_ce ce fun layout_clos_prg top_decls = let val _ = print "\nlayout begin..." - val r = NODE{start="ClosExp program begin", - finish="ClosExp program end", - indent=2, - childsep=NOSEP, - children = map layout_top_decl top_decls} - val _ = print "\nlayout end" + val r = NODE{start="ClosExp program begin", + finish="ClosExp program end", + indent=2, + childsep=NOSEP, + children = map layout_top_decl top_decls} + val _ = print "\nlayout end" in r end fun pp_sma sma = PP.flatten1(pr_sma sma) @@ -493,11 +493,11 @@ struct fun display(title, tree) = fast_pr(PP.NODE{start=title ^ ": ", - finish="", - indent=3, - children=[tree], - childsep=PP.NOSEP - }) + finish="", + indent=3, + children=[tree], + childsep=PP.NOSEP + }) (****************************) (* Normalize MulExp Program *) @@ -519,125 +519,126 @@ struct fun fresh _ = (r:= !r + 1; Lvars.new_named_lvar ("kn" ^ Int.toString(!r))) in fun N(prog as MulExp.PGM{expression = tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi}) = + export_datbinds, + import_vars, + export_vars, + export_basis, + export_Psi}) = let - fun NTrip ((MulExp.TR(e,metaType,ateffects,mulef))) insert_let = - let - fun e_to_t e = MulExp.TR(e,metaType,ateffects,mulef) - local - val il0 = RType.mk_il([],[],[]) - val dummy_'c = () - in - fun lvar_as_term(x,mu) = - TR(VAR{lvar=x,il=il0,plain_arreffs=[], - fix_bound=false,rhos_actuals=ref [],other=dummy_'c},mu,[],ref Mul.empty_psi) - fun mk_pat(lvar,mu) = - (case mu of - RegionExp.Mus[(ty,place)] => - [(lvar,ref([]:RType.il ref list),[],ref([]:effect list),ty,place,dummy_'c)] - | _ => die "mk_pat: metatype not (tau,rho)") - end - - fun Nsw (tr, choices, opt) = - MulExp.SWITCH(NTrip tr true, - map (fn(match,tr) => (match,NTrip tr true)) choices, - (case opt of - SOME tr => SOME (NTrip tr true) - | NONE => NONE)) - - fun NExp e = - (case e of - MulExp.VAR _ => e - | MulExp.INTEGER(i,t,alloc) => e - | MulExp.WORD(i,t,alloc) => e - | MulExp.STRING(s,alloc) => e - | MulExp.REAL(r,alloc) => e - | MulExp.F64(r,alloc) => e - | MulExp.UB_RECORD trs => MulExp.UB_RECORD (map (fn tr => NTrip tr true) trs) - | MulExp.FN{pat,body,free,alloc} => - if insert_let then - let - val x = fresh() - in - MulExp.LET{k_let = true, - pat = mk_pat(x,metaType), - bind = e_to_t(MulExp.FN{pat=pat, - body=NTrip body true, - free=free, - alloc=alloc}), - scope = lvar_as_term(x,metaType)} - end - else - MulExp.FN{pat=pat,body=NTrip body true,free=free,alloc=alloc} - | MulExp.LETREGION{B, rhos, body} => MulExp.LETREGION{B=B,rhos=rhos,body=NTrip body true} - | MulExp.LET{k_let,pat,bind,scope} => MulExp.LET{k_let=k_let, - pat=pat, - bind=NTrip bind false, - scope=NTrip scope true} - | MulExp.FIX{free,shared_clos,functions,scope} => - MulExp.FIX{free=free, - shared_clos=shared_clos, - functions= - map (fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, - bound_but_never_written_into,other,bind} => - {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss, - Type=Type,rhos_formals=rhos_formals,other=other, - bound_but_never_written_into=bound_but_never_written_into, - bind=NTrip bind false}) functions, - scope=NTrip scope true} - | MulExp.APP(callKind,saveRestore,operator,operand) => - MulExp.APP(callKind,saveRestore,NTrip operator true,NTrip operand true) - | MulExp.EXCEPTION(excon,bool,typePlace,alloc,scope) => - MulExp.EXCEPTION(excon,bool,typePlace,alloc,NTrip scope true) - | MulExp.RAISE tr => MulExp.RAISE (NTrip tr true) - | MulExp.HANDLE(tr1,tr2) => MulExp.HANDLE(NTrip tr1 true,NTrip tr2 true) - | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,choices,opt), precision} => - MulExp.SWITCH_I {switch=Nsw(tr, choices, opt), precision=precision} - | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,choices,opt), precision} => - MulExp.SWITCH_W {switch=Nsw(tr, choices, opt), precision=precision} - | MulExp.SWITCH_S(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_S(Nsw(tr, choices, opt)) - | MulExp.SWITCH_C(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_C(Nsw(tr, choices, opt)) - | MulExp.SWITCH_E(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_E(Nsw(tr, choices, opt)) - | MulExp.CON0{con,il,aux_regions,alloc} => e - | MulExp.CON1({con,il,alloc},tr) => MulExp.CON1({con=con,il=il,alloc=alloc},NTrip tr true) - | MulExp.DECON({con,il},tr) => MulExp.DECON({con=con,il=il}, NTrip tr true) - | MulExp.EXCON(excon,NONE) => e - | MulExp.EXCON(excon,SOME(alloc,tr)) => MulExp.EXCON(excon,SOME(alloc, NTrip tr true)) - | MulExp.DEEXCON(excon,tr) => MulExp.DEEXCON(excon, NTrip tr true) - | MulExp.RECORD(alloc, trs) => MulExp.RECORD(alloc, map (fn tr => NTrip tr true) trs) - | MulExp.BLOCKF64(alloc, trs) => MulExp.BLOCKF64(alloc, map (fn tr => NTrip tr true) trs) - | MulExp.SCRATCHMEM(n,alloc) => MulExp.SCRATCHMEM(n,alloc) - | MulExp.SELECT(i,tr) => MulExp.SELECT(i,NTrip tr true) - | MulExp.DEREF tr => MulExp.DEREF (NTrip tr true) - | MulExp.REF(a,tr) => MulExp.REF(a,NTrip tr true) - | MulExp.ASSIGN(alloc,tr1,tr2) => MulExp.ASSIGN(alloc,NTrip tr1 true,NTrip tr2 true) - | MulExp.DROP tr => MulExp.DROP (NTrip tr true) - | MulExp.EQUAL({mu_of_arg1,mu_of_arg2,alloc},tr1, tr2) => - MulExp.EQUAL({mu_of_arg1=mu_of_arg1,mu_of_arg2=mu_of_arg2,alloc=alloc}, - NTrip tr1 true, - NTrip tr2 true) - | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => - MulExp.CCALL({name=name,mu_result=mu_result,rhos_for_result=rhos_for_result}, - map (fn tr => NTrip tr true) trs) - | MulExp.EXPORT(i, tr) => MulExp.EXPORT(i, NTrip tr true) - | MulExp.RESET_REGIONS({force, alloc, regions_for_resetting},tr) => - MulExp.RESET_REGIONS({force=force,alloc=alloc,regions_for_resetting=regions_for_resetting}, - NTrip tr true) - | MulExp.FRAME{declared_lvars, declared_excons} => e) - in - MulExp.TR(NExp e,metaType,ateffects,mulef) - end + fun NTrip ((MulExp.TR(e,metaType,ateffects,mulef))) insert_let = + let + fun e_to_t e = MulExp.TR(e,metaType,ateffects,mulef) + local + val il0 = RType.mk_il([],[],[]) + val dummy_'c = () + in fun lvar_as_term (x,mu) = + TR(VAR{lvar=x,il=il0,plain_arreffs=[], + fix_bound=false,rhos_actuals=ref [],other=dummy_'c},mu,[],ref Mul.empty_psi) + fun mk_pat (lvar,mu) = + case mu of + RegionExp.Mus[mu] => + let val (ty,place) = RType.unbox mu + in [(lvar,ref([]:RType.il ref list),[],ref([]:effect list),ty,place,dummy_'c)] + end + | _ => die "mk_pat: metatype not (tau,rho)" + end + + fun Nsw (tr, choices, opt) = + MulExp.SWITCH(NTrip tr true, + map (fn(match,tr) => (match,NTrip tr true)) choices, + (case opt of + SOME tr => SOME (NTrip tr true) + | NONE => NONE)) + + fun NExp e = + (case e of + MulExp.VAR _ => e + | MulExp.INTEGER(i,t,alloc) => e + | MulExp.WORD(i,t,alloc) => e + | MulExp.STRING(s,alloc) => e + | MulExp.REAL(r,alloc) => e + | MulExp.F64 r => e + | MulExp.UB_RECORD trs => MulExp.UB_RECORD (map (fn tr => NTrip tr true) trs) + | MulExp.FN{pat,body,free,alloc} => + if insert_let then + let + val x = fresh() + in + MulExp.LET{k_let = true, + pat = mk_pat(x,metaType), + bind = e_to_t(MulExp.FN{pat=pat, + body=NTrip body true, + free=free, + alloc=alloc}), + scope = lvar_as_term(x,metaType)} + end + else + MulExp.FN{pat=pat,body=NTrip body true,free=free,alloc=alloc} + | MulExp.LETREGION{B, rhos, body} => MulExp.LETREGION{B=B,rhos=rhos,body=NTrip body true} + | MulExp.LET{k_let,pat,bind,scope} => MulExp.LET{k_let=k_let, + pat=pat, + bind=NTrip bind false, + scope=NTrip scope true} + | MulExp.FIX{free,shared_clos,functions,scope} => + MulExp.FIX{free=free, + shared_clos=shared_clos, + functions= + map (fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + bound_but_never_written_into,other,bind} => + {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss, + Type=Type,rhos_formals=rhos_formals,other=other, + bound_but_never_written_into=bound_but_never_written_into, + bind=NTrip bind false}) functions, + scope=NTrip scope true} + | MulExp.APP(callKind,saveRestore,operator,operand) => + MulExp.APP(callKind,saveRestore,NTrip operator true,NTrip operand true) + | MulExp.EXCEPTION(excon,bool,typePlace,alloc,scope) => + MulExp.EXCEPTION(excon,bool,typePlace,alloc,NTrip scope true) + | MulExp.RAISE tr => MulExp.RAISE (NTrip tr true) + | MulExp.HANDLE(tr1,tr2) => MulExp.HANDLE(NTrip tr1 true,NTrip tr2 true) + | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,choices,opt), precision} => + MulExp.SWITCH_I {switch=Nsw(tr, choices, opt), precision=precision} + | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,choices,opt), precision} => + MulExp.SWITCH_W {switch=Nsw(tr, choices, opt), precision=precision} + | MulExp.SWITCH_S(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_S(Nsw(tr, choices, opt)) + | MulExp.SWITCH_C(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_C(Nsw(tr, choices, opt)) + | MulExp.SWITCH_E(MulExp.SWITCH(tr,choices,opt)) => MulExp.SWITCH_E(Nsw(tr, choices, opt)) + | MulExp.CON0{con,il,aux_regions,alloc} => e + | MulExp.CON1({con,il,alloc},tr) => MulExp.CON1({con=con,il=il,alloc=alloc},NTrip tr true) + | MulExp.DECON({con,il},tr) => MulExp.DECON({con=con,il=il}, NTrip tr true) + | MulExp.EXCON(excon,NONE) => e + | MulExp.EXCON(excon,SOME(alloc,tr)) => MulExp.EXCON(excon,SOME(alloc, NTrip tr true)) + | MulExp.DEEXCON(excon,tr) => MulExp.DEEXCON(excon, NTrip tr true) + | MulExp.RECORD(alloc, trs) => MulExp.RECORD(alloc, map (fn tr => NTrip tr true) trs) + | MulExp.BLOCKF64(alloc, trs) => MulExp.BLOCKF64(alloc, map (fn tr => NTrip tr true) trs) + | MulExp.SCRATCHMEM(n,alloc) => MulExp.SCRATCHMEM(n,alloc) + | MulExp.SELECT(i,tr) => MulExp.SELECT(i,NTrip tr true) + | MulExp.DEREF tr => MulExp.DEREF (NTrip tr true) + | MulExp.REF(a,tr) => MulExp.REF(a,NTrip tr true) + | MulExp.ASSIGN(tr1,tr2) => MulExp.ASSIGN(NTrip tr1 true,NTrip tr2 true) + | MulExp.DROP tr => MulExp.DROP (NTrip tr true) + | MulExp.EQUAL({mu_of_arg1,mu_of_arg2},tr1, tr2) => + MulExp.EQUAL({mu_of_arg1=mu_of_arg1,mu_of_arg2=mu_of_arg2}, + NTrip tr1 true, + NTrip tr2 true) + | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => + MulExp.CCALL({name=name,mu_result=mu_result,rhos_for_result=rhos_for_result}, + map (fn tr => NTrip tr true) trs) + | MulExp.EXPORT(i, tr) => MulExp.EXPORT(i, NTrip tr true) + | MulExp.RESET_REGIONS({force, regions_for_resetting,liveset},tr) => + MulExp.RESET_REGIONS({force=force,regions_for_resetting=regions_for_resetting,liveset=liveset}, + NTrip tr true) + | MulExp.FRAME{declared_lvars, declared_excons} => e) + in + MulExp.TR(NExp e,metaType,ateffects,mulef) + end in - MulExp.PGM{expression = NTrip tr false, - export_datbinds = export_datbinds, - import_vars = import_vars, - export_vars = export_vars, - export_basis = export_basis, - export_Psi = export_Psi} + MulExp.PGM{expression = NTrip tr false, + export_datbinds = export_datbinds, + import_vars = import_vars, + export_vars = export_vars, + export_basis = export_basis, + export_Psi = export_Psi} end end @@ -667,40 +668,40 @@ struct structure FuncEnv = Lvars.Map (* OrderFinMap(struct - type T = lvar - fun lt(l1: T) l2 = Lvars.lt(l1,l2) - end) + type T = lvar + fun lt(l1: T) l2 = Lvars.lt(l1,l2) + end) *) local fun pp_dom lvar = PP.LEAF (Lvars.pr_lvar lvar) fun pp_ran (FN(args,free)) = - PP.LEAF ("FN[Args:"^(pr_lvars args)^ - ",Free:"^(pr_free free)^"]") - | pp_ran (FIX(args,free)) = - PP.LEAF ("FIX[Args:"^(pr_lvars args)^ - ",Free:"^(pr_free free)^"]") + PP.LEAF ("FN[Args:"^(pr_lvars args)^ + ",Free:"^(pr_free free)^"]") + | pp_ran (FIX(args,free)) = + PP.LEAF ("FIX[Args:"^(pr_lvars args)^ + ",Free:"^(pr_free free)^"]") in fun pp_fenv fenv = pr_st(pp_ran fenv); fun pp_Fenv Fenv = - let - val init = {start="Fenv[",eq="-->",sep="",finish="]"} - in - FuncEnv.layoutMap init pp_dom pp_ran Fenv - end + let + val init = {start="Fenv[",eq="-->",sep="",finish="]"} + in + FuncEnv.layoutMap init pp_dom pp_ran Fenv + end end val empty_Fenv = FuncEnv.empty fun is_in_dom_Fenv Fenv lvar = case FuncEnv.lookup Fenv lvar of - NONE => false + NONE => false | SOME r => true fun lookup_Fenv Fenv lvar = FuncEnv.lookup Fenv lvar fun rem_Fenv Fenv lvar = case FuncEnv.remove (lvar, Fenv) of - SOME Fenv => Fenv + SOME Fenv => Fenv | NONE => die "Remove lvar fra Fenv." fun add_Fenv Fenv lvar v = FuncEnv.add (lvar, v, Fenv) @@ -709,22 +710,22 @@ struct (* Env *) (*******) structure EnvLvar = - OrderSet(struct - type t = lvar - fun lt(l1: t, l2) = Lvars.lt(l1,l2) - end) + OrderSet(struct + type t = lvar + fun lt(l1: t, l2) = Lvars.lt(l1,l2) + end) structure EnvExCon = - OrderSet(struct - type t = excon - fun lt(e1: t, e2) = Excon.< (e1,e2) - end) + OrderSet(struct + type t = excon + fun lt(e1: t, e2) = Excon.< (e1,e2) + end) structure EnvRho = - OrderSet(struct - type t = place - val lt = Effect.lt_eps_or_rho - end) + OrderSet(struct + type t = place + val lt = Effect.lt_eps_or_rho + end) fun add_Env (Lvar, ExCon, Rho) (lvars, excons, rhos) = (EnvLvar.addList lvars Lvar, EnvExCon.addList excons ExCon, EnvRho.addList rhos Rho) @@ -736,11 +737,11 @@ struct fun free_in_Env (LvarEnv, ExConEnv, RhoEnv) (lvars, excons, rhos) = (List.foldl (fn (lvar,base) => - if EnvLvar.member lvar LvarEnv andalso base=true then true else false) true lvars) andalso + if EnvLvar.member lvar LvarEnv andalso base=true then true else false) true lvars) andalso (List.foldl (fn (excon,base) => - if EnvExCon.member excon ExConEnv andalso base=true then true else false) true excons) andalso + if EnvExCon.member excon ExConEnv andalso base=true then true else false) true excons) andalso (List.foldl (fn (rho,base) => - if EnvRho.member rho RhoEnv andalso base=true then true else false) true rhos) + if EnvRho.member rho RhoEnv andalso base=true then true else false) true rhos) (***************) (* Return Type *) @@ -751,248 +752,248 @@ struct in fun F(prog as MulExp.PGM{expression = tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi}) = + export_datbinds, + import_vars, + export_vars, + export_basis, + export_Psi}) = if false (*Flags.is_on "prune_closures"*) then - let - val export_vars_set = EnvLvar.fromList (#1 export_vars) - val import_vars = - case import_vars - of ref (SOME vars) => vars - | _ => die "ClosExp.F.no import vars info" - - fun FTrip ((MulExp.TR(e,metaType,ateffects,mulef))) Fenv Env = - let - fun FExp e Fenv (Env as (EnvLvar, EnvExCon, EnvRho)) = - (case e of - MulExp.VAR{lvar,...} => - if is_in_dom_Fenv Fenv lvar then - (rem_Fenv Fenv lvar, [OTHER]) - else - (Fenv, [OTHER]) - | MulExp.INTEGER(i,t,alloc) => (Fenv, [OTHER]) - | MulExp.WORD(i,t,alloc) => (Fenv, [OTHER]) - | MulExp.STRING(s,alloc) => (Fenv, [OTHER]) - | MulExp.REAL(r,alloc) => (Fenv, [OTHER]) - | MulExp.F64(r,alloc) => (Fenv, [OTHER]) - | MulExp.UB_RECORD trs => - List.foldr (fn (tr,(Fenv',types')) => - (case FTrip tr Fenv' Env - of (Fenv_t, [t]) => (Fenv_t,t::types') - | _ => die "UB_RECORD")) (Fenv, []) trs - | MulExp.FN{pat,body,free,alloc} => - let - val free_vars = - case (!free) of - SOME free => free - | NONE => ([], [], []) - val args = map #1 pat - val (Fenv',_) = FTrip body Fenv (add_Env (fresh_Env free_vars import_vars) (args,[],[])) - in - (Fenv', [FUNC(args,free_vars)]) - end - | MulExp.LETREGION{B, rhos, body} => - FTrip body Fenv (add_Env Env ([],[],List.map #1 (!rhos))) - | MulExp.LET{k_let,pat,bind,scope} => - let - val lvars = List.map #1 pat - val (Fenv', types) = FTrip bind Fenv Env - val types' = zip (lvars,types) - val Fenv_scope = List.foldl (fn ((lvar',type'),base) => - case type' of - FUNC(args,free) => add_Fenv base lvar' (FN(args, free)) - | OTHER => base) Fenv' types' - in - FTrip scope Fenv_scope (add_Env Env (lvars,[],[])) - end - | MulExp.FIX{free,shared_clos,functions,scope} => - let - (* funcs : (lvar, args, formals, free, body) list *) - fun f {lvar, occ, tyvars, rhos, epss, Type, rhos_formals: (place*phsize) list ref, other, - bound_but_never_written_into, - bind = MulExp.TR(MulExp.FN{pat,body,free,alloc},_,_,_)} = - (case (!free) - of NONE => (lvar, List.map #1 pat, List.map #1 (!rhos_formals), ([],[],[]), body) - | SOME free => (lvar, List.map #1 pat, List.map #1 (!rhos_formals), free, body)) - | f _ = die "Functions not in expected shape." - val funcs = List.map f functions - - val Fenv1 = List.foldl (fn ((lvar,args,_,free,_),base) => - add_Fenv base lvar (FIX(args, free))) Fenv funcs - - val FenvN = List.foldl (fn ((_,args,rhos_formals,free,body),base) => - #1(FTrip body base - (add_Env (fresh_Env free import_vars) - (args,[],rhos_formals)))) Fenv1 funcs - - val all_exists = List.foldl (fn ((lvar,_,_,_,_),base) => - if is_in_dom_Fenv FenvN lvar andalso - not (EnvLvar.member lvar export_vars_set) andalso (* none of the letrec may be exported *) - base = true then true else false) true funcs - - val Fenv_scope = - if all_exists then - FenvN - else (* Remove all FIX bound functions. *) - List.foldl (fn ((lvar,_,_,_,_),base) => - if is_in_dom_Fenv base lvar then - rem_Fenv base lvar - else - base) FenvN funcs - in - FTrip scope Fenv_scope (add_Env Env (List.map #1 funcs,[],[])) - end - | MulExp.APP(callKind,saveRestore,operator,operand) => - (case operator - of MulExp.TR(MulExp.VAR{lvar,il, plain_arreffs,fix_bound=false,rhos_actuals,other},_,_,_) => - (* Ordinary function call *) - let - val Fenv' = (case lookup_Fenv Fenv lvar - of NONE => Fenv - | SOME (FN(arg_fn,free_fn)) => - if free_in_Env Env free_fn then - Fenv - else - rem_Fenv Fenv lvar - | SOME (FIX(lvars,free)) => die "Function should be FN but is recorded as FIX") - val (Fenv_res, _) = FTrip operand Fenv' Env - in - (Fenv_res, [OTHER]) - end - | MulExp.TR(MulExp.VAR{lvar,il, plain_arreffs,fix_bound=true,rhos_actuals,other},_,_,_) => - (* Region Polymorphic call *) - let - val Fenv' = (case lookup_Fenv Fenv lvar - of NONE => Fenv - | SOME (FIX(args_fix,free_fix)) => - if free_in_Env Env free_fix then - Fenv - else - rem_Fenv Fenv lvar - | SOME (FN(lvars,free)) => die "Function should be a FIX but is recorded as FN") - val (Fenv_res,_) = FTrip operand Fenv' Env - in - (Fenv_res, [OTHER]) - end - | _ => die "First argument in application not as expected.") - | MulExp.EXCEPTION(excon,bool,typePlace,alloc,scope) => - FTrip scope Fenv (add_Env Env ([],[excon],[])) - | MulExp.RAISE tr => FTrip tr Fenv Env - | MulExp.HANDLE(tr1,tr2) => - let - val (Fenv1, _) = FTrip tr1 Fenv Env - val (Fenv2, _) = FTrip tr2 Fenv1 Env - in - (Fenv2, [OTHER]) - end - | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,choices,opt), precision} => - let - val (Fenv_tr,_) = FTrip tr Fenv Env - val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices - val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) - in - (Fenv_res,[OTHER]) - end - | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,choices,opt), precision} => - let - val (Fenv_tr,_) = FTrip tr Fenv Env - val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices - val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) - in - (Fenv_res,[OTHER]) - end - | MulExp.SWITCH_S(MulExp.SWITCH(tr,choices,opt)) => - let - val (Fenv_tr,_) = FTrip tr Fenv Env - val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices - val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) - in - (Fenv_res,[OTHER]) - end - | MulExp.SWITCH_C(MulExp.SWITCH(tr,choices,opt)) => - let - val (Fenv_tr,_) = FTrip tr Fenv Env - val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices - val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) - in - (Fenv_res,[OTHER]) - end - | MulExp.SWITCH_E(MulExp.SWITCH(tr,choices,opt)) => - let - val (Fenv_tr,_) = FTrip tr Fenv Env - val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices - val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) - in - (Fenv_res,[OTHER]) - end - | MulExp.CON0{con,il,aux_regions,alloc} => (Fenv, [OTHER]) - | MulExp.CON1({con,il,alloc},tr) => (Fenv, [OTHER]) - | MulExp.DECON({con,il},tr) => FTrip tr Fenv Env - | MulExp.EXCON(excon,NONE) => (Fenv, [OTHER]) - | MulExp.EXCON(excon,SOME(alloc,tr)) => FTrip tr Fenv Env - | MulExp.DEEXCON(excon,tr) => FTrip tr Fenv Env - | MulExp.RECORD(alloc, trs) => - let val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs - in (Fenv_res, [OTHER]) - end - | MulExp.BLOCKF64(alloc, trs) => - let val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs - in (Fenv_res, [OTHER]) - end - | MulExp.SCRATCHMEM(n,alloc) => (Fenv, [OTHER]) - | MulExp.SELECT(i,tr) => FTrip tr Fenv Env - | MulExp.DEREF tr => FTrip tr Fenv Env - | MulExp.REF(a,tr) => FTrip tr Fenv Env - | MulExp.ASSIGN(alloc,tr1,tr2) => - let - val (Fenv1,_) = FTrip tr1 Fenv Env - val (Fenv2,_) = FTrip tr2 Fenv1 Env - in - (Fenv2, [OTHER]) - end - | MulExp.DROP tr => FTrip tr Fenv Env - | MulExp.EQUAL({mu_of_arg1,mu_of_arg2,alloc},tr1, tr2) => - let - val (Fenv1,_) = FTrip tr1 Fenv Env - val (Fenv2,_) = FTrip tr2 Fenv1 Env - in - (Fenv2, [OTHER]) - end - | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => - let - val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs - in - (Fenv_res, [OTHER]) - end - | MulExp.EXPORT(i,tr) => FTrip tr Fenv Env - | MulExp.RESET_REGIONS({force, alloc, regions_for_resetting},tr) => FTrip tr Fenv Env - | MulExp.FRAME{declared_lvars, declared_excons} => - (List.foldl (fn ({lvar,...},base) => if is_in_dom_Fenv base lvar then - rem_Fenv base lvar - else - base) Fenv declared_lvars, [OTHER])) - in - FExp e Fenv Env - end - - val (Fenv', _) = FTrip tr FuncEnv.empty (fresh_Env import_vars ([],[],[])) - - (* Remove all export_vars from Fenv'. Currently, they are closure implemented. *) - val Fenv_res = List.foldl (fn (lvar,base) => - if is_in_dom_Fenv base lvar then - rem_Fenv base lvar - else - base) Fenv' (#1(export_vars)) - - (*val _ = pr_st (pp_Fenv Fenv_res) 29/08-2000, Niels *) - in - Fenv_res - end + let + val export_vars_set = EnvLvar.fromList (#1 export_vars) + val import_vars = + case import_vars + of ref (SOME vars) => vars + | _ => die "ClosExp.F.no import vars info" + + fun FTrip ((MulExp.TR(e,metaType,ateffects,mulef))) Fenv Env = + let + fun FExp e Fenv (Env as (EnvLvar, EnvExCon, EnvRho)) = + (case e of + MulExp.VAR{lvar,...} => + if is_in_dom_Fenv Fenv lvar then + (rem_Fenv Fenv lvar, [OTHER]) + else + (Fenv, [OTHER]) + | MulExp.INTEGER(i,t,alloc) => (Fenv, [OTHER]) + | MulExp.WORD(i,t,alloc) => (Fenv, [OTHER]) + | MulExp.STRING(s,alloc) => (Fenv, [OTHER]) + | MulExp.REAL(r,alloc) => (Fenv, [OTHER]) + | MulExp.F64 r => (Fenv, [OTHER]) + | MulExp.UB_RECORD trs => + List.foldr (fn (tr,(Fenv',types')) => + (case FTrip tr Fenv' Env + of (Fenv_t, [t]) => (Fenv_t,t::types') + | _ => die "UB_RECORD")) (Fenv, []) trs + | MulExp.FN{pat,body,free,alloc} => + let + val free_vars = + case (!free) of + SOME free => free + | NONE => ([], [], []) + val args = map #1 pat + val (Fenv',_) = FTrip body Fenv (add_Env (fresh_Env free_vars import_vars) (args,[],[])) + in + (Fenv', [FUNC(args,free_vars)]) + end + | MulExp.LETREGION{B, rhos, body} => + FTrip body Fenv (add_Env Env ([],[],List.map #1 (!rhos))) + | MulExp.LET{k_let,pat,bind,scope} => + let + val lvars = List.map #1 pat + val (Fenv', types) = FTrip bind Fenv Env + val types' = zip (lvars,types) + val Fenv_scope = List.foldl (fn ((lvar',type'),base) => + case type' of + FUNC(args,free) => add_Fenv base lvar' (FN(args, free)) + | OTHER => base) Fenv' types' + in + FTrip scope Fenv_scope (add_Env Env (lvars,[],[])) + end + | MulExp.FIX{free,shared_clos,functions,scope} => + let + (* funcs : (lvar, args, formals, free, body) list *) + fun f {lvar, occ, tyvars, rhos, epss, Type, rhos_formals: (place*phsize) list ref, other, + bound_but_never_written_into, + bind = MulExp.TR(MulExp.FN{pat,body,free,alloc},_,_,_)} = + (case (!free) + of NONE => (lvar, List.map #1 pat, List.map #1 (!rhos_formals), ([],[],[]), body) + | SOME free => (lvar, List.map #1 pat, List.map #1 (!rhos_formals), free, body)) + | f _ = die "Functions not in expected shape." + val funcs = List.map f functions + + val Fenv1 = List.foldl (fn ((lvar,args,_,free,_),base) => + add_Fenv base lvar (FIX(args, free))) Fenv funcs + + val FenvN = List.foldl (fn ((_,args,rhos_formals,free,body),base) => + #1(FTrip body base + (add_Env (fresh_Env free import_vars) + (args,[],rhos_formals)))) Fenv1 funcs + + val all_exists = List.foldl (fn ((lvar,_,_,_,_),base) => + if is_in_dom_Fenv FenvN lvar andalso + not (EnvLvar.member lvar export_vars_set) andalso (* none of the letrec may be exported *) + base = true then true else false) true funcs + + val Fenv_scope = + if all_exists then + FenvN + else (* Remove all FIX bound functions. *) + List.foldl (fn ((lvar,_,_,_,_),base) => + if is_in_dom_Fenv base lvar then + rem_Fenv base lvar + else + base) FenvN funcs + in + FTrip scope Fenv_scope (add_Env Env (List.map #1 funcs,[],[])) + end + | MulExp.APP(callKind,saveRestore,operator,operand) => + (case operator + of MulExp.TR(MulExp.VAR{lvar,il, plain_arreffs,fix_bound=false,rhos_actuals,other},_,_,_) => + (* Ordinary function call *) + let + val Fenv' = (case lookup_Fenv Fenv lvar + of NONE => Fenv + | SOME (FN(arg_fn,free_fn)) => + if free_in_Env Env free_fn then + Fenv + else + rem_Fenv Fenv lvar + | SOME (FIX(lvars,free)) => die "Function should be FN but is recorded as FIX") + val (Fenv_res, _) = FTrip operand Fenv' Env + in + (Fenv_res, [OTHER]) + end + | MulExp.TR(MulExp.VAR{lvar,il, plain_arreffs,fix_bound=true,rhos_actuals,other},_,_,_) => + (* Region Polymorphic call *) + let + val Fenv' = (case lookup_Fenv Fenv lvar + of NONE => Fenv + | SOME (FIX(args_fix,free_fix)) => + if free_in_Env Env free_fix then + Fenv + else + rem_Fenv Fenv lvar + | SOME (FN(lvars,free)) => die "Function should be a FIX but is recorded as FN") + val (Fenv_res,_) = FTrip operand Fenv' Env + in + (Fenv_res, [OTHER]) + end + | _ => die "First argument in application not as expected.") + | MulExp.EXCEPTION(excon,bool,typePlace,alloc,scope) => + FTrip scope Fenv (add_Env Env ([],[excon],[])) + | MulExp.RAISE tr => FTrip tr Fenv Env + | MulExp.HANDLE(tr1,tr2) => + let + val (Fenv1, _) = FTrip tr1 Fenv Env + val (Fenv2, _) = FTrip tr2 Fenv1 Env + in + (Fenv2, [OTHER]) + end + | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,choices,opt), precision} => + let + val (Fenv_tr,_) = FTrip tr Fenv Env + val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices + val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) + in + (Fenv_res,[OTHER]) + end + | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,choices,opt), precision} => + let + val (Fenv_tr,_) = FTrip tr Fenv Env + val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices + val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) + in + (Fenv_res,[OTHER]) + end + | MulExp.SWITCH_S(MulExp.SWITCH(tr,choices,opt)) => + let + val (Fenv_tr,_) = FTrip tr Fenv Env + val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices + val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) + in + (Fenv_res,[OTHER]) + end + | MulExp.SWITCH_C(MulExp.SWITCH(tr,choices,opt)) => + let + val (Fenv_tr,_) = FTrip tr Fenv Env + val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices + val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) + in + (Fenv_res,[OTHER]) + end + | MulExp.SWITCH_E(MulExp.SWITCH(tr,choices,opt)) => + let + val (Fenv_tr,_) = FTrip tr Fenv Env + val Fenv_ch = List.foldl (fn ((_,tr),base) => #1(FTrip tr base Env)) Fenv_tr choices + val (Fenv_res) = (case opt of SOME tr => #1(FTrip tr Fenv_ch Env) | NONE => Fenv_ch) + in + (Fenv_res,[OTHER]) + end + | MulExp.CON0{con,il,aux_regions,alloc} => (Fenv, [OTHER]) + | MulExp.CON1({con,il,alloc},tr) => (Fenv, [OTHER]) + | MulExp.DECON({con,il},tr) => FTrip tr Fenv Env + | MulExp.EXCON(excon,NONE) => (Fenv, [OTHER]) + | MulExp.EXCON(excon,SOME(alloc,tr)) => FTrip tr Fenv Env + | MulExp.DEEXCON(excon,tr) => FTrip tr Fenv Env + | MulExp.RECORD(alloc, trs) => + let val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs + in (Fenv_res, [OTHER]) + end + | MulExp.BLOCKF64(alloc, trs) => + let val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs + in (Fenv_res, [OTHER]) + end + | MulExp.SCRATCHMEM(n,alloc) => (Fenv, [OTHER]) + | MulExp.SELECT(i,tr) => FTrip tr Fenv Env + | MulExp.DEREF tr => FTrip tr Fenv Env + | MulExp.REF(a,tr) => FTrip tr Fenv Env + | MulExp.ASSIGN(tr1,tr2) => + let + val (Fenv1,_) = FTrip tr1 Fenv Env + val (Fenv2,_) = FTrip tr2 Fenv1 Env + in + (Fenv2, [OTHER]) + end + | MulExp.DROP tr => FTrip tr Fenv Env + | MulExp.EQUAL({mu_of_arg1,mu_of_arg2},tr1, tr2) => + let + val (Fenv1,_) = FTrip tr1 Fenv Env + val (Fenv2,_) = FTrip tr2 Fenv1 Env + in + (Fenv2, [OTHER]) + end + | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => + let + val Fenv_res = List.foldl (fn (tr,base) => #1(FTrip tr base Env)) Fenv trs + in + (Fenv_res, [OTHER]) + end + | MulExp.EXPORT(i,tr) => FTrip tr Fenv Env + | MulExp.RESET_REGIONS({force, regions_for_resetting, ...},tr) => FTrip tr Fenv Env + | MulExp.FRAME{declared_lvars, declared_excons} => + (List.foldl (fn ({lvar,...},base) => if is_in_dom_Fenv base lvar then + rem_Fenv base lvar + else + base) Fenv declared_lvars, [OTHER])) + in + FExp e Fenv Env + end + + val (Fenv', _) = FTrip tr FuncEnv.empty (fresh_Env import_vars ([],[],[])) + + (* Remove all export_vars from Fenv'. Currently, they are closure implemented. *) + val Fenv_res = List.foldl (fn (lvar,base) => + if is_in_dom_Fenv base lvar then + rem_Fenv base lvar + else + base) Fenv' (#1(export_vars)) + + (*val _ = pr_st (pp_Fenv Fenv_res) 29/08-2000, Niels *) + in + Fenv_res + end else - empty_Fenv + empty_Fenv end (**********************) @@ -1055,7 +1056,6 @@ struct fun pr_at (AtInf.ATTOP _) = "Attop" | pr_at (AtInf.ATBOT _) = "Atbot" | pr_at (AtInf.SAT _) = "Sat" - | pr_at (AtInf.IGNORE) = "Ignore" fun convert_sma (AtInf.ATTOP(rho,pp),CE.LI,ce) = ATTOP_LI (ce,pp) | convert_sma (AtInf.ATTOP(rho,pp),CE.LF,ce) = ATTOP_LF (ce,pp) @@ -1066,7 +1066,7 @@ struct | convert_sma (AtInf.SAT(rho,pp),CE.FI,ce) = SAT_FI (ce,pp) | convert_sma (AtInf.SAT(rho,pp),CE.FF,ce) = SAT_FF (ce,pp) | convert_sma (at,rk,ce) = die ("convert_sma: sma combination not recognized." ^ - "at=" ^ pr_at at ^ ", rk=" ^ pr_rho_kind rk ^ "\n") + "at=" ^ pr_at at ^ ", rk=" ^ pr_rho_kind rk ^ "\n") (* ----------------------------------------------- *) (* Utility Functions on Select Expressions *) @@ -1080,34 +1080,34 @@ struct | lt_se(FETCH_SE _ ,NONE_SE) = false | lt_se(FETCH_SE(_,lab1),FETCH_SE(_,lab2)) = if Labels.lt(lab1,lab2) then - true - else - false + true + else + false | lt_se(FETCH_SE _, SELECT_SE _) = true | lt_se(SELECT_SE _, NONE_SE) = false | lt_se(SELECT_SE _, FETCH_SE _) = false | lt_se(SELECT_SE(_,i1,lv1), SELECT_SE(_,i2,lv2)) = - if (i1 ce) is used temporarily by unify_ce_se and unify_sma_se only *) - OrderFinMap(struct - type t = select_exp - val lt = lt_se - end) + OrderFinMap(struct + type t = select_exp + val lt = lt_se + end) fun unify_ce_se ces_and_ses se_map = let - fun resolve((ce,NONE_SE),(ces,ses,se_map)) = (ce::ces,ses,se_map) - | resolve((ce,se),(ces,ses,se_map)) = - (case SEMap.lookup se_map se of - NONE => (ce::ces,se::ses,SEMap.add (se,ce,se_map)) - | SOME(ce') => (ce'::ces,ses,se_map)) + fun resolve((ce,NONE_SE),(ces,ses,se_map)) = (ce::ces,ses,se_map) + | resolve((ce,se),(ces,ses,se_map)) = + (case SEMap.lookup se_map se of + NONE => (ce::ces,se::ses,SEMap.add (se,ce,se_map)) + | SOME(ce') => (ce'::ces,ses,se_map)) in List.foldr resolve ([],[],se_map) ces_and_ses end @@ -1115,55 +1115,55 @@ struct (* Must keep the sma information and only exchange the expression inside the sma *) fun unify_sma_se smas_and_ses se_map = let - fun resolve((sma,NONE_SE),(smas,ses,se_map)) = (sma::smas,ses,se_map) - | resolve((sma,se),(smas,ses,se_map)) = - (case SEMap.lookup se_map se of - NONE => (sma::smas,se::ses,SEMap.add (se,get_ce(sma),se_map)) - | SOME(ce') => (insert_ce_in_sma(ce',sma)::smas,ses,se_map)) + fun resolve((sma,NONE_SE),(smas,ses,se_map)) = (sma::smas,ses,se_map) + | resolve((sma,se),(smas,ses,se_map)) = + (case SEMap.lookup se_map se of + NONE => (sma::smas,se::ses,SEMap.add (se,get_ce(sma),se_map)) + | SOME(ce') => (insert_ce_in_sma(ce',sma)::smas,ses,se_map)) in - List.foldr resolve ([],[],se_map) smas_and_ses + List.foldr resolve ([],[],se_map) smas_and_ses end fun unify_smas_ces_and_ses (smas_and_ses,ces_and_ses) = let - val (smas,ses_smas,se_map) = unify_sma_se smas_and_ses SEMap.empty - val (ces,ses,_) = unify_ce_se ces_and_ses se_map + val (smas,ses_smas,se_map) = unify_sma_se smas_and_ses SEMap.empty + val (ces,ses,_) = unify_ce_se ces_and_ses se_map in - (smas,ces,ses_smas@ses) + (smas,ces,ses_smas@ses) end fun unify_smas_ces_and_ses_free (smas_and_ses,(lvs_ces_ses,excons_ces_ses,rhos_ces_ses)) = let - val (smas,ses_smas,se_map) = unify_sma_se smas_and_ses SEMap.empty - val (rhos_ces,rhos_ses,se_map) = unify_ce_se rhos_ces_ses se_map - val (excons_ces,excons_ses,se_map) = unify_ce_se excons_ces_ses se_map - val (lvs_ces,lvs_ses,_) = unify_ce_se lvs_ces_ses se_map + val (smas,ses_smas,se_map) = unify_sma_se smas_and_ses SEMap.empty + val (rhos_ces,rhos_ses,se_map) = unify_ce_se rhos_ces_ses se_map + val (excons_ces,excons_ses,se_map) = unify_ce_se excons_ces_ses se_map + val (lvs_ces,lvs_ses,_) = unify_ce_se lvs_ces_ses se_map in - (smas,(lvs_ces,excons_ces,rhos_ces),ses_smas@rhos_ses@excons_ses@lvs_ses) + (smas,(lvs_ces,excons_ces,rhos_ces),ses_smas@rhos_ses@excons_ses@lvs_ses) end fun insert_se(ce,NONE_SE) = ce | insert_se(ce,SELECT_SE (lv1,i,lv2)) = LET{pat=[lv1], - bind=SELECT(i,VAR lv2), - scope=ce} + bind=SELECT(i,VAR lv2), + scope=ce} | insert_se(ce,FETCH_SE(lv,lab)) = - LET{pat=[lv], - bind=FETCH lab, - scope=ce} + LET{pat=[lv], + bind=FETCH lab, + scope=ce} fun insert_ses(ce,ses) = let - fun filter(acc,NONE_SE) = acc - | filter((lvs,ces),SELECT_SE (lv1,i,lv2)) = (lv1::lvs,SELECT(i,VAR lv2)::ces) - | filter((lvs,ces),FETCH_SE(lv,lab)) = (lv::lvs,FETCH lab::ces) - val (lvs,ces) = List.foldr (fn (se,acc) => filter(acc,se)) ([],[]) ses + fun filter(acc,NONE_SE) = acc + | filter((lvs,ces),SELECT_SE (lv1,i,lv2)) = (lv1::lvs,SELECT(i,VAR lv2)::ces) + | filter((lvs,ces),FETCH_SE(lv,lab)) = (lv::lvs,FETCH lab::ces) + val (lvs,ces) = List.foldr (fn (se,acc) => filter(acc,se)) ([],[]) ses in - (case lvs of - [] => ce - | _ => LET{pat=lvs, - bind=UB_RECORD ces, - scope=ce}) + (case lvs of + [] => ce + | _ => LET{pat=lvs, + bind=UB_RECORD ces, + scope=ce}) end (* ----------------------------------------- *) @@ -1187,111 +1187,96 @@ struct fun lookup_fix_profiling env lv = case CE.lookupVarOpt env lv - of SOME (CE.FIX(_,_,_,formals)) => formals - | _ => die "lookup_fix_profiling" + of SOME (CE.FIX(_,_,_,formals)) => formals + | _ => die "lookup_fix_profiling" fun lookup_ve env lv = let - fun resolve_se(CE.LVAR lv') = (VAR lv',NONE_SE) - | resolve_se(CE.SELECT(lv',i)) = - let - val lv'' = fresh_lvar("lookup_ve") - in - (VAR lv'',SELECT_SE(lv'',i,lv')) - end - | resolve_se(CE.LABEL lab) = - let - val lv' = fresh_lvar("lookup_ve") - in - (VAR lv',FETCH_SE (lv',lab)) - end - | resolve_se _ = die "resolve_se: wrong FIX or RVAR binding in VE" + fun resolve_se(CE.LVAR lv') = (VAR lv',NONE_SE) + | resolve_se(CE.SELECT(lv',i)) = + let + val lv'' = fresh_lvar("lookup_ve") + in + (VAR lv'',SELECT_SE(lv'',i,lv')) + end + | resolve_se(CE.LABEL lab) = + let + val lv' = fresh_lvar("lookup_ve") + in + (VAR lv',FETCH_SE (lv',lab)) + end + | resolve_se _ = die "resolve_se: wrong FIX or RVAR binding in VE" in - case CE.lookupVarOpt env lv of - SOME(CE.FIX(_,SOME a,_,_)) => resolve_se(a) - | SOME(CE.FIX(_,NONE,_,_)) => die "lookup_ve: this case should be caught in APP." - | SOME(a) => resolve_se(a) - | NONE => die ("lookup_ve: lvar(" ^ (Lvars.pr_lvar lv) ^ ") not bound in env.") + case CE.lookupVarOpt env lv of + SOME(CE.FIX(_,SOME a,_,_)) => resolve_se(a) + | SOME(CE.FIX(_,NONE,_,_)) => die "lookup_ve: this case should be caught in APP." + | SOME(a) => resolve_se(a) + | NONE => die ("lookup_ve: lvar(" ^ (Lvars.pr_lvar lv) ^ ") not bound in env.") end fun lookup_fun env lv = - case CE.lookupVarOpt env lv of - SOME(CE.FIX(lab,ce,size,_)) => (lab,size) - | _ => die ("lookup_fun: function(" ^ Lvars.pr_lvar lv ^ ") does not exists") + case CE.lookupVarOpt env lv of + SOME(CE.FIX(lab,ce,size,_)) => (lab,size) + | _ => die ("lookup_fun: function(" ^ Lvars.pr_lvar lv ^ ") does not exists") fun lookup_excon env excon = - (case CE.lookupExconOpt env excon of - SOME(CE.LVAR lv') => (VAR lv',NONE_SE) - | SOME(CE.SELECT(lv',i)) => - let - val lv'' = fresh_lvar("lookup_excon") - in - (VAR lv'',SELECT_SE(lv'',i,lv')) - end - | SOME(CE.LABEL lab) => - let - val lv' = fresh_lvar("lookup_excon") - in - (VAR lv',FETCH_SE (lv',lab)) - end - | SOME _ => die "lookup_excon: excon bound to FIX or RVAR" - | NONE => die ("lookup_excon: excon(" ^ (Excon.pr_excon excon) ^ ") not bound")) + case CE.lookupExconOpt env excon of + SOME(CE.LVAR lv') => (VAR lv',NONE_SE) + | SOME(CE.SELECT(lv',i)) => + let val lv'' = fresh_lvar("lookup_excon") + in (VAR lv'',SELECT_SE(lv'',i,lv')) + end + | SOME(CE.LABEL lab) => + let val lv' = fresh_lvar("lookup_excon") + in (VAR lv',FETCH_SE (lv',lab)) + end + | SOME _ => die "lookup_excon: excon bound to FIX or RVAR" + | NONE => die ("lookup_excon: excon(" ^ (Excon.pr_excon excon) ^ ") not bound") fun lookup_rho env place (f : unit -> string) = - (case CE.lookupRhoOpt env place of - SOME(CE.LVAR lv') => (VAR lv',NONE_SE) - | SOME(CE.RVAR place) => (RVAR place, NONE_SE) - | SOME(CE.DROPPED_RVAR place) => (DROPPED_RVAR place, NONE_SE) - | SOME(CE.SELECT(lv',i)) => - let - val lv'' = fresh_lvar("lookup_rho") - in - (VAR lv'',SELECT_SE(lv'',i,lv')) - end - | SOME(CE.LABEL lab) => - let - val lv' = fresh_lvar("lookup_rho") - in - (VAR lv',FETCH_SE (lv',lab)) - end - | SOME _ => die ("lookup_rho: rho bound to FIX. " ^ f()) - | NONE => die ("lookup_rho: rho(" ^ PP.flatten1(Effect.layout_effect place) ^ ") not bound. " ^ f())) + case CE.lookupRhoOpt env place of + SOME(CE.LVAR lv') => (VAR lv',NONE_SE) + | SOME(CE.RVAR place) => (RVAR place, NONE_SE) + | SOME(CE.DROPPED_RVAR place) => (DROPPED_RVAR place, NONE_SE) + | SOME(CE.SELECT(lv',i)) => + let val lv'' = fresh_lvar("lookup_rho") + in (VAR lv'',SELECT_SE(lv'',i,lv')) + end + | SOME(CE.LABEL lab) => + let val lv' = fresh_lvar("lookup_rho") + in (VAR lv',FETCH_SE (lv',lab)) + end + | SOME _ => die ("lookup_rho: rho bound to FIX. " ^ f()) + | NONE => die ("lookup_rho: rho(" ^ PP.flatten1(Effect.layout_effect place) ^ ") not bound. " ^ f()) fun convert_alloc (alloc,env) = - (case alloc of - AtInf.ATBOT(rho,pp) => - let - val (ce,se) = lookup_rho env rho (fn () => "convert_alloc1") - in - (convert_sma(AtInf.ATBOT(rho,pp),CE.lookupRhoKind env rho,ce),se) - end - | AtInf.SAT(rho,pp) => - let - val (ce,se) = lookup_rho env rho (fn () => "convert_alloc2") - in - (convert_sma(AtInf.SAT(rho,pp),CE.lookupRhoKind env rho,ce),se) - end - | AtInf.ATTOP(rho,pp) => - let - val (ce,se) = lookup_rho env rho (fn () => "convert_alloc3") - in - (convert_sma(AtInf.ATTOP(rho,pp),CE.lookupRhoKind env rho,ce),se) - end - | AtInf.IGNORE => (IGNORE,NONE_SE)) - - fun mult("f",PhysSizeInf.INF) = CE.FI - | mult("f",PhysSizeInf.WORDS n) = CE.FF - | mult("l",PhysSizeInf.INF) = CE.LI - | mult("l",PhysSizeInf.WORDS n) = CE.LF + case alloc of + AtInf.ATBOT(rho,pp) => + let val (ce,se) = lookup_rho env rho (fn () => "convert_alloc1") + in (convert_sma(AtInf.ATBOT(rho,pp),CE.lookupRhoKind env rho,ce),se) + end + | AtInf.SAT(rho,pp) => + let val (ce,se) = lookup_rho env rho (fn () => "convert_alloc2") + in (convert_sma(AtInf.SAT(rho,pp),CE.lookupRhoKind env rho,ce),se) + end + | AtInf.ATTOP(rho,pp) => + let val (ce,se) = lookup_rho env rho (fn () => "convert_alloc3") + in (convert_sma(AtInf.ATTOP(rho,pp),CE.lookupRhoKind env rho,ce),se) + end + + fun mult ("f",PhysSizeInf.INF) = CE.FI + | mult ("f",PhysSizeInf.WORDS n) = CE.FF + | mult ("l",PhysSizeInf.INF) = CE.LI + | mult ("l",PhysSizeInf.WORDS n) = CE.LF | mult _ = die "mult: Wrong binding or phsize" fun lookup_con env con = - (case CE.lookupCon env con of - CE.ENUM i => ENUM i - | CE.UB_NULLARY i => UNBOXED i - | CE.UB_UNARY i => UNBOXED i - | CE.B_NULLARY i => BOXED i - | CE.B_UNARY i => BOXED i) + case CE.lookupCon env con of + CE.ENUM i => ENUM i + | CE.UB_NULLARY i => UNBOXED i + | CE.UB_UNARY i => UNBOXED i + | CE.B_NULLARY i => BOXED i + | CE.B_UNARY i => BOXED i (*------------------------------------------------------------------*) (* Analyse the datatype bindings and return an environment mapping *) @@ -1304,44 +1289,44 @@ struct (*------------------------------------------------------------------*) fun add_datbinds_to_env (RegionExp.DATBINDS dbs) l2clos_exp_env : CE.env = let - fun enumeration tn binds = - TyName.unboxed tn andalso - List.all (fn (_,k,_) => k = RegionExp.CONSTANT) binds - - fun tags_enum n nil = nil - | tags_enum n ((con,_,_)::binds) = (con,CE.ENUM n) :: tags_enum (n+1) binds - - fun unary tn n = if TyName.unboxed tn then CE.UB_UNARY n - else CE.B_UNARY n - fun nullary tn n = if TyName.unboxed tn then CE.UB_NULLARY n - else CE.B_NULLARY n - fun tags tn n0 n1 [] = [] - | tags tn n0 n1 ((con,RegionExp.VALUE_CARRYING,_)::binds) = (con,unary tn n1) :: tags tn n0 (n1+1) binds - | tags tn n0 n1 ((con,RegionExp.CONSTANT,_)::binds) = (con,nullary tn n0) :: tags tn (n0+1) n1 binds - - fun analyse_datbind (tn,binds: (con * RegionExp.constructorKind * 'a) list) : (con * CE.con_kind) list = - if enumeration tn binds then tags_enum 0 binds - else tags tn 0 0 binds + fun enumeration tn binds = + TyName.unboxed tn andalso + List.all (fn (_,k,_) => k = RegionExp.CONSTANT) binds + + fun tags_enum n nil = nil + | tags_enum n ((con,_,_)::binds) = (con,CE.ENUM n) :: tags_enum (n+1) binds + + fun unary tn n = if TyName.unboxed tn then CE.UB_UNARY n + else CE.B_UNARY n + fun nullary tn n = if TyName.unboxed tn then CE.UB_NULLARY n + else CE.B_NULLARY n + fun tags tn n0 n1 [] = [] + | tags tn n0 n1 ((con,RegionExp.VALUE_CARRYING,_)::binds) = (con,unary tn n1) :: tags tn n0 (n1+1) binds + | tags tn n0 n1 ((con,RegionExp.CONSTANT,_)::binds) = (con,nullary tn n0) :: tags tn (n0+1) n1 binds + + fun analyse_datbind (tn,binds: (con * RegionExp.constructorKind * 'a) list) : (con * CE.con_kind) list = + if enumeration tn binds then tags_enum 0 binds + else tags tn 0 0 binds in List.foldl (fn (datbind,env) => - (env plus_decl_with CE.declareCon) (analyse_datbind datbind)) + (env plus_decl_with CE.declareCon) (analyse_datbind datbind)) l2clos_exp_env (concat_lists dbs) end local fun member tn nil = false - | member tn (x::xs) = TyName.eq (tn,x) orelse member tn xs + | member tn (x::xs) = TyName.eq (tn,x) orelse member tn xs in fun tn_to_foreign_type (tn : TyName.TyName) : foreign_type = - if TyName.eq(tn,TyName.tyName_BOOL) then Bool - else - if TyName.eq(tn,TyName.tyName_FOREIGNPTR) then ForeignPtr - else - if member tn [TyName.tyName_STRING, TyName.tyName_CHARARRAY] then CharArray - else - if member tn [TyName.tyName_IntDefault(), TyName.tyName_WordDefault()] then Int - else die ("tn_to_foreign_type.Type name " ^ TyName.pr_TyName tn - ^ " not supported in auto conversion") + if TyName.eq(tn,TyName.tyName_BOOL) then Bool + else + if TyName.eq(tn,TyName.tyName_FOREIGNPTR) then ForeignPtr + else + if member tn [TyName.tyName_STRING, TyName.tyName_CHARARRAY] then CharArray + else + if member tn [TyName.tyName_IntDefault(), TyName.tyName_WordDefault()] then Int + else die ("tn_to_foreign_type.Type name " ^ TyName.pr_TyName tn + ^ " not supported in auto conversion") end (* -------------------------------- *) @@ -1371,15 +1356,15 @@ struct fun precisionNumType t = case RType.unCONSTYPE t of SOME(tn,_,_,_) => - if TyName.eq(tn, TyName.tyName_INT31) then 31 - else if TyName.eq(tn, TyName.tyName_INT32) then 32 - else if TyName.eq(tn, TyName.tyName_INT63) then 63 - else if TyName.eq(tn, TyName.tyName_INT64) then 64 - else if TyName.eq(tn, TyName.tyName_WORD31) then 31 - else if TyName.eq(tn, TyName.tyName_WORD32) then 32 - else if TyName.eq(tn, TyName.tyName_WORD63) then 63 - else if TyName.eq(tn, TyName.tyName_WORD64) then 64 - else die "precisionNumType.wrong tyname" + if TyName.eq(tn, TyName.tyName_INT31) then 31 + else if TyName.eq(tn, TyName.tyName_INT32) then 32 + else if TyName.eq(tn, TyName.tyName_INT63) then 63 + else if TyName.eq(tn, TyName.tyName_INT64) then 64 + else if TyName.eq(tn, TyName.tyName_WORD31) then 31 + else if TyName.eq(tn, TyName.tyName_WORD32) then 32 + else if TyName.eq(tn, TyName.tyName_WORD63) then 63 + else if TyName.eq(tn, TyName.tyName_WORD64) then 64 + else die "precisionNumType.wrong tyname" | NONE => die "precisionNumType.wrong type" (* ------------------------------ *) @@ -1391,15 +1376,15 @@ struct (* registers associated with zero sized region closures are never defined. *) fun remove_zero_sized_region_closure_lvars env (lvs,rhos,excons) = let - fun remove [] = [] - | remove (lv::lvs) = - (case CE.lookupVar env lv of - CE.FIX(lab,NONE,0,_) => remove lvs - | CE.FIX(lab,NONE,i,_) => die "remove_zero_sized_region_closure_lvars: FIX messed up" - | CE.FIX(lab,SOME _,0,_) => die "remove_zero_sized_region_closure_lvars: FIX messed up" - | _ => lv :: remove lvs) + fun remove [] = [] + | remove (lv::lvs) = + (case CE.lookupVar env lv of + CE.FIX(lab,NONE,0,_) => remove lvs + | CE.FIX(lab,NONE,i,_) => die "remove_zero_sized_region_closure_lvars: FIX messed up" + | CE.FIX(lab,SOME _,0,_) => die "remove_zero_sized_region_closure_lvars: FIX messed up" + | _ => lv :: remove lvs) in - (remove lvs,rhos,excons) + (remove lvs,rhos,excons) end (* Determine the free variables for an ordinary or shared closure. *) @@ -1411,51 +1396,50 @@ struct (* f64 lambda variables; necessary for tagging. *) fun build_clos_env org_env new_env lv_clos base_offset (free_lv,free_excon,free_rho) = let - (* When computing offsets we do not increase the offset counter when meeting *) - (* a lambda variable bound to a zero sized shared region closure, since code *) - (* is not constructed to put such region closures into the actual closure. *) - fun add_free_lv (lv,(env,i)) = - (case CE.lookupVar org_env lv of - CE.FIX(lab,NONE,0,formals) => (CE.declareLvar(lv,CE.FIX(lab,NONE,0,formals),env),i) - | CE.FIX(lab,NONE,s,formals) => die "add_free_lv: CE.FIX messed up." - | CE.FIX(lab,SOME _,0,formals) => die "add_free_lv: CE.FIX messed up." - | CE.FIX(lab,SOME _,s,formals) => (CE.declareLvar(lv,CE.FIX(lab,SOME(CE.SELECT(lv_clos,i)),s,formals),env),i+1) - | _ => (CE.declareLvar(lv,CE.SELECT(lv_clos,i),env),i+1)) - fun add_free_excon (excon,(env,i)) = - (CE.declareExcon(excon,(CE.SELECT(lv_clos,i), - CE.lookupExconArity org_env excon),env),i+1) - fun add_free_rho (place,(env,i)) = - (CE.declareRhoKind(place,CE.lookupRhoKind org_env place, - CE.declareRho(place,CE.SELECT(lv_clos,i),env)),i+1) - val (env',_) = + (* When computing offsets we do not increase the offset counter when meeting *) + (* a lambda variable bound to a zero sized shared region closure, since code *) + (* is not constructed to put such region closures into the actual closure. *) + fun add_free_lv (lv,(env,i)) = + (case CE.lookupVar org_env lv of + CE.FIX(lab,NONE,0,formals) => (CE.declareLvar(lv,CE.FIX(lab,NONE,0,formals),env),i) + | CE.FIX(lab,NONE,s,formals) => die "add_free_lv: CE.FIX messed up." + | CE.FIX(lab,SOME _,0,formals) => die "add_free_lv: CE.FIX messed up." + | CE.FIX(lab,SOME _,s,formals) => (CE.declareLvar(lv,CE.FIX(lab,SOME(CE.SELECT(lv_clos,i)),s,formals),env),i+1) + | _ => (CE.declareLvar(lv,CE.SELECT(lv_clos,i),env),i+1)) + fun add_free_excon (excon,(env,i)) = + (CE.declareExcon(excon,(CE.SELECT(lv_clos,i), + CE.lookupExconArity org_env excon),env),i+1) + fun add_free_rho (place,(env,i)) = + (CE.declareRhoKind(place,CE.lookupRhoKind org_env place, + CE.declareRho(place,CE.SELECT(lv_clos,i),env)),i+1) + val (env',_) = (* - List.foldl add_free_lv - (List.foldl add_free_excon - (List.foldl add_free_rho (new_env, base_offset) free_rho) free_excon) free_lv + List.foldl add_free_lv + (List.foldl add_free_excon + (List.foldl add_free_rho (new_env, base_offset) free_rho) free_excon) free_lv *) - List.foldl add_free_excon - (List.foldl add_free_lv - (List.foldl add_free_rho (new_env, base_offset) free_rho) free_lv) free_excon + List.foldl add_free_excon + (List.foldl add_free_lv + (List.foldl add_free_rho (new_env, base_offset) free_rho) free_lv) free_excon in - env' + env' end (* Returns (ces,ses) corresponding to accessing the free variables *) fun gen_ces_and_ses_free env (free_lv,free_excon,free_rho) = let - val lvs_and_ses = List.map (fn lv => lookup_ve env lv) free_lv - val excons_and_ses = List.map (fn excon => lookup_excon env excon) free_excon - val rhos_and_ses = List.map (fn place => lookup_rho env place (fn () => "gen_ces_and_ses_free")) free_rho + val lvs_and_ses = List.map (fn lv => lookup_ve env lv) free_lv + val excons_and_ses = List.map (fn excon => lookup_excon env excon) free_excon + val rhos_and_ses = List.map (fn place => lookup_rho env place (fn () => "gen_ces_and_ses_free")) free_rho in - (lvs_and_ses,excons_and_ses,rhos_and_ses) + (lvs_and_ses,excons_and_ses,rhos_and_ses) end (* drop_rho rho: replace rho by a global region with the same runtime type; *) (* used when rho is letrec-bound, but never written into. *) fun drop_rho rho = (case Effect.get_place_ty rho of - SOME Effect.WORD_RT => Effect.toplevel_region_withtype_word - | SOME Effect.STRING_RT => Effect.toplevel_region_withtype_string + SOME Effect.STRING_RT => Effect.toplevel_region_withtype_string | SOME Effect.PAIR_RT => Effect.toplevel_region_withtype_pair | SOME Effect.ARRAY_RT => Effect.toplevel_region_withtype_array | SOME Effect.REF_RT => Effect.toplevel_region_withtype_ref @@ -1467,51 +1451,51 @@ struct (* ces_and_ses contains the arguments. The function compiles the closure argument if exists. *) fun compile_letrec_app env lvar ces_and_ses = let - val (lab_f,size_clos) = lookup_fun env lvar + val (lab_f,size_clos) = lookup_fun env lvar in - if size_clos = 0 then - let - val (ces,ses,_) = unify_ce_se ces_and_ses SEMap.empty - in - (NONE,ces,ses,lab_f) - end - else - let - val (ce_clos,se_clos) = lookup_ve env lvar - val (ces,ses,_) = unify_ce_se ((ce_clos,se_clos)::ces_and_ses) SEMap.empty - val (ce_clos',ces') = split_in_hd_and_tl ces - in - (SOME ce_clos',ces',ses,lab_f) - end + if size_clos = 0 then + let + val (ces,ses,_) = unify_ce_se ces_and_ses SEMap.empty + in + (NONE,ces,ses,lab_f) + end + else + let + val (ce_clos,se_clos) = lookup_ve env lvar + val (ces,ses,_) = unify_ce_se ((ce_clos,se_clos)::ces_and_ses) SEMap.empty + val (ce_clos',ces') = split_in_hd_and_tl ces + in + (SOME ce_clos',ces',ses,lab_f) + end end fun compile_sels_and_default sels default f_match ccTrip = let - val sels' = - List.foldr (fn ((m,tr),sels_acc) => - (f_match m, insert_se(ccTrip tr))::sels_acc) [] sels + val sels' = + List.foldr (fn ((m,tr),sels_acc) => + (f_match m, insert_se(ccTrip tr))::sels_acc) [] sels in - case default of - SOME tr => (sels', insert_se(ccTrip tr)) - | NONE => - (case rev sels' of - ((_,ce)::rev_sels') => (rev rev_sels',ce) - | _ => die "compile_sels_and_default: no selections.") + case default of + SOME tr => (sels', insert_se(ccTrip tr)) + | NONE => + (case rev sels' of + ((_,ce)::rev_sels') => (rev rev_sels',ce) + | _ => die "compile_sels_and_default: no selections.") end local fun labs (fun_lab: label list, dat_lab: label list) (r:CE.access_type) : label list * label list = - case r - of CE.FIX(lab,SOME(CE.LABEL sclos_lab),_,_) => (lab::fun_lab,sclos_lab::dat_lab) (* lab is a function and sclos is a data object. *) - | CE.FIX(lab,NONE,_,_) => (lab::fun_lab,dat_lab) (* lab is a function with empty shared closure. *) - | CE.LABEL lab => (fun_lab,lab::dat_lab) (* Is a DatLab *) - | CE.FIX(lab,SOME(CE.LVAR lvar),_,_) => die "find_globals_in_env: FIX with SCLOS bound to lvar." - | CE.FIX(lab,SOME(CE.SELECT(lvar,i)),_,_) => die "find_globals_in_env: FIX with SCLOS bound to SELECT." - | CE.FIX(lab,_,_,_) => die "find_globals_in_env: global bound to wierd FIX." - | CE.LVAR _ => die "find_globals_in_env: global bound to lvar." - | CE.RVAR _ => die "find_globals_in_env: global bound to rvar." - | CE.DROPPED_RVAR _ => die "find_globals_in_env: global bound to dropped rvar." - | CE.SELECT _ => die "find_globals_in_env: global bound to select expression." + case r + of CE.FIX(lab,SOME(CE.LABEL sclos_lab),_,_) => (lab::fun_lab,sclos_lab::dat_lab) (* lab is a function and sclos is a data object. *) + | CE.FIX(lab,NONE,_,_) => (lab::fun_lab,dat_lab) (* lab is a function with empty shared closure. *) + | CE.LABEL lab => (fun_lab,lab::dat_lab) (* Is a DatLab *) + | CE.FIX(lab,SOME(CE.LVAR lvar),_,_) => die "find_globals_in_env: FIX with SCLOS bound to lvar." + | CE.FIX(lab,SOME(CE.SELECT(lvar,i)),_,_) => die "find_globals_in_env: FIX with SCLOS bound to SELECT." + | CE.FIX(lab,_,_,_) => die "find_globals_in_env: global bound to wierd FIX." + | CE.LVAR _ => die "find_globals_in_env: global bound to lvar." + | CE.RVAR _ => die "find_globals_in_env: global bound to rvar." + | CE.DROPPED_RVAR _ => die "find_globals_in_env: global bound to dropped rvar." + | CE.SELECT _ => die "find_globals_in_env: global bound to select expression." in fun find_globals_in_env_all env = CE.labelsEnv labs env @@ -1519,39 +1503,37 @@ struct (* -- labels to functions, (i.e., code labels) *) (* -- labels to data, (i.e., data labels) *) fun find_globals_in_env (lvars, excons, regvars) env = - let - fun lookup lv f_lookup (fun_lab,dat_lab) = - case f_lookup env lv - of SOME r => labs (fun_lab,dat_lab) r - | NONE => die ("find_globals_in_env: lvar not bound in env.") - val pair_labs = foldr (fn (lv,a) => lookup lv CE.lookupVarOpt a) ([],[]) lvars - val pair_labs = foldr (fn (ex,a) => lookup ex CE.lookupExconOpt a) pair_labs excons -(* val pair_labs = foldr (fn (rho,a) => lookup rho CE.lookupRhoOpt a) pair_labs regvars + let + fun lookup lv f_lookup (fun_lab,dat_lab) = + case f_lookup env lv + of SOME r => labs (fun_lab,dat_lab) r + | NONE => die ("find_globals_in_env: lvar not bound in env.") + val pair_labs = foldr (fn (lv,a) => lookup lv CE.lookupVarOpt a) ([],[]) lvars + val pair_labs = foldr (fn (ex,a) => lookup ex CE.lookupExconOpt a) pair_labs excons +(* val pair_labs = foldr (fn (rho,a) => lookup rho CE.lookupRhoOpt a) pair_labs regvars this one does not seem necessary because no new regions survive program units and because the the global regions 0-3 are allocated statically with address labels 0-3. ME 2000-10-31 *) - in pair_labs - end + in pair_labs + end end - fun gen_fresh_res_lvars(RegionExp.Mus type_and_places) = - (case type_and_places of - [(ty,_)] => - (case RType.unFUN ty of + fun gen_fresh_res_lvars (RegionExp.Mus [mu]) = + (case RType.unFUN (#1(RType.unbox mu)) of SOME(mus1,arroweffect,mus2) => List.map (fn _ => fresh_lvar("res")) mus2 | NONE => die "gen_fresh_res: not a function type.") - | _ => die "gen_fresh_res: not a function type.") - | gen_fresh_res_lvars(RegionExp.Frame _) = [] - | gen_fresh_res_lvars(RegionExp.RaisedExnBind) = [] + | gen_fresh_res_lvars (RegionExp.Mus _) = die "gen_fresh_res: expecting singleton mu." + | gen_fresh_res_lvars (RegionExp.Frame _) = [] + | gen_fresh_res_lvars (RegionExp.RaisedExnBind) = [] (* Convert ~n to -n *) fun convert_real r = (* Translate a real constant into C notation: *) - let fun conv #"~" = #"-" - | conv #"E" = #"e" - | conv c = c - in (implode o (map conv) o explode) r - end + let fun conv #"~" = #"-" + | conv #"E" = #"e" + | conv c = c + in (implode o (map conv) o explode) r + end fun pass_ptr_to_rho s pr sma = let @@ -1575,203 +1557,203 @@ struct (* ------------------------ *) fun ccTrip (MulExp.TR(e,metaType,ateffects,mulef)) env lab cur_rv = let - fun ccExp e = - (case e of - MulExp.VAR{lvar,...} => lookup_ve env lvar - | MulExp.INTEGER(i,t,alloc) => - (INTEGER {value=i, precision=precisionNumType t}, NONE_SE) - | MulExp.WORD(w,t,alloc) => + fun ccExp e = + (case e of + MulExp.VAR{lvar,...} => lookup_ve env lvar + | MulExp.INTEGER(i,t,alloc) => + (INTEGER {value=i, precision=precisionNumType t}, NONE_SE) + | MulExp.WORD(w,t,alloc) => (WORD {value=w, precision=precisionNumType t}, NONE_SE) - | MulExp.STRING(s,alloc) => (STRING s,NONE_SE) - | MulExp.REAL(r,alloc) => (REAL (convert_real r),NONE_SE) - | MulExp.F64(r,alloc) => (F64 (convert_real r),NONE_SE) - | MulExp.UB_RECORD trs => - let - val ces_and_ses = List.map (fn tr => ccTrip tr env lab cur_rv) trs - val (ces,ses,_) = unify_ce_se ces_and_ses SEMap.empty - in - (insert_ses(UB_RECORD ces,ses),NONE_SE) - end - | MulExp.FN{pat,body,free=ref (SOME free_vars_all),alloc} => - (* For now, the function is closure implemented. *) - (* Free variables must go into the closure. All free variables *) - (* (free_vars_all) must be bound in the closure environment, *) - (* while we do not store region closures with no free variables *) + | MulExp.STRING(s,alloc) => (STRING s,NONE_SE) + | MulExp.REAL(r,alloc) => (REAL (convert_real r),NONE_SE) + | MulExp.F64 r => (F64 (convert_real r),NONE_SE) + | MulExp.UB_RECORD trs => + let + val ces_and_ses = List.map (fn tr => ccTrip tr env lab cur_rv) trs + val (ces,ses,_) = unify_ce_se ces_and_ses SEMap.empty + in + (insert_ses(UB_RECORD ces,ses),NONE_SE) + end + | MulExp.FN{pat,body,free=ref (SOME free_vars_all),alloc} => + (* For now, the function is closure implemented. *) + (* Free variables must go into the closure. All free variables *) + (* (free_vars_all) must be bound in the closure environment, *) + (* while we do not store region closures with no free variables *) (* in the actual closure. *) - let - val free_vars = remove_zero_sized_region_closure_lvars env free_vars_all - - val new_lab = fresh_lab (Labels.pr_label lab ^ ".anon") - val lv_clos = fresh_lvar("clos") - val args = List.map #1 pat - val ress = gen_fresh_res_lvars metaType (* Result variables are not bound in env as they only exists in cc *) - val cc = CallConv.mk_cc_fn(args,SOME lv_clos,ress) - - val env_body = build_clos_env env (get_global_env()) lv_clos BI.init_clos_offset free_vars_all - val env_with_args = (env_body plus_decl_with CE.declareLvar) (map (fn lv => (lv, CE.LVAR lv)) args) - - val ces_and_ses = gen_ces_and_ses_free env free_vars - handle _ => die "FN" - - val _ = add_new_fn(new_lab, cc, insert_se(ccTrip body env_with_args new_lab NONE)) - val (sma,se_sma) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses_free([(sma,se_sma)],ces_and_ses) - in - (insert_ses(CLOS_RECORD{label=new_lab, elems=ces, alloc=one_in_list(smas)},ses),NONE_SE) - end - | MulExp.FN _ => die "ccExp: FN with no free vars info" - | MulExp.FIX{free=ref (SOME free_vars_all),shared_clos=alloc,functions,scope} => - (* For now, the functions are closure implemented *) - (* Note, that we may pass a shared closure to a function even though it isn't used by the function. *) - (* It is not necessary to pass a shared closure to a FIX bound function f iff: *) - (* 1- f has no free variables except FIX bound functions. *) - (* 2- f does not call another FIX bound function g using the shared closure. *) - let - val free_vars_in_shared_clos = remove_zero_sized_region_closure_lvars env free_vars_all - val shared_clos_size = size3 free_vars_in_shared_clos - - val lv_sclos = fresh_lvar("sclos") - val ces_and_ses = gen_ces_and_ses_free env free_vars_in_shared_clos - handle _ => die "FIX" - val lvars_labels_formals = map (fn {lvar, rhos_formals=ref formals, ...} => - (lvar, fresh_lab(Lvars.pr_lvar lvar), formals)) functions - val lvars = map #lvar functions - val binds = map #bind functions - val formalss = map (! o #rhos_formals) functions (* place*phsize *) - val dropss = map (valOf o #bound_but_never_written_into) functions - handle Option => die "FIX.dropps: bound but never written was None" - - val labels = map #2 lvars_labels_formals - - val env_scope = - if shared_clos_size = 0 then - (env plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) - else - (env plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos),shared_clos_size,formals))) lvars_labels_formals) - - fun compile_fn (lvar,bind,formals,drops,lab) = - let - val (args,body,metaType) = case bind of - MulExp.TR(MulExp.FN{pat,body,...},metaType,_,_) => (List.map #1 pat, body,metaType) - | _ => die "compile_fn: bind is not a FN" - val ress = gen_fresh_res_lvars metaType (* Result variables are not bound in env as they only exists in cc *) - val lv_sclos_fn = fresh_lvar("sclos") - val env_bodies = build_clos_env env (get_global_env()) lv_sclos_fn BI.init_sclos_offset free_vars_all - - val env_with_funs = - if shared_clos_size = 0 then - (env_bodies plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) - else - (env_bodies plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos_fn),shared_clos_size,formals))) lvars_labels_formals) - val lv_rv = fresh_lvar("rv") - val (reg_args, env_with_rv) = - if region_vectors then - let val e = #1(List.foldl (fn ((place,_),(env,i)) => - (CE.declareRho(place,CE.SELECT(lv_rv,i),env),i+1)) - (env_with_funs, BI.init_regvec_offset) formals) (* formals may be empty! *) - in (nil, e) - end - else (List.foldr (fn ((place,_),(lvs,env)) => - let val lv = fresh_lvar "regarg" - in (lv::lvs, CE.declareRho(place,CE.LVAR lv,env)) - end) - (nil,env_with_funs) formals) - - val env_with_rho_kind = - (env_with_rv plus_decl_with CE.declareRhoKind) - (map (fn (place,phsize) => (place,mult("f",phsize))) formals) - - val env_with_rho_drop = - (env_with_rho_kind plus_decl_with CE.declareRho) - (map (fn (place,_) => (place,CE.DROPPED_RVAR(drop_rho place))) drops) - val env_with_rho_drop_kind = - (env_with_rho_drop plus_decl_with CE.declareRhoKind) - (map (fn(place,phsize) => (place,mult("f",phsize))) drops) - - val env_with_args = - (env_with_rho_drop_kind plus_decl_with CE.declareLvar) - (map (fn lv => (lv, CE.LVAR lv)) args) - -(* val _ = print ("Closure size, " ^ (Lvars.pr_lvar lv_sclos_fn) ^ ": " ^ (Int.toString shared_clos_size) ^ - " " ^ (pr_free free_vars_in_shared_clos) ^ "\n") *) - val sclos = if shared_clos_size = 0 then NONE else SOME lv_sclos_fn (* 14/06-2000, Niels *) - val (lv_rv_opt, lv_rv_var_opt) = - if List.null formals orelse not(region_vectors) then (NONE, NONE) - else (SOME lv_rv, SOME(VAR lv_rv)) - val cc = CallConv.mk_cc_fun(args,sclos,lv_rv_opt,reg_args,ress) - in - add_new_fun(lab,cc,insert_se(ccTrip body env_with_args lab lv_rv_var_opt)) - end - val _ = List.app compile_fn (zip5 (lvars,binds,formalss,dropss,labels)) - in - if shared_clos_size = 0 then - (insert_se(ccTrip scope env_scope lab cur_rv),NONE_SE) - else - let - val (sma,se_a) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses_free([(sma,se_a)],ces_and_ses) - in - (insert_ses(LET{pat=[lv_sclos], - bind= SCLOS_RECORD{elems=ces,alloc=one_in_list(smas)}, - scope=insert_se(ccTrip scope env_scope lab cur_rv)}, - ses),NONE_SE) - end - end - | MulExp.FIX{free=_,shared_clos,functions,scope} => die "ccExp: No free variables in FIX" - - | MulExp.APP(SOME MulExp.JMP, _, tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound,rhos_actuals = ref rhos_actuals,...}, _, _, _), tr2) => - (* Poly tail call; this could be made more efficient if we distinguish between a tail call - * and a jmp - that is, if we recognice that regions in registers and on the stack - * can be reused. *) - let - val _ = - if region_profiling() then - let val rhos_formals = lookup_fix_profiling env lvar - in RegionFlowGraphProfiling.add_edges((rhos_formals,Lvars.pr_lvar lvar),rhos_actuals) - end - else () - - val ces_and_ses = (* We remove the unboxed record. *) - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs - | _ => [ccTrip tr2 env lab cur_rv] - - val (ce_clos,ces_arg,ses,lab_f) = compile_letrec_app env lvar ces_and_ses - in - let val smas_regvec_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) rhos_actuals - val (smas,ses_sma,_) = unify_sma_se smas_regvec_and_ses SEMap.empty - val fresh_lvs = map (fn _ => fresh_lvar "sma") smas - fun maybe_insert_smas([],[],ce) = ce - | maybe_insert_smas(fresh_lvs,smas,ce) = - LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} - in - (insert_ses - (maybe_insert_smas - (fresh_lvs,map (pass_ptr_to_rho "JMP" (fn () => Lvars.pr_lvar lvar)) smas, - insert_ses - (JMP{opr=lab_f,args=ces_arg,reg_vec=NONE, - reg_args=map VAR fresh_lvs,clos=ce_clos}, - ses)), - ses_sma), - NONE_SE) - end - end - | MulExp.APP(SOME MulExp.JMP, _, tr1 (*not lvar: error *), tr2) => die "JMP to other than lvar" - | MulExp.APP(SOME MulExp.FUNCALL, _, - tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound=true, rhos_actuals=ref rhos_actuals,...},_,_,_), - tr2) => - let - (* Insert edges in the Region Flow Graph for Profiling. *) - val _ = - if region_profiling() then - let val rhos_formals = lookup_fix_profiling env lvar - in RegionFlowGraphProfiling.add_edges((rhos_formals,Lvars.pr_lvar lvar),rhos_actuals) - end - else () + let + val free_vars = remove_zero_sized_region_closure_lvars env free_vars_all + + val new_lab = fresh_lab (Labels.pr_label lab ^ ".anon") + val lv_clos = fresh_lvar("clos") + val args = List.map #1 pat + val ress = gen_fresh_res_lvars metaType (* Result variables are not bound in env as they only exists in cc *) + val cc = CallConv.mk_cc_fn(args,SOME lv_clos,ress) + + val env_body = build_clos_env env (get_global_env()) lv_clos BI.init_clos_offset free_vars_all + val env_with_args = (env_body plus_decl_with CE.declareLvar) (map (fn lv => (lv, CE.LVAR lv)) args) + + val ces_and_ses = gen_ces_and_ses_free env free_vars + handle _ => die "FN" + + val _ = add_new_fn(new_lab, cc, insert_se(ccTrip body env_with_args new_lab NONE)) + val (sma,se_sma) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses_free([(sma,se_sma)],ces_and_ses) + in + (insert_ses(CLOS_RECORD{label=new_lab, elems=ces, alloc=one_in_list(smas)},ses),NONE_SE) + end + | MulExp.FN _ => die "ccExp: FN with no free vars info" + | MulExp.FIX{free=ref (SOME free_vars_all),shared_clos=alloc,functions,scope} => + (* For now, the functions are closure implemented *) + (* Note, that we may pass a shared closure to a function even though it isn't used by the function. *) + (* It is not necessary to pass a shared closure to a FIX bound function f iff: *) + (* 1- f has no free variables except FIX bound functions. *) + (* 2- f does not call another FIX bound function g using the shared closure. *) + let + val free_vars_in_shared_clos = remove_zero_sized_region_closure_lvars env free_vars_all + val shared_clos_size = size3 free_vars_in_shared_clos + + val lv_sclos = fresh_lvar("sclos") + val ces_and_ses = gen_ces_and_ses_free env free_vars_in_shared_clos + handle _ => die "FIX" + val lvars_labels_formals = map (fn {lvar, rhos_formals=ref formals, ...} => + (lvar, fresh_lab(Lvars.pr_lvar lvar), formals)) functions + val lvars = map #lvar functions + val binds = map #bind functions + val formalss = map (! o #rhos_formals) functions (* place*phsize *) + val dropss = map (valOf o #bound_but_never_written_into) functions + handle Option => die "FIX.dropps: bound but never written was None" + + val labels = map #2 lvars_labels_formals + + val env_scope = + if shared_clos_size = 0 then + (env plus_decl_with CE.declareLvar) + (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) + else + (env plus_decl_with CE.declareLvar) + (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos),shared_clos_size,formals))) lvars_labels_formals) + + fun compile_fn (lvar,bind,formals,drops,lab) = + let + val (args,body,metaType) = case bind of + MulExp.TR(MulExp.FN{pat,body,...},metaType,_,_) => (List.map #1 pat, body,metaType) + | _ => die "compile_fn: bind is not a FN" + val ress = gen_fresh_res_lvars metaType (* Result variables are not bound in env as they only exists in cc *) + val lv_sclos_fn = fresh_lvar("sclos") + val env_bodies = build_clos_env env (get_global_env()) lv_sclos_fn BI.init_sclos_offset free_vars_all + + val env_with_funs = + if shared_clos_size = 0 then + (env_bodies plus_decl_with CE.declareLvar) + (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) + else + (env_bodies plus_decl_with CE.declareLvar) + (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos_fn),shared_clos_size,formals))) lvars_labels_formals) + val lv_rv = fresh_lvar("rv") + val (reg_args, env_with_rv) = + if region_vectors then + let val e = #1(List.foldl (fn ((place,_),(env,i)) => + (CE.declareRho(place,CE.SELECT(lv_rv,i),env),i+1)) + (env_with_funs, BI.init_regvec_offset) formals) (* formals may be empty! *) + in (nil, e) + end + else (List.foldr (fn ((place,_),(lvs,env)) => + let val lv = fresh_lvar "regarg" + in (lv::lvs, CE.declareRho(place,CE.LVAR lv,env)) + end) + (nil,env_with_funs) formals) + + val env_with_rho_kind = + (env_with_rv plus_decl_with CE.declareRhoKind) + (map (fn (place,phsize) => (place,mult("f",phsize))) formals) + + val env_with_rho_drop = + (env_with_rho_kind plus_decl_with CE.declareRho) + (map (fn (place,_) => (place,CE.DROPPED_RVAR(drop_rho place))) drops) + val env_with_rho_drop_kind = + (env_with_rho_drop plus_decl_with CE.declareRhoKind) + (map (fn(place,phsize) => (place,mult("f",phsize))) drops) + + val env_with_args = + (env_with_rho_drop_kind plus_decl_with CE.declareLvar) + (map (fn lv => (lv, CE.LVAR lv)) args) + +(* val _ = print ("Closure size, " ^ (Lvars.pr_lvar lv_sclos_fn) ^ ": " ^ (Int.toString shared_clos_size) ^ + " " ^ (pr_free free_vars_in_shared_clos) ^ "\n") *) + val sclos = if shared_clos_size = 0 then NONE else SOME lv_sclos_fn (* 14/06-2000, Niels *) + val (lv_rv_opt, lv_rv_var_opt) = + if List.null formals orelse not(region_vectors) then (NONE, NONE) + else (SOME lv_rv, SOME(VAR lv_rv)) + val cc = CallConv.mk_cc_fun(args,sclos,lv_rv_opt,reg_args,ress) + in + add_new_fun(lab,cc,insert_se(ccTrip body env_with_args lab lv_rv_var_opt)) + end + val _ = List.app compile_fn (zip5 (lvars,binds,formalss,dropss,labels)) + in + if shared_clos_size = 0 then + (insert_se(ccTrip scope env_scope lab cur_rv),NONE_SE) + else + let + val (sma,se_a) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses_free([(sma,se_a)],ces_and_ses) + in + (insert_ses(LET{pat=[lv_sclos], + bind= SCLOS_RECORD{elems=ces,alloc=one_in_list(smas)}, + scope=insert_se(ccTrip scope env_scope lab cur_rv)}, + ses),NONE_SE) + end + end + | MulExp.FIX{free=_,shared_clos,functions,scope} => die "ccExp: No free variables in FIX" + + | MulExp.APP(SOME MulExp.JMP, _, tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound,rhos_actuals = ref rhos_actuals,...}, _, _, _), tr2) => + (* Poly tail call; this could be made more efficient if we distinguish between a tail call + * and a jmp - that is, if we recognice that regions in registers and on the stack + * can be reused. *) + let + val _ = + if region_profiling() then + let val rhos_formals = lookup_fix_profiling env lvar + in RegionFlowGraphProfiling.add_edges((rhos_formals,Lvars.pr_lvar lvar),rhos_actuals) + end + else () + + val ces_and_ses = (* We remove the unboxed record. *) + case tr2 of + MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs + | _ => [ccTrip tr2 env lab cur_rv] + + val (ce_clos,ces_arg,ses,lab_f) = compile_letrec_app env lvar ces_and_ses + in + let val smas_regvec_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) rhos_actuals + val (smas,ses_sma,_) = unify_sma_se smas_regvec_and_ses SEMap.empty + val fresh_lvs = map (fn _ => fresh_lvar "sma") smas + fun maybe_insert_smas([],[],ce) = ce + | maybe_insert_smas(fresh_lvs,smas,ce) = + LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} + in + (insert_ses + (maybe_insert_smas + (fresh_lvs,map (pass_ptr_to_rho "JMP" (fn () => Lvars.pr_lvar lvar)) smas, + insert_ses + (JMP{opr=lab_f,args=ces_arg,reg_vec=NONE, + reg_args=map VAR fresh_lvs,clos=ce_clos}, + ses)), + ses_sma), + NONE_SE) + end + end + | MulExp.APP(SOME MulExp.JMP, _, tr1 (*not lvar: error *), tr2) => die "JMP to other than lvar" + | MulExp.APP(SOME MulExp.FUNCALL, _, + tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound=true, rhos_actuals=ref rhos_actuals,...},_,_,_), + tr2) => + let + (* Insert edges in the Region Flow Graph for Profiling. *) + val _ = + if region_profiling() then + let val rhos_formals = lookup_fix_profiling env lvar + in RegionFlowGraphProfiling.add_edges((rhos_formals,Lvars.pr_lvar lvar),rhos_actuals) + end + else () (* fun check_rho s rho = case lookup_rho env rho (fn () => "FUNCALL-check") of @@ -1780,548 +1762,566 @@ struct val () = (* check that all rhos_actuals are NON-DROPPED *) List.app (fn a => case a of - AtInf.IGNORE => die ("FUNCALL" ^ Lvars.pr_lvar lvar ^ ": ignore") - | AtInf.ATTOP(rho,pp) => check_rho "ATTOP" rho + AtInf.ATTOP(rho,pp) => check_rho "ATTOP" rho | AtInf.ATBOT(rho,pp) => check_rho "ATBOT" rho | AtInf.SAT(rho,pp) => check_rho "SAT" rho ) rhos_actuals *) - val ces_and_ses = (* We remove the unboxed record. *) - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs - | _ => [ccTrip tr2 env lab cur_rv] - - val (ce_clos,ces_arg,ses,lab_f) = compile_letrec_app env lvar ces_and_ses - val (smas,ses_sma) = - let val smas_regvec_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) rhos_actuals - val (smas,ses_sma,_) = unify_sma_se smas_regvec_and_ses SEMap.empty - in (smas,ses_sma) - end - - val fresh_lvs = map (fn _ => fresh_lvar "sma") smas - fun maybe_insert_smas([],[],ce) = ce - | maybe_insert_smas(fresh_lvs,smas,ce) = - LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} - in - (insert_ses - (maybe_insert_smas - (fresh_lvs, map (pass_ptr_to_rho "FUNCALL" (fn () => Lvars.pr_lvar lvar)) smas, - insert_ses - (FUNCALL{opr=lab_f,args=ces_arg,reg_vec=NONE, - reg_args=map VAR fresh_lvs,clos=ce_clos}, - ses)), - ses_sma), - NONE_SE) - end - | MulExp.APP(SOME MulExp.FNJMP,_, tr1,tr2) => - let - val ces_and_ses = - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs - | _ => [ccTrip tr2 env lab cur_rv] - val (ce_opr,se_opr) = ccTrip tr1 env lab cur_rv - val (ces1,ses',_) = unify_ce_se ((ce_opr,se_opr)::ces_and_ses) SEMap.empty - val (ce_opr',ces') = split_in_hd_and_tl ces1 - in - (insert_ses(FNJMP{opr=ce_opr',args=ces',clos=SOME ce_opr'}, - ses'),NONE_SE) - end - | MulExp.APP(SOME MulExp.FNCALL,_, tr1, tr2) => - let - val ces_and_ses = - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs - | _ => [ccTrip tr2 env lab cur_rv] - val (ce_opr,se_opr) = ccTrip tr1 env lab cur_rv - val (ces1,ses',_) = unify_ce_se ((ce_opr,se_opr)::ces_and_ses) SEMap.empty - val (ce_opr',ces') = split_in_hd_and_tl ces1 - in - (insert_ses(FNCALL{opr=ce_opr',args=ces',clos=SOME ce_opr'}, - ses'),NONE_SE) - end - | MulExp.APP _ => die "application form not recognised" - - | MulExp.LETREGION{B,rhos=ref bound_regvars,body} => - let - (* Insert letregion nodes in the RegionFlowGraph. *) - val _ = - if region_profiling() then - RegionFlowGraphProfiling.add_nodes (bound_regvars,"LETREGION") - else () - - val env_with_kind = - (env plus_decl_with CE.declareRhoKind) - (map (fn (place,phsize) => (place,mult("l",phsize))) bound_regvars) - val env_body = - (env_with_kind plus_decl_with CE.declareRho) - (map (fn (place,_) => (place,CE.RVAR place)) bound_regvars) - in - (LETREGION{rhos=bound_regvars, - body=insert_se(ccTrip body env_body lab cur_rv)},NONE_SE) - end - | MulExp.LET{k_let,pat,bind,scope} => - let - val lvars = List.map #1 pat - val env_with_lvar = - (env plus_decl_with CE.declareLvar) - (map (fn lv => (lv,CE.LVAR lv)) lvars) - in - (LET{pat=lvars, - bind=insert_se(ccTrip bind env lab cur_rv), - scope=insert_se(ccTrip scope env_with_lvar lab cur_rv)},NONE_SE) - end - | MulExp.EXCEPTION(excon,true,typePlace,alloc,scope) => (* Nullary exception constructor *) - let - val lv1 = fresh_lvar "exn0-1" - val lv2 = fresh_lvar "exn0-2" - val lv3 = fresh_lvar "exn0-3" - val lv4 = fresh_lvar "exn0-4" - val env' = CE.declareExcon(excon,(CE.LVAR lv4,CE.NULLARY_EXCON),env) - val (sma,se_a) = convert_alloc(alloc,env) - in - (LET{pat=[lv1], - bind=CCALL{name="__fresh_exname", - args=[], - rhos_for_result=[]}, - scope=insert_se(LET{pat=[lv2], - bind=STRING (Excon.pr_excon excon), - scope=LET{pat=[lv3], - bind=RECORD{elems=[VAR lv1,VAR lv2], - alloc=sma, - tag=BI.tag_exname false, - maybeuntag=false}, - scope=LET{pat=[lv4], - bind=RECORD{elems=[VAR lv3], - alloc=sma, - tag=BI.tag_excon0 false, - maybeuntag=false}, - scope=insert_se (ccTrip scope env' lab cur_rv)}}}, - se_a)},NONE_SE) - end - | MulExp.EXCEPTION(excon,false,typePlace,alloc,scope) => (* Unary exception constructor *) - let - val lv1 = fresh_lvar "exn0-1" - val lv2 = fresh_lvar "exn0-2" - val lv3 = fresh_lvar "exn0-3" - val env' = CE.declareExcon(excon,(CE.LVAR lv3,CE.UNARY_EXCON),env) - val (sma,se_a) = convert_alloc(alloc,env) - in - (LET{pat=[lv1], - bind=CCALL{name="__fresh_exname", - args=[], - rhos_for_result=[]}, - scope=LET{pat=[lv2], - bind=STRING (Excon.pr_excon excon), - scope=insert_se(LET{pat=[lv3], - bind=RECORD{elems=[VAR lv1,VAR lv2], - alloc=sma, - tag=BI.tag_exname false, - maybeuntag=false}, - scope=insert_se (ccTrip scope env' lab cur_rv)},se_a)}},NONE_SE) - end - | MulExp.RAISE tr => - let - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(RAISE ce,se),NONE_SE) - end - | MulExp.HANDLE(tr1,tr2) => (HANDLE (insert_se(ccTrip tr1 env lab cur_rv), - insert_se(ccTrip tr2 env lab cur_rv)),NONE_SE) - | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,selections,opt), precision} => - let - val (selections,opt) = - compile_sels_and_default selections opt (fn i => i) (fn tr => ccTrip tr env lab cur_rv) - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(SWITCH_I {switch=SWITCH(ce,selections,opt), precision=precision},se),NONE_SE) - end - | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,selections,opt), precision} => - let - val (selections,opt) = - compile_sels_and_default selections opt (fn i => i) (fn tr => ccTrip tr env lab cur_rv) - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(SWITCH_W {switch=SWITCH(ce,selections,opt), precision=precision},se),NONE_SE) - end - | MulExp.SWITCH_S(MulExp.SWITCH(tr,selections,opt)) => - let - val (selections,opt) = - compile_sels_and_default selections opt (fn m=>m) (fn tr => ccTrip tr env lab cur_rv) - val (ce,se) = ccTrip tr env lab cur_rv - - (* When tagging is enabled, integers in SWITCH_I are converted in - * CodeGenX86.sml - so in that case we must use an untagged representation - * of true, which is 1 (given that BI.ml_true is 3). *) - val True = IntInf.fromInt (if BI.ml_true = 3 then - if BI.tag_values() then 1 - else BI.ml_true - else die "True") - fun compile_seq_switch(ce,[],default) = default - | compile_seq_switch(ce,(s,ce')::rest,default) = - let - val lv_sw = fresh_lvar("sw") - val lv_s = fresh_lvar("str") - in - LET{pat=[lv_s], - bind=STRING s, - scope=LET{pat=[lv_sw], - bind=CCALL{name="equalStringML",args=[ce,VAR lv_s],rhos_for_result=[]}, - scope=SWITCH_I{switch=SWITCH(VAR lv_sw,[(True,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()}}} - end - in - (insert_se(compile_seq_switch(ce,selections,opt),se),NONE_SE) - end - - | MulExp.SWITCH_C(MulExp.SWITCH(tr,selections,opt)) => - let - fun tag con = - (case CE.lookupCon env con of - CE.ENUM i => - if BI.tag_values() orelse (* hack to treat booleans tagged *) - Con.eq(con,Con.con_TRUE) orelse Con.eq(con,Con.con_FALSE) then - (con,ENUM(2*i+1)) - else - (con,ENUM i) - | CE.UB_NULLARY i => (con,UNBOXED(4*i+3)) - | CE.UB_UNARY i => (con,UNBOXED i) - | CE.B_NULLARY i => (con,BOXED(Word32.toInt (BI.tag_con0(false,i)))) - | CE.B_UNARY i => (con,BOXED(Word32.toInt (BI.tag_con1(false,i))))) - - val (selections,opt) = - compile_sels_and_default selections opt tag - (fn tr => ccTrip tr env lab cur_rv) - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(SWITCH_C(SWITCH(ce,selections,opt)),se),NONE_SE) - end - | MulExp.SWITCH_E(MulExp.SWITCH(tr,selections,opt)) => - let - val (selections,opt) = - compile_sels_and_default selections opt - (fn m=>(lookup_excon env m,CE.lookupExconArity env m)) - (fn tr => ccTrip tr env lab cur_rv) - val (ce,se) = ccTrip tr env lab cur_rv - fun compile_seq_switch(ce,[],default) = default - | compile_seq_switch(ce,(((ce_e,se_e),arity),ce')::rest,default) = - let - val lv_sw = fresh_lvar("sw") - val lv_exn1 = fresh_lvar("exn1") - val lv_exn2 = fresh_lvar("exn2") - in - (case arity of - CE.NULLARY_EXCON => - LET{pat=[lv_exn1], - bind=insert_se(SELECT(0,ce_e),se_e), - scope=LET{pat=[lv_exn2], - bind=SELECT(0,VAR lv_exn1), - scope=LET{pat=[lv_sw], - bind=CCALL{name="__equal_int32ub", - args=[ce,VAR lv_exn2],rhos_for_result=[]}, - scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()}}}} - | UNARY_EXCON => - LET{pat=[lv_exn1], - bind=insert_se(SELECT(0,ce_e),se_e), - scope=LET{pat=[lv_sw], - bind=CCALL{name="__equal_int32ub", - args=[ce,VAR lv_exn1],rhos_for_result=[]}, - scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()}}}) - end - val lv_exn_arg1 = fresh_lvar("exn_arg1") - val lv_exn_arg2 = fresh_lvar("exn_arg2") - val ce_res = + val ces_and_ses = (* We remove the unboxed record. *) + case tr2 of + MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs + | _ => [ccTrip tr2 env lab cur_rv] + + val (ce_clos,ces_arg,ses,lab_f) = compile_letrec_app env lvar ces_and_ses + val (smas,ses_sma) = + let val smas_regvec_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) rhos_actuals + val (smas,ses_sma,_) = unify_sma_se smas_regvec_and_ses SEMap.empty + in (smas,ses_sma) + end + + val fresh_lvs = map (fn _ => fresh_lvar "sma") smas + fun maybe_insert_smas([],[],ce) = ce + | maybe_insert_smas(fresh_lvs,smas,ce) = + LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} + in + (insert_ses + (maybe_insert_smas + (fresh_lvs, map (pass_ptr_to_rho "FUNCALL" (fn () => Lvars.pr_lvar lvar)) smas, + insert_ses + (FUNCALL{opr=lab_f,args=ces_arg,reg_vec=NONE, + reg_args=map VAR fresh_lvs,clos=ce_clos}, + ses)), + ses_sma), + NONE_SE) + end + | MulExp.APP(SOME MulExp.FNJMP,_, tr1,tr2) => + let + val ces_and_ses = + case tr2 of + MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs + | _ => [ccTrip tr2 env lab cur_rv] + val (ce_opr,se_opr) = ccTrip tr1 env lab cur_rv + val (ces1,ses',_) = unify_ce_se ((ce_opr,se_opr)::ces_and_ses) SEMap.empty + val (ce_opr',ces') = split_in_hd_and_tl ces1 + in + (insert_ses(FNJMP{opr=ce_opr',args=ces',clos=SOME ce_opr'}, + ses'),NONE_SE) + end + | MulExp.APP(SOME MulExp.FNCALL,_, tr1, tr2) => + let + val ces_and_ses = + case tr2 of + MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => ccTrip tr env lab cur_rv) trs + | _ => [ccTrip tr2 env lab cur_rv] + val (ce_opr,se_opr) = ccTrip tr1 env lab cur_rv + val (ces1,ses',_) = unify_ce_se ((ce_opr,se_opr)::ces_and_ses) SEMap.empty + val (ce_opr',ces') = split_in_hd_and_tl ces1 + in + (insert_ses(FNCALL{opr=ce_opr',args=ces',clos=SOME ce_opr'}, + ses'),NONE_SE) + end + | MulExp.APP _ => die "application form not recognised" + + | MulExp.LETREGION{B,rhos=ref bound_regvars,body} => + let + (* Insert letregion nodes in the RegionFlowGraph. *) + val _ = + if region_profiling() then + RegionFlowGraphProfiling.add_nodes (bound_regvars,"LETREGION") + else () + + val env_with_kind = + (env plus_decl_with CE.declareRhoKind) + (map (fn (place,phsize) => (place,mult("l",phsize))) bound_regvars) + val env_body = + (env_with_kind plus_decl_with CE.declareRho) + (map (fn (place,_) => (place,CE.RVAR place)) bound_regvars) + in + (LETREGION{rhos=bound_regvars, + body=insert_se(ccTrip body env_body lab cur_rv)},NONE_SE) + end + | MulExp.LET{k_let,pat,bind,scope} => + let + val lvars = List.map #1 pat + val env_with_lvar = + (env plus_decl_with CE.declareLvar) + (map (fn lv => (lv,CE.LVAR lv)) lvars) + in + (LET{pat=lvars, + bind=insert_se(ccTrip bind env lab cur_rv), + scope=insert_se(ccTrip scope env_with_lvar lab cur_rv)},NONE_SE) + end + | MulExp.EXCEPTION(excon,true,typePlace,alloc,scope) => (* Nullary exception constructor *) + let + val lv1 = fresh_lvar "exn0-1" + val lv2 = fresh_lvar "exn0-2" + val lv3 = fresh_lvar "exn0-3" + val lv4 = fresh_lvar "exn0-4" + val env' = CE.declareExcon(excon,(CE.LVAR lv4,CE.NULLARY_EXCON),env) + val (sma,se_a) = convert_alloc(alloc,env) + in + (LET{pat=[lv1], + bind=CCALL{name="__fresh_exname", + args=[], + rhos_for_result=[]}, + scope=insert_se(LET{pat=[lv2], + bind=STRING (Excon.pr_excon excon), + scope=LET{pat=[lv3], + bind=RECORD{elems=[VAR lv1,VAR lv2], + alloc=sma, + tag=BI.tag_exname false, + maybeuntag=false}, + scope=LET{pat=[lv4], + bind=RECORD{elems=[VAR lv3], + alloc=sma, + tag=BI.tag_excon0 false, + maybeuntag=false}, + scope=insert_se (ccTrip scope env' lab cur_rv)}}}, + se_a)},NONE_SE) + end + | MulExp.EXCEPTION(excon,false,typePlace,alloc,scope) => (* Unary exception constructor *) + let + val lv1 = fresh_lvar "exn0-1" + val lv2 = fresh_lvar "exn0-2" + val lv3 = fresh_lvar "exn0-3" + val env' = CE.declareExcon(excon,(CE.LVAR lv3,CE.UNARY_EXCON),env) + val (sma,se_a) = convert_alloc(alloc,env) + in + (LET{pat=[lv1], + bind=CCALL{name="__fresh_exname", + args=[], + rhos_for_result=[]}, + scope=LET{pat=[lv2], + bind=STRING (Excon.pr_excon excon), + scope=insert_se(LET{pat=[lv3], + bind=RECORD{elems=[VAR lv1,VAR lv2], + alloc=sma, + tag=BI.tag_exname false, + maybeuntag=false}, + scope=insert_se (ccTrip scope env' lab cur_rv)},se_a)}},NONE_SE) + end + | MulExp.RAISE tr => + let + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(RAISE ce,se),NONE_SE) + end + | MulExp.HANDLE(tr1,tr2) => (HANDLE (insert_se(ccTrip tr1 env lab cur_rv), + insert_se(ccTrip tr2 env lab cur_rv)),NONE_SE) + | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,selections,opt), precision} => + let + val (selections,opt) = + compile_sels_and_default selections opt (fn i => i) (fn tr => ccTrip tr env lab cur_rv) + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(SWITCH_I {switch=SWITCH(ce,selections,opt), precision=precision},se),NONE_SE) + end + | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,selections,opt), precision} => + let + val (selections,opt) = + compile_sels_and_default selections opt (fn i => i) (fn tr => ccTrip tr env lab cur_rv) + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(SWITCH_W {switch=SWITCH(ce,selections,opt), precision=precision},se),NONE_SE) + end + | MulExp.SWITCH_S(MulExp.SWITCH(tr,selections,opt)) => + let + val (selections,opt) = + compile_sels_and_default selections opt (fn m=>m) (fn tr => ccTrip tr env lab cur_rv) + val (ce,se) = ccTrip tr env lab cur_rv + + (* When tagging is enabled, integers in SWITCH_I are converted in + * CodeGenX86.sml - so in that case we must use an untagged representation + * of true, which is 1 (given that BI.ml_true is 3). *) + val True = IntInf.fromInt (if BI.ml_true = 3 then + if BI.tag_values() then 1 + else BI.ml_true + else die "True") + fun compile_seq_switch(ce,[],default) = default + | compile_seq_switch(ce,(s,ce')::rest,default) = + let + val lv_sw = fresh_lvar("sw") + val lv_s = fresh_lvar("str") + in + LET{pat=[lv_s], + bind=STRING s, + scope=LET{pat=[lv_sw], + bind=CCALL{name="equalStringML",args=[ce,VAR lv_s],rhos_for_result=[]}, + scope=SWITCH_I{switch=SWITCH(VAR lv_sw,[(True,ce')], + compile_seq_switch(ce,rest,default)), + precision=BI.defaultIntPrecision()}}} + end + in + (insert_se(compile_seq_switch(ce,selections,opt),se),NONE_SE) + end + + | MulExp.SWITCH_C(MulExp.SWITCH(tr,selections,opt)) => + let + fun tag con = + (case CE.lookupCon env con of + CE.ENUM i => + if BI.tag_values() orelse (* hack to treat booleans tagged *) + Con.eq(con,Con.con_TRUE) orelse Con.eq(con,Con.con_FALSE) then + (con,ENUM(2*i+1)) + else + (con,ENUM i) + | CE.UB_NULLARY i => (con,UNBOXED(4*i+3)) + | CE.UB_UNARY i => (con,UNBOXED i) + | CE.B_NULLARY i => (con,BOXED(Word32.toInt (BI.tag_con0(false,i)))) + | CE.B_UNARY i => (con,BOXED(Word32.toInt (BI.tag_con1(false,i))))) + + val (selections,opt) = + compile_sels_and_default selections opt tag + (fn tr => ccTrip tr env lab cur_rv) + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(SWITCH_C(SWITCH(ce,selections,opt)),se),NONE_SE) + end + | MulExp.SWITCH_E(MulExp.SWITCH(tr,selections,opt)) => + let + val (selections,opt) = + compile_sels_and_default selections opt + (fn m=>(lookup_excon env m,CE.lookupExconArity env m)) + (fn tr => ccTrip tr env lab cur_rv) + val (ce,se) = ccTrip tr env lab cur_rv + fun compile_seq_switch(ce,[],default) = default + | compile_seq_switch(ce,(((ce_e,se_e),arity),ce')::rest,default) = + let + val lv_sw = fresh_lvar("sw") + val lv_exn1 = fresh_lvar("exn1") + val lv_exn2 = fresh_lvar("exn2") + in + (case arity of + CE.NULLARY_EXCON => + LET{pat=[lv_exn1], + bind=insert_se(SELECT(0,ce_e),se_e), + scope=LET{pat=[lv_exn2], + bind=SELECT(0,VAR lv_exn1), + scope=LET{pat=[lv_sw], + bind=CCALL{name="__equal_int32ub", + args=[ce,VAR lv_exn2],rhos_for_result=[]}, + scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], + compile_seq_switch(ce,rest,default)), + precision=BI.defaultIntPrecision()}}}} + | UNARY_EXCON => + LET{pat=[lv_exn1], + bind=insert_se(SELECT(0,ce_e),se_e), + scope=LET{pat=[lv_sw], + bind=CCALL{name="__equal_int32ub", + args=[ce,VAR lv_exn1],rhos_for_result=[]}, + scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], + compile_seq_switch(ce,rest,default)), + precision=BI.defaultIntPrecision()}}}) + end + val lv_exn_arg1 = fresh_lvar("exn_arg1") + val lv_exn_arg2 = fresh_lvar("exn_arg2") + val ce_res = insert_se(LET{pat=[lv_exn_arg1], - bind=SELECT(0,ce), - scope=LET{pat=[lv_exn_arg2], - bind=SELECT(0,VAR lv_exn_arg1), - scope=compile_seq_switch(VAR lv_exn_arg2,selections,opt)}},se) - in - (ce_res,NONE_SE) - end - | MulExp.CON0{con,il,aux_regions,alloc} => - let - val (sma,se_a) = convert_alloc(alloc,env) - - val smas_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) aux_regions - - val (smas,ses',_) = unify_sma_se ((sma,se_a)::smas_and_ses) SEMap.empty - val (sma',smas') = split_in_hd_and_tl smas - in - (insert_ses(CON0{con=con, - con_kind=lookup_con env con, - aux_regions=smas', - alloc=sma'},ses'),NONE_SE) - end - | MulExp.CON1({con,il,alloc},tr) => - let - val (sma,se_a) = convert_alloc(alloc,env) - val (ce_arg,se_arg) = ccTrip tr env lab cur_rv - val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],[(ce_arg,se_arg)]) - in - (insert_ses(CON1{con=con, - con_kind=lookup_con env con, - alloc=one_in_list(smas), - arg=one_in_list(ces)},ses),NONE_SE) - end - | MulExp.DECON({con,il},tr) => - let - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(DECON{con=con, - con_kind=lookup_con env con, - con_exp = ce},se),NONE_SE) - end - | MulExp.EXCON(excon,NONE) => lookup_excon env excon - | MulExp.EXCON(excon,SOME(alloc,tr)) => - let - val (ce_excon,se_excon) = lookup_excon env excon - val (ce_arg,se_arg) = ccTrip tr env lab cur_rv - val (sma,se_a) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses ([(sma,se_a)],[(ce_excon,se_excon),(ce_arg,se_arg)]) - in - (insert_ses(RECORD{elems=ces, - alloc=one_in_list(smas), - tag=BI.tag_excon1 false, - maybeuntag=false},ses),NONE_SE) - end - | MulExp.DEEXCON(excon,tr) => - let - val (ce_arg,se_arg) = ccTrip tr env lab cur_rv - in - (insert_se(SELECT(1,ce_arg),se_arg),NONE_SE) - end - | MulExp.RECORD(alloc, trs) => - let - val ces_and_ses = List.foldr (fn (tr,b) => ccTrip tr env lab cur_rv::b) [] trs - val (sma,se_a) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],ces_and_ses) - fun pair_or_triple_region rho = - case Effect.get_place_ty rho of - SOME Effect.PAIR_RT => - if length trs = 2 then true - else die "RECORD.wrong number of elements in pair region" - | SOME Effect.TRIPLE_RT => - if length trs = 3 then true - else die "RECORD.wrong number of elements in triple region" - | _ => false - val maybeuntag = - case alloc - of AtInf.ATTOP (rho,_) => pair_or_triple_region rho - | AtInf.ATBOT (rho,_) => pair_or_triple_region rho - | AtInf.SAT (rho,_) => pair_or_triple_region rho - | _ => false - in - (insert_ses(RECORD{elems=ces, - alloc=one_in_list(smas), - tag=BI.tag_record(false,length ces), - maybeuntag=maybeuntag},ses),NONE_SE) - end - | MulExp.BLOCKF64(alloc, trs) => - let - val ces_and_ses = List.foldr (fn (tr,b) => ccTrip tr env lab cur_rv::b) [] trs - val (sma,se_a) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],ces_and_ses) - in - (insert_ses(BLOCKF64{elems=ces, - alloc=one_in_list(smas), - tag=BI.tag_blockf64(false,length ces)},ses),NONE_SE) - end - | MulExp.SCRATCHMEM(n,alloc) => - let - val (sma,se_a) = convert_alloc(alloc,env) - val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],[]) - in - (insert_ses(SCRATCHMEM{bytes=n, - alloc=one_in_list(smas), - tag=BI.tag_blockf64(false,(8+n-1) div 8)},ses),NONE_SE) - end - | MulExp.SELECT(i,tr) => - let - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(SELECT(i,ce),se),NONE_SE) - end - | MulExp.REF(a,tr) => - let - val (ce,se) = ccTrip tr env lab cur_rv - val (sma,se_sma) = convert_alloc(a,env) - val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_sma)],[(ce,se)]) - in - (insert_ses(REF(one_in_list(smas),one_in_list(ces)),ses),NONE_SE) - end - | MulExp.DEREF tr => - let - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(DEREF ce,se),NONE_SE) - end - | MulExp.ASSIGN(alloc,tr1,tr2) => - let - val (sma,se_sma) = convert_alloc(alloc,env) - val (sma,ce1,ce2,ses) = - case unify_smas_ces_and_ses([(sma,se_sma)],[ccTrip tr1 env lab cur_rv,ccTrip tr2 env lab cur_rv]) of - ([sma],[ce1,ce2],ses) => (sma,ce1,ce2,ses) - | _ => die "ASSIGN: error in unify." - in - (insert_ses(ASSIGN(sma,ce1,ce2),ses),NONE_SE) - end - | MulExp.DROP tr => - let - val (ce,se) = ccTrip tr env lab cur_rv - in - (insert_se(DROP ce,se),NONE_SE) - end - | MulExp.EQUAL({mu_of_arg1,mu_of_arg2,alloc},tr1,tr2) => - let - val tau = - (case tr1 of - MulExp.TR(_,RegionExp.Mus[(tau,_)],_,_) => tau - | _ => die "EQUAL.metaType not Mus.") - - val (ce1,ce2,ses) = - (case unify_ce_se [ccTrip tr1 env lab cur_rv, - ccTrip tr2 env lab cur_rv] SEMap.empty of - ([ce1,ce2],ses,_) => (ce1,ce2,ses) - | _ => die "EQUAL: error in unify.") - - fun eq_prim n = CCALL{name=n,args=[ce1,ce2],rhos_for_result=[]} - - val ce = - (case RType.unCONSTYPE tau of - SOME(tn,_,_,_) => + bind=SELECT(0,ce), + scope=LET{pat=[lv_exn_arg2], + bind=SELECT(0,VAR lv_exn_arg1), + scope=compile_seq_switch(VAR lv_exn_arg2,selections,opt)}},se) + in + (ce_res,NONE_SE) + end + | MulExp.CON0{con,il,aux_regions,alloc=SOME alloc} => + let val (sma,se_a) = convert_alloc(alloc,env) + val smas_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) aux_regions + val (smas,ses',_) = unify_sma_se ((sma,se_a)::smas_and_ses) SEMap.empty + val (sma',smas') = split_in_hd_and_tl smas + in + (insert_ses(CON0{con=con, + con_kind=lookup_con env con, + aux_regions=smas', + alloc=sma'},ses'),NONE_SE) + end + | MulExp.CON0{con,il,aux_regions,alloc=NONE} => + let val smas_and_ses = List.map (fn alloc => convert_alloc(alloc,env)) aux_regions + val (smas,ses,_) = unify_sma_se smas_and_ses SEMap.empty + in + (insert_ses(CON0{con=con, + con_kind=lookup_con env con, + aux_regions=smas, + alloc=IGNORE},ses),NONE_SE) + end + | MulExp.CON1({con,il,alloc=SOME alloc},tr) => + let + val (sma,se_a) = convert_alloc(alloc,env) + val (ce_arg,se_arg) = ccTrip tr env lab cur_rv + val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],[(ce_arg,se_arg)]) + in + (insert_ses(CON1{con=con, + con_kind=lookup_con env con, + alloc=one_in_list smas, + arg=one_in_list ces},ses),NONE_SE) + end + | MulExp.CON1({con,il,alloc=NONE},tr) => + let + val (ce_arg,se_arg) = ccTrip tr env lab cur_rv + val (smas,ces,ses) = unify_smas_ces_and_ses([],[(ce_arg,se_arg)]) + in + (insert_ses(CON1{con=con, + con_kind=lookup_con env con, + alloc=IGNORE, + arg=one_in_list ces},ses),NONE_SE) + end + | MulExp.DECON({con,il},tr) => + let + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(DECON{con=con, + con_kind=lookup_con env con, + con_exp = ce},se),NONE_SE) + end + | MulExp.EXCON(excon,NONE) => lookup_excon env excon + | MulExp.EXCON(excon,SOME(alloc,tr)) => + let + val (ce_excon,se_excon) = lookup_excon env excon + val (ce_arg,se_arg) = ccTrip tr env lab cur_rv + val (sma,se_a) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses ([(sma,se_a)],[(ce_excon,se_excon),(ce_arg,se_arg)]) + in + (insert_ses(RECORD{elems=ces, + alloc=one_in_list(smas), + tag=BI.tag_excon1 false, + maybeuntag=false},ses),NONE_SE) + end + | MulExp.DEEXCON(excon,tr) => + let + val (ce_arg,se_arg) = ccTrip tr env lab cur_rv + in + (insert_se(SELECT(1,ce_arg),se_arg),NONE_SE) + end + | MulExp.RECORD(NONE, []) => + (insert_ses(RECORD{elems=[], + alloc=IGNORE, + tag=BI.tag_record(false,0), + maybeuntag=false},[]),NONE_SE) + | MulExp.RECORD(NONE, _) => die "RECORD: expecting allocation place" + | MulExp.RECORD(SOME alloc, trs) => + let + val ces_and_ses = List.foldr (fn (tr,b) => ccTrip tr env lab cur_rv::b) [] trs + val (sma,se_a) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],ces_and_ses) + fun pair_or_triple_region rho = + case Effect.get_place_ty rho of + SOME Effect.PAIR_RT => + if length trs = 2 then true + else die "RECORD.wrong number of elements in pair region" + | SOME Effect.TRIPLE_RT => + if length trs = 3 then true + else die "RECORD.wrong number of elements in triple region" + | _ => false + val maybeuntag = + case alloc of + AtInf.ATTOP (rho,_) => pair_or_triple_region rho + | AtInf.ATBOT (rho,_) => pair_or_triple_region rho + | AtInf.SAT (rho,_) => pair_or_triple_region rho + in + (insert_ses(RECORD{elems=ces, + alloc=one_in_list smas, + tag=BI.tag_record(false,length ces), + maybeuntag=maybeuntag},ses),NONE_SE) + end + | MulExp.BLOCKF64(alloc, trs) => + let + val ces_and_ses = List.foldr (fn (tr,b) => ccTrip tr env lab cur_rv::b) [] trs + val (sma,se_a) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],ces_and_ses) + in + (insert_ses(BLOCKF64{elems=ces, + alloc=one_in_list(smas), + tag=BI.tag_blockf64(false,length ces)},ses),NONE_SE) + end + | MulExp.SCRATCHMEM(n,alloc) => + let + val (sma,se_a) = convert_alloc(alloc,env) + val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_a)],[]) + in + (insert_ses(SCRATCHMEM{bytes=n, + alloc=one_in_list(smas), + tag=BI.tag_blockf64(false,(8+n-1) div 8)},ses),NONE_SE) + end + | MulExp.SELECT(i,tr) => + let + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(SELECT(i,ce),se),NONE_SE) + end + | MulExp.REF(a,tr) => + let + val (ce,se) = ccTrip tr env lab cur_rv + val (sma,se_sma) = convert_alloc(a,env) + val (smas,ces,ses) = unify_smas_ces_and_ses([(sma,se_sma)],[(ce,se)]) + in + (insert_ses(REF(one_in_list(smas),one_in_list(ces)),ses),NONE_SE) + end + | MulExp.DEREF tr => + let + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(DEREF ce,se),NONE_SE) + end + | MulExp.ASSIGN(tr1,tr2) => + let + val (ce1,ce2,ses) = + case unify_smas_ces_and_ses([],[ccTrip tr1 env lab cur_rv,ccTrip tr2 env lab cur_rv]) of + ([],[ce1,ce2],ses) => (ce1,ce2,ses) + | _ => die "ASSIGN: error in unify." + in + (insert_ses(ASSIGN(IGNORE,ce1,ce2),ses),NONE_SE) + end + | MulExp.DROP tr => + let + val (ce,se) = ccTrip tr env lab cur_rv + in + (insert_se(DROP ce,se),NONE_SE) + end + | MulExp.EQUAL({mu_of_arg1,mu_of_arg2},tr1,tr2) => + let + val tau = case tr1 of + MulExp.TR(_,RegionExp.Mus[mu],_,_) => #1(RType.unbox mu) + | _ => die "EQUAL.metaType not Mus." + + val (ce1,ce2,ses) = + case unify_ce_se [ccTrip tr1 env lab cur_rv, + ccTrip tr2 env lab cur_rv] SEMap.empty of + ([ce1,ce2],ses,_) => (ce1,ce2,ses) + | _ => die "EQUAL: error in unify." + fun eq_prim n = CCALL{name=n,args=[ce1,ce2],rhos_for_result=[]} + val ce = + case RType.unCONSTYPE tau of + SOME(tn,_,_,_) => if (TyName.eq(tn,TyName.tyName_BOOL) - orelse TyName.eq(tn,TyName.tyName_REF) - orelse TyName.eq(tn,TyName.tyName_ARRAY) - orelse TyName.eq(tn,TyName.tyName_CHARARRAY)) - then - eq_prim "__equal_int32ub" - else if TyName.eq(tn,TyName.tyName_INT31) then - eq_prim "__equal_int31" - else if TyName.eq(tn,TyName.tyName_INT32) then - (if BI.tag_values() then eq_prim "__equal_int32b" - else eq_prim "__equal_int32ub") - else if TyName.eq(tn,TyName.tyName_INT63) then - eq_prim "__equal_int63" - else if TyName.eq(tn,TyName.tyName_INT64) then - (if BI.tag_values() then eq_prim "__equal_int64b" - else eq_prim "__equal_int64ub") + orelse TyName.eq(tn,TyName.tyName_REF) + orelse TyName.eq(tn,TyName.tyName_ARRAY) + orelse TyName.eq(tn,TyName.tyName_CHARARRAY)) + then + eq_prim "__equal_int32ub" + else if TyName.eq(tn,TyName.tyName_INT31) then + eq_prim "__equal_int31" + else if TyName.eq(tn,TyName.tyName_INT32) then + (if BI.tag_values() then eq_prim "__equal_int32b" + else eq_prim "__equal_int32ub") + else if TyName.eq(tn,TyName.tyName_INT63) then + eq_prim "__equal_int63" + else if TyName.eq(tn,TyName.tyName_INT64) then + (if BI.tag_values() then eq_prim "__equal_int64b" + else eq_prim "__equal_int64ub") else if TyName.eq(tn,TyName.tyName_WORD31) then - eq_prim "__equal_word31" - else if TyName.eq(tn,TyName.tyName_WORD32) then - (if BI.tag_values() then eq_prim "__equal_word32b" - else eq_prim "__equal_word32ub") + eq_prim "__equal_word31" + else if TyName.eq(tn,TyName.tyName_WORD32) then + (if BI.tag_values() then eq_prim "__equal_word32b" + else eq_prim "__equal_word32ub") else if TyName.eq(tn,TyName.tyName_WORD63) then - eq_prim "__equal_word63" - else if TyName.eq(tn,TyName.tyName_WORD64) then - (if BI.tag_values() then eq_prim "__equal_word64b" - else eq_prim "__equal_word64ub") - else if TyName.eq(tn,TyName.tyName_STRING) then - eq_prim "equalStringML" - else if TyName.eq(tn,TyName.tyName_VECTOR) then - die "`=' on vectors! EliminateEq should have dealt with this" - else eq_prim "equalPolyML" + eq_prim "__equal_word63" + else if TyName.eq(tn,TyName.tyName_WORD64) then + (if BI.tag_values() then eq_prim "__equal_word64b" + else eq_prim "__equal_word64ub") + else if TyName.eq(tn,TyName.tyName_STRING) then + eq_prim "equalStringML" + else if TyName.eq(tn,TyName.tyName_VECTOR) then + die "`=' on vectors! EliminateEq should have dealt with this" + else eq_prim "equalPolyML" | NONE => case RType.unRECORD tau of - SOME [] => eq_prim "__equal_int32ub" - | _ => eq_prim "equalPolyML") - in - (insert_ses(ce,ses),NONE_SE) - end - | MulExp.CCALL({name = "id", mu_result, rhos_for_result}, trs) => - (case trs of - [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) - | _ => die "CCALL: ``id'' with more than one tr") - | MulExp.CCALL({name = "pointer", mu_result, rhos_for_result}, trs) => + SOME [] => eq_prim "__equal_int32ub" (* bool *) + | _ => eq_prim "equalPolyML" + in + (insert_ses(ce,ses),NONE_SE) + end + | MulExp.CCALL({name = "id", mu_result, rhos_for_result}, trs) => + (case trs of + [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) + | _ => die "CCALL: ``id'' with more than one tr") + | MulExp.CCALL({name = "pointer", mu_result, rhos_for_result}, trs) => (* unsafe cast; pointer : 'a -> foreignptr, in particular with 'a * instantiated to a function *) - (case trs of - [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) - | _ => die "CCALL: ``pointer'' with more than one tr") - | MulExp.CCALL({name = "ord", mu_result, rhos_for_result}, trs) => - (case trs of - [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) - | _ => die "CCALL: ``ord'' with more than one tr") - | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => - (* Regions in mu_result must be passed to the C-function for storing *) - (* the result of the call. Regions are passed in two ways, dependent *) - (* on whether the size of the allocation in the region can be *) - (* determined statically. Either, (1) a pointer to the region is *) - (* passed, or (2) a pointer to already allocated space is passed. *) - (* Regions occurring in mu_result paired with a string type or occur *) - (* in a type (tau list,rho) in mu_result, are passed by passing a *) - (* pointer to the region. For other regions we allocate space *) - (* statically and pass a pointer to the allocated space. Regions *) - (* passed as infinite also have to get the storage mode set for the *) - (* case that the C function calls resetRegion. See also the chapter *) - (* `Calling C Functions' in the documentation. *) - let - fun add_pp_for_profiling ([], args) = (name, args) - | add_pp_for_profiling ((sma,i_opt)::rest,args) = - if region_profiling() then - (case i_opt of - SOME 0 => die "get_pp_for_profiling (CCALL ...): argument region with size 0" - | SOME i => add_pp_for_profiling(rest,args) - | NONE => (name ^ "Prof", args @ [INTEGER {value=IntInf.fromInt(get_pp sma), - precision=BI.defaultIntPrecision()}])) - (*get any arbitrary pp (they are the same):*) - else (name, args) - - fun comp_region_args_sma [] = [] - | comp_region_args_sma ((sma, i_opt)::rest) = - case i_opt of - SOME 0 => die "ccExp (CCALL ...): argument region with size 0" - | SOME i => PASS_PTR_TO_MEM(sma,i) :: comp_region_args_sma rest - | NONE => pass_ptr_to_rho "CCALL" (fn () => name) sma :: comp_region_args_sma rest - val smas_and_ses = List.map (fn (alloc,_) => convert_alloc(alloc,env)) rhos_for_result - val i_opts = List.map #2 rhos_for_result - - val ces_and_ses = List.map (fn tr => ccTrip tr env lab cur_rv) trs - val (smas',ces,ses) = unify_smas_ces_and_ses(smas_and_ses,ces_and_ses) - val rhos_for_result' = zip(smas',i_opts) - val smas = comp_region_args_sma rhos_for_result' - val maybe_return_unit = - if BI.tag_values() then - (case RType.unRECORD(#1 mu_result) of - SOME [] => (fn ce => LET{pat=[fresh_lvar("ccall")],bind=ce, - scope=RECORD{elems=[], - alloc=IGNORE, - tag=BI.tag_ignore, - maybeuntag=false}}) - | _ => (fn ce => ce)) - else (fn ce => ce) - val fresh_lvs = map (fn _ => fresh_lvar "sma") smas - fun maybe_insert_smas([],[],ce) = ce - | maybe_insert_smas(fresh_lvs,smas,ce) = - LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} - in - (case explode name of + (case trs of + [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) + | _ => die "CCALL: ``pointer'' with more than one tr") + | MulExp.CCALL({name = "ord", mu_result, rhos_for_result}, trs) => + (case trs of + [tr] => (insert_se(ccTrip tr env lab cur_rv),NONE_SE) + | _ => die "CCALL: ``ord'' with more than one tr") + | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => + (* Regions in mu_result must be passed to the C-function for storing *) + (* the result of the call. Regions are passed in two ways, dependent *) + (* on whether the size of the allocation in the region can be *) + (* determined statically. Either, (1) a pointer to the region is *) + (* passed, or (2) a pointer to already allocated space is passed. *) + (* Regions occurring in mu_result paired with a string type or occur *) + (* in a type (tau list,rho) in mu_result, are passed by passing a *) + (* pointer to the region. For other regions we allocate space *) + (* statically and pass a pointer to the allocated space. Regions *) + (* passed as infinite also have to get the storage mode set for the *) + (* case that the C function calls resetRegion. See also the chapter *) + (* `Calling C Functions' in the documentation. *) + let + fun add_pp_for_profiling ([], args) = (name, args) + | add_pp_for_profiling ((sma,i_opt)::rest,args) = + if region_profiling() then + (case i_opt of + SOME 0 => die "get_pp_for_profiling (CCALL ...): argument region with size 0" + | SOME i => add_pp_for_profiling(rest,args) + | NONE => (name ^ "Prof", args @ [INTEGER {value=IntInf.fromInt(get_pp sma), + precision=BI.defaultIntPrecision()}])) + (*get any arbitrary pp (they are the same):*) + else (name, args) + + fun comp_region_args_sma [] = [] + | comp_region_args_sma ((sma, i_opt)::rest) = + case i_opt of + SOME 0 => die "ccExp (CCALL ...): argument region with size 0" + | SOME i => PASS_PTR_TO_MEM(sma,i) :: comp_region_args_sma rest + | NONE => pass_ptr_to_rho "CCALL" (fn () => name) sma :: comp_region_args_sma rest + val smas_and_ses = List.map (fn (alloc,_) => convert_alloc(alloc,env)) rhos_for_result + val i_opts = List.map #2 rhos_for_result + + val ces_and_ses = List.map (fn tr => ccTrip tr env lab cur_rv) trs + val (smas',ces,ses) = unify_smas_ces_and_ses(smas_and_ses,ces_and_ses) + val rhos_for_result' = zip(smas',i_opts) + val smas = comp_region_args_sma rhos_for_result' + val maybe_return_unit = + if BI.tag_values() then + (case RType.unRECORD(#1 (RType.unbox (mu_result))) of + SOME [] => (fn ce => LET{pat=[fresh_lvar("ccall")],bind=ce, + scope=RECORD{elems=[], + alloc=IGNORE, + tag=BI.tag_ignore, + maybeuntag=false}}) + | _ => (fn ce => ce)) + else (fn ce => ce) + val fresh_lvs = map (fn _ => fresh_lvar "sma") smas + fun maybe_insert_smas([],[],ce) = ce + | maybe_insert_smas(fresh_lvs,smas,ce) = + LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} + in + (case explode name of #"@" :: rest => (* AUTO CONVERSION *) - let val name = implode rest - fun ty_trs tr = - case tr - of MulExp.TR(_,RegionExp.Mus[(ty,_)],_,_) => ty - | _ => die "CCALL_AUTO.ty" - fun fty ty : foreign_type = - case RType.unCONSTYPE ty of - SOME(tn,_,_,_) => tn_to_foreign_type tn - | NONE => case RType.unRECORD ty of - SOME [] => Unit - | _ => die "CCALL_AUTO.fty" - val args = ListPair.zip(ces,map (fty o ty_trs) trs) - handle _ => die "CCALL_AUTO.zip" - val res = case fty (#1 mu_result) - of CharArray => die "CCALL_AUTO.CharArray not supported in result" - | t => t - in (insert_ses(CCALL_AUTO{name=name, args=args, res=res}, - ses), - NONE_SE) - end - | _ => + let val name = implode rest + fun mu_trs tr = + case tr of + MulExp.TR(_,RegionExp.Mus[mu],_,_) => mu + | _ => die "CCALL_AUTO.ty" + fun fmu mu : foreign_type = + let val (ty,_) = RType.unbox mu + in case RType.unCONSTYPE ty of + SOME(tn,_,_,_) => tn_to_foreign_type tn + | NONE => case RType.unRECORD ty of + SOME [] => Unit + | _ => die "CCALL_AUTO.fty" + end + val args = ListPair.zip(ces,map (fmu o mu_trs) trs) + handle _ => die "CCALL_AUTO.zip" + val res = case fmu mu_result + of CharArray => die "CCALL_AUTO.CharArray not supported in result" + | t => t + in (insert_ses(CCALL_AUTO{name=name, args=args, res=res}, + ses), + NONE_SE) + end + | _ => (* for overloaded primitives that may raise exceptions (e.g., div and mod), * we add the evaluation context as the first parameter to the function; we @@ -2330,7 +2330,7 @@ struct * backend requires that a context is made accessible during evaluation. *) - let fun cons_ctx ces = + let fun cons_ctx ces = let val lv_ctx = fresh_lvar "ctx" in ( fn e => LET{pat=[lv_ctx],bind=CCALL{name="__get_ctx",args=[],rhos_for_result=[]}, scope=e} @@ -2365,134 +2365,135 @@ struct | "__mod_int64b" => cons_ctx ces | _ => (fn x => x, ces) val (name, args) = add_pp_for_profiling(rhos_for_result',ces) - in (maybe_return_unit - (insert_ses(maybe_insert_smas(fresh_lvs,smas, - maybe_add_context + in (maybe_return_unit + (insert_ses(maybe_insert_smas(fresh_lvs,smas, + maybe_add_context (CCALL{name=name, - args=args, - rhos_for_result=map VAR fresh_lvs})), - ses)), - NONE_SE) - end) - end - | MulExp.EXPORT({name,mu_arg,mu_res},tr) => - let val (ce,se) = ccTrip tr env lab cur_rv - fun toForeignType (ty,_) : foreign_type = - case RType.unCONSTYPE ty of - SOME(tn,_,_,_) => tn_to_foreign_type tn - | NONE => case RType.unRECORD ty of - SOME [] => Unit - | _ => die "EXPORT.toForeignType" - val maybe_return_unit = - if BI.tag_values() andalso toForeignType mu_res = Unit then - (fn ce => LET{pat=[fresh_lvar("export")],bind=ce, - scope=RECORD{elems=[], - alloc=IGNORE, - tag=BI.tag_ignore, - maybeuntag=false}}) - else (fn ce => ce) - - val lab = Labels.new_named ("ExportClosLab_" ^ name) - val _ = add_new_export lab - in - (maybe_return_unit - (insert_se (EXPORT{name=name, - clos_lab=lab, - arg=(ce,toForeignType mu_arg, toForeignType mu_res)}, - se)) - , NONE_SE) - end - | MulExp.RESET_REGIONS({force,alloc,regions_for_resetting},tr) => - let - val regions_for_resetting = List.filter (fn alloc => - case alloc of - AtInf.IGNORE => false | _ => true) regions_for_resetting - val smas_and_se_smas = List.map (fn alloc => convert_alloc(alloc,env)) regions_for_resetting - val (smas,se_smas,_) = unify_sma_se smas_and_se_smas SEMap.empty - in - (insert_ses(RESET_REGIONS{force=force, - regions_for_resetting=smas},se_smas),NONE_SE) - end - | MulExp.FRAME{declared_lvars, declared_excons} => - let - val lvars = List.map #lvar declared_lvars - val lvars_and_labels' = - List.map (fn lvar => - (case CE.lookupVar env lvar of - CE.FIX(lab,SOME(CE.LVAR lv_clos),i,formals) => - let - val lab_sclos = fresh_lab(Lvars.pr_lvar lv_clos ^ "_lab") - in - (SOME{lvar=lv_clos,label=lab_sclos},{lvar=lvar,acc_type=CE.FIX(lab,SOME(CE.LABEL lab_sclos),i,formals)}) - end - | CE.FIX(lab,NONE,i,formals) => (NONE,{lvar=lvar,acc_type=CE.FIX(lab,NONE,i,formals)}) - | CE.LVAR lv => - let - val lab = fresh_lab(Lvars.pr_lvar lvar ^ "_lab") - in - (SOME{lvar=lvar,label=lab},{lvar=lvar,acc_type=CE.LABEL lab}) - end - | _ => die "FRAME: lvar not bound to either LVAR or FIX.")) lvars - val (lv_and_lab,frame_env_lv) = ListPair.unzip lvars_and_labels' - val lvars_and_labels = List.foldr (fn (lv_lab,acc) => - case lv_lab of - NONE => acc | SOME lv_lab => lv_lab::acc) [] lv_and_lab - val frame_env_lv = - (ClosConvEnv.empty plus_decl_with CE.declareLvar) - (map (fn {lvar,acc_type} => (lvar,acc_type)) frame_env_lv) - val excons = List.map #1 declared_excons - val excons_and_labels = List.map (fn excon => {excon=excon,label=fresh_lab(Excon.pr_excon excon ^ "_lab")}) excons - val frame_env = - (frame_env_lv plus_decl_with CE.declareExcon) - (map (fn {excon,label} => (excon,(CE.LABEL label, - CE.lookupExconArity env excon))) excons_and_labels) - val _ = set_frame_env frame_env - in - (List.foldr (fn ({excon,label},acc) => - let - val (ce,se) = lookup_excon env excon - in - LET{pat=[(*fresh_lvar("not_used")*)],bind=insert_se(STORE(ce,label),se),scope=acc} - end) - (List.foldr (fn ({lvar,label},acc) => LET{pat=[(*fresh_lvar("not_used")*)],bind=STORE(VAR lvar,label),scope=acc}) - (FRAME{declared_lvars=lvars_and_labels,declared_excons=excons_and_labels}) lvars_and_labels) - excons_and_labels, NONE_SE) - end) + args=args, + rhos_for_result=map VAR fresh_lvs})), + ses)), + NONE_SE) + end) + end + | MulExp.EXPORT({name,mu_arg,mu_res},tr) => + let val (ce,se) = ccTrip tr env lab cur_rv + fun toForeignType mu : foreign_type = + let val ty = case RType.unBOX mu of + SOME (ty,_) => ty + | NONE => mu + in case RType.unCONSTYPE ty of + SOME(tn,_,_,_) => tn_to_foreign_type tn + | NONE => case RType.unRECORD ty of + SOME [] => Unit + | _ => die "EXPORT.toForeignType" + end + val maybe_return_unit = + if BI.tag_values() andalso toForeignType mu_res = Unit then + (fn ce => LET{pat=[fresh_lvar("export")],bind=ce, + scope=RECORD{elems=[], + alloc=IGNORE, + tag=BI.tag_ignore, + maybeuntag=false}}) + else (fn ce => ce) + + val lab = Labels.new_named ("ExportClosLab_" ^ name) + val _ = add_new_export lab + in + (maybe_return_unit + (insert_se (EXPORT{name=name, + clos_lab=lab, + arg=(ce,toForeignType mu_arg, toForeignType mu_res)}, + se)) + , NONE_SE) + end + | MulExp.RESET_REGIONS({force,regions_for_resetting,...},tr) => + let + val smas_and_se_smas = List.map (fn alloc => convert_alloc(alloc,env)) regions_for_resetting + val (smas,se_smas,_) = unify_sma_se smas_and_se_smas SEMap.empty + in + (insert_ses(RESET_REGIONS{force=force, + regions_for_resetting=smas},se_smas),NONE_SE) + end + | MulExp.FRAME{declared_lvars, declared_excons} => + let + val lvars = List.map #lvar declared_lvars + val lvars_and_labels' = + List.map (fn lvar => + (case CE.lookupVar env lvar of + CE.FIX(lab,SOME(CE.LVAR lv_clos),i,formals) => + let + val lab_sclos = fresh_lab(Lvars.pr_lvar lv_clos ^ "_lab") + in + (SOME{lvar=lv_clos,label=lab_sclos},{lvar=lvar,acc_type=CE.FIX(lab,SOME(CE.LABEL lab_sclos),i,formals)}) + end + | CE.FIX(lab,NONE,i,formals) => (NONE,{lvar=lvar,acc_type=CE.FIX(lab,NONE,i,formals)}) + | CE.LVAR lv => + let + val lab = fresh_lab(Lvars.pr_lvar lvar ^ "_lab") + in + (SOME{lvar=lvar,label=lab},{lvar=lvar,acc_type=CE.LABEL lab}) + end + | _ => die "FRAME: lvar not bound to either LVAR or FIX.")) lvars + val (lv_and_lab,frame_env_lv) = ListPair.unzip lvars_and_labels' + val lvars_and_labels = List.foldr (fn (lv_lab,acc) => + case lv_lab of + NONE => acc | SOME lv_lab => lv_lab::acc) [] lv_and_lab + val frame_env_lv = + (ClosConvEnv.empty plus_decl_with CE.declareLvar) + (map (fn {lvar,acc_type} => (lvar,acc_type)) frame_env_lv) + val excons = List.map #1 declared_excons + val excons_and_labels = List.map (fn excon => {excon=excon,label=fresh_lab(Excon.pr_excon excon ^ "_lab")}) excons + val frame_env = + (frame_env_lv plus_decl_with CE.declareExcon) + (map (fn {excon,label} => (excon,(CE.LABEL label, + CE.lookupExconArity env excon))) excons_and_labels) + val _ = set_frame_env frame_env + in + (List.foldr (fn ({excon,label},acc) => + let + val (ce,se) = lookup_excon env excon + in + LET{pat=[(*fresh_lvar("not_used")*)],bind=insert_se(STORE(ce,label),se),scope=acc} + end) + (List.foldr (fn ({lvar,label},acc) => LET{pat=[(*fresh_lvar("not_used")*)],bind=STORE(VAR lvar,label),scope=acc}) + (FRAME{declared_lvars=lvars_and_labels,declared_excons=excons_and_labels}) lvars_and_labels) + excons_and_labels, NONE_SE) + end) in - ccExp e + ccExp e end (* End ccTrip *) in fun clos_conv(l2clos_exp_env, Fenv, - prog as MulExp.PGM{expression = tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi}) = + prog as MulExp.PGM{expression = tr, + export_datbinds, + import_vars, + export_vars, + export_basis, + export_Psi}) = let - val _ = reset_lvars() - val _ = reset_labs() - val _ = reset_top_decls() - val _ = reset_exports() - val import_labs = - find_globals_in_env (valOf(!import_vars)) l2clos_exp_env - handle _ => die "clos_conv: import_vars not specified." - val env_datbind = add_datbinds_to_env export_datbinds CE.empty - val global_env = CE.plus (l2clos_exp_env, env_datbind) - val _ = set_global_env global_env - val main_lab = fresh_lab "main" - val clos_exp = insert_se(ccTrip tr global_env main_lab NONE) - val _ = add_new_fn(main_lab,CallConv.mk_cc_fn([],NONE,[]),clos_exp) - val export_env = CE.plus (env_datbind, (get_frame_env())) - val export_labs = find_globals_in_env (export_vars) (get_frame_env()) - val export_labs = (#1 export_labs, #2 export_labs @ get_exports()) + val _ = reset_lvars() + val _ = reset_labs() + val _ = reset_top_decls() + val _ = reset_exports() + val import_labs = + find_globals_in_env (valOf(!import_vars)) l2clos_exp_env + handle _ => die "clos_conv: import_vars not specified." + val env_datbind = add_datbinds_to_env export_datbinds CE.empty + val global_env = CE.plus (l2clos_exp_env, env_datbind) + val _ = set_global_env global_env + val main_lab = fresh_lab "main" + val clos_exp = insert_se(ccTrip tr global_env main_lab NONE) + val _ = add_new_fn(main_lab,CallConv.mk_cc_fn([],NONE,[]),clos_exp) + val export_env = CE.plus (env_datbind, (get_frame_env())) + val export_labs = find_globals_in_env (export_vars) (get_frame_env()) + val export_labs = (#1 export_labs, #2 export_labs @ get_exports()) (* val _ = display("\nReport: export_env:", CE.layoutEnv export_env)*) in - {main_lab=main_lab, - code=get_top_decls(), - env=export_env, - imports=import_labs, - exports=export_labs} + {main_lab=main_lab, + code=get_top_decls(), + env=export_env, + imports=import_labs, + exports=export_labs} end (* End clos_conv *) end @@ -2510,27 +2511,27 @@ struct (* Perform Closure Conversion *) (******************************) fun cc(clos_env, - prog as MulExp.PGM{expression = tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi}) = + prog as MulExp.PGM{expression = tr, + export_datbinds, + import_vars, + export_vars, + export_basis, + export_Psi}) = let val _ = chat "[Closure Conversion..." val n_prog = N prog val _ = - if print_normalized_program_p() then - display("\nReport: AFTER NORMALIZATION:", PhysSizeInf.layout_pgm n_prog) - else - () + if print_normalized_program_p() then + display("\nReport: AFTER NORMALIZATION:", PhysSizeInf.layout_pgm n_prog) + else + () val Fenv = F n_prog val all = clos_conv (clos_env, Fenv, n_prog) val _ = - if print_clos_conv_program_p() then - display("\nReport: AFTER CLOSURE CONVERSION:", layout_clos_prg (#code(all))) - else - () + if print_clos_conv_program_p() then + display("\nReport: AFTER CLOSURE CONVERSION:", layout_clos_prg (#code(all))) + else + () val _ = chat "]\n" in all diff --git a/src/Compiler/CompBasis.sml b/src/Compiler/CompBasis.sml index 3502f6e83..3ae562d4c 100644 --- a/src/Compiler/CompBasis.sml +++ b/src/Compiler/CompBasis.sml @@ -184,7 +184,6 @@ structure CompBasis: COMP_BASIS = val mularefmap1 = Mul.restrict_mularefmap(mularefmap,effectvars) val drop_env1 = DropRegions.restrict(drop_env,lvars) val psi_env1 = PhysSizeInf.restrict(psi_env,lvars) - val places = DropRegions.drop_places places in ({NEnv=NEnv1, TCEnv=TCEnv1, EqEnv=EqEnv1, diff --git a/src/Compiler/Compile.sml b/src/Compiler/Compile.sml index 24a7b986c..014ffba2e 100644 --- a/src/Compiler/Compile.sml +++ b/src/Compiler/Compile.sml @@ -269,7 +269,7 @@ structure Compile: COMPILE = NONE (*SOME(ref[])*) (* reset occurrences *), NONE ), rse)) rse_con declared_lvars in - foldl (fn ((excon, SOME(Type, place)), rse) => SpreadExp.RegionStatEnv.declareExcon(excon,(Type,place),rse) + foldl (fn ((excon, SOME mu), rse) => SpreadExp.RegionStatEnv.declareExcon(excon,mu,rse) | _ => die "rse.excon") rse_temp declared_excons end handle _ => die "cannot form rse'") @@ -436,12 +436,11 @@ structure Compile: COMPILE = (* Warn against dangling pointers (when Garbage Collection is on) *) (* ---------------------------------------------------------------------- *) - fun warn_dangling_pointers(rse, psi_pgm) = + fun warn_dangling_pointers (rse, psi_pgm) = let (* warn against dangling references *) - fun get_place_at(AtInf.ATTOP(rho,pp)) = rho - | get_place_at(AtInf.ATBOT(rho,pp)) = rho - | get_place_at(AtInf.SAT(rho,pp)) = rho - | get_place_at(AtInf.IGNORE) = Effect.toplevel_region_withtype_top + fun get_place_at (AtInf.ATTOP(rho,pp)) = rho + | get_place_at (AtInf.ATBOT(rho,pp)) = rho + | get_place_at (AtInf.SAT(rho,pp)) = rho in chat "[Checking for dangling pointers..."; Timing.timing_begin(); @@ -487,7 +486,7 @@ structure Compile: COMPILE = fun compile fe (CEnv, Basis, strdecs) : res = let - val _ = RegionExp.printcount:=1; +(* val _ = RegionExp.printcount:=1; *) val {NEnv,TCEnv,EqEnv,OEnv,rse,mulenv, mularefmap=Psi,drop_env,psi_env} = CompBasis.de_CompBasis Basis val BtoLamb = CompBasisToLamb.mk_CompBasis{NEnv=NEnv,TCEnv=TCEnv,EqEnv=EqEnv,OEnv=OEnv} diff --git a/src/Compiler/Lambda/LambdaStatSem.sml b/src/Compiler/Lambda/LambdaStatSem.sml index 88a689091..472ebe87c 100644 --- a/src/Compiler/Lambda/LambdaStatSem.sml +++ b/src/Compiler/Lambda/LambdaStatSem.sml @@ -768,7 +768,7 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = | _ => die "LET.polymorphic let -- Polymorphism only allowed in FIX.") else (fn _ => ()) - fun check_type_scheme(tyvars, tau, tau') = + fun check_type_scheme (tyvars, tau, tau') = (eqType "LET" (tau,tau'); check_polymorphism tyvars; tyvars_not_in_env(tyvars, env)) diff --git a/src/Compiler/Regions/AT_INF.sml b/src/Compiler/Regions/AT_INF.sml index 8a9dc5b82..c50cdef26 100644 --- a/src/Compiler/Regions/AT_INF.sml +++ b/src/Compiler/Regions/AT_INF.sml @@ -7,20 +7,19 @@ signature AT_INF = and mul and qmularefset - datatype 'a at = ATTOP of 'a | ATBOT of 'a | SAT of 'a | IGNORE + datatype 'a at = ATTOP of 'a | ATBOT of 'a | SAT of 'a val sma : (place, place*mul, qmularefset ref)LambdaPgm -> (place at, place*mul, unit)LambdaPgm (* In the old storage mode analysis an environment was propagated to later - * program units. Since we must assign storage mode attop to regions passed - * to functions declared outside a program unit, the environment is of no - * use. 13/10/96-Martin - *) + * program units. Since we must assign storage mode attop to regions passed + * to functions declared outside a program unit, the environment is of no + * use. 13/10/96-Martin + *) type StringTree val layout_pgm : (place at, place*mul, unit)LambdaPgm -> StringTree val layout_exp_brief : (place at, place*mul, unit)LambdaExp -> StringTree val layout_pgm_brief : (place at, place*mul, unit)LambdaPgm -> StringTree - val layout_at : ('a -> StringTree) -> 'a at -> StringTree option + val layout_at : ('a -> StringTree) -> 'a at -> StringTree option end - diff --git a/src/Compiler/Regions/AtInf.sml b/src/Compiler/Regions/AtInf.sml index fe513c3c0..b675efd9a 100644 --- a/src/Compiler/Regions/AtInf.sml +++ b/src/Compiler/Regions/AtInf.sml @@ -24,7 +24,6 @@ structure AtInf: AT_INF = (* -----------------------------------------------------------------------*) val print_regions = Flags.is_on0 "print_regions" - val print_word_regions = Flags.is_on0 "print_word_regions" val print_effects = Flags.is_on0 "print_effects" val debug_which_at = Flags.add_bool_entry @@ -36,20 +35,20 @@ structure AtInf: AT_INF = {long="disable_atbot_analysis", short=NONE, menu=["Control","all storage modes attop (for POPL 96)"], item=ref false, neg=false, desc= "Disable storage mode analysis. That is, turn all\n\ - \allocation directives into attop."} + \allocation directives into attop."} (***********************) (* Storage modes *) (***********************) open MulExp - datatype 'a at = ATTOP of 'a | ATBOT of 'a | SAT of 'a | IGNORE + datatype 'a at = ATTOP of 'a | ATBOT of 'a | SAT of 'a (**************************) (* utilities *) (**************************) - fun footnote(x,y) = x + fun footnote (x,y) = x infix footnote fun die s = Crash.impossible ("AtInf." ^ s) @@ -57,62 +56,53 @@ structure AtInf: AT_INF = fun log s = TextIO.output (!Flags.log , s ^ "\n") fun device s = TextIO.output(!Flags.log, s) fun dump t = PP.outputTree(device, t, !Flags.colwidth) - fun warn report = Flags.warn report + fun warn report = Flags.warn report 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 = show_arreffs rhos fun forceATBOT (ATTOP p) = (ATBOT p) | forceATBOT (ATBOT p) = (ATBOT p) | forceATBOT (SAT p) = (ATBOT p) - | forceATBOT IGNORE = die "forceATBOT: I exptected storage\ - \ mode analysis to happen before dropping of regions." - fun debug0(rho, how_bound) = - if debug_which_at() then - log ("\nwhich_at: " ^ show_place rho ^ how_bound) - else () + fun debug0 (rho, how_bound) = + if debug_which_at() then + log ("\nwhich_at: " ^ show_place rho ^ how_bound) + else () fun show_live_vars liveset : string = PP.flatten1(LLV.layout_liveset liveset) - fun debug1(rho_related, liveset) = - if debug_which_at() then - (log ("locally live variables: " ^ show_live_vars liveset); - log (" = {" ^ show_places rho_related ^ "}")) - else () + fun debug1 (rho_related, liveset) = + if debug_which_at() then + (log ("locally live variables: " ^ show_live_vars liveset); + log (" = {" ^ show_places rho_related ^ "}")) + else () fun debug2 atbot_or_sat = - (if debug_which_at() then - log (case atbot_or_sat of - ATBOT _ => "ATBOT" - | SAT _ => "SAT" - | ATTOP _ => "ATTOP" - | IGNORE => "IGNORE") - else (); - (NONE, atbot_or_sat)) - + (if debug_which_at() then + log (case atbot_or_sat of + ATBOT _ => "ATBOT" + | SAT _ => "SAT" + | ATTOP _ => "ATTOP") + else (); + (NONE, atbot_or_sat)) (* error reporting for resetRegions: *) local - fun lay_pair(t1,p)= - let fun lay (t1,p) = PP.NODE{start="(",finish = ")", indent= 1, - childsep = PP.RIGHT",", children = - [t1,PP.LEAF (show_place p)]} - in if print_word_regions() then lay (t1,p) - else case Eff.get_place_ty p - of SOME Eff.WORD_RT => t1 - | _ => lay (t1,p) - end + fun lay_pair (t1,p) = + PP.NODE{start="(",finish = ")", indent= 1, + childsep = PP.RIGHT",", + children = [t1,PP.LEAF (show_place p)]} in - fun lay_sigma_p(sigma,p) = + fun lay_sigma_p (sigma,p:place option) = let val a = !Flags.print_types (* val b = print_regions() - val c = print_effects() + val c = print_effects() *) in Flags.print_types:= true; @@ -120,43 +110,36 @@ structure AtInf: AT_INF = Flags.print_regions:=true; Flags.print_effects := true; *) - lay_pair(RType.mk_lay_sigma false sigma, p) - footnote(Flags.print_types:= a (* ; + case p of + SOME p => + lay_pair(RType.mk_lay_sigma false sigma, p) + footnote(Flags.print_types:= a (* ; Flags.print_regions:= b; Flags.print_effects := c *)) + | NONE => RType.mk_lay_sigma false sigma end end - fun lay_header(force,lvar,(tau,p)) = + fun lay_header (force,lvar,(tau,p:place option)) = if force - then - PP.NODE{start= "", finish = "", indent = 0, childsep = PP.NOSEP, - children = [PP.LEAF "You have requested resetting the regions that appear free ", - PP.LEAF ("in the type scheme with place of '" ^ Lvars.pr_lvar lvar ^ "', i.e., in"), - lay_sigma_p(RType.type_to_scheme tau,p), - PP.LEAF "I have done as you requested, but I cannot guarantee that it is safe.", - PP.LEAF "Here are my objections (one for each region variable concerned):"]} - - else - PP.NODE{start= "", finish = "", indent = 0, childsep = PP.NOSEP, - children = [PP.LEAF "You have suggested resetting the regions that appear free ", - PP.LEAF ("in the type scheme with place of '" ^ Lvars.pr_lvar lvar ^ "', i.e., in"), - lay_sigma_p(RType.type_to_scheme tau,p)]} - + then PP.NODE{start= "", finish = "", indent = 0, childsep = PP.NOSEP, + children = [PP.LEAF "You have requested resetting the regions that appear free ", + PP.LEAF ("in the type scheme with place of '" ^ Lvars.pr_lvar lvar ^ "', i.e., in"), + lay_sigma_p(RType.type_to_scheme tau,p), + PP.LEAF "I have done as you requested, but I cannot guarantee that it is safe.", + PP.LEAF "Here are my objections (one for each region variable concerned):"]} + + else PP.NODE{start= "", finish = "", indent = 0, childsep = PP.NOSEP, + children = [PP.LEAF "You have suggested resetting the regions that appear free ", + PP.LEAF ("in the type scheme with place of '" ^ Lvars.pr_lvar lvar ^ "', i.e., in"), + lay_sigma_p(RType.type_to_scheme tau,p)]} fun lay_set (rhos: place list) = - let val rhos = if print_word_regions() then rhos - else List.filter (fn rho => case Eff.get_place_ty rho - of SOME Eff.WORD_RT => false - | _ => true) rhos - in PP.HNODE{start ="{", finish = "}", childsep = PP.RIGHT",", - children = map Eff.layout_effect rhos} - end + PP.HNODE{start ="{", finish = "}", childsep = PP.RIGHT",", + children = map Eff.layout_effect rhos} fun indent (t:StringTree) = - PP.NODE{start =" ",finish = "", indent = 5, childsep = PP.NOSEP, children = [t]} - - + PP.NODE{start =" ",finish = "", indent = 5, childsep = PP.NOSEP, children = [t]} (*****************************) (* Storage Mode Environments *) @@ -177,16 +160,16 @@ structure AtInf: AT_INF = | NONE => raise RegvarEnv end - type lvar_env_range = (sigma*place) * place list + type lvar_env_range = (sigma*place option) * place list abstype lvar_env = LVAR_ENV of lvar_env_range BT.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)) - fun retrieve_lvar_env(x,LVAR_ENV m) = + fun declare_lvar_env (x,y,LVAR_ENV m) = LVAR_ENV(BT.add(Lvars.key x,y,m)) + fun retrieve_lvar_env (x,LVAR_ENV m) = case BT.lookup m x of - SOME x => x + SOME x => x | NONE => raise LvarEnv end @@ -196,31 +179,27 @@ structure AtInf: AT_INF = with exception ExconEnv val empty_excon_env = EXCON_ENV [] - fun declare_excon_env(x,y,EXCON_ENV m) = EXCON_ENV((x,y)::m) - fun retrieve_excon_env(x,EXCON_ENV m) = + fun declare_excon_env (x,y,EXCON_ENV m) = EXCON_ENV((x,y)::m) + fun retrieve_excon_env (x,EXCON_ENV m) = case List.find (fn x' => Excon.eq(x, #1 x')) m of SOME (_,res) => res | NONE => raise ExconEnv end - type storage_mode_env = regvar_env * lvar_env * excon_env val empty_sme = (empty_regvar_env,empty_lvar_env,empty_excon_env) - end; (* SME *) + end (* SME *) (******************) (* more utilities *) (******************) - fun count_inner_conflicting_lvar() = () - fun count_inner_conflicting_excon() = () - exception AbortExpression datatype conflict = - LVAR_PROBLEM of place * lvar *SME.lvar_env_range * place (* the witness *) + LVAR_PROBLEM of place * lvar * SME.lvar_env_range * place (* the witness *) | GLOBAL_LVAR_PROBLEM of place * lvar * place list * place (* the witness *) | EXCON_PROBLEM of place * excon * SME.excon_env_range * place | GLOBAL_EXCON_PROBLEM of place * excon * place list * place (* the witness *) @@ -229,7 +208,6 @@ structure AtInf: AT_INF = | FORMAL_REGION_PARAM of place (* used with forceResetting, when SAT is changed to ATBOT *) val global_regions = [Eff.toplevel_region_withtype_top, - Eff.toplevel_region_withtype_word, Eff.toplevel_region_withtype_bot , Eff.toplevel_region_withtype_string , Eff.toplevel_region_withtype_pair , @@ -239,36 +217,36 @@ structure AtInf: AT_INF = Eff.toplevel_arreff] - fun lines (l: string list) = PP.NODE{start="",finish="", indent=0,childsep=PP.NOSEP, children = map PP.LEAF l} + fun lines (l: string list) = + PP.NODE{start="",finish="", indent=0,childsep=PP.NOSEP, children = map PP.LEAF l} fun item (item_number:int) (t:StringTree) = - let val s = "(" ^ Int.toString item_number ^ ")" - in - PP.NODE{start = s, finish = "", - indent = Int.max (size s+1, 5), - childsep = PP.NOSEP, children = [t]} - end - - fun layout_message(rho,kind:string,var:string,sigma_p,reachable,witness,item_number:int,force:bool) = - item item_number - (PP.NODE{start="",finish ="", indent=0,childsep= PP.NOSEP,children=[ - PP.LEAF " ", (* to provoke linebreak *) - if force then - PP.LEAF ("I cannot reset '" ^ show_place rho ^ "', because of conflict with the locally") - else PP.LEAF ("'" ^ show_place rho ^ "': there is a conflict with the locally"), - PP.LEAF ("live " ^ kind), - PP.NODE{start = var ^ " :", finish = "", indent = 5, childsep= PP.NOSEP, children = [ - lay_sigma_p sigma_p]}, - PP.LEAF ("from which the following region variables can be reached "), - PP.LEAF ("in the region flow graph:" ), - indent (lay_set reachable), - PP.LEAF ("Amongst these, '" ^ show_place witness ^ "' can also be reached from '" ^ show_place rho^ "'."), - if force then - PP.LEAF ("This suggests that you may be destroying data in '" ^ show_place witness ^ "'.") - else PP.LEAF ("Thus I have given '" ^ show_place rho ^ "' storage mode \"attop\".")]}) + let val s = "(" ^ Int.toString item_number ^ ")" + in PP.NODE{start = s, finish = "", + indent = Int.max (size s+1, 5), + childsep = PP.NOSEP, children = [t]} + end - fun layout_global_message(rho,kind:string,var:string,reachable,witness,item_number:int,force) = - item item_number + fun layout_message (rho,kind:string,var:string,sigma_p:sigma*place option,reachable,witness,item_number:int,force:bool) = + item item_number + (PP.NODE{start="",finish ="", indent=0,childsep= PP.NOSEP,children=[ + PP.LEAF " ", (* to provoke linebreak *) + if force then + PP.LEAF ("I cannot reset '" ^ show_place rho ^ "', because of conflict with the locally") + else PP.LEAF ("'" ^ show_place rho ^ "': there is a conflict with the locally"), + PP.LEAF ("live " ^ kind), + PP.NODE{start = var ^ " :", finish = "", indent = 5, childsep= PP.NOSEP, + children = [lay_sigma_p sigma_p]}, + PP.LEAF ("from which the following region variables can be reached "), + PP.LEAF ("in the region flow graph:" ), + indent (lay_set reachable), + PP.LEAF ("Amongst these, '" ^ show_place witness ^ "' can also be reached from '" ^ show_place rho^ "'."), + if force then + PP.LEAF ("This suggests that you may be destroying data in '" ^ show_place witness ^ "'.") + else PP.LEAF ("Thus I have given '" ^ show_place rho ^ "' storage mode \"attop\".")]}) + + fun layout_global_message (rho,kind:string,var:string,reachable,witness,item_number:int,force) = + item item_number (PP.NODE{start="",finish ="", indent=0,childsep= PP.NOSEP,children=[ PP.LEAF " ", (* to provoke linebreak *) if force then @@ -285,102 +263,101 @@ structure AtInf: AT_INF = PP.LEAF ("Thus I have given '" ^ show_place rho ^ "' storage mode \"attop\".")]}) fun layout_conflict (item_number:int, force: bool, c: conflict) = - case c of - LVAR_PROBLEM(rho,lvar,(sigma_p,reachable),witness) => - layout_message(rho,"variable", Lvars.pr_lvar lvar,sigma_p,reachable,witness,item_number,force) - | GLOBAL_LVAR_PROBLEM(rho,lvar,reachable,witness) => - layout_global_message(rho,"variable", Lvars.pr_lvar lvar,reachable,witness,item_number,force) - | EXCON_PROBLEM(rho,excon,(sigma_p,reachable), witness) => - layout_message(rho,"exception constructor", Excon.pr_excon excon,sigma_p,reachable,witness,item_number,force) - | GLOBAL_EXCON_PROBLEM(rho,excon,reachable,witness) => - layout_global_message(rho,"exception constructor", Excon.pr_excon excon,reachable,witness,item_number,force) - | NON_LOCAL rho => item item_number - (if force then - PP.LEAF ("'" ^ show_place rho ^ "': this region variable is bound\ + case c of + LVAR_PROBLEM(rho,lvar,(sigma_p,reachable),witness) => + layout_message(rho,"variable", Lvars.pr_lvar lvar,sigma_p,reachable,witness,item_number,force) + | GLOBAL_LVAR_PROBLEM(rho,lvar,reachable,witness) => + layout_global_message(rho,"variable", Lvars.pr_lvar lvar,reachable,witness,item_number,force) + | EXCON_PROBLEM(rho,excon,((sigma,p),reachable), witness) => + layout_message(rho,"exception constructor", Excon.pr_excon excon,(sigma,SOME p),reachable,witness,item_number,force) + | GLOBAL_EXCON_PROBLEM(rho,excon,reachable,witness) => + layout_global_message(rho,"exception constructor", Excon.pr_excon excon,reachable,witness,item_number,force) + | NON_LOCAL rho => item item_number + (if force then + PP.LEAF ("'" ^ show_place rho ^ "': this region variable is bound\ \ outside the present function") - else - lines[("I cannot reset '" ^ show_place rho ^ "', for it "), - ("is bound outside the present function.")] - ) - | ALL_ATTOP rho => item item_number - (if force then - lines[("'" ^ show_place rho ^ "': the flag \"Storage Mode Analysis/all modes attop\""), - (" is enabled.")] - else - lines[("I cannot reset '" ^ show_place rho ^ "', for the flag "), - ("\"Storage Mode Analysis/all modes attop\" is enabled.")] - ) - | FORMAL_REGION_PARAM(rho) => - (* here force is true *) - item item_number - (lines[("'" ^ show_place rho ^ "' is a formal parameter of a region-polymorphic "), - ("function (which is or may in future program units be "), - ("applied to regions containing live values).")]) + else + lines[("I cannot reset '" ^ show_place rho ^ "', for it "), + ("is bound outside the present function.")] + ) + | ALL_ATTOP rho => item item_number + (if force then + lines[("'" ^ show_place rho ^ "': the flag \"Storage Mode Analysis/all modes attop\""), + (" is enabled.")] + else + lines[("I cannot reset '" ^ show_place rho ^ "', for the flag "), + ("\"Storage Mode Analysis/all modes attop\" is enabled.")] + ) + | FORMAL_REGION_PARAM rho => + (* here force is true *) + item item_number + (lines[("'" ^ show_place rho ^ "' is a formal parameter of a region-polymorphic "), + ("function (which is or may in future program units be "), + ("applied to regions containing live values).")]) fun lay_conflicts (force:bool,l : conflict list) = - let fun loop(item_number:int, l: conflict list) = - case l of [] => [] - | (c::rest) => (layout_conflict(item_number, force, c):: - loop(item_number+1,rest)) - in loop(1,l) - end - - fun lay_report(force:bool, lvar, mu, conflicts) : StringTree = - PP.NODE{start = if force then ("forceResetting(" ^ Lvars.pr_lvar lvar ^ "): ") - else ("resetRegions(" ^ Lvars.pr_lvar lvar ^ "): "), - finish = "", indent = 3, childsep = PP.NOSEP,children = - lay_header(force,lvar,mu) :: lay_conflicts(force,conflicts)} + let fun loop(item_number:int, l: conflict list) = + case l of [] => [] + | (c::rest) => (layout_conflict(item_number, force, c):: + loop(item_number+1,rest)) + in loop(1,l) + end + + fun lay_report (force:bool, lvar, mu, conflicts) : StringTree = + let val tau_p = + case RType.unBOX mu of + SOME (tau,p) => (tau,SOME p) + | NONE => (mu,NONE) + in PP.NODE{start = if force then ("forceResetting(" ^ Lvars.pr_lvar lvar ^ "): ") + else ("resetRegions(" ^ Lvars.pr_lvar lvar ^ "): "), + finish = "", indent = 3, childsep = PP.NOSEP, + children = lay_header(force,lvar,tau_p) :: lay_conflicts(force,conflicts)} + end fun any_live (rho,sme as (_,LE,EE), liveset, rho_points_into, atbot_or_sat): conflict option * place at= 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) - in - case rho_points_into(lrv) of - SOME (witness: place) => SOME(LVAR_PROBLEM(rho,lvar,lvar_res,witness)) - | NONE => NONE - end handle SME.LvarEnv => + fun conflicting_local_lvar lvar : conflict option = + let val lvar_res as (_,lrv) = SME.retrieve_lvar_env(Lvars.key lvar, LE) + in case rho_points_into lrv of + SOME (witness: place) => SOME(LVAR_PROBLEM(rho,lvar,lvar_res,witness)) + | NONE => NONE + end handle SME.LvarEnv => (* lvar from previous program module. The follwing code assumes that the only region variables that can occur free in the type of an lvar from a previous module are global regions declared in Effect!!! *) - (case rho_points_into(global_regions) of - SOME (witness: place) => SOME(GLOBAL_LVAR_PROBLEM(rho,lvar,global_regions,witness)) - | NONE => NONE) - - 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 - SOME (witness: place) => SOME(EXCON_PROBLEM(rho,excon,excon_res,witness)) - | _ => NONE - end handle SME.ExconEnv => + (case rho_points_into global_regions of + SOME (witness: place) => SOME(GLOBAL_LVAR_PROBLEM(rho,lvar,global_regions,witness)) + | NONE => NONE) + + 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 + SOME (witness: place) => SOME(EXCON_PROBLEM(rho,excon,excon_res,witness)) + | _ => NONE + end handle SME.ExconEnv => (* excon from previous program module. The following code assumes that the only region variables that can occur free in the type of an lvar or excon from a previous module are global regions declared in Effect!!! *) - (case rho_points_into(global_regions) of - SOME (witness: place) => SOME(GLOBAL_EXCON_PROBLEM(rho,excon,global_regions,witness)) - | NONE => NONE) + (case rho_points_into global_regions of + SOME (witness: place) => SOME(GLOBAL_EXCON_PROBLEM(rho,excon,global_regions,witness)) + | NONE => NONE) in - case LLV.findLvar conflicting_local_lvar liveset of - SOME(lvar,conflict) => (SOME conflict, ATTOP rho) - | _ => (case LLV.findExcon conflicting_local_excon liveset of - SOME(excon, conflict) => (SOME conflict,ATTOP rho) - | _ => (NONE, atbot_or_sat) - ) - (*footnote Profile.profileOff()*) + case LLV.findLvar conflicting_local_lvar liveset of + SOME(lvar,conflict) => (SOME conflict, ATTOP rho) + | _ => case LLV.findExcon conflicting_local_excon liveset of + SOME(excon, conflict) => (SOME conflict,ATTOP rho) + | _ => (NONE, atbot_or_sat) end handle _ => die "any_live failed" 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 - in - debug1([],liveset); - any_live(rho,sme,liveset, rho_points_into, ATBOT rho) + 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 fun is_visited rho = !(Eff.get_visited rho) @@ -388,145 +365,127 @@ structure AtInf: AT_INF = fun unvisit rho = Eff.get_visited rho := false; 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 _ = Profile.profileOff();*) - fun rho_points_into lrv = List.find is_visited lrv - in - debug1(rho_related,liveset); - List.app visit rho_related; - any_live(rho,sme,liveset,rho_points_into, SAT rho) - footnote List.app unvisit rho_related + let (*val _ = Profile.profileOn();*) + 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); + List.app visit rho_related; + any_live(rho,sme,liveset,rho_points_into, SAT rho) + footnote List.app unvisit rho_related end fun show_place_at (ATTOP p) = "attop " ^ show_place p | show_place_at (ATBOT p) = "atbot " ^ show_place p | show_place_at (SAT p) = "sat " ^ show_place p - | show_place_at IGNORE = "(ignore)" fun which_at0 explain (sme as (RE,LE,EE),rho,liveset) : conflict option * place at = (* Invariant: all rhos have their visited field false *) - case Eff.get_place_ty rho of - SOME Eff.WORD_RT => (NONE, ATTOP rho) - | _ => (if disable_atbot_analysis() then - (SOME(ALL_ATTOP rho), ATTOP rho) + (SOME(ALL_ATTOP rho), ATTOP rho) else - (case SME.retrieve_regvar_env(rho,RE) of - SME.LETREGION_BOUND => (* SMA rules 25 and 26 *) - (debug0 (rho,"(letregion-bound)");letregion_bound(rho,sme,liveset)) - | SME.LETREC_BOUND => (* SMA rules 27 and 28 *) - (debug0(rho, "(letrec-bound)"); letrec_bound(rho,sme,liveset)) - ) - handle SME.RegvarEnv => (* SMA rule 29 *) - (debug0(rho, "(non-locally bound)");(SOME (NON_LOCAL rho), ATTOP rho)) + (case SME.retrieve_regvar_env(rho,RE) of + SME.LETREGION_BOUND => (* SMA rules 25 and 26 *) + (debug0 (rho,"(letregion-bound)"); + letregion_bound(rho,sme,liveset)) + | SME.LETREC_BOUND => (* SMA rules 27 and 28 *) + (debug0(rho, "(letrec-bound)"); + letrec_bound(rho,sme,liveset)) + ) + handle SME.RegvarEnv => (* SMA rule 29 *) + (debug0(rho, "(non-locally bound)");(SOME (NON_LOCAL rho), ATTOP rho)) ) fun which_at env (rho,liveset) : place at = - #2(which_at0 false (env,rho,liveset)) + #2(which_at0 false (env,rho,liveset)) - fun which_at_with_explanation(env,rho,liveset) - : conflict option * place at = which_at0 true (env,rho,liveset) + fun which_at_with_explanation (env,rho,liveset) : conflict option * place at = + which_at0 true (env,rho,liveset) fun analyse_rhos_for_resetting (sme, liveset, rhos) : place at list * conflict list= - let - fun loop([]:place list, acc1: place at list, acc2: conflict list) = (acc1,acc2) - | loop(rho::rest, acc1,acc2)= - case which_at_with_explanation(sme,rho,liveset) of - (NONE, place_at) => loop(rest,place_at::acc1, acc2) - | (SOME problem, place_at) => loop(rest,place_at::acc1, problem::acc2) - in - loop(rhos,[],[]) + let fun loop ([]:place list, acc1: place at list, acc2: conflict list) = (acc1,acc2) + | loop (rho::rest, acc1,acc2)= + case which_at_with_explanation(sme,rho,liveset) of + (NONE, place_at) => loop(rest,place_at::acc1, acc2) + | (SOME problem, place_at) => loop(rest,place_at::acc1, problem::acc2) + in loop(rhos,[],[]) end (* rvars(sigma, p0) = ((sigma, p0), lrv) where lrv is the set of all region and effect variables reachable from p or a free region or effect variables of sigma. *) - fun rvars (sigma, p0): SME.lvar_env_range = - ((*Profile.profileOn();*) - let val free_vars = RType.ferv_sigma sigma - val free_vars' = p0 :: free_vars - val lrv = RegFlow.reachable_with_insertion free_vars' - handle Find => Crash.impossible "AtInference: rvars " - in - (*Profile.profileOff();*) - ((sigma, p0),lrv) - end) - - fun mu_to_scheme_and_place(mu) = - let val (tau,p) = mu - val sigma = RType.type_to_scheme tau - in - (sigma,p) + fun rvars (sigma, p0:place option) : SME.lvar_env_range = + let val free_vars = RType.ferv_sigma sigma + val free_vars' = case p0 of SOME p => p :: free_vars + | NONE => free_vars + val lrv = RegFlow.reachable_with_insertion free_vars' + handle Find => Crash.impossible "AtInference: rvars " + in ((sigma, p0),lrv) end + fun mu_to_scheme_and_place (tau:RType.Type, rho_opt : place option) : sigma * place option = + (RType.type_to_scheme tau, rho_opt) + (********************************) (* 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)) = - let val tr' = sma_trip sme tr - val choices' = map (fn (a,tr) => (a,sma_trip sme tr)) choices - val opt' = case opt of SOME tr => SOME (sma_trip sme tr) | NONE => NONE - in SWITCH(tr',choices',opt') - end - 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, - fix_bound=fix_bound,rhos_actuals=ref actuals',other=()} - end - | INTEGER(n, t, alloc as (place,liveset)) => - if RType.unboxed t then INTEGER(n, t, ATTOP place) (* no need for analysis *) - else INTEGER(n, t, which_at sme alloc) - | WORD(w, t, alloc as (place,liveset)) => - if RType.unboxed t then WORD(w, t, ATTOP place) (* no need for analysis *) - else WORD(w, t, which_at sme alloc) - | STRING(s,alloc) => STRING(s, which_at sme alloc) - | REAL(s,alloc) => REAL(s, which_at sme alloc) - | F64(s,alloc as (place,_)) => F64(s, ATTOP place) - | UB_RECORD trips => UB_RECORD(map (sma_trip sme) trips) - | FN{pat,body,free,alloc} => sma_fn(sme,SME.empty_regvar_env,pat,body,free,alloc) - | LETREGION{B,rhos,body} => - let - val (RE,LE,EE) = sme - fun extend ((rho,mul), RE') = SME.declare_regvar_env(rho,SME.LETREGION_BOUND,RE') - val sme_body = (foldl extend RE (!rhos), LE, EE) - in - LETREGION{B=B,rhos=rhos,body=sma_trip sme_body body} + let fun sma_sw sme (SWITCH(tr,choices,opt)) = + let val tr' = sma_trip sme tr + val choices' = map (fn (a,tr) => (a,sma_trip sme tr)) choices + val opt' = case opt of SOME tr => SOME (sma_trip sme tr) | NONE => NONE + in SWITCH(tr',choices',opt') + end + 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, + fix_bound=fix_bound,rhos_actuals=ref actuals',other=()} + end + | INTEGER(n, t, alloc) => INTEGER(n, t, Option.map (which_at sme) alloc) + | WORD(w, t, alloc) => WORD(w, t, Option.map (which_at sme) alloc) + | STRING(s,alloc) => STRING(s, which_at sme alloc) + | REAL(s,alloc) => REAL(s, which_at sme alloc) + | F64 s => F64 s + | UB_RECORD trips => UB_RECORD(map (sma_trip sme) trips) + | FN{pat,body,free,alloc} => sma_fn(sme,SME.empty_regvar_env,pat,body,free,alloc) + | LETREGION{B,rhos,body} => + let val (RE,LE,EE) = sme + fun extend ((rho,mul), RE') = SME.declare_regvar_env(rho,SME.LETREGION_BOUND,RE') + val sme_body = (foldl extend RE (!rhos), LE, EE) + in LETREGION{B=B,rhos=rhos,body=sma_trip sme_body body} end - | LET{k_let,pat,bind,scope} => - let val (RE,LE,EE) = sme + | LET{k_let,pat,bind,scope} => + let val (RE,LE,EE) = sme fun do_pat (lv,ils,tvs,effs,tau,p,other) = (lv,ils,tvs,effs,tau,p,()) fun extend ((lvar,_,alphas,ref [], ty, rho, other), LE) = SME.declare_lvar_env(lvar,rvars(mu_to_scheme_and_place(ty,rho)), LE) | extend _ = die "non-empty list of bound region or effect variables at LET" val sme_scope = (RE, foldl extend LE pat,EE) - in LET{k_let=k_let,pat=map do_pat pat, + in LET{k_let=k_let,pat=map do_pat pat, bind=sma_trip sme bind, scope=sma_trip sme_scope scope} - end - | FIX{free,shared_clos = shared_clos as (shared_rho,liveset),functions,scope} => - let + end + | FIX{free,shared_clos = shared_clos as (shared_rho,liveset),functions,scope} => + let val (RE,LE,EE) = sme val LE' = foldl (fn ({lvar,tyvars, rhos_formals, epss, Type, ...}, acc) => - let val rhos = map (fn (a,_) => a) (!rhos_formals) - in SME.declare_lvar_env(lvar,rvars(RType.FORALL(rhos, - epss,tyvars,Type),shared_rho),acc) - end) + let val rhos = map (fn (a,_) => a) (!rhos_formals) + in SME.declare_lvar_env(lvar,rvars(RType.FORALL(rhos, + epss,tyvars,Type),SOME shared_rho),acc) + end) LE functions val sme' = (RE,LE',EE) fun do_function {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, @@ -536,12 +495,12 @@ structure AtInf: AT_INF = TR(FN{pat,body,free,alloc}, mu_lam, phi_lam, psi_lam) => let fun extend (rho, RE') = SME.declare_regvar_env(rho,SME.LETREC_BOUND,RE') - val rhos' = map (fn (a,_) => a) (!rhos_formals) + val rhos' = map (fn (a,_) => a) (!rhos_formals) val RE_for_body_of_fn = foldl extend SME.empty_regvar_env rhos' val fn' = sma_fn(sme',RE_for_body_of_fn,pat,body,free,alloc) in - {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, - rhos_formals=rhos_formals, + {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, + rhos_formals=rhos_formals, bound_but_never_written_into=bound_but_never_written_into, other=(), bind=TR(fn', mu_lam,phi_lam,psi_lam)} @@ -549,121 +508,116 @@ structure AtInf: AT_INF = | _ => die "right-hand side of fun must be a lambda-abstraction" ) - in FIX{free=free, - shared_clos=which_at sme shared_clos, - functions=map do_function functions, - scope=sma_trip sme' scope} - end - | APP(ck,sr,tr1,tr2) => APP(ck,sr,sma_trip sme tr1, sma_trip sme tr2) - | EXCEPTION(excon,b,tp,alloc as (rho,liveset),scope) => - let val (RE,LE,EE) = sme - val sme_body = (RE,LE,SME.declare_excon_env(excon,rvars(mu_to_scheme_and_place tp), EE)) - - in - EXCEPTION(excon,b,tp, ATTOP rho, - sma_trip sme_body scope) + in FIX{free=free, + shared_clos=which_at sme shared_clos, + functions=map do_function functions, + scope=sma_trip sme' scope} end - | RAISE tr => RAISE (sma_trip sme tr) - | HANDLE(tr1,tr2) => HANDLE(sma_trip sme tr1, sma_trip sme tr2) - | SWITCH_I {switch,precision} => SWITCH_I {switch=sma_sw sme switch, precision=precision} - | SWITCH_W {switch,precision} => SWITCH_W {switch=sma_sw sme switch, precision=precision} - | SWITCH_S sw => SWITCH_S (sma_sw sme sw) - | SWITCH_C sw => SWITCH_C (sma_sw sme sw) - | SWITCH_E sw => SWITCH_E (sma_sw sme sw) - | CON0 {con, il, aux_regions, alloc} => - CON0 {con=con, il=il, - aux_regions=map (which_at sme) aux_regions, - alloc=which_at sme alloc} - | CON1 ({con, il, alloc}, tr) => - CON1 ({con=con,il=il,alloc= which_at sme alloc}, - sma_trip sme tr) - | DECON ({con, il}, tr) => DECON({con=con,il=il},sma_trip sme tr) - | EXCON (excon, opt) => EXCON(excon, case opt - of SOME (alloc as (p, liveset),tr) => + | APP(ck,sr,tr1,tr2) => APP(ck,sr,sma_trip sme tr1, sma_trip sme tr2) + | EXCEPTION(excon,b,mu,alloc as (rho,liveset),scope) => + let val (RE,LE,EE) = sme + val mu' = case RType.unBOX mu of SOME(tau,p) => (tau,SOME p) + | NONE => (mu, NONE) + val rng = case rvars(mu_to_scheme_and_place mu') of + ((sigma, SOME p0),lrv) => ((sigma,p0),lrv) + | _ => die "EXCEPTION.expecting boxed type" + val sme_body = (RE,LE,SME.declare_excon_env(excon,rng,EE)) + in EXCEPTION(excon,b,mu, ATTOP rho, + sma_trip sme_body scope) + end + | RAISE tr => RAISE (sma_trip sme tr) + | HANDLE(tr1,tr2) => HANDLE(sma_trip sme tr1, sma_trip sme tr2) + | SWITCH_I {switch,precision} => SWITCH_I {switch=sma_sw sme switch, precision=precision} + | SWITCH_W {switch,precision} => SWITCH_W {switch=sma_sw sme switch, precision=precision} + | SWITCH_S sw => SWITCH_S (sma_sw sme sw) + | SWITCH_C sw => SWITCH_C (sma_sw sme sw) + | SWITCH_E sw => SWITCH_E (sma_sw sme sw) + | CON0 {con, il, aux_regions, alloc} => + CON0 {con=con, il=il, + aux_regions=map (which_at sme) aux_regions, + alloc=Option.map (which_at sme) alloc} + | CON1 ({con, il, alloc}, tr) => + CON1 ({con=con,il=il,alloc=Option.map (which_at sme) alloc}, + sma_trip sme tr) + | DECON ({con, il}, tr) => DECON({con=con,il=il},sma_trip sme tr) + | EXCON (excon, opt) => EXCON(excon, case opt + of SOME (alloc as (p, liveset),tr) => SOME (ATTOP p, sma_trip sme tr) - | NONE => NONE) - | DEEXCON (excon,tr) => DEEXCON(excon, sma_trip sme tr) - | RECORD (alloc, trs) => RECORD(which_at sme alloc,map (sma_trip sme) trs) - | SELECT (i, tr) => SELECT(i,sma_trip sme tr) - | DEREF tr => DEREF (sma_trip sme tr) - | REF (alloc,tr) => REF(which_at sme alloc, sma_trip sme tr) - | ASSIGN (alloc as (rho,_),tr1,tr2) => ASSIGN (ATTOP rho,sma_trip sme tr1, sma_trip sme tr2) (* no need for analysis *) - | DROP tr => DROP (sma_trip sme tr) - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc = (p,liveset)}, tr1,tr2) => - EQUAL ({mu_of_arg1=mu_of_arg1, mu_of_arg2=mu_of_arg2, alloc=ATTOP p}, (* 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) - | 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) - | RESET_REGIONS ({force, alloc = (p, liveset), ...}, tr as (TR(VAR{lvar,...},meta,_,_))) => + | NONE => NONE) + | DEEXCON (excon,tr) => DEEXCON(excon, sma_trip sme tr) + | RECORD (alloc, trs) => RECORD(Option.map (which_at sme) alloc,map (sma_trip sme) trs) + | SELECT (i, tr) => SELECT(i,sma_trip sme tr) + | DEREF tr => DEREF (sma_trip sme tr) + | REF (alloc,tr) => REF(which_at sme alloc, sma_trip sme tr) + | ASSIGN (tr1,tr2) => ASSIGN (sma_trip sme tr1, sma_trip sme tr2) (* no need for analysis *) + | DROP tr => DROP (sma_trip sme tr) + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => + 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) + | 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) + | RESET_REGIONS ({force, liveset=SOME liveset, ...}, tr as (TR(VAR{lvar,...},meta,_,_))) => (case meta of MulExp.RegionExp.Mus [mu] => - let - val free_regions = - Eff.remove_duplicates(RType.frv_mu mu) - + let val free_regions = Eff.remove_duplicates(RType.frv_mu mu) val (place_at_list, conflicts) = - analyse_rhos_for_resetting(sme,liveset,free_regions) + analyse_rhos_for_resetting(sme,liveset,free_regions) val conflicts' = - if force then - foldl (fn (SAT rho, acc) => FORMAL_REGION_PARAM rho :: acc - | (_, acc) => acc) conflicts place_at_list - else conflicts + if force then + foldl (fn (SAT rho, acc) => FORMAL_REGION_PARAM rho :: acc + | (_, acc) => acc) conflicts place_at_list + else conflicts in - case conflicts' of - [] => () - | _ => warn (PP.reportStringTree(lay_report(force,lvar,mu,conflicts'))); -(*ME 1998-08-30 - | _ => (dump(lay_report(force,lvar,mu,conflicts')); - warn (Report.// (Report.line "Warnings concerning resetting of regions \ - \printed earlier in this file!", - Report.line "(Search on \"You have\")"))); -*) - RESET_REGIONS({force=force,alloc=ATTOP p,regions_for_resetting = place_at_list}, - (* the place_at_list may contain word regions *) - sma_trip sme tr) + case conflicts' of + [] => () + | _ => warn (PP.reportStringTree(lay_report(force,lvar,mu,conflicts'))); + RESET_REGIONS({force=force,regions_for_resetting = place_at_list, liveset=NONE}, + sma_trip sme tr) end - | _ => die "RESET_REGIONS: expected a type and place on argument to resetRegions" + | _ => die "RESET_REGIONS: expected a type and place on argument to resetRegions" ) | RESET_REGIONS _ => die "ill-formed expression: argument to RESET_REGIONS should be a variable" - | FRAME{declared_lvars, declared_excons} => - let fun f {lvar,sigma,other,place} = {lvar=lvar,sigma=sigma,other=(),place=place} - in FRAME{declared_lvars=map f declared_lvars, declared_excons = declared_excons} - end + | FRAME{declared_lvars, declared_excons} => + let fun f {lvar,sigma,other,place} = {lvar=lvar,sigma=sigma,other=(),place=place} + in FRAME{declared_lvars=map f declared_lvars, declared_excons = declared_excons} + end ) handle Crash.CRASH => (log "\nStorage Mode Analysis failed at expression:"; dump(MulExp.layoutLambdaExp(fn _ => NONE)(fn _ => NONE)(fn _ => NONE)(fn _ => NONE) e); raise AbortExpression) - in TR(e', metaType, ateffects, mulef_r) - end - and sma_fn(sme,regvar_env0,pat,body,free,alloc) = - let val (_, LE, EE) = sme - fun extend ((lvar, mu), LE) = - SME.declare_lvar_env(lvar,rvars(mu_to_scheme_and_place mu), LE) - val sme_body = (regvar_env0, - foldl extend LE pat, - EE) - in - FN{pat=pat,body=sma_trip sme_body body, - free=free,alloc=which_at sme alloc} - end - + in TR(e', metaType, ateffects, mulef_r) + end + and sma_fn (sme,regvar_env0,pat,body,free,alloc) = + let val (_, LE, EE) = sme + fun extend ((lvar, mu), LE) = + let val mu = case RType.unBOX mu of SOME (tau,rho) => (tau,SOME rho) + | NONE => (mu, NONE) + in SME.declare_lvar_env(lvar,rvars(mu_to_scheme_and_place mu), LE) + end + val sme_body = (regvar_env0, + foldl extend LE pat, + EE) + in + FN{pat=pat,body=sma_trip sme_body body, + free=free,alloc=which_at sme alloc} + end in PGM{expression=sma_trip SME.empty_sme trip, - export_datbinds=export_datbinds, - import_vars=import_vars, - export_vars=export_vars, - export_basis=export_basis, - export_Psi=export_Psi} + export_datbinds=export_datbinds, + import_vars=import_vars, + export_vars=export_vars, + export_basis=export_basis, + export_Psi=export_Psi} end (********************************************) @@ -680,24 +634,24 @@ structure AtInf: AT_INF = (* the general principles. *) (********************************************) - fun sma(pgm: (place, place*mul, qmularefset ref)LambdaPgm): - (place at, place*mul, unit)LambdaPgm = - (chat "Building region flow graph ..."; - Timing.timing_begin(); - RegFlow.mk_graph(pgm) handle _ => die "call of RegFlow.mk_graph failed"; - Timing.timing_end("RegFlow"); + fun sma (pgm: (place, place*mul, qmularefset ref)LambdaPgm) + : (place at, place*mul, unit)LambdaPgm = + (chat "Building region flow graph ..."; + Timing.timing_begin(); + RegFlow.mk_graph(pgm) handle _ => die "call of RegFlow.mk_graph failed"; + Timing.timing_end("RegFlow"); + Timing.timing_begin(); + chat "Computing locally live variables ..."; + let val pgm' = LLV.llv pgm + handle _ => die "call of LLV.llv failed" + in + Timing.timing_end("LocLive"); + chat "Storage mode analysis ..."; Timing.timing_begin(); - chat "Computing locally live variables ..."; - let val pgm' = LLV.llv pgm - handle _ => die "call of LLV.llv failed" - in - Timing.timing_end("LocLive"); - chat "Storage mode analysis ..."; - Timing.timing_begin(); - (sma0(pgm')handle AbortExpression => die "call of sma0 failed") + (sma0(pgm')handle AbortExpression => die "call of sma0 failed") footnote Timing.timing_end("SMA") - end - ) + end + ) (***********************************) (* Pretty printing *) @@ -705,18 +659,17 @@ structure AtInf: AT_INF = type StringTree = PP.StringTree fun lay (s : string) (p: 'a -> StringTree) (a : 'a) : StringTree option = - SOME(PP.HNODE{start=s^" ",finish="",children=[p a],childsep=PP.NOSEP}) + SOME(PP.HNODE{start=s^" ",finish="",children=[p a],childsep=PP.NOSEP}) fun layout_at (p: 'a -> StringTree) (at : 'a at) = - case at - of ATTOP a => lay "attop" p a - | ATBOT a => lay "atbot" p a - | SAT a => lay "sat" p a - | IGNORE => NONE + case at of + ATTOP a => lay "attop" p a + | ATBOT a => lay "atbot" p a + | SAT a => lay "sat" p a fun layout_placeXmul (place,mul) = - PP.HNODE{start="",finish="",childsep=PP.RIGHT ":", - children=[Eff.layout_effect place, Mul.layout_mul mul]} + PP.HNODE{start="",finish="",childsep=PP.RIGHT ":", + children=[Eff.layout_effect place, Mul.layout_mul mul]} fun layout_unit () = NONE val layout_trip : (place at, place*mul, unit)trip -> StringTree = MulExp.layoutLambdaTrip (layout_at Eff.layout_effect)(layout_at Eff.layout_effect) (SOME o layout_placeXmul) layout_unit @@ -724,21 +677,19 @@ structure AtInf: AT_INF = (* brief printing of expressions: *) fun layout_at' (p: 'a -> StringTree) (at : 'a at) = case at - of ATTOP a => lay "at" p a - | ATBOT a => lay "at" p a - | SAT a => lay "at" p a - | IGNORE => NONE + of ATTOP a => lay "at" p a + | ATBOT a => lay "at" p a + | SAT a => lay "at" p a fun layout_at'' (p: 'a -> StringTree) (at : 'a at) = case at - of ATTOP a => SOME(p a) - | ATBOT a => SOME(p a) - | SAT a => SOME(p a) - | IGNORE => NONE + of ATTOP a => SOME(p a) + | ATBOT a => SOME(p a) + | SAT a => SOME(p a) fun ignore _ = NONE - fun layout_trip_brief(tr : (place at, place*mul, unit)trip): StringTree = + fun layout_trip_brief (tr : (place at, place*mul, unit)trip): StringTree = if print_regions() then MulExp.layoutLambdaTrip (layout_at' Eff.layout_effect)(layout_at'' Eff.layout_effect) (SOME o layout_placeXmul) layout_unit tr @@ -755,4 +706,4 @@ structure AtInf: AT_INF = fun layout_pgm (PGM{expression,...}) = layout_trip expression fun layout_pgm_brief (PGM{expression,...}) = layout_trip_brief expression -end (* AtInf *) +end diff --git a/src/Compiler/Regions/DROP_REGIONS.sml b/src/Compiler/Regions/DROP_REGIONS.sml index 473bb13f9..19a5eb5c8 100644 --- a/src/Compiler/Regions/DROP_REGIONS.sml +++ b/src/Compiler/Regions/DROP_REGIONS.sml @@ -4,25 +4,22 @@ signature DROP_REGIONS = type ('a,'b,'c)LambdaPgm and place and mul - and 'a at - and env - and lvar + and 'a at + and env + and lvar - val empty : env - val init : env - val plus : env * env -> env + val empty : env + val init : env + val plus : env * env -> env - val restrict : env * lvar list -> env - val enrich : env * env -> bool + val restrict : env * lvar list -> env + val enrich : env * env -> bool - val drop_regions : env * (place at, place*mul, unit)LambdaPgm -> - (place at, place*mul, unit)LambdaPgm * env + val drop_regions : env * (place at, place*mul, unit)LambdaPgm -> + (place at, place*mul, unit)LambdaPgm * env - val drop_places : place list -> place list + type StringTree + val layout_env : env -> StringTree - type StringTree - val layout_env : env -> StringTree - - val pu_env : env Pickle.pu + val pu_env : env Pickle.pu end - diff --git a/src/Compiler/Regions/DropRegions.sml b/src/Compiler/Regions/DropRegions.sml index cb08e00e2..9b205b873 100644 --- a/src/Compiler/Regions/DropRegions.sml +++ b/src/Compiler/Regions/DropRegions.sml @@ -17,20 +17,17 @@ structure DropRegions: DROP_REGIONS = fun device s = TextIO.output(!Flags.log, s) fun dump t = PP.outputTree(device, t, !Flags.colwidth) - (* ----------------------------------------------------------------- * Various functions * ----------------------------------------------------------------- *) fun rt_place place = case Eff.get_place_ty place - of SOME rt => rt - | NONE => die "rt_place" - + of SOME rt => rt + | NONE => die "rt_place" fun pr_rho place = PP.flatten1 (Eff.layout_effect place) - fun pr_rt Eff.WORD_RT = "word" - | pr_rt Eff.STRING_RT = "string" + fun pr_rt Eff.STRING_RT = "string" | pr_rt Eff.PAIR_RT = "pair" | pr_rt Eff.ARRAY_RT = "array" | pr_rt Eff.REF_RT = "ref" @@ -38,27 +35,16 @@ structure DropRegions: DROP_REGIONS = | pr_rt Eff.BOT_RT = "bot" | pr_rt Eff.TOP_RT = "top" - fun bot_region place = case rt_place place of Eff.BOT_RT => true | _ => false - fun word_region place = case Eff.get_place_ty place - of SOME rt => Eff.is_wordsize rt - | NONE => die "word_region" - fun word_or_bot_region place = case rt_place place - of Eff.WORD_RT => true - | Eff.BOT_RT => true - | _ => false - - fun drop_atplace (a as ATTOP place) = if word_region place then IGNORE else a - | drop_atplace (a as ATBOT place) = if word_region place then IGNORE else a - | drop_atplace (a as SAT place ) = if word_region place then IGNORE else a - | drop_atplace _ = die "drop_atplace failed (applied to IGNORE)" + fun bot_region place = + case rt_place place of + Eff.BOT_RT => true + | _ => false fun place_atplace (ATTOP place) = place | place_atplace (ATBOT place) = place | place_atplace (SAT place) = place - | place_atplace _ = die "place_atplace" - - (******************) - local val bucket : place list ref = ref [] (* Visited fields *) + (******************) + local val bucket : place list ref = ref [] (* Visited fields *) in fun unvisit place = Eff.get_visited place := false (******************) fun reset_bucket () = (List.app unvisit (!bucket); bucket := []) fun visit place = (Eff.get_visited place := true; bucket := (place :: !bucket)) @@ -68,24 +54,23 @@ structure DropRegions: DROP_REGIONS = (* from version 2: *) - fun drop_places(places, arreffs) = (*************************) + fun drop_places (places, arreffs) = (*************************) let (* a rho is marked if it *) - (* should NOT be dropped *) + (* should NOT be dropped *) (*************************) - 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) - in visit_put_rhos arreffs - end - fun unvisit_word_bot_rhos [] = () - | unvisit_word_bot_rhos (rho::rhos) = - (if word_or_bot_region rho then unvisit rho - else (); unvisit_word_bot_rhos rhos) - val _ = visit_put_rhos arreffs - val _ = unvisit_word_bot_rhos places - val bl = map is_visited places + 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) + in visit_put_rhos arreffs + end + fun unvisit_bot_rhos [] = () + | unvisit_bot_rhos (rho::rhos) = + (if bot_region rho then unvisit rho + else (); unvisit_bot_rhos rhos) + val _ = visit_put_rhos arreffs + val _ = unvisit_bot_rhos places + val bl = map is_visited places in reset_bucket(); bl end @@ -106,11 +91,11 @@ structure DropRegions: DROP_REGIONS = (*****************************) val init = (* create the initial env by *) let fun foldfn ((lvar, (compound,_,_,sigma,_,_,_)), env) = (* folding over RSE.initial *) - if compound then let val (places,arreffs,_) = RType.bv sigma (*****************************) - val bl = drop_places(places,arreffs) - in add(lvar,FIXBOUND bl,env) - end - else add(lvar,NOTFIXBOUND,env) + if compound then let val (places,arreffs,_) = RType.bv sigma (*****************************) + val bl = drop_places(places,arreffs) + in add(lvar,FIXBOUND bl,env) + end + else add(lvar,NOTFIXBOUND,env) in RSE.FoldLvar foldfn empty RSE.initial end @@ -118,21 +103,21 @@ structure DropRegions: DROP_REGIONS = fun restrict(env,lvars) = foldl(fn (lv,acc) => - case lookup env lv - of SOME res => add(lv,res,acc) - | NONE => die "restrict.lv not in env") empty lvars + case lookup env lv + of SOME res => add(lv,res,acc) + | NONE => die "restrict.lv not in env") empty lvars fun enrich(env1,env2) = LvarMap.Fold(fn ((lv2,res2),b) => b andalso - case LvarMap.lookup env1 lv2 - of SOME res1 => res1=res2 - | NONE => false) true env2 + case LvarMap.lookup env1 lv2 + of SOME res1 => res1=res2 + | NONE => false) true env2 type StringTree = PP.StringTree fun layout_bool true = PP.LEAF "1" | layout_bool false = PP.LEAF "0" fun layout_env_res (FIXBOUND bl) = PP.NODE{start="FIXBOUND[",finish="]",indent=1,childsep=PP.NOSEP, - children=map layout_bool bl} + children=map layout_bool bl} | layout_env_res NOTFIXBOUND = PP.LEAF "NOTFIXBOUND" fun layout_lvar lv = PP.LEAF (Lvars.pr_lvar lv) val layout_env = LvarMap.layoutMap {start="DROPENV(",finish=")",eq=" -> ",sep=", "} layout_lvar layout_env_res @@ -169,36 +154,29 @@ structure DropRegions: DROP_REGIONS = fun check_atplace (rt, atplace) s = let val place = place_atplace atplace - val rt' = rt_place place + val rt' = rt_place place in if rt = rt' then () - else die ("check_atplace." ^ s ^ " : found runtype " ^ pr_rt rt' ^ " for " ^ pr_rho place ^ - ", expected runtype " ^ pr_rt rt) + else die ("check_atplace." ^ s ^ " : found runtype " ^ pr_rt rt' ^ " for " ^ pr_rho place ^ + ", expected runtype " ^ pr_rt rt) end - fun check_atp_w atp s = check_atplace (Eff.WORD_RT, atp) s fun check_atp_p atp s = check_atplace (Eff.PAIR_RT, atp) s fun check_atp_s atp s = check_atplace (Eff.STRING_RT, atp) s fun check_atp_t atp s = check_atplace (Eff.TOP_RT, atp) s - - fun filter [] = [] - | filter (IGNORE::xs) = filter xs - | filter (x::xs) = x::filter xs - (* maybe_add_rho regvar_env (rho, acc) conses rho onto acc if rho is marked as DROPIT in regvar_env: *) - fun maybe_add_rho regvar_env (rho, acc) = - case PlaceMap.lookup regvar_env rho - of SOME DROPIT => rho :: acc - | _ => acc + fun maybe_add_rho regvar_env (rho, acc) = + case PlaceMap.lookup regvar_env rho + of SOME DROPIT => rho :: acc + | _ => acc - fun maybe_add regvar_env (atp, acc) = - case atp of - IGNORE => acc - | ATTOP rho => maybe_add_rho regvar_env (rho, acc) - | ATBOT rho => maybe_add_rho regvar_env (rho, acc) - | SAT rho => maybe_add_rho regvar_env (rho, acc) + fun maybe_add regvar_env (atp, acc) = + case atp of + ATTOP rho => maybe_add_rho regvar_env (rho, acc) + | ATBOT rho => maybe_add_rho regvar_env (rho, acc) + | SAT rho => maybe_add_rho regvar_env (rho, acc) (* ----------------------------------------------------------------- * Dropping regions @@ -208,113 +186,105 @@ structure DropRegions: DROP_REGIONS = fun drop (env as (lvar_env: env, regvar_env: regenv)) (t0 as TR(e,metaType,ateffs,mulef)) (acc: place list) : - (place at, place*mul, unit)trip * place list= - + (place at, place*mul, unit)trip * place list = let - fun S atp = - if region_inference() then atp - else - let - fun subst rho = - case PlaceMap.lookup regvar_env rho - of SOME LETREGION_INF => ATTOP - (case Eff.get_place_ty rho - of SOME Eff.STRING_RT => Eff.toplevel_region_withtype_string - | SOME Eff.PAIR_RT => Eff.toplevel_region_withtype_pair - | SOME Eff.ARRAY_RT => Eff.toplevel_region_withtype_array - | SOME Eff.REF_RT => Eff.toplevel_region_withtype_ref - | SOME Eff.TRIPLE_RT => Eff.toplevel_region_withtype_triple - | SOME _ => Eff.toplevel_region_withtype_top - | NONE => die "S_atp.lookup") - | _ => atp - in case atp - of IGNORE => atp - | ATTOP rho => subst rho - | ATBOT rho => subst rho - | SAT rho => subst rho - end - - fun drop_sw (SWITCH(tr,sel,opt)) acc = - let val (sel', acc) = List.foldr (fn ((a,tr), (trs, acc)) => + fun S atp = + if region_inference() then atp + else + let + fun subst rho = + case PlaceMap.lookup regvar_env rho + of SOME LETREGION_INF => ATTOP + (case Eff.get_place_ty rho + of SOME Eff.STRING_RT => Eff.toplevel_region_withtype_string + | SOME Eff.PAIR_RT => Eff.toplevel_region_withtype_pair + | SOME Eff.ARRAY_RT => Eff.toplevel_region_withtype_array + | SOME Eff.REF_RT => Eff.toplevel_region_withtype_ref + | SOME Eff.TRIPLE_RT => Eff.toplevel_region_withtype_triple + | SOME _ => Eff.toplevel_region_withtype_top + | NONE => die "S_atp.lookup") + | _ => atp + in case atp of + ATTOP rho => subst rho + | ATBOT rho => subst rho + | SAT rho => subst rho + end + + fun drop_sw (SWITCH(tr,sel,opt)) acc = + let val (sel', acc) = List.foldr (fn ((a,tr), (trs, acc)) => let val (tr', acc) = drop env tr acc in ((a, tr') :: trs, acc) end) ([] , acc) sel - val (opt',acc) = + val (opt',acc) = case opt of SOME tr => let val (tr', acc) = drop env tr acc in (SOME tr', acc) end | NONE => (NONE, acc) val (tr', acc) = drop env tr acc - in (SWITCH(tr',sel',opt'), acc) - end - - val (e', acc) = - (case e - of VAR {fix_bound=false,rhos_actuals=ref[],...} => (e, acc) (* fix-bound and prim lvars are dealt with below *) - | VAR _ => die "drop.should be fix-bound" - | INTEGER (n, t, atp) => - if RType.unboxed t then (check_atp_w atp "INTEGER"; - (INTEGER (n, t, IGNORE), acc)) - else (check_atp_t atp "INTEGER_BOXED"; - (INTEGER(n,t,S atp), maybe_add regvar_env (atp, acc))) - | WORD (w, t, atp) => - if RType.unboxed t then (check_atp_w atp "WORD"; - (WORD (w, t, IGNORE), acc)) - else (check_atp_t atp "WORD_BOXED"; - (WORD(w,t,S atp), maybe_add regvar_env (atp, acc))) - | STRING (s, atp) => (check_atp_s atp "STRING"; + in (SWITCH(tr',sel',opt'), acc) + end + + val (e', acc) = + (case e + of VAR {fix_bound=false,rhos_actuals=ref[],...} => (e, acc) (* fix-bound and prim lvars are dealt with below *) + | VAR _ => die "drop.should be fix-bound" + | INTEGER (n, t, NONE) => (INTEGER (n, t, NONE), acc) + | INTEGER (n, t, SOME atp) => + (check_atp_t atp "INTEGER_BOXED"; + (INTEGER(n,t,SOME(S atp)), + maybe_add regvar_env (atp, acc))) + | WORD (w, t, NONE) => (WORD (w, t, NONE), acc) + | WORD (w, t, SOME atp) => + (check_atp_t atp "WORD_BOXED"; + (WORD(w,t,SOME(S atp)), + maybe_add regvar_env (atp, acc))) + | STRING (s, atp) => (check_atp_s atp "STRING"; (STRING(s,S atp), maybe_add regvar_env (atp, acc))) - | REAL (s, atp) => (check_atp_t atp "REAL"; (REAL(s,S atp), maybe_add regvar_env (atp, acc))) - | F64 (s, atp) => (check_atp_w atp "F64"; (F64(s,IGNORE), acc)) - | UB_RECORD trips => - let val (trips', acc) = List.foldr (fn (tr, (trs,acc)) => - let val (tr', acc)= drop env tr acc - in (tr'::trs, acc) - end) ([], acc) trips - in (UB_RECORD trips', acc) - end - | FN{pat,body,free,alloc=atp} => - (check_atp_t atp "FN_CLOS"; - let val (body', acc) = drop env body acc - in - (FN{pat=pat,body=body',free=free,alloc=S atp}, - maybe_add regvar_env (atp, acc)) - end) - | LETREGION{B,rhos=ref rhos,body} => - let fun drop_rhos [] = [] - | drop_rhos ((rho as (p,mul))::rhos) = - if word_region p then drop_rhos rhos - else ((*if bot_region p then die "letregion bound variable with runtype BOT." - else ();mads *) rho::drop_rhos rhos) - val rhos' = drop_rhos rhos - val (rhos', env) = - if region_inference() then (rhos', env) - else foldr (fn (rho as (p,Mul.INF),(rhos',env)) => (rhos',add_regenv'(p,LETREGION_INF,env)) - | (rho,(rhos',env)) => (rho::rhos',env)) (nil,env) rhos' - val (body', acc) = drop env body acc - in (LETREGION{B=B,rhos=ref rhos',body=body'}, acc) - end - | LET{k_let,pat,bind,scope} => - let val env' = (List.foldl(fn ((lvar,_,_,_,_,_,_),acc) => - add(lvar,NOTFIXBOUND,acc)) lvar_env pat, - regvar_env) - val (scope', acc) = drop env' scope acc - val (bind', acc) = drop env bind acc - in (LET{k_let=k_let,pat=pat,bind=bind', - scope=scope'}, acc) - end - | FIX{free,shared_clos=atp,functions,scope} => - let val _ = check_atp_t atp "FIX_CLOS" + | REAL (s, atp) => (check_atp_t atp "REAL"; (REAL(s,S atp), maybe_add regvar_env (atp, acc))) + | F64 s => (F64 s, acc) + | UB_RECORD trips => + let val (trips', acc) = List.foldr (fn (tr, (trs,acc)) => + let val (tr', acc) = drop env tr acc + in (tr'::trs, acc) + end) ([], acc) trips + in (UB_RECORD trips', acc) + end + | FN{pat,body,free,alloc=atp} => + (check_atp_t atp "FN_CLOS"; + let val (body', acc) = drop env body acc + in (FN{pat=pat,body=body',free=free,alloc=S atp}, + maybe_add regvar_env (atp, acc)) + end) + | LETREGION{B,rhos=ref rhos,body} => + let val rhos' = rhos + val (rhos', env) = + if region_inference() then (rhos', env) + else foldr (fn (rho as (p,Mul.INF),(rhos',env)) => (rhos',add_regenv'(p,LETREGION_INF,env)) + | (rho,(rhos',env)) => (rho::rhos',env)) (nil,env) rhos' + val (body', acc) = drop env body acc + in (LETREGION{B=B,rhos=ref rhos',body=body'}, acc) + end + | LET{k_let,pat,bind,scope} => + let val env' = (List.foldl(fn ((lvar,_,_,_,_,_,_),acc) => + add(lvar,NOTFIXBOUND,acc)) lvar_env pat, + regvar_env) + val (scope', acc) = drop env' scope acc + val (bind', acc) = drop env bind acc + in (LET{k_let=k_let,pat=pat,bind=bind', + scope=scope'}, acc) + end + | FIX{free,shared_clos=atp,functions,scope} => + let val _ = check_atp_t atp "FIX_CLOS" val acc = maybe_add regvar_env (atp, acc) - type tr = lvar * bool list * (place * mul) list * (place*mul) list * regenv - fun tr_function {lvar,occ,tyvars,rhos,epss, + type tr = lvar * bool list * (place * mul) list * (place*mul) list * regenv + fun tr_function {lvar,occ,tyvars,rhos,epss, Type,rhos_formals=ref formals,bound_but_never_written_into, other,bind} : tr = - let - val rhos = map #1 formals (* thinned, contracted version of rhos above - * ; see MulInf.sml *) - val bool_list = drop_places(rhos,epss) - val formals' = filter_bl(bool_list,formals) + let + val rhos = map #1 formals (* thinned, contracted version of rhos above + * ; see MulInf.sml *) + val bool_list = drop_places(rhos,epss) + val formals' = filter_bl(bool_list,formals) val drop_formals' = (filter_bl (map not bool_list, formals)) (* regvars_env' extends regvar with one binding for each bound region @@ -327,22 +297,20 @@ structure DropRegions: DROP_REGIONS = regvar_env (ListPair.zip(formals, bool_list) handle _ => die "FIX: formals and bool list have different lengths") - in (lvar, bool_list, formals', drop_formals', regvar_env') - end - val trs : tr list = map tr_function functions - val lvar_env' = List.foldl (fn ((lvar,bool_list,_,_,_), env) => + in (lvar, bool_list, formals', drop_formals', regvar_env') + end + val trs : tr list = map tr_function functions + val lvar_env' = List.foldl (fn ((lvar,bool_list,_,_,_), env) => add(lvar,FIXBOUND bool_list,env)) lvar_env trs - fun new_functions [] [] acc = ([], acc) - | new_functions ({lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + fun new_functions [] [] acc = ([], acc) + | new_functions ({lvar,occ,tyvars,rhos,epss,Type,rhos_formals, other,bind,bound_but_never_written_into}::fcs) - ((lvar',_,formals,drop_formals',regvar_env')::trs') acc = + ((lvar',_,formals,drop_formals',regvar_env')::trs') acc = (if not(Lvars.eq(lvar,lvar')) then die "new_functions.lvar" else let val (bind', acc1) = drop(lvar_env',regvar_env') bind [] - val bound_but_never_written_into = (* drop_formals' intersect acc1 *) - (* List.filter (fn (rho,_) => List.exists (fn rho' => - Eff.eq_effect(rho,rho')) acc1) *) drop_formals' + val bound_but_never_written_into = drop_formals' val propagate = (* acc1 setminus drop_formals' *) List.filter (fn rho => not(List.exists (fn (rho',_) => Eff.eq_effect(rho,rho')) drop_formals')) acc1 @@ -358,210 +326,206 @@ structure DropRegions: DROP_REGIONS = :: rest, acc) end ) - | new_functions _ _ acc = die "new_functions" - val (functions', acc) = new_functions functions trs acc - val (scope',acc) = drop (lvar_env', regvar_env) scope acc - in (FIX{free=free,shared_clos=S atp,functions=functions',scope=scope'}, acc) - end - | APP(ck,sr,tr1 as TR(VAR{lvar,il,plain_arreffs, fix_bound, + | new_functions _ _ acc = die "new_functions" + val (functions', acc) = new_functions functions trs acc + val (scope',acc) = drop (lvar_env', regvar_env) scope acc + in (FIX{free=free,shared_clos=S atp,functions=functions',scope=scope'}, acc) + end + | APP(ck,sr,tr1 as TR(VAR{lvar,il,plain_arreffs, fix_bound, rhos_actuals=ref actuals, other},metaType, ateffs,mulef), tr2) => - (case lookup lvar_env lvar - of SOME (FIXBOUND bool_list) => - let - val actuals' = filter_bl(bool_list,actuals) + (case lookup lvar_env lvar + of SOME (FIXBOUND bool_list) => + let + val actuals' = filter_bl(bool_list,actuals) val acc = List.foldl (maybe_add regvar_env) acc actuals' val (tr2', acc) = drop env tr2 acc - val actuals' = map S actuals' - in (APP(ck,sr,TR(VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs,fix_bound=fix_bound, - rhos_actuals=ref actuals',other=other},metaType,ateffs,mulef), + val actuals' = map S actuals' + in (APP(ck,sr,TR(VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs,fix_bound=fix_bound, + rhos_actuals=ref actuals',other=other},metaType,ateffs,mulef), tr2'), acc) - end - | _ => (case (fix_bound, actuals) - of (false, []) => + end + | _ => (case (fix_bound, actuals) + of (false, []) => let val (tr2', acc) = drop env tr2 acc in (APP(ck,sr,tr1,tr2'), acc) end - | _ => die ("drop.APP(VAR= " ^ Lvars.pr_lvar lvar ^ " ,tr2)"))) - | APP(ck,sr,tr1,tr2) => + | _ => die ("drop.APP(VAR= " ^ Lvars.pr_lvar lvar ^ " ,tr2)"))) + | APP(ck,sr,tr1,tr2) => let val (tr1', acc) = drop env tr1 acc val (tr2', acc) = drop env tr2 acc in (APP(ck,sr,tr1',tr2'), acc) end - | EXCEPTION(excon,b,mu,atp,tr) => + | EXCEPTION(excon,b,mu,atp,tr) => let val acc = maybe_add regvar_env (atp, acc) val (tr', acc) = drop env tr acc in check_atp_t atp "EXCEPTION"; (EXCEPTION(excon,b,mu,S atp, tr'), acc) end - | RAISE tr => + | RAISE tr => let val (tr', acc) = drop env tr acc in (RAISE (tr'), acc) end - | HANDLE (tr1,tr2) => + | HANDLE (tr1,tr2) => let val (tr1', acc) = drop env tr1 acc val (tr2', acc) = drop env tr2 acc in (HANDLE(tr1', tr2'), acc) end - | SWITCH_I {switch, precision} => + | SWITCH_I {switch, precision} => let val (switch', acc) = drop_sw switch acc in (SWITCH_I {switch=switch', precision=precision}, acc) end - | SWITCH_W {switch, precision} => + | SWITCH_W {switch, precision} => let val (switch', acc) = drop_sw switch acc in (SWITCH_W {switch=switch', precision=precision}, acc) end - | SWITCH_S sw => + | SWITCH_S sw => let val (sw', acc) = drop_sw sw acc in (SWITCH_S sw', acc) end - | SWITCH_C sw => + | SWITCH_C sw => let val (sw', acc) = drop_sw sw acc in (SWITCH_C sw', acc) end - | SWITCH_E sw => + | SWITCH_E sw => let val (sw', acc) = drop_sw sw acc in (SWITCH_E sw', acc) end - | CON0 {con, il, aux_regions, alloc} => - let val aux_regions' = filter(map drop_atplace aux_regions) - val acc = List.foldl (maybe_add regvar_env) acc (alloc::aux_regions') - in (CON0{con=con,il=il, - aux_regions=map S aux_regions', - alloc=S(drop_atplace alloc)}, acc) - end - | CON1 ({con, il, alloc}, tr) => + | CON0 {con, il, aux_regions, alloc} => + let val rhos = case alloc of SOME p => p :: aux_regions + | NONE => aux_regions + val acc = List.foldl (maybe_add regvar_env) acc rhos + in (CON0{con=con,il=il, + aux_regions=map S aux_regions, + alloc=Option.map S alloc}, acc) + end + | CON1 ({con, il, alloc}, tr) => let val (tr', acc) = drop env tr acc - val acc = maybe_add regvar_env (alloc, acc) + val acc = case alloc of SOME p => maybe_add regvar_env (p, acc) + | NONE => acc in (CON1({con=con,il=il, - alloc=S(drop_atplace alloc)},tr'), + alloc=Option.map S alloc},tr'), acc) end - | DECON (c, tr) => + | DECON (c, tr) => let val (tr', acc) = drop env tr acc in (DECON (c,tr'), acc) end - | EXCON (excon, opt) => + | EXCON (excon, opt) => let val (tr_opt', acc) = case opt of SOME (alloc,tr) => let val acc = maybe_add regvar_env (alloc, acc) val (tr', acc) = drop env tr acc - in (SOME(S(drop_atplace alloc), tr'), acc) + in (SOME(S(alloc), tr'), acc) end | NONE => (NONE, acc) in (EXCON(excon, tr_opt'), acc) end - | DEEXCON (excon,tr) => let val (tr', acc) = drop env tr acc + | DEEXCON (excon,tr) => let val (tr', acc) = drop env tr acc in (DEEXCON(excon, tr'), acc) end - | RECORD (alloc, trs) => - let val acc = maybe_add regvar_env (drop_atplace alloc, acc) + | RECORD (alloc, trs) => + let val acc = + case alloc of + SOME p => maybe_add regvar_env (p, acc) + | NONE => acc val (trs', acc) = List.foldr (fn (tr, (trs, acc)) => let val (tr', acc) = drop env tr acc in (tr'::trs, acc) end) ([], acc) trs in - (RECORD(S(drop_atplace alloc), trs'), acc) + (RECORD(Option.map S alloc, trs'), acc) end - | SELECT (i, tr) => + | SELECT (i, tr) => let val (tr', acc) = drop env tr acc in (SELECT(i, tr'), acc) end - | DEREF tr => + | DEREF tr => let val (tr', acc) = drop env tr acc in (DEREF tr', acc) end - | REF (alloc,tr) => + | REF (alloc,tr) => let val acc = maybe_add regvar_env (alloc, acc) val (tr', acc)= drop env tr acc in - (REF(S(drop_atplace alloc),tr'), acc) + (REF(S(alloc),tr'), acc) end - | ASSIGN (alloc,tr1,tr2) => - let val acc = maybe_add regvar_env (alloc, acc) - val (tr1', acc) = drop env tr1 acc + | ASSIGN (tr1,tr2) => + let val (tr1', acc) = drop env tr1 acc val (tr2', acc) = drop env tr2 acc - in (ASSIGN(S(drop_atplace alloc), tr1', tr2'), + in (ASSIGN(tr1', tr2'), acc) end - | DROP tr => + | DROP tr => let val (tr', acc) = drop env tr acc - in (DROP (tr'), acc) - end - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc}, tr1,tr2) => - let val acc = maybe_add regvar_env (alloc, acc) - val (tr1', acc) = drop env tr1 acc + in (DROP (tr'), acc) + end + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => + let val (tr1', acc) = drop env tr1 acc val (tr2', acc) = drop env tr2 acc in (EQUAL ({mu_of_arg1=mu_of_arg1, - mu_of_arg2=mu_of_arg2, - alloc=S(drop_atplace alloc)}, tr1', tr2'), acc) + mu_of_arg2=mu_of_arg2}, tr1', tr2'), acc) end - | CCALL ({name, mu_result, rhos_for_result}, trs) => - let + | CCALL ({name, mu_result, rhos_for_result}, trs) => + let val acc = List.foldl (maybe_add regvar_env) acc (map #1 rhos_for_result) val (trs', acc) = List.foldr (fn (tr, (trs, acc)) => let val (tr', acc) = drop env tr acc in (tr'::trs, acc) end) ([],acc) trs - (*I do not think you can be sure that List.dropAll preserves - the order of the list, so filter is used:*) - fun filter [] = [] - | filter ((IGNORE, _) :: xs) = filter xs - | filter ((_, SOME 0) :: xs) = die "filter: undropped region with size=0?" - | filter (x :: xs) = x :: filter xs - in(CCALL ({name = name, - mu_result = mu_result, - rhos_for_result = - filter (map (fn (atp, i_opt) => - (S(drop_atplace atp), i_opt)) rhos_for_result)}, - trs'), acc) - end - | BLOCKF64 (alloc, trs) => - let val acc = maybe_add regvar_env (drop_atplace alloc, acc) + in (CCALL ({name = name, + mu_result = mu_result, + rhos_for_result = + map (fn (atp, i_opt) => + (S(atp), i_opt)) rhos_for_result}, + trs'), acc) + end + | BLOCKF64 (alloc, trs) => + let val acc = maybe_add regvar_env (alloc, acc) val (trs', acc) = List.foldr (fn (tr, (trs, acc)) => let val (tr', acc) = drop env tr acc in (tr'::trs, acc) end) ([], acc) trs - in (BLOCKF64(S(drop_atplace alloc), trs'), acc) + in (BLOCKF64(S(alloc), trs'), acc) end - | SCRATCHMEM (n,alloc) => - let val acc = maybe_add regvar_env (drop_atplace alloc, acc) - in (SCRATCHMEM(n,S(drop_atplace alloc)), acc) + | SCRATCHMEM (n,alloc) => + let val acc = maybe_add regvar_env (alloc, acc) + in (SCRATCHMEM(n,S(alloc)), acc) end - | EXPORT(i,tr) => + | EXPORT(i,tr) => let val (tr', acc) = drop env tr acc - in (EXPORT (i,tr'), acc) - end - | RESET_REGIONS ({force, alloc,regions_for_resetting}, tr) => + in (EXPORT (i,tr'), acc) + end + | RESET_REGIONS ({force, regions_for_resetting,liveset}, tr) => let - val acc = maybe_add regvar_env (alloc, acc) - val regions_for_resetting' = map drop_atplace regions_for_resetting + val regions_for_resetting' = regions_for_resetting val acc = List.foldl (maybe_add regvar_env) acc regions_for_resetting' val (tr', acc) = drop env tr acc - val regions_for_resetting' = - if region_inference() then regions_for_resetting' - else nil + val regions_for_resetting' = + if region_inference() then regions_for_resetting' + else nil in - (RESET_REGIONS ({force=force,alloc=S(drop_atplace alloc), - regions_for_resetting = regions_for_resetting'}, - tr'), acc) + (RESET_REGIONS ({force=force, + liveset=liveset, + regions_for_resetting = regions_for_resetting'}, + tr'), acc) + end + | FRAME{declared_lvars,declared_excons} => + let val lvars = map #lvar declared_lvars + val lvar_env' = List.foldl (fn (lv, env') => + (case lookup lvar_env lv + of SOME bool_list => add(lv,bool_list,env') + | NONE => die "drop.FRAME.lv not in env")) empty lvars + val _ = export_env := lvar_env' + in (e, acc) end - | FRAME{declared_lvars,declared_excons} => - let val lvars = map #lvar declared_lvars - val lvar_env' = List.foldl (fn (lv, env') => - (case lookup lvar_env lv - of SOME bool_list => add(lv,bool_list,env') - | NONE => die "drop.FRAME.lv not in env")) empty lvars - val _ = export_env := lvar_env' - in (e, acc) - end ) handle AbortExpression => raise AbortExpression | _ => (log "\nDropRegions failed at expression:"; @@ -571,43 +535,40 @@ structure DropRegions: DROP_REGIONS = end fun drop_regions (env:env, - PGM{expression, - export_datbinds, - import_vars, - export_vars=(export_lvars,export_excons,export_rhos), - export_basis, - export_Psi}) = + PGM{expression, + export_datbinds, + import_vars, + export_vars=(export_lvars,export_excons,export_rhos), + export_basis, + export_Psi}) = let val _ = export_env := empty - val (expression', acc) = drop (env, empty_regenv) expression [] + val (expression', acc) = drop (env, empty_regenv) expression [] handle AbortExpression => die "drop_regions failed" val _ = case acc of [] => () | _ => die "non-empty list of regions to be dropped at top-level" - val env' = ! export_env - val _ = export_env := empty - val export_rhos' = List.foldl (fn (rho, places) => - if word_or_bot_region rho then places - else rho::places) [] export_rhos + val env' = ! export_env + val _ = export_env := empty + val export_rhos' = List.foldl (fn (rho, places) => + if bot_region rho then places + else rho::places) [] export_rhos in (PGM{expression=expression', - export_datbinds=export_datbinds, - import_vars=import_vars, - export_vars=(export_lvars, export_excons,export_rhos'), - export_basis=export_basis,export_Psi=export_Psi}, env') + export_datbinds=export_datbinds, + import_vars=import_vars, + export_vars=(export_lvars, export_excons,export_rhos'), + export_basis=export_basis,export_Psi=export_Psi}, env') end - fun drop_places places = List.filter (not o word_region) places - - val pu_env_res = - let fun toInt (FIXBOUND _) = 0 - | toInt NOTFIXBOUND = 1 - fun fun_FIXBOUND _ = - Pickle.con1 FIXBOUND (fn FIXBOUND a => a | _ => die "pu_env_res.FIXBOUND") - (Pickle.listGen Pickle.bool) - val fun_NOTFIXBOUND = Pickle.con0 NOTFIXBOUND - in Pickle.dataGen("DropRegions.env_res",toInt,[fun_FIXBOUND,fun_NOTFIXBOUND]) - end + let fun toInt (FIXBOUND _) = 0 + | toInt NOTFIXBOUND = 1 + fun fun_FIXBOUND _ = + Pickle.con1 FIXBOUND (fn FIXBOUND a => a | _ => die "pu_env_res.FIXBOUND") + (Pickle.listGen Pickle.bool) + val fun_NOTFIXBOUND = Pickle.con0 NOTFIXBOUND + in Pickle.dataGen("DropRegions.env_res",toInt,[fun_FIXBOUND,fun_NOTFIXBOUND]) + end val pu_env : env Pickle.pu = - LvarMap.pu Lvars.pu pu_env_res + LvarMap.pu Lvars.pu pu_env_res end diff --git a/src/Compiler/Regions/EFFECT.sig b/src/Compiler/Regions/EFFECT.sig index 071e06134..7df677700 100644 --- a/src/Compiler/Regions/EFFECT.sig +++ b/src/Compiler/Regions/EFFECT.sig @@ -2,10 +2,9 @@ signature EFFECT = sig - datatype runType = WORD_RT | STRING_RT | PAIR_RT | TOP_RT | BOT_RT + datatype runType = STRING_RT | PAIR_RT | TOP_RT | BOT_RT | ARRAY_RT | REF_RT | TRIPLE_RT - val is_wordsize: runType -> bool val ord_runType: runType -> int val show_runType: runType -> string val lub_runType: runType * runType -> runType @@ -26,7 +25,6 @@ sig val removeatomiceffects: (effect * 'a)list * effect list-> (effect * 'a)list val get_visited: effect -> bool ref - val get_instance: effect -> effect option ref (* setInstance(rho,rho') sets the instance field of rho @@ -47,7 +45,6 @@ sig val is_get : effect -> bool val rho_of : effect -> place (* should only be applied to PUT and GET nodes *) - (* acc_rho effect acc conses effect onto acc iff acc is a RHO node which has a put effect on it. When effect is consed onto acc, its visited field is set. @@ -75,7 +72,6 @@ sig val info: cone -> string val toplevel_region_withtype_top : effect - val toplevel_region_withtype_word : effect val toplevel_region_withtype_bot : effect val toplevel_region_withtype_string : effect val toplevel_region_withtype_pair : effect @@ -117,8 +113,8 @@ sig val restrain : cone -> cone (* B' = restrain(B): B must contain at least one level. - Lower (by one) the levels of region and effect variables in the topmost - layer of B. B' is B with the topmost layer removed. + Lower (by one) the levels of region and effect variables in the topmost + layer of B. B' is B with the topmost layer removed. *) val sort: effect list -> effect list @@ -129,31 +125,33 @@ sig val level: cone -> int val resetCount: unit -> unit (* set initial regionid/effectid to that provided - * on command-line with "-regionvar n". *) + * on command-line with "-regionvar n". *) val getCountFirstLast: unit -> int * int (* used for storing count numbers in MLB/f.rv file - * when "-c -regionvar N" is given as argument to - * mlkit executable; used for region profiling. *) + * when "-c -regionvar N" is given as argument to + * mlkit executable; used for region profiling. *) + val freshRho: cone -> effect * cone val freshRhos: place list * cone -> place list * cone + val freshRhosPreserveRT: place list * cone -> place list * cone val renameRhos: place list * cone -> place list * cone (* fresh variables, preserve runtime types and pix *) val cloneRhos: place list * cone -> place list * cone (* fresh variables, preserve runtime types, pix = ~1 *) - val freshRhoRegVar: cone * RegVar.regvar -> effect * cone + val freshRhoRegVar : cone * RegVar.regvar -> effect * cone + val freshRhoWithTy : runType * cone -> effect * cone + val freshRhoWithTy' : RegVar.regvar option * runType * cone -> effect * cone - val freshRhoWithTy: runType * cone -> effect * cone - val freshRhoWithTy': RegVar.regvar option * runType * cone -> effect * cone - val setRunType: place -> runType -> unit - val get_place_ty: place -> runType option + val setRunType : place -> runType -> unit + val get_place_ty : place -> runType option - val setRegVar : place -> RegVar.regvar -> unit - val getRegVar : place -> RegVar.regvar option + val setRegVar : place -> RegVar.regvar -> unit + val getRegVar : place -> RegVar.regvar option - val freshEps: cone -> effect * cone - val freshEpss: effect list * cone -> effect list * cone - val renameEpss: effect list * cone -> effect list * cone - val cloneEpss: effect list * cone -> effect list * cone + val freshEps : cone -> effect * cone + val freshEpss : effect list * cone -> effect list * cone + val renameEpss : effect list * cone -> effect list * cone + val cloneEpss : effect list * cone -> effect list * cone val mkPut: effect -> effect (* argument must represent a region variable *) diff --git a/src/Compiler/Regions/Effect.sml b/src/Compiler/Regions/Effect.sml index 1d27668bd..f6970681e 100644 --- a/src/Compiler/Regions/Effect.sml +++ b/src/Compiler/Regions/Effect.sml @@ -1,6 +1,6 @@ structure Effect: EFFECT = (* comment out this signature before - * running TestEffect *) + * running TestEffect *) struct structure PP = PrettyPrint structure G = DiGraph @@ -12,37 +12,32 @@ struct menu=["Control", "region variable initial value"], desc= "Uses the provided number as the id of the first\n\ \generated region variable. When this option is\n\ - \provided together with the -c option, a file f.rv\n\ - \is written in the MLB/ directory with two numbers\n\ - \in it: the id for the first region variable\n\ - \generated and the id for the last region variable\n\ - \generated. The number given must be greater than\n\ - \any id for a top-level region/effect variable (>9)."} + \provided together with the -c option, a file f.rv\n\ + \is written in the MLB/ directory with two numbers\n\ + \in it: the id for the first region variable\n\ + \generated and the id for the last region variable\n\ + \generated. The number given must be greater than\n\ + \any id for a top-level region/effect variable (>9)."} val print_rho_levels = Flags.add_bool_entry {long="print_rho_levels", short=NONE, item=ref false, neg=false, menu=["Layout", "print levels of region variables"], desc= "Print levels of region and effect variables in types and\n\ - \intermediate forms. Levels control quantification of\n\ - \region and effect variables."} + \intermediate forms. Levels control quantification of\n\ + \region and effect variables."} val print_rho_types = Flags.add_bool_entry {long="print_rho_types", short=NONE, item=ref false, neg=false, - menu=["Layout","print runtime types of region variables"], desc= - "Print region types of region variables in types and\n\ - \intermediate forms. Possible region types are:\n\ - \ w Type of regions containing only word values; these\n\ - \ regions are dropped from the program because word\n\ - \ values are represented unboxed.\n\ - \ p Type of regions containing pairs.\n\ - \ a Type of regions containing arrays.\n\ - \ r Type of regions containing references.\n\ - \ t Type of regions containing triples.\n\ - \ s Type of regions containing strings.\n\ - \ B Type of regions associated with type variables.\n\ - \ Regions of this type do not exist at runtime.\n\ - \ T Type of regions containing other than the above\n\ - \ kinds of values."} + menu=["Layout","print runtime types of region variables"], desc= + "Print region types of region variables in types and\n\ + \intermediate forms. Possible region types are:\n\ + \ p Type of regions containing pairs.\n\ + \ a Type of regions containing arrays.\n\ + \ r Type of regions containing references.\n\ + \ t Type of regions containing triples.\n\ + \ s Type of regions containing strings.\n\ + \ T Type of regions containing other than the above\n\ + \ kinds of values."} val print_regions = Flags.add_bool_entry {long="print_regions", short=SOME "Pregions", item=ref true, neg=true, @@ -57,7 +52,8 @@ struct type StringTree = PP.StringTree fun die s = (print ("Effect." ^ s ^ "\n"); Crash.impossible("Effect." ^ s)) - fun log_tree (tr: StringTree) = PP.outputTree(fn s => TextIO.output(!Flags.log, s), tr, !Flags.colwidth) + fun log_tree (tr: StringTree) = + PP.outputTree(fn s => TextIO.output(!Flags.log, s), tr, !Flags.colwidth) fun say i = TextIO.output(TextIO.stdOut, i) fun say_etas (trl: StringTree list) = PP.outputTree(fn s => TextIO.output(TextIO.stdOut, s), @@ -69,29 +65,24 @@ struct fun noSome (NONE, s) = die s | noSome (SOME v, _) = v - datatype runType = WORD_RT | STRING_RT | PAIR_RT | TOP_RT | BOT_RT + datatype runType = STRING_RT | PAIR_RT | TOP_RT | BOT_RT | ARRAY_RT | REF_RT | TRIPLE_RT - fun ord_runType WORD_RT = 0 - | ord_runType STRING_RT = 1 + fun ord_runType STRING_RT = 1 | ord_runType PAIR_RT = 2 | ord_runType ARRAY_RT = 3 | ord_runType REF_RT = 4 | ord_runType TRIPLE_RT = 5 | ord_runType TOP_RT = 6 - | ord_runType BOT_RT = 7 - - fun is_wordsize WORD_RT = true - | is_wordsize _ = false + | ord_runType BOT_RT = 7 (* for supporting explicit region declatations *) fun show_runType tau = case tau of - WORD_RT => "w" - | PAIR_RT => "p" + PAIR_RT => "p" | STRING_RT => "s" - | ARRAY_RT => "a" - | REF_RT => "r" - | TRIPLE_RT => "t" + | ARRAY_RT => "a" + | REF_RT => "r" + | TRIPLE_RT => "t" | TOP_RT => "T" | BOT_RT => "B" @@ -122,7 +113,7 @@ struct instance : einfo G.node option ref, pix: int ref} | UNION of {represents: einfo G.node list option} - | PUT | GET | WORDEFFECT + | PUT | GET | RHO of {put: einfo G.node option, get: einfo G.node option, key: key, @@ -134,54 +125,54 @@ struct pinned: bool} fun layout_einfo einfo = - case einfo of - EPS{key,level,...} => PP.LEAF("e"^ show_key key - ^ (if print_rho_levels() then - "(" ^ show_level level ^ ")" - else "")) - | PUT => PP.LEAF "put" - | GET => PP.LEAF "get" - | UNION _=> PP.LEAF "U" - | WORDEFFECT => PP.LEAF "" (*"U"*) - | RHO{key,level,ty,put,rv_opt,...} => - let val n = case rv_opt of - NONE => "r" ^ show_key key - | SOME rv => "`" ^ RegVar.pr rv ^ "_" ^ show_key key - in PP.LEAF (n ^ - (if print_rho_types() then show_runType ty - else "") ^ - (if print_rho_levels() then "(" ^ show_level level ^ ")" - else "") - ) - end + case einfo of + EPS{key,level,...} => + PP.LEAF("e" ^ show_key key + ^ (if print_rho_levels() then + "(" ^ show_level level ^ ")" + else "")) + | PUT => PP.LEAF "put" + | GET => PP.LEAF "get" + | UNION _ => PP.LEAF "U" + | RHO{key,level,ty,put,rv_opt,...} => + let val n = case rv_opt of + NONE => "r" ^ show_key key + | SOME rv => "`" ^ RegVar.pr rv ^ "_" ^ show_key key + in PP.LEAF (n ^ + (if print_rho_types() then show_runType ty + else "") ^ + (if print_rho_levels() then "(" ^ show_level level ^ ")" + else "") + ) + end type effect = einfo G.node type place = effect val empty = G.mk_node (UNION{represents = NONE}) - fun eq_effect(node1, node2) = G.eq_nodes(node1,node2) + fun eq_effect (node1, node2) = G.eq_nodes(node1,node2) fun layout_effect e = G.layout_node layout_einfo e fun layout_effect_deep e = G.layout_nodes_deep layout_einfo [e] fun get_instance effect = - case G.find_info effect of - EPS{instance, ...} => instance - | RHO{instance, ...} => instance - | _ => die "get_instance" + case G.find_info effect of + EPS{instance, ...} => instance + | RHO{instance, ...} => instance + | _ => die "get_instance" fun is_arrow_effect effect = - case G.find_info effect of - EPS _ => true - | _ => false + case G.find_info effect of + EPS _ => true + | _ => false fun is_union (UNION _) = true | is_union _ = false fun is_rho effect = - case G.find_info effect of - RHO _ => true - | _ => false + case G.find_info effect of + RHO _ => true + | _ => false (* acc_rho effect acc conses effect onto acc iff acc is a RHO node which has a put effect on it. @@ -190,8 +181,8 @@ struct fun acc_rho effect (acc: effect list): effect list = case (G.find_info effect, G.find_visited effect) of - (RHO{put = SOME _, ...}, r as ref false) => (r:= true; effect :: acc) - | _ => acc + (RHO{put = SOME _, ...}, r as ref false) => (r:= true; effect :: acc) + | _ => acc fun pinned_explicit_rho effect : regvar option = case G.find_info effect of @@ -227,10 +218,10 @@ struct | _ => NONE fun level_of effect : int option = - case G.find_info effect of - EPS{level,key,...} => SOME(!level) - | RHO{level,key,...} => SOME(!level) - | _ => NONE + case G.find_info effect of + EPS{level,key,...} => SOME(!level) + | RHO{level,key,...} => SOME(!level) + | _ => NONE fun setkey generator effect = case G.find_info effect of @@ -249,19 +240,19 @@ struct | _ => die "key_of_rho (not a RHO)" fun get_key_of_eps effect : int = - case G.find_info effect of - EPS{key as ref k,...} => k - | _ => die "GetKeyOfEps" + case G.find_info effect of + EPS{key as ref k,...} => k + | _ => die "GetKeyOfEps" fun get_place_ty effect : runType option = - case G.find_info effect of - RHO{ty,...} => SOME ty - | _ => NONE + case G.find_info effect of + RHO{ty,...} => SOME ty + | _ => NONE fun rho_of node = case G.out_of_node node of - [rho_node] => rho_node - | _ => die "rho_of" + [rho] => rho + | _ => die "rho_of" fun edge (from,to) = G.mk_edge(from,to); @@ -276,63 +267,52 @@ struct end fun mkPut (n: effect) = (* n must represent a region variable*) - let - in - case G.find_info n of - RHO{put=SOME n',...} => n' (* hash consing *) - | RHO{put=NONE,key,level,get,instance,pix,ty,rv_opt,pinned} => - let (* create new node *) - val new = G.mk_node PUT - in G.set_info n (RHO{put=SOME new, - get=get,key=key,level=level,instance=instance, - pix=pix,ty=ty,rv_opt=rv_opt,pinned=pinned}); - G.mk_edge(new,n); - new - end - | _ => die "mkPut: node does not represent region variable" - end + case G.find_info n of + RHO{put=SOME n',...} => n' (* hash consing *) + | RHO{put=NONE,key,level,get,instance,pix,ty,rv_opt,pinned} => + let val new = G.mk_node PUT (* create new node *) + in G.set_info n (RHO{put=SOME new, + get=get,key=key,level=level,instance=instance, + pix=pix,ty=ty,rv_opt=rv_opt,pinned=pinned}); + G.mk_edge(new,n); + new + end + | _ => die "mkPut: node does not represent region variable" fun mkGet (n: effect) = (* n must represent a region variable*) - let - in - case G.find_info n of - RHO{get=SOME n',...} => n' (* hash consing *) - | RHO{get=NONE,key,level,put,instance,pix,ty,rv_opt,pinned} => - let (* create new node *) - val new = G.mk_node GET - in G.set_info n (RHO{get=SOME new, - put=put,key=key,level=level,instance=instance, - pix=pix,ty=ty,rv_opt=rv_opt,pinned=pinned}); - G.mk_edge(new,n); - new - end - | _ => die "mkGet: node does not represent region variable" - end + case G.find_info n of + RHO{get=SOME n',...} => n' (* hash consing *) + | RHO{get=NONE,key,level,put,instance,pix,ty,rv_opt,pinned} => + let val new = G.mk_node GET (* create new node *) + in G.set_info n (RHO{get=SOME new, + put=put,key=key,level=level,instance=instance, + pix=pix,ty=ty,rv_opt=rv_opt,pinned=pinned}); + G.mk_edge(new,n); + new + end + | _ => die "mkGet: node does not represent region variable" fun mkUnion (l : effect list) = - let (* val _ = case l of nil => print ("Effect.mkUnion: empty list!!!\n") | _ => () *) - val new = G.mk_node(UNION{represents=NONE}) - in - app (fn n => G.mk_edge(new, n)) l; - new + let val new = G.mk_node(UNION{represents=NONE}) + in app (fn n => G.mk_edge(new, n)) l; + new end fun mkEps (level,key) = G.mk_node(EPS{key = ref key, level = ref level, - represents = NONE, pix = ref ~1, - instance = ref NONE}) + represents = NONE, pix = ref ~1, + instance = ref NONE}) + fun remove_duplicates effects = - let fun loop([], acc) = acc - | loop(effect::rest, acc) = + let fun loop([], acc) = acc + | loop(effect::rest, acc) = let val r = (G.find_visited effect) in if !r then loop(rest,acc) else (r:= true; loop(rest, effect::acc)) end - - val result = loop(effects,[]) - in - app (fn node => G.find_visited node:= false) result; - result - end + val result = loop(effects,[]) + in app (fn node => G.find_visited node:= false) result; + result + end (*********************************) (* cones *) @@ -347,78 +327,6 @@ struct fun size m = fold (fn (_,acc) => acc+1) 0 m val fromSortedList = addList end -(* - structure ConeLayer(*:MONO_FINMAP*) = - struct - val lsize = 10 - type dom = int - type 'b map = (int*'b)list array - - val empty = Array.array((*lsize*)0,[]:(int*effect)list) - fun mkEmpty() = Array.array(lsize,[]) - - fun add(k0,d0, t) = - let val i = k0 mod lsize - val l = Array.sub(t,i) - in Array.update(t, i, (k0,d0)::l); t - end (* handle _ => die ("add: lsize = " ^ Int.toString lsize ^ " , k0 = " ^ Int.toString k0) *) - - fun remove(k0, t) = - let val i = k0 mod lsize - (*was: val l' = List.filter (fn (i',_) =>i'<>i)(Array.sub(t,i)) ; ME 2001-03-07*) - val l' = List.filter (fn (k,_) =>k<>k0)(Array.sub(t,i)) - in - Array.update(t, i, l'); - SOME t - end handle _ => NONE - - fun range (m:'b map) : 'b list = - let - fun loop(n, acc) = - if n < 0 then acc - else loop(n-1, map #2 (Array.sub(m, n)) @ acc) - in - loop(lsize-1,[]) - end - - fun size (m:'b map) : int = - let fun loop(n, acc) = - if n < 0 then acc - else loop(n-1, List.length (Array.sub(m, n)) + acc) - in loop(lsize-1, 0) - end - - fun fromSortedList l a= - foldl (fn ((d,r),a) => add(d,r, a)) a l - - type StringTree = PP.StringTree - type Report = Report.Report - - local - fun list (m:'b map) : (dom * 'b) list = - let fun loop(n, acc) = if n<0 then acc - else loop(n-1, Array.sub(m, n) @ acc) - in loop(lsize-1,[]) - end - in - fun layoutMap {start, eq=equal, sep, finish} layoutDom layoutRan m = - PP.NODE {start=start, - finish=finish, - children=map (fn (d,r) => - PP.NODE {start="", - finish="", - children=[layoutDom d, - layoutRan r], - indent=3, - childsep=PP.RIGHT equal}) - (list m), - indent=3, - childsep=PP.RIGHT sep} - fun reportMap f t = Report.flatten(map f (list t)) - val reportMapSORTED = reportMap - end - end -*) type coneLayer = effect ConeLayer.map @@ -465,12 +373,12 @@ struct handle _ => NONE fun reset (_,array) = (* reset levels 0 to max_cone_level -1 in array *) - let fun reset_loop i = - if i >= max_cone_level then () - else (Array.update(array, i, ConeLayer.empty); - reset_loop (i+1)) - in reset_loop 0 - end + let fun reset_loop i = + if i >= max_cone_level then () + else (Array.update(array, i, ConeLayer.empty); + reset_loop (i+1)) + in reset_loop 0 + end fun layoutMap {start: string, eq: string, sep: string, finish: string} layoutInt @@ -482,11 +390,11 @@ struct else (i,Array.sub(table, i)) :: get_layers(i+1) in PP.NODE{start = start, finish = finish, indent = 3, childsep=PP.RIGHT sep, children= map (fn (d,r) => - PP.NODE {start="", - finish="", - children=[layoutInt d, layoutConeLayer r], - indent=3, - childsep=PP.RIGHT sep}) + PP.NODE {start="", + finish="", + children=[layoutInt d, layoutConeLayer r], + indent=3, + childsep=PP.RIGHT sep}) (get_layers 1)} end @@ -532,12 +440,12 @@ struct SOME layer' => (n,Cone.add(!level,layer',c)) (* replaces old layer*) | _ => die ("remove: failed to remove effect " ^ PP.flatten1 (layout_effect effect) ^ - "\nfrom cone at level " ^ Int.toString (!level) ^ - "\n(no key " ^ Int.toString key ^ " in cone)" ^ - "\n(key(effect) = " ^ - (case get_key_of_eps_or_rho effect of + "\nfrom cone at level " ^ Int.toString (!level) ^ + "\n(no key " ^ Int.toString key ^ " in cone)" ^ + "\n(key(effect) = " ^ + (case get_key_of_eps_or_rho effect of NONE => "NONE" - | SOME k => Int.toString k))) + | SOME k => Int.toString k))) (* add "effect" with "key" to "cone" at "level" *) @@ -650,26 +558,26 @@ struct val firstRef : int option ref = ref NONE (* first rho/eps declared in a program unit *) in fun set_init_count () = (* to be called after declaration of top-level effects below *) - case !init_count of - NONE => init_count := SOME (!count) - | SOME _ => die "init_count already set" + case !init_count of + NONE => init_count := SOME (!count) + | SOME _ => die "init_count already set" fun resetCount () = (* to be called before region inference in Compile.sml *) - case !init_count of - SOME c => - let val first = max (c, regionvarInitial()) - in count := first ; firstRef := SOME first - end - | NONE => die "init_count not set" + case !init_count of + SOME c => + let val first = max (c, regionvarInitial()) + in count := first ; firstRef := SOME first + end + | NONE => die "init_count not set" fun freshInt () = !count before inc count fun getCountFirstLast () = - let val last = !count - in case !firstRef of - SOME first => (first,last) - | NONE => die "getCountFirstLast: error" - end + let val last = !count + in case !firstRef of + SOME first => (first,last) + | NONE => die "getCountFirstLast: error" + end end (* freshRho(cone): Generate a fresh region variable @@ -756,33 +664,33 @@ struct fun freshRhosPreserveRT (rhos,c: cone): effect list * cone = foldr (fn (rho,(rhos',c)) => - (case get_place_ty rho - of NONE => die "freshRhosPreserveRT" - | SOME rt => - let val (rho',c) = freshRhoWithTy(rt, c) - in (rho'::rhos',c) - end)) ([],c) rhos + (case get_place_ty rho of + NONE => die "freshRhosPreserveRT" + | SOME rt => + let val (rho',c) = freshRhoWithTy(rt, c) + in (rho'::rhos',c) + end)) ([],c) rhos fun setRunType (place:place) (rt: runType) : unit = case G.find_info place of - RHO{put,get,key,level,instance,pix,ty,rv_opt,pinned} => - G.set_info place (RHO{put=put,get=get,key=key,level=level,instance=instance, + RHO{put,get,key,level,instance,pix,ty,rv_opt,pinned} => + G.set_info place (RHO{put=put,get=get,key=key,level=level,instance=instance, pix=pix,ty=rt,rv_opt=rv_opt,pinned=pinned}) - | _ => die "setRunType: node is not a region variable" + | _ => die "setRunType: node is not a region variable" fun setRegVar (place:place) (rv: RegVar.regvar) : unit = case G.find_info place of - RHO{put,get,key,level,instance,pix,ty,rv_opt=NONE,pinned} => - G.set_info place (RHO{put=put,get=get,key=key,level=level,instance=instance, + RHO{put,get,key,level,instance,pix,ty,rv_opt=NONE,pinned} => + G.set_info place (RHO{put=put,get=get,key=key,level=level,instance=instance, pix=pix,ty=ty,rv_opt=SOME rv,pinned=pinned}) | RHO{rv_opt=SOME rv',...} => if RegVar.eq(rv,rv') then () else die "setRegVar: explicit regvar already set" - | _ => die "setRegVar: node is not a region variable" + | _ => die "setRegVar: node is not a region variable" fun getRegVar (place:place) : RegVar.regvar option = case G.find_info place of - RHO{put,get,key,level,instance,pix,ty,rv_opt,pinned} => rv_opt - | _ => die "getRegVar: node is not a region variable" + RHO{put,get,key,level,instance,pix,ty,rv_opt,pinned} => rv_opt + | _ => die "getRegVar: node is not a region variable" (* freshEps(cone): Generate a fresh effect variable at the topmost layer of cone and insert it in @@ -795,7 +703,7 @@ struct end fun freshEpss (epss, c: cone): effect list * cone = - foldr (fn (eps,(epss',c)) => + foldr (fn (eps,(epss',c)) => let val (eps',c) = freshEps c in (eps'::epss',c) end) ([],c) epss @@ -806,153 +714,95 @@ struct local (* Atomic effects put(r) and get(r) are memorized for each r (see - * the definitions of mkPut and mkGet). For the word region (r2), - * we initially set the memorized node to the ``empty effect'' - * WORDEFFECT, which is then returned by mkPut and mkGet when called - * with r2. Thus, no atomic effects on the form put(r2) or get(r2) - * appear in effects, I conjecture! ME 1998-09-03. To make this work, - * the unification of two region variables (RHOs) needs also unify - * correctly the cached put and get effects (which may be WORDEFFECTs) - * annotated on the RHOs -- see the code for aux_combine below. + * the definitions of mkPut and mkGet) *) - - fun freshRhoWithWordTy (cone:cone as (n, c)): effect * cone = - let val key = freshInt() - val empty = G.mk_node WORDEFFECT - val node =G.mk_node(RHO{key = ref key, level = ref n, - put = SOME empty, get = SOME empty, instance = ref NONE, - pix = ref ~1, ty = WORD_RT,rv_opt=NONE,pinned=false}) - in (node, add(node, n, key, cone)) - end in val (toplevel_region_withtype_top, initCone) = freshRhoWithTy(TOP_RT,push emptyCone) (*1*) - val (toplevel_region_withtype_word, initCone) = freshRhoWithWordTy(initCone) (*2*) - val (toplevel_region_withtype_bot, initCone) = freshRhoWithTy(BOT_RT,initCone) (*3*) - val (toplevel_region_withtype_string, initCone) = freshRhoWithTy(STRING_RT,initCone) (*4*) - val (toplevel_region_withtype_pair, initCone) = freshRhoWithTy(PAIR_RT,initCone) (*5*) - val (toplevel_region_withtype_array, initCone) = freshRhoWithTy(ARRAY_RT,initCone) (*6*) - val (toplevel_region_withtype_ref, initCone) = freshRhoWithTy(REF_RT,initCone) (*7*) - val (toplevel_region_withtype_triple, initCone) = freshRhoWithTy(TRIPLE_RT,initCone) (*8*) - val (toplevel_arreff, initCone) = freshEps(initCone) (*9*) + val (toplevel_region_withtype_bot, initCone) = freshRhoWithTy(BOT_RT,push emptyCone) (*2*) + val (toplevel_region_withtype_string, initCone) = freshRhoWithTy(STRING_RT,initCone) (*3*) + val (toplevel_region_withtype_pair, initCone) = freshRhoWithTy(PAIR_RT,initCone) (*4*) + val (toplevel_region_withtype_array, initCone) = freshRhoWithTy(ARRAY_RT,initCone) (*5*) + val (toplevel_region_withtype_ref, initCone) = freshRhoWithTy(REF_RT,initCone) (*6*) + val (toplevel_region_withtype_triple, initCone) = freshRhoWithTy(TRIPLE_RT,initCone) (*7*) + val (toplevel_arreff, initCone) = freshEps(initCone) (*8*) val _ = set_init_count() - val toplevel_effects = [toplevel_region_withtype_top, toplevel_region_withtype_word, - toplevel_region_withtype_bot, toplevel_region_withtype_string, - toplevel_region_withtype_pair, toplevel_region_withtype_array, - toplevel_region_withtype_ref, toplevel_region_withtype_triple, - toplevel_arreff] + val toplevel_effects = [toplevel_region_withtype_top, toplevel_region_withtype_bot, + toplevel_region_withtype_string, + toplevel_region_withtype_pair, toplevel_region_withtype_array, + toplevel_region_withtype_ref, toplevel_region_withtype_triple, + toplevel_arreff] end val toplevel_puts_and_gets = - let val toplevel_rhos = [toplevel_region_withtype_top, (* toplevel_region_withtype_word, ME 1998-09-03 *) - toplevel_region_withtype_bot, toplevel_region_withtype_string, - toplevel_region_withtype_pair, toplevel_region_withtype_array, - toplevel_region_withtype_ref, toplevel_region_withtype_triple] - val puts = map mkPut toplevel_rhos - val gets = map mkGet toplevel_rhos - val puts_and_gets = puts@gets - in app (fn to => edge(toplevel_arreff,to)) puts_and_gets - ; puts_and_gets - end - - (* Optimization: For regions of type word we reuse the top-level - * region. Word regions are dropped anyway. When the flag - * region_inference is disabled, fresh regions are not - * generated. *) + let val toplevel_rhos = [toplevel_region_withtype_top, toplevel_region_withtype_bot, + toplevel_region_withtype_string, + toplevel_region_withtype_pair, toplevel_region_withtype_array, + toplevel_region_withtype_ref, toplevel_region_withtype_triple] + val puts = map mkPut toplevel_rhos + val gets = map mkGet toplevel_rhos + val puts_and_gets = puts@gets + in app (fn to => edge(toplevel_arreff,to)) puts_and_gets + ; puts_and_gets + end val region_inference = Flags.is_on0 "region_inference" fun maybeFreshRhoWithTy (p as (rt,cone)) = if region_inference() then freshRhoWithTy p - else case rt - of TOP_RT => (toplevel_region_withtype_top,cone) - | WORD_RT => die "maybeFreshRhoWithTy.not possible" - | BOT_RT => freshRhoWithTy p (* toplevel_region_withtype_bot *) - | STRING_RT => (toplevel_region_withtype_string,cone) - | PAIR_RT => (toplevel_region_withtype_pair,cone) - | ARRAY_RT => (toplevel_region_withtype_array,cone) - | REF_RT => (toplevel_region_withtype_ref,cone) - | TRIPLE_RT => (toplevel_region_withtype_triple,cone) - - val freshRhoWithTy = fn (WORD_RT,cone) => (toplevel_region_withtype_word, cone) - | p => freshRhoWithTy p (*maybeFreshRhoWithTy p *) + else case rt of + TOP_RT => (toplevel_region_withtype_top,cone) + | BOT_RT => (toplevel_region_withtype_bot,cone) + | STRING_RT => (toplevel_region_withtype_string,cone) + | PAIR_RT => (toplevel_region_withtype_pair,cone) + | ARRAY_RT => (toplevel_region_withtype_array,cone) + | REF_RT => (toplevel_region_withtype_ref,cone) + | TRIPLE_RT => (toplevel_region_withtype_triple,cone) + + val freshRhoWithTy = fn p => freshRhoWithTy p (*maybeFreshRhoWithTy p *) fun toplevelRhoFromTy rt : effect = case rt of - TOP_RT => toplevel_region_withtype_top - | WORD_RT => toplevel_region_withtype_word - | BOT_RT => toplevel_region_withtype_bot - | STRING_RT => toplevel_region_withtype_string - | PAIR_RT => toplevel_region_withtype_pair - | ARRAY_RT => toplevel_region_withtype_array - | REF_RT => toplevel_region_withtype_ref - | TRIPLE_RT => toplevel_region_withtype_triple + TOP_RT => toplevel_region_withtype_top + | BOT_RT => toplevel_region_withtype_bot + | STRING_RT => toplevel_region_withtype_string + | PAIR_RT => toplevel_region_withtype_pair + | ARRAY_RT => toplevel_region_withtype_array + | REF_RT => toplevel_region_withtype_ref + | TRIPLE_RT => toplevel_region_withtype_triple fun setInstance (node,node') = (* see explanation in signature *) - let (* val key = - case get_level_and_key node of - SOME (_,k) => !k - | NONE => die "setInstance: not rho or eps" - val _ = if key <= 9 then die ("setInstance: instantiating toplevel effect " ^ PP.flatten1 (layout_effect node)) - else () *) - (* This check is not ok (I think) because sigmas may decrease in - * the number of bound variables during region inference; see RegInf... - *) - in - get_instance node := SOME node' - end + get_instance node := SOME node' fun clearInstance (node,_) = get_instance node := NONE - (* Picklers *) val pu_intref = Pickle.refOneGen Pickle.int val pu_runType = Pickle.enumGen ("Effect.runType", - [WORD_RT, STRING_RT, PAIR_RT, TOP_RT, BOT_RT, - ARRAY_RT, REF_RT, TRIPLE_RT]) + [STRING_RT, PAIR_RT, TOP_RT, BOT_RT, + ARRAY_RT, REF_RT, TRIPLE_RT]) val pu_runTypes = Pickle.listGen pu_runType fun maybeNewHashInfo i = case i of - PUT => NONE - | GET => NONE - | WORDEFFECT => NONE - | UNION _ => NONE - | RHO {key=ref k,...} => SOME k - | EPS {key=ref k,...} => SOME k + PUT => NONE + | GET => NONE + | UNION _ => NONE + | RHO {key=ref k,...} => SOME k + | EPS {key=ref k,...} => SOME k val pu_node_nodes : einfo Pickle.pu -> einfo G.node Pickle.pu * einfo G.node list Pickle.pu = - let -(* - fun eq_eff (e1,e2) = - let fun check_eq is_kind key = - is_kind e1 andalso is_kind e2 andalso key e1 = key e2 - in check_eq is_rho key_of_rho - orelse check_eq is_put (key_of_rho o rho_of) - orelse check_eq is_get (key_of_rho o rho_of) - orelse check_eq is_arrow_effect get_key_of_eps - end -*) - fun key_effect e = - case get_key_of_eps_or_rho e of - SOME i => if i <> 0 then i else die "pu_node" - | NONE => 0 (* could be optimized! *) -(* - fun checkRho1 e = - case get_level_and_key e of - SOME(_,ref k) => (if k = 1 then - (if not(eq_effect(toplevel_region_withtype_top,e)) then die "checkRho1" - else ()) - else ()) - | NONE => () -*) + let fun key_effect e = + case get_key_of_eps_or_rho e of + SOME i => if i <> 0 then i else die "pu_node" + | NONE => 0 (* could be optimized! *) in Pickle.cache2 "Effect.node_nodes" - (G.pu {maybeNewHashInfo=maybeNewHashInfo,dummy=PUT, - register=Pickle.registerEq eq_effect key_effect "pu_node" + (G.pu {maybeNewHashInfo=maybeNewHashInfo,dummy=PUT, + register=Pickle.registerEq eq_effect key_effect "pu_node" (toplevel_effects@toplevel_puts_and_gets)}) end @@ -966,92 +816,43 @@ struct val pu_einfo = let fun toInt (EPS _) = 0 - | toInt (UNION _) = 1 - | toInt PUT = 2 - | toInt GET = 3 - | toInt WORDEFFECT = 4 - | toInt (RHO _) = 5 - fun fun_EPS pu_einfo = - Pickle.newHash (fn EPS {key=ref k,...} => k | _ => die "pu_einfo.newHash.EPS") - (Pickle.con1 (fn ((k,l,r),p) => EPS{key=k,level=l,represents=r,instance=ref NONE,pix=p}) - (fn EPS{key=k,level=l,represents=r,instance=ref NONE,pix=p} => ((k,l,r),p) - | _ => die "pu_einfo.fun_EPS") - (Pickle.pairGen0(Pickle.tup3Gen0(pu_intref,pu_intref,pu_represents pu_einfo), - pu_intref))) - fun fun_UNION pu_einfo = - Pickle.con1 (fn r => UNION{represents=r}) - (fn UNION {represents=r} => r - | _ => die "pu_einfo.fun_UNION") - (pu_represents pu_einfo) - val fun_PUT = Pickle.con0 PUT - val fun_GET = Pickle.con0 GET - val fun_WORDEFFECT = Pickle.con0 WORDEFFECT - fun fun_RHO pu_einfo = - Pickle.newHash (fn RHO {key=ref k,...} => k | _ => die "pu_einfo.newHash.RHO") - (Pickle.con1 (fn ((k,p,g,l),px,t,y) => RHO {key=k,put=p,get=g,level=l, - instance=ref NONE,pix=px,ty=t,rv_opt=y, + | toInt (UNION _) = 1 + | toInt PUT = 2 + | toInt GET = 3 + | toInt (RHO _) = 4 + fun fun_EPS pu_einfo = + Pickle.newHash (fn EPS {key=ref k,...} => k | _ => die "pu_einfo.newHash.EPS") + (Pickle.con1 (fn ((k,l,r),p) => EPS{key=k,level=l,represents=r,instance=ref NONE,pix=p}) + (fn EPS{key=k,level=l,represents=r,instance=ref NONE,pix=p} => ((k,l,r),p) + | _ => die "pu_einfo.fun_EPS") + (Pickle.pairGen0(Pickle.tup3Gen0(pu_intref,pu_intref,pu_represents pu_einfo), + pu_intref))) + fun fun_UNION pu_einfo = + Pickle.con1 (fn r => UNION{represents=r}) + (fn UNION {represents=r} => r + | _ => die "pu_einfo.fun_UNION") + (pu_represents pu_einfo) + val fun_PUT = Pickle.con0 PUT + val fun_GET = Pickle.con0 GET + fun fun_RHO pu_einfo = + Pickle.newHash (fn RHO {key=ref k,...} => k | _ => die "pu_einfo.newHash.RHO") + (Pickle.con1 (fn ((k,p,g,l),px,t,y) => RHO {key=k,put=p,get=g,level=l, + instance=ref NONE,pix=px,ty=t,rv_opt=y, pinned=false}) - (fn RHO {key=k,put=p,get=g,level=l,instance=ref NONE,pix=px,ty=t,rv_opt=y,pinned=_} => - ((* print ("Pickling rho(" ^ Int.toString (!k) ^ ") with level \t" ^ Int.toString (!l) ^ "\n"); *) - ((k,p,g,l),px,t,y)) - | _ => die "pu_einfo.fun_RHO") - (Pickle.tup4Gen0(Pickle.tup4Gen0(pu_intref, Pickle.nameGen "put" (pu_nodeopt pu_einfo), - Pickle.nameGen "get" (pu_nodeopt pu_einfo), - pu_intref), - pu_intref,pu_runType,Pickle.optionGen RegVar.pu))) + (fn RHO {key=k,put=p,get=g,level=l,instance=ref NONE,pix=px,ty=t,rv_opt=y,pinned=_} => + ((* print ("Pickling rho(" ^ Int.toString (!k) ^ ") with level \t" ^ Int.toString (!l) ^ "\n"); *) + ((k,p,g,l),px,t,y)) + | _ => die "pu_einfo.fun_RHO") + (Pickle.tup4Gen0(Pickle.tup4Gen0(pu_intref, Pickle.nameGen "put" (pu_nodeopt pu_einfo), + Pickle.nameGen "get" (pu_nodeopt pu_einfo), + pu_intref), + pu_intref,pu_runType,Pickle.optionGen RegVar.pu))) in Pickle.dataGen("Effect.einfo",toInt,[fun_EPS, fun_UNION, fun_PUT, fun_GET, - fun_WORDEFFECT, fun_RHO]) + fun_RHO]) end val (pu_effect, pu_effects) = pu_node_nodes pu_einfo -(* Tracing Cone Layers (for profiling) - - val trace = ConeLayer.trace - fun traceOrderFinMap(): unit = - (* sort ConeLayer.trace and print first 50 elements *) - let - fun merge([], ys) = ys:int list - | merge(xs, []) = xs - | merge(l as x::xs, r as y:: ys) = - if x>= y then x::merge(xs, r) - else y:: merge(l, ys) - - (* sort: top-down mergesort*) - - fun sort [] = [] - | sort [x] = [x] - | sort xs = - let val k = length xs div 2 - in merge(sort(take(k, xs)), - sort(drop(k, xs))) - end - - val l = sort(!ConeLayer.trace) - fun report[] = [] - | report(x::rest) = - let val (l,r) = List.splitFirst(fn y => y<>x) rest - handle _ => (rest,[]) - in - (x, length l +1, x * (length l +1)):: - report(r) - end; - fun report1 [] = () - | report1((x, multiplicity, product)::rest)= - (say ("depth " ^ Int.toString x ^ ": " - ^ Int.toString(multiplicity) ^ " times = " ^ - Int.toString product ^ "\n"); - report1 rest) - - val l1 = report l - val sum = foldl (fn (x:int, y) => x+y) 0 - (map #3 l1) - in - report1 l1; - say("\nsum = " ^ Int.toString sum ^ "\n") - end; - -tracing *) (******************************************************) (* computing effect increments during algorithm R *) (******************************************************) @@ -1079,7 +880,7 @@ tracing *) structure PlaceOrEffectMap = OrderFinMap(struct type t = effect - val lt = lt_eps_or_rho + val lt = lt_eps_or_rho end) structure Increments = PlaceOrEffectMap @@ -1112,45 +913,39 @@ tracing *) | _ => die "key_of_eps_or_rho" fun computeIncrement delta = - let - fun search' ([],acc) = acc + let fun search' ([],acc) = acc | search' (x::xs,acc) = search'(xs,search(x,acc)) and searchDelta (Lf effects, acc) = search'(effects,acc) | searchDelta (Br(d1,d2), acc) = searchDelta(d1,searchDelta(d2,acc)) and search (n:effect, ns:effect list) : effect list = - let - val r = G.find_visited n - in - if !r then ns - else (r := true; - let val i = G.find_info n - in case i of - UNION _ => - (* do not include n itself, but search children *) - search'(G.out_of_node n, ns) - | RHO _ => (* do not include it; a PUT or GET will be - included, when necessary *) - ns - | PUT => n::ns - | GET => n::ns - | WORDEFFECT => ns - | EPS _ => - search'(G.out_of_node n, - case Increments.lookup (!globalIncs) n of - SOME delta' => searchDelta(delta', n::ns) - | NONE => n::ns - ) - - end - ) + let val r = G.find_visited n + in if !r then ns + else (r := true; + let val i = G.find_info n + in case i of + UNION _ => + (* do not include n itself, but search children *) + search'(G.out_of_node n, ns) + | RHO _ => (* do not include it; a PUT or GET will be + included, when necessary *) + ns + | PUT => n::ns + | GET => n::ns + | EPS _ => + search'(G.out_of_node n, + case Increments.lookup (!globalIncs) n of + SOME delta' => searchDelta(delta', n::ns) + | NONE => n::ns + ) + end) end in searchDelta(delta,[]) before unvisitDelta delta end fun current_increment eps = - case Increments.lookup (!globalIncs) eps of + case Increments.lookup (!globalIncs) eps of SOME delta => delta | NONE => Lf [] @@ -1184,8 +979,8 @@ tracing *) end val cone' = remove(effect,l,!key,cone) (* take node out of cone *) handle ? => (print "lower\n"; raise ?) - val _ = l:= newlevel - val cone'' = add(effect, newlevel, !key,cone') + val _ = l:= newlevel + val cone'' = add(effect, newlevel, !key,cone') (* put node back in cone at lower level *) in low' (G.out_of_node effect, cone'') end @@ -1196,8 +991,9 @@ tracing *) fun lower_delta level delta B = case delta of - Lf(l: effect list) => foldl (fn (a,b) => lower level a b - handle ? => (print "lower_delta\n"; raise ?)) B l + Lf(l: effect list) => + foldl (fn (a,b) => lower level a b + handle ? => (print "lower_delta\n"; raise ?)) B l | Br(d1, d2) => lower_delta level d2 (lower_delta level d1 B) fun setminus (l1: effect list, l2: effect list) : effect list = @@ -1215,22 +1011,15 @@ tracing *) level no greater than the level of eps *) fun update_areff eps = - ((*say ("update_areff: eps = "); say_eps eps; - say "\n";*) - if is_arrow_effect eps - then - case Increments.lookup (!globalIncs) eps of - SOME delta => - let val nodes = computeIncrement delta - val to_be_added = setminus(nodes, G.nodes(G.subgraph [eps])) - in G.add_edges(eps, to_be_added) (* ; - say "update_areff:result = "; - PP.outputTree(say, layout_effect_deep eps, !Flags.colwidth); - say "\n" *) - end - | NONE => () - else () - ) + if is_arrow_effect eps + then case Increments.lookup (!globalIncs) eps of + SOME delta => + let val nodes = computeIncrement delta + val to_be_added = setminus(nodes, G.nodes(G.subgraph [eps])) + in G.add_edges(eps, to_be_added) + end + | NONE => () + else () fun min_key (key1 as ref i1,key2 as ref i2) = if (i1:int) < i2 then key1 else key2 @@ -1246,67 +1035,64 @@ tracing *) | NONE => die "removeIncr")) fun einfo_combine_eps (eps1,eps2)(einfo1,einfo2) = (* assume einfo1 and einfo2 - * have the same level *) + * have the same level *) case (einfo1, einfo2) of (EPS{key = key1 as ref k1, represents, instance, pix, ...}, - EPS{key = key2 as ref k2, ...}) => - if k1 = k2 then die "einfo_combine_eps: expected keys to be different" - else (* merge increment information for einfo1 and einfo2 *) - if k1 < k2 then - (if !algorithm_R then - case Increments.lookup(!globalIncs)eps2 - of SOME delta2 => (update_increment(eps1,delta2); - update_areff eps1 handle _ => die "einfo_combine_eps1"; + EPS{key = key2 as ref k2, ...}) => + if k1 = k2 then die "einfo_combine_eps: expected keys to be different" + else (* merge increment information for einfo1 and einfo2 *) + if k1 < k2 then + (if !algorithm_R then + case Increments.lookup(!globalIncs)eps2 + of SOME delta2 => (update_increment(eps1,delta2); + update_areff eps1 handle _ => die "einfo_combine_eps1"; removeIncr eps2) - | NONE => () - else (); einfo1) - else (* k2 < k1 *) - (if !algorithm_R then - case Increments.lookup(!globalIncs)eps1 - of SOME delta1 => (update_increment(eps2,delta1); - update_areff eps2 handle _ => die "einfo_combine_eps2"; + | NONE => () + else (); einfo1) + else (* k2 < k1 *) + (if !algorithm_R then + case Increments.lookup(!globalIncs)eps1 + of SOME delta1 => (update_increment(eps2,delta1); + update_areff eps2 handle _ => die "einfo_combine_eps2"; removeIncr eps1) - | NONE => () - else (); einfo2) + | NONE => () + else (); einfo2) | _ => die "einfo_combine_eps" local val largest_toplevel_effect_key = 9 fun aux_combine (op1,op2) = - case (op1,op2) of - (_, NONE) => op1 - | (NONE, _) => op2 - | (SOME n1, SOME n2) => - (* n1 and n2 are supposed to be either both PUT nodes - or both GET nodes *) - (* The resulting node (a PUT/GET) will have only one out-edge, - namely to the region variable which n1 points to *) - SOME(G.union_left - (fn (a,b) => - case (a,b) of - (WORDEFFECT,_) => WORDEFFECT (* see comment by freshRhoWithWordTy above *) - | (_,WORDEFFECT) => WORDEFFECT - | (PUT,PUT) => a - | (GET,GET) => a - | _ => die ("aux_combine: (a,b) = (" ^ PP.flatten1 (layout_einfo a) ^ ", " ^ - PP.flatten1 (layout_einfo b) ^ ")\n")) - (n1, n2)) + case (op1,op2) of + (_, NONE) => op1 + | (NONE, _) => op2 + | (SOME n1, SOME n2) => + (* n1 and n2 are supposed to be either both PUT nodes + or both GET nodes *) + (* The resulting node (a PUT/GET) will have only one out-edge, + namely to the region variable which n1 points to *) + SOME(G.union_left + (fn (a,b) => + case (a,b) of + (PUT,PUT) => a + | (GET,GET) => a + | _ => die ("aux_combine: (a,b) = (" ^ PP.flatten1 (layout_einfo a) ^ ", " ^ + PP.flatten1 (layout_einfo b) ^ ")\n")) + (n1, n2)) in fun einfo_combine_rho (einfo1, einfo2) = (* assume einfo1 and einfo2 - * have the same level *) - case (einfo1, einfo2) of - (RHO{level=l1,put=p1,get=g1,key=k1,instance=instance1,pix=pix1,ty=t1, + * have the same level *) + case (einfo1, einfo2) of + (RHO{level=l1,put=p1,get=g1,key=k1,instance=instance1,pix=pix1,ty=t1, rv_opt=rv_opt1,pinned=pinned1}, - RHO{level=_,put=p2,get=g2,key=k2,instance=instance2,pix=pix2,ty=t2, + RHO{level=_,put=p2,get=g2,key=k2,instance=instance2,pix=pix2,ty=t2, rv_opt=rv_opt2,pinned=pinned2}) => - if !k1 <> !k2 andalso (!k1 < largest_toplevel_effect_key - andalso !k2 < largest_toplevel_effect_key) - orelse !k1 = 3 andalso t2<>BOT_RT - orelse !k2 = 3 andalso t1<>BOT_RT - then - die ("illegal unification involving global region(s) " ^ - Int.toString (!k1) ^ show_runType t1 ^ " / " ^ Int.toString (!k2) ^ show_runType t2) - else + if !k1 <> !k2 andalso (!k1 < largest_toplevel_effect_key + andalso !k2 < largest_toplevel_effect_key) + orelse !k1 = 2 andalso t2<>BOT_RT + orelse !k2 = 2 andalso t1<>BOT_RT + then die ("illegal unification involving global region(s) " ^ + Int.toString (!k1) ^ show_runType t1 ^ " / " ^ Int.toString (!k2) ^ show_runType t2) + else let val rv_opt = case (rv_opt1,rv_opt2) of (NONE,_) => rv_opt2 | (_,NONE) => rv_opt1 @@ -1322,11 +1108,11 @@ tracing *) in raise DeepError (report0 // report) end in RHO{level = l1, put = aux_combine(p1,p2), - get = aux_combine(g1,g2), key = min_key(k1,k2), - instance = instance1, pix = pix1, ty = lub_runType(t1,t2), + get = aux_combine(g1,g2), key = min_key(k1,k2), + instance = instance1, pix = pix1, ty = lub_runType(t1,t2), rv_opt=rv_opt,pinned=pinned1 orelse pinned2} end - | _ => die "einfo_combine_rho" + | _ => die "einfo_combine_rho" end fun mkSameLevel (node1, node2) cone : cone = @@ -1337,7 +1123,7 @@ tracing *) else if l1l2 *) lower l2 node1 cone | _ => die "mkSameLevel: one of the two nodes was not \ - \an EPS or a RHO node" + \an EPS or a RHO node" (* unifyNodes f (node1, node2) cone : cone First lower node1 and node2 to the same level; then union @@ -1351,9 +1137,9 @@ tracing *) fun unifyNodes f (node1, node2) cone : cone = if G.eq_nodes(node1,node2) then cone else let val cone1 = mkSameLevel(node1, node2) cone - in f(node1, node2); - cone1 - end + in f(node1, node2); + cone1 + end fun unifyNodes_no_lowering f (n1, n2) : unit = if G.eq_nodes(n1,n2) then () @@ -1401,8 +1187,8 @@ tracing *) (checkNotRho "unifyEps1" e1; checkNotRho "unifyEps2" e2; unifyNodes(G.union_without_edge_duplication - (einfo_combine_eps(e1,e2)) - is_union) (e1,e2) cone) + (einfo_combine_eps(e1,e2)) + is_union) (e1,e2) cone) (*****************************************************) @@ -1420,7 +1206,7 @@ tracing *) *) fun instNodes l cone = #1(instNodesClever l cone) - and instNodesClever (l : (effect * effect) list) cone : cone * (effect * delta_phi)list= + and instNodesClever (l : (effect * effect) list) cone : cone * (effect * delta_phi)list = let (* bound_to_free_no_transparent nodes: map each non-transparent n to itself, if it is not @@ -1454,16 +1240,13 @@ tracing *) | _ => die "instNodes: get node has no region argument" ) | UNION _ => NONE (* node not bound *) - | WORDEFFECT => SOME node (*do not return NONE as this would make G.multi_graft - *trace the outedges of the node, which include - *the region variable r2 (global word region). *) | EPS {instance as ref i, ...} => (case i of g as SOME n' => (* generic *) g | NONE => (* non-generic*) SOME node ) | RHO{instance as ref i, key,...} => die ("bound_to_free.RHO: " ^ - PP.flatten1 (layout_effect node) ^ "\n") + PP.flatten1 (layout_effect node) ^ "\n") fun lower_new_edges (n:effect, new_target_nodes:effect list) cone : cone = let val level = noSome (level_of n, "instNodes: no level") @@ -1471,7 +1254,7 @@ tracing *) end handle ? => (print "lower_new_edges\n"; raise ?) val targets_and_new_children: (effect * effect list) list = - G.multi_graft bound_to_free l + G.multi_graft bound_to_free l in (foldl (fn (a,b) => lower_new_edges a b) cone targets_and_new_children, map (fn (target, children) => (target, Lf children)) targets_and_new_children) @@ -1542,7 +1325,6 @@ tracing *) else (r_acc:= n :: !r_acc; ns)) | GET => (if include_put_or_get n then n::ns else (r_acc:= n :: !r_acc; ns)) - | WORDEFFECT => ns | EPS{level as ref l', ...} => if l'<=l then (* include it, without examining children *) @@ -1640,7 +1422,7 @@ tracing *) (UNION _ , _) => einfo2 | (_, UNION _) => einfo1 | (EPS {key=ref k1,...}, EPS {key=ref k2,...}) => - if k1 < k2 then einfo1 else einfo2 (* was einfo1 ; ME 2001-03-07 *) + if k1 < k2 then einfo1 else einfo2 (* was einfo1 ; ME 2001-03-07 *) | _ => die "einfo_scc_combine: strongly connected\ \ component in effect graph contained \ \\nnode which was neither an arrow effect nor a union" @@ -1657,16 +1439,17 @@ tracing *) fun contract_effects (arreffs: effect list) : effect list = let val sg = G.subgraph arreffs - val effs = G.nodes(G.quotient layout_einfo einfo_scc_combine sg); + val effs = G.nodes(G.quotient layout_einfo einfo_scc_combine sg); in effs end fun topsort x = G.topsort x - fun pix node = case G.find_info node of - RHO{pix, ...} => pix - | EPS{pix, ...} => pix - | _ => die "pix: cannot take pre-order index of node which is not a region or effect variable" + fun pix node = + case G.find_info node of + RHO{pix, ...} => pix + | EPS{pix, ...} => pix + | _ => die "pix: cannot take pre-order index of node which is not a region or effect variable" fun get_visited node = G.find_visited node (*G.get_visited(G.find node)*) @@ -1684,7 +1467,7 @@ tracing *) val reset_cone = Cone.reset fun reset () = ((*reset_cone emptyCone;*) - (* resetCount(); *) + (* resetCount(); *) globalIncs:= Increments.empty) (* ------------------------------------------------------- @@ -1723,55 +1506,46 @@ tracing *) fun unify_with_toplevel_effect effect : unit = let fun union_with toplevel_rho : unit = - if G.eq_nodes(toplevel_rho,effect) then () - else (G.union einfo_combine_rho (toplevel_rho,effect);()) - in (*say_etas[layout_effect effect] (*test*);*) - if is_arrow_effect effect then - if G.eq_nodes(toplevel_arreff,effect) then () - else ( - (* - print "unifying with toplevel_arreff:"; - say_eps toplevel_arreff; - say_eps effect; - print "\n"; - *) - G.union_without_edge_duplication - (einfo_combine_eps(toplevel_arreff,effect)) - is_union (toplevel_arreff,effect); - (* - print "toplevel_arreff, effect :"; - say_eps toplevel_arreff; - say_eps effect; print "\n"; - *) - ()) + if G.eq_nodes(toplevel_rho,effect) then () + else (G.union einfo_combine_rho (toplevel_rho,effect);()) + in if is_arrow_effect effect then + if G.eq_nodes(toplevel_arreff,effect) then () + else ( + (* + print "unifying with toplevel_arreff:"; + say_eps toplevel_arreff; + say_eps effect; + print "\n"; + *) + G.union_without_edge_duplication + (einfo_combine_eps(toplevel_arreff,effect)) + is_union (toplevel_arreff,effect); + (* + print "toplevel_arreff, effect :"; + say_eps toplevel_arreff; + say_eps effect; print "\n"; + *) + ()) else - if is_rho effect then - case get_place_ty effect - of SOME WORD_RT => union_with(toplevel_region_withtype_word) - | SOME TOP_RT => union_with(toplevel_region_withtype_top) - | SOME BOT_RT => union_with(toplevel_region_withtype_bot) - | SOME STRING_RT => union_with(toplevel_region_withtype_string) - | SOME PAIR_RT => union_with(toplevel_region_withtype_pair) - | SOME ARRAY_RT => union_with(toplevel_region_withtype_array) - | SOME REF_RT => union_with(toplevel_region_withtype_ref) - | SOME TRIPLE_RT => union_with(toplevel_region_withtype_triple) - | NONE => die "unify_with_toplevel_effect.no runtype info" - else die "unify_with_toplevel_effect.not rho or eps" + if is_rho effect then + case get_place_ty effect of + SOME TOP_RT => union_with(toplevel_region_withtype_top) + | SOME BOT_RT => union_with(toplevel_region_withtype_bot) + | SOME STRING_RT => union_with(toplevel_region_withtype_string) + | SOME PAIR_RT => union_with(toplevel_region_withtype_pair) + | SOME ARRAY_RT => union_with(toplevel_region_withtype_array) + | SOME REF_RT => union_with(toplevel_region_withtype_ref) + | SOME TRIPLE_RT => union_with(toplevel_region_withtype_triple) + | NONE => die "unify_with_toplevel_effect.no runtype info" + else die "unify_with_toplevel_effect.not rho or eps" end fun unify_with_toplevel_rhos_eps (cone as (n,c),rhos_epss) : cone = - let - val nodes_for_unification = - rhos_epss @ - ConeLayer.range(noSome(Cone.lookup c 1, (* 1 is the number of the top level *) - "mk_top_level_unique: not top-level in cone")) - in -(* - print"unify_with_toplevel_rhos_eps: list of nodes for unification:\n"; - say_etas(layoutEtas nodes_for_unification); - print"now unifying...:\n"; -*) - app unify_with_toplevel_effect nodes_for_unification; + let val nodes_for_unification = + rhos_epss @ + ConeLayer.range(noSome(Cone.lookup c 1, (* 1 is the number of the top level *) + "mk_top_level_unique: not top-level in cone")) + in app unify_with_toplevel_effect nodes_for_unification; (* the above side-effects cone; now return it: *) cone end @@ -1780,32 +1554,30 @@ tracing *) (* restrain: decrease the level of all variables in the topmost * layer by one and pop the topmost layer. *) fun restrain (B as (n,c) : cone) : cone = - let val effs = topLayer B (*ConeLayer.range (noSome(Cone.lookup c n, "restrain: no such layer"))*) + let val effs = topLayer B (* make variables top-level effect variables *) - val B = unify_with_toplevel_rhos_eps(B,effs) -(* val B = foldl (fn (eff,B) => lower 1 eff B) B ((*remove_duplicates*) effs) *) + val B = unify_with_toplevel_rhos_eps(B,effs) in #2(pop B) end - (**************************************) (* for multiplicity inference: *) (**************************************) - fun key_of_get_or_put node = case G.out_of_node node of - [rho_node] => key_of_rho rho_node - | _ => die "key_of_get_or_put" + fun key_of_get_or_put node = + case G.out_of_node node of + [rho_node] => key_of_rho rho_node + | _ => die "key_of_get_or_put" exception AE_LT - - fun ae_lt(node1, node2) = (* GET > PUT > EPS *) + fun ae_lt (node1, node2) = (* GET > PUT > EPS *) case (G.find_info node1, G.find_info node2) of - (EPS _, EPS _) => get_key_of_eps node1 < get_key_of_eps node2 - | (EPS _, _) => true - | (PUT, PUT) => key_of_get_or_put node1 < key_of_get_or_put node2 - | (PUT, EPS _) => false - | _ => raise AE_LT + (EPS _, EPS _) => get_key_of_eps node1 < get_key_of_eps node2 + | (EPS _, _) => true + | (PUT, PUT) => key_of_get_or_put node1 < key_of_get_or_put node2 + | (PUT, EPS _) => false + | _ => raise AE_LT local (* sorting of atomic effects *) fun merge([], ys) = ys:effect list @@ -1814,8 +1586,7 @@ tracing *) if ae_lt(x, y) then x::merge(xs, r) else y:: merge(l, ys) - (* sort: top-down mergesort*) - + (* sort: top-down mergesort *) fun sort [] = [] | sort [x] = [x] | sort xs = @@ -1823,7 +1594,6 @@ tracing *) in merge(sort(take(k, xs)), sort(drop(k, xs))) end - in val sort_ae = sort end @@ -1837,38 +1607,34 @@ tracing *) | UNION{represents = SOME l} => l | PUT => [eps_node] | GET => [] - | WORDEFFECT => [] | RHO _ => [] | _ => die "mk_phi" fun visit_eps_or_rho node acc = let val i = G.find_info node val r = G.find_visited node - in - case i of - EPS _ => (r:=true; r::acc) - | RHO{put, ...} => + in case i of + EPS _ => (r:=true; r::acc) + | RHO{put, ...} => (case put of - NONE => (r:=true; r::acc) - | SOME n => - let - val r' = G.find_visited n - in r:= true; r':=true; r::r'::acc - end) - | _ => die "visit_eps_or_rho: neither eps nor rho node" + NONE => (r:=true; r::acc) + | SOME n => + let val r' = G.find_visited n + in r:= true; r':=true; r::r'::acc + end) + | _ => die "visit_eps_or_rho: neither eps nor rho node" end - fun removeatomiceffects(psi, []) = psi - | removeatomiceffects(psi: (effect * 'a) list, discharged_basis: effect list): (effect*'a) list = + fun removeatomiceffects (psi, []) = psi + | removeatomiceffects (psi: (effect * 'a) list, discharged_basis: effect list): (effect*'a) list = (* each member of discharged_basis is either a region variable or an arrow effect; now remove from psi all ae:m for which ae takes the form eps in discharged_basis or PUT rho or GET rho for rho in discharged_basis: *) let val refs = foldl (fn (a,b) => visit_eps_or_rho a b) [] discharged_basis fun keep (ae,mul): bool = not(!(G.find_visited ae)) - in - List.filter keep psi before - app (fn r => r := false) refs + in List.filter keep psi before + app (fn r => r := false) refs end (************************************) @@ -1885,7 +1651,7 @@ tracing *) are non-empty. The key value of a list is the key value of the first element of the list.*) - fun leq_key(i, j) = ae_lt(i,j) orelse eq_effect(i,j) + fun leq_key (i, j) = ae_lt(i,j) orelse eq_effect(i,j) structure HI = struct type elem = effect list @@ -1900,39 +1666,37 @@ tracing *) fun eq (ae1, ae2) = eq_effect(ae1, ae2) fun makeHeap ll = - let fun mkHeap([], h) = h - | mkHeap([]::rest, h) = mkHeap(rest,h) - | mkHeap( l::rest, h) = mkHeap(rest, Heap.insert l h) - in - mkHeap(ll, Heap.empty) - end + let fun mkHeap ([], h) = h + | mkHeap ([]::rest, h) = mkHeap(rest,h) + | mkHeap (l::rest, h) = mkHeap(rest, Heap.insert l h) + in mkHeap(ll, Heap.empty) + end fun insert ([], h) = h | insert (l, h) = Heap.insert l h fun merge_against (min, h) = if Heap.is_empty h then [min] - 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)) + 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)) else - if Heap.is_empty h1 then min :: l1 - else min :: merge_against(x1, insert(xs1, h1)) - | _ => die "merge_against" + if Heap.is_empty h1 then min :: l1 + else min :: merge_against(x1, insert(xs1, h1)) + | _ => die "merge_against" 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)) - | _ => die "merge_all" + else case Heap.delete_min h of + (x1::xs1, h1) => merge_against(x1, insert(xs1,h1)) + | _ => die "merge_all" fun multimerge (ll: HI.elem list) = merge_all(makeHeap ll) end - fun insert_into_list (eps,[]) = [eps] | insert_into_list (eps, l as eps'::rest) = if ae_lt(eps,eps') then eps ::l @@ -1940,13 +1704,14 @@ tracing *) else eps' :: insert_into_list(eps, rest) fun check_represents l = (* check that all members of l are atomic effects*) - (map (fn n => case G.find_info n of - EPS _ => () - | PUT => () - | GET => () - | _ => (log_string "check_represents failed on effect:"; - log_tree(layout_effect_deep n); - die "check_represents")) l; + (map (fn n => + case G.find_info n of + EPS _ => () + | PUT => () + | GET => () + | _ => (log_string "check_represents failed on effect:"; + log_tree(layout_effect_deep n); + die "check_represents")) l; l) fun bottom_up_eval (g : effect list) : unit = @@ -1982,8 +1747,7 @@ tracing *) ) | PUT => [n] | GET => [] - | WORDEFFECT => [] - | _ => (say "bottom_up_eval: unexpected node(1): " ; + | _ => (say "bottom_up_eval: unexpected node(1): " ; say_eps n; say "\n"; [] ) @@ -2009,7 +1773,6 @@ tracing *) end) | PUT => [n] | GET => [] - | WORDEFFECT => [] | RHO _ => [] ) end @@ -2022,7 +1785,6 @@ tracing *) G.unvisit g end - fun say s = TextIO.output(TextIO.stdOut, s^"\n") (* eval_phis(phis): all members of phis must be EPS nodes; @@ -2030,9 +1792,7 @@ tracing *) do a bottom-up evaluation of the graph *) fun eval_phis (phis: effect list) : unit = - let (*val _ = G.remove_cycles(G.subgraph phis) - val nodes = G.nodes(G.subgraph phis) *) - val nodes = contract_effects(phis) + let val nodes = contract_effects(phis) in bottom_up_eval nodes handle exn => (say "\neval_phis failed; nodes = "; say_etas (layoutEtas nodes); @@ -2041,10 +1801,10 @@ tracing *) fun represents eps = case G.find_info eps of - EPS{represents = SOME l, ...} => l - | _ => (say "No info for eps\n"; - say_eps eps; - die ("represents")) + EPS{represents = SOME l, ...} => l + | _ => (say "No info for eps\n"; + say_eps eps; + die ("represents")) end (* diff --git a/src/Compiler/Regions/LOCALLY_LIVE_VARIABLES.sml b/src/Compiler/Regions/LOCALLY_LIVE_VARIABLES.sml index dade90d38..6e262ea51 100644 --- a/src/Compiler/Regions/LOCALLY_LIVE_VARIABLES.sml +++ b/src/Compiler/Regions/LOCALLY_LIVE_VARIABLES.sml @@ -4,15 +4,14 @@ signature LOCALLY_LIVE_VARIABLES = sig type liveset (* sets of locally live lvars and excons *) - type place and mul and qmularefset + type place and mul and qmularefset and ('a,'b,'c)LambdaPgm (*from MulExp*) and lvar and excon - - (*llv(p): annotate every binder in p with a set of + (*llv(p): annotate every binder in p with a set of locally live lvars and excons *) - val llv: (place, place*mul, qmularefset ref)LambdaPgm -> + val llv: (place, place*mul, qmularefset ref)LambdaPgm -> (place*liveset, place*mul, qmularefset ref)LambdaPgm (* findLvar f liveset returns @@ -22,11 +21,9 @@ sig Similarly for findExcon. *) - val findLvar: (lvar -> '_a option) -> liveset -> (lvar*'_a) option - val findExcon: (excon -> 'a option) -> liveset -> (excon*'a) option - + val findLvar: (lvar -> 'a option) -> liveset -> (lvar * 'a) option + val findExcon: (excon -> 'a option) -> liveset -> (excon * 'a) option type StringTree val layout_liveset: liveset -> StringTree end - diff --git a/src/Compiler/Regions/LocallyLiveVariables.sml b/src/Compiler/Regions/LocallyLiveVariables.sml index d269bc202..847ace4bb 100644 --- a/src/Compiler/Regions/LocallyLiveVariables.sml +++ b/src/Compiler/Regions/LocallyLiveVariables.sml @@ -23,11 +23,11 @@ struct (* 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 die errmsg = Crash.impossible ("LocallyLiveVariables." ^ errmsg) - fun unimplemented x = Crash.unimplemented ("RegFlow." ^ x) + 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 die errmsg = Crash.impossible ("LocallyLiveVariables." ^ errmsg) + fun unimplemented x = Crash.unimplemented ("RegFlow." ^ x) (* -----------------------------------------------------------------------*) (* Debugging flags; updated from Flags each time main function in module *) @@ -38,38 +38,36 @@ 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 (* ---------------------------------------------------------------------- *) (* Computing locally live variables and inserting them in the syntax *) (* tree at allocation points. *) (* ---------------------------------------------------------------------- *) - fun union_list[] = Lvarset.empty - | union_list[set] = set - | union_list(set::rest) = Lvarset.union(set,union_list rest) + fun union_list [] = Lvarset.empty + | union_list [set] = set + | union_list (set::rest) = Lvarset.union(set,union_list rest) - fun union(lvarset1,lvarset2) = Lvarset.union(lvarset1,lvarset2) + fun union (lvarset1,lvarset2) = Lvarset.union(lvarset1,lvarset2) val empty = Lvarset.empty - fun difference(lvarset, lvars) = - foldl (fn (lvar, set) => - Lvarset.delete(set,lvar)) lvarset lvars - fun add(lvarset, lvar) = Lvarset.add(lvarset, lvar) - fun delete(lvarset, lvar) = Lvarset.delete(lvarset,lvar) + fun difference (lvarset, lvars) = + foldl (fn (lvar, set) => + Lvarset.delete(set,lvar)) lvarset lvars + fun add (lvarset, lvar) = Lvarset.add(lvarset, lvar) + fun delete (lvarset, lvar) = Lvarset.delete(lvarset,lvar) fun singleton lvar = Lvarset.singleton lvar fun findLvar pred (liveset as (lvarset,_)) = Lvarset.findLvar pred lvarset fun norm lvarset = lvarset - fun fromList(lvars) = Lvarset.lvarsetof(lvars) + fun fromList lvars = Lvarset.lvarsetof(lvars) (*******************************************) @@ -77,18 +75,14 @@ struct (*******************************************) type liveset = lvarset * Excon.excon list - fun norm_liveset(lvarset, excons) = (norm lvarset, excons) + fun norm_liveset (lvarset, excons) = (norm lvarset, excons) fun layout_liveset (liveset) = - case norm_liveset liveset of - (lvarset, excons) => - PrettyPrint.NODE{start = "{", finish = "}", indent =1, childsep = PrettyPrint.RIGHT",", - children = map (PrettyPrint.LEAF o Lvars.pr_lvar) (Lvarset.members lvarset) @ - map (PrettyPrint.LEAF o Excon.pr_excon) excons} - - - - + case norm_liveset liveset of + (lvarset, excons) => + PrettyPrint.NODE{start = "{", finish = "}", indent =1, childsep = PrettyPrint.RIGHT",", + children = map (PrettyPrint.LEAF o Lvars.pr_lvar) (Lvarset.members lvarset) @ + map (PrettyPrint.LEAF o Excon.pr_excon) excons} type mulexp_llv = (place*liveset, place*mul, qmularefset ref)MulExp.LambdaExp type trip_llv = (place*liveset, place*mul, qmularefset ref)MulExp.trip @@ -96,22 +90,20 @@ struct val empty_liveset = (empty, []) fun diff_llv (liveset as (xs,es) : liveset, lvars': lvar list) : liveset = - let - val xs'' = difference(xs, lvars') - in - (xs'', es) - end + let val xs'' = difference(xs, lvars') + in (xs'', es) + end fun union_excons ([], es') = es' | union_excons (es, []) = es | union_excons (es, es') = foldl (fn (excon, res) => - if List.exists (fn excon' => Excon.eq(excon,excon')) es' then res - else excon :: res) es' es + if List.exists (fn excon' => Excon.eq(excon,excon')) es' then res + else excon :: res) es' es - fun union_llv((xs, es), (xs',es')) = (union(xs,xs'), union_excons(es,es')) + fun union_llv ((xs, es), (xs',es')) = (union(xs,xs'), union_excons(es,es')) - fun union_many(l : liveset list): liveset = + fun union_many (l : liveset list): liveset = (union_list(map #1 l), foldr union_excons [] (map #2 l)) @@ -131,13 +123,13 @@ struct (lvars, List.filter(fn excon' => not(Excon.eq(excon',excon))) excons) fun findExcon pred (_,excons) = - let fun loop[] = NONE - | loop (excon::rest) = - case pred excon of - NONE => loop rest - | SOME result => SOME(excon,result) - in loop excons - end + let fun loop [] = NONE + | loop (excon::rest) = + case pred excon of + NONE => loop rest + | SOME result => SOME(excon,result) + in loop excons + end val union_llvs = foldl (fn (liveset, res) => union_llv(liveset, res)) empty_liveset @@ -154,26 +146,27 @@ struct local open MulExp in - fun cp_triv_exp (VAR{lvar,il,plain_arreffs,fix_bound=false,rhos_actuals = ref [] ,other}) = VAR{lvar=lvar,il=il,plain_arreffs=plain_arreffs, fix_bound=false, rhos_actuals= ref [], other = other} - | cp_triv_exp (VAR{lvar, ...}) = die - ("cp_triv_exp: lvar badly annotated: " ^ Lvars.pr_lvar lvar) - | cp_triv_exp (INTEGER(i, t, place)) = INTEGER(i, t, (place, empty_liveset)) (* the - lvarset is not - needed for integers, since no code is generated for it *) - | cp_triv_exp (WORD(i, t, place)) = WORD(i, t, (place, empty_liveset)) (* the - lvarset is not - needed for integers, since no code is generated for it *) - | cp_triv_exp (RECORD(place,[])) = RECORD((place,empty_liveset), []) (* the - lvarset is not - needed for the unit value, it is represented unboxed *) - | cp_triv_exp (F64(s,place)) = F64(s, (place, empty_liveset)) - | cp_triv_exp _ = die - ("cp_triv_exp: not an atomic expression (expected K-normal form)") + | cp_triv_exp (VAR{lvar, ...}) = die ("cp_triv_exp: lvar badly annotated: " + ^ Lvars.pr_lvar lvar) + | cp_triv_exp (INTEGER(i, t, SOME place)) = INTEGER(i, t, SOME (place, empty_liveset)) + | cp_triv_exp (INTEGER(i, t, NONE)) = INTEGER(i, t, NONE) + (* the lvarset is not + needed for integers, since no code is generated for it *) + | cp_triv_exp (WORD(i, t, SOME place)) = WORD(i, t, SOME(place, empty_liveset)) + | cp_triv_exp (WORD(i, t, NONE)) = WORD(i, t, NONE) + (* the lvarset is not + needed for integers, since no code is generated for it *) + | cp_triv_exp (RECORD(NONE,[])) = RECORD(NONE, []) + | cp_triv_exp (RECORD(SOME place,[])) = RECORD(SOME(place,empty_liveset), []) + (* the lvarset is not + needed for the unit value, it is represented unboxed *) + | cp_triv_exp (F64 s) = F64 s + | cp_triv_exp _ = die ("cp_triv_exp: not an atomic expression (expected K-normal form)") fun cp_triv (TR(e, meta,l, r)) = TR(cp_triv_exp(e), meta,l,r) @@ -200,129 +193,123 @@ struct llv-annotated output expression *) - fun llv(tr: multrip as TR(e,meta,l,r), liveset as (xs, es): liveset) : trip_llv * liveset = + fun llv (tr: multrip as TR(e,meta,l,r), liveset as (xs, es): liveset) : trip_llv * liveset = let val (e', liveset') = llvExp(e, liveset) in (TR(e',meta,l,r), liveset') end - and llvExp(e: mulexp, liveset as (xs, es) : liveset) : mulexp_llv * liveset = + and llvExp (e: mulexp, liveset as (xs, es) : liveset) : mulexp_llv * liveset = let - fun llv_switch(SWITCH(e,branches,e_opt), liveset) = - (* Note: e is trivial *) - let val children = map (fn (c,e) => llv (e,liveset)) branches + fun llv_switch (SWITCH(e,branches,e_opt), liveset) = + (* Note: e is trivial *) + let val children = map (fn (c,e) => llv (e,liveset)) branches val freeInRhs = union_llvs (map #2 children) - val (e_opt_llv, freeInOpt) = case e_opt of - NONE => (NONE, empty_liveset) - | SOME e => + val (e_opt_llv, freeInOpt) = case e_opt of + NONE => (NONE, empty_liveset) + | SOME e => let val (e_llv, llv') = llv (e, liveset) in (SOME e_llv, llv') end val newBranches = ListPair.zip(map #1 branches, map #1 children) - in - (SWITCH(cp_triv e, newBranches, e_opt_llv), - union_llv(freeInRhs, union_llv(freeInOpt, freeInTriv e))) - end + in + (SWITCH(cp_triv e, newBranches, e_opt_llv), + union_llv(freeInRhs, union_llv(freeInOpt, freeInTriv e))) + end in case e of - VAR{lvar,...} => (cp_triv_exp e, (singleton lvar, [])) - | INTEGER(i,t,a) => - if RType.unboxed t then (cp_triv_exp e, empty_liveset) - else (INTEGER(i,t, (a, norm_liveset liveset)), empty_liveset) - | WORD(i,t,a) => - if RType.unboxed t then (cp_triv_exp e, empty_liveset) - else (WORD(i,t, (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) - | F64(r,_) => (cp_triv_exp e, empty_liveset) - | UB_RECORD(trs) => - let val children = map (fn tr => llv(tr, liveset)) trs - in - (UB_RECORD(map #1 children), - union_many(map #2 children) - ) - end - | FN{pat,body,free,alloc = p} => - let val (body',freeInBody) = llv(body, empty_liveset) - val for_closure: liveset = + 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) + | 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) + | F64 r => (cp_triv_exp e, empty_liveset) + | UB_RECORD(trs) => + let val children = map (fn tr => llv(tr, liveset)) trs + in (UB_RECORD(map #1 children), + union_many(map #2 children) + ) + end + | FN{pat,body,free,alloc = p} => + let val (body',freeInBody) = llv(body, empty_liveset) + val for_closure: liveset = delete_lvars(freeInBody, map #1 pat) - in + in (FN{pat=pat,body = body',free = free, alloc = (p, norm_liveset(union_llv(liveset, for_closure)))}, - for_closure) - end - - | LETREGION{B,rhos,body} => + for_closure) + end + | LETREGION{B,rhos,body} => let val (body', liveset') = llv(body, liveset) - in - (LETREGION{B=B,rhos=rhos,body = body'}, + in (LETREGION{B=B,rhos=rhos,body = body'}, liveset') (* note that rhos need not be subtracted: they are not lvars *) end - | LET{k_let,pat,bind,scope} => - let val (scope',freeInScope) = llv(scope, liveset) + | LET{k_let,pat,bind,scope} => + let val (scope',freeInScope) = llv(scope, liveset) val bound_lvars = map #1 pat - val liveAtRhs = delete_lvars(freeInScope, bound_lvars) - val (bind',freeInRhs) = llv(bind, union_llv(liveAtRhs, liveset)) + val liveAtRhs = delete_lvars(freeInScope, bound_lvars) + val (bind',freeInRhs) = llv(bind, union_llv(liveAtRhs, liveset)) + in + (LET{k_let=k_let,pat=pat, bind = bind', scope= scope'}, + union_llv(freeInRhs, liveAtRhs)) + end + | FIX{free,shared_clos = rho,functions,scope}=> + let val (scope',freeInScope) = llv(scope, liveset) + val children = map (fn function => llv(#bind function, empty_liveset)) functions + val freeInRhs = union_llvs (map #2 children) + val boundByLhs = map #lvar functions + (* XXX PS: The calculation in AtInference29a3 seemed wrong: *) + val localFree = diff_llv(union_llv(freeInRhs, freeInScope), + boundByLhs) in - (LET{k_let=k_let,pat=pat, bind = bind', scope= scope'}, - union_llv(freeInRhs, liveAtRhs)) - end - - - | FIX{free,shared_clos = rho,functions,scope}=> - let val (scope',freeInScope) = llv(scope, liveset) - val children = map (fn function => llv(#bind function, empty_liveset)) functions - val freeInRhs = union_llvs (map #2 children) - val boundByLhs = map #lvar functions - (* XXX PS: The calculation in AtInference29a3 seemed wrong: *) - val localFree = diff_llv(union_llv(freeInRhs, freeInScope), - boundByLhs) - in - (FIX{free =free, shared_clos = (rho, norm_liveset(union_llv(localFree, liveset))), - functions = - map(fn({lvar,occ,tyvars,rhos,epss,Type,rhos_formals, - bound_but_never_written_into, - other,bind = _}, bind) => - {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, - rhos_formals = rhos_formals, - bound_but_never_written_into=bound_but_never_written_into, - other=other,bind = bind}) - (ListPair.zip(functions,map #1 children)), - scope = scope'}, - localFree) - end - - | APP(ck,sr,tr1 as TR(VAR{lvar = f,il,plain_arreffs,fix_bound=true, - rhos_actuals, other},meta,phi,psi), - tr2) => (* equation 23 and 24 in popl 96 paper *) - let + (FIX{free =free, shared_clos = (rho, norm_liveset(union_llv(localFree, liveset))), + functions = + map(fn({lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + bound_but_never_written_into, + other,bind = _}, bind) => + {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, + rhos_formals = rhos_formals, + bound_but_never_written_into=bound_but_never_written_into, + other=other,bind = bind}) + (ListPair.zip(functions,map #1 children)), + scope = scope'}, + localFree) + end + + | APP(ck,sr,tr1 as TR(VAR{lvar = f,il,plain_arreffs,fix_bound=true, + 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 *) - in - (APP(ck,sr,TR(VAR{lvar=f,il=il,plain_arreffs=plain_arreffs, - fix_bound=true, (* see (24) *) - rhos_actuals = ref (map (fn rho_act => - (* see (23) *) (rho_act,liveset)) (!rhos_actuals)), - other = other}, meta,phi,psi), - tr2'), - add_lvar(freeInTriv' tr2, f)) - end - - | APP(ck,sr,tr1 as TR(VAR{lvar = f,il,plain_arreffs,fix_bound=false, - rhos_actuals = ref [], other},meta,phi,psi), - tr2) => (* equation missing in popl paper! *) - let + in + (APP(ck,sr,TR(VAR{lvar=f,il=il,plain_arreffs=plain_arreffs, + fix_bound=true, (* see (24) *) + rhos_actuals = ref (map (fn rho_act => + (* see (23) *) (rho_act,liveset)) (!rhos_actuals)), + other = other}, meta,phi,psi), + tr2'), + add_lvar(freeInTriv' tr2, f)) + end + + | APP(ck,sr,tr1 as TR(VAR{lvar = f,il,plain_arreffs,fix_bound=false, + rhos_actuals = ref [], other},meta,phi,psi), + tr2) => (* equation missing in popl paper! *) + let (* Note that tr1 and tr2 are trivial (variables) because of - K Normal Form *) - val (tr2',free_tr2) = llv(tr2,liveset) - val (tr1',free_tr1) = llv(tr1,liveset) - in - (APP(ck,sr,tr1',tr2'), - union_llv(free_tr1,free_tr2)) - end + K Normal Form *) + val (tr2',free_tr2) = llv(tr2,liveset) + val (tr1',free_tr1) = llv(tr1,liveset) + in + (APP(ck,sr,tr1',tr2'), + union_llv(free_tr1,free_tr2)) + end (* | APP(ck,sr,tr1 as TR(VAR{lvar, il, plain_arreffs,fix_bound=false, rhos_actuals,other}, meta,phi,psi),tr2) => (* non-empty list of actual regions: has to be primitive lvar *) @@ -343,205 +330,202 @@ struct | NONE => die "ill-formed application (expected K-normal form)" ) *) - | APP(ck,sr, _ , _) => - die "ill-formed application; operator not variable (expected K-normal form)" - - | EXCEPTION(excon,b,mu,rho,tr1) => - let val (tr1',freeInScope) = llv(tr1, liveset) - in - (EXCEPTION(excon,b,mu,(rho,norm_liveset(liveset)),tr1'), - delete_excon(freeInScope, excon)) - end - - | RAISE(tr1) => - let val (tr1', free_in_tr1) = llv(tr1,liveset) (* it might be ok to - replace "liveset" by "empty_liveset" *) - in (RAISE tr1', free_in_tr1) - end - - | HANDLE(tr1, tr2) => - (* here tr2 is trivial, but tr1 may be non-trivial *) - let + | APP(ck,sr, _ , _) => + die "ill-formed application; operator not variable (expected K-normal form)" + + | EXCEPTION(excon,b,mu,rho,tr1) => + let val (tr1',freeInScope) = llv(tr1, liveset) + in + (EXCEPTION(excon,b,mu,(rho,norm_liveset(liveset)),tr1'), + delete_excon(freeInScope, excon)) + end + + | RAISE(tr1) => + let val (tr1', free_in_tr1) = llv(tr1,liveset) (* it might be ok to + replace "liveset" by "empty_liveset" *) + in (RAISE tr1', free_in_tr1) + end + + | HANDLE(tr1, tr2) => + (* here tr2 is trivial, but tr1 may be non-trivial *) + let val (tr2', live_in_tr2) = llv(tr2, liveset) val (tr1', live_in_tr1) = llv(tr1, union_llv(live_in_tr2, liveset)) - in - (HANDLE(tr1',tr2'), - union_llv(live_in_tr2, live_in_tr1) - ) - end - | SWITCH_I {switch,precision} => + in + (HANDLE(tr1',tr2'), + union_llv(live_in_tr2, live_in_tr1) + ) + end + | SWITCH_I {switch,precision} => let val (switch', liveset') = llv_switch(switch,liveset) in (SWITCH_I {switch=switch',precision=precision},liveset') end - | SWITCH_W {switch,precision} => + | SWITCH_W {switch,precision} => let val (switch', liveset') = llv_switch(switch,liveset) in (SWITCH_W {switch=switch',precision=precision},liveset') end - | SWITCH_C(switch) => + | SWITCH_C(switch) => let val (switch', liveset') = llv_switch(switch,liveset) in (SWITCH_C(switch'),liveset') end - | SWITCH_S(switch) => + | SWITCH_S(switch) => let val (switch', liveset') = llv_switch(switch,liveset) in (SWITCH_S(switch'),liveset') end - | SWITCH_E(SWITCH(e,branches,e_opt)) => - (* Note: e is trivial *) - let fun doBranch(c,e) = + | SWITCH_E(SWITCH(e,branches,e_opt)) => + (* Note: e is trivial *) + let fun doBranch(c,e) = let val (e', free_in_e) = llv(e, liveset) in ((c,e'), add_excon(free_in_e, c)) end val children = map doBranch branches val freeInRules = union_llvs (map #2 children) - val (opt',freeInOpt) = case e_opt of - NONE => (NONE,empty_liveset) - | SOME e => + val (opt',freeInOpt) = case e_opt of + NONE => (NONE,empty_liveset) + | SOME e => let val (e',livee') = llv (e, liveset) in (SOME e', livee') end val (e', freee')= llv(e,liveset) - in + in (SWITCH_E(SWITCH(e',map #1 children, opt')), - union_llv(freeInRules, union_llv(freeInOpt, freee'))) - end - - | CON0{con,il,aux_regions,alloc} => - let val livehere= norm_liveset liveset - in - (CON0{con=con,il=il,aux_regions= map (fn rho => (rho,livehere)) aux_regions, - alloc = (alloc,livehere)}, - empty_liveset) - end - - | CON1({con,il,alloc},tr1) => (* tr1 is trivial *) - let val (tr1',freeInArgs) = llv(tr1, liveset) - val livehere = norm_liveset(union_llv(liveset, freeInArgs)) - in - (CON1({con=con,il=il,alloc = (alloc,livehere)}, tr1'), + union_llv(freeInRules, union_llv(freeInOpt, freee'))) + end + + | CON0{con,il,aux_regions,alloc=NONE} => + let val livehere = norm_liveset 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 + in + (CON0{con=con,il=il,aux_regions= map (fn rho => (rho,livehere)) aux_regions, + alloc = SOME(alloc,livehere)}, + empty_liveset) + end + + | CON1({con,il,alloc=NONE},tr1) => (* tr1 is trivial *) + let val (tr1',freeInArgs) = llv(tr1, liveset) + val livehere = norm_liveset(union_llv(liveset, freeInArgs)) + in + (CON1({con=con,il=il,alloc=NONE}, tr1'), freeInArgs) - end - | DECON({con,il}, tr1) => (* tr1 is trivial *) - let - val (tr1', free_tr1) = llv(tr1, liveset) - in - (DECON({con=con, il=il}, tr1'), + 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)) + in + (CON1({con=con,il=il,alloc=SOME(alloc,livehere)}, tr1'), + freeInArgs) + end + | DECON({con,il}, tr1) => (* tr1 is trivial *) + let val (tr1', free_tr1) = llv(tr1, liveset) + in (DECON({con=con, il=il}, tr1'), free_tr1) - end - - | 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')), + end + | 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')), add_excon(free_tr1,excon)) - end - | DEEXCON(excon,tr1) => (* tr1 trivial *) - let - val (tr1', free_tr1) = llv(tr1, liveset) - in - (DEEXCON(excon,tr1'), + end + | DEEXCON(excon,tr1) => (* tr1 trivial *) + let val (tr1', free_tr1) = llv(tr1, liveset) + in (DEEXCON(excon,tr1'), free_tr1) - end + end + | 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), + freeInArgs) + end + | RECORD(NONE, nil) => (RECORD(NONE, nil), empty_liveset) + | RECORD(NONE, _) => die "llvExp.RECORD.NONE" - | RECORD(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((rho,norm_liveset(union_llv(freeInArgs, liveset))), map #1 children), - freeInArgs) - end - - | SELECT(i,tr1) =>(* tr1 trivial *) - let - val (tr1', free_tr1) = llv(tr1, liveset) - in - (SELECT(i, tr1'),free_tr1) - end - | DEREF(tr1) => (* tr1 trivial *) - let - val (tr1', free_tr1) = llv(tr1, liveset) - in - (DEREF(tr1'),free_tr1) - 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'), + | SELECT(i,tr1) => (* tr1 trivial *) + let val (tr1', free_tr1) = llv(tr1, liveset) + in (SELECT(i, tr1'),free_tr1) + end + | DEREF(tr1) => (* tr1 trivial *) + let val (tr1', free_tr1) = llv(tr1, liveset) + in (DEREF(tr1'),free_tr1) + 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'), free_tr1) - end - | ASSIGN(rho,tr1,tr2) => (* tr1 and tr2 trivial *) - let - val (tr1',free_tr1) = llv(tr1, liveset) - val (tr2',free_tr2) = llv(tr2, liveset) - in - (ASSIGN((rho,norm_liveset(liveset)), tr1',tr2'), - union_llv(free_tr1,free_tr2)) - end - | DROP(tr1) => - let val (tr1', free_in_tr1) = llv(tr1,liveset) (* it might be ok to - replace "liveset" by "empty_liveset" *) - in (DROP tr1', free_in_tr1) - end - | EQUAL({mu_of_arg1,mu_of_arg2,alloc = rho}, tr1, tr2) => (* tr1 and tr2 trivial *) - let - val (tr1',free_tr1) = llv(tr1, liveset) - val (tr2',free_tr2) = llv(tr2, liveset) - in - (EQUAL({mu_of_arg1=mu_of_arg1, mu_of_arg2 = mu_of_arg2, - alloc = (rho, norm_liveset(union_many[free_tr1,free_tr2,liveset]))}, - tr1',tr2'), + end + | ASSIGN(tr1,tr2) => (* tr1 and tr2 trivial *) + let val (tr1',free_tr1) = llv(tr1, liveset) + val (tr2',free_tr2) = llv(tr2, liveset) + in (ASSIGN(tr1',tr2'), union_llv(free_tr1,free_tr2)) - end - | CCALL ({name, mu_result, rhos_for_result}, trs) => (* trs consists of trivial expressions only*) - let + end + | DROP(tr1) => + let val (tr1', free_in_tr1) = llv(tr1,liveset) (* it might be ok to + replace "liveset" by "empty_liveset" *) + in (DROP tr1', free_in_tr1) + end + | EQUAL({mu_of_arg1,mu_of_arg2}, tr1, tr2) => (* tr1 and tr2 trivial *) + let val (tr1',free_tr1) = llv(tr1, liveset) + val (tr2',free_tr2) = llv(tr2, liveset) + in + (EQUAL({mu_of_arg1=mu_of_arg1, mu_of_arg2 = mu_of_arg2}, + tr1',tr2'), + union_llv(free_tr1,free_tr2)) + end + | CCALL ({name, mu_result, rhos_for_result}, trs) => (* trs consists of trivial expressions only*) + 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)) - in - (CCALL ({name = name, mu_result = mu_result, - rhos_for_result = - map (fn (rho, i_opt) => ((rho, liveset_here), i_opt)) - rhos_for_result}, - map #1 children), - freeInChildren) - end - - | BLOCKF64(rho, trs) => (* elements of trs trivial *) - let val children = map (fn tr => llv(tr, liveset)) trs - val freeInArgs = union_many(map #2 children) - in + in + (CCALL ({name = name, mu_result = mu_result, + rhos_for_result = + map (fn (rho, i_opt) => ((rho, liveset_here), i_opt)) + rhos_for_result}, + map #1 children), + freeInChildren) + end + + | BLOCKF64(rho, trs) => (* elements of trs trivial *) + 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), freeInArgs) - end - | SCRATCHMEM(n,a) => (SCRATCHMEM(n,(a, norm_liveset 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, alloc = rho,regions_for_resetting}, tr1) => (* tr1 is trivial *) - let + end + | SCRATCHMEM(n,a) => (SCRATCHMEM(n,(a, norm_liveset 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 + in (RESET_REGIONS({force=force, - alloc = (rho, liveset), + liveset=SOME liveset, regions_for_resetting = - map (fn rho => (rho,liveset)) regions_for_resetting}, tr1'), + map (fn rho => (rho,liveset)) regions_for_resetting}, tr1'), free_tr1) - end - | FRAME{declared_lvars,declared_excons} => - (FRAME{declared_lvars=declared_lvars, declared_excons=declared_excons}, - (* we have to assume that subsequent program unit refer to - all exported lvars and excons: (previously, I had this set to be empty) *) + end + | FRAME{declared_lvars,declared_excons} => + (FRAME{declared_lvars=declared_lvars, declared_excons=declared_excons}, + (* we have to assume that subsequent program unit refer to + al l exported lvars and excons: (previously, I had this set to be empty) *) (fromList (map #lvar declared_lvars), map #1 declared_excons) - ) + ) end - handle Crash.CRASH => - (log "Locally Live Variables failed at expression:\n"; - dump(MulInf.layoutExp e); - raise AbortExpression) + handle Crash.CRASH => + (log "Locally Live Variables failed at expression:\n"; + dump(MulInf.layoutExp e); + raise AbortExpression) (* llv *) @@ -558,4 +542,4 @@ struct end end (* local open MulExp *) -end; (*LocallyLiveVariables*) +end diff --git a/src/Compiler/Regions/MUL.sig b/src/Compiler/Regions/MUL.sig index b947f1ae3..9cc0e9438 100644 --- a/src/Compiler/Regions/MUL.sig +++ b/src/Compiler/Regions/MUL.sig @@ -1,144 +1,139 @@ -(* contains multiplicities, multiplicity effects, +(* contains multiplicities, multiplicity effects, effect environments, multiplicity substitutions, etc*) -signature MUL = -sig - type mulef (* multiplicity effects, psi *) - type mularef (* multiplicity arrow effects *) - type mularefset (* multiplicity arrow effect sets *) - type mularefmap (* multiplicity arrow effect maps, Psi *) - type imp_mularefmap (* imperative multiplicity arrow effect maps, Psi *) - type efenv (* effect environments *) - type efsubst (* effect substitutions *) - type qmularefset (* quantified multiplicity arrow effect set*) - type lvar (* lambda variables *) - type place (* region variables; from EFFECT *) - - structure Effect: EFFECT - type effectvar - sharing type effectvar = Effect.effect - type effect (* = ateff list *) - type arroweffect (* = effectvar * effect *) - type ateffect - sharing type ateffect = Effect.effect - - datatype mul = INF | NUM of int (* multiplicities *) - val sumef: mulef*mulef -> mulef - val sum_psis: mulef list -> mulef - val maxef: mulef*mulef -> mulef - val max_psis: mulef list -> mulef - val diffef: mulef*mulef -> mulef - val timesef: mul*mulef -> mulef - - (* nf(eps, psi) computes the normal form of the arrow effect (eps, psi); - normal forms eliminate cycles (making the multiplicities in psi infinite). - diffef may only be used on multiplicity effects that stem from two arrow - effects which are both in normal form. - *) - val nf: mularef -> mularef - - (* these functions are used in the letregion case of mulinf*) - val removeatomiceffects: mulef*Effect.effect list-> mulef - val getmultiplicities: mulef*place list -> mul list - val getmultiplicities_unsorted: mulef*place list -> mul list - - val K: int (* largest finite multiplicity (e.g., 1 *) - val empty_psi: mulef - val empty_qmularefset:qmularefset - val empty_efenv: efenv - val initial: efenv - - (* create an effect containing a zero multiplicity put-effect to place - is used in the ASG-case of mulinf*) - val putzero: place ->mulef - val makezero_muleffect: Effect.effect list -> mulef - val reify: mularef ref list -> mularefmap - val mk_infinite: mularef -> mularef - - (* the functions create effect with multiplicity one*) - - val put: place -> mulef - val get: place -> mulef - val efvar: effectvar->mulef - - (* the functions create effect with multiplicity INF *) - - val putInf: place -> mulef - val getInf: place -> mulef - - val placeof: qmularefset -> place - val makearef:effectvar*mulef->mularef - val makeqmularefset: place list*effectvar list* imp_mularefmap*place * Effect.cone -> - qmularefset - val makesubst: effectvar*mularef->efsubst - val un_mularef: mularef -> effectvar * mulef - val make_arroweffects: (Effect.effect* Effect.effect list) list -> arroweffect list (* the identity*) - val makezero_Phi: (Effect.effect* Effect.effect list) list -> imp_mularefmap - (*i.e., arroweffect list -> imp_mularefmap *) - val lookup_mularefmap: imp_mularefmap*effectvar -> mularef ref - val combine: mularefmap * imp_mularefmap -> imp_mularefmap - val plus_mularefmap: mularefmap * mularefmap -> mularefmap - val empty_mularefmap : mularefmap - val initial_mularefmap : mularefmap - val restrict_mularefmap : mularefmap * effectvar list -> mularefmap - val enrich_mularefmap : mularefmap * mularefmap -> bool - - val lookup_efenv: efenv*lvar->qmularefset ref - val declare: efenv*lvar*qmularefset ref -> efenv - val plus : efenv * efenv -> efenv - val restrict_efenv : efenv * lvar list -> efenv - - type regionStatEnv - val enrich_efenv : (efenv*regionStatEnv) * (efenv*regionStatEnv) -> bool - - val apply_mulef :efsubst*mulef -> mulef - val apply_mularef :efsubst*mularef -> mularef - val apply_mularefset :efsubst*mularefset -> mularefset - val apply_qmularefset :efsubst*qmularefset -> qmularefset - - val instantiateRegions: place list * qmularefset -> qmularefset - - (* inteffect psi converts the multiplicities of psi to integers (INF = 10000) - Is used when passing the effect of an expression to the interpreter *) - val inteffect:mulef->(ateffect*int)list - - datatype shared = MULEFF of mulef ref - | MULAREFF of mularef ref - | MULSCHEME of qmularefset ref - - type dependency_map - val empty_dep : dependency_map - val reset_dep : unit -> unit - val lookup_dep: dependency_map * effectvar -> shared list - val add_dependency: dependency_map * effectvar * shared -> dependency_map - val add_dependencies: dependency_map * shared * Effect.effect list -> dependency_map - val doSubst: effectvar*mulef*dependency_map ->unit - (* doSubst(eps,delta_psi,Psi): if delta_psi is not just a zero increment, - then increment every shared semantic object in dep(eps) - by delta_psi *) - val instantiateeffects : arroweffect list * qmularefset * imp_mularefmap * dependency_map-> unit - - val last_increment: unit -> int (* last time a multiplicity was increased *) - - val mk_init_dependency_map: imp_mularefmap -> dependency_map - (* pretty printing *) - type StringTree - val layout_mul: mul -> StringTree - val layout_mulef: mulef -> StringTree - val layout_mularef: mularef -> StringTree - val layout_mularefset: mularefset -> StringTree - val layout_mularefmap: mularefmap -> StringTree - val layout_imp_mularefmap: imp_mularefmap -> StringTree - val layout_qmularefset: qmularefset -> StringTree - val layout_subst: efsubst -> StringTree - val layout_Phi: arroweffect list -> StringTree - val layout_effect : effect -> StringTree - val layout_efenv : efenv -> StringTree - - (* Picklers *) - val pu_efenv : efenv Pickle.pu - val pu_mularefmap : mularefmap Pickle.pu +signature MUL = sig + type mulef (* multiplicity effects, psi *) + type mularef (* multiplicity arrow effects *) + type mularefset (* multiplicity arrow effect sets *) + type mularefmap (* multiplicity arrow effect maps, Psi *) + type imp_mularefmap (* imperative multiplicity arrow effect maps, Psi *) + type efenv (* effect environments *) + type efsubst (* effect substitutions *) + type qmularefset (* quantified multiplicity arrow effect set*) + type lvar (* lambda variables *) + type place (* region variables; from EFFECT *) + + structure Effect: EFFECT + type effectvar = Effect.effect + type effect (* = ateff list *) + type arroweffect (* = effectvar * effect *) + type ateffect = Effect.effect + + datatype mul = INF | NUM of int (* multiplicities *) + val sumef : mulef*mulef -> mulef + val sum_psis : mulef list -> mulef + val maxef : mulef*mulef -> mulef + val max_psis : mulef list -> mulef + val diffef : mulef*mulef -> mulef + val timesef : mul*mulef -> mulef + + (* nf(eps, psi) computes the normal form of the arrow effect (eps, psi); + normal forms eliminate cycles (making the multiplicities in psi infinite). + diffef may only be used on multiplicity effects that stem from two arrow + effects which are both in normal form. + *) + val nf: mularef -> mularef + + (* these functions are used in the letregion case of mulinf*) + val removeatomiceffects : mulef*Effect.effect list-> mulef + val getmultiplicities : mulef*place list -> mul list + val getmultiplicities_unsorted : mulef*place list -> mul list + + val K: int (* largest finite multiplicity (e.g., 1 *) + val empty_psi : mulef + val empty_qmularefset : qmularefset + val empty_efenv : efenv + val initial : efenv + + (* create an effect containing a zero multiplicity put-effect to place + is used in the ASG-case of mulinf*) + val putzero : place ->mulef + val makezero_muleffect : Effect.effect list -> mulef + val reify : mularef ref list -> mularefmap + val mk_infinite : mularef -> mularef + + (* the functions create effect with multiplicity one*) + + val put : place -> mulef + val get : place -> mulef + val efvar : effectvar->mulef + + (* the functions create effect with multiplicity INF *) + + val putInf : place -> mulef + val getInf : place -> mulef + + val placeof : qmularefset -> place option + val makearef : effectvar * mulef -> mularef + val makeqmularefset : place list * effectvar list * imp_mularefmap * place option * Effect.cone + -> qmularefset + val makesubst : effectvar * mularef -> efsubst + val un_mularef : mularef -> effectvar * mulef + val make_arroweffects : (Effect.effect * Effect.effect list) list -> arroweffect list (* the identity*) + val makezero_Phi : (Effect.effect * Effect.effect list) list -> imp_mularefmap + (*i.e., arroweffect list -> imp_mularefmap *) + val lookup_mularefmap : imp_mularefmap*effectvar -> mularef ref + val combine : mularefmap * imp_mularefmap -> imp_mularefmap + val plus_mularefmap : mularefmap * mularefmap -> mularefmap + val empty_mularefmap : mularefmap + val initial_mularefmap : mularefmap + val restrict_mularefmap : mularefmap * effectvar list -> mularefmap + val enrich_mularefmap : mularefmap * mularefmap -> bool + + val lookup_efenv : efenv*lvar->qmularefset ref + val declare : efenv*lvar*qmularefset ref -> efenv + val plus : efenv * efenv -> efenv + val restrict_efenv : efenv * lvar list -> efenv + + type regionStatEnv + val enrich_efenv : (efenv*regionStatEnv) * (efenv*regionStatEnv) -> bool + + val apply_mulef : efsubst*mulef -> mulef + val apply_mularef : efsubst*mularef -> mularef + val apply_mularefset : efsubst*mularefset -> mularefset + val apply_qmularefset : efsubst*qmularefset -> qmularefset + + val instantiateRegions : place list * qmularefset -> qmularefset + + (* inteffect psi converts the multiplicities of psi to integers (INF = 10000) + Is used when passing the effect of an expression to the interpreter *) + val inteffect:mulef->(ateffect*int)list + + datatype shared = MULEFF of mulef ref + | MULAREFF of mularef ref + | MULSCHEME of qmularefset ref + + type dependency_map + val empty_dep : dependency_map + val reset_dep : unit -> unit + val lookup_dep : dependency_map * effectvar -> shared list + val add_dependency : dependency_map * effectvar * shared -> dependency_map + val add_dependencies : dependency_map * shared * Effect.effect list -> dependency_map + val doSubst : effectvar*mulef*dependency_map ->unit + (* doSubst(eps,delta_psi,Psi): if delta_psi is not just a zero increment, + then increment every shared semantic object in dep(eps) + by delta_psi *) + val instantiateeffects : arroweffect list * qmularefset * imp_mularefmap * dependency_map -> unit + + val last_increment : unit -> int (* last time a multiplicity was increased *) + + val mk_init_dependency_map : imp_mularefmap -> dependency_map + (* pretty printing *) + type StringTree + val layout_mul: mul -> StringTree + val layout_mulef: mulef -> StringTree + val layout_mularef: mularef -> StringTree + val layout_mularefset: mularefset -> StringTree + val layout_mularefmap: mularefmap -> StringTree + val layout_imp_mularefmap: imp_mularefmap -> StringTree + val layout_qmularefset: qmularefset -> StringTree + val layout_subst: efsubst -> StringTree + val layout_Phi: arroweffect list -> StringTree + val layout_effect : effect -> StringTree + val layout_efenv : efenv -> StringTree + + (* Picklers *) + val pu_efenv : efenv Pickle.pu + val pu_mularefmap : mularefmap Pickle.pu end - - diff --git a/src/Compiler/Regions/MUL_EXP.sml b/src/Compiler/Regions/MUL_EXP.sml index 9d7fd28a0..4b75f429a 100644 --- a/src/Compiler/Regions/MUL_EXP.sml +++ b/src/Compiler/Regions/MUL_EXP.sml @@ -28,10 +28,13 @@ signature MUL_EXP = eqtype tyvar - type Type and sigma and il and cone and constructorKind and + type Type and mu and sigma and il and cone and constructorKind and datbinds and metaType and ateffect and mulef and mularef and mularefmap and dependency_map and qmularefset and regionStatEnv + type lvarset + type liveset = lvarset * excon list + structure RegionExp: REGION_EXP where type lvar = lvar where type con = con @@ -47,6 +50,7 @@ signature MUL_EXP = where type metaType = metaType where type datbinds = datbinds where type Type = Type + where type mu = mu datatype callKind = JMP (* tail call to fix-bound function *) | FUNCALL (* non-tail call to fix-bound function *) @@ -59,8 +63,8 @@ signature MUL_EXP = datatype ('a,'b,'c) LambdaPgm = PGM of {expression: ('a,'b,'c)trip, export_datbinds: datbinds, - import_vars: (lvar list * excon list * place list) option ref, - export_vars: lvar list * excon list * place list, + import_vars: (lvar list * excon list * place list) option ref, + export_vars: lvar list * excon list * place list, export_basis: ateffect list, (* list of region variables and arrow effects *) export_Psi: mularef ref list } @@ -73,18 +77,18 @@ signature MUL_EXP = and ('a,'b,'c)LambdaExp = VAR of {lvar: lvar, il : il, plain_arreffs: (effectvar * ateffect list) list, fix_bound: bool, rhos_actuals: 'a list ref, other: 'c} - | INTEGER of IntInf.int * Type * 'a - | WORD of IntInf.int * Type * 'a + | INTEGER of IntInf.int * Type * 'a option + | WORD of IntInf.int * Type * 'a option | STRING of string * 'a | REAL of string * 'a (* reals are represented as strings - * for the precision to be preserved. *) - | F64 of string * 'a (* f64s are represented as strings - * for the precision to be preserved. *) + * for the precision to be preserved. *) + | F64 of string (* f64s are represented as strings + * for the precision to be preserved. *) | UB_RECORD of ('a,'b,'c) trip list (* unboxed records *) - | FN of {pat : (lvar * (Type*place)) list, + | FN of {pat : (lvar * mu) list, body : ('a,'b,'c)trip, - free: (lvar list * excon list * place list) option ref, + free: (lvar list * excon list * place list) option ref, alloc: 'a} | LETREGION of {B: effect list ref, (* contains both region variables and arrow effects *) @@ -93,28 +97,28 @@ signature MUL_EXP = | LET of {k_let: bool, pat : (lvar * il ref list ref * (tyvar*effectvar option) list * - effect list ref * Type * place * 'c) list, - bind : ('a,'b,'c)trip, - scope: ('a,'b,'c)trip} + effect list ref * Type * place option * 'c) list, + bind : ('a,'b,'c)trip, + scope: ('a,'b,'c)trip} | FIX of {free: (lvar list * excon list * place list) option ref, - shared_clos: 'a, + shared_clos: 'a, functions : {lvar : lvar, occ : il list, (* instantiation lists *) (* at non-binding occurrences of il *) - tyvars : (tyvar*effectvar option) list, (* original *) + tyvars : (tyvar*effectvar option) list, (* original *) rhos: place list, (* region *) epss: effect list, (* type *) - Type : Type, (* scheme. *) - rhos_formals: 'b list ref, + Type : Type, (* scheme. *) + rhos_formals: 'b list ref, bound_but_never_written_into: 'b list option, (* set by DropRegions; used by CompLamb*) other: 'c, - bind : ('a,'b,'c)trip} list, - scope : ('a,'b,'c)trip} + bind : ('a,'b,'c)trip} list, + scope : ('a,'b,'c)trip} | APP of callKind option * saveRestore * ('a,'b,'c)trip * ('a,'b,'c)trip - | EXCEPTION of excon * bool * (Type*place) * 'a * ('a,'b,'c)trip - (* Type*place: of exception constructor + | EXCEPTION of excon * bool * mu * 'a * ('a,'b,'c)trip + (* mu: of exception constructor bool: true if exception is nullary *) | RAISE of ('a,'b,'c)trip | HANDLE of ('a,'b,'c)trip * ('a,'b,'c)trip @@ -123,59 +127,59 @@ signature MUL_EXP = | SWITCH_S of ('a,'b,'c,string) Switch | SWITCH_C of ('a,'b,'c,con) Switch | SWITCH_E of ('a,'b,'c,excon) Switch - | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a} - | CON1 of {con : con, il : il, alloc: 'a} * ('a,'b,'c)trip + | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a option} + | CON1 of {con : con, il : il, alloc: 'a option} * ('a,'b,'c)trip | DECON of {con : con, il : il} * ('a,'b,'c)trip | EXCON of excon * ('a * ('a,'b,'c)trip) option (* nullary excons are looked up in dyn env. *) | DEEXCON of excon * ('a,'b,'c)trip - | RECORD of 'a * ('a,'b,'c)trip list + | RECORD of 'a option * ('a,'b,'c)trip list | SELECT of int * ('a,'b,'c)trip | DEREF of ('a,'b,'c)trip | REF of 'a * ('a,'b,'c)trip - | ASSIGN of 'a * ('a,'b,'c)trip * ('a,'b,'c)trip + | ASSIGN of ('a,'b,'c)trip * ('a,'b,'c)trip | DROP of ('a,'b,'c)trip - | EQUAL of {mu_of_arg1: Type * place , mu_of_arg2: Type*place, alloc: 'a} * ('a,'b,'c)trip * ('a,'b,'c)trip + | EQUAL of {mu_of_arg1: mu, mu_of_arg2: mu} * ('a,'b,'c)trip * ('a,'b,'c)trip | CCALL of {name : string, - mu_result : Type * place, (*mu of result from c function*) - rhos_for_result : ('a * int option) list} - * ('a,'b,'c)trip list (* Calling C functions *) - - (*`rhos_for_result' is technical but needed in PhysSizeInf, MulInf & - CompLamb. Roughly it is the rho arguments to the c function as - described in the documentation in the chapter `Calling C Functions'. - So do not change the order if you tamper with this list! - `rhos_for_result' is needed in PhysSizeInf, MulInf & CompLamb. It - is a list of pairs (rho, i_opt), where rho is a region variable in - the return type for the c function `name'. `i_opt' describes how - `name' will allocate in rho. `Some 0' means that `name' will put an - unboxed type in rho (e.g., bool or unit). `Some i' means that - `name' will allocate i words in rho. `None' means that `name' may - allocate unboundedly in rho. rhos with a tyvar as tau are not in - the list. I think it would be wrong if c_function_effects removed - duplicates (using Eff.remove_duplicates), because we may want the - same region passed to the c function more than once if it simply - happens to be used for more than one thing.*) + mu_result : mu, (*mu of result from c function*) + rhos_for_result : ('a * int option) list} + * ('a,'b,'c)trip list (* Calling C functions *) + + (*`rhos_for_result' is technical but needed in PhysSizeInf, MulInf & + CompLamb. Roughly it is the rho arguments to the c function as + described in the documentation in the chapter `Calling C Functions'. + So do not change the order if you tamper with this list! + `rhos_for_result' is needed in PhysSizeInf, MulInf & CompLamb. It + is a list of pairs (rho, i_opt), where rho is a region variable in + the return type for the c function `name'. `i_opt' describes how + `name' will allocate in rho. `Some 0' means that `name' will put an + unboxed type in rho (e.g., bool or unit). `Some i' means that + `name' will allocate i words in rho. `None' means that `name' may + allocate unboundedly in rho. rhos with a tyvar as tau are not in + the list. I think it would be wrong if c_function_effects removed + duplicates (using Eff.remove_duplicates), because we may want the + same region passed to the c function more than once if it simply + happens to be used for more than one thing.*) | BLOCKF64 of 'a * ('a,'b,'c)trip list | SCRATCHMEM of int * 'a | EXPORT of {name : string, - mu_arg : Type * place, (*mu of argument for c function*) - mu_res : Type * place} - * ('a,'b,'c)trip - - | RESET_REGIONS of {force: bool, alloc : 'a, regions_for_resetting: 'a list} - * ('a,'b,'c)trip (* for programmer-directed resetting of regions; *) - (* resetting is forced iff "force" is true. *) - (* Forced resetting is not guaranteed to be sound *) + mu_arg : mu, (*mu of argument for c function*) + mu_res : mu} + * ('a,'b,'c)trip + + | RESET_REGIONS of {force: bool, liveset: liveset option, regions_for_resetting: 'a list} + * ('a,'b,'c)trip (* for programmer-directed resetting of regions; *) + (* resetting is forced iff "force" is true. *) + (* Forced resetting is not guaranteed to be sound *) | FRAME of {declared_lvars: {lvar : lvar, sigma : sigma, other : 'c, - place : place} list, - declared_excons: (excon * (Type*place) option) list} + place : place option} list, + declared_excons: (excon * mu option) list} (* a frame is the result of a structure-level * declaration. - *) + *) and ('a,'b,'c,'d) Switch = SWITCH of ('a,'b,'c)trip * ('d * ('a,'b,'c)trip) list * ('a,'b,'c)trip option @@ -211,7 +215,6 @@ signature MUL_EXP = ('b list * 'a -> 'b list) -> ('a,'b,'c)LambdaPgm -> ('a,'b,'c)LambdaPgm - val printcount: int ref (* controls printing of effects on expressions*) val layoutLambdaPgm: ('a -> StringTree option) -> ('a -> StringTree option) -> ('b -> StringTree option) -> ('c -> StringTree option) -> ('a, 'b, 'c)LambdaPgm -> StringTree diff --git a/src/Compiler/Regions/MUL_INF.sml b/src/Compiler/Regions/MUL_INF.sml index 448f4336b..b8afbdcdb 100644 --- a/src/Compiler/Regions/MUL_INF.sml +++ b/src/Compiler/Regions/MUL_INF.sml @@ -1,22 +1,22 @@ (* Multiplicity Inference *) -signature MUL_INF = +signature MUL_INF = sig type ('a,'b)LambdaPgm_phi and ('a,'b,'c)LambdaPgm_psi and cone and place and mulef and efenv and mul and qmularefset and mularefmap and ('a,'b,'c)LambdaExp - val mulInf: (place,unit)LambdaPgm_phi * mularefmap * cone * efenv -> + val mulInf: (place,unit)LambdaPgm_phi * mularefmap * cone * efenv -> (place,place*mul, qmularefset ref)LambdaPgm_psi * efenv * mularefmap val k_normPgm: (place,place*mul, qmularefset ref)LambdaPgm_psi -> - (place,place*mul, qmularefset ref)LambdaPgm_psi + (place,place*mul, qmularefset ref)LambdaPgm_psi - val contract : (place,place*mul, qmularefset ref)LambdaPgm_psi -> unit + val contract : (place,place*mul, qmularefset ref)LambdaPgm_psi -> unit type StringTree val layoutLambdaPgm: (place,place*mul,qmularefset ref)LambdaPgm_psi -> StringTree val layoutExp: (place,place*mul,qmularefset ref)LambdaExp -> StringTree - end + end diff --git a/src/Compiler/Regions/Mul.sml b/src/Compiler/Regions/Mul.sml index cfdfda64c..502bbd4cf 100644 --- a/src/Compiler/Regions/Mul.sml +++ b/src/Compiler/Regions/Mul.sml @@ -8,8 +8,8 @@ struct structure PP = PrettyPrint structure QM_EffVarEnv = QuasiEnv(structure OFinMap = EffVarEnv - val key = Effect.key_of_eps_or_rho - val eq = Effect.eq_effect) + val key = Effect.key_of_eps_or_rho + val eq = Effect.eq_effect) structure LvarMap = Lvar.Map @@ -94,7 +94,7 @@ struct val lookup = QM_EffVarEnv.lookup fun layoutMap format f g Psi = QM_EffVarEnv.layout format f g Psi - fun add(eps,range,qmap) = (QM_EffVarEnv.update(eps,range,qmap);qmap) + fun add (eps,range,qmap) = (QM_EffVarEnv.update(eps,range,qmap);qmap) val plus = QM_EffVarEnv.Env.plus fun Fold f recipient (source:mularef ref map) = QM_EffVarEnv.Fold (fn ((key, y), acc) => f((key,y), acc)) recipient source @@ -111,7 +111,7 @@ struct type mularefmap = mularef ref GlobalEffVarEnv.map (* cross-module Psi *) type imp_mularefmap = mularef ref EffVarEnv.map (* intra-compilation-unit Psi *) - fun combine(Psi_global: mularefmap, Psi_local: imp_mularefmap): imp_mularefmap= + fun combine (Psi_global: mularefmap, Psi_local: imp_mularefmap): imp_mularefmap= QM_EffVarEnv.combine(Psi_global, Psi_local) fun summul (NUM n1, NUM n2) = if n1 + n2 > K then INF else NUM (n1 + n2) @@ -124,142 +124,142 @@ struct compress((ae1, summul(m1,m2))::rest) else (ae1,m1)::compress((ae2,m2)::rest) - fun equal_mulef(mulef1,mulef2) = + fun equal_mulef (mulef1,mulef2) = let val sort = ListSort.sort (fn (ae1,_) => fn (ae2,_) => Eff.ae_lt(ae1,ae2)) val mulef1 = compress(sort mulef1) val mulef2 = compress(sort mulef2) - fun eq ([],[]) = true - | eq ((ae1,mul1)::mulef1,(ae2,mul2)::mulef2) = - Eff.eq_effect(ae1,ae2) andalso mul1=mul2 andalso eq (mulef1,mulef2) - | eq _ = false + fun eq ([],[]) = true + | eq ((ae1,mul1)::mulef1,(ae2,mul2)::mulef2) = + Eff.eq_effect(ae1,ae2) andalso mul1=mul2 andalso eq (mulef1,mulef2) + | eq _ = false in eq(mulef1,mulef2) end handle Eff.AE_LT => die "equal_mulef.effect in dom of mulef1 or mulef2 not atomic" - fun equal_mularef((eps1,mulef1),(eps2,mulef2)) = - Eff.eq_effect(eps1,eps2) andalso equal_mulef(mulef1,mulef2) + fun equal_mularef ((eps1,mulef1),(eps2,mulef2)) = + Eff.eq_effect(eps1,eps2) andalso equal_mulef(mulef1,mulef2) - fun enrich_mularefmap(mularefmap1,mularefmap2) = - GlobalEffVarEnv.Fold(fn ((effectvar2,ref res2),b) => b andalso - case GlobalEffVarEnv.lookup mularefmap1 effectvar2 - of SOME (ref res1) => equal_mularef(res1,res2) - | NONE => false) true mularefmap2 + fun enrich_mularefmap (mularefmap1,mularefmap2) = + GlobalEffVarEnv.Fold(fn ((effectvar2,ref res2),b) => b andalso + case GlobalEffVarEnv.lookup mularefmap1 effectvar2 + of SOME (ref res1) => equal_mularef(res1,res2) + | NONE => false) true mularefmap2 - fun restrict_mularefmap(mularefmap,effectvars) = + fun restrict_mularefmap (mularefmap,effectvars) = List.foldl(fn (effectvar,acc) => - case GlobalEffVarEnv.lookup mularefmap effectvar - of SOME res => GlobalEffVarEnv.add(effectvar,res,acc) - | NONE => die "restrict_mularefmap") GlobalEffVarEnv.empty effectvars + case GlobalEffVarEnv.lookup mularefmap effectvar + of SOME res => GlobalEffVarEnv.add(effectvar,res,acc) + | NONE => die "restrict_mularefmap") GlobalEffVarEnv.empty effectvars (* A quantified multiplicity arrow effect set represents a type scheme. An effect environment is a finite map from program variables (lvars) to (refs to) quantified multiplicity arrow effect sets. *) - type qmularefset = (effectvar list * place list * mularefset)* place (* Xi *) - val empty_qmularefset :qmularefset = (([], [],[]), Eff.toplevel_region_withtype_top ) + type qmularefset = (effectvar list * place list * mularefset) * place option (* Xi *) + val empty_qmularefset :qmularefset = (([], [],[]), SOME Eff.toplevel_region_withtype_top ) type efenv = qmularefset ref LvarMap.map - fun restrict_efenv(efenv,lvars) = + fun restrict_efenv (efenv,lvars) = foldl(fn (lv,acc) => - case LvarMap.lookup efenv lv - of SOME res => LvarMap.add(lv,res,acc) - | NONE => die "restrict_efenv") LvarMap.empty lvars + case LvarMap.lookup efenv lv + of SOME res => LvarMap.add(lv,res,acc) + | NONE => die "restrict_efenv") LvarMap.empty lvars (* normalize_qmularefset(qmularefset,sigma) normalizes qmularefset * with respect to the order arroweffects occur in tau of sigma. * Rhos are normalized during S and R. *) - fun normalize_qmularefset(qmularefset : qmularefset,sigma) : qmularefset = + fun normalize_qmularefset (qmularefset : qmularefset,sigma) : qmularefset = let fun visit n = Eff.get_visited n := true - fun unvisit n = Eff.get_visited n := false + fun unvisit n = Eff.get_visited n := false val ((epss,rhos,mularefs),rho) = qmularefset - val epss' = Eff.remove_duplicates (List.filter Eff.is_arrow_effect (RType.ann_sigma(sigma)[])) - val _ = List.app visit epss - val epss' = List.filter (! o Eff.get_visited) epss' - val _ = List.app unvisit epss - fun shuffle [] = [] - | shuffle (eps::epss) = - let fun grep [] = die "normalize_qmularefset.shuffle" - | grep ((mularef as (eps',mulef))::mularefs) = if Eff.eq_effect(eps,eps') then mularef - else grep mularefs - in grep mularefs :: shuffle epss - end + val epss' = Eff.remove_duplicates (List.filter Eff.is_arrow_effect (RType.ann_sigma sigma [])) + val _ = List.app visit epss + val epss' = List.filter (! o Eff.get_visited) epss' + val _ = List.app unvisit epss + fun shuffle [] = [] + | shuffle (eps::epss) = + let fun grep [] = die "normalize_qmularefset.shuffle" + | grep ((mularef as (eps',mulef))::mularefs) = if Eff.eq_effect(eps,eps') then mularef + else grep mularefs + in grep mularefs :: shuffle epss + end in ((epss',rhos,shuffle epss'),rho) end - fun arity_qmularefset((epss,rhos,_),_) : int * int = (List.length epss, List.length rhos) + fun arity_qmularefset ((epss,rhos,_),_) : int * int = (List.length epss, List.length rhos) fun equal_mularefset ([],[]) = true | equal_mularefset (mularef1::mularefset1,mularef2::mularefset2) = - equal_mularef(mularef1,mularef2) andalso equal_mularefset(mularefset1,mularefset2) + equal_mularef(mularef1,mularef2) andalso equal_mularefset(mularefset1,mularefset2) | equal_mularefset _ = false - fun instantiate_qmularefset(epss',rhos',((epss,rhos,mularefset),_) : qmularefset) : mularefset = + fun instantiate_qmularefset (epss',rhos',((epss,rhos,mularefset),_) : qmularefset) : mularefset = let val eps_pairs = BasisCompat.ListPair.zipEq (epss,epss') handle BasisCompat.ListPair.UnequalLengths => die "instantiate_qmularefset.Zip" val rho_pairs = BasisCompat.ListPair.zipEq (rhos,rhos') handle BasisCompat.ListPair.UnequalLengths => die "instantiate_qmularefset.Zip" - fun setInstance(node,node') = (Eff.get_instance node) := SOME node' - fun clearInstance(node,node') = (Eff.get_instance node) := NONE - fun on_ae ae = if Eff.is_arrow_effect ae then - case !(Eff.get_instance ae) - of SOME ae => ae - | NONE => ae - else if Eff.is_put ae then - case !(Eff.get_instance (rho_of ae)) - of SOME rho => Eff.mkPut rho - | NONE => ae - else if Eff.is_get ae then - case !(Eff.get_instance (rho_of ae)) - of SOME rho => Eff.mkGet rho - | NONE => ae - else die "on_ae.not atomic effect" - fun on_mulef [] = [] - | on_mulef ((ae,mul)::mulef) = (on_ae ae,mul) :: on_mulef mulef - fun on_mularef (eps,mulef) = - case !(Eff.get_instance eps) - of SOME node => (node, on_mulef mulef) - | NONE => die "on_mularef.no forward info" - fun on_mularefset [] = [] - | on_mularefset (mularef::mularefset) = on_mularef mularef :: on_mularefset mularefset - val _ = List.app setInstance eps_pairs - val _ = List.app setInstance rho_pairs - val mularefset' = on_mularefset mularefset - val _ = List.app setInstance eps_pairs - val _ = List.app setInstance rho_pairs + fun setInstance (node,node') = (Eff.get_instance node) := SOME node' + fun clearInstance (node,node') = (Eff.get_instance node) := NONE + fun on_ae ae = if Eff.is_arrow_effect ae then + case !(Eff.get_instance ae) + of SOME ae => ae + | NONE => ae + else if Eff.is_put ae then + case !(Eff.get_instance (rho_of ae)) + of SOME rho => Eff.mkPut rho + | NONE => ae + else if Eff.is_get ae then + case !(Eff.get_instance (rho_of ae)) + of SOME rho => Eff.mkGet rho + | NONE => ae + else die "on_ae.not atomic effect" + fun on_mulef [] = [] + | on_mulef ((ae,mul)::mulef) = (on_ae ae,mul) :: on_mulef mulef + fun on_mularef (eps,mulef) = + case !(Eff.get_instance eps) + of SOME node => (node, on_mulef mulef) + | NONE => die "on_mularef.no forward info" + fun on_mularefset [] = [] + | on_mularefset (mularef::mularefset) = on_mularef mularef :: on_mularefset mularefset + val _ = List.app setInstance eps_pairs + val _ = List.app setInstance rho_pairs + val mularefset' = on_mularefset mularefset + val _ = List.app setInstance eps_pairs + val _ = List.app setInstance rho_pairs in mularefset' end - fun equal_qmularefset((qmularefset1:qmularefset,sigma1),(qmularefset2:qmularefset,sigma2)) = - arity_qmularefset(qmularefset1) = arity_qmularefset(qmularefset2) andalso + fun equal_qmularefset ((qmularefset1:qmularefset,sigma1),(qmularefset2:qmularefset,sigma2)) = + arity_qmularefset(qmularefset1) = arity_qmularefset(qmularefset2) andalso (* (1) normalize qmularefsets so that bvs comes in the order of first * occurrences in its type. (2) instantiate qmularefsets to fresh * rhos and arrow effects. (3) check for equality of instantiated * mularefsets. *) - let val qmularefset1 as ((epss1,rhos1,_),_) = normalize_qmularefset(qmularefset1,sigma1) - val qmularefset2 = normalize_qmularefset(qmularefset2,sigma2) - val cone = Eff.push Eff.initCone - val (fresh_epss,cone) = Eff.freshEpss(epss1,cone) - val (fresh_rhos,cone) = Eff.freshRhos(rhos1,cone) - val mularefset1 = instantiate_qmularefset(fresh_epss,fresh_rhos,qmularefset1) - val mularefset2 = instantiate_qmularefset(fresh_epss,fresh_rhos,qmularefset2) - val _ = Eff.pop cone - in equal_mularefset(mularefset1,mularefset2) - end + let val qmularefset1 as ((epss1,rhos1,_),_) = normalize_qmularefset(qmularefset1,sigma1) + val qmularefset2 = normalize_qmularefset(qmularefset2,sigma2) + val cone = Eff.push Eff.initCone + val (fresh_epss,cone) = Eff.freshEpss(epss1,cone) + val (fresh_rhos,cone) = Eff.freshRhos(rhos1,cone) + val mularefset1 = instantiate_qmularefset(fresh_epss,fresh_rhos,qmularefset1) + val mularefset2 = instantiate_qmularefset(fresh_epss,fresh_rhos,qmularefset2) + val _ = Eff.pop cone + in equal_mularefset(mularefset1,mularefset2) + end type regionStatEnv = RSE.regionStatEnv - fun enrich_efenv((efenv1,rse1),(efenv2,rse2)) = + fun enrich_efenv ((efenv1,rse1),(efenv2,rse2)) = LvarMap.Fold(fn ((lv2,ref res2),b) => b andalso - case LvarMap.lookup efenv1 lv2 - of SOME (ref res1) => - let val sigma1 = case RSE.lookupLvar rse1 lv2 - of SOME a => #4 a - | NONE => die "enrich_efenv.lv not in rse1" - val sigma2 = case RSE.lookupLvar rse2 lv2 - of SOME a => #4 a - | NONE => die "enrich_efenv.lv not in rse2" - in equal_qmularefset((res1,sigma1),(res2,sigma2)) - end - | NONE => false) true efenv2 + case LvarMap.lookup efenv1 lv2 + of SOME (ref res1) => + let val sigma1 = case RSE.lookupLvar rse1 lv2 + of SOME a => #4 a + | NONE => die "enrich_efenv.lv not in rse1" + val sigma2 = case RSE.lookupLvar rse2 lv2 + of SOME a => #4 a + | NONE => die "enrich_efenv.lv not in rse2" + in equal_qmularefset((res1,sigma1),(res2,sigma2)) + end + | NONE => false) true efenv2 fun placeof (_, b) = b @@ -271,7 +271,6 @@ struct | MULAREFF of mularef ref | MULSCHEME of qmularefset ref - structure DepEnv = struct type 'a map = (int * 'a) list array @@ -286,9 +285,9 @@ struct | NONE => NONE end fun layoutMap _ _ _ _ = PP.LEAF "(not implemented)" - fun hash(key) = key mod size + fun hash key = key mod size val key_of_toplevel_arreff = Effect.key_of_eps_or_rho Effect.toplevel_arreff - fun add(eps, range, _) = + fun add (eps, range, _) = let val key = Effect.key_of_eps_or_rho eps val hash = hash key val old_list = Array.sub(empty, hash) @@ -299,7 +298,7 @@ struct else (); empty end - fun reset() = (* reset all entries of the depency map array to [] and then + fun reset () = (* reset all entries of the depency map array to [] and then insert toplevel_arreff (e9) in the map with an empty list of dependants. *) let fun loop n = if n>=size then () @@ -312,14 +311,14 @@ struct [(key_of_toplevel_arreff,[])]) end - fun plus(old_hash, new_hash) = new_hash + fun plus (old_hash, new_hash) = new_hash end type dependency_map = shared list DepEnv.map type efsubst = (effectvar*mularef)list - fun reset_dep() = DepEnv.reset() + fun reset_dep () = DepEnv.reset() (*pretty printing*) @@ -366,20 +365,20 @@ struct (* layout_atompair sets and clears visited fields *) - fun layout_atompair(ae, mul) = - layout_pair(layout_ateffect ae, ":", layout_mul mul) + fun layout_atompair (ae, mul) = + layout_pair(layout_ateffect ae, ":", layout_mul mul) (* layout_mulef sets and clears visited fields *) fun layout_mulef psi = - layout_set_horizontal (map layout_atompair psi) + layout_set_horizontal (map layout_atompair psi) (* layout_mularef sets and clears visited fields *) fun layout_mularef (eps, psi)= - layout_pair(layout_effectvar eps,".", layout_mulef psi) + layout_pair(layout_effectvar eps,".", layout_mulef psi) (* layout_mularefset sets and clears visited fields *) fun layout_mularefset Psi = - layout_set (map layout_mularef Psi) + layout_set (map layout_mularef Psi) (* (* layout_effectvar_int: no side-effect *) @@ -388,17 +387,17 @@ struct (* layout_mularefmap sets and clears visited fields *) fun layout_mularefmap Psi = - GlobalEffVarEnv.layoutMap{start = "Mularefmap: [", finish = "]", eq = " -> ", sep = ", "} - layout_effectvar (layout_mularef o !) Psi + GlobalEffVarEnv.layoutMap{start = "Mularefmap: [", finish = "]", eq = " -> ", sep = ", "} + layout_effectvar (layout_mularef o !) Psi (* layout_imp_mularefmap: sets and clears visited fields *) fun layout_imp_mularefmap Psi = - EffVarEnv.layoutMap{start = "{", finish = "}", eq = "=", sep = ","} - layout_effectvar (layout_mularef o !) Psi + EffVarEnv.layoutMap{start = "{", finish = "}", eq = "=", sep = ","} + layout_effectvar (layout_mularef o !) Psi (* layout_effectvars: no side-effect *) fun layout_effectvars epss = - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT" ", + PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT" ", children = map layout_effectvar epss} (* layout_place : no side-effect *) @@ -406,37 +405,37 @@ struct (* layout_places: no side-effects *) fun layout_places rhos = - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT" ", - children = map layout_place rhos} + PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT" ", + children = map layout_place rhos} fun at t = - PP.NODE{start = " at ", finish = "", indent = 4, childsep = PP.NOSEP, - children = [t]} + PP.NODE{start = " at ", finish = "", indent = 4, childsep = PP.NOSEP, + children = [t]} (* layout_qmul: sets and clears visited fields *) fun layout_qmul (epses, rhos, Psi)= - PP.NODE{start = "forall ", finish = "", indent = 7, childsep = PP.NOSEP, - children = [layout_effectvars epses, - layout_places rhos, - layout_mularefset Psi]} + PP.NODE{start = "forall ", finish = "", indent = 7, childsep = PP.NOSEP, + children = [layout_effectvars epses, + layout_places rhos, + layout_mularefset Psi]} fun layout_qmularefset (((epses, rhos, Psi), p):qmularefset)= - PP.NODE{start = "forall ", finish = "", indent = 7, childsep = PP.NOSEP, - children = [layout_effectvars epses, - layout_places rhos, - layout_mularefset Psi, - at(layout_place p)]} + PP.NODE{start = "forall ", finish = "", indent = 7, childsep = PP.NOSEP, + children = [layout_effectvars epses, + layout_places rhos, + layout_mularefset Psi, + at(case p of NONE => PP.LEAF "none" | SOME p => layout_place p)]} fun layout_efenv mulenv = - LvarMap.layoutMap{start="Efenv: [", finish = "]", eq = " -> ", sep = ", "} - (PP.LEAF o Lvar.pr_lvar) - (layout_qmularefset o !) - mulenv + LvarMap.layoutMap{start="Efenv: [", finish = "]", eq = " -> ", sep = ", "} + (PP.LEAF o Lvar.pr_lvar) + (layout_qmularefset o !) + mulenv fun layout_mapping (eps, aref) = - layout_pair(layout_effectvar eps, "->", layout_mularef aref) + layout_pair(layout_effectvar eps, "->", layout_mularef aref) fun layout_subst subst = - layout_set(map layout_mapping subst) + layout_set(map layout_mapping subst) fun layout_Phi Phi = layout_set (map layout_aref Phi) @@ -446,9 +445,9 @@ struct fun layout_dependency_map dep = DepEnv.layoutMap{start="{", finish = "}", eq = "=", sep = ","} - (fn eps => Effect.layout_effect eps) - (fn shared_list => layout_list(map layout_shared shared_list)) - dep + (fn eps => Effect.layout_effect eps) + (fn shared_list => layout_list(map layout_shared shared_list)) + dep (* operations on multiplicity effects *) @@ -457,7 +456,6 @@ struct fun inteffect psi = map (fn(x, mul)=>(x, intof_mul mul)) psi - fun maxmul (NUM n1, NUM n2) = if n1 > n2 then NUM n1 else NUM n2 | maxmul _ = INF @@ -489,20 +487,19 @@ struct are non-empty. The key value of a list is the key value of the first element of the list.*) - - fun leq_key(i, j) = Eff.ae_lt(i,j) orelse Eff.eq_effect(i,j) + fun leq_key (i, j) = Eff.ae_lt(i,j) orelse Eff.eq_effect(i,j) structure HI = struct type elem = (Eff.effect * mul)list - fun leq((x,_)::_, (y,_)::_) = leq_key(x,y) + fun leq ((x,_)::_, (y,_)::_) = leq_key(x,y) | leq _ = die "leq" - fun layout(_)= die "layout" + fun layout _ = die "layout" end structure Heap = Heap(structure HeapInfo = HI) - fun merge((ae1,m1), (ae2,m2)) = (ae1, summul(m1,m2)) - fun eq((ae1, m1), (ae2,m2)) = Eff.eq_effect(ae1, ae2) + fun merge ((ae1,m1), (ae2,m2)) = (ae1, summul(m1,m2)) + fun eq ((ae1, m1), (ae2,m2)) = Eff.eq_effect(ae1, ae2) fun makeHeap ll = let fun mkHeap([], h) = h @@ -512,16 +509,16 @@ struct mkHeap(ll, Heap.empty) end - fun insert([], h) = h - | insert( l, h) = Heap.insert l h + fun insert ([], h) = h + | insert (l, h) = Heap.insert l h - fun merge_against(min, h) = + fun merge_against (min, h) = if Heap.is_empty h then [min] else let (*val (l1 as (x1::xs1), h1) = Heap.delete_min h*) - val (l1,x1,xs1,h1) = - case Heap.delete_min h - of (l1 as (x1::xs1), h1) => (l1,x1,xs1,h1) - | _ => die "merge_against" + val (l1,x1,xs1,h1) = + case Heap.delete_min h + of (l1 as (x1::xs1), h1) => (l1,x1,xs1,h1) + | _ => die "merge_against" in if eq(min,x1) then if Heap.is_empty h1 then merge(min,x1)::xs1 else merge_against(merge(min,x1), insert(xs1, h1)) @@ -534,10 +531,10 @@ struct if Heap.is_empty h then [] else let (*val (l1 as (x1::xs1), h1) = Heap.delete_min h*) - val (l1,x1,xs1,h1) = - case Heap.delete_min h - of (l1 as (x1::xs1), h1) => (l1,x1,xs1,h1) - | _ => die "merge_against" + val (l1,x1,xs1,h1) = + case Heap.delete_min h + of (l1 as (x1::xs1), h1) => (l1,x1,xs1,h1) + | _ => die "merge_against" in merge_against(x1, insert(xs1,h1)) end @@ -545,14 +542,11 @@ struct merge_all(makeHeap ll) end - fun sum_psis [psi] = psi | sum_psis [psi1,psi2] = sumef(psi1,psi2) | sum_psis [] = die "sum_psis: expects at least one argument" | sum_psis (at_least_three) = MultiMerge.multimerge(at_least_three) (*sumef(psi, sum_psis psis)*) - - (* maxef(psi1,psi2): computes the max of psi1 and psi2. One does not necessarily have Dom(psi1) = Dom(psi2). Done by merging psi1 and psi2 @@ -597,29 +591,29 @@ struct local fun check ((e1,_)::(e2,_)::x) = - let fun toStr e = PP.flatten1 (Effect.layout_effect e) - val r1 = Effect.rho_of e1 - val r2 = Effect.rho_of e2 - in - say ("e1 = e2: " ^ Bool.toString(Eff.eq_effect(e1,e2))); - say ("rhoOf(e1) = rhoOf(e2): " ^ Bool.toString(Eff.eq_effect(r1,r2))); - say("e1 = " ^ toStr e1); - say("e2 = " ^ toStr e2); - say("r1 = " ^ toStr r1); - say("r2 = " ^ toStr r2) - end - | check _ = die "check bad" + let fun toStr e = PP.flatten1 (Effect.layout_effect e) + val r1 = Effect.rho_of e1 + val r2 = Effect.rho_of e2 + in + say ("e1 = e2: " ^ Bool.toString(Eff.eq_effect(e1,e2))); + say ("rhoOf(e1) = rhoOf(e2): " ^ Bool.toString(Eff.eq_effect(r1,r2))); + say("e1 = " ^ toStr e1); + say("e2 = " ^ toStr e2); + say("r1 = " ^ toStr r1); + say("r2 = " ^ toStr r2) + end + | check _ = die "check bad" in - fun diffef(mulef1,mulef2) = - diffef_aux(mulef1,mulef2) - handle DiffEf => - (say "oh-oh ... cannot subtract effects"; - say "mulef1: "; - outtree(layout_mulef mulef1); - say "\nmulef2: "; - outtree(layout_mulef mulef2); -(* check mulef1; *) - die "diffef failed") + fun diffef (mulef1,mulef2) = + diffef_aux(mulef1,mulef2) + handle DiffEf => + (say "oh-oh ... cannot subtract effects"; + say "mulef1: "; + outtree(layout_mulef mulef1); + say "\nmulef2: "; + outtree(layout_mulef mulef2); + (* check mulef1; *) + die "diffef failed") end fun timesef (mul,[]) = [] @@ -645,19 +639,19 @@ struct *) let val _ = List.app (fn eps_or_rho => Eff.get_visited eps_or_rho := true) discharged_basis fun keep (ae,mul): bool = - let val ae = Eff.find ae - in if Eff.is_arrow_effect ae then not(!(Eff.get_visited ae)) - else if Eff.is_put ae then not(!(Eff.get_visited(rho_of ae))) - else (*if Eff.is_get (Eff.find ae) + let val ae = Eff.find ae + in if Eff.is_arrow_effect ae then not(!(Eff.get_visited ae)) + else if Eff.is_put ae then not(!(Eff.get_visited(rho_of ae))) + else (*if Eff.is_get (Eff.find ae) then not(!(Eff.get_visited(Eff.rho_of ae))) else*) die "removeatomiceffects.keep" - end + end in List.filter keep psi footnote List.app (fn eps_or_rho => Eff.get_visited eps_or_rho := false) discharged_basis end *) - fun removeatomiceffects(psi, discharged_basis: Effect.effect list) = + fun removeatomiceffects (psi, discharged_basis: Effect.effect list) = Eff.removeatomiceffects(psi, discharged_basis) (* getmultiplicities(psi, [rho_1,...,rho_k]) returns [mul_1,..., mul_k], where mul_i @@ -665,10 +659,10 @@ struct getmultiplicities assumes that psi is sorted on Eff.ae_lt and that [rho_1,...,rho_k] are sorted according to their "key" fields. *) - fun getmultiplicities_loop(psi, [])= [] - | getmultiplicities_loop((ae1, mul1)::psi, rho::rhos) = + fun getmultiplicities_loop (psi, [])= [] + | getmultiplicities_loop ((ae1, mul1)::psi, rho::rhos) = let - val ae2 = Eff.mkPut rho (* important: mkPut returns existing Put rho, if one exists*) + val ae2 = Eff.mkPut rho (* important: mkPut returns existing Put rho, if one exists*) in if Eff.eq_effect(ae1,ae2) then mul1:: getmultiplicities_loop(psi, rhos) @@ -677,11 +671,11 @@ struct else getmultiplicities_loop(psi, rho::rhos) end - | getmultiplicities_loop([], ae2::phi) = map (fn _ => NUM 0) (ae2::phi) + | getmultiplicities_loop ([], ae2::phi) = map (fn _ => NUM 0) (ae2::phi) - fun getmultiplicities(psi,rhos) = getmultiplicities_loop(psi,rhos) + fun getmultiplicities (psi,rhos) = getmultiplicities_loop(psi,rhos) - fun getmultiplicities_unsorted(psi,rhos) = + fun getmultiplicities_unsorted (psi,rhos) = map (fn rho => let val ae_rho = Eff.mkPut rho in case List.find (fn (ae,mul) => Eff.eq_effect(ae, ae_rho)) psi of SOME (_,res) => res @@ -692,142 +686,120 @@ struct val empty_psi = [] val empty_efenv = LvarMap.empty - local - - (* To avoid multiplicity effects on regions with runtime type - * WORD_RT, the empty multiplicity effect is returned for calls - * to put, putInf, putzero, get, and getInf in the case that the - * argument is a word region (i.e., the word region - * r2). Instead, one could modify MulExp and the initial - * environment such that these functions are called only with - * arguments that represents non-word regions. ME 1998-09-03 - *) - - fun word_rho place = - case Eff.get_place_ty place - of SOME Eff.WORD_RT => true - | _ => false - in - fun put place = if word_rho place then [] else [(Eff.mkPut place, NUM 1)] - fun putInf place = if word_rho place then [] else [(Eff.mkPut place, INF)] - fun putzero place = if word_rho place then [] else [(Eff.mkPut place, NUM 0)] - fun get place = if word_rho place then [] else [(Eff.mkGet place, NUM 1)] - fun getInf place = if word_rho place then [] else [(Eff.mkGet place, INF)] - end + fun put place = [(Eff.mkPut place, NUM 1)] + fun putInf place = [(Eff.mkPut place, INF)] + fun putzero place = [(Eff.mkPut place, NUM 0)] + fun get place = [(Eff.mkGet place, NUM 1)] + fun getInf place = [(Eff.mkGet place, INF)] fun efvar eps = [(eps, NUM 1)] - fun makearef(eps,psi)= (eps,psi) - fun makesubst(eps, mularef):efsubst = [(eps, mularef)] + fun makearef (eps,psi)= (eps,psi) + fun makesubst (eps, mularef):efsubst = [(eps, mularef)] fun mk_infinite (eps, mulef) = (eps, map (fn (ae, _) => (ae, INF)) mulef) - fun lookup_mularefset((eps, psi)::Psi, eps') = - if Eff.eq_effect(eps, eps') then psi else lookup_mularefset(Psi, eps') - | lookup_mularefset([], eps') = - die ("lookup_mularefset: " ^ show_effectvar eps') + fun lookup_mularefset ((eps, psi)::Psi, eps') = + if Eff.eq_effect(eps, eps') then psi else lookup_mularefset(Psi, eps') + | lookup_mularefset ([], eps') = + die ("lookup_mularefset: " ^ show_effectvar eps') - fun lookup_mularefmap(Psi,eps)= + fun lookup_mularefmap (Psi,eps) = case EffVarEnv.lookup Psi eps of - SOME x => x - | NONE => die ("lookup_mularefmap: "^show_effectvar eps) + SOME x => x + | NONE => die ("lookup_mularefmap: "^show_effectvar eps) - fun reify(mularefs) = + fun reify mularefs = List.foldl (fn ((r as ref(eps,mulef)),acc) => - GlobalEffVarEnv.add((*Eff.key_of_eps_or_rho*) eps, r, acc)) - GlobalEffVarEnv.empty - mularefs + GlobalEffVarEnv.add((*Eff.key_of_eps_or_rho*) eps, r, acc)) + GlobalEffVarEnv.empty + mularefs - fun lookup_efenv(EE, lvar) = + fun lookup_efenv (EE, lvar) = case LvarMap.lookup EE lvar of - SOME x => x - | NONE => die ("lookup_efenv: "^Lvar.pr_lvar lvar) + SOME x => x + | NONE => die ("lookup_efenv: "^Lvar.pr_lvar lvar) - fun declare(EE,x,Xi) = LvarMap.add(x,Xi,EE) - fun plus(EE,EE') = LvarMap.plus(EE,EE') + fun declare (EE,x,Xi) = LvarMap.add(x,Xi,EE) + fun plus (EE,EE') = LvarMap.plus(EE,EE') - fun getimage([], x)= NONE - | getimage((x, fx)::f, x')= if Eff.eq_effect(x,x') then SOME fx else getimage(f, x') + fun getimage ([], x)= NONE + | getimage ((x, fx)::f, x')= if Eff.eq_effect(x,x') then SOME fx else getimage(f, x') fun apply_mulef (S, [])= [] | apply_mulef (S, psi0 as (ae_m as (eps,mul))::psi) = if Eff.is_arrow_effect eps then case getimage(S, eps) of - SOME (eps', psi') => + SOME (eps', psi') => sumef([(eps', mul)], sumef(timesef(mul, psi'), apply_mulef(S, psi))) - | NONE => sumef([ae_m], apply_mulef(S,psi)) + | NONE => sumef([ae_m], apply_mulef(S,psi)) else psi0 (*sumef([ae_m], apply_mulef(S, psi))*) - fun getarefs(Psi, epses)= + fun getarefs (Psi, epses)= ListPair.zip(epses, map (fn eps => lookup_mularefmap(Psi,eps)) epses) - fun apply_mularef(S, (eps,psi)) = case getimage(S, eps) of - SOME (eps', psi') => (eps', sumef( psi', apply_mulef(S, psi))) - | NONE => (eps, apply_mulef(S, psi)) + fun apply_mularef (S, (eps,psi)) = + case getimage(S, eps) of + SOME (eps', psi') => (eps', sumef( psi', apply_mulef(S, psi))) + | NONE => (eps, apply_mulef(S, psi)) fun pairmap f S [] = [] | pairmap f S (x::xs) = f(S, x)::(pairmap f S xs) - fun apply_mularefset(S, Psi)= pairmap apply_mularef S Psi + fun apply_mularefset (S, Psi) = pairmap apply_mularef S Psi fun sort_psi psi = ListSort.sort (fn (ae1,_) => fn (ae2,_) => Eff.ae_lt(ae1,ae2)) psi - fun apply_regionsubst_mulef(S, psi) = + fun apply_regionsubst_mulef (S, psi) = let val unsorted: mulef ref = ref [] val psi'_list = - (List.foldr (fn ((ae,mul),l) => - if Eff.is_put ae then - let val rho = rho_of ae - in if !(Eff.get_visited(rho)) then (* generic *) - (case getimage(S, rho) - of SOME place => (unsorted:= (Eff.mkPut place, mul):: !unsorted; l) - | NONE => die "apply_regionsubst_mulef: non-generic node visited") - else (* non-generic *) - (ae,mul)::l - end - else (ae,mul)::l) - [] psi) + (List.foldr (fn ((ae,mul),l) => + if Eff.is_put ae then + let val rho = rho_of ae + in if !(Eff.get_visited(rho)) then (* generic *) + (case getimage(S, rho) + of SOME place => (unsorted:= (Eff.mkPut place, mul):: !unsorted; l) + | NONE => die "apply_regionsubst_mulef: non-generic node visited") + else (* non-generic *) + (ae,mul)::l + end + else (ae,mul)::l) + [] psi) in case !unsorted of - [] => psi - | l => ((sumef(compress(sort_psi l), psi'_list)) handle X => die "apply_regionsubst_mulef.sumef") + [] => psi + | l => ((sumef(compress(sort_psi l), psi'_list)) handle X => die "apply_regionsubst_mulef.sumef") end - fun apply_regionsubst_mularef(S, (eps,psi)) = - (eps, apply_regionsubst_mulef(S, psi)) + fun apply_regionsubst_mularef (S, (eps,psi)) = + (eps, apply_regionsubst_mulef(S, psi)) - fun apply_regionsubst_mularefset(S, Psi)= + fun apply_regionsubst_mularefset (S, Psi)= let val visited_refs = map (fn (rho,_) => Eff.get_visited rho) S - - in - List.app (fn r => r:=true) visited_refs; - (* mark dom(Sr) as visited; for faster instantiation *) - pairmap apply_regionsubst_mularef S Psi - footnote List.app (fn r => r:=false) visited_refs + in List.app (fn r => r:=true) visited_refs; + (* mark dom(Sr) as visited; for faster instantiation *) + pairmap apply_regionsubst_mularef S Psi + footnote List.app (fn r => r:=false) visited_refs end - fun apply_qmularefset(S, ((epses,rhos, Psi), p)) = - ((epses, rhos, apply_mularefset(S, Psi)), p) - + fun apply_qmularefset (S, ((epses,rhos, Psi), p)) = + ((epses, rhos, apply_mularefset(S, Psi)), p) + fun instantiateRegions ([], qmularefset as((epses, [], Psi), place))= qmularefset + | instantiateRegions (places, ((epses, rhos, Psi), place))= + let val Sr = BasisCompat.ListPair.zipEq(rhos, places) + in ((epses, [], apply_regionsubst_mularefset(Sr, Psi)), place) + end + handle BasisCompat.ListPair.UnequalLengths => + die ("instantiateRegions: " ^ Int.toString(List.length rhos) ^ " formals, " ^ + Int.toString (List.length places) ^ "actuals") - fun instantiateRegions([], qmularefset as((epses, [], Psi), place))= qmularefset - | instantiateRegions(places, ((epses, rhos, Psi), place))= - let - val Sr = BasisCompat.ListPair.zipEq(rhos, places) - in - ((epses, [], apply_regionsubst_mularefset(Sr, Psi)), place) - end - handle BasisCompat.ListPair.UnequalLengths => - die ("instantiateRegions: " ^ Int.toString(List.length rhos) ^ " formals, " ^ - Int.toString (List.length places) ^ "actuals") - - fun cyclic(eps, []) = false - | cyclic(eps, (eps',_):: rest) = - Eff.eq_effect(eps,eps') orelse - Eff.ae_lt(eps', eps) andalso cyclic(eps,rest) + fun cyclic (eps, []) = false + | cyclic (eps, (eps',_):: rest) = + Eff.eq_effect(eps,eps') orelse + Eff.ae_lt(eps', eps) andalso cyclic(eps,rest) (* find_cyclic mularefs returns (SOME aref, mularefs') if @@ -842,16 +814,15 @@ struct in (c_opt, (eps,psi)::rest') end - fun remove_cycles(l : mularef list): mularef list = - case find_cyclic l of - (NONE, _) => l - |(SOME(eps,psi), rest) => - let val new_psi = map (fn (eps, _) => (eps, INF)) - (List.filter (fn (eps',_) => not(Eff.eq_effect(eps,eps'))) psi) - val Se = makesubst(eps,(eps,new_psi)) - in remove_cycles(apply_mularefset(Se,rest)@[(eps,new_psi)]) - end - + fun remove_cycles (l : mularef list): mularef list = + case find_cyclic l of + (NONE, _) => l + | (SOME(eps,psi), rest) => + let val new_psi = map (fn (eps, _) => (eps, INF)) + (List.filter (fn (eps',_) => not(Eff.eq_effect(eps,eps'))) psi) + val Se = makesubst(eps,(eps,new_psi)) + in remove_cycles(apply_mularefset(Se,rest)@[(eps,new_psi)]) + end (* fun checkPsi [] = true @@ -862,46 +833,45 @@ struct fun checkPsi Psi = List.al (not o cyclic) Psi *) - fun makeqmularefset (rhos,epses, Psi:imp_mularefmap, place, cone):qmularefset = - let - val c = Eff.push cone - val Psi':mularefset= - remove_cycles(map (fn (eps, r as ref mularef) => mularef) - (getarefs(Psi, epses))) - val (freshrhos,c) = Eff.freshRhos(rhos,c) - val (freshepses,c) = Eff.freshEpss(epses, c) - val S = BasisCompat.ListPair.zipEq(epses, BasisCompat.ListPair.zipEq(freshepses, - map (fn x => []) freshepses)) - val Sr= BasisCompat.ListPair.zipEq(rhos, freshrhos) - val Psi'' : mularefset = apply_mularefset(S, Psi') - val Psi'' : mularefset = apply_regionsubst_mularefset(Sr, Psi'') - in - (*if checkPsi Psi'' then () else die "makeqmularefset creates bad scheme"*) - Eff.pop c; - ((freshepses, freshrhos, Psi''), place) - end - handle BasisCompat.ListPair.UnequalLengths => die "makeqmularefset.Zip" - | _ => die "makeqmularefset" + fun makeqmularefset (rhos,epses, Psi:imp_mularefmap, place, cone) : qmularefset = + let val c = Eff.push cone + val Psi':mularefset= + remove_cycles(map (fn (eps, r as ref mularef) => mularef) + (getarefs(Psi, epses))) + val (freshrhos,c) = Eff.freshRhos(rhos,c) + val (freshepses,c) = Eff.freshEpss(epses, c) + val S = BasisCompat.ListPair.zipEq(epses, BasisCompat.ListPair.zipEq(freshepses, + map (fn x => []) freshepses)) + val Sr= BasisCompat.ListPair.zipEq(rhos, freshrhos) + val Psi'' : mularefset = apply_mularefset(S, Psi') + val Psi'' : mularefset = apply_regionsubst_mularefset(Sr, Psi'') + in + (*if checkPsi Psi'' then () else die "makeqmularefset creates bad scheme"*) + Eff.pop c; + ((freshepses, freshrhos, Psi''), place) + end + handle BasisCompat.ListPair.UnequalLengths => die "makeqmularefset.Zip" + | _ => die "makeqmularefset" val empty_dep = DepEnv.empty - fun lookup_dep(dep, eps) = + fun lookup_dep (dep, eps) = case DepEnv.lookup dep eps of - SOME x => x - | NONE => die ("lookup_dep: "^ show_effectvar eps ^ "\n" ^ - PP.flatten1(layout_dependency_map dep)) - - fun add_dependency(dep,eps,shared) = - let val shared_list = case DepEnv.lookup dep eps of - SOME x => x - | NONE => [] - in - DepEnv.add(eps, shared :: shared_list, dep) - end handle _ => die "add_dependency" + SOME x => x + | NONE => die ("lookup_dep: "^ show_effectvar eps ^ "\n" ^ + PP.flatten1(layout_dependency_map dep)) + + fun add_dependency (dep,eps,shared) = + let val shared_list = case DepEnv.lookup dep eps of + SOME x => x + | NONE => [] + in + DepEnv.add(eps, shared :: shared_list, dep) + end handle _ => die "add_dependency" val count_increment = ref 0 val no_increase_sofar = ref true - fun last_increment() = !count_increment + fun last_increment () = !count_increment (* normal form of arrow effects: an arrow effect eps.psi is said to be in normal form if, @@ -913,96 +883,95 @@ struct fun nf (eps,psi) = if cyclic(eps, psi) - then (* cyclic effect: make all multiplicities infinite *) - (eps, map(fn (eps,_) => (eps, INF)) - (List.filter (fn (eps',_) => not(Eff.eq_effect(eps,eps'))) psi)) - else - (eps, psi) + then (* cyclic effect: make all multiplicities infinite *) + (eps, map(fn (eps,_) => (eps, INF)) + (List.filter (fn (eps',_) => not(Eff.eq_effect(eps,eps'))) psi)) + else (eps, psi) (* mulef_has_grown(old_mulef, new_mulef) determines whether new_mulef>old_mulef Precondition: Dom(old_mulef) = Dom(new_mulef) and new_mulef>= old_mulef*) - fun mulef_has_grown_loop(mulef_old:mulef as [], muleff_new:mulef as []) = false - | mulef_has_grown_loop((ae1,m1)::mulef_old, (ae2,m2)::muleff_new) = - if not(Eff.eq_effect(ae1,ae2)) - then die "mulef_has_grown_loop: mismatching atomic effects" - else intof_mul m2 > intof_mul m1 - orelse mulef_has_grown_loop(mulef_old, muleff_new) + fun mulef_has_grown_loop (mulef_old:mulef as [], muleff_new:mulef as []) = false + | mulef_has_grown_loop ((ae1,m1)::mulef_old, (ae2,m2)::muleff_new) = + if not(Eff.eq_effect(ae1,ae2)) + then die "mulef_has_grown_loop: mismatching atomic effects" + else intof_mul m2 > intof_mul m1 + orelse mulef_has_grown_loop(mulef_old, muleff_new) | mulef_has_grown_loop _ = - die "mulef_has_grown: mismatching multiplicity effects" - - fun mulef_has_grown(mulef_old, mulef_new) = - mulef_has_grown_loop(mulef_old, mulef_new) handle x => - (mes("\nold: " ^ PP.flatten1(layout_mulef mulef_old) - ^ "\nnew: " ^ PP.flatten1(layout_mulef mulef_new) ^ "\n"); - raise x) - - - fun mularef_has_grown(mularef_old:mularef, mularef_new: mularef) = - mulef_has_grown(#2(nf mularef_old), #2(nf mularef_new)) - - fun nf_mularef_has_grown(mularef_old:mularef as (_,psi_old), - mularef_new:mularef as (_,psi_new)) = - mulef_has_grown(psi_old, psi_new) - - fun qmularefset_has_grown(old as ((_,_,Psi_old),_): qmularefset, - new as ((_,_,Psi_new),_): qmularefset) = - List.exists nf_mularef_has_grown (BasisCompat.ListPair.zipEq(Psi_old,Psi_new)) - handle _ => (say ("qmularefset_has_grown, old scheme:"); - outtree(layout_qmularefset old); - say ("qmularefset_has_grown, new scheme:"); - outtree(layout_qmularefset old); - die "qmularefset_has_grown: mismatching type schemes") + die "mulef_has_grown: mismatching multiplicity effects" + + fun mulef_has_grown (mulef_old, mulef_new) = + mulef_has_grown_loop (mulef_old, mulef_new) + handle x => + (mes("\nold: " ^ PP.flatten1(layout_mulef mulef_old) + ^ "\nnew: " ^ PP.flatten1(layout_mulef mulef_new) ^ "\n"); + raise x) + + fun mularef_has_grown (mularef_old:mularef, mularef_new: mularef) = + mulef_has_grown(#2(nf mularef_old), #2(nf mularef_new)) + + fun nf_mularef_has_grown (mularef_old:mularef as (_,psi_old), + mularef_new:mularef as (_,psi_new)) = + mulef_has_grown (psi_old, psi_new) + + fun qmularefset_has_grown (old as ((_,_,Psi_old),_): qmularefset, + new as ((_,_,Psi_new),_): qmularefset) = + List.exists nf_mularef_has_grown (BasisCompat.ListPair.zipEq(Psi_old,Psi_new)) + handle _ => (say ("qmularefset_has_grown, old scheme:"); + outtree(layout_qmularefset old); + say ("qmularefset_has_grown, new scheme:"); + outtree(layout_qmularefset old); + die "qmularefset_has_grown: mismatching type schemes") (* doSubst(eps,mulef,dep) performs the substitution eps |-> eps.mulef on every element of the list dep(eps), i.e., on every semantic object in which eps occurs free. *) - fun saw_progress() = + fun saw_progress () = (no_increase_sofar:= false; count_increment:= !count_increment+1) - fun doSubst(eps,[],dep): unit = () - | doSubst(eps,mulef,dep): unit = - let val dependants = lookup_dep(dep,eps) - val Se = makesubst(eps,(eps,mulef)) - fun update_shared(MULEFF(r as ref mulef)) = - let val new = apply_mulef(Se, mulef) - in - if !no_increase_sofar andalso mulef_has_grown(mulef, new) - then saw_progress() - else (); - r:= new - end - | update_shared(MULSCHEME(r as ref qmularefset)) = - let val new = apply_qmularefset(Se,qmularefset) - in - if !no_increase_sofar andalso - qmularefset_has_grown(qmularefset, new) - then saw_progress() - else (); - r:= new - end - | update_shared(MULAREFF(r as ref mularef)) = - let val new = apply_mularef(Se, mularef) - in - if !no_increase_sofar andalso mularef_has_grown(mularef, new) - handle x => - (say ("mularef_has_grown: old: "); - outtree(layout_mularef mularef); - say ("mularef_has_grown: new: "); - outtree(layout_mularef new); - raise x) - then saw_progress() - else (); - r:= new - end - in - no_increase_sofar:= true; - List.app update_shared dependants - handle x => (mes("substitution: " ^ PP.flatten1(layout_subst Se) ^ "\n"); - raise x) - end + fun doSubst (eps,[],dep): unit = () + | doSubst (eps,mulef,dep): unit = + let val dependants = lookup_dep(dep,eps) + val Se = makesubst(eps,(eps,mulef)) + fun update_shared (MULEFF(r as ref mulef)) = + let val new = apply_mulef(Se, mulef) + in + if !no_increase_sofar andalso mulef_has_grown(mulef, new) + then saw_progress() + else (); + r:= new + end + | update_shared (MULSCHEME(r as ref qmularefset)) = + let val new = apply_qmularefset(Se,qmularefset) + in + if !no_increase_sofar andalso + qmularefset_has_grown(qmularefset, new) + then saw_progress() + else (); + r:= new + end + | update_shared (MULAREFF(r as ref mularef)) = + let val new = apply_mularef(Se, mularef) + in + if !no_increase_sofar andalso mularef_has_grown(mularef, new) + handle x => + (say ("mularef_has_grown: old: "); + outtree(layout_mularef mularef); + say ("mularef_has_grown: new: "); + outtree(layout_mularef new); + raise x) + then saw_progress() + else (); + r:= new + end + in + no_increase_sofar:= true; + List.app update_shared dependants + handle x => (mes("substitution: " ^ PP.flatten1(layout_subst Se) ^ "\n"); + raise x) + end (* fun eq_epss(epses1,epses2): bool = List.all Eff.eq_effect (ListPair.zip(epses1,epses2)) @@ -1024,9 +993,9 @@ struct fun makezero_muleffect phi = map (fn x => (x, NUM 1)) phi (* phi must be sorted! *) - fun makezero_arroweffect(eps, phi) = (eps, makezero_muleffect phi) + fun makezero_arroweffect (eps, phi) = (eps, makezero_muleffect phi) - fun makezero_Phi(Phi: arroweffect list) : imp_mularefmap = + fun makezero_Phi (Phi: arroweffect list) : imp_mularefmap = List.foldl (fn ((eps,phi), Psi) => EffVarEnv.add(eps, ref(makezero_arroweffect(eps,phi)), Psi)) (QM_EffVarEnv.mk 1000 GlobalEffVarEnv.empty) @@ -1037,22 +1006,22 @@ struct fun check_eff s e = if Eff.is_put e orelse Eff.is_get e then - let val r = Eff.rho_of e - val k = Eff.key_of_eps_or_rho r - in if k = 1 andalso not(Eff.eq_effect(Eff.toplevel_region_withtype_top,r)) then - die ("check_eps: " ^ s) - else () - end + let val r = Eff.rho_of e + val k = Eff.key_of_eps_or_rho r + in if k = 1 andalso not(Eff.eq_effect(Eff.toplevel_region_withtype_top,r)) then + die ("check_eps: " ^ s) + else () + end else () fun check_psi s nil = () | check_psi s ((e,_)::xs) = (check_eff s e; check_psi s xs) - fun instantiate([], Xi, Psi, dep)= () - | instantiate((aref0 as (eps0,phi0))::plainarroweffects, + fun instantiate ([], Xi, Psi, dep)= () + | instantiate ((aref0 as (eps0,phi0))::plainarroweffects, qmul as (eps0' :: epses', [], Psi'), Psi, dep)= - let + let (* val _ = if checkPsi Psi' then () else (say "instantiate applied to ill-formed Xi = "; outtree(layout_qmul qmul)) @@ -1064,34 +1033,34 @@ struct val t3 = layout_mulef (lookup_mularefset(Psi', eps0')) *) val actual_psi = #2(nf(!(lookup_mularefmap(Psi, eps0)))) - val _ = check_psi "actual_psi" actual_psi (* mael 2004-10-19 *) - val formal_psi = lookup_mularefset(Psi', eps0') - val _ = check_psi "formal_psi" formal_psi (* mael 2004-10-19 *) + val _ = check_psi "actual_psi" actual_psi (* mael 2004-10-19 *) + val formal_psi = lookup_mularefset(Psi', eps0') + val _ = check_psi "formal_psi" formal_psi (* mael 2004-10-19 *) val new_actual_psi:mulef = maxef(actual_psi, formal_psi) (* formal, acyclic *) - val _ = check_psi "before nf" new_actual_psi (* mael 2004-10-19 *) + val _ = check_psi "before nf" new_actual_psi (* mael 2004-10-19 *) (* (eps0,new_actual_psi) is not necessarily acyclic, so normalise it: *) val (eps0,new_actual_psi) = nf (eps0,new_actual_psi) - val _ = check_psi "after nf" new_actual_psi (* mael 2004-10-19 *) + val _ = check_psi "after nf" new_actual_psi (* mael 2004-10-19 *) (* val t4 = layout_mulef new_actual_psi *) val Se:efsubst = [(eps0', (eps0,new_actual_psi))] val _ = doSubst(eps0, diffef(new_actual_psi,actual_psi), dep) - handle X => (say "\ninstantiate.doSubst or diffef failed\n"; raise X) + handle X => (say "\ninstantiate.doSubst or diffef failed\n"; raise X) handle x => - (say "eps0 is "; outtree (Eff.layout_effect eps0); - say "eps0' is "; outtree (Eff.layout_effect eps0'); + (say "eps0 is "; outtree (Eff.layout_effect eps0); + say "eps0' is "; outtree (Eff.layout_effect eps0'); (* - say "\nqmul="; outtree t0; + say "\nqmul="; outtree t0; say "\nlookup Psi gave"; outtree t1; say "\nnf gave"; outtree t2; say "\nlookup Psi' gave"; outtree t3; say "\nnew_actual_psi was:"; outtree t4; *) - raise x) - in + raise x) + in instantiate(plainarroweffects, (epses', [], apply_mularefset(Se, @@ -1105,7 +1074,7 @@ struct | instantiate _ = die "instatiate: wrong arguments" handle Zip => die "instantiate" - fun instantiateeffects(arroweffects, qmul as ((epses, [], Psi'), _), Psi, dep) = + fun instantiateeffects (arroweffects, qmul as ((epses, [], Psi'), _), Psi, dep) = instantiate(arroweffects, (epses, [], Psi'), Psi, dep) | instantiateeffects _ = die "instantiateeffects: non-empty list of formal regions" @@ -1114,7 +1083,7 @@ struct fun is_arrow_effect eps = Eff.is_arrow_effect (eps) - fun add_dependencies(dep:dependency_map,shared,phi): dependency_map = + fun add_dependencies (dep:dependency_map,shared,phi): dependency_map = let fun loop ([], dep) = dep | loop (eps::rest, dep) = if is_arrow_effect (eps) @@ -1135,8 +1104,8 @@ struct at the appropriate place which makes the result sorted. If eps' is already in phi, it is not inserted again. *) - fun cons_if_not_there(eps',[]) = [eps'] - | cons_if_not_there(eps',eps::rest) = + fun cons_if_not_there (eps',[]) = [eps'] + | cons_if_not_there (eps',eps::rest) = if Eff.eq_effect(eps,eps') then eps::rest else if Eff.ae_lt(eps', eps) then eps' :: eps :: rest else eps::cons_if_not_there(eps',rest) @@ -1147,7 +1116,7 @@ struct fun mk_init_dependency_map (Psi:imp_mularefmap) = let val _ = reset_dep() - val result = EffVarEnv.Fold mk_init_dep empty_dep Psi + val result = EffVarEnv.Fold mk_init_dep empty_dep Psi in (*say "initial dependency map";*) (*say "omitted"*) @@ -1170,16 +1139,16 @@ struct (* Picklers *) val pu_mul = let fun toInt INF = 0 - | toInt (NUM _) = 1 - val fun_INF = Pickle.con0 INF - fun fun_NUM _ = Pickle.con1 NUM (fn NUM a => a | _ => die "pu_mul.NUM") Pickle.int + | toInt (NUM _) = 1 + val fun_INF = Pickle.con0 INF + fun fun_NUM _ = Pickle.con1 NUM (fn NUM a => a | _ => die "pu_mul.NUM") Pickle.int in Pickle.dataGen("Mul.mul",toInt,[fun_INF,fun_NUM]) end val pu_mulef = Pickle.nameGen "mulef" (Pickle.listGen(Pickle.pairGen0(Eff.pu_effect,pu_mul))) val pu_mularef = Pickle.nameGen "mularef" (Pickle.pairGen0(Eff.pu_effect,pu_mulef)) val pu_mularefset = Pickle.listGen pu_mularef val pu_qmularefset = Pickle.pairGen0(Pickle.tup3Gen0(Eff.pu_effects,Eff.pu_effects,pu_mularefset), - Eff.pu_effect) + Pickle.optionGen Eff.pu_effect) (* val pu_efenv = LvarMap.pu Lvar.pu (Pickle.ref0Gen pu_qmularefset) *) val pu_efenv = LvarMap.pu Lvar.pu (Pickle.convert (ref,!) pu_qmularefset) diff --git a/src/Compiler/Regions/MulExp.sml b/src/Compiler/Regions/MulExp.sml index c993c7553..242f1e078 100644 --- a/src/Compiler/Regions/MulExp.sml +++ b/src/Compiler/Regions/MulExp.sml @@ -11,27 +11,26 @@ struct val print_regions = Flags.is_on0 "print_regions" val print_effects = Flags.is_on0 "print_effects" - val print_word_regions = Flags.is_on0 "print_word_regions" val print_K_normal_forms = Flags.add_bool_entry - {long="print_K_normal_forms", short=NONE, menu=["Layout","print K-Normal Forms"], - item=ref false, neg=false, desc= - "Print Region Expressions in K-Normal Form. Applicable,\n\ - \only after storage mode analysis has been applied."} + {long="print_K_normal_forms", short=NONE, menu=["Layout","print K-Normal Forms"], + item=ref false, neg=false, desc= + "Print Region Expressions in K-Normal Form. Applicable,\n\ + \only after storage mode analysis has been applied."} val warn_on_escaping_puts = Flags.add_bool_entry - {long="warn_on_escaping_puts", short=NONE, menu=["Control","warn on escaping put effects"], - item=ref false, neg=false, desc= - "Enable the compiler to issue a warning whenever a \n\ - \region type scheme contains a put effect on a region\n\ - \that is not quantified."} + {long="warn_on_escaping_puts", short=NONE, menu=["Control","warn on escaping put effects"], + item=ref false, neg=false, desc= + "Enable the compiler to issue a warning whenever a \n\ + \region type scheme contains a put effect on a region\n\ + \that is not quantified."} val warn_on_parallel_puts = Flags.add_bool_entry - {long="warn_on_parallel_puts", short=NONE, menu=["Control","warn on parallel put effects"], - item=ref false, neg=false, desc= - "Enable the compiler to issue a warning whenever a \n\ - \par-construct is passed functions with intersecting\n\ - \put effects."} + {long="warn_on_parallel_puts", short=NONE, menu=["Control","warn on parallel put effects"], + item=ref false, neg=false, desc= + "Enable the compiler to issue a warning whenever a \n\ + \par-construct is passed functions with intersecting\n\ + \put effects."} fun uncurry f (a, b) = f a b @@ -62,10 +61,14 @@ struct type mularef = Mul.mularef type Type = R.Type + and mu = R.mu and sigma = R.sigma and il = R.il and coneLayer = Eff.coneLayer + type lvarset = Lvarset.lvarset + type liveset = lvarset * excon list + type constructorKind = RegionExp.constructorKind type datbinds = RegionExp.datbinds type metaType = RegionExp.metaType @@ -90,8 +93,8 @@ struct datatype ('a,'b,'c) LambdaPgm = PGM of {expression:('a,'b,'c)trip, export_datbinds: datbinds, - import_vars: (lvar list * excon list * place list) option ref, - export_vars: lvar list * excon list * place list, + import_vars: (lvar list * excon list * place list) option ref, + export_vars: lvar list * excon list * place list, export_basis: effect list, (* list of region variables and arrow effects *) export_Psi: mularef ref list } @@ -103,16 +106,16 @@ struct and ('a,'b,'c)LambdaExp = VAR of {lvar: lvar, il: il, plain_arreffs: (effectvar * ateffect list) list, fix_bound: bool, rhos_actuals: 'a list ref, other: 'c} - | INTEGER of IntInf.int * Type * 'a - | WORD of IntInf.int * Type * 'a + | INTEGER of IntInf.int * Type * 'a option + | WORD of IntInf.int * Type * 'a option | STRING of string * 'a | REAL of string * 'a - | F64 of string * 'a + | F64 of string | UB_RECORD of ('a,'b,'c) trip list (* unboxed records *) - | FN of {pat : (lvar * (Type*place)) list, + | FN of {pat : (lvar * mu) list, body : ('a,'b,'c)trip, - free: (lvar list * excon list * place list) option ref, + free: (lvar list * excon list * place list) option ref, alloc: 'a} | LETREGION of {B: effect list ref, (* contains both region variables and arrow effects *) @@ -121,28 +124,28 @@ struct | LET of {k_let: bool, pat : (lvar * il ref list ref * (tyvar*effectvar option) list * - effect list ref * Type * place * 'c) list, - bind : ('a,'b,'c)trip, - scope: ('a,'b,'c)trip} + effect list ref * Type * place option * 'c) list, + bind : ('a,'b,'c)trip, + scope: ('a,'b,'c)trip} | FIX of {free: (lvar list * excon list * place list) option ref, - shared_clos: 'a, + shared_clos: 'a, functions : {lvar : lvar, occ : il list, (* instantiation lists *) (* at non-binding occurrences of il *) - tyvars : (tyvar*effectvar option) list, (* original *) + tyvars : (tyvar*effectvar option) list, (* original *) rhos: place list, (* region *) epss: effect list, (* type *) - Type : Type, (* scheme. *) - rhos_formals: 'b list ref, + Type : Type, (* scheme. *) + rhos_formals: 'b list ref, bound_but_never_written_into: 'b list option, other: 'c, - bind : ('a,'b,'c)trip} list, - scope : ('a,'b,'c)trip} + bind : ('a,'b,'c)trip} list, + scope : ('a,'b,'c)trip} | APP of callKind option * saveRestore * ('a,'b,'c)trip * ('a,'b,'c)trip - | EXCEPTION of excon * bool * (Type*place) * 'a * ('a,'b,'c)trip - (* Type*place: of exception constructor + | EXCEPTION of excon * bool * mu * 'a * ('a,'b,'c)trip + (* mu: of exception constructor bool: true if exception is nullary *) | RAISE of ('a,'b,'c)trip | HANDLE of ('a,'b,'c)trip * ('a,'b,'c)trip @@ -151,39 +154,39 @@ struct | SWITCH_S of ('a,'b,'c,string) Switch | SWITCH_C of ('a,'b,'c,con) Switch | SWITCH_E of ('a,'b,'c,excon) Switch - | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a} - | CON1 of {con : con, il : il, alloc: 'a} * ('a,'b,'c)trip + | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a option} + | CON1 of {con : con, il : il, alloc: 'a option} * ('a,'b,'c)trip | DECON of {con : con, il : il} * ('a,'b,'c)trip | EXCON of excon * ('a * ('a,'b,'c)trip) option (* nullary excons are looked up in dyn env. *) | DEEXCON of excon * ('a,'b,'c)trip - | RECORD of 'a * ('a,'b,'c)trip list + | RECORD of 'a option * ('a,'b,'c)trip list | SELECT of int * ('a,'b,'c)trip | DEREF of ('a,'b,'c)trip | REF of 'a * ('a,'b,'c)trip - | ASSIGN of 'a * ('a,'b,'c)trip * ('a,'b,'c)trip + | ASSIGN of ('a,'b,'c)trip * ('a,'b,'c)trip | DROP of ('a,'b,'c)trip - | EQUAL of {mu_of_arg1: Type * place , mu_of_arg2: Type*place, alloc: 'a} * ('a,'b,'c)trip * ('a,'b,'c)trip + | EQUAL of {mu_of_arg1: mu, mu_of_arg2: mu} * ('a,'b,'c)trip * ('a,'b,'c)trip | CCALL of {name : string, - mu_result : Type * place, (*mu of result from c function*) - rhos_for_result : ('a * int option) list} - * ('a,'b,'c)trip list (* Calling C functions *) + mu_result : mu, (*mu of result from c function*) + rhos_for_result : ('a * int option) list} + * ('a,'b,'c)trip list (* Calling C functions *) | BLOCKF64 of 'a * ('a,'b,'c)trip list | SCRATCHMEM of int * 'a | EXPORT of {name : string, - mu_arg : Type * place, (*mu of argument for c function*) - mu_res : Type * place} - * ('a,'b,'c)trip - | RESET_REGIONS of {force: bool, alloc : 'a,regions_for_resetting: 'a list} * ('a,'b,'c)trip (* for programmer-directed resetting of regions; - * resetting is forced iff "force" is true. - * Forced resetting is not guaranteed to be sound *) + mu_arg : mu, (*mu of argument for c function*) + mu_res : mu} + * ('a,'b,'c)trip + | RESET_REGIONS of {force: bool,liveset:liveset option,regions_for_resetting: 'a list} * ('a,'b,'c)trip (* for programmer-directed resetting of regions; + * resetting is forced iff "force" is true. + * Forced resetting is not guaranteed to be sound *) | FRAME of {declared_lvars: {lvar: lvar, sigma: sigma, other: 'c, - place: place} list, - declared_excons: (excon * (Type*place) option) list} + place: place option} list, + declared_excons: (excon * mu option) list} (* a frame is the result of a structure-level * declaration. - *) + *) and ('a,'b,'c,'d) Switch = SWITCH of ('a,'b,'c)trip * ('d * ('a,'b,'c)trip) list * ('a,'b,'c)trip option @@ -206,8 +209,8 @@ struct infix // val already_reported: R.place list ref = ref []; (* those region variables rho, for which other - * lvars with rho free in their type and place - * have already been reported once *) + * lvars with rho free in their type and place + * have already been reported once *) fun pp_regvar rho = PP.flatten1(Eff.layout_effect rho) fun flatten [] = [] @@ -224,30 +227,33 @@ struct else let val _ = already_reported:= rho :: (!already_reported) val excons_rho = - RSE.FoldExcon (fn ((excon, mu), l: string list) => - if List.exists (fn rho' => Eff.eq_effect(rho,rho'))(R.frv_mu mu) - then Excon.pr_excon excon :: l - else l)[] TE - val lvars_and_excons_rho = - RSE.FoldLvar (fn ((lvar, (_,_,_,sigma,p,_,_)), l: string list) => - if Eff.eq_effect(rho,p) orelse - List.exists (fn rho' => Eff.eq_effect(rho,rho')) - (R.frv_sigma sigma) - then Lvars.pr_lvar lvar :: l - else l - ) excons_rho TE + RSE.FoldExcon (fn ((excon, mu), l: string list) => + if List.exists (fn rho' => Eff.eq_effect(rho,rho')) (R.frv_mu mu) + then Excon.pr_excon excon :: l + else l)[] TE + val lvars_and_excons_rho = + RSE.FoldLvar (fn ((lvar, (_,_,_,sigma,p,_,_)), l: string list) => + case p of + SOME p => + if Eff.eq_effect(rho,p) orelse + List.exists (fn rho' => Eff.eq_effect(rho,rho')) + (R.frv_sigma sigma) + then Lvars.pr_lvar lvar :: l + else l + | NONE => l + ) excons_rho TE in - (pp_regvar rho:: - ", which is also free in the type schemes with places of : ":: - map (fn s => " " ^ s) lvars_and_excons_rho) @ ["\n"] - end - in + (pp_regvar rho:: + ", which is also free in the type schemes with places of : ":: + map (fn s => " " ^ s) lvars_and_excons_rho) @ ["\n"] + end + in Flags.warn (line (Lvars.pr_lvar lvar - ^ "\t has a type scheme with escaping put effects\ - \ on region(s): ") - // line (concat (flatten (map report_rho rhos)))) - end + ^ "\t has a type scheme with escaping put effects\ + \ on region(s): ") + // line (concat (flatten (map report_rho rhos)))) + end fun pr_ty ty = let val (lay_ty, _) = R.mk_layout false @@ -261,53 +267,59 @@ struct else let val _ = already_reported:= [] (* reset *) - fun warn_puts TE e = - case e of - FIX{shared_clos, functions, scope, ... (*bound_lvars,binds,scope,info*)} => - let val TE' = - foldr (fn ({lvar,tyvars,rhos,epss,Type,...}, TE') => - RSE.declareLvar(lvar, (true,true,[],R.FORALL(rhos,epss,tyvars,Type), shared_clos , NONE, NONE), TE')) - TE functions - - fun warn_lvar {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + fun warn_puts TE e = + case e of + FIX{shared_clos, functions, scope, ... (*bound_lvars,binds,scope,info*)} => + let val TE' = + foldr (fn ({lvar,tyvars,rhos,epss,Type,...}, TE') => + RSE.declareLvar(lvar, (true,true,[],R.FORALL(rhos,epss,tyvars,Type), SOME shared_clos, + NONE, NONE), TE')) + TE functions + + fun warn_lvar {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, bound_but_never_written_into,other,bind} = - let val sigma = R.FORALL(rhos,epss,tyvars,Type) - in (if warn_on_escaping_puts() then - warn_if_escaping_puts(TE, lvar, sigma) + let val sigma = R.FORALL(rhos,epss,tyvars,Type) + in (if warn_on_escaping_puts() then + warn_if_escaping_puts(TE, lvar, sigma) else ()); - warn_puts_trip TE' bind - end - in - app warn_lvar functions; - warn_puts_trip TE' scope - end + warn_puts_trip TE' bind + end + in + app warn_lvar functions; + warn_puts_trip TE' scope + end | FN{pat,body,...} => - let val TE' = foldr (fn ((lvar,(tau,rho)), TE') => - RSE.declareLvar(lvar, (true,true,[],R.type_to_scheme tau, rho , NONE, NONE), TE')) - TE pat - in - warn_puts_trip TE' body - end + let val TE' = foldr (fn ((lvar,mu), TE') => + let val (ty,rho) = + case R.unBOX mu of + SOME (ty,rho) => (ty,SOME rho) + | NONE => (mu,NONE) + in RSE.declareLvar(lvar, (true,true,[],R.type_to_scheme ty,rho,NONE,NONE), + TE') + end) + TE pat + in warn_puts_trip TE' body + end | LET{k_let,pat,bind,scope} => - (warn_puts_trip TE bind; - let - val TE' = foldr (fn ((lvar,_,tyvars,ref epss,tau,rho,_), TE') => - RSE.declareLvar(lvar, (true,true,[],R.FORALL([],epss,tyvars,tau), rho , NONE, NONE), TE')) - TE - pat - in warn_puts_trip TE' scope - end - ) - | APP(_,_,e1,e2) => (warn_puts_trip TE e1; warn_puts_trip TE e2) - | EXCEPTION(excon, is_nullary, (tau,p), _, body) => - warn_puts_trip (RSE.declareExcon(excon,(tau,p),TE)) body - | RAISE(e) => warn_puts_trip TE e - | HANDLE(e1,e2) => (warn_puts_trip TE e1; warn_puts_trip TE e2) - | SWITCH_I {switch, precision} => warn_puts_i TE switch - | SWITCH_W {switch, precision} => warn_puts_w TE switch - | SWITCH_S(switch) => warn_puts_s TE switch - | SWITCH_C(switch) => warn_puts_c TE switch - | SWITCH_E(switch) => warn_puts_e TE switch + (warn_puts_trip TE bind; + let val TE' = foldr (fn ((lvar,_,tyvars,ref epss,tau,rho,_), TE') => + RSE.declareLvar(lvar, (true,true,[],R.FORALL([],epss,tyvars,tau), rho, + NONE, NONE), + TE')) + TE + pat + in warn_puts_trip TE' scope + end) + | APP(_,_,e1,e2) => (warn_puts_trip TE e1; warn_puts_trip TE e2) + | EXCEPTION(excon, is_nullary, mu, _, body) => + warn_puts_trip (RSE.declareExcon(excon,mu,TE)) body + | RAISE(e) => warn_puts_trip TE e + | HANDLE(e1,e2) => (warn_puts_trip TE e1; warn_puts_trip TE e2) + | SWITCH_I {switch, precision} => warn_puts_i TE switch + | SWITCH_W {switch, precision} => warn_puts_w TE switch + | SWITCH_S(switch) => warn_puts_s TE switch + | SWITCH_C(switch) => warn_puts_c TE switch + | SWITCH_E(switch) => warn_puts_e TE switch | CON0 _ => () | CON1(_,tr) => warn_puts_trip TE tr | DECON(_,tr) => warn_puts_trip TE tr @@ -318,7 +330,7 @@ struct | SELECT(_,tr) => warn_puts_trip TE tr | DEREF tr => warn_puts_trip TE tr | REF(_,tr) => warn_puts_trip TE tr - | ASSIGN(_,tr1,tr2) => (warn_puts_trip TE tr1; warn_puts_trip TE tr2) + | ASSIGN(tr1,tr2) => (warn_puts_trip TE tr1; warn_puts_trip TE tr2) | DROP(tr1) => (warn_puts_trip TE tr1) | EQUAL(_,tr1,tr2) => (warn_puts_trip TE tr1; warn_puts_trip TE tr2) | CCALL(_,l) => app (warn_puts_trip TE) l @@ -328,88 +340,91 @@ struct | RESET_REGIONS(_,tr) => warn_puts_trip TE tr | FRAME _ => () | LETREGION{body, ...} => warn_puts_trip TE body - | _ => () + | _ => () and warn_puts_trip TE (TR(e,mt,_,_)) = case e of VAR {lvar, il, plain_arreffs, fix_bound=true, rhos_actuals, other} => if Lvars.pr_lvar lvar = "par" andalso warn_on_parallel_puts() then (case mt of - RegionExp.Mus[(ty,p)] => - (case R.unFUN ty of - SOME([(ty1,_),(ty2,_)],_,_) => - (case (R.unFUN ty1, R.unFUN ty2) of - (SOME(_,ae1,_), SOME(_,ae2,_)) => - let val s1 = R.type_to_scheme ty1 - val s2 = R.type_to_scheme ty2 - val ps1 = R.free_puts s1 - val ps2 = R.free_puts s2 - fun pr_effect e = PP.flatten1(Eff.layout_effect e) - fun pr_puteffect e = "put(" ^ pr_effect e ^ ")" - fun pr_list p l = "{" ^ String.concatWith "," (List.map p l) ^ "}" - val pr_puteffects = pr_list pr_puteffect - fun intersect nil l2 acc = acc - | intersect l1 nil acc = acc - | intersect (x::xs) ys acc = - intersect xs ys (if List.exists (fn y => Eff.eq_effect(x,y)) ys - then x::acc else acc) - val problematic = intersect ps1 ps2 nil - in - case problematic of - nil => Flags.warn (line "** Great: par is passed two functions with non-intersecting put effects!" // - line ("** fun1: " ^ pr_puteffects ps1) // - line ("** fun2: " ^ pr_puteffects ps2)) - | xs => Flags.warn (line ("** Ugggh: par is passed two functions with intersecting put effects!") // - line ("** problematic effects: " ^ pr_puteffects xs) // - line ("** fun1: " ^ pr_puteffects ps1) // - line ("** fun2: " ^ pr_puteffects ps2)) - end - | _ => print "par - no match - fun2\n") - | _ => print "par - no match - fun\n") - | _ => print "par - no match - mt\n") + RegionExp.Mus[mu] => + (case R.unBOX mu of + SOME (ty,p) => + (case R.unFUN ty of + SOME([mu1,mu2],_,_) => + (case (R.unBOX mu1, R.unBOX mu2) of + (SOME (ty1,_), SOME (ty2,_)) => + (case (R.unFUN ty1, R.unFUN ty2) of + (SOME _, SOME _) => + let val s1 = R.type_to_scheme ty1 + val s2 = R.type_to_scheme ty2 + val ps1 = R.free_puts s1 + val ps2 = R.free_puts s2 + fun pr_effect e = PP.flatten1(Eff.layout_effect e) + fun pr_puteffect e = "put(" ^ pr_effect e ^ ")" + fun pr_list p l = "{" ^ String.concatWith "," (List.map p l) ^ "}" + val pr_puteffects = pr_list pr_puteffect + fun intersect nil l2 acc = acc + | intersect l1 nil acc = acc + | intersect (x::xs) ys acc = + intersect xs ys (if List.exists (fn y => Eff.eq_effect(x,y)) ys + then x::acc else acc) + val problematic = intersect ps1 ps2 nil + in + case problematic of + nil => Flags.warn (line "** Great: par is passed two functions with non-intersecting put effects!" // + line ("** fun1: " ^ pr_puteffects ps1) // + line ("** fun2: " ^ pr_puteffects ps2)) + | xs => Flags.warn (line ("** Ugggh: par is passed two functions with intersecting put effects!") // + line ("** problematic effects: " ^ pr_puteffects xs) // + line ("** fun1: " ^ pr_puteffects ps1) // + line ("** fun2: " ^ pr_puteffects ps2)) + end + | _ => print "par - no match - fun2\n") + | _ => print "par - no match - fun1\n") + | _ => print "par - no match - fun\n") + | _ => print "par - no match - mt\n") + | _ => print "par - no match - mt2\n") else () | _ => warn_puts TE e - and warn_puts_i TE (SWITCH(e, list, e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_w TE (SWITCH(e, list, e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_s TE (SWITCH(e, list, e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_r TE (SWITCH(e, list,e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_c TE (SWITCH(e, list, e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_e TE (SWITCH(e, list, e')) = - (warn_puts_trip TE e; - app ((warn_puts_trip TE) o #2) list; - warn_puts_opt TE e' - ) - and warn_puts_opt TE NONE = () - | warn_puts_opt TE (SOME e) = warn_puts_trip TE e + and warn_puts_i TE (SWITCH(e, list, e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_w TE (SWITCH(e, list, e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_s TE (SWITCH(e, list, e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_r TE (SWITCH(e, list,e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_c TE (SWITCH(e, list, e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_e TE (SWITCH(e, list, e')) = + (warn_puts_trip TE e; + app ((warn_puts_trip TE) o #2) list; + warn_puts_opt TE e' + ) + and warn_puts_opt TE NONE = () + | warn_puts_opt TE (SOME e) = warn_puts_trip TE e in warn_puts TE e end - - - (**********************************) (* Reporting dangling pointers *) (* from closures *) @@ -437,35 +452,35 @@ struct *) - fun bad_rhos(fn_level, rhos): place list = - List.filter (fn rho=> case Eff.level_of rho of - SOME level_rho => level_rho > fn_level - | NONE => die "bad_rhos: no level" - ) rhos - - type bad_lvars = (Lvars.lvar * (sigma*place)*place list)list - - fun bad_lvars(fn_level, TE, lvars) : bad_lvars = - foldl (fn (lvar, acc) => case RSE.lookupLvar TE lvar of - SOME (_,_,_,sigma,p,_,_) => - (case bad_rhos(fn_level, p:: R.frv_sigma sigma) of - [] => acc - | l => (print ("** Lvar " ^ Lvars.pr_lvar lvar ^ " has a type scheme with a region \n\ - \ variable with higher level than the epsilon of the function.\n"); - (lvar,(sigma,p), l) :: acc)) - | NONE => die "bad_lvars: lvar not in scope") - [] lvars - - type bad_excons = (Excon.excon * (R.Type*place)*place list)list - - fun bad_excons(fn_level, TE, excons) : bad_excons = - foldl (fn (excon, acc) => case RSE.lookupExcon TE excon of - SOME (tau,p) => - (case bad_rhos(fn_level, p:: R.frv_mu(tau,p)) of - [] => acc - | l => (excon,(tau,p), l) :: acc) - | NONE => die "bad_excons: excon not in scope") - [] excons + fun bad_rhos (fn_level, rhos): place list = + List.filter (fn rho => case Eff.level_of rho of + SOME level_rho => level_rho > fn_level + | NONE => die "bad_rhos: no level" + ) rhos + + type bad_lvars = (Lvars.lvar * (sigma*place option)*place list)list + + fun bad_lvars (fn_level, TE, lvars) : bad_lvars = + foldl (fn (lvar, acc) => case RSE.lookupLvar TE lvar of + SOME (_,_,_,sigma,p,_,_) => + (case bad_rhos(fn_level, case p of SOME p => p:: R.frv_sigma sigma | NONE => R.frv_sigma sigma) of + [] => acc + | l => (print ("** Lvar " ^ Lvars.pr_lvar lvar ^ " has a type scheme with a region \n\ + \ variable with higher level than the epsilon of the function.\n"); + (lvar,(sigma,p), l) :: acc)) + | NONE => die "bad_lvars: lvar not in scope") + [] lvars + + type bad_excons = (Excon.excon * mu * place list)list + + fun bad_excons (fn_level, TE, excons) : bad_excons = + foldl (fn (excon, acc) => case RSE.lookupExcon TE excon of + SOME mu => + (case bad_rhos(fn_level, R.frv_mu mu) of + [] => acc + | l => (excon,mu,l)::acc) + | NONE => die "bad_excons: excon not in scope") + [] excons fun show_rhos rhos = concat(map (fn rho => " " ^ pp_regvar rho) rhos) @@ -478,16 +493,16 @@ struct concat(map (fn (lvar,_) => " " ^ Lvars.pr_lvar lvar) pat) ^ ":\n" | _ => die "report_dangling: expression is not a lambda abstraction" val bad_lvar_lines = - map (fn (lvar,(sigma,p), bad_rhos) => concat[" " ^ Lvars.pr_lvar lvar^ ": " ^ show_rhos bad_rhos ^ "\n"]) + map (fn (lvar,_,bad_rhos) => concat[" " ^ Lvars.pr_lvar lvar ^ ": " ^ show_rhos bad_rhos ^ "\n"]) l1 val bad_excon_lines = - map (fn (excon,(tau,p), bad_rhos) => concat[" " ^ Excon.pr_excon excon^ ": " ^ show_rhos bad_rhos ^ "\n"]) + map (fn (excon,_,bad_rhos) => concat[" " ^ Excon.pr_excon excon ^ ": " ^ show_rhos bad_rhos ^ "\n"]) l2 in Report.print (Report.flatten (map line (source_identification :: - (bad_lvar_lines @ bad_excon_lines)))); + (bad_lvar_lines @ bad_excon_lines)))); Crash.unimplemented "Potential dangling pointer! Garbage collection \n\ - \ is unsound in this case. Please disable garbage collection\n\ + \ is unsound in this case. Please disable garbage collection\n\ \ or alter your program so that no non-live values escape in\n\ \ closures. This is also a warning that if you run your\n\ \ program through a compiler based on conventional garbage\n\ @@ -497,31 +512,34 @@ struct val gc_p = Flags.is_on0 "garbage_collection" fun warn_dangling_pointers (TE:regionStatEnv, - (PGM{expression = TR(e,_,_,_), ...}):('place,'a,'b) LambdaPgm, - get_place: 'place -> place):unit = - if true (*when gc is enabled, the region inference algorithm R ensures that - *no dangling pointers occur; mael 2001-11-05 *) orelse not(gc_p()) + (PGM{expression = TR(e,_,_,_), ...}):('place,'a,'b) LambdaPgm, + get_place: 'place -> place):unit = + if true (*when gc is enabled, the region inference algorithm R ensures that + *no dangling pointers occur; mael 2001-11-05 *) orelse not(gc_p()) then () else let - fun warn_dangle TE (e: ('place,'a,'b)LambdaExp,eps_opt) = - case e of - FIX{shared_clos, functions, scope, ... (*bound_lvars,binds,scope,info*)} => - let val TE' = - foldr (fn ({lvar,tyvars,rhos,epss,Type,...}, TE') => - RSE.declareLvar(lvar, (true,true,[],R.FORALL(rhos,epss,tyvars,Type), get_place shared_clos , NONE, NONE), TE')) - TE functions - - in warn_dangle_trip TE' scope; - app (warn_dangle_trip TE' o #bind) functions - end + fun warn_dangle TE (e: ('place,'a,'b)LambdaExp,eps_opt) = + case e of + FIX{shared_clos, functions, scope, ... (*bound_lvars,binds,scope,info*)} => + let val TE' = + foldr (fn ({lvar,tyvars,rhos,epss,Type,...}, TE') => + RSE.declareLvar(lvar, (true,true,[],R.FORALL(rhos,epss,tyvars,Type), + SOME (get_place shared_clos), + NONE, NONE), TE')) + TE functions + in warn_dangle_trip TE' scope; + app (warn_dangle_trip TE' o #bind) functions + end | FN{pat,body, - free = ref(SOME(lvars, excons, _)), - ...} => - let val TE' = foldr (fn ((lvar,(tau,rho)), TE') => - RSE.declareLvar(lvar, (true,true,[],R.type_to_scheme tau, rho , NONE, NONE), TE')) - TE pat + free = ref(SOME(lvars, excons, _)), + ...} => + let val TE' = foldr (fn ((lvar,mu), TE') => + let val (tau,rho) = case R.unBOX mu of SOME (tau,rho) => (tau,SOME rho) | NONE => (mu,NONE) + in RSE.declareLvar(lvar, (true,true,[],R.type_to_scheme tau, rho , NONE, NONE), TE') + end) + TE pat val level_fn = case eps_opt of SOME eps => (case Eff.level_of eps of SOME int => int @@ -540,22 +558,22 @@ struct (warn_dangle_trip TE bind; let val TE' = foldr (fn ((lvar,_,tyvars,ref epss,tau,rho,_), TE') => - RSE.declareLvar(lvar, (true,true,[],R.FORALL([],epss,tyvars,tau), rho , NONE, NONE), TE')) + RSE.declareLvar(lvar, (true,true,[],R.FORALL([],epss,tyvars,tau), rho , NONE, NONE), TE')) TE - pat + pat in warn_dangle_trip TE' scope end ) - | APP(_,_,e1,e2) => (warn_dangle_trip TE e1; warn_dangle_trip TE e2) - | EXCEPTION(excon, is_nullary, (tau,p), _, body) => - warn_dangle_trip (RSE.declareExcon(excon,(tau,p),TE)) body - | RAISE(e) => warn_dangle_trip TE e - | HANDLE(e1,e2) => (warn_dangle_trip TE e1; warn_dangle_trip TE e2) - | SWITCH_I {switch,precision} => warn_dangle_i TE switch - | SWITCH_W {switch,precision} => warn_dangle_w TE switch - | SWITCH_S(switch) => warn_dangle_s TE switch - | SWITCH_C(switch) => warn_dangle_c TE switch - | SWITCH_E(switch) => warn_dangle_e TE switch + | APP(_,_,e1,e2) => (warn_dangle_trip TE e1; warn_dangle_trip TE e2) + | EXCEPTION(excon, is_nullary, mu, _, body) => + warn_dangle_trip (RSE.declareExcon(excon,mu,TE)) body + | RAISE(e) => warn_dangle_trip TE e + | HANDLE(e1,e2) => (warn_dangle_trip TE e1; warn_dangle_trip TE e2) + | SWITCH_I {switch,precision} => warn_dangle_i TE switch + | SWITCH_W {switch,precision} => warn_dangle_w TE switch + | SWITCH_S(switch) => warn_dangle_s TE switch + | SWITCH_C(switch) => warn_dangle_c TE switch + | SWITCH_E(switch) => warn_dangle_e TE switch | CON0 _ => () | CON1(_,tr) => warn_dangle_trip TE tr | DECON(_,tr) => warn_dangle_trip TE tr @@ -566,7 +584,7 @@ struct | SELECT(_,tr) => warn_dangle_trip TE tr | DEREF tr => warn_dangle_trip TE tr | REF(_,tr) => warn_dangle_trip TE tr - | ASSIGN(_,tr1,tr2) => (warn_dangle_trip TE tr1; warn_dangle_trip TE tr2) + | ASSIGN(tr1,tr2) => (warn_dangle_trip TE tr1; warn_dangle_trip TE tr2) | DROP(tr1) => (warn_dangle_trip TE tr1) | EQUAL(_,tr1,tr2) => (warn_dangle_trip TE tr1; warn_dangle_trip TE tr2) | CCALL(_,l) => app (warn_dangle_trip TE) l @@ -576,46 +594,49 @@ struct | RESET_REGIONS(_,tr) => warn_dangle_trip TE tr | FRAME _ => () | LETREGION{body, ...} => warn_dangle_trip TE body - | _ => () - - and warn_dangle_trip TE (TR(e,mu as RegionExp.Mus[(ty,_)],_,_)) = - (case R.unFUN ty of - SOME (_,eps,_) => warn_dangle TE (e,SOME eps) - | NONE => warn_dangle TE (e, NONE)) - | warn_dangle_trip TE (TR(e,mu,_,_)) = warn_dangle TE (e, NONE) - - and warn_dangle_i TE (SWITCH(e, list, e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_w TE (SWITCH(e, list, e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_s TE (SWITCH(e, list, e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_r TE (SWITCH(e, list,e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_c TE (SWITCH(e, list, e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_e TE (SWITCH(e, list, e')) = - (warn_dangle_trip TE e; - app ((warn_dangle_trip TE) o #2) list; - warn_dangle_opt TE e' - ) - and warn_dangle_opt TE NONE = () - | warn_dangle_opt TE (SOME e) = warn_dangle_trip TE e + | _ => () + + and warn_dangle_trip TE (TR(e,RegionExp.Mus[mu],_,_)) = + (case R.unBOX mu of + SOME(ty,_) => + (case R.unFUN ty of + SOME (_,eps,_) => warn_dangle TE (e,SOME eps) + | NONE => warn_dangle TE (e, NONE)) + | NONE => warn_dangle TE (e, NONE)) + | warn_dangle_trip TE (TR(e,_,_,_)) = warn_dangle TE (e, NONE) + + and warn_dangle_i TE (SWITCH(e, list, e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_w TE (SWITCH(e, list, e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_s TE (SWITCH(e, list, e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_r TE (SWITCH(e, list,e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_c TE (SWITCH(e, list, e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_e TE (SWITCH(e, list, e')) = + (warn_dangle_trip TE e; + app ((warn_dangle_trip TE) o #2) list; + warn_dangle_opt TE e' + ) + and warn_dangle_opt TE NONE = () + | warn_dangle_opt TE (SOME e) = warn_dangle_trip TE e in warn_dangle TE (e,NONE) @@ -629,11 +650,6 @@ struct (* same as in RegionExp) *) (*****************************) - fun isWordRegion rho = - case Eff.get_place_ty rho of - SOME Eff.WORD_RT => true - | _ => false - type StringTree = PP.StringTree fun layPair (t1,t2) = PP.NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT", ", children = [t1, t2]} @@ -644,8 +660,6 @@ struct case opt of SOME t => t::acc | NONE => acc) [] l - val printcount = ref 1 (* controls when effects are printed *) - fun mkLay (omit_region_info: bool) (layout_alloc: 'a -> StringTree option) (layout_alloc_short: 'a -> StringTree option) (layout_bind: 'b -> StringTree option) @@ -659,22 +673,30 @@ struct fun maybe_prefix_space s = if s = "" then s else " " ^ s + fun layout_alloc_opt NONE = NONE + | layout_alloc_opt (SOME a) = layout_alloc a + fun alloc_string alloc = case layout_alloc alloc of SOME t => PP.flatten1 t - | NONE => "" + | NONE => "" + + fun alloc_opt_string alloc = + case alloc of + SOME alloc => alloc_string alloc + | NONE => "" fun layList f l = NODE{start = "[", finish = "]", indent = 1, childsep = RIGHT ",", children = map f l} fun layHlist f l = HNODE{start = "[", finish = "]", childsep = RIGHT ",", - children = map f l} + children = map f l} fun layHseq f l : StringTree list = foldr(fn (y, ts) => case f y of SOME t => t::ts - | _ => ts)[]l + | _ => ts)[]l fun layHlistopt f l = HNODE{start = "[", finish = "]", childsep = RIGHT ",", - children = layHseq f l} + children = layHseq f l} infix ^^ (* s ^^ st_opt: tag the string tree option st_opt onto the string s *) @@ -698,25 +720,25 @@ struct fun layMeta metatype = RegionExp.layMeta metatype fun layVarMu (x,mu) = if !Flags.print_types then LEAF (concat[Lvars.pr_lvar x, ":", PP.flatten1(layMu mu)]) - else LEAF (Lvars.pr_lvar x) + else LEAF (Lvars.pr_lvar x) fun layPatFn [] = LEAF("() => ") | layPatFn [(x,mu)] = NODE{start = "", finish = " => ", indent = 0, childsep = NOSEP, children = [layVarMu(x,mu)]} | layPatFn pat = HNODE{start = "(", finish = ") =>", childsep = RIGHT",", children = map layVarMu pat} - - fun layVarSigma start (lvar,rhos,epss,alphas,tau, rho) = + fun layVarSigma start (lvar,rhos,epss,alphas,tau,rho) = let val sigma_t = R.mk_lay_sigma' omit_region_info (rhos, epss, alphas, tau) val start:string = start ^ Lvars.pr_lvar lvar ^ (if !Flags.print_types then ":" else "") - val sigma_rho_t = if print_regions() andalso !Flags.print_types andalso - (print_word_regions() orelse not(isWordRegion rho)) then - NODE{start = "(", finish = ")", childsep = RIGHT",", - indent = 1, - children = [sigma_t, Eff.layout_effect rho]} - else sigma_t - + val sigma_rho_t = + if print_regions() andalso !Flags.print_types then + case rho of + SOME rho => NODE{start = "(", finish = ")", childsep = RIGHT",", + indent = 1, + children = [sigma_t, Eff.layout_effect rho]} + | NONE => sigma_t + else sigma_t in PP.NODE{start = start, finish = "", indent = size start +1, childsep = PP.NOSEP, children = [sigma_rho_t]} end @@ -755,14 +777,14 @@ struct val rho_actuals_t_opt= if print_regions() then SOME(layHlistopt layout_alloc_short rhos_actuals) else NONE - val taus_opt = if !(Flags.print_types) + val taus_opt = if !(Flags.print_types) then SOME(layList layTau taus) else NONE - val rhos_opt = if !Flags.print_types andalso print_regions() + val rhos_opt = if !Flags.print_types andalso print_regions() orelse print_effects() then SOME(layHlist Eff.layout_effect rhos) else NONE - val epss_opt = if print_effects() + val epss_opt = if print_effects() then SOME(layList Eff.layout_effect_deep epss) else NONE (*mads*) in @@ -773,7 +795,7 @@ struct fun laypoly (lvar,fix_bound,il,rhos_actuals) = case (fix_bound, R.un_il il) of (false, ([],[],[])) => LEAF (Lvars.pr_lvar lvar) - | _ => lay_il(Lvars.pr_lvar lvar, "", il, rhos_actuals) + | _ => lay_il(Lvars.pr_lvar lvar, "", il, rhos_actuals) fun dont_lay_il (lvar_string:string, terminator: string, il) : StringTree = LEAF(lvar_string ^ terminator) @@ -785,23 +807,23 @@ struct fun layBin (bop:string, n, t1, t2, SOME a) = (case alloc_string a - of "" => (* put parenthesis, if precedence dictates it *) - if n>=2 then - NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - else - NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - | s_alloc => (* assume allocation string is short: use it as terminator *) - NODE{start = "(", finish = ")" ^ s_alloc, indent =1, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]}) - | layBin (bop:string, n, t1, t2, NONE) = - if n>=2 then - NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - else - NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} + of "" => (* put parenthesis, if precedence dictates it *) + if n>=2 then + NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + else + NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + | s_alloc => (* assume allocation string is short: use it as terminator *) + NODE{start = "(", finish = ")" ^ s_alloc, indent =1, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]}) + | layBin (bop:string, n, t1, t2, NONE) = + if n>=2 then + NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + else + NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} and layExp (lamb: ('a, 'b, 'c) LambdaExp,n): StringTree = case lamb of VAR{lvar,il,fix_bound=false,rhos_actuals=ref[],plain_arreffs,other} => (* fix-bound variables and prims *) @@ -818,57 +840,54 @@ struct | VAR{lvar, il, fix_bound=true, rhos_actuals = ref rhos_actuals, plain_arreffs,other} => lay_il(Lvars.pr_lvar lvar, "", il, rhos_actuals) ^^^ layout_other other - | INTEGER(i, t, a) => LEAF(IntInf.toString i ^^ layout_alloc a) - | WORD(w, t, a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ layout_alloc a) + | INTEGER(i, t, a) => LEAF(IntInf.toString i ^^ layout_alloc_opt a) + | WORD(w, t, a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ layout_alloc_opt a) | STRING(s, a) => LEAF(quote s ^^ layout_alloc a) | REAL(r, a) => LEAF(r ^^ layout_alloc a) - | F64(r, a) => LEAF((r^"f64") ^^ layout_alloc a) - | UB_RECORD(args) => - PP.NODE{start = "<", finish = ">" , indent = 1, childsep = PP.RIGHT", ", - children = map (fn trip => layTrip(trip,0)) args} + | F64 r => LEAF(r^"f64") + | UB_RECORD args => + PP.NODE{start = "<", finish = ">" , indent = 1, childsep = PP.RIGHT", ", + children = map (fn trip => layTrip(trip,0)) args} | CON0{con, il, aux_regions,alloc} => (* nullary constructor *) - let val alloc_s = alloc_string alloc - in dont_lay_il(Con.pr_con con, maybe_prefix_space alloc_s, il) - end + let val alloc_s = alloc_opt_string alloc + in dont_lay_il(Con.pr_con con, maybe_prefix_space alloc_s, il) + end | CON1({con, il, alloc},trip) => (* unary constructor *) let fun trylist e = case e of CON0{con,alloc,...} => - if Con.eq(con,Con.con_NIL) then SOME([],alloc) + if Con.eq(con,Con.con_NIL) then SOME([],NONE) else NONE - | CON1({con,...},TR(RECORD(a,[t1,TR(e2,_,_,_)]),_,_,_)) => + | CON1({con,...},TR(RECORD(SOME a,[t1,TR(e2,_,_,_)]),_,_,_)) => if Con.eq(con,Con.con_CONS) then case trylist e2 of - SOME(ts,_) => SOME (t1::ts,a) + SOME(ts,_) => SOME (t1::ts,SOME a) | NONE => NONE else NONE | _ => NONE in case trylist lamb of SOME(ts,alloc) => let val l = layList (fn t => layTrip(t,0)) ts - val alloc_s = alloc_string alloc + val alloc_s = alloc_opt_string alloc in if print_regions() andalso alloc_s <> "" then PP.NODE{start="", finish="", indent = 0, childsep = PP.RIGHT " ", children = [l, PP.LEAF alloc_s]} else l end - | NONE => - let val alloc_s = alloc_string alloc + | NONE => (* not a list *) + let val alloc_s = alloc_opt_string alloc val t1 = dont_lay_il(Con.pr_con con, maybe_prefix_space alloc_s, il) in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", children = [t1, layTrip(trip,3)]} end end | DECON({con, il},trip) => (* destruction *) - let - val t1 = dont_lay_il("decon_" ^ Con.pr_con con , "", il) - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + let val t1 = dont_lay_il("decon_" ^ Con.pr_con con , "", il) + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", children = [t1, layTrip(trip,3)]} - end - + end | EXCON(excon, NONE) => (* nullary exception constructor *) - PP.LEAF(Excon.pr_excon excon) + PP.LEAF(Excon.pr_excon excon) | EXCON(excon, SOME (alloc,t)) => (* unary exception constructor *) let val alloc_s = maybe_prefix_space (alloc_string alloc) @@ -876,15 +895,14 @@ struct PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", children = [PP.LEAF(Excon.pr_excon excon ^ alloc_s), layTrip(t,3)]} end - | DEEXCON(excon,tr) => - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", - children = [PP.LEAF("deexcon_" ^ Excon.pr_excon excon), layTrip(tr,3)]} - | RECORD(alloc, args) => - let - val alloc_s = alloc_string alloc - in - PP.NODE{start = "(", finish = ")" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", - children = map (fn trip => layTrip(trip,0)) args} + | DEEXCON(excon,tr) => + PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + children = [PP.LEAF("deexcon_" ^ Excon.pr_excon excon), layTrip(tr,3)]} + | RECORD(NONE, []) => PP.LEAF "()" + | RECORD(SOME alloc, args) => + let val alloc_s = alloc_string alloc + in PP.NODE{start = "(", finish = ")" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", + children = map (fn trip => layTrip(trip,0)) args} end | SELECT(i, trip) => PP.NODE{start = "#"^Int.toString i ^ " ", finish = "", indent = 4, childsep = PP.NOSEP, @@ -897,7 +915,7 @@ struct f il (exp) *) - val t1 = laypoly(lvar,fix_bound,il,rhos_actuals) + val t1 = laypoly(lvar,fix_bound,il,rhos_actuals) in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", children = [t1, layTrip(t2,3)]} @@ -910,12 +928,12 @@ struct | APP(SOME JMP, _, TR(VAR{lvar, il, fix_bound, rhos_actuals=ref rhos_actuals, plain_arreffs,other},_,_,_), t2)=> NODE{start = "jmp ", finish = "", indent = 4, childsep = PP.RIGHT " ", - children= [laypoly(lvar,fix_bound,il,rhos_actuals),layTrip(t2,4)]} + children= [laypoly(lvar,fix_bound,il,rhos_actuals),layTrip(t2,4)]} | APP(SOME FUNCALL, _, TR(VAR{lvar, il, fix_bound, rhos_actuals=ref rhos_actuals, plain_arreffs,other},_,_,_), t2)=> (* insert printing of store resave here *) NODE{start = "funcall " , finish = "", indent = 8, childsep = PP.RIGHT " ", - children= [laypoly(lvar,fix_bound,il,rhos_actuals),layTrip(t2,4)]} + children= [laypoly(lvar,fix_bound,il,rhos_actuals),layTrip(t2,4)]} | APP(SOME FNJMP, _, t1, t2) => NODE{start = if n>3 then "(fnjmp " else "fnjmp ", finish = if n>3 then ")" else "", @@ -952,14 +970,12 @@ struct finish = if n>=3 then ")" else "", indent = 3, childsep = PP.NOSEP, children = [layTrip(t,4)]} - | ASSIGN(alloc, t1,t2) => - let val s = alloc_string alloc - in PP.NODE{start = "(" , finish = ")"^s, indent = 1, childsep = PP.RIGHT " := ", - children = [layTrip(t1,2), layTrip(t2,2)]} - end + | ASSIGN(t1,t2) => + PP.NODE{start = "(" , finish = ")", indent = 1, childsep = PP.RIGHT " := ", + children = [layTrip(t1,2), layTrip(t2,2)]} | DROP(t) => layTrip(t,n) - | EQUAL({mu_of_arg1,mu_of_arg2, alloc}, arg1, arg2) => - let val eq = if print_regions() then " =" ^ maybe_prefix_space(alloc_string alloc) ^ " " else " = " + | EQUAL({mu_of_arg1,mu_of_arg2}, arg1, arg2) => + let val eq = " = " val ty = if !(Flags.print_types) then concat["(* domain of = is: ", PP.flatten1(layMu mu_of_arg1), "*", @@ -972,9 +988,9 @@ struct children = [layTrip(arg1,2), layTrip(arg2, 2)]} end | CCALL ({name, rhos_for_result, mu_result}, args) => - let val rhos_for_result_sts = if print_regions() - then map (PP.LEAF o alloc_string o #1) rhos_for_result - else [] + let val rhos_for_result_sts = if print_regions() + then map (PP.LEAF o alloc_string o #1) rhos_for_result + else [] fun drop__ n = if size n > 2 andalso String.sub(n,0) = #"_" andalso String.sub(n,1) = #"_" then SOME(String.extract(n,2,NONE)) @@ -1052,22 +1068,22 @@ struct else "$" ^ name ^ "(" val ty = if !Flags.print_types then ":" ^ PP.flatten1(layMu mu_result) else "" - in PP.NODE {start = start, + in PP.NODE {start = start, finish = ")" ^ ty, - indent = 2, childsep = PP.RIGHT ", ", - children = rhos_for_result_sts - @ (map (fn t => layTrip(t,0)) args)} - end + indent = 2, childsep = PP.RIGHT ", ", + children = rhos_for_result_sts + @ (map (fn t => layTrip(t,0)) args)} + end end | EXPORT ({name, mu_arg, mu_res}, arg) => - let - in PP.NODE {start = "_export(" ^ name, finish = ")" - ^ (if !Flags.print_types then - ":" ^ PP.flatten1(layMu mu_arg) ^ " -> " ^ PP.flatten1(layMu mu_res) - else ""), - indent = 6, childsep = PP.RIGHT ", ", - children = [layTrip(arg,0)]} - end + let + in PP.NODE {start = "_export(" ^ name, finish = ")" + ^ (if !Flags.print_types then + ":" ^ PP.flatten1(layMu mu_arg) ^ " -> " ^ PP.flatten1(layMu mu_res) + else ""), + indent = 6, childsep = PP.RIGHT ", ", + children = [layTrip(arg,0)]} + end | BLOCKF64(alloc, args) => let val alloc_s = alloc_string alloc @@ -1079,11 +1095,11 @@ struct let val alloc_s = alloc_string alloc in PP.LEAF ("scratch(" ^ Int.toString n ^ ")" ^ alloc_s) end - | RESET_REGIONS({force, alloc,regions_for_resetting}, t) => + | RESET_REGIONS({force, regions_for_resetting, ...}, t) => let val fcn = if force then "forceResetting " else "resetRegions " val aux_regions_t = HNODE{start="[",finish="]", childsep=NOSEP, children=[layHlistopt layout_alloc_short regions_for_resetting]} - in PP.NODE{start = "(" ^ fcn , finish = ")" ^ (if print_regions() then alloc_string alloc else ""), + in PP.NODE{start = "(" ^ fcn , finish = ")", indent = size fcn + 2, childsep = PP.NOSEP, children = [aux_regions_t,layTrip(t,0)]} end @@ -1104,46 +1120,24 @@ struct | _ => LEAF "pretty-printing of this multiplicity expression not yet implemented" and layout_declared_lvar {lvar, sigma, place, other} = - if not(print_word_regions()) andalso isWordRegion place then - NODE{start = Lvars.pr_lvar lvar ^ ": ", finish = "", - indent = 5, childsep = NOSEP, - children = [if !Flags.print_types then - R.mk_lay_sigma omit_region_info sigma - else LEAF "_"]} - else - NODE{start = Lvars.pr_lvar lvar ^ ": (", finish = ")", - indent = 5, childsep = RIGHT",", - children = [if !Flags.print_types then - R.mk_lay_sigma omit_region_info sigma - else LEAF "_", - Eff.layout_effect place]} - - and layTrip(TR(e,RegionExp.Mus mus,rea,ref psi),n) = - let val t1 = - case (e, mus) of - (FN{pat,body,free,alloc}, [(ty,_)])=> - (case R.unFUN ty of - SOME (_,eps,_) => - let val eps_s = if print_effects() then PP.flatten1(Eff.layout_effect(*_deep*) eps) ^ " " (*mads*) - else "" - in layLam((pat,body,alloc), n, eps_s) - end - | NONE => layExp(e,n)) - | _ => layExp(e,n) - val tick = (printcount:= !printcount+1; !printcount) - in - if false (*tick mod 10 = 0*) then - let (*val t2 = layMus mus*) - val t3 = Mul.layout_mulef psi - in NODE{start = "(", finish = ")", indent = 1, childsep = RIGHT":", - children = [t1,(*t2,*)t3]} - end - else t1 - end - | layTrip(TR(e, _, rea,_), n) = layExp(e,n) - - - and layLam((pat,body,alloc), n, eps: string) = + case place of + NONE => NODE{start = Lvars.pr_lvar lvar ^ ": ", finish = "", + indent = 5, childsep = NOSEP, + children = [if !Flags.print_types then + R.mk_lay_sigma omit_region_info sigma + else LEAF "_"]} + | SOME place => + NODE{start = Lvars.pr_lvar lvar ^ ": (", finish = ")", + indent = 5, childsep = RIGHT",", + children = [if !Flags.print_types then + R.mk_lay_sigma omit_region_info sigma + else LEAF "_", + Eff.layout_effect place]} + + and layTrip (TR(e, _, _, _), n) = layExp(e,n) + + + and layLam ((pat,body,alloc), n, eps: string) = (* (fn eps alloc pat => lamb ) @@ -1228,7 +1222,7 @@ struct and mk_mutual_binding (opt_alloc, functions) = let fun mk_fix ({lvar,occ,tyvars,rhos,epss,Type, rhos_formals= ref rhos_formals, bound_but_never_written_into, - bind as TR(FN{pat, body, ...},_,_,_),other}) (no, rest_of_mutual_binding) = + bind as TR(FN{pat, body, ...},_,_,_),other}) (no, rest_of_mutual_binding) = (* fun fljadsfj <: sigma> <[rho1, ..., rho_k]> (x_1, ..., x_n) = @@ -1237,12 +1231,12 @@ struct *) (no-1,let - val print_rhos_formals = print_regions() + val print_rhos_formals = print_regions() val keyword = if no = 1 then "fun " else "and " val sigma_t_opt = if !Flags.print_types then SOME(PP.NODE{start = ":", finish = "", indent = 1, childsep= PP.NOSEP, children = [R.mk_lay_sigma'' (SOME o Eff.layout_effect) - omit_region_info (rhos,epss,tyvars,Type)]}) + omit_region_info (rhos,epss,tyvars,Type)]}) else NONE val rho_formals_opt = if print_rhos_formals then SOME(PP.HNODE{start = "[", finish = "]", childsep= PP.RIGHT", ", @@ -1343,9 +1337,9 @@ struct | RAISE(tr) => e_to_t(RAISE(eval env tr)) | HANDLE(tr1,tr2) => e_to_t(HANDLE(eval env tr1, eval env tr2)) | SWITCH_I {switch,precision} => e_to_t (SWITCH_I {switch=eval_sw env switch, - precision=precision}) + precision=precision}) | SWITCH_W {switch,precision} => e_to_t (SWITCH_W {switch=eval_sw env switch, - precision=precision}) + precision=precision}) | SWITCH_S(sw) => e_to_t(SWITCH_S(eval_sw env sw)) | SWITCH_C(sw) => e_to_t(SWITCH_C(eval_sw env sw)) | SWITCH_E(sw) => e_to_t(SWITCH_E(eval_sw env sw)) @@ -1359,7 +1353,7 @@ struct | SELECT(i,tr) => e_to_t(SELECT(i, eval env tr)) | DEREF(tr) => e_to_t(DEREF(eval env tr)) | REF(a, tr) => e_to_t(REF(a, eval env tr)) - | ASSIGN(a,tr1,tr2) => e_to_t(ASSIGN(a,eval env tr1, eval env tr2)) + | ASSIGN(tr1,tr2) => e_to_t(ASSIGN(eval env tr1, eval env tr2)) | DROP(tr) => e_to_t(DROP(eval env tr)) | EQUAL(info,tr1,tr2)=>e_to_t(EQUAL(info,eval env tr1, eval env tr2)) | CCALL(info,trs) => e_to_t(CCALL(info, map (eval env) trs)) @@ -1396,8 +1390,8 @@ struct (layout_other: ('c -> StringTree option)) (p as PGM{expression = trip_in as TR(lamb,meta,rea,_), export_datbinds = datbinds as RegionExp.DATBINDS dblist, - import_vars, - export_vars, + import_vars, + export_vars, export_basis, export_Psi}):StringTree = let @@ -1516,20 +1510,20 @@ struct case e of RegionExp.VAR{lvar, il_r, fix_bound} => let val (rhos,eff_nodes,_) = R.un_il(#1(!il_r)) - val arreffs = map (fn eps => (eps, Eff.mk_phi eps)) eff_nodes + val arreffs = map (fn eps => (eps, Eff.mk_phi eps)) eff_nodes handle _ => die ("VAR (mk_phi failed), lvar = " ^ Lvars.pr_lvar lvar) - val r = Mul.lookup_efenv(EE, lvar) + val r = Mul.lookup_efenv(EE, lvar) handle _ => die ("VAR (lookup_efenv failed), lvar = " ^ Lvars.pr_lvar lvar) - in - (VAR{lvar=lvar, il = #1(!il_r) , plain_arreffs = arreffs, + in + (VAR{lvar=lvar, il = #1(!il_r) , plain_arreffs = arreffs, fix_bound=fix_bound,rhos_actuals=ref rhos, other = r}, dep) - end + end | RegionExp.INTEGER(i,t,a) => (INTEGER(i,t,a), dep) | RegionExp.WORD(i,t,a) => (WORD(i,t,a), dep) | RegionExp.STRING(s,a) => (STRING(s,a), dep) | RegionExp.REAL(r,a) => (REAL(r,a), dep) - | RegionExp.F64(r,a) => (F64(r,a), dep) + | RegionExp.F64 r => (F64 r, dep) | RegionExp.UB_RECORD(ts) => let val (ts', dep) = mk_deps(EE, ts, dep) in (UB_RECORD ts', dep) @@ -1537,7 +1531,7 @@ struct | RegionExp.FN{pat,body,alloc,free} => let val EE' = foldl (fn ((lvar,_), EE) => Mul.declare(EE,lvar,ref(Mul.empty_qmularefset))) EE pat - val (body',dep) = mk_deptr(EE',body, dep) + val (body',dep) = mk_deptr(EE',body, dep) in (FN{pat=pat,body=body',free=ref NONE,alloc=alloc}, dep) end | RegionExp.LETREGION_B{B,body,...} => @@ -1604,71 +1598,71 @@ struct let val (sw', dep) = mk_dep_sw(EE,sw, dep) in (SWITCH_E sw', dep) end - | RegionExp.CON0 c => (CON0 c, dep) - | RegionExp.CON1 (c,tr) => + | RegionExp.CON0 c => (CON0 c, dep) + | RegionExp.CON1 (c,tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (CON1(c,tr'),dep) end - | RegionExp.DECON(c,tr) => + | RegionExp.DECON(c,tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (DECON(c,tr'),dep) end - | RegionExp.EXCON(excon,NONE) => (EXCON(excon,NONE), dep) - | RegionExp.EXCON(excon,SOME(p,tr)) => + | RegionExp.EXCON(excon,NONE) => (EXCON(excon,NONE), dep) + | RegionExp.EXCON(excon,SOME(p,tr)) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (EXCON(excon,SOME(p,tr')),dep) end - | RegionExp.DEEXCON(excon,tr) => + | RegionExp.DEEXCON(excon,tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (DEEXCON(excon,tr'),dep) end - | RegionExp.RECORD (p,trs) => + | RegionExp.RECORD (p,trs) => let val (trs',dep) = mk_deps(EE,trs,dep) in (RECORD(p,trs'),dep) end - | RegionExp.SELECT(i,tr) => + | RegionExp.SELECT(i,tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (SELECT(i,tr'),dep) end - | RegionExp.DEREF tr => + | RegionExp.DEREF tr => let val (tr',dep) = mk_deptr(EE,tr,dep) in (DEREF tr',dep) end - | RegionExp.REF (p, tr) => + | RegionExp.REF (p, tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (REF(p,tr'),dep) end - | RegionExp.ASSIGN(p,tr1,tr2) => + | RegionExp.ASSIGN(tr1,tr2) => let val (tr1',dep) = mk_deptr(EE,tr1,dep) - val (tr2',dep) = mk_deptr(EE,tr2,dep) - in (ASSIGN(p,tr1',tr2'),dep) + val (tr2',dep) = mk_deptr(EE,tr2,dep) + in (ASSIGN(tr1',tr2'),dep) end - | RegionExp.DROP (tr) => + | RegionExp.DROP (tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (DROP(tr'),dep) end - | RegionExp.EQUAL(c,tr1,tr2) => + | RegionExp.EQUAL(c,tr1,tr2) => let val (tr1',dep) = mk_deptr(EE,tr1,dep) - val (tr2',dep) = mk_deptr(EE,tr2,dep) + val (tr2',dep) = mk_deptr(EE,tr2,dep) in (EQUAL(c,tr1',tr2'),dep) end - | RegionExp.CCALL(c,trs) => + | RegionExp.CCALL(c,trs) => let val (trs',dep) = mk_deps(EE,trs,dep) in (CCALL(c,trs'),dep) end - | RegionExp.BLOCKF64 (p,trs) => + | RegionExp.BLOCKF64 (p,trs) => let val (trs',dep) = mk_deps(EE,trs,dep) in (BLOCKF64(p,trs'),dep) end - | RegionExp.SCRATCHMEM (n,p) => + | RegionExp.SCRATCHMEM (n,p) => (SCRATCHMEM(n,p),dep) - | RegionExp.EXPORT(c,tr) => + | RegionExp.EXPORT(c,tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) in (EXPORT(c,tr'),dep) end - | RegionExp.RESET_REGIONS(c,tr) => + | RegionExp.RESET_REGIONS({force,regions_for_resetting},tr) => let val (tr',dep) = mk_deptr(EE,tr,dep) - in (RESET_REGIONS(c,tr'),dep) + in (RESET_REGIONS({force=force,liveset=NONE,regions_for_resetting=regions_for_resetting},tr'),dep) end | RegionExp.FRAME{declared_lvars, declared_excons} => let @@ -1697,7 +1691,7 @@ struct bound_but_never_written_into = NONE, bind=bind',other = r}::functions', dep) end - | mk_dep_funcs _ = die "mk_dep_funcs" + | mk_dep_funcs _ = die "mk_dep_funcs" and mk_deps (EE, [],dep) = ([], dep) | mk_deps (EE, tr::ts, dep) = @@ -1739,10 +1733,10 @@ struct let fun e_to_t (e) = TR(e, mu,arefss,psir) - +(* fun ty_of (RegionExp.Mus[(tau,_)]) = tau | ty_of _ = die "ty_of" - +*) local val il0 = R.mk_il([],[],[]) in fun lvar_as_term (x,mu) = @@ -1751,19 +1745,22 @@ struct fun ub_record0_as_term mu = TR(UB_RECORD[], mu, [], ref Mul.empty_psi) - +(* fun lvar_as_term' (x,mu as (tau,rho)) = lvar_as_term(x,RegionExp.Mus[mu]) - +*) fun mk_pat (lvar, mu) = case mu of - RegionExp.Mus[(ty,place)] => - let val () = if R.isF64Type ty then Lvars.set_ubf64 lvar else () + RegionExp.Mus[mu] => + let val (ty,place) = case R.unBOX mu of + SOME (ty,rho) => (ty,SOME rho) + | NONE => (mu,NONE) + val () = if R.isF64Type ty then Lvars.set_ubf64 lvar else () in [(lvar, ref ([]:R.il ref list), [], ref([]:effect list), ty, place, dummy_'c)] end | RegionExp.RaisedExnBind => [] | _ => die ("mk_pat: metatype not (tau,rho). Lvar is " ^ Lvars.pr_lvar lvar ^ ". Metatype is " ^ - PP.flatten1 (RegionExp.layMeta mu)) + PP.flatten1 (RegionExp.layMeta mu)) end fun atomic (TR(VAR _, _, _, _)) = true @@ -1810,13 +1807,13 @@ struct (* fun kns (sw as (SWITCH(tr0, match, tr_opt))) constr = - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in constr(SWITCH(x_tr_0,match',tr_opt')) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in constr(SWITCH(x_tr_0,match',tr_opt')) + end) *) in case e of @@ -1851,17 +1848,17 @@ struct end) | APP(ck,sr,opr as (TR(VAR{fix_bound=true,...},_,_,_)), (*mael: unboxed region-polymorphic call *) - t2 as TR((UB_RECORD trs), mu2, phi2, psir2)) => - many_sub trs (fn trs' => e_to_t(APP(ck,sr,opr, TR(UB_RECORD trs' , mu2, phi2, psir2)))) + t2 as TR((UB_RECORD trs), mu2, phi2, psir2)) => + many_sub trs (fn trs' => e_to_t(APP(ck,sr,opr, TR(UB_RECORD trs' , mu2, phi2, psir2)))) | APP(ck,sr,opr as (TR(VAR{fix_bound=true,...},_,_,_)), t2) => (* region-polymorphic call *) - one_sub t2 (fn atomic2 => e_to_t(APP(ck,sr,opr, atomic2))) + one_sub t2 (fn atomic2 => e_to_t(APP(ck,sr,opr, atomic2))) | APP(ck,sr,opr as TR(VAR{fix_bound=false, ... },_,_,_), t2 as TR((UB_RECORD trs), mu2, phi2, psir2)) => (* primitive *) - many_sub trs (fn trs' => e_to_t(APP(ck,sr,opr, TR(UB_RECORD trs' , mu2, phi2, psir2)))) + many_sub trs (fn trs' => e_to_t(APP(ck,sr,opr, TR(UB_RECORD trs' , mu2, phi2, psir2)))) | APP(ck,sr,t1 ,t2) => (* other application *) - two_sub(t1,t2) (fn (t1',t2') => e_to_t(APP(ck,sr,t1',t2'))) + two_sub(t1,t2) (fn (t1',t2') => e_to_t(APP(ck,sr,t1',t2'))) | EXCEPTION(excon,b,mu_excon,a,tr1) => k(e_to_t(EXCEPTION(excon,b,mu_excon,a, kne tr1 (fn x => x)))) | RAISE (tr1 as TR(_,mu2,phi1,psi1)) => @@ -1875,48 +1872,48 @@ struct | SWITCH_E(sw) => kns sw (e_to_t o SWITCH_E ) *) | SWITCH_I {switch=SWITCH(tr0, match, tr_opt), precision} => - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in e_to_t(SWITCH_I {switch=SWITCH(x_tr_0,match',tr_opt'), - precision=precision}) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in e_to_t(SWITCH_I {switch=SWITCH(x_tr_0,match',tr_opt'), + precision=precision}) + end) | SWITCH_W {switch=SWITCH(tr0, match, tr_opt), precision} => - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in e_to_t(SWITCH_W {switch=SWITCH(x_tr_0,match',tr_opt'), - precision=precision}) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in e_to_t(SWITCH_W {switch=SWITCH(x_tr_0,match',tr_opt'), + precision=precision}) + end) | SWITCH_S(SWITCH(tr0, match, tr_opt)) => - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in e_to_t(SWITCH_S(SWITCH(x_tr_0,match',tr_opt'))) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in e_to_t(SWITCH_S(SWITCH(x_tr_0,match',tr_opt'))) + end) | SWITCH_C(SWITCH(tr0, match, tr_opt)) => - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in e_to_t(SWITCH_C(SWITCH(x_tr_0,match',tr_opt'))) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in e_to_t(SWITCH_C(SWITCH(x_tr_0,match',tr_opt'))) + end) | SWITCH_E(SWITCH(tr0, match, tr_opt)) => - one_sub tr0 (fn x_tr_0 => - let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match - val tr_opt' = case tr_opt of - SOME tr_alt => SOME(kne tr_alt (fn x => x)) - | NONE => NONE - in e_to_t(SWITCH_E(SWITCH(x_tr_0,match',tr_opt'))) - end) + one_sub tr0 (fn x_tr_0 => + let val match' = map (fn (con,tr) => (con,kne tr (fn x => x))) match + val tr_opt' = case tr_opt of + SOME tr_alt => SOME(kne tr_alt (fn x => x)) + | NONE => NONE + in e_to_t(SWITCH_E(SWITCH(x_tr_0,match',tr_opt'))) + end) | CON0 _ => k tr | CON1(info,tr1 as TR(_,mu1,phi1,psi1)) => one_sub tr1 (fn t' => e_to_t(CON1(info,t'))) @@ -1932,8 +1929,8 @@ struct one_sub tr1 (fn t' => e_to_t(SELECT(i,t'))) | DEREF(tr1) => one_sub tr1 (e_to_t o DEREF) | REF(a,tr1) => one_sub tr1 (fn tr' => e_to_t(REF(a,tr'))) - | ASSIGN(a,tr1,tr2) => - two_sub (tr1,tr2) (fn (t1,t2) => e_to_t(ASSIGN(a,t1,t2))) + | ASSIGN(tr1,tr2) => + two_sub (tr1,tr2) (fn (t1,t2) => e_to_t(ASSIGN(t1,t2))) | DROP(tr1) => one_sub tr1 (fn tr' => e_to_t(DROP(tr'))) | EQUAL(info,t1,t2) => two_sub (t1,t2) (fn (t1',t2') => e_to_t(EQUAL(info,t1',t2'))) @@ -1994,7 +1991,7 @@ struct | (WORD(w,t,_), WORD(w',t',_)) => w=w' | (STRING(s,_), STRING(s',_)) => s=s' | (REAL(r,_), REAL(r',_)) => (r=r') (* reals are represented as strings for the precision to be preserved *) - | (F64(r,_), F64(r',_)) => (r=r') (* f64s are represented as strings for the precision to be preserved *) + | (F64 r, F64 r') => (r=r') (* f64s are represented as strings for the precision to be preserved *) | (UB_RECORD ts1, UB_RECORD ts2) => eq_list eq (ts1,ts2) | (FN{pat = pat1, body = body1, ...}, FN{pat = pat2, body = body2, ...}) => @@ -2018,9 +2015,9 @@ struct | (HANDLE(tr1,tr1'), HANDLE(tr2,tr2')) => eq(tr1,tr2) andalso eq(tr1',tr2') | (SWITCH_I {switch=sw1,precision=p1}, SWITCH_I {switch=sw2, precision=p2}) => - eq_sw (sw1,sw2) eq andalso p1=p2 + eq_sw (sw1,sw2) eq andalso p1=p2 | (SWITCH_W {switch=sw1,precision=p1}, SWITCH_W {switch=sw2, precision=p2}) => - eq_sw (sw1,sw2) eq andalso p1=p2 + eq_sw (sw1,sw2) eq andalso p1=p2 | (SWITCH_S(sw1),SWITCH_S(sw2)) => eq_sw (sw1,sw2) eq | (SWITCH_C(sw1),SWITCH_C(sw2)) => eq_sw (sw1,sw2) eq | (SWITCH_E(sw1),SWITCH_E(sw2)) => eq_sw (sw1,sw2) eq @@ -2034,7 +2031,7 @@ struct | (SELECT(i,tr1), SELECT(i',tr2)) => i=i' andalso eq(tr1,tr2) | (DEREF(tr1), DEREF(tr2)) => eq(tr1,tr2) | (REF(a,tr1), REF(a', tr2)) => eq(tr1,tr2) - | (ASSIGN(a1,tr1,tr1'), ASSIGN(a2,tr2,tr2')) => eq(tr1,tr2) andalso eq(tr1',tr2') + | (ASSIGN(tr1,tr1'), ASSIGN(tr2,tr2')) => eq(tr1,tr2) andalso eq(tr1',tr2') | (DROP(tr1), DROP(tr2)) => eq(tr1,tr2) | (EQUAL(_,tr1,tr1'), EQUAL(_,tr2,tr2')) => eq(tr1,tr2) andalso eq(tr1',tr2') | (CCALL(_,trs1), CCALL(_,trs2)) => eq_list eq (trs1,trs2) @@ -2203,9 +2200,9 @@ struct in (HANDLE(tr1',tr2'), NEXT) end | SWITCH_I {switch,precision} => - (SWITCH_I{switch=tailsw(switch, cont), precision=precision}, NEXT) + (SWITCH_I{switch=tailsw(switch, cont), precision=precision}, NEXT) | SWITCH_W {switch,precision} => - (SWITCH_W{switch=tailsw(switch, cont), precision=precision}, NEXT) + (SWITCH_W{switch=tailsw(switch, cont), precision=precision}, NEXT) | SWITCH_S sw => (SWITCH_S(tailsw(sw, cont)), NEXT) | SWITCH_C sw => (SWITCH_C(tailsw(sw, cont)), NEXT) | SWITCH_E sw => (SWITCH_E(tailsw(sw, cont)), NEXT) @@ -2243,10 +2240,10 @@ struct let val (tr', _) = tail(tr, NEXT) in (REF(a,tr'), NEXT) end - | ASSIGN(a,tr1,tr2) => + | ASSIGN(tr1,tr2) => let val (tr1', _) = tail(tr1, NEXT) val (tr2', _) = tail(tr2, NEXT) - in (ASSIGN(a,tr1',tr2'), NEXT) + in (ASSIGN(tr1',tr2'), NEXT) end | DROP(tr) => let val (tr', _) = tail(tr, NEXT) @@ -2270,11 +2267,12 @@ struct let val (tr', _) = tail(tr,NEXT) in (EXPORT(tyinfo, tr'), NEXT) end - | RESET_REGIONS({force,alloc,regions_for_resetting},t) => + | RESET_REGIONS({force,regions_for_resetting,liveset},t) => let val (t',_) = tail(t,NEXT) - in (RESET_REGIONS({force=force, alloc=alloc, - regions_for_resetting=regions_for_resetting}, - t'), NEXT) + in (RESET_REGIONS({force=force, + regions_for_resetting=regions_for_resetting, + liveset=liveset}, + t'), NEXT) end | FRAME l => (FRAME l, NEXT) ) @@ -2315,4 +2313,4 @@ struct export_Psi = export_Psi} end -end; +end diff --git a/src/Compiler/Regions/MulInf.sml b/src/Compiler/Regions/MulInf.sml index 1e4c27f36..6635e4982 100644 --- a/src/Compiler/Regions/MulInf.sml +++ b/src/Compiler/Regions/MulInf.sml @@ -38,12 +38,19 @@ struct fun sum_psis psis = Mul.sum_psis psis fun max_psis psis = Mul.max_psis psis - fun get_psi(MulExp.TR(_,_,_,psi_r as ref psi)) = psi - fun get_mu(MulExp.TR(_,mu,_,_)) = mu - fun get_place tr = case get_mu tr of RegionExp.Mus[(_,p)] => p | _ => die "get_place" + fun get_psi (MulExp.TR(_,_,_,psi_r as ref psi)) = psi + fun get_mu (MulExp.TR(_,mu,_,_)) = mu - fun frv(mu): RType.place list = - Eff.remove_duplicates(List.filter Eff.is_rho (RType.ann_mus [mu] [])) + fun get_boxed_place s tr = + case get_mu tr of + RegionExp.Mus[mu] => + (case RType.unBOX mu of + SOME (_,p) => p + | NONE => die ("get_boxed_place.expecting boxed mu: " ^ s)) + | _ => die ("get_boxed_place.expecting single mu: " ^ s) + + fun frv mu : RType.place list = + Eff.remove_duplicates(List.filter Eff.is_rho (RType.ann_mus [mu] [])) fun cons_if_there (NONE) l = l | cons_if_there (SOME x) l = x::l @@ -51,7 +58,7 @@ struct val return_EE = ref Mul.empty_efenv (* the efenv to be returned by multiplicity inference*) type StringTree = PP.StringTree - fun layoutp(t1,t2) = PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT":", children = [t1,t2]} + fun layoutp (t1,t2) = PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT":", children = [t1,t2]} fun layoutExp e = MulExp.layoutLambdaExp (if print_regions() @@ -99,19 +106,19 @@ struct *) exception Abort of exn - fun mulinf(Psi: Mul.imp_mularefmap, dep: Mul.dependency_map, cone: Eff.cone, - tr as MulExp.TR(e, mu, phi, psi_r as ref psi): (place, (place*Mul.mul), Mul.qmularefset ref)trip_psi) = + fun mulinf (Psi: Mul.imp_mularefmap, dep: Mul.dependency_map, cone: Eff.cone, + tr as MulExp.TR(e, mu, phi, psi_r as ref psi): (place, (place*Mul.mul), Mul.qmularefset ref)trip_psi) = let open MulExp (* to get constructors of expressions *) - fun infer_trip(tr as MulExp.TR(e, mu, phi, psi_r as ref psi): (place, (place*Mul.mul), Mul.qmularefset ref)trip_psi): unit = + fun infer_trip (tr as MulExp.TR(e, mu, phi, psi_r as ref psi): (place, (place*Mul.mul), Mul.qmularefset ref)trip_psi) : unit = let fun infer_sw (MulExp.SWITCH(tr0, choices, opt_else)) = let val right_hand_sides = (cons_if_there opt_else (map #2 choices)) val _ = app (fn tr => infer_trip(tr)) (tr0 :: right_hand_sides) - val case_object_place = get_place tr0 + (* val case_object_place = get_place tr0 *) val choices_psi = max_psis (map get_psi right_hand_sides) in psi_r:= Mul.sumef(get_psi tr0, choices_psi) @@ -137,56 +144,56 @@ struct shared semantic objects *) (* val psi = case alloc - of SOME p => Mul.put p - | NONE => Mul.empty_psi + of SOME p => Mul.put p + | NONE => Mul.empty_psi *) - val psi = Mul.empty_psi + val psi = Mul.empty_psi in - psi_r:= psi - end - | INTEGER(_,t,p) => psi_r:= Mul.put p - | WORD(_,t,p) => psi_r:= Mul.put p + psi_r:= psi + end + | INTEGER(_,t,p) => (case p of SOME p => psi_r:= Mul.put p | NONE => ()) + | WORD(_,t,p) => (case p of SOME p => psi_r:= Mul.put p | NONE => ()) | STRING(_,p) => psi_r:= Mul.put p | REAL(_,p) => psi_r:= Mul.put p - | F64(_,p) => psi_r:= Mul.put p + | F64 _ => () | UB_RECORD(trips) => - let - val _ = app(fn tr => infer_trip(tr))trips - val psi = sum_psis(map get_psi trips) - in - psi_r:= psi + let val _ = app(fn tr => infer_trip(tr))trips + val psi = sum_psis(map get_psi trips) + in psi_r:= psi end | FN{pat,body,free,alloc} => - (case mu of - RegionExp.Mus[(ty,_)] => - (case RType.unFUN ty of - SOME (_,eps,_) => - let - val _ = infer_trip(body) - val psi = get_psi body - val psi_eps = #2(Mul.un_mularef(Mul.nf(!( + (case mu of + RegionExp.Mus[mu] => + (case RType.unBOX mu of + SOME (ty,_) => + (case RType.unFUN ty of + SOME (_,eps,_) => + let val _ = infer_trip(body) + val psi = get_psi body + val psi_eps = #2(Mul.un_mularef(Mul.nf(!( Mul.lookup_mularefmap(Psi, eps))))) - val almost_new_psi = Mul.maxef(psi,psi_eps) - (* eps.almost_new_psi is not necessarily acyclic; so normalise it: *) - val (_,new_psi) = Mul.un_mularef(Mul.nf(Mul.makearef(eps,almost_new_psi))) - fun debug() = - (print "DEBUG FN\n"; - print " eps = \n" ; outtree(Eff.layout_effect eps); - print "\n psi =\n" ; outtree(Mul.layout_mulef psi); - print "\n psi_eps =\n"; outtree(Mul.layout_mulef psi_eps); - print "\n almost_new_psi=\n"; outtree(Mul.layout_mulef almost_new_psi); - print "\n new_psi=\n"; outtree(Mul.layout_mulef new_psi); - print "\n") - val _ = Mul.doSubst(eps, Mul.diffef(new_psi,psi_eps), dep) - handle X => - (say "\nMulInf(FN) fails:\n"; - debug(); raise X) - in - psi_r:= Mul.put alloc - end - | NONE => die "function not of function type") - | _ => die "function not of function type" - ) + val almost_new_psi = Mul.maxef(psi,psi_eps) + (* eps.almost_new_psi is not necessarily acyclic; so normalise it: *) + val (_,new_psi) = Mul.un_mularef(Mul.nf(Mul.makearef(eps,almost_new_psi))) + fun debug () = + (print "DEBUG FN\n"; + print " eps = \n" ; outtree(Eff.layout_effect eps); + print "\n psi =\n" ; outtree(Mul.layout_mulef psi); + print "\n psi_eps =\n"; outtree(Mul.layout_mulef psi_eps); + print "\n almost_new_psi=\n"; outtree(Mul.layout_mulef almost_new_psi); + print "\n new_psi=\n"; outtree(Mul.layout_mulef new_psi); + print "\n") + val _ = Mul.doSubst(eps, Mul.diffef(new_psi,psi_eps), dep) + handle X => + (say "\nMulInf(FN) fails:\n"; + debug(); raise X) + in + psi_r:= Mul.put alloc + end + | NONE => die "function not of function type") + | NONE => die "function not boxed") + | _ => die "function not of function type" + ) | LETREGION{B: effect list ref, rhos, body} => let val _ = infer_trip(body) val psi_body = get_psi body @@ -215,14 +222,17 @@ struct end | APP(ck,sr,tr1, tr2) => - (* application is by the inference rules (non-smart) *) - let + (* application is by the inference rules (non-smart) *) + let val (eps, p) = case get_mu tr1 of - RegionExp.Mus[(ty, p)]=> - (case RType.unFUN ty of - SOME (_,eps,_) => (eps, p) - | NONE => die "non-function type at application") - | _ => die "non-function type at application" + RegionExp.Mus[mu] => + (case RType.unBOX mu of + NONE => die "non-boxed function type at application" + | SOME (ty,p) => + (case RType.unFUN ty of + SOME (_,eps,_) => (eps, p) + | NONE => die "non-function type at application")) + | _ => die "non-function type at application" val _ = infer_trip(tr1) val _ = infer_trip(tr2) val psi1 = get_psi tr1 (* may have been updated by mulinf(e2)! *) @@ -232,12 +242,11 @@ struct psi1, psi2] in psi_r := psi - end + end - - | EXCEPTION(excon, nullary: bool, mu as (tau,rho), alloc, body) => + | EXCEPTION(excon, nullary: bool, mu, alloc, body) => let - val _ = infer_trip(body); (* no need to bind excon; won't have to look it up! *) + val _ = infer_trip body (* no need to bind excon; won't have to look it up! *) (* Nullary constructors are bound to a pointer * in region rho which points to object consisting of exname and @@ -253,12 +262,10 @@ struct * into region rho. *) + val (_,rho) = case RType.unBOX mu of SOME p => p | NONE => die "EXCEPTION: expecting boxed value" val psi_excon = if nullary then Mul.sumef(Mul.put rho, Mul.put rho) else Mul.put rho - - in - psi_r:= Mul.sumef(psi_excon, get_psi body) + in psi_r:= Mul.sumef(psi_excon, get_psi body) end - | RAISE(tr) => (infer_trip(tr); psi_r:= get_psi tr @@ -268,11 +275,14 @@ struct val _ = infer_trip(tr1) val _ = infer_trip(tr2) val (eps,rho_handler) = case get_mu tr2 of - RegionExp.Mus[(ty,rho)] => - (case RType.unFUN ty of - SOME (_,eps,_) => (eps,rho) - | NONE => die "HANDLE: handler did not have functional type") - | _ => die "HANDLE: handler did not have functional type" + RegionExp.Mus[mu] => + (case RType.unBOX mu of + SOME(ty,rho) => + (case RType.unFUN ty of + SOME (_,eps,_) => (eps,rho) + | NONE => die "HANDLE: handler did not have functional type") + | NONE => die "HANDLE: handler did not have boxed functional type") + | _ => die "HANDLE: handler did not have functional type" val psi_of_eps = #2(Mul.un_mularef(!(Mul.lookup_mularefmap(Psi,eps)))) val psi_aux = Mul.sum_psis[psi_of_eps,Mul.efvar eps(*, Mul.get rho_handler*)] in @@ -283,84 +293,85 @@ struct | SWITCH_S sw => infer_sw sw | SWITCH_C sw => infer_sw sw | SWITCH_E sw => infer_sw sw - | CON0{con, il, aux_regions,alloc = p} => psi_r:= Mul.put p - | CON1({con, il, alloc = p}, tr) => - (infer_trip(tr); - psi_r:= Mul.sumef(Mul.put p, get_psi tr)) + | CON0{con, il, aux_regions,alloc} => + (case alloc of + SOME p => psi_r:= Mul.put p + | NONE => ()) + | CON1({con, il, alloc}, tr) => + (infer_trip tr; + case alloc of + SOME p => psi_r:= Mul.sumef(Mul.put p, get_psi tr) + | NONE => psi_r:= get_psi tr) | DECON({con, il}, tr) => - (infer_trip(tr); - psi_r:= get_psi tr(*Mul.sumef(Mul.get(get_place(tr)), get_psi tr)*) ) + (infer_trip tr; + psi_r:= get_psi tr(*Mul.sumef(Mul.get(get_place(tr)), get_psi tr)*) ) | EXCON(excon, NONE) => psi_r:= Mul.empty_psi | EXCON(excon, SOME (p,tr)) => - (infer_trip(tr); - psi_r:= Mul.sumef(Mul.put p, get_psi tr)) + (infer_trip tr; + psi_r:= Mul.sumef(Mul.put p, get_psi tr)) | DEEXCON(excon, tr) => - (infer_trip(tr); - psi_r:= get_psi tr (*Mul.sumef(Mul.get(get_place(tr)), get_psi tr)*) ) - | RECORD(p, triples) => - let - val _ = app(fn tr => infer_trip(tr))triples - val psi = sum_psis(Mul.put p :: map get_psi triples) - in - psi_r:= psi - end + (infer_trip tr; + psi_r:= get_psi tr (*Mul.sumef(Mul.get(get_place(tr)), get_psi tr)*) ) + | RECORD(NONE, nil) => () + | RECORD(NONE,_) => die "mulinf: RECORD" + | RECORD(SOME p, triples) => + let val _ = app (fn tr => infer_trip tr) triples + val psi = sum_psis(Mul.put p :: map get_psi triples) + in psi_r:= psi + end | SELECT(i, tr)=> - (infer_trip(tr); - case get_mu tr of - RegionExp.Mus[(_,place_of_tuple)] => - psi_r:= get_psi tr (*Mul.sumef(Mul.get place_of_tuple, get_psi tr)*) - | _ => die "SELECT: expected single type and place") + (infer_trip(tr); + let val place_of_tuple = get_boxed_place "SELECT" tr + in psi_r:= get_psi tr (*Mul.sumef(Mul.get place_of_tuple, get_psi tr)*) + end) | DEREF tr => - (infer_trip(tr); - case get_mu tr of - RegionExp.Mus[(_,place_of_ref)] => - psi_r:= get_psi tr (*Mul.sumef(Mul.get place_of_ref, get_psi tr)*) - | _ => die "DEREF: expected single type and place") + (infer_trip tr; + let val place_of_ref = get_boxed_place "DEREF" tr + in psi_r:= get_psi tr (*Mul.sumef(Mul.get place_of_ref, get_psi tr)*) + end) | REF(p, tr1) => - (infer_trip(tr1); - case get_mu tr of - RegionExp.Mus[(_,place_of_ref)] => - psi_r:= Mul.sumef(Mul.put place_of_ref, get_psi tr1) - | _ => die "REF: expected single type and place") - | ASSIGN(p, tr1, tr2) => - (infer_trip(tr1); - infer_trip(tr2); - case get_mu tr1 of - RegionExp.Mus[(_,place_of_ref)] => - psi_r:= sum_psis[Mul.put p, (*Mul.putzero place_of_ref,mael*) get_psi tr1, get_psi tr2] - | _ => die "ASSIGN: expected single type and place of reference") + (infer_trip tr1; + let val place_of_ref = get_boxed_place "REF" tr + in psi_r:= Mul.sumef(Mul.put place_of_ref, get_psi tr1) + end) + | ASSIGN(tr1, tr2) => + (infer_trip tr1; + infer_trip tr2; + psi_r:= sum_psis[get_psi tr1, get_psi tr2] + ) | DROP(tr) => - (infer_trip(tr); + (infer_trip tr; psi_r:= get_psi tr ) - | EQUAL({mu_of_arg1,mu_of_arg2, alloc}, tr1, tr2)=> + | EQUAL({mu_of_arg1,mu_of_arg2}, tr1, tr2)=> (infer_trip(tr1); infer_trip(tr2); let val annotations = RType.ann_mus[mu_of_arg1, mu_of_arg2] [] val frv = Eff.remove_duplicates(List.filter Eff.is_rho annotations) - in psi_r:= sum_psis(get_psi tr1::get_psi tr2 :: Mul.put alloc :: [] (*map Mul.getInf frv*)) + in psi_r:= sum_psis [get_psi tr1, get_psi tr2] (*map Mul.getInf frv*) end) | CCALL ({name, rhos_for_result, ...}, trips) => (*Calling C functions*) (app infer_trip trips; (*We produce a `put(rho) : m' for every rho which occurs in - the result type. If rho occurs in a LIST type then m is - INFINITE---otherwise it is NUM 1. To do this, we use the - ``physical size'' of rho according to `rhos_for_result', - which was annotated in SpreadExpression. (See also the - comment in MUL_EXP.)*) - - let val (rhos_inf, rhos_fin) = - foldl (fn ((rho, i_opt),(rhos_inf, rhos_fin)) => - (case i_opt of - SOME i => (rhos_inf, rho :: rhos_fin) - | NONE => (rho :: rhos_inf, rhos_fin))) - ([], []) rhos_for_result - val psi = sum_psis ( map Mul.putInf (Eff.remove_duplicates rhos_inf) - @ map Mul.put (Eff.remove_duplicates rhos_fin) - @ map get_psi trips) - in - psi_r := psi - end) + the result type. If rho occurs in a LIST type then m is + INFINITE---otherwise it is NUM 1. To do this, we use the + ``physical size'' of rho according to `rhos_for_result', + which was annotated in SpreadExpression. (See also the + comment in MUL_EXP.)*) + + let val (rhos_inf, rhos_fin) = + foldl (fn ((rho, i_opt),(rhos_inf, rhos_fin)) => + (case i_opt of + SOME i => (rhos_inf, rho :: rhos_fin) + | NONE => (rho :: rhos_inf, rhos_fin))) + ([], []) rhos_for_result + val psis = map Mul.putInf (Eff.remove_duplicates rhos_inf) + @ map Mul.put (Eff.remove_duplicates rhos_fin) + @ map get_psi trips + in case psis of + nil => () + | _ => psi_r := sum_psis psis + end) | BLOCKF64(p, triples) => let val _ = app infer_trip triples val psi = sum_psis(Mul.put p :: map get_psi triples) @@ -371,7 +382,7 @@ struct (infer_trip(tr); psi_r:= get_psi tr ) - | RESET_REGIONS({force: bool, alloc,regions_for_resetting}, tr) => + | RESET_REGIONS({force: bool, regions_for_resetting, liveset}, tr) => (* for programmer-directed resetting of regions; resetting is forced iff "force" is true.*) (infer_trip(tr); @@ -385,38 +396,36 @@ struct | FRAME{declared_lvars, declared_excons} => return_EE := foldl(fn ({lvar, other, ...}, EE) => - ((*say(Lvar.pr_lvar lvar ^ ":"); (*mads*) - outtree(Mul.layout_qmularefset(!other)); - say "\n";*) - Mul.declare(EE,lvar, other))) - Mul.empty_efenv - declared_lvars + ((*say(Lvar.pr_lvar lvar ^ ":"); (*mads*) + outtree(Mul.layout_qmularefset(!other)); + say "\n";*) + Mul.declare(EE,lvar, other))) + Mul.empty_efenv + declared_lvars end handle Abort exn => raise Abort exn | exn => (outtree(layouttrip tr); raise Abort exn) - and inf_rh_sides(functions, shared_clos) = - let - val t0 = Mul.last_increment() - val _ = app (fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, - bound_but_never_written_into, - other,bind} => - let val qmul = Mul.makeqmularefset(rhos,epss,Psi,shared_clos,cone) - in - other:= qmul - end) functions + and inf_rh_sides (functions, shared_clos) = + let val t0 = Mul.last_increment() + val _ = app (fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + bound_but_never_written_into, + other,bind} => + let val qmul = Mul.makeqmularefset(rhos,epss,Psi,SOME shared_clos,cone) + in other := qmul + end) functions in - app(fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, - bound_but_never_written_into, - other,bind} => - (infer_trip(bind); - (* update type scheme for the function, if there has been - a change. *) - if t0 <> Mul.last_increment() - then other:= Mul.makeqmularefset(rhos,epss,Psi,shared_clos,cone) - else () - ) - ) functions; + app (fn {lvar,occ,tyvars,rhos,epss,Type,rhos_formals, + bound_but_never_written_into, + other,bind} => + (infer_trip bind; + (* update type scheme for the function, if there has been + a change. *) + if t0 <> Mul.last_increment() + then other:= Mul.makeqmularefset(rhos,epss,Psi,SOME shared_clos,cone) + else () + ) + ) functions; if t0 = Mul.last_increment() then () else inf_rh_sides(functions, shared_clos) @@ -480,21 +489,21 @@ struct | SWITCH_E sw => set_sw sw | CON0 _ => () | CON1 (_,tr) => set_trip tr - | DECON (_,tr) => set_trip tr - | EXCON(_,SOME(_,tr)) => set_trip tr - | EXCON(_,NONE) => () + | DECON (_,tr) => set_trip tr + | EXCON(_,SOME(_,tr)) => set_trip tr + | EXCON(_,NONE) => () | DEEXCON(_, tr) => set_trip tr | RECORD (_, triples) => app set_trip triples | SELECT(_, tr) => set_trip tr | DEREF tr => set_trip tr | REF(_, tr) => set_trip tr - | ASSIGN(_, tr1, tr2) => (set_trip tr1; set_trip tr2) + | ASSIGN(tr1, tr2) => (set_trip tr1; set_trip tr2) | DROP(tr1) => (set_trip tr1) | EQUAL(_, tr1, tr2) => (set_trip tr1; set_trip tr2) | CCALL(_, trips) => app set_trip trips | BLOCKF64 (_, triples) => app set_trip triples | SCRATCHMEM _ => () - | EXPORT(_,tr) => set_trip tr + | EXPORT(_,tr) => set_trip tr | RESET_REGIONS(_, tr) => set_trip tr | FRAME _ => () end handle Abort exn => raise Abort exn @@ -556,7 +565,7 @@ struct of tr may be looked up; it is applicative *) c: Eff.cone, mulenv: Mul.efenv) : (place,place*Mul.mul,Mul.qmularefset ref)LambdaPgm_psi * efenv * mularefmap = - let + let val test = false val _ = if test then say "\nmulInf:" else (); val _ = if test then say " collecting all effects..." else () @@ -571,33 +580,33 @@ struct val _ = if test then say " making the arrow effect set Phi..." else () val Psi = - (* 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)) + (* 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)) ( (*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 - end + val _ = if test then say " made Phi, now constructing the map Psi..." else () + in makezero_Phi Phi + end val _ = if test then (say " Psi0 = "; outtree(Mul.layout_mularefmap Psi0)) - else () + else () val _ = if test then (say " Psi = "; outtree(Mul.layout_imp_mularefmap Psi)) - else () + else () val _ = if test then say "\n made Psi, now adding local and external Psi" else () val Psi_combined = combine(Psi0, Psi) - val _ = if test then (say " Psi_combined = "; - outtree(Mul.layout_imp_mularefmap Psi_combined)) - else () + val _ = if test then (say " Psi_combined = "; + outtree(Mul.layout_imp_mularefmap Psi_combined)) + else () - val _ = if test then say "\n now making initial multiplicity expression" else () + val _ = if test then say "\n now making initial multiplicity expression" else () val dep = mk_init_dependency_map Psi_combined (* dep is purely local to this program unit; no global dependencies between semantic objects are required, as we assume that all top-level multiplicities are infinite; - Yes, but we need to add top-level effectvars anyway, for - lookup_dep not to fail! 12/01/97-Martin *) + Yes, but we need to add top-level effectvars anyway, for + lookup_dep not to fail! 12/01/97-Martin *) val (tr_psi, dep) = mk_initial_mulexp(mulenv,tr, dep) val _ = if test then say "\n now starting multiplicity inference proper (i.e., calling mulinf)..." else () val tr' = mulinf(Psi_combined, dep, c, tr_psi) footnote @@ -622,34 +631,34 @@ struct val Psi_export = Mul.reify export_Psi_list - val (export_lvars, export_excons) = - let open MulExp - val TR(_,metatype,_,_) = tr' - in case metatype - of RegionExp.Frame{declared_lvars,declared_excons} => - (map #lvar declared_lvars, map #1 declared_excons) - | RegionExp.RaisedExnBind => ([],[]) - | RegionExp.Mus _ => die "export" - end + val (export_lvars, export_excons) = + let open MulExp + val TR(_,metatype,_,_) = tr' + in case metatype + of RegionExp.Frame{declared_lvars,declared_excons} => + (map #lvar declared_lvars, map #1 declared_excons) + | RegionExp.RaisedExnBind => ([],[]) + | RegionExp.Mus _ => die "export" + end - val export_rhos = - foldl (fn (effect, rhos) => if Eff.is_rho effect then effect::rhos else rhos) - [] export_basis + val export_rhos = + foldl (fn (effect, rhos) => if Eff.is_rho effect then effect::rhos else rhos) + [] export_basis val pgm' = MulExp.PGM{expression = tr', - export_datbinds = export_datbinds, (* unchanged *) - import_vars=ref NONE, - export_vars=(export_lvars,export_excons,export_rhos), - export_basis = export_basis, (* unchanged *) - export_Psi = export_Psi_list} + export_datbinds = export_datbinds, (* unchanged *) + import_vars=ref NONE, + export_vars=(export_lvars,export_excons,export_rhos), + export_basis = export_basis, (* unchanged *) + export_Psi = export_Psi_list} - val _ = case export_rhos of nil => () | _ => - print ("** MulInf: export_rhos non-empty\n") + val _ = case export_rhos of nil => () | _ => + print ("** MulInf: export_rhos non-empty\n") - val _ = case export_Psi_list of nil => () | _ => - print ("** MulInf: export_Psi_list non-empty\n") + val _ = case export_Psi_list of nil => () | _ => + print ("** MulInf: export_Psi_list non-empty\n") - in + in if false then if test_knorm(pgm') then () @@ -657,7 +666,7 @@ struct else (); (pgm', EE', Psi_export) footnote Mul.reset_dep() - end + end (* Contract: traverse program and combine regions of the same region * type that are bound by the same letregion construct. *) @@ -665,105 +674,105 @@ struct local open MulExp in datatype app_cont = APP_CONT | APP_BREAK local - fun apps appt (SWITCH(t,ts,d)) : unit = - (appt t; List.app (fn (_,t) => appt t) ts; - case d of SOME t => appt t | NONE => ()) - fun appt f (TR(e,_,_,_)) : unit = appe f e - and appe f e = - case f e of - APP_BREAK => () - | APP_CONT => - case e of - VAR _ => () - | INTEGER _ => () - | WORD _ => () - | STRING _ => () - | REAL _ => () - | F64 _ => () - | UB_RECORD ts => List.app (appt f) ts - | FN {pat,body,free,alloc} => appt f body - | LET {k_let, pat, bind, scope} => (appt f bind; appt f scope) - | LETREGION {B,rhos,body} => appt f body - | FIX {free, shared_clos, functions,scope} => - let fun appf {lvar,occ,tyvars,rhos,epss, - Type,rhos_formals,bound_but_never_written_into, - other, bind} = appt f bind - in List.app appf functions; appt f scope - end - | APP (_,_,t1,t2) => (appt f t1; appt f t2) - | EXCEPTION (_,_,_,_,t) => appt f t - | RAISE t => appt f t - | HANDLE (t1,t2) => (appt f t1; appt f t2) - | SWITCH_I {switch,precision} => apps (appt f) switch - | SWITCH_W {switch,precision} => apps (appt f) switch - | SWITCH_S switch => apps (appt f) switch - | SWITCH_C switch => apps (appt f) switch - | SWITCH_E switch => apps (appt f) switch - | CON0 _ => () - | CON1 (_,t) => appt f t - | DECON (_,t) => appt f t - | EXCON (_,opt) => (case opt of - SOME (_,t) => appt f t - | NONE => ()) - | DEEXCON (_,t) => appt f t - | RECORD (_,ts) => List.app (appt f) ts - | SELECT (_,t) => appt f t - | DEREF t => appt f t - | REF (_,t) => appt f t - | ASSIGN (_,t1,t2) => (appt f t1; appt f t2) - | DROP t => appt f t - | EQUAL (_,t1,t2) => (appt f t1; appt f t2) - | CCALL (_,ts) => List.app (appt f) ts - | BLOCKF64 (_,ts) => List.app (appt f) ts + fun apps appt (SWITCH(t,ts,d)) : unit = + (appt t; List.app (fn (_,t) => appt t) ts; + case d of SOME t => appt t | NONE => ()) + fun appt f (TR(e,_,_,_)) : unit = appe f e + and appe f e = + case f e of + APP_BREAK => () + | APP_CONT => + case e of + VAR _ => () + | INTEGER _ => () + | WORD _ => () + | STRING _ => () + | REAL _ => () + | F64 _ => () + | UB_RECORD ts => List.app (appt f) ts + | FN {pat,body,free,alloc} => appt f body + | LET {k_let, pat, bind, scope} => (appt f bind; appt f scope) + | LETREGION {B,rhos,body} => appt f body + | FIX {free, shared_clos, functions,scope} => + let fun appf {lvar,occ,tyvars,rhos,epss, + Type,rhos_formals,bound_but_never_written_into, + other, bind} = appt f bind + in List.app appf functions; appt f scope + end + | APP (_,_,t1,t2) => (appt f t1; appt f t2) + | EXCEPTION (_,_,_,_,t) => appt f t + | RAISE t => appt f t + | HANDLE (t1,t2) => (appt f t1; appt f t2) + | SWITCH_I {switch,precision} => apps (appt f) switch + | SWITCH_W {switch,precision} => apps (appt f) switch + | SWITCH_S switch => apps (appt f) switch + | SWITCH_C switch => apps (appt f) switch + | SWITCH_E switch => apps (appt f) switch + | CON0 _ => () + | CON1 (_,t) => appt f t + | DECON (_,t) => appt f t + | EXCON (_,opt) => (case opt of + SOME (_,t) => appt f t + | NONE => ()) + | DEEXCON (_,t) => appt f t + | RECORD (_,ts) => List.app (appt f) ts + | SELECT (_,t) => appt f t + | DEREF t => appt f t + | REF (_,t) => appt f t + | ASSIGN (t1,t2) => (appt f t1; appt f t2) + | DROP t => appt f t + | EQUAL (_,t1,t2) => (appt f t1; appt f t2) + | CCALL (_,ts) => List.app (appt f) ts + | BLOCKF64 (_,ts) => List.app (appt f) ts | SCRATCHMEM _ => () - | EXPORT (_,t) => appt f t - | RESET_REGIONS (_,t) => appt f t - | FRAME _ => () + | EXPORT (_,t) => appt f t + | RESET_REGIONS (_,t) => appt f t + | FRAME _ => () in - fun app f (PGM{expression,...}) = appt f expression - val appt = appt + fun app f (PGM{expression,...}) = appt f expression + val appt = appt end local exception LVARS of lvar list in - fun exported_lvars p = - let fun r (FRAME {declared_lvars,...}) = - raise LVARS (map #lvar declared_lvars) - | r _ = APP_CONT - in app r p ; die "exported_lvars.shouldn't get here" - end handle LVARS lvs => lvs + fun exported_lvars p = + let fun r (FRAME {declared_lvars,...}) = + raise LVARS (map #lvar declared_lvars) + | r _ = APP_CONT + in app r p ; die "exported_lvars.shouldn't get here" + end handle LVARS lvs => lvs end fun contract_letregions (p : (place,place*mul, qmularefset ref)LambdaPgm_psi) : unit = - let - fun on_letregion x = - let fun seek r nil = NONE - | seek r ((_,Mul.NUM _)::rs) = seek r rs - | seek r ((r',Mul.INF)::rs) = - (case (Eff.get_place_ty r, Eff.get_place_ty r') of - (SOME rt, SOME rt') => if rt=rt' then SOME r' - else seek r rs - | _ => die "contract") - fun t (nil,acc) = rev acc - | t ((p as (_,Mul.NUM _))::rs,acc) = t(rs,p::acc) - | t ((p as (r,Mul.INF))::rs, acc) = - (* look for infinite regions in acc with same runType *) - (case seek r acc of - SOME r' => (Eff.unifyRho (r,r') Eff.initCone; t(rs,acc)) - | NONE => t(rs,p::acc)) - in t (x,nil) - end - fun f (LETREGION {B,rhos,body}) = (rhos := on_letregion(!rhos); APP_CONT) - | f _ = APP_CONT - in - app f p - end + let + fun on_letregion x = + let fun seek r nil = NONE + | seek r ((_,Mul.NUM _)::rs) = seek r rs + | seek r ((r',Mul.INF)::rs) = + (case (Eff.get_place_ty r, Eff.get_place_ty r') of + (SOME rt, SOME rt') => if rt=rt' then SOME r' + else seek r rs + | _ => die "contract") + fun t (nil,acc) = rev acc + | t ((p as (_,Mul.NUM _))::rs,acc) = t(rs,p::acc) + | t ((p as (r,Mul.INF))::rs, acc) = + (* look for infinite regions in acc with same runType *) + (case seek r acc of + SOME r' => (Eff.unifyRho (r,r') Eff.initCone; t(rs,acc)) + | NONE => t(rs,p::acc)) + in t (x,nil) + end + fun f (LETREGION {B,rhos,body}) = (rhos := on_letregion(!rhos); APP_CONT) + | f _ = APP_CONT + in + app f p + end fun member lv nil = false - | member lv (x::xs) = Lvar.eq(lv,x) orelse member lv xs + | member lv (x::xs) = Lvar.eq(lv,x) orelse member lv xs type rng = {formals:(place*mul) list ref, rargss: place list ref list ref, - argss:place list ref list ref} + argss:place list ref list ref} (* Build initial a-list from formal region arguments; an a-list describes * which region parameters that may be collapsed. Because we do not wish @@ -771,237 +780,237 @@ struct * regions, whereas 1 is chosen for infinite regions. Further, infinite * regions of different types should not be collapsed. *) fun init_alist (pl: (place*mul)list) : int list = - let - fun lookup (ty,e,n) = - let fun look nil = (n,(ty,n)::e,n+1) - | look ((ty',i)::xs) = if ty=ty' then (i,e,n) else look xs - in look e - end - in - rev(#1(List.foldl (fn ((p,m),(l,e,n)) => - case m of - Mul.NUM _ => (n::l,e,n+1) - | Mul.INF => - (case Eff.get_place_ty p of - SOME ty => let val (i,e,n) = lookup(ty,e,n) - in (i::l,e,n) - end - | NONE => die "init_alist")) - (nil,nil,1) pl)) - end + let + fun lookup (ty,e,n) = + let fun look nil = (n,(ty,n)::e,n+1) + | look ((ty',i)::xs) = if ty=ty' then (i,e,n) else look xs + in look e + end + in + rev(#1(List.foldl (fn ((p,m),(l,e,n)) => + case m of + Mul.NUM _ => (n::l,e,n+1) + | Mul.INF => + (case Eff.get_place_ty p of + SOME ty => let val (i,e,n) = lookup(ty,e,n) + in (i::l,e,n) + end + | NONE => die "init_alist")) + (nil,nil,1) pl)) + end (* Build a-list from region vector. *) fun args_alist (pl: place list) : int list = - let fun get n p e = - let fun loop nil = (n, (p,n)::e,n+1) - | loop ((p',i)::rest) = if Eff.eq_effect(p,p') then (i,e,n) - else loop rest - in loop e - end - in - rev(#1(List.foldl (fn (p,(l,e,n)) => - let val (i,e,n) = get n p e - in (i::l,e,n) - end) - (nil,nil,1) pl)) - end + let fun get n p e = + let fun loop nil = (n, (p,n)::e,n+1) + | loop ((p',i)::rest) = if Eff.eq_effect(p,p') then (i,e,n) + else loop rest + in loop e + end + in + rev(#1(List.foldl (fn (p,(l,e,n)) => + let val (i,e,n) = get n p e + in (i::l,e,n) + end) + (nil,nil,1) pl)) + end fun eq_E (E:(place list * int list)list) (p,p') = - let fun loop z (nil,_) = NONE - | loop z (_,nil) = NONE - | loop z (x::xs,y::ys) = if Eff.eq_effect(z,x) then SOME y - else loop z (xs,ys) - fun loop2 n z nil = NONE - | loop2 n z (x::xs) = (case loop z x of - SOME i => SOME (n,i) - | NONE => loop2 (n+1) z xs) - fun find p : (int*int) option = loop2 1 p E - in case find p of - SOME pair => (case find p' of - SOME pair' => pair=pair' - | NONE => false) - | NONE => false - end + let fun loop z (nil,_) = NONE + | loop z (_,nil) = NONE + | loop z (x::xs,y::ys) = if Eff.eq_effect(z,x) then SOME y + else loop z (xs,ys) + fun loop2 n z nil = NONE + | loop2 n z (x::xs) = (case loop z x of + SOME i => SOME (n,i) + | NONE => loop2 (n+1) z xs) + fun find p : (int*int) option = loop2 1 p E + in case find p of + SOME pair => (case find p' of + SOME pair' => pair=pair' + | NONE => false) + | NONE => false + end fun rargs_alist (E: (place list * int list)list) (pl: place list) : int list = - let fun eq (p,p') = Eff.eq_effect (p,p') orelse eq_E E (p,p') - fun get n p e = - let fun loop nil = (n, (p,n)::e,n+1) - | loop ((p',i)::rest) = if eq(p,p') then (i,e,n) - else loop rest - in loop e - end - in - rev(#1(List.foldl (fn (p,(l,e,n)) => - let val (i,e,n) = get n p e - in (i::l,e,n) - end) - (nil,nil,1) pl)) - end + let fun eq (p,p') = Eff.eq_effect (p,p') orelse eq_E E (p,p') + fun get n p e = + let fun loop nil = (n, (p,n)::e,n+1) + | loop ((p',i)::rest) = if eq(p,p') then (i,e,n) + else loop rest + in loop e + end + in + rev(#1(List.foldl (fn (p,(l,e,n)) => + let val (i,e,n) = get n p e + in (i::l,e,n) + end) + (nil,nil,1) pl)) + end (* Collapse two a-lists into one a-list *) fun collapse_alist (l1:int list) (l2:int list) : int list = - let fun get n p e = - let fun look nil = (n, (p,n)::e, n+1) - | look ((p',i)::rest) = if p = p' then (i,e,n) else look rest - in look e - end - in rev(#1(ListPair.foldl (fn (i1,i2,(l,e,n)) => - let val (i,e,n) = get n (i1,i2) e - in (i::l,e,n) - end) (nil,nil,1) (l1,l2))) - end + let fun get n p e = + let fun look nil = (n, (p,n)::e, n+1) + | look ((p',i)::rest) = if p = p' then (i,e,n) else look rest + in look e + end + in rev(#1(ListPair.foldl (fn (i1,i2,(l,e,n)) => + let val (i,e,n) = get n (i1,i2) e + in (i::l,e,n) + end) (nil,nil,1) (l1,l2))) + end fun pp_ls nil = "" - | pp_ls [x] = x - | pp_ls (x::xs) = x ^ "," ^ pp_ls xs + | pp_ls [x] = x + | pp_ls (x::xs) = x ^ "," ^ pp_ls xs fun pp_list nil = "[]" - | pp_list xs = "[" ^ pp_ls xs ^ "]" + | pp_list xs = "[" ^ pp_ls xs ^ "]" fun pp_mul (Mul.NUM _) = "f" - | pp_mul (Mul.INF) = "" + | pp_mul (Mul.INF) = "" fun pp_places xs = pp_list (map (fn p => PP.flatten1 (Eff.layout_effect p)) xs) fun pp_formals xs = pp_list (map (fn (p,m) => (PP.flatten1 (Eff.layout_effect p) ^ pp_mul m)) xs) fun pp_args xs = pp_places (!xs) fun pp_ints xs = pp_list (map Int.toString xs) fun pp_argss nil = "" - | pp_argss (x::xs) = " " ^ pp_args x ^ "\n" ^ pp_argss xs + | pp_argss (x::xs) = " " ^ pp_args x ^ "\n" ^ pp_argss xs val touched = ref false val touch_count = ref 0 fun unify_formals lv (alist: int list, formals: (place*mul)list) : unit = - let fun unify (_,_,nil,nil) = () - | unify (x,p,x'::xs,(p',_)::ps) = - if x = x' then (Eff.unifyRho_no_lowering (p,p'); - touched := true; - touch_count := !touch_count + 1 -(* ; print("UNIFYING(" ^ Lvar.pr_lvar lv ^ "\n") *) - ) - else unify (x,p,xs,ps) - | unify _ = die "unify_formals.unify" - fun loop (nil,nil) = () - | loop (x::xs, (p,_)::ps) = (unify (x,p,xs,ps); loop (xs,ps)) - | loop _ = die "unify_formals.loop" - in loop (alist,formals) - end + let fun unify (_,_,nil,nil) = () + | unify (x,p,x'::xs,(p',_)::ps) = + if x = x' then (Eff.unifyRho_no_lowering (p,p'); + touched := true; + touch_count := !touch_count + 1 +(* ; print("UNIFYING(" ^ Lvar.pr_lvar lv ^ "\n") *) + ) + else unify (x,p,xs,ps) + | unify _ = die "unify_formals.unify" + fun loop (nil,nil) = () + | loop (x::xs, (p,_)::ps) = (unify (x,p,xs,ps); loop (xs,ps)) + | loop _ = die "unify_formals.loop" + in loop (alist,formals) + end fun trim_args (alist: int list, l:'a list) = - let fun is_in (x,nil) = false - | is_in (x,y::ys) = x=y orelse is_in(x,ys) - fun loop (nil,nil,e) = nil - | loop (x::xs,p::ps,e) = if is_in (x,e) then loop (xs,ps,e) - else p :: loop (xs,ps,x::e) - | loop _ = die "trim_args" - in loop(alist,l,nil) - end + let fun is_in (x,nil) = false + | is_in (x,y::ys) = x=y orelse is_in(x,ys) + fun loop (nil,nil,e) = nil + | loop (x::xs,p::ps,e) = if is_in (x,e) then loop (xs,ps,e) + else p :: loop (xs,ps,x::e) + | loop _ = die "trim_args" + in loop(alist,l,nil) + end fun contract_args' (fss: (lvar*rng) list list) : unit = - let - fun alist_before_rec (formals,argss) = - let val alist1 = init_alist (!formals) - val alist2 = List.foldl (fn (args,al) => - collapse_alist (args_alist (!args)) al) - alist1 (!argss) - in alist2 - end - - fun onef ((lvar,{formals,rargss,argss}), alist) = - ((* print ("FUNCTION " ^ Lvar.pr_lvar lvar ^ ":\n "); - print (pp_formals (!formals) ^ "\n recursive apps:\n"); - print (pp_argss (!rargss) ^ " apps:\n"); - print (pp_argss (!argss) ^ " alist: "); - print (pp_ints alist ^ "\n"); *) - unify_formals lvar (alist,!formals); - formals := trim_args (alist,!formals); - List.app (fn args => args := (trim_args (alist,!args))) (!argss); - List.app (fn rargs => rargs := (trim_args (alist,!rargs))) (!rargss)) - - fun one_group (fs : (lvar*rng)list) : unit = - let - fun process (with_alists) : ((lvar * rng) * int list) list = - let - val E = map (fn ((lv,{formals,...}),al) => - (map (fn (p,_) => p) (!formals), al)) - with_alists - val alists = map (fn ((lv,{rargss,...}),al) => - List.foldl (fn (rargs,al) => - collapse_alist (rargs_alist E (!rargs)) al) - al (!rargss)) - with_alists - in if map #2 with_alists = alists then with_alists - else (* compute new `with_alists' based on assumptions - * and result, and reprocess. *) - let - val with_alists = - ListPair.map (fn ((f,al),al') => - (f,collapse_alist al al')) - (with_alists,alists) - in process with_alists - end - end - val with_alists_init = map (fn r as (_, {formals,argss,...}) => - (r,alist_before_rec (formals,argss))) fs - val with_alists = process with_alists_init - in List.app onef with_alists - end - - fun loop n = - (touched:=false; - List.app one_group fss; - if !touched then loop (n+1) - else n) - val n = (touch_count := 0; loop 1) - in - print ("Argument contractions: " ^ Int.toString (!touch_count) ^ " - " - ^ Int.toString n ^ " rounds.\n") - end + let + fun alist_before_rec (formals,argss) = + let val alist1 = init_alist (!formals) + val alist2 = List.foldl (fn (args,al) => + collapse_alist (args_alist (!args)) al) + alist1 (!argss) + in alist2 + end + + fun onef ((lvar,{formals,rargss,argss}), alist) = + ((* print ("FUNCTION " ^ Lvar.pr_lvar lvar ^ ":\n "); + print (pp_formals (!formals) ^ "\n recursive apps:\n"); + print (pp_argss (!rargss) ^ " apps:\n"); + print (pp_argss (!argss) ^ " alist: "); + print (pp_ints alist ^ "\n"); *) + unify_formals lvar (alist,!formals); + formals := trim_args (alist,!formals); + List.app (fn args => args := (trim_args (alist,!args))) (!argss); + List.app (fn rargs => rargs := (trim_args (alist,!rargs))) (!rargss)) + + fun one_group (fs : (lvar*rng)list) : unit = + let + fun process (with_alists) : ((lvar * rng) * int list) list = + let + val E = map (fn ((lv,{formals,...}),al) => + (map (fn (p,_) => p) (!formals), al)) + with_alists + val alists = map (fn ((lv,{rargss,...}),al) => + List.foldl (fn (rargs,al) => + collapse_alist (rargs_alist E (!rargs)) al) + al (!rargss)) + with_alists + in if map #2 with_alists = alists then with_alists + else (* compute new `with_alists' based on assumptions + * and result, and reprocess. *) + let + val with_alists = + ListPair.map (fn ((f,al),al') => + (f,collapse_alist al al')) + (with_alists,alists) + in process with_alists + end + end + val with_alists_init = map (fn r as (_, {formals,argss,...}) => + (r,alist_before_rec (formals,argss))) fs + val with_alists = process with_alists_init + in List.app onef with_alists + end + + fun loop n = + (touched:=false; + List.app one_group fss; + if !touched then loop (n+1) + else n) + val n = (touch_count := 0; loop 1) + in + print ("Argument contractions: " ^ Int.toString (!touch_count) ^ " - " + ^ Int.toString n ^ " rounds.\n") + end fun contract_args p : unit = - let val M : rng Lvar.Map.map ref = ref Lvar.Map.empty (* for quick lookup *) - val L : (lvar * rng) list list ref = ref nil (* lists of mutually recursive functions *) - val exported = exported_lvars p - fun is_exported lv = member lv exported - local - val fix_stack : lvar list ref = ref nil - in - fun push lv : unit = fix_stack := (lv :: (!fix_stack)) - fun pop() : unit = - case !fix_stack of - x::xs => fix_stack := xs - | _ => die "contract_args.pop" - fun is_rec lv = member lv (!fix_stack) - end - fun build e : app_cont = - case e of - VAR {lvar,fix_bound=true,rhos_actuals,...} => - (case Lvar.Map.lookup (!M) lvar of - SOME {argss,rargss,...} => - if is_rec lvar then - (rargss := (rhos_actuals :: (!rargss)); APP_BREAK) - else - (argss := (rhos_actuals :: (!argss)); APP_BREAK) - | NONE => APP_BREAK) - | FIX {functions,scope,...} => - let val funs : (lvar * rng) list = - List.foldl (fn ({lvar,rhos_formals,...},acc) => - if is_exported lvar then acc - else let val rng = {formals=rhos_formals, - argss=ref nil, rargss=ref nil} - in M := Lvar.Map.add(lvar,rng,!M); - (lvar,rng)::acc - end) - nil functions - in - L := funs :: !L; (* for processing *) - List.app (fn {lvar,bind,...} => push lvar) functions; - List.app (fn {bind,...} => appt build bind) functions; - List.app (fn _ => pop ()) functions; - appt build scope; - APP_BREAK - end - | _ => APP_CONT - in app build p; - contract_args' (!L) - end + let val M : rng Lvar.Map.map ref = ref Lvar.Map.empty (* for quick lookup *) + val L : (lvar * rng) list list ref = ref nil (* lists of mutually recursive functions *) + val exported = exported_lvars p + fun is_exported lv = member lv exported + local + val fix_stack : lvar list ref = ref nil + in + fun push lv : unit = fix_stack := (lv :: (!fix_stack)) + fun pop() : unit = + case !fix_stack of + x::xs => fix_stack := xs + | _ => die "contract_args.pop" + fun is_rec lv = member lv (!fix_stack) + end + fun build e : app_cont = + case e of + VAR {lvar,fix_bound=true,rhos_actuals,...} => + (case Lvar.Map.lookup (!M) lvar of + SOME {argss,rargss,...} => + if is_rec lvar then + (rargss := (rhos_actuals :: (!rargss)); APP_BREAK) + else + (argss := (rhos_actuals :: (!argss)); APP_BREAK) + | NONE => APP_BREAK) + | FIX {functions,scope,...} => + let val funs : (lvar * rng) list = + List.foldl (fn ({lvar,rhos_formals,...},acc) => + if is_exported lvar then acc + else let val rng = {formals=rhos_formals, + argss=ref nil, rargss=ref nil} + in M := Lvar.Map.add(lvar,rng,!M); + (lvar,rng)::acc + end) + nil functions + in + L := funs :: !L; (* for processing *) + List.app (fn {lvar,bind,...} => push lvar) functions; + List.app (fn {bind,...} => appt build bind) functions; + List.app (fn _ => pop ()) functions; + appt build scope; + APP_BREAK + end + | _ => APP_CONT + in app build p; + contract_args' (!L) + end (* Region specialization; tranform @@ -1020,168 +1029,168 @@ struct *) type srng = {R:place list list, formals:(place*mul) list ref, - rargss: place list ref list ref, argss:place list ref list ref} + rargss: place list ref list ref, argss:place list ref list ref} fun inR (p,nil) = false - | inR (p,l::ls) = inR'(p,l) orelse inR (p,ls) + | inR (p,l::ls) = inR'(p,l) orelse inR (p,ls) and inR' (p,nil) = false - | inR' (p,x::xs) = Eff.eq_effect(p,x) orelse inR' (p,xs) + | inR' (p,x::xs) = Eff.eq_effect(p,x) orelse inR' (p,xs) fun drop (nil, nil) = nil - | drop (true::ds, x::xs) = drop(ds,xs) - | drop (false::ds, x::xs) = x :: drop(ds,xs) - | drop _ = die "drop" + | drop (true::ds, x::xs) = drop(ds,xs) + | drop (false::ds, x::xs) = x :: drop(ds,xs) + | drop _ = die "drop" val touched = ref false val counter = ref 0 fun touch () = (touched := true; - counter:= (!counter + 1)) + counter:= (!counter + 1)) fun same_arg n xss = - let fun loop nil = NONE - | loop (xs::xss) = - let val r = List.nth (!xs,n) - in case loop xss of - res as SOME r' => if Eff.eq_effect(r,r') then res - else NONE - | NONE => SOME r - end - in loop xss - end handle _ => die "same_arg" + let fun loop nil = NONE + | loop (xs::xss) = + let val r = List.nth (!xs,n) + in case loop xss of + res as SOME r' => if Eff.eq_effect(r,r') then res + else NONE + | NONE => SOME r + end + in loop xss + end handle _ => die "same_arg" fun invariant n p xss = - let fun loop nil = true - | loop (xs::xss) = (Eff.eq_effect(List.nth (!xs,n),p) - andalso invariant n p xss) - in loop xss - end handle _ => die "invariant" + let fun loop nil = true + | loop (xs::xss) = (Eff.eq_effect(List.nth (!xs,n),p) + andalso invariant n p xss) + in loop xss + end handle _ => die "invariant" fun spec (fss : (lvar * srng) list list) = - let - fun one_f (lv,{R,formals,rargss,argss}) = - let - (* - val _ = print ("FUNCTION " ^ Lvar.pr_lvar lv ^ "\n") - val _ = print ("R = " ^ String.concat (map pp_places R) ^ "\n") - val _ = print (" formals: " ^ pp_formals (!formals) ^ "\n") - val _ = print (" argss: " ^ pp_argss (!argss)) - val _ = print (" rargss: " ^ pp_argss (!rargss)) - *) - fun go (n,nil) : bool list = nil (* true=drop*) - | go (n,(f as (p,_))::fs) = - (case same_arg n (!argss) of - SOME r => - if inR (r, R) andalso invariant n p (!rargss) - then (Eff.unifyRho_no_lowering (p,r); - touch(); - true::go(n+1,fs)) - else false::go(n+1,fs) - | NONE => false::go(n+1,fs)) - val ds = go (0,!formals) - in formals := drop(ds,!formals) - ; List.app (fn rargs => rargs := drop(ds,!rargs)) (!rargss) - ; List.app (fn args => args := drop(ds,!args)) (!argss) - end - fun loop n = - (touched := false; - List.app (List.app one_f) fss; - if !touched then loop (n+1) - else n) - val n = (counter := 0; loop 1) - in - print ("Region specialization: " ^ Int.toString (!counter) ^ " - " - ^ Int.toString n ^ " rounds.\n") - end + let + fun one_f (lv,{R,formals,rargss,argss}) = + let + (* + val _ = print ("FUNCTION " ^ Lvar.pr_lvar lv ^ "\n") + val _ = print ("R = " ^ String.concat (map pp_places R) ^ "\n") + val _ = print (" formals: " ^ pp_formals (!formals) ^ "\n") + val _ = print (" argss: " ^ pp_argss (!argss)) + val _ = print (" rargss: " ^ pp_argss (!rargss)) + *) + fun go (n,nil) : bool list = nil (* true=drop*) + | go (n,(f as (p,_))::fs) = + (case same_arg n (!argss) of + SOME r => + if inR (r, R) andalso invariant n p (!rargss) + then (Eff.unifyRho_no_lowering (p,r); + touch(); + true::go(n+1,fs)) + else false::go(n+1,fs) + | NONE => false::go(n+1,fs)) + val ds = go (0,!formals) + in formals := drop(ds,!formals) + ; List.app (fn rargs => rargs := drop(ds,!rargs)) (!rargss) + ; List.app (fn args => args := drop(ds,!args)) (!argss) + end + fun loop n = + (touched := false; + List.app (List.app one_f) fss; + if !touched then loop (n+1) + else n) + val n = (counter := 0; loop 1) + in + print ("Region specialization: " ^ Int.toString (!counter) ^ " - " + ^ Int.toString n ^ " rounds.\n") + end fun specialize p : unit = - let val M : srng Lvar.Map.map ref = ref Lvar.Map.empty (* for quick lookup *) - val L : (lvar * srng) list list ref = ref nil (* lists of mutually recursive functions *) - val exported = exported_lvars p - fun is_exported lv = member lv exported - local - val fix_stack : lvar list ref = ref nil - val reg_stack : place list list ref = ref - [[Eff.toplevel_region_withtype_top, - Eff.toplevel_region_withtype_string, - Eff.toplevel_region_withtype_pair, - Eff.toplevel_region_withtype_array, - Eff.toplevel_region_withtype_ref, - Eff.toplevel_region_withtype_triple]] - in - fun push_lv lv : unit = fix_stack := (lv :: (!fix_stack)) - fun pop_lv() : unit = - case !fix_stack of - x::xs => fix_stack := xs - | _ => die "specialize.pop_lv" - fun is_rec_lv lv = member lv (!fix_stack) - fun push_regs regs = reg_stack := (regs :: (!reg_stack)) - fun pop_regs () : unit = - case !reg_stack of - x::xs => reg_stack := xs - | _ => die "specialize.pop_regs" - fun get_reg_stack () = !reg_stack - end - fun build e : app_cont = - case e of - VAR {lvar,fix_bound=true,rhos_actuals,...} => - (case Lvar.Map.lookup (!M) lvar of - SOME {argss,rargss,...} => - if is_rec_lv lvar then - (rargss := (rhos_actuals :: (!rargss)); APP_BREAK) - else - (argss := (rhos_actuals :: (!argss)); APP_BREAK) - | NONE => APP_BREAK) - | FIX {functions,scope,...} => - let val funs : (lvar * srng) list = - List.foldl (fn ({lvar,rhos_formals,...},acc) => - if is_exported lvar then acc - else let val srng = {R=get_reg_stack(), - formals=rhos_formals, - argss=ref nil, rargss=ref nil} - in M := Lvar.Map.add(lvar,srng,!M); - (lvar,srng)::acc - end) - nil functions - in - L := funs :: !L; (* for processing *) - List.app (fn {lvar,bind,rhos_formals,...} => - (push_lv lvar; push_regs (map #1 (!rhos_formals)))) functions; - List.app (fn {bind,...} => appt build bind) functions; - List.app (fn _ => (pop_lv (); pop_regs())) functions; - appt build scope; - APP_BREAK - end - | LETREGION{B,rhos,body} => - (push_regs (map #1 (!rhos)); - appt build body; - pop_regs(); - APP_BREAK) - | _ => APP_CONT - in app build p; - spec (!L) - end + let val M : srng Lvar.Map.map ref = ref Lvar.Map.empty (* for quick lookup *) + val L : (lvar * srng) list list ref = ref nil (* lists of mutually recursive functions *) + val exported = exported_lvars p + fun is_exported lv = member lv exported + local + val fix_stack : lvar list ref = ref nil + val reg_stack : place list list ref = ref + [[Eff.toplevel_region_withtype_top, + Eff.toplevel_region_withtype_string, + Eff.toplevel_region_withtype_pair, + Eff.toplevel_region_withtype_array, + Eff.toplevel_region_withtype_ref, + Eff.toplevel_region_withtype_triple]] + in + fun push_lv lv : unit = fix_stack := (lv :: (!fix_stack)) + fun pop_lv() : unit = + case !fix_stack of + x::xs => fix_stack := xs + | _ => die "specialize.pop_lv" + fun is_rec_lv lv = member lv (!fix_stack) + fun push_regs regs = reg_stack := (regs :: (!reg_stack)) + fun pop_regs () : unit = + case !reg_stack of + x::xs => reg_stack := xs + | _ => die "specialize.pop_regs" + fun get_reg_stack () = !reg_stack + end + fun build e : app_cont = + case e of + VAR {lvar,fix_bound=true,rhos_actuals,...} => + (case Lvar.Map.lookup (!M) lvar of + SOME {argss,rargss,...} => + if is_rec_lv lvar then + (rargss := (rhos_actuals :: (!rargss)); APP_BREAK) + else + (argss := (rhos_actuals :: (!argss)); APP_BREAK) + | NONE => APP_BREAK) + | FIX {functions,scope,...} => + let val funs : (lvar * srng) list = + List.foldl (fn ({lvar,rhos_formals,...},acc) => + if is_exported lvar then acc + else let val srng = {R=get_reg_stack(), + formals=rhos_formals, + argss=ref nil, rargss=ref nil} + in M := Lvar.Map.add(lvar,srng,!M); + (lvar,srng)::acc + end) + nil functions + in + L := funs :: !L; (* for processing *) + List.app (fn {lvar,bind,rhos_formals,...} => + (push_lv lvar; push_regs (map #1 (!rhos_formals)))) functions; + List.app (fn {bind,...} => appt build bind) functions; + List.app (fn _ => (pop_lv (); pop_regs())) functions; + appt build scope; + APP_BREAK + end + | LETREGION{B,rhos,body} => + (push_regs (map #1 (!rhos)); + appt build body; + pop_regs(); + APP_BREAK) + | _ => APP_CONT + in app build p; + spec (!L) + end val _ = Flags.add_bool_entry - {long="contract_regions", short=SOME"cr", item=ref false, - menu=["Control", "Regions", "contract regions"], neg=false, - desc= - "When this option is enabled, identically typed\n\ - \regions bound by the same letregion construct\n\ - \are unified. Moreover, region parameters to\n\ - \non-exported functions are trimmed whenever\n\ - \possible."} + {long="contract_regions", short=SOME"cr", item=ref false, + menu=["Control", "Regions", "contract regions"], neg=false, + desc= + "When this option is enabled, identically typed\n\ + \regions bound by the same letregion construct\n\ + \are unified. Moreover, region parameters to\n\ + \non-exported functions are trimmed whenever\n\ + \possible."} val contract_p = Flags.is_on0 "contract_regions" fun contract p = - if contract_p() then - (contract_letregions p; - contract_args p; - specialize p; - contract_args p) - else () + if contract_p() then + (contract_letregions p; + contract_args p; + specialize p; + contract_args p) + else () end -end; +end diff --git a/src/Compiler/Regions/PHYS_SIZE_INF.sml b/src/Compiler/Regions/PHYS_SIZE_INF.sml index 55d3aede3..70cdae7b2 100644 --- a/src/Compiler/Regions/PHYS_SIZE_INF.sml +++ b/src/Compiler/Regions/PHYS_SIZE_INF.sml @@ -1,13 +1,13 @@ (* Physical Size Inference *) -signature PHYS_SIZE_INF = +signature PHYS_SIZE_INF = sig type ('a,'b,'c)LambdaPgm - and place + and place and 'a at - and mul - type pp = int - type lvar + and mul + type pp = int + type lvar datatype phsize = INF | WORDS of int @@ -15,17 +15,17 @@ signature PHYS_SIZE_INF = val empty : env val init : env val plus : env * env -> env - val enrich : env * env -> bool - val restrict : env * lvar list -> env + val enrich : env * env -> bool + val restrict : env * lvar list -> env val psi: (unit -> pp) * env * (place at, place*mul, unit)LambdaPgm -> (*************************) - ((place*pp)at, place*phsize, unit)LambdaPgm * env (* In the resulting trip *) - (* free variables has *) - (* been inserted. *) + ((place*pp)at, place*phsize, unit)LambdaPgm * env (* In the resulting trip *) + (* free variables has *) + (* been inserted. *) (*************************) (* appConvert(pgm) rewrites pgm, categorizing every function call in pgm as one of the following - + * tail call to fix-bound function (jmp) * non-tail call to fix-bound function (funcall) * tail call to function which is not fix-bound (fnjmp) @@ -35,11 +35,10 @@ signature PHYS_SIZE_INF = val appConvert : ((place*pp) at, place*phsize, unit)LambdaPgm -> ((place*pp) at, place*phsize, unit)LambdaPgm - type StringTree + type StringTree val layout_env : env -> StringTree val layout_pgm : ((place*pp)at, place*phsize, unit)LambdaPgm -> StringTree - val pu_env : env Pickle.pu - val pu_phsize : phsize Pickle.pu - end - + val pu_env : env Pickle.pu + val pu_phsize : phsize Pickle.pu + end diff --git a/src/Compiler/Regions/PhysSizeInf.sml b/src/Compiler/Regions/PhysSizeInf.sml index 11a721efb..35f0850dc 100644 --- a/src/Compiler/Regions/PhysSizeInf.sml +++ b/src/Compiler/Regions/PhysSizeInf.sml @@ -35,11 +35,10 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun place_atplace (atp: place at) : place option = let open AtInf - in case atp - of ATTOP p => SOME p - | ATBOT p => SOME p - | SAT p => SOME p - | IGNORE => NONE + in case atp of + ATTOP p => SOME p + | ATBOT p => SOME p + | SAT p => SOME p end (* --------------------------------------------------- @@ -52,67 +51,74 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun layout_lvar lv = PP.LEAF (Lvars.pr_lvar lv) fun layout_excon excon = PP.LEAF (Excon.pr_excon excon) fun layout_fvs (s,(lvars, excons, places)) = - PP.NODE{start=s ^ " {",finish=" }",indent=1,childsep=PP.RIGHT ", ", - children=(map layout_lvar lvars) @ (map layout_excon excons) @ (map E.layout_effect places)} + PP.NODE{start=s ^ " {",finish=" }",indent=1,childsep=PP.RIGHT ", ", + children=(map layout_lvar lvars) @ (map layout_excon excons) @ (map E.layout_effect places)} fun layout_fvs' (lv, ref (SOME (lvars, excons, places))) = - PP.NODE{start=Lvars.pr_lvar lv ^ " -> [",finish="]",indent=1,childsep=PP.RIGHT ",", - children=(map layout_lvar lvars) @ (map layout_excon excons) @ (map E.layout_effect places)} - | layout_fvs' (lv,_) = PP.LEAF(Lvars.pr_lvar lv ^ " -> <>") + PP.NODE{start=Lvars.pr_lvar lv ^ " -> [",finish="]",indent=1,childsep=PP.RIGHT ",", + children=(map layout_lvar lvars) @ (map layout_excon excons) @ (map E.layout_effect places)} + | layout_fvs' (lv,_) = PP.LEAF(Lvars.pr_lvar lv ^ " -> <>") val pr_fvs = pr_st o layout_fvs' val log_fvs' = log_st o layout_fvs' local (* buckets *) - val lvar_bucket = ref ([]:lvar list) - val excon_bucket = ref ([]:excon list) - val place_bucket = ref ([]:place list) - - fun gen_marker(bucket, get_ref) = - let fun is_marked var = !(get_ref var) - fun mark var = get_ref var := true - fun unmark var = get_ref var := false - fun add var = if is_marked var then () - else (bucket := (var :: !bucket); mark var) - in (mark, unmark, add) - end + val lvar_bucket = ref ([]:lvar list) + val excon_bucket = ref ([]:excon list) + val place_bucket = ref ([]:place list) + + fun gen_marker(bucket, get_ref) = + let fun is_marked var = !(get_ref var) + fun mark var = get_ref var := true + fun unmark var = get_ref var := false + fun add var = if is_marked var then () + else (bucket := (var :: !bucket); mark var) + in (mark, unmark, add) + end in (* local buckets *) - val (mark_place, unmark_place, add_place) = gen_marker(place_bucket, E.get_visited) - - val (mark_lvar, unmark_lvar, add_lvar) = gen_marker(lvar_bucket, Lvars.is_free) - - fun add_excon (excon:excon) : unit = - if List.exists (fn excon' => Excon.eq(excon,excon')) (!excon_bucket) then () - else excon_bucket := excon :: (!excon_bucket) - - fun add_atp atp = case place_atplace atp - of SOME p => add_place p - | NONE => () - fun mark_atp atp = case place_atplace atp - of SOME p => mark_place p - | NONE => () - fun unmark_atp atp = case place_atplace atp - of SOME p => unmark_place p - | NONE => () - - fun kill_excon (excon:excon) : unit = - let fun kill [] = [] - | kill (excon'::excons) = if Excon.eq(excon',excon) then excons - else excon'::kill excons - in excon_bucket := kill (!excon_bucket) - end - - fun reset_fvs () = (List.app unmark_lvar (!lvar_bucket); - List.app unmark_place (!place_bucket); - lvar_bucket := []; - excon_bucket := []; - place_bucket := []) - fun get_fvs () = - let val lvs = List.filter Lvars.get_ubf64 (!lvar_bucket) + val (mark_place, unmark_place, add_place) = gen_marker(place_bucket, E.get_visited) + + val (mark_lvar, unmark_lvar, add_lvar) = gen_marker(lvar_bucket, Lvars.is_free) + + fun add_excon (excon:excon) : unit = + if List.exists (fn excon' => Excon.eq(excon,excon')) (!excon_bucket) then () + else excon_bucket := excon :: (!excon_bucket) + + fun add_atp atp = + case place_atplace atp of + SOME p => add_place p + | NONE => () + fun add_atp_opt atp = + case atp of + SOME atp => add_atp atp + | NONE => () + fun mark_atp atp = + case place_atplace atp of + SOME p => mark_place p + | NONE => () + fun unmark_atp atp = + case place_atplace atp of + SOME p => unmark_place p + | NONE => () + + fun kill_excon (excon:excon) : unit = + let fun kill [] = [] + | kill (excon'::excons) = if Excon.eq(excon',excon) then excons + else excon'::kill excons + in excon_bucket := kill (!excon_bucket) + end + + fun reset_fvs () = (List.app unmark_lvar (!lvar_bucket); + List.app unmark_place (!place_bucket); + lvar_bucket := []; + excon_bucket := []; + place_bucket := []) + fun get_fvs () = + let val lvs = List.filter Lvars.get_ubf64 (!lvar_bucket) @ List.filter (not o Lvars.get_ubf64) (!lvar_bucket) val fvs = (lvs, !excon_bucket, !place_bucket) - in reset_fvs (); fvs - end + in reset_fvs (); fvs + end end (*local buckets*) @@ -122,87 +128,86 @@ structure PhysSizeInf: PHYS_SIZE_INF = * ------------------------------------------------------ *) fun fv (TR(e,_,_,_): (place at,place*mul,unit)trip) : unit = - let fun fv_sw (SWITCH(tr,choices,opt)) = (fv tr; List.app (fv o #2) choices; - case opt of SOME tr => fv tr | NONE => ()) - in case e - of VAR{lvar,rhos_actuals=ref actuals,...} => - (add_lvar lvar; List.app add_atp actuals) - | INTEGER(n,t,alloc) => add_atp alloc - | WORD(n,t,alloc) => add_atp alloc - | STRING(s,alloc) => add_atp alloc - | REAL(s,alloc) => add_atp alloc - | F64(s,alloc) => add_atp alloc - | UB_RECORD trips => List.app fv trips - | FN{pat,body,free,alloc} => - (case free - of ref (SOME (lvars,excons,places)) => - (List.app add_lvar lvars; - List.app add_excon excons; - List.app add_place places; - add_atp alloc) - | _ => die "fv.FN.free vars not available.") - | LETREGION{B,rhos=ref rhos,body} => - (List.app (fn (place,mul) => mark_place place) rhos; - fv body; - List.app (fn (place,mul) => unmark_place place) rhos) - | LET{k_let,pat,bind,scope} => - (fv bind; - List.app (mark_lvar o #1) pat; - fv scope; - List.app (unmark_lvar o #1) pat) - | FIX{free,shared_clos,functions,scope} => - (case free - of ref (SOME (lvars,excons,places)) => - (List.app add_lvar lvars; - List.app add_excon excons; - List.app add_place places; - add_atp shared_clos; - List.app (mark_lvar o #lvar) functions; - fv scope; - List.app (unmark_lvar o #lvar) functions) - | _ => die "fv.FIX.free vars not available.") - | APP(_,_,tr1,tr2) => (fv tr1; fv tr2) - | EXCEPTION(excon,b,tp,alloc,scope) => - (fv scope; add_atp alloc; - kill_excon excon) - | RAISE tr => fv tr - | HANDLE(tr1,tr2) => (fv tr1; fv tr2) - | SWITCH_I {switch, precision} => fv_sw switch - | SWITCH_W {switch, precision} => fv_sw switch - | SWITCH_S sw => fv_sw sw - | SWITCH_C sw => fv_sw sw - | SWITCH_E sw => let val SWITCH(_,choices,_) = sw - in List.app (add_excon o #1) choices; - fv_sw sw - end - | CON0 {con, il, aux_regions, alloc} => (List.app add_atp aux_regions; - add_atp alloc) - | CON1 ({con, il, alloc}, tr) => (add_atp alloc; fv tr) - | DECON ({con, il}, tr) => fv tr - | EXCON (excon, opt) => (case opt - of SOME (alloc,tr) => (add_excon excon; add_atp alloc; fv tr) - | NONE => add_excon excon) - | DEEXCON (excon,tr) => (add_excon excon; fv tr) - | RECORD (alloc, trs) => (add_atp alloc; List.app fv trs) - | SELECT (i, tr) => fv tr - | DEREF tr => fv tr - | REF (alloc,tr) => (add_atp alloc; fv tr) - | ASSIGN (alloc,tr1,tr2) => (add_atp alloc; fv tr1; fv tr2) - | DROP tr => fv tr - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc}, tr1,tr2) => (add_atp alloc; fv tr1; fv tr2) - | CCALL ({rhos_for_result, ...}, trs) => (List.app (add_atp o #1) rhos_for_result; - List.app fv trs) - | BLOCKF64 (alloc, trs) => (add_atp alloc; List.app fv trs) - | SCRATCHMEM (n,alloc) => add_atp alloc - | EXPORT (_,tr) => fv tr - | RESET_REGIONS ({force, alloc,regions_for_resetting}, tr) => - (add_atp alloc; - List.app add_atp regions_for_resetting; - fv tr) - | FRAME{declared_lvars, declared_excons} => - (List.app (add_lvar o #lvar) declared_lvars; - List.app (add_excon o #1) declared_excons) - end + let fun fv_sw (SWITCH(tr,choices,opt)) = (fv tr; List.app (fv o #2) choices; + case opt of SOME tr => fv tr | NONE => ()) + in case e + of VAR{lvar,rhos_actuals=ref actuals,...} => + (add_lvar lvar; List.app add_atp actuals) + | INTEGER(n,t,alloc) => add_atp_opt alloc + | WORD(n,t,alloc) => add_atp_opt alloc + | STRING(s,alloc) => add_atp alloc + | REAL(s,alloc) => add_atp alloc + | F64 s => () + | UB_RECORD trips => List.app fv trips + | FN{pat,body,free,alloc} => + (case free + of ref (SOME (lvars,excons,places)) => + (List.app add_lvar lvars; + List.app add_excon excons; + List.app add_place places; + add_atp alloc) + | _ => die "fv.FN.free vars not available.") + | LETREGION{B,rhos=ref rhos,body} => + (List.app (fn (place,mul) => mark_place place) rhos; + fv body; + List.app (fn (place,mul) => unmark_place place) rhos) + | LET{k_let,pat,bind,scope} => + (fv bind; + List.app (mark_lvar o #1) pat; + fv scope; + List.app (unmark_lvar o #1) pat) + | FIX{free,shared_clos,functions,scope} => + (case free + of ref (SOME (lvars,excons,places)) => + (List.app add_lvar lvars; + List.app add_excon excons; + List.app add_place places; + add_atp shared_clos; + List.app (mark_lvar o #lvar) functions; + fv scope; + List.app (unmark_lvar o #lvar) functions) + | _ => die "fv.FIX.free vars not available.") + | APP(_,_,tr1,tr2) => (fv tr1; fv tr2) + | EXCEPTION(excon,b,tp,alloc,scope) => + (fv scope; add_atp alloc; + kill_excon excon) + | RAISE tr => fv tr + | HANDLE(tr1,tr2) => (fv tr1; fv tr2) + | SWITCH_I {switch, precision} => fv_sw switch + | SWITCH_W {switch, precision} => fv_sw switch + | SWITCH_S sw => fv_sw sw + | SWITCH_C sw => fv_sw sw + | SWITCH_E sw => let val SWITCH(_,choices,_) = sw + in List.app (add_excon o #1) choices; + fv_sw sw + end + | CON0 {con, il, aux_regions, alloc} => (List.app add_atp aux_regions; + add_atp_opt alloc) + | CON1 ({con, il, alloc}, tr) => (add_atp_opt alloc; fv tr) + | DECON ({con, il}, tr) => fv tr + | EXCON (excon, opt) => (case opt + of SOME (alloc,tr) => (add_excon excon; add_atp alloc; fv tr) + | NONE => add_excon excon) + | DEEXCON (excon,tr) => (add_excon excon; fv tr) + | RECORD (alloc, trs) => (add_atp_opt alloc; List.app fv trs) + | SELECT (i, tr) => fv tr + | DEREF tr => fv tr + | REF (alloc,tr) => (add_atp alloc; fv tr) + | ASSIGN (tr1,tr2) => (fv tr1; fv tr2) + | DROP tr => fv tr + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => (fv tr1; fv tr2) + | CCALL ({rhos_for_result, ...}, trs) => (List.app (add_atp o #1) rhos_for_result; + List.app fv trs) + | BLOCKF64 (alloc, trs) => (add_atp alloc; List.app fv trs) + | SCRATCHMEM (n,alloc) => add_atp alloc + | EXPORT (_,tr) => fv tr + | RESET_REGIONS ({force, regions_for_resetting,...}, tr) => + (List.app add_atp regions_for_resetting; + fv tr) + | FRAME{declared_lvars, declared_excons} => + (List.app (add_lvar o #lvar) declared_lvars; + List.app (add_excon o #1) declared_excons) + end (* ---------------------------------------------------------- @@ -214,102 +219,102 @@ structure PhysSizeInf: PHYS_SIZE_INF = | getOpt NONE =[] fun ifv (TR(e,_,_,_): (place at,place*mul,unit)trip) : unit = - let fun ifv_sw (SWITCH(tr,choices,opt)) = (ifv tr; List.app (ifv o #2) choices; - case opt of SOME tr => ifv tr | NONE => ()) - in case e - of VAR _ => () - | INTEGER _ => () - | WORD _ => () - | STRING _ => () - | REAL _ => () - | F64 _ => () - | UB_RECORD trips => List.app ifv trips - | FN{pat,body,free,alloc} => (ifv body; - List.app (mark_lvar o #1) pat; - fv body; - free := (SOME (get_fvs())); - List.app (unmark_lvar o #1) pat) - | LETREGION{B,rhos,body} => ifv body - | LET{k_let,pat,bind,scope} => (ifv bind; ifv scope) - | FIX{free,shared_clos,functions,scope} => - let fun ifv_under_bind (TR(FN{body,...},_,_,_)) = ifv body - | ifv_under_bind _ = die "FIX.bind not fn." - - fun ifv_bind (TR(FN{free,pat,body,alloc(*same as shared_clos*)}, _, _, _)) = - (List.app (mark_lvar o #1) pat; - fv body; - free := (SOME (get_fvs())); - List.app (unmark_lvar o #1) pat) - | ifv_bind _ = die "FIX.bind not fn(2)." - fun fv_bind (TR(FN{free,pat,body,alloc(*same as shared_clos*)}, _, _, _)) = - (case free - of ref (SOME (lvars,excons,places)) => - (List.app add_lvar lvars; - List.app add_excon excons; - List.app add_place places) (* Region containing shared closure, alloc, is not free in letrec bound FN *) - | _ => die "FIX.fv_bind free vars not available.") - | fv_bind tr = die "FIX.fv_bind not fn." - in ifv scope; - List.app (ifv_under_bind o #bind) functions; - List.app (mark_lvar o #lvar) functions; - List.app ((List.app (mark_place o #1)) o ! o #rhos_formals) functions; - List.app ((List.app (mark_place o #1)) o getOpt o #bound_but_never_written_into) functions; - (*mark_atp shared_clos; commented out, 23/4/97, mads *) - List.app (ifv_bind o #bind) functions; - List.app (fv_bind o #bind) functions; (* use fv_bind instead of fv 14/06-2000, Niels *) - free := (SOME (get_fvs())); - (*unmark_atp shared_clos; commented out, 23/4/97, mads *) - List.app ((List.app (unmark_place o #1)) o getOpt o #bound_but_never_written_into) functions; - List.app ((List.app (unmark_place o #1)) o ! o #rhos_formals) functions; - List.app (unmark_lvar o #lvar) functions + let fun ifv_sw (SWITCH(tr,choices,opt)) = (ifv tr; List.app (ifv o #2) choices; + case opt of SOME tr => ifv tr | NONE => ()) + in case e + of VAR _ => () + | INTEGER _ => () + | WORD _ => () + | STRING _ => () + | REAL _ => () + | F64 _ => () + | UB_RECORD trips => List.app ifv trips + | FN{pat,body,free,alloc} => (ifv body; + List.app (mark_lvar o #1) pat; + fv body; + free := (SOME (get_fvs())); + List.app (unmark_lvar o #1) pat) + | LETREGION{B,rhos,body} => ifv body + | LET{k_let,pat,bind,scope} => (ifv bind; ifv scope) + | FIX{free,shared_clos,functions,scope} => + let fun ifv_under_bind (TR(FN{body,...},_,_,_)) = ifv body + | ifv_under_bind _ = die "FIX.bind not fn." + + fun ifv_bind (TR(FN{free,pat,body,alloc(*same as shared_clos*)}, _, _, _)) = + (List.app (mark_lvar o #1) pat; + fv body; + free := (SOME (get_fvs())); + List.app (unmark_lvar o #1) pat) + | ifv_bind _ = die "FIX.bind not fn(2)." + fun fv_bind (TR(FN{free,pat,body,alloc(*same as shared_clos*)}, _, _, _)) = + (case free + of ref (SOME (lvars,excons,places)) => + (List.app add_lvar lvars; + List.app add_excon excons; + List.app add_place places) (* Region containing shared closure, alloc, is not free in letrec bound FN *) + | _ => die "FIX.fv_bind free vars not available.") + | fv_bind tr = die "FIX.fv_bind not fn." + in ifv scope; + List.app (ifv_under_bind o #bind) functions; + List.app (mark_lvar o #lvar) functions; + List.app ((List.app (mark_place o #1)) o ! o #rhos_formals) functions; + List.app ((List.app (mark_place o #1)) o getOpt o #bound_but_never_written_into) functions; + (*mark_atp shared_clos; commented out, 23/4/97, mads *) + List.app (ifv_bind o #bind) functions; + List.app (fv_bind o #bind) functions; (* use fv_bind instead of fv 14/06-2000, Niels *) + free := (SOME (get_fvs())); + (*unmark_atp shared_clos; commented out, 23/4/97, mads *) + List.app ((List.app (unmark_place o #1)) o getOpt o #bound_but_never_written_into) functions; + List.app ((List.app (unmark_place o #1)) o ! o #rhos_formals) functions; + List.app (unmark_lvar o #lvar) functions (* - ;case functions - of [{lvar,...}] => pr_fvs (lvar, free) - | _ => () + ;case functions + of [{lvar,...}] => pr_fvs (lvar, free) + | _ => () *) - end - | APP(_,_,tr1,tr2) => (ifv tr1; ifv tr2) - | EXCEPTION(excon,b,tp,alloc,scope) => ifv scope - | RAISE tr => ifv tr - | HANDLE(tr1,tr2) => (ifv tr1; ifv tr2) - | SWITCH_I {switch,precision} => ifv_sw switch - | SWITCH_W {switch,precision} => ifv_sw switch - | SWITCH_S sw => ifv_sw sw - | SWITCH_C sw => ifv_sw sw - | SWITCH_E sw => ifv_sw sw - | CON0 {con, il, aux_regions, alloc} => () - | CON1 ({con, il, alloc}, tr) => ifv tr - | DECON ({con, il}, tr) => ifv tr - | EXCON (excon, opt) => (case opt - of SOME (alloc,tr) => ifv tr - | NONE => ()) - | DEEXCON (excon,tr) => ifv tr - | RECORD (alloc, trs) => List.app ifv trs - | SELECT (i, tr) => ifv tr - | DEREF tr => ifv tr - | REF (alloc,tr) => ifv tr - | ASSIGN (alloc,tr1,tr2) => (ifv tr1; ifv tr2) - | DROP (tr) => ifv tr - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc}, tr1,tr2) => (ifv tr1; ifv tr2) - | CCALL (_, trs) => List.app ifv trs - | BLOCKF64 (alloc, trs) => List.app ifv trs - | SCRATCHMEM (n,alloc) => () - | EXPORT (_, tr) => ifv tr - | RESET_REGIONS ({force, alloc,regions_for_resetting}, tr) => ifv tr - | FRAME{declared_lvars, declared_excons} => () - end + end + | APP(_,_,tr1,tr2) => (ifv tr1; ifv tr2) + | EXCEPTION(excon,b,tp,alloc,scope) => ifv scope + | RAISE tr => ifv tr + | HANDLE(tr1,tr2) => (ifv tr1; ifv tr2) + | SWITCH_I {switch,precision} => ifv_sw switch + | SWITCH_W {switch,precision} => ifv_sw switch + | SWITCH_S sw => ifv_sw sw + | SWITCH_C sw => ifv_sw sw + | SWITCH_E sw => ifv_sw sw + | CON0 {con, il, aux_regions, alloc} => () + | CON1 ({con, il, alloc}, tr) => ifv tr + | DECON ({con, il}, tr) => ifv tr + | EXCON (excon, opt) => (case opt + of SOME (alloc,tr) => ifv tr + | NONE => ()) + | DEEXCON (excon,tr) => ifv tr + | RECORD (alloc, trs) => List.app ifv trs + | SELECT (i, tr) => ifv tr + | DEREF tr => ifv tr + | REF (alloc,tr) => ifv tr + | ASSIGN (tr1,tr2) => (ifv tr1; ifv tr2) + | DROP (tr) => ifv tr + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => (ifv tr1; ifv tr2) + | CCALL (_, trs) => List.app ifv trs + | BLOCKF64 (alloc, trs) => List.app ifv trs + | SCRATCHMEM (n,alloc) => () + | EXPORT (_, tr) => ifv tr + | RESET_REGIONS ({force, regions_for_resetting,...}, tr) => ifv tr + | FRAME{declared_lvars, declared_excons} => () + end in (*local*) val reset_fvs : unit -> unit = reset_fvs fun insert_free_vars (tr, import_vars, export_vars) = - (ifv tr; - import_vars := - SOME let val (_, _, export_rhos) = export_vars - val _ = List.app mark_place export_rhos - val imp_vars = (fv(tr); get_fvs()) - val _ = List.app unmark_place export_rhos - in imp_vars - end) + (ifv tr; + import_vars := + SOME let val (_, _, export_rhos) = export_vars + val _ = List.app mark_place export_rhos + val imp_vars = (fv(tr); get_fvs()) + val _ = List.app unmark_place export_rhos + in imp_vars + end) end (*local*) @@ -367,19 +372,19 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun enrich(env1,env2) = LvarMap.Fold(fn ((lv2,res2),b) => b andalso - case LvarMap.lookup env1 lv2 - of SOME res1 => equal_res(res1,res2) - | NONE => false) true env2 + case LvarMap.lookup env1 lv2 + of SOME res1 => equal_res(res1,res2) + | NONE => false) true env2 fun restrict(env,lvars) = foldl(fn (lv, acc) => - case LvarMap.lookup env lv - of SOME res => add_env(lv,res,acc) - | NONE => die "restrict") empty lvars + case LvarMap.lookup env lv + of SOME res => add_env(lv,res,acc) + | NONE => die "restrict") empty lvars type StringTree = PP.StringTree fun layout_list (p : 'a -> StringTree,first,sep,last) (l: 'a list) : StringTree = PP.NODE{start=first,finish=last,indent=1,childsep=PP.RIGHT sep, - children=map p l} + children=map p l} fun layout_range (FORMAL_REGVARS places) = layout_list (E.layout_effect, "[", ",", "]") places | layout_range (FORMAL_SIZES phsizes) = layout_list (layout_phsize, "[", ",", "]") phsizes | layout_range NOTFIXBOUND = PP.LEAF "NOTFIXBOUND" @@ -407,19 +412,19 @@ structure PhysSizeInf: PHYS_SIZE_INF = end fun eval_psi_graph () : unit = let - (* val _ = log "eval_psi_graph" *) - fun max_list [] = die "eval_psi_graph" - | max_list (i::is) = List.foldl (fn (i,b)=>phsize_max i b) i is - val layout_info = layout_phsize o ! - - val sccs = DiGraph.scc layout_info (!psi_graph) - val compressed_sccs = - map (DiGraph.union_graph - (fn (i1,i2) => (i2 := phsize_max (!i1) (!i2); i2))) - sccs + (* val _ = log "eval_psi_graph" *) + fun max_list [] = die "eval_psi_graph" + | max_list (i::is) = List.foldl (fn (i,b)=>phsize_max i b) i is + val layout_info = layout_phsize o ! + + val sccs = DiGraph.scc layout_info (!psi_graph) + val compressed_sccs = + map (DiGraph.union_graph + (fn (i1,i2) => (i2 := phsize_max (!i1) (!i2); i2))) + sccs in - DiGraph.bottom_up_eval - (fn (i, is) => i := max_list (map (op !) (i::is))) (!psi_graph) + DiGraph.bottom_up_eval + (fn (i, is) => i := max_list (map (op !) (i::is))) (!psi_graph) end (* -------------------------------------------------------------------------------- @@ -439,29 +444,29 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun psi_add_place_size (place,size') = case psi_lookup place - of SOME n => - (case DiGraph.find_info n - of (r as ref size) => r := phsize_max size size') - | NONE => () + of SOME n => + (case DiGraph.find_info n + of (r as ref size) => r := phsize_max size size') + | NONE => () fun psi_add_edge (actual_regvar,formal_regvar) = case (psi_lookup actual_regvar, psi_lookup formal_regvar) - of (SOME n1, SOME n2) => (* both regvars have mul 1 *) - if DiGraph.eq_nodes(n1,n2) then () - else DiGraph.mk_edge(n1,n2) - (* the actual must have physical size greater than or equal to - * physical size of the formal *) - | (NONE, SOME n2) => () (* actual mul infinite, formal mul 1 *) - | (NONE, NONE) => () (* both regvars have mul infinite *) - | (SOME n1, NONE) => () (* formal mul infinite, actual mul finite. This - * is ok. Applying a curried function, for instance, - * to one argument, may not cause any allocation. - * Multiplicity inference figures this out.. *) + of (SOME n1, SOME n2) => (* both regvars have mul 1 *) + if DiGraph.eq_nodes(n1,n2) then () + else DiGraph.mk_edge(n1,n2) + (* the actual must have physical size greater than or equal to + * physical size of the formal *) + | (NONE, SOME n2) => () (* actual mul infinite, formal mul 1 *) + | (NONE, NONE) => () (* both regvars have mul infinite *) + | (SOME n1, NONE) => () (* formal mul infinite, actual mul finite. This + * is ok. Applying a curried function, for instance, + * to one argument, may not cause any allocation. + * Multiplicity inference figures this out.. *) fun phsize_place place : phsize = case psi_lookup place - of SOME n => !(DiGraph.find_info n) - | NONE => INF + of SOME n => !(DiGraph.find_info n) + | NONE => INF (* ------------------------------------------------------------ @@ -472,8 +477,8 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun convert_env env = let fun ch_entry (FORMAL_REGVARS places) = FORMAL_SIZES (map phsize_place places) - | ch_entry (FORMAL_SIZES sizes) = FORMAL_SIZES sizes - | ch_entry NOTFIXBOUND = NOTFIXBOUND + | ch_entry (FORMAL_SIZES sizes) = FORMAL_SIZES sizes + | ch_entry NOTFIXBOUND = NOTFIXBOUND in LvarMap.composemap ch_entry env end @@ -489,155 +494,162 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun psi_tr env (TR(e,_,_,_) : (place at, place*mul,unit)trip) = case e - of VAR{lvar,fix_bound=false,rhos_actuals=ref [],...} => () - | VAR _ => die "psi_tr.variables not fully applied as assumed." - | INTEGER _ => () - | WORD _ => () - | STRING _ => () (* immediate strings are allocated statically.. *) - | REAL _ => () (* immediate reals are allocated statically.. *) - | F64 _ => () - | UB_RECORD trips => List.app (psi_tr env) trips - | FN{pat,body,free=ref (SOME fvs),alloc} => - (case place_atplace alloc - of SOME place => (psi_add_place_size (place,closure_size fvs); - psi_tr env body) - | NONE => die "psi_tr.FN") - | FN _ => die "psi_tr.FN.free vars not available." - | LETREGION{B,rhos=ref rhos,body} => - (List.app (fn (place,Mul.INF) => () - | (place,Mul.NUM n) => if n = 1 orelse n = 0 then psi_declare place - else die "psi_tr.LETREGION.mul not in {0,1}") - rhos; psi_tr env body) - | LET{k_let,pat,bind,scope} => - let val env' = List.foldl(fn (pat,acc) => - add_env(#1 pat,NOTFIXBOUND,acc)) env pat - in psi_tr env bind; psi_tr env' scope - end + of VAR{lvar,fix_bound=false,rhos_actuals=ref [],...} => () + | VAR _ => die "psi_tr.variables not fully applied as assumed." + | INTEGER _ => () + | WORD _ => () + | STRING _ => () (* immediate strings are allocated statically.. *) + | REAL _ => () (* immediate reals are allocated statically.. *) + | F64 _ => () + | UB_RECORD trips => List.app (psi_tr env) trips + | FN{pat,body,free=ref (SOME fvs),alloc} => + (case place_atplace alloc + of SOME place => (psi_add_place_size (place,closure_size fvs); + psi_tr env body) + | NONE => die "psi_tr.FN") + | FN _ => die "psi_tr.FN.free vars not available." + | LETREGION{B,rhos=ref rhos,body} => + (List.app (fn (place,Mul.INF) => () + | (place,Mul.NUM n) => if n = 1 orelse n = 0 then psi_declare place + else die "psi_tr.LETREGION.mul not in {0,1}") + rhos; psi_tr env body) + | LET{k_let,pat,bind,scope} => + let val env' = List.foldl(fn (pat,acc) => + add_env(#1 pat,NOTFIXBOUND,acc)) env pat + in psi_tr env bind; psi_tr env' scope + end | FIX{free=ref (SOME fvs),shared_clos,functions,scope} => - let val env' = List.foldl - (fn ({lvar,rhos_formals,...},env) => - let val formals = map (fn (place,mul) => - (case mul - of Mul.NUM 0 => psi_declare place - | Mul.NUM 1 => psi_declare place - | Mul.NUM _ => die "psi_tr.FIX" - | Mul.INF => (); place)) - (!rhos_formals) - in add_env (lvar,FORMAL_REGVARS formals, env) - end) - env functions - in - case place_atplace shared_clos - of SOME place => (let val sz = fix_closure_size fvs - in psi_add_place_size (place,sz); - map (fn {bind=TR(FN{body,...},_,_,_),...} => psi_tr env' body - | _ => die "psi_tr.FIX.FN expected") functions; - psi_tr env' scope end) - | NONE => die "psi_tr.FIX" - end - | FIX _ => die "psi_tr.free vars not available." - | APP(_,_,tr1 as TR(VAR{lvar,fix_bound,rhos_actuals=ref atps,...},_,_,_), tr2) => - let val actuals = map (fn atp => case place_atplace atp - of SOME place => place - | NONE => die "APP.actual atp is IGNORE.") atps - in case lookup_env env lvar - (* If lvar is bound in the program we add edges - * between formals and actuals, otherwise we add - * necessary sizes to the actuals. *) - of SOME (FORMAL_REGVARS formals) => - (List.app psi_add_edge (BasisCompat.ListPair.zipEq(actuals,formals)) - handle BasisCompat.ListPair.UnequalLengths => - die "psi_tr.APP.region_polymorphic_application: actuals differs from formals.") - | SOME (FORMAL_SIZES sizes) => - (List.app psi_add_place_size (BasisCompat.ListPair.zipEq (actuals, sizes)) - handle BasisCompat.ListPair.UnequalLengths => - die "psi_tr.APP.region_polymorphic_application.actuals differs from sizes.") - | _ => (); - psi_tr env tr2 - end - | APP(_,_,tr1,tr2) => (psi_tr env tr1; psi_tr env tr2) - | EXCEPTION(excon,b,mu,atp,tr) => - let val place = case place_atplace atp - of SOME place => place - | NONE => die "psi_tr.EXCEPTION." - in - if b then (* nullary exception *) - psi_add_place_size (place,size_nullery_exn()) (* was words 2 2001-01-18, Niels *) - else (* unary exception *) - psi_add_place_size (place,size_exname()); (* was words 2 2001-01-18, Niels *) - psi_tr env tr - end - | RAISE tr => psi_tr env tr - | HANDLE(tr1,tr2) => (psi_tr env tr1; psi_tr env tr2) - | SWITCH_I {switch,precision} => psi_sw (psi_tr env) switch - | SWITCH_W {switch,precision} => psi_sw (psi_tr env) switch - | SWITCH_S sw => psi_sw (psi_tr env) sw - | SWITCH_C sw => psi_sw (psi_tr env) sw - | SWITCH_E sw => psi_sw (psi_tr env) sw - | CON0 {con, il, aux_regions, alloc} => (case place_atplace alloc - of SOME place => psi_add_place_size(place,size_con0()) (* was 1 2001-01-18, Niels *) - | NONE => () (* unboxed_con *)) - | CON1 ({con, il, alloc}, tr) => (case place_atplace alloc - of SOME place => psi_add_place_size(place,size_con1()) (* was 2 2001-01-18, Niels *) - | NONE => (); psi_tr env tr) - | DECON ({con, il}, tr) => psi_tr env tr - | EXCON (excon, opt) => (case opt - of SOME (alloc,tr) => - (case place_atplace alloc - of SOME place => (psi_add_place_size (place,size_excon1()); psi_tr env tr) (* was 2 2001-01-18, Niels*) - | NONE => die "psi_tr.EXCON") - | NONE => ()) - | DEEXCON (excon,tr) => psi_tr env tr - | RECORD (alloc, trs) => + let val env' = List.foldl + (fn ({lvar,rhos_formals,...},env) => + let val formals = map (fn (place,mul) => + (case mul + of Mul.NUM 0 => psi_declare place + | Mul.NUM 1 => psi_declare place + | Mul.NUM _ => die "psi_tr.FIX" + | Mul.INF => (); place)) + (!rhos_formals) + in add_env (lvar,FORMAL_REGVARS formals, env) + end) + env functions + in + case place_atplace shared_clos + of SOME place => (let val sz = fix_closure_size fvs + in psi_add_place_size (place,sz); + map (fn {bind=TR(FN{body,...},_,_,_),...} => psi_tr env' body + | _ => die "psi_tr.FIX.FN expected") functions; + psi_tr env' scope end) + | NONE => die "psi_tr.FIX" + end + | FIX _ => die "psi_tr.free vars not available." + | APP(_,_,tr1 as TR(VAR{lvar,fix_bound,rhos_actuals=ref atps,...},_,_,_), tr2) => + let val actuals = map (fn atp => case place_atplace atp + of SOME place => place + | NONE => die "APP.actual atp is IGNORE.") atps + in case lookup_env env lvar + (* If lvar is bound in the program we add edges + * between formals and actuals, otherwise we add + * necessary sizes to the actuals. *) + of SOME (FORMAL_REGVARS formals) => + (List.app psi_add_edge (BasisCompat.ListPair.zipEq(actuals,formals)) + handle BasisCompat.ListPair.UnequalLengths => + die "psi_tr.APP.region_polymorphic_application: actuals differs from formals.") + | SOME (FORMAL_SIZES sizes) => + (List.app psi_add_place_size (BasisCompat.ListPair.zipEq (actuals, sizes)) + handle BasisCompat.ListPair.UnequalLengths => + die "psi_tr.APP.region_polymorphic_application.actuals differs from sizes.") + | _ => (); + psi_tr env tr2 + end + | APP(_,_,tr1,tr2) => (psi_tr env tr1; psi_tr env tr2) + | EXCEPTION(excon,b,mu,atp,tr) => + let val place = case place_atplace atp + of SOME place => place + | NONE => die "psi_tr.EXCEPTION." + in + if b then (* nullary exception *) + psi_add_place_size (place,size_nullery_exn()) (* was words 2 2001-01-18, Niels *) + else (* unary exception *) + psi_add_place_size (place,size_exname()); (* was words 2 2001-01-18, Niels *) + psi_tr env tr + end + | RAISE tr => psi_tr env tr + | HANDLE(tr1,tr2) => (psi_tr env tr1; psi_tr env tr2) + | SWITCH_I {switch,precision} => psi_sw (psi_tr env) switch + | SWITCH_W {switch,precision} => psi_sw (psi_tr env) switch + | SWITCH_S sw => psi_sw (psi_tr env) sw + | SWITCH_C sw => psi_sw (psi_tr env) sw + | SWITCH_E sw => psi_sw (psi_tr env) sw + | CON0 {con, il, aux_regions, alloc} => + (case alloc of + NONE => () + | SOME alloc => + case place_atplace alloc of + SOME place => psi_add_place_size(place,size_con0()) (* was 1 2001-01-18, Niels *) + | NONE => () (* unboxed_con *)) + | CON1 ({con, il, alloc}, tr) => + ((case alloc of + NONE => () + | SOME alloc => + case place_atplace alloc of + SOME place => psi_add_place_size(place,size_con1()) (* was 2 2001-01-18, Niels *) + | NONE => ()) + ; psi_tr env tr) + | DECON ({con, il}, tr) => psi_tr env tr + | EXCON (excon, opt) => (case opt + of SOME (alloc,tr) => + (case place_atplace alloc + of SOME place => (psi_add_place_size (place,size_excon1()); psi_tr env tr) (* was 2 2001-01-18, Niels*) + | NONE => die "psi_tr.EXCON") + | NONE => ()) + | DEEXCON (excon,tr) => psi_tr env tr + | RECORD (NONE, []) => () + | RECORD (NONE, _) => die "psi_tr.RECORD: expecting zero args" + | RECORD (SOME alloc, trs) => (case (place_atplace alloc, trs) - of (NONE, []) => () (* unit *) - | (SOME place, _) => psi_add_place_size(place, size_of_record trs) - | _ => die "psi_tr.RECORD"; List.app (psi_tr env) trs) - | SELECT (i, tr) => psi_tr env tr - | DEREF tr => psi_tr env tr - | REF (alloc,tr) => (case place_atplace alloc - of SOME place => psi_add_place_size(place,size_of_ref()) - | NONE => die "psi_tr.REF"; psi_tr env tr) - | ASSIGN (alloc,tr1,tr2) => (case place_atplace alloc - of SOME _ => die "psi_tr.ASSIGN" - | NONE => (psi_tr env tr1; psi_tr env tr2)) - | DROP tr => psi_tr env tr - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc}, tr1,tr2) => - (case place_atplace alloc - of SOME _ => die "psi_tr.EQUAL" - | NONE => (psi_tr env tr1; psi_tr env tr2)) - | CCALL ({name, rhos_for_result, ...}, trs) => - (List.app (fn (atp, i_opt) => - (case noSome (place_atplace atp) "psi_tr (CCALL ...): IGNORE" of rho => - (case i_opt of - NONE => () - (*rho has logical size infinity, so it will automagically - get physical size infinity: nothing need be done*) - | SOME 0 => () - (*the region contains an unboxed type*) - | SOME i => psi_add_place_size (rho, WORDS i)))) - rhos_for_result ; - List.app (psi_tr env) trs) - | BLOCKF64 (alloc, trs) => + of (NONE, []) => () (* unit *) + | (SOME place, _) => psi_add_place_size(place, size_of_record trs) + | _ => die "psi_tr.RECORD"; List.app (psi_tr env) trs) + | SELECT (i, tr) => psi_tr env tr + | DEREF tr => psi_tr env tr + | REF (alloc,tr) => (case place_atplace alloc + of SOME place => psi_add_place_size(place,size_of_ref()) + | NONE => die "psi_tr.REF"; psi_tr env tr) + | ASSIGN (tr1,tr2) => (psi_tr env tr1; psi_tr env tr2) + | DROP tr => psi_tr env tr + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => + (psi_tr env tr1; psi_tr env tr2) + | CCALL ({name, rhos_for_result, ...}, trs) => + (List.app (fn (atp, i_opt) => + (case noSome (place_atplace atp) "psi_tr (CCALL ...): IGNORE" of rho => + (case i_opt of + NONE => () + (*rho has logical size infinity, so it will automagically + get physical size infinity: nothing need be done*) + | SOME 0 => () + (*the region contains an unboxed type*) + | SOME i => psi_add_place_size (rho, WORDS i)))) + rhos_for_result ; + List.app (psi_tr env) trs) + | BLOCKF64 (alloc, trs) => (case (place_atplace alloc, trs) - of (NONE, []) => () (* unit *) - | (SOME place, _) => psi_add_place_size(place, size_of_blockf64 trs) - | _ => die "psi_tr.BLOCKF64"; List.app (psi_tr env) trs) - | SCRATCHMEM (n,alloc) => + of (NONE, []) => () (* unit *) + | (SOME place, _) => psi_add_place_size(place, size_of_blockf64 trs) + | _ => die "psi_tr.BLOCKF64"; List.app (psi_tr env) trs) + | SCRATCHMEM (n,alloc) => (case (n, place_atplace alloc) - of (0,NONE) => () (* unit *) - | (_,SOME place) => psi_add_place_size(place, WORDS(1+(n+8-1)div 8)) (* n=3b => w(n)=1+10 div 8= 1w; n=9b => w(n)=1+16 div 8=3w *) - | _ => die "psi_tr.SCRATCHMEM") - | EXPORT(_,tr) => psi_tr env tr - | RESET_REGIONS ({force, alloc,regions_for_resetting}, tr) => psi_tr env tr - | FRAME{declared_lvars, ...} => - let val env' = List.foldr (fn ({lvar,...},frame_env) => - case lookup_env env lvar - of SOME res => add_env (lvar, res, frame_env) - | NONE => die "psi_tr.FRAME.lv not in env") - empty declared_lvars - in frame_env := env' - end + of (0,NONE) => () (* unit *) + | (_,SOME place) => psi_add_place_size(place, WORDS(1+(n+8-1)div 8)) (* n=3b => w(n)=1+10 div 8= 1w; n=9b => w(n)=1+16 div 8=3w *) + | _ => die "psi_tr.SCRATCHMEM") + | EXPORT(_,tr) => psi_tr env tr + | RESET_REGIONS ({force, regions_for_resetting, ...}, tr) => psi_tr env tr + | FRAME{declared_lvars, ...} => + let val env' = List.foldr (fn ({lvar,...},frame_env) => + case lookup_env env lvar + of SOME res => add_env (lvar, res, frame_env) + | NONE => die "psi_tr.FRAME.lv not in env") + empty declared_lvars + in frame_env := env' + end (* -------------------------------------------------------------------- @@ -650,93 +662,91 @@ structure PhysSizeInf: PHYS_SIZE_INF = type pp = int val dummypp = ~1 local open AtInf - in fun pp_dummy IGNORE = IGNORE - | pp_dummy (ATTOP a) = ATTOP (a, dummypp) - | pp_dummy (ATBOT a) = ATBOT (a, dummypp) - | pp_dummy (SAT a) = SAT (a, dummypp) + in fun pp_dummy (ATTOP a) = ATTOP (a, dummypp) + | pp_dummy (ATBOT a) = ATBOT (a, dummypp) + | pp_dummy (SAT a) = SAT (a, dummypp) end fun ips (pp_c : unit -> pp) (TR(e,mt,ateffs,mulef)) = let local open AtInf - in fun gen_pp f IGNORE = IGNORE - | gen_pp f (ATTOP a) = ATTOP (a, f()) - | gen_pp f (ATBOT a) = ATBOT (a, f()) - | gen_pp f (SAT a) = SAT (a, f()) - end - val pp = gen_pp pp_c - val ips = ips pp_c - fun ips_sw (SWITCH(tr,sel,opt)) = - SWITCH(ips tr,map (fn (a,tr) => (a,ips tr)) sel, - case opt of SOME tr => SOME (ips tr) | NONE => NONE) - fun bind_transform (place, mul) = (place, phsize_place place) - val e' = - case e - of VAR {lvar,il,plain_arreffs,fix_bound,rhos_actuals,other} => - VAR {lvar=lvar,il=il,plain_arreffs=plain_arreffs,fix_bound=fix_bound, - rhos_actuals=ref (map pp (!rhos_actuals)),other=other} - | INTEGER (a,t,p) => INTEGER (a,t,pp p) - | WORD (a,t,p) => WORD (a,t,pp p) - | STRING (a,p) => STRING (a,pp p) - | REAL (a,p) => REAL (a,pp p) - | F64 (a,p) => F64 (a,pp p) - | UB_RECORD trs => UB_RECORD (map ips trs) - | FN {pat,body,free,alloc} => FN {pat=pat,body=ips body,free=free,alloc=pp alloc} - | LET {k_let,pat,bind,scope} => LET {k_let=k_let,pat=pat,bind=ips bind,scope=ips scope} - | FIX{free,shared_clos,functions,scope} => - let fun ips_f {lvar,occ,tyvars,rhos,epss,Type,rhos_formals,bound_but_never_written_into,other,bind} = - let val rhos_formals' = map bind_transform (!rhos_formals) + in fun gen_pp f (ATTOP a) = ATTOP (a, f()) + | gen_pp f (ATBOT a) = ATBOT (a, f()) + | gen_pp f (SAT a) = SAT (a, f()) + end + val pp = gen_pp pp_c + val ips = ips pp_c + fun ips_sw (SWITCH(tr,sel,opt)) = + SWITCH(ips tr,map (fn (a,tr) => (a,ips tr)) sel, + case opt of SOME tr => SOME (ips tr) | NONE => NONE) + fun bind_transform (place, mul) = (place, phsize_place place) + val e' = + case e + of VAR {lvar,il,plain_arreffs,fix_bound,rhos_actuals,other} => + VAR {lvar=lvar,il=il,plain_arreffs=plain_arreffs,fix_bound=fix_bound, + rhos_actuals=ref (map pp (!rhos_actuals)),other=other} + | INTEGER (a,t,p) => INTEGER (a,t,Option.map pp p) + | WORD (a,t,p) => WORD (a,t,Option.map pp p) + | STRING (a,p) => STRING (a,pp p) + | REAL (a,p) => REAL (a,pp p) + | F64 a => F64 a + | UB_RECORD trs => UB_RECORD (map ips trs) + | FN {pat,body,free,alloc} => FN {pat=pat,body=ips body,free=free,alloc=pp alloc} + | LET {k_let,pat,bind,scope} => LET {k_let=k_let,pat=pat,bind=ips bind,scope=ips scope} + | FIX{free,shared_clos,functions,scope} => + let fun ips_f {lvar,occ,tyvars,rhos,epss,Type,rhos_formals,bound_but_never_written_into,other,bind} = + let val rhos_formals' = map bind_transform (!rhos_formals) val bound_but_never_written_into' = case bound_but_never_written_into of SOME l => SOME(map bind_transform l) | NONE => NONE - in {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, - rhos_formals=ref rhos_formals', + in {lvar=lvar,occ=occ,tyvars=tyvars,rhos=rhos,epss=epss,Type=Type, + rhos_formals=ref rhos_formals', bound_but_never_written_into = bound_but_never_written_into', other=other,bind=ips bind} - end - in FIX{free=free,shared_clos=pp shared_clos,functions=map ips_f functions,scope=ips scope} - end - | APP(ck,sr,tr1,tr2) => APP(ck,sr,ips tr1, ips tr2) - | EXCEPTION(excon,b,mu,atp,tr) => EXCEPTION(excon,b,mu,pp atp,ips tr) - | RAISE tr => RAISE(ips tr) - | HANDLE(tr1,tr2) => HANDLE(ips tr1, ips tr2) - | SWITCH_I {switch,precision} => SWITCH_I {switch=ips_sw switch, precision=precision} - | SWITCH_W {switch,precision} => SWITCH_W {switch=ips_sw switch, precision=precision} - | SWITCH_S sw => SWITCH_S(ips_sw sw) - | SWITCH_C sw => SWITCH_C(ips_sw sw) - | SWITCH_E sw => SWITCH_E(ips_sw sw) - | LETREGION{B,rhos,body} => LETREGION{B=B,rhos=ref (map bind_transform (!rhos)), - body=ips body} - | CON0 {con, il, aux_regions, alloc} => CON0 {con=con, il=il, aux_regions=map pp_dummy aux_regions, alloc=pp alloc} - | CON1 ({con, il, alloc}, tr) => CON1 ({con=con, il=il, alloc=pp alloc}, ips tr) - | DECON ({con, il}, tr) => DECON ({con=con, il=il}, ips tr) - | EXCON (excon, opt) => EXCON(excon, case opt - of SOME (alloc,tr) => SOME (pp alloc, ips tr) - | NONE => NONE) - | DEEXCON (excon,tr) => DEEXCON (excon,ips tr) - | RECORD (alloc, trs) => RECORD (pp alloc, map ips trs) - | SELECT (i, tr) => SELECT (i, ips tr) - | DEREF tr => DEREF (ips tr) - | REF (alloc,tr) => REF (pp alloc,ips tr) - | ASSIGN (alloc,tr1,tr2) => ASSIGN (pp alloc,ips tr1,ips tr2) - | DROP (tr) => DROP (ips tr) - | EQUAL ({mu_of_arg1, mu_of_arg2, alloc}, tr1,tr2) => - EQUAL ({mu_of_arg1=mu_of_arg1, mu_of_arg2=mu_of_arg2, alloc=pp alloc}, ips tr1, ips tr2) - | CCALL ({name, mu_result, rhos_for_result}, trs) => - let val p_point = pp_c() - in CCALL ({name = name, - mu_result = mu_result, - rhos_for_result = - map (fn (atp, i_opt) => - (gen_pp (fn () => p_point) atp, i_opt)) - rhos_for_result}, - map ips trs) - end - | BLOCKF64 (alloc, trs) => BLOCKF64 (pp alloc, map ips trs) - | SCRATCHMEM (n,alloc) => SCRATCHMEM (n,pp alloc) - | EXPORT (i,tr) => EXPORT (i,ips tr) - | RESET_REGIONS ({force, alloc,regions_for_resetting}, tr) => - RESET_REGIONS ({force=force, alloc=pp alloc, + end + in FIX{free=free,shared_clos=pp shared_clos,functions=map ips_f functions,scope=ips scope} + end + | APP(ck,sr,tr1,tr2) => APP(ck,sr,ips tr1, ips tr2) + | EXCEPTION(excon,b,mu,atp,tr) => EXCEPTION(excon,b,mu,pp atp,ips tr) + | RAISE tr => RAISE(ips tr) + | HANDLE(tr1,tr2) => HANDLE(ips tr1, ips tr2) + | SWITCH_I {switch,precision} => SWITCH_I {switch=ips_sw switch, precision=precision} + | SWITCH_W {switch,precision} => SWITCH_W {switch=ips_sw switch, precision=precision} + | SWITCH_S sw => SWITCH_S(ips_sw sw) + | SWITCH_C sw => SWITCH_C(ips_sw sw) + | SWITCH_E sw => SWITCH_E(ips_sw sw) + | LETREGION{B,rhos,body} => LETREGION{B=B,rhos=ref (map bind_transform (!rhos)), + body=ips body} + | CON0 {con, il, aux_regions, alloc} => CON0 {con=con, il=il, aux_regions=map pp_dummy aux_regions, alloc=Option.map pp alloc} + | CON1 ({con, il, alloc}, tr) => CON1 ({con=con, il=il, alloc=Option.map pp alloc}, ips tr) + | DECON ({con, il}, tr) => DECON ({con=con, il=il}, ips tr) + | EXCON (excon, opt) => EXCON(excon, case opt + of SOME (alloc,tr) => SOME (pp alloc, ips tr) + | NONE => NONE) + | DEEXCON (excon,tr) => DEEXCON (excon,ips tr) + | RECORD (alloc, trs) => RECORD (Option.map pp alloc, map ips trs) + | SELECT (i, tr) => SELECT (i, ips tr) + | DEREF tr => DEREF (ips tr) + | REF (alloc,tr) => REF (pp alloc,ips tr) + | ASSIGN (tr1,tr2) => ASSIGN (ips tr1,ips tr2) + | DROP (tr) => DROP (ips tr) + | EQUAL ({mu_of_arg1, mu_of_arg2}, tr1,tr2) => + EQUAL ({mu_of_arg1=mu_of_arg1, mu_of_arg2=mu_of_arg2}, ips tr1, ips tr2) + | CCALL ({name, mu_result, rhos_for_result}, trs) => + let val p_point = pp_c() + in CCALL ({name = name, + mu_result = mu_result, + rhos_for_result = + map (fn (atp, i_opt) => + (gen_pp (fn () => p_point) atp, i_opt)) + rhos_for_result}, + map ips trs) + end + | BLOCKF64 (alloc, trs) => BLOCKF64 (pp alloc, map ips trs) + | SCRATCHMEM (n,alloc) => SCRATCHMEM (n,pp alloc) + | EXPORT (i,tr) => EXPORT (i,ips tr) + | RESET_REGIONS ({force, regions_for_resetting, liveset}, tr) => + RESET_REGIONS ({force=force, liveset=NONE, regions_for_resetting = map pp regions_for_resetting}, ips tr) - | FRAME a => FRAME a + | FRAME a => FRAME a in TR(e',mt,ateffs,mulef) end @@ -756,33 +766,33 @@ structure PhysSizeInf: PHYS_SIZE_INF = * -------------------------------------------------------------- *) fun psi (pp_counter : unit -> pp, env : env, - PGM{expression=tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi} : (place at, place*mul,unit)LambdaPgm) + PGM{expression=tr, + export_datbinds, + import_vars, + export_vars, + export_basis, + export_Psi} : (place at, place*mul,unit)LambdaPgm) : ((place*pp)at,place*phsize,unit)LambdaPgm * env = let - val _ = reset() (* reset free_vars-buckets, graph - * and the internal environment *) + val _ = reset() (* reset free_vars-buckets, graph + * and the internal environment *) - val _ = insert_free_vars (tr, import_vars, export_vars) (* Insert free variables *) - val _ = psi_tr env tr (* Build graph *) - val _ = eval_psi_graph() (* Evaluate graph *) - val tr1 = ips pp_counter tr (* Transform trip *) + val _ = insert_free_vars (tr, import_vars, export_vars) (* Insert free variables *) + val _ = psi_tr env tr (* Build graph *) + val _ = eval_psi_graph() (* Evaluate graph *) + val tr1 = ips pp_counter tr (* Transform trip *) - val env1 = convert_env (!frame_env) (* Compute resulting environment mapping - * exported lvars into minimal physical - * sizes of actual region variables. *) - val _ = reset() + val env1 = convert_env (!frame_env) (* Compute resulting environment mapping + * exported lvars into minimal physical + * sizes of actual region variables. *) + val _ = reset() in (PGM{expression=tr1, - export_datbinds=export_datbinds, - import_vars=import_vars, - export_vars=export_vars, - export_basis=export_basis, - export_Psi=export_Psi}, env1) + export_datbinds=export_datbinds, + import_vars=import_vars, + export_vars=export_vars, + export_basis=export_basis, + export_Psi=export_Psi}, env1) end @@ -798,7 +808,6 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun get_rho(AtInf.ATTOP(rho,_)) = rho | get_rho(AtInf.ATBOT(rho,_)) = rho | get_rho(AtInf.SAT(rho,_)) = rho - | get_rho(AtInf.IGNORE) = raise GetRho fun actual_regions_match_formal_regions([],[]) = true | actual_regions_match_formal_regions(l as ((formal_rho,mul)::forms), rho_act::acts): bool = @@ -829,13 +838,13 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun layout_effectpp (effect, ~1) = E.layout_effect effect | layout_effectpp (effect, pp) = if !print_all_program_points then - PP.HNODE{start="",finish="",childsep=PP.RIGHT " ", - children=[E.layout_effect effect, PP.LEAF ("pp"^Int.toString pp)]} + PP.HNODE{start="",finish="",childsep=PP.RIGHT " ", + children=[E.layout_effect effect, PP.LEAF ("pp"^Int.toString pp)]} else E.layout_effect effect fun layout_placeXphsize (place,phsize) = - PP.HNODE{start="",finish="",childsep=PP.RIGHT ":", - children=[E.layout_effect place,layout_phsize phsize]} + PP.HNODE{start="",finish="",childsep=PP.RIGHT ":", + children=[E.layout_effect place,layout_phsize phsize]} fun layout_unit () = NONE val layout_trip = layoutLambdaTrip (AtInf.layout_at layout_effectpp) (AtInf.layout_at layout_effectpp) (SOME o layout_placeXphsize) layout_unit @@ -843,60 +852,27 @@ structure PhysSizeInf: PHYS_SIZE_INF = fun layout_pgm(PGM{expression,...}) = layout_trip expression val pu_phsize = - let fun toInt INF = 0 - | toInt (WORDS _) = 1 - val fun_INF = Pickle.con0 INF - fun fun_WORDS _ = Pickle.con1 WORDS (fn WORDS a => a | _ => die "pu_phsize") Pickle.int - in Pickle.dataGen("PhysSizeInf.phsize",toInt,[fun_INF, fun_WORDS]) - end + let fun toInt INF = 0 + | toInt (WORDS _) = 1 + val fun_INF = Pickle.con0 INF + fun fun_WORDS _ = Pickle.con1 WORDS (fn WORDS a => a | _ => die "pu_phsize") Pickle.int + in Pickle.dataGen("PhysSizeInf.phsize",toInt,[fun_INF, fun_WORDS]) + end val pu_range_env = - let fun toInt (FORMAL_REGVARS _) = 0 - | toInt (FORMAL_SIZES _) = 1 - | toInt NOTFIXBOUND = 2 - fun fun_FORMAL_REGVARS _ = - Pickle.con1 FORMAL_REGVARS (fn FORMAL_REGVARS a => a | _ => die "pu_range_env.FORMAL_REGVARS") - Effect.pu_effects - fun fun_FORMAL_SIZES _ = - Pickle.con1 FORMAL_SIZES (fn FORMAL_SIZES a => a | _ => die "pu_range_env.FORMAL_SIZES") - (Pickle.listGen pu_phsize) - val fun_NOTFIXBOUND = Pickle.con0 NOTFIXBOUND - in Pickle.dataGen("PhysSizeInf.range_env",toInt,[fun_FORMAL_REGVARS, fun_FORMAL_SIZES, fun_NOTFIXBOUND]) - end + let fun toInt (FORMAL_REGVARS _) = 0 + | toInt (FORMAL_SIZES _) = 1 + | toInt NOTFIXBOUND = 2 + fun fun_FORMAL_REGVARS _ = + Pickle.con1 FORMAL_REGVARS (fn FORMAL_REGVARS a => a | _ => die "pu_range_env.FORMAL_REGVARS") + Effect.pu_effects + fun fun_FORMAL_SIZES _ = + Pickle.con1 FORMAL_SIZES (fn FORMAL_SIZES a => a | _ => die "pu_range_env.FORMAL_SIZES") + (Pickle.listGen pu_phsize) + val fun_NOTFIXBOUND = Pickle.con0 NOTFIXBOUND + in Pickle.dataGen("PhysSizeInf.range_env",toInt,[fun_FORMAL_REGVARS, fun_FORMAL_SIZES, fun_NOTFIXBOUND]) + end val pu_env = LvarMap.pu Lvars.pu pu_range_env -(* - fun layout_vars(lvars,excons,places) = - let val t1 = PP.HNODE{start = "lvars:", finish = "end of lvars;", - childsep = PP.RIGHT " ", children = map (PP.LEAF o Lvars.pr_lvar) lvars} - val t2 = PP.HNODE{start = "excons:", finish = "end of excons;", - childsep = PP.RIGHT " ", children = map (PP.LEAF o Excon.pr_excon) excons} - val t3 = PP.HNODE{start = "region variables:", finish = "end of region variables;", - childsep = PP.RIGHT " ", children = map Effect.layout_effect places} - in - PP.NODE{start = "variables begin", finish = "variables end", indent = 2, - childsep = PP.NOSEP, children = [t1,t2,t3]} - end - - fun layout_pgm (PGM{expression,import_vars,export_vars,...}) = (* belongs in MulExp, actually *) - let - val t1 = PP.NODE{start = "import_vars: ", finish = "end import vars", - childsep = PP.RIGHT " ", - indent = 2, children = - case import_vars of - ref(SOME iv)=> [layout_vars iv] - | _ => [PP.LEAF " (reference not set) "]} - val t2 = PP.NODE{start = "export_vars: ", finish = "end export vars", - childsep = PP.RIGHT " ", - indent = 2, children = [layout_vars export_vars]} - val t3 = layout_trip expression - in - PP.NODE{start = "Physical Size Program (a MulExp)", - finish = "end of Physical Size Program", - indent = 2, childsep = PP.NOSEP, - children = [t1,t2,t3]} - end -ME 1998-09-07*) - end diff --git a/src/Compiler/Regions/REGION_EXP.sml b/src/Compiler/Regions/REGION_EXP.sml index faaa00bc3..4e382c4aa 100644 --- a/src/Compiler/Regions/REGION_EXP.sml +++ b/src/Compiler/Regions/REGION_EXP.sml @@ -1,6 +1,5 @@ -signature REGION_EXP = - sig +signature REGION_EXP = sig (* Intermediate language used for region inference. The language * is typed and functions are allowed to accept and return @@ -9,7 +8,7 @@ signature REGION_EXP = * represented in registers. * * Value and exceptions constructors are supposed to be - * distinct. This must be ensured by the compiler. *) + * distinct, which must be ensured by the compiler frontend. *) type lvar type con @@ -19,22 +18,22 @@ signature REGION_EXP = eqtype tyvar - type Type and sigma and il and cone + type Type and mu and sigma and il and cone datatype constructorKind = CONSTANT | VALUE_CARRYING datatype datbinds = DATBINDS of (TyName * (con * constructorKind * sigma) list) list list datatype metaType = (* describes normal expressions: *) - Mus of (Type*place) list + Mus of mu list (* To allow the result of a declaration: *) | Frame of {declared_lvars: {lvar : lvar, compound : bool, create_region_record : bool, regvars : RegVar.regvar list, sigma: sigma ref, - place: place}list, - declared_excons: (excon* (Type*place)option) list} + place: place option} list, + declared_excons: (excon * mu option) list} | RaisedExnBind (* to be a raised Bind exception. *) @@ -49,18 +48,18 @@ signature REGION_EXP = and ('a,'b)trip = TR of ('a,'b)LambdaExp * metaType * effect and ('a,'b)LambdaExp = VAR of {lvar: lvar, il_r : (il * (il * cone -> il * cone)) ref, fix_bound: bool} - | INTEGER of IntInf.int * Type * 'a - | WORD of IntInf.int * Type * 'a + | INTEGER of IntInf.int * Type * 'a option (* NONE if unboxed *) + | WORD of IntInf.int * Type * 'a option (* NONE if unboxed *) | STRING of string * 'a | REAL of string * 'a - | F64 of string * 'a + | F64 of string | UB_RECORD of ('a,'b) trip list (* unboxed records *) - | FN of {pat : (lvar * (Type*place)) list, + | FN of {pat : (lvar * mu) list, body : ('a,'b)trip, alloc: 'a, free: (lvar list * excon list) option} (*region inference without dangling pointers*) | LETREGION_B of {B: effect list ref, discharged_phi: effect list ref, body: ('a,'b)trip} - | LET of {pat : (lvar * (tyvar*effect option) list * Type * place) list, + | LET of {pat : (lvar * (tyvar*effect option) list * Type * place option) list, (* memo: delete tyvar list *) bind : ('a,'b)trip, scope: ('a,'b)trip} | FIX of {shared_clos: 'a, @@ -74,8 +73,8 @@ signature REGION_EXP = bind : ('a,'b)trip} list, scope : ('a,'b)trip} | APP of ('a,'b)trip * ('a,'b)trip - | EXCEPTION of excon * bool * (Type*place) * 'a * ('a,'b)trip - (* Type*place: of exception constructor + | EXCEPTION of excon * bool * mu * 'a * ('a,'b)trip + (* mu: of exception constructor bool: true if exception is nullary *) | RAISE of ('a,'b)trip | HANDLE of ('a,'b)trip * ('a,'b)trip @@ -84,20 +83,20 @@ signature REGION_EXP = | SWITCH_S of ('a,'b,string) Switch | SWITCH_C of ('a,'b,con) Switch | SWITCH_E of ('a,'b,excon) Switch - | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a} - | CON1 of {con : con, il : il, alloc: 'a} * ('a,'b)trip + | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a option} (* NONE if unboxed *) + | CON1 of {con : con, il : il, alloc: 'a option} * ('a,'b)trip (* NONE if unboxed *) | DECON of {con : con, il : il} * ('a,'b)trip | EXCON of excon * ('a * ('a,'b)trip) option (* nullary excons are looked up in dyn env. *) | DEEXCON of excon * ('a,'b)trip - | RECORD of 'a * ('a,'b)trip list + | RECORD of 'a option * ('a,'b)trip list | SELECT of int * ('a,'b)trip | DEREF of ('a,'b)trip | REF of 'a * ('a,'b)trip - | ASSIGN of 'a * ('a,'b)trip * ('a,'b)trip + | ASSIGN of ('a,'b)trip * ('a,'b)trip | DROP of ('a,'b)trip (* to do wild cards properly; drops the type *) - | EQUAL of {mu_of_arg1: Type * place , mu_of_arg2: Type*place, alloc: 'a} * ('a,'b)trip * ('a,'b)trip + | EQUAL of {mu_of_arg1: mu, mu_of_arg2: mu} * ('a,'b)trip * ('a,'b)trip | CCALL of {name : string, - mu_result : Type * place, (*mu of result from c function*) + mu_result : mu, (*mu of result from c function*) rhos_for_result : ('a * int option) list} * ('a,'b)trip list (* Calling C functions *) @@ -107,19 +106,19 @@ signature REGION_EXP = (*`rhos_for_result' is technical; see comment in signature MUL_EXP*) | EXPORT of {name : string, - mu_arg : Type * place, (*mu of argument to c function*) - mu_res : Type * place} + mu_arg : mu, (*mu of argument to c function*) + mu_res : mu} * ('a,'b)trip (* The ML function *) - | RESET_REGIONS of {force: bool, alloc : 'a, regions_for_resetting: 'a list} + | RESET_REGIONS of {force: bool, regions_for_resetting: 'a list} * ('a,'b)trip (* for programmer-directed resetting of regions; * resetting is forced iff "force" is true. * Forced resetting is not guaranteed to be sound *) | FRAME of {declared_lvars: {lvar : lvar, regvars : RegVar.regvar list, sigma: sigma ref, - place: place} list, - declared_excons: (excon * (Type*place) option) list} + place: place option} list, + declared_excons: (excon * mu option) list} (* a frame is the result of a structure-level * declaration. *) @@ -132,12 +131,10 @@ signature REGION_EXP = val normPgm: (place, 'b)LambdaPgm * (unit -> int) -> unit - val countletregions: 'a -> unit - val pr_tyvar : tyvar -> string type StringTree - val printcount: int ref (* controls printing of effects on expressions*) + val layMeta : metaType -> StringTree val layoutLambdaPgm: ('a -> StringTree option) -> ('b -> StringTree option) -> ('a, 'b)LambdaPgm -> StringTree diff --git a/src/Compiler/Regions/REGION_STAT_ENV.sml b/src/Compiler/Regions/REGION_STAT_ENV.sml index 288446ff6..d56033b27 100644 --- a/src/Compiler/Regions/REGION_STAT_ENV.sml +++ b/src/Compiler/Regions/REGION_STAT_ENV.sml @@ -8,86 +8,72 @@ signature REGION_STAT_ENV = sig type cone - type regionStatEnv type con (* Unqualified value constructors. *) - type excon (* Unqualified exception constructors.*) + type excon (* Unqualified exception constructors.*) type TyName - type lvar (* Unique lambda identifiers. *) - type TypeAndPlaceScheme and Type and place and runType and effectvar + type lvar (* Unique lambda identifiers. *) + type sigma and Type and mu and place and runType and effectvar type tyvar - type arity - val mk_arity: int * runType list * int -> arity - val un_arity: arity -> int * runType list * int + type arity + val mk_arity : int * runType list * int -> arity + val un_arity : arity -> int * runType list * int type il + type instance_list = (il * (il * cone -> il * cone)) ref list + type lvar_env_range = + bool (* true iff type scheme is compound *) + * bool (* true iff reference to lvar should create region record *) + * RegVar.regvar list + * sigma + * place option + * instance_list ref option (* il node at applied instances of the lvars *) + * (il -> unit) option (* il transformer which can be used for pruning in later topdecs*) + + type regionStatEnv + + val empty : regionStatEnv + val initial : regionStatEnv + + val declareTyName : (TyName * arity * regionStatEnv) -> regionStatEnv + val declareCon : (con * sigma * regionStatEnv) -> regionStatEnv + val declareExcon : (excon * mu * regionStatEnv) -> regionStatEnv + val declareLvar : (lvar * lvar_env_range * regionStatEnv) -> regionStatEnv + val declareRegVar : RegVar.regvar * place * regionStatEnv -> regionStatEnv + val declareTyVar : tyvar * effectvar * regionStatEnv -> regionStatEnv + + val plus : regionStatEnv * regionStatEnv -> regionStatEnv + + val lookupTyName : regionStatEnv -> TyName -> arity option + val lookupCon : regionStatEnv -> con -> sigma option + val lookupExcon : regionStatEnv -> excon -> mu option + val lookupLvar : regionStatEnv -> lvar -> lvar_env_range option + val lookupRegVar : regionStatEnv -> RegVar.regvar -> place option + val lookupTyVar : regionStatEnv -> tyvar -> effectvar option + + val FoldExcon : (((excon * mu) * 'a) -> 'a) -> 'a -> regionStatEnv -> 'a + val FoldLvar : (((lvar * lvar_env_range) * 'a) -> 'a) -> 'a -> regionStatEnv -> 'a + + val mapLvar : (lvar_env_range -> lvar_env_range) -> regionStatEnv -> regionStatEnv + + val restrict : regionStatEnv * {lvars:lvar list, + tynames:TyName list, + cons:con list, + excons:excon list} -> regionStatEnv - val empty: regionStatEnv - val initial: regionStatEnv - - val declareTyName: (TyName * arity * regionStatEnv) -> regionStatEnv - val declareCon: (con * TypeAndPlaceScheme * regionStatEnv) -> regionStatEnv - val declareExcon: (excon * (Type * place) * regionStatEnv) -> regionStatEnv - val declareLvar : (lvar - * ( bool (* true iff type scheme is compound *) - * bool (* true iff reference to lvar should create region record *) - * RegVar.regvar list - * TypeAndPlaceScheme - * place - * (il * (il * cone -> il * cone)) ref list ref option (* il node at applied instances of the lvars *) - * (il->unit) option) (* il transformer which can be used for pruning in later topdecs*) - * regionStatEnv) -> regionStatEnv - val declareRegVar : RegVar.regvar * place * regionStatEnv -> regionStatEnv - val declareTyVar : tyvar * effectvar * regionStatEnv -> regionStatEnv - - val plus: regionStatEnv * regionStatEnv -> regionStatEnv - - val lookupTyName : regionStatEnv -> TyName -> arity option - val lookupCon : regionStatEnv -> con -> TypeAndPlaceScheme option - val lookupExcon : regionStatEnv -> excon -> (Type * place) option - val lookupLvar : regionStatEnv -> lvar -> - ( bool - * bool - * RegVar.regvar list - * TypeAndPlaceScheme - * place - * (il * (il * cone -> il * cone)) ref list ref option (* il node at applied instances of the lvars *) - * (il -> unit)option (* il transformer which can be used for pruning in later topdecs*) - ) option - - val lookupRegVar : regionStatEnv -> RegVar.regvar -> place option - val lookupTyVar : regionStatEnv -> tyvar -> effectvar option - - val FoldExcon: (((excon * (Type * place)) * 'a) -> 'a) -> 'a -> regionStatEnv -> 'a - val FoldLvar : (((lvar * (bool * bool * RegVar.regvar list * TypeAndPlaceScheme - * place - * (il * (il * cone -> il * cone))ref list ref option - * (il -> unit)option - )) * 'a) -> 'a) -> 'a -> regionStatEnv -> 'a - - - val mapLvar : ((bool*bool*RegVar.regvar list*TypeAndPlaceScheme*place*(il * (il * cone -> il * cone))ref list ref option * (il->unit)option) -> - (bool*bool*RegVar.regvar list*TypeAndPlaceScheme*place*(il * (il * cone -> il * cone))ref list ref option * (il->unit)option)) - -> regionStatEnv -> regionStatEnv - - val restrict : regionStatEnv * {lvars:lvar list, - tynames:TyName list, - cons:con list, - excons:excon list} -> regionStatEnv - - val enrich : regionStatEnv * regionStatEnv -> bool - val places_effectvarsRSE : regionStatEnv -> place list * effectvar list + val enrich : regionStatEnv * regionStatEnv -> bool + val places_effectvarsRSE : regionStatEnv -> place list * effectvar list val places_effectvarsRSE' : regionStatEnv -> place list * effectvar list - val mkConeToplevel: regionStatEnv -> cone + val mkConeToplevel : regionStatEnv -> cone type StringTree - val layout : regionStatEnv -> StringTree + val layout : regionStatEnv -> StringTree - val pu : regionStatEnv Pickle.pu + val pu : regionStatEnv Pickle.pu (* Spurious type variables and related functionality *) - val spuriousJoin : tyvar list -> tyvar list -> tyvar list - val spuriousTyvars : regionStatEnv -> Type -> (lvar list * excon list) -> tyvar list + val spuriousJoin : tyvar list -> tyvar list -> tyvar list + val spuriousTyvars : regionStatEnv -> Type -> (lvar list * excon list) -> tyvar list end diff --git a/src/Compiler/Regions/RTYPE.sig b/src/Compiler/Regions/RTYPE.sig index 1045257c6..a1b52b2aa 100644 --- a/src/Compiler/Regions/RTYPE.sig +++ b/src/Compiler/Regions/RTYPE.sig @@ -12,17 +12,23 @@ sig type runType type Type - type mu = Type * place + type mu = Type - val mkTYVAR : tyvar -> Type + val wf_mu : Type -> bool + + val mkTYVAR : tyvar -> mu val mkCONSTYPE : tyname * mu list * place list * arroweffect list -> Type val mkRECORD : mu list -> Type val mkFUN : mu list * arroweffect * mu list -> Type + val mkBOX : Type * place -> mu - val unTYVAR : Type -> tyvar option + val unTYVAR : mu -> tyvar option val unCONSTYPE : Type -> (tyname * mu list * place list * arroweffect list) option val unRECORD : Type -> mu list option val unFUN : Type -> (mu list * arroweffect * mu list) option + val unBOX : mu -> (Type * place) option + + val unbox : mu -> Type * place option val exnType : Type val int31Type : Type @@ -42,7 +48,7 @@ sig val chararrayType : Type val unboxed : Type -> bool - val runtype : Type -> runType + val runtype : Type -> runType option val isF64Type : Type -> bool @@ -57,8 +63,6 @@ sig val unify_mu : mu * mu -> cone -> cone val unify_mus : mu list * mu list -> cone -> cone - val locate_arrow_effect : effect -> Type -> Type -> effect option - type sigma and il val type_to_scheme : Type -> sigma val bv : sigma -> place list * effect list * (tyvar*arroweffect option) list @@ -68,9 +72,9 @@ sig val mk_il : place list * effect list * Type list -> il val un_il : il -> place list * effect list * Type list val ann_sigma : sigma -> effect list -> effect list (* ann_sigma(sigma)acc is a list of all the - * places and arrow effects that occur in - * type of sigma, consed onto acc; word regions - * are not included in the result. *) + * places and arrow effects that occur in + * type of sigma, consed onto acc; word regions + * are not included in the result. *) val un_scheme : sigma -> place list * effect list * (tyvar*arroweffect option) list * Type @@ -114,7 +118,7 @@ sig * in MUL_EXP. *) - val sigma_for_c_function : tyvar list -> mu -> cone -> sigma * cone + val sigma_for_c_function : tyvar list -> Type -> cone -> sigma * cone val c_function_effects : sigma * mu -> (place * int option) list type StringTree diff --git a/src/Compiler/Regions/RType.sml b/src/Compiler/Regions/RType.sml index 9d7f63515..6c165bf0c 100644 --- a/src/Compiler/Regions/RType.sml +++ b/src/Compiler/Regions/RType.sml @@ -5,19 +5,14 @@ struct structure L = LambdaExp structure E = Effect - val print_word_regions = Flags.add_bool_entry - {long="print_word_regions", short=SOME "Pwordregions", item=ref false, neg=false, - menu=["Layout", "print word regions"], desc= - "Also print word regions that have been dropped."} - val print_regions = Flags.is_on0 "print_regions" val print_effects = Flags.is_on0 "print_effects" fun uncurry f (a,b) = f a b - fun say s= TextIO.output(TextIO.stdOut, s ^ "\n"); - fun logsay s= TextIO.output(!Flags.log, s ); - fun log_tree t= PP.outputTree(logsay, t, !Flags.colwidth) + fun say s = TextIO.output(TextIO.stdOut, s ^ "\n"); + fun logsay s = TextIO.output(!Flags.log, s ); + fun log_tree t = PP.outputTree(logsay, t, !Flags.colwidth) fun show_rho rho = PP.flatten1(E.layout_effect rho) fun show_eps e = PP.flatten1(E.layout_effect e) fun show_rhos rhos = ListUtils.stringSep "[" "]" ", " show_rho rhos @@ -47,16 +42,33 @@ struct datatype Type = TYVAR of tyvar - | CONSTYPE of tyname * mu list * place list * arroweffect list - | RECORD of mu list - | FUN of mu list * arroweffect * mu list - - withtype mu = Type*place + | CONSTYPE of tyname * Type list * place list * arroweffect list + | RECORD of Type list + | FUN of Type list * arroweffect * Type list + | BOX of Type * place + + type mu = Type + + fun wf_mu mu = + case mu of + TYVAR _ => true + | CONSTYPE (tyname,mus,rhos,effs) => + TyName.unboxed tyname andalso List.all wf_mu mus + | RECORD nil => true + | RECORD _ => false + | FUN _ => false + | BOX(RECORD mus, _) => length mus > 0 andalso List.all wf_mu mus + | BOX(FUN(mus,_,mus'),_) => List.all wf_mu mus andalso List.all wf_mu mus' + | BOX(CONSTYPE (tyname,mus,rhos,effs),_) => + not(TyName.unboxed tyname) andalso List.all wf_mu mus + | BOX(TYVAR _, _) => false + | BOX(BOX _,_) => false val mkTYVAR = TYVAR val mkCONSTYPE = CONSTYPE val mkRECORD = RECORD val mkFUN = FUN + val mkBOX = BOX fun unTYVAR (TYVAR a) = SOME a | unTYVAR _ = NONE @@ -70,6 +82,13 @@ struct fun unFUN (FUN a) = SOME a | unFUN _ = NONE + fun unBOX (BOX a) = SOME a + | unBOX _ = NONE + + fun unbox mu = + case unBOX mu of + SOME(tau,p) => (tau,SOME p) + | NONE => (mu,NONE) type runType = E.runType @@ -87,132 +106,53 @@ struct collection. *) fun runtype (CONSTYPE(tn, _, _, _)) = - if TyName.unboxed tn then E.WORD_RT - else if eq(tn, tyName_REF) then E.REF_RT - else if eq(tn, tyName_ARRAY) orelse eq(tn, tyName_VECTOR) then E.ARRAY_RT - else if eq(tn, tyName_STRING) orelse eq(tn, tyName_CHARARRAY) then E.STRING_RT - else E.TOP_RT - | runtype (TYVAR _) = E.BOT_RT - | runtype (RECORD[_,_]) = E.PAIR_RT - | runtype (RECORD[_,_,_]) = E.TRIPLE_RT - | runtype (RECORD[]) = E.WORD_RT (* unit is also unboxed *) - | runtype _ = E.TOP_RT - end - - fun isWordRegion (rho) = - case E.get_place_ty rho of - SOME E.WORD_RT => true - | _ => false - - fun isTopWordRegion rho = E.eq_effect(rho,E.toplevel_region_withtype_word) - - fun discard_top_wordrho places = List.filter (not o isTopWordRegion) places - fun discard_word_rhos places = List.filter (not o isWordRegion) places - -(* - local - val (lay_ty,lay_mu) = mk_layout false - fun dump_ty(ty) = - PP.outputTree(fn s => TextIO.output(!Flags.log, s), - lay_ty ty, !Flags.colwidth) - - fun dump_mu(mu) = - PP.outputTree(fn s => TextIO.output(!Flags.log, s), - lay_mu mu, !Flags.colwidth) - - fun unify_ty0 (t1,t2,c) : c = - case (t1, t2) of - (TYVAR _, TYVAR _) => c - | (CONSTYPE(_,mus1,rs1,es1),CONSTYPE(_,mus2,rs2,es2)) => - unify_mus0(mus1,mus2, - unify_rhos0(rs1,rs2, - unify_epss0(es1,es2,c))) - | (RECORD mus1, RECORD mus2) => unify_mus0(mus1,mus2,c) - | (FUN(mus1,e1,mus'1),FUN(mus2,e2,mus'2)) => - unify_mus0(mus1,mus2, E.unifyEps(e1,e2) (unify_mus0(mus'1,mus'2,c))) - | _ => (TextIO.output(!Flags.log, "ty1 = \n"); dump_ty t1; - TextIO.output(!Flags.log, "ty2 = \n"); dump_ty t2; - die ("unify: types do not unify")) - - and unify_mu0 ((t1,r1),(t2,r2),c) = - unify_ty0(t1,t2, E.unifyRho(r1,r2)c) - - and unify_mus0 (mus1,mus2,c) = - ListPair.foldlEq unify_mu0 c (mus1,mus2) - handle ListPair.UnequalLengths => - die "unify_mus0: UnequalLengths" - and unify_rhos0 (rs1,rs2,c) = - ListPair.foldlEq (fn (a,b,c) => E.unifyRho(a,b)c) c (rs1,rs2) - handle ListPair.UnequalLengths => - die "unify_rhos0: UnequalLengths" - and unify_epss0 (es1,es2,c) = - ListPair.foldlEq (fn (a,b,c) => E.unifyEps(a,b)c) c (es1,es2) - handle ListPair.UnequalLengths => - die "unify_epss0: UnequalLengths" - in - fun unify_ty (a,b) c = unify_ty0 (a,b,c) - handle _ => (TextIO.output(!Flags.log, "mu1 = \n"); dump_ty a; - TextIO.output(!Flags.log, "mu2 = \n"); dump_ty b; - die "unify_ty: types do not unify") - fun unify_mus (a,b) c = unify_mus0 (a,b,c) - handle _ => (die "unify_mus: types with places do not unify") - fun unify_mu (a,b) c = unify_mu0 (a,b,c) - handle _ => (TextIO.output(!Flags.log, "mu1 = \n"); dump_mu a; - TextIO.output(!Flags.log, "mu2 = \n"); dump_mu b; - die "unify_mu: types with places do not unify") - + if TyName.unboxed tn then NONE + else if eq(tn, tyName_REF) then SOME E.REF_RT + else if eq(tn, tyName_ARRAY) orelse eq(tn, tyName_VECTOR) then SOME E.ARRAY_RT + else if eq(tn, tyName_STRING) orelse eq(tn, tyName_CHARARRAY) then SOME E.STRING_RT + else SOME E.TOP_RT + | runtype (TYVAR _) = NONE + | runtype (RECORD[_,_]) = SOME E.PAIR_RT + | runtype (RECORD[_,_,_]) = SOME E.TRIPLE_RT + | runtype (RECORD[]) = NONE (* unit is also unboxed *) + | runtype _ = SOME E.TOP_RT end -*) (* ann_XX0 ty acc: return effects in the order they appear in the * underlying ML-type; this function is used for unifying effects in - * types; we do not remove the topWordRegions from the lists as this - * could mess up the lists... mael 2007-11-14 *) - - fun ann_ty0 ty (acc : effect list) = - case ty of - TYVAR _ => acc - | CONSTYPE(_,mus,rhos,epss) => - List.foldr ann_mu0 (rhos @ (epss @ acc)) mus - | RECORD mus => - List.foldr ann_mu0 acc mus - | FUN(mus1,eps,mus2) => - ann_mus0 mus1 (eps:: ann_mus0 mus2 acc) - and ann_mu0 ((tau,rho), acc) = ann_ty0 tau (rho::acc) - and ann_mus0 [] acc = acc - | ann_mus0 (mu::rest) acc = ann_mu0 (mu, ann_mus0 rest acc) + * types *) fun ann_ty ty (acc : effect list) = case ty of TYVAR _ => acc | CONSTYPE(_,mus,rhos,epss) => - List.foldr ann_mu (discard_top_wordrho rhos @ (epss @ acc)) mus + List.foldr ann_mu (rhos @ (epss @ acc)) mus | RECORD mus => List.foldr ann_mu acc mus | FUN(mus1,eps,mus2) => ann_mus mus1 (eps:: ann_mus mus2 acc) - and ann_mu ((tau,rho), acc) = - ann_ty tau (if isTopWordRegion rho then acc else rho::acc) - and ann_mus [] acc = acc + | BOX(tau,rho) => ann_ty tau (rho::acc) + and ann_mu (tau, acc) = ann_ty tau acc + and ann_mus [] acc = acc | ann_mus (mu::rest) acc = ann_mu (mu, ann_mus rest acc) - (* free region variables of mu, including secondary occurrences but excluding the topWordRegion *) + (* free region variables of mu, including secondary occurrences *) fun frv_mu mu = let val annotations = ann_mu (mu, []) val all_nodes = E.subgraph annotations - in - List.filter (fn e => E.is_rho e andalso not(isTopWordRegion e)) all_nodes + in List.filter (fn e => E.is_rho e) all_nodes end local (* free primary region and effect variables ("pfrv tau" etc.) *) fun pfrv0 (ty, acc) = case ty of TYVAR _ => acc - | CONSTYPE(_,mus,places,_) => List.foldr pfrvMu0 (discard_top_wordrho places @ acc) mus + | CONSTYPE(_,mus,places,_) => List.foldr pfrvMu0 (places @ acc) mus | RECORD mus => List.foldr pfrvMu0 acc mus | FUN(mus1,_,mus2) => pfrvMus0 (mus1, pfrvMus0 (mus2, acc)) - and pfrvMu0 ((tau,rho), acc) = pfrv0 (tau, if isTopWordRegion rho then acc else rho::acc) + | BOX (tau,rho) => pfrv0 (tau, rho::acc) + and pfrvMu0 (tau, acc) = pfrv0 (tau, acc) and pfrvMus0 ([], acc) = acc | pfrvMus0 (mu::rest, acc) = pfrvMu0 (mu, pfrvMus0 (rest, acc)) @@ -222,12 +162,14 @@ struct | CONSTYPE(_,mus,_,arreffs) => List.foldr pfevMu0 (arreffs@acc) mus | RECORD mus => List.foldr pfevMu0 acc mus | FUN(mus1,arreff,mus2) => pfevMus0 (mus1,arreff::(pfevMus0(mus2,acc))) - and pfevMu0 ((tau,rho), acc) = pfev0 (tau, acc) + | BOX (tau,rho) => pfev0 (tau, acc) + and pfevMu0 (tau, acc) = pfev0 (tau, acc) and pfevMus0 ([], acc) = acc | pfevMus0 (mu::rest, acc) = pfevMu0 (mu, pfevMus0 (rest, acc)) in fun pfrv ty = pfrv0 (ty, []) fun pfrvMu mu = pfrvMu0 (mu, []) + fun pfrvMus mus = pfrvMus0 (mus, []) fun pfev ty = pfev0 (ty, []) fun pfevMu mu = pfevMu0 (mu, []) @@ -238,55 +180,53 @@ struct repeat (n-1) f (f acc) fun freshType (lookup: tyname -> (int*runType list*int)option) : - (L.Type * cone -> Type * cone) - * (L.Type * cone -> mu * cone) = + (L.Type * cone -> Type * cone) * (L.Type * cone -> mu * cone) = let - fun mkTy (ty,cone) = case ty of + fun mkTy (ty,cone) = + case ty of L.TYVARtype alpha => (TYVAR alpha, cone) | L.ARROWtype(tys1,tys2)=> - let val (eps,cone') = E.freshEps(cone) + let val (eps,cone') = E.freshEps cone val (cone1,mus1) = List.foldr mkMus (cone',[]) tys1 val (cone2,mus2) = List.foldr mkMus (cone1,[]) tys2 - in (FUN(mus1,eps,mus2), cone2) end + in (FUN(mus1,eps,mus2), cone2) + end | L.CONStype(tys,tyname)=> let val arity as (alpha_count, rhos_runtypes, eps_count) = - case lookup tyname - of SOME arity => arity - | NONE => die ("mkTy: type name " ^ TyName.pr_TyName tyname ^ " not declared") + case lookup tyname of + SOME arity => arity + | NONE => die ("mkTy: type name " ^ TyName.pr_TyName tyname ^ " not declared") val (cone, mus) = List.foldr mkMus (cone,[]) tys fun repeat2 ([],cone,rhos) = (cone, rev rhos) | repeat2 (rt::rts,cone,rhos) = - let val (rho,cone') = E.freshRhoWithTy(rt,cone) - in repeat2 (rts,cone',rho::rhos) - end + let val (rho,cone') = E.freshRhoWithTy(rt,cone) + in repeat2 (rts,cone',rho::rhos) + end val (cone, rhos) = repeat2(rhos_runtypes,cone,[]) - -(*17/10/96-Martin - repeat rho_count (fn (cone, acc: place list) => - let val (rho,cone') = E.freshRho cone - in (cone', rho::acc) end) (cone,[]) -*) val (cone, epss) = repeat eps_count (fn (cone, acc: arroweffect list) => - let val (eps,cone') = E.freshEps cone - in (cone', eps::acc) end) (cone,[]) + let val (eps,cone') = E.freshEps cone + in (cone', eps::acc) + end) (cone,[]) in (CONSTYPE(tyname,mus,rhos,epss), cone) end - | L.RECORDtype(tys) => - let val (cone,mus) = List.foldr mkMus (cone,[]) tys - in - (RECORD(mus),cone) - end - and mkMu(ty, cone) = + | L.RECORDtype tys => + let val (cone,mus) = List.foldr mkMus (cone,[]) tys + in (RECORD(mus),cone) + end + and mkMu (ty, cone) = let val (tau, cone) = mkTy(ty,cone) - val (rho,cone) = E.freshRhoWithTy(runtype tau, cone) - in - ((tau,rho),cone) + in case runtype tau of + SOME rt => let val (rho,cone) = E.freshRhoWithTy(rt, cone) + in (BOX(tau,rho),cone) + end + | NONE => (tau, cone) end and mkMus (ty, (cone, acc: mu list)) = - let val (mu,cone') = mkMu(ty,cone) - in (cone', mu::acc) end + let val (mu,cone') = mkMu(ty,cone) + in (cone', mu::acc) + end in (mkTy, mkMu) end @@ -325,11 +265,11 @@ struct children = map f l}) fun layout_tuple'' l = - let fun mk_list([],acc) = rev acc - | mk_list(SOME t::rest, acc) = mk_list(rest,t::acc) - | mk_list(NONE::rest, acc) = mk_list(rest,acc) - in layout_tuple' (fn x => x) (mk_list (l,[])) - end + let fun mk_list([],acc) = rev acc + | mk_list(SOME t::rest, acc) = mk_list(rest,t::acc) + | mk_list(NONE::rest, acc) = mk_list(rest,acc) + in layout_tuple' (fn x => x) (mk_list (l,[])) + end fun layout_tyvar alpha = PP.LEAF(L.pr_tyvar alpha) @@ -342,57 +282,52 @@ struct fun lay_node_short n = E.layout_effect n fun mk_layout omit_region_info = - let - fun layout_arrow_rec arreff = + let fun layout_arrow_rec arreff = if print_effects() then Node{start = "-", finish = "->", - indent = 2, childsep = PP.NOSEP, - children = [lay_node arreff]} + indent = 2, childsep = PP.NOSEP, + children = [lay_node arreff]} else leaf "->" - fun lay_tau_rec parenthesise ty = - case ty of - TYVAR v => layout_tyvar v - | FUN(mus1,areff,mus2) => - let val children = [layout_arg_res mus1, layout_arrow_rec areff, layout_arg_res mus2] - in if parenthesise then - Node{start = "(", finish = ")", indent = 1, childsep = PP.NOSEP, children = children} - else Node{start="", finish="", indent=1, childsep=PP.NOSEP, children=children} - end - | CONSTYPE(tyname,[],[],[]) => - leaf (TyName.pr_TyName tyname) - | CONSTYPE(tyname,mu_list,place_list,arreff_list) => - if omit_region_info - then case layout_tuple' (lay_mu_rec true) mu_list - of SOME mu_tree => - Node{start = "", finish = "", indent = 0, - childsep = PP.RIGHT " ", - children = [mu_tree, leaf (TyName.pr_TyName tyname)]} - | NONE => leaf (TyName.pr_TyName tyname) - else - let val mu_tree = layout_tuple' (lay_mu_rec true) mu_list - val place_list = if print_word_regions() then place_list - else discard_word_rhos place_list - val rho_tree = layout_list' lay_node place_list - val effect_tree = layout_list' lay_node arreff_list - in case layout_tuple'' [mu_tree,rho_tree,effect_tree] - of SOME t => Node{start = "", finish = "", indent = 0, - childsep = PP.RIGHT " ", - children = [t, leaf (TyName.pr_TyName tyname)]} - | NONE => leaf (TyName.pr_TyName tyname) - end - | RECORD [] => leaf "unit" - | RECORD mu_list => - if parenthesise then Node{start = "(", finish = ")", childsep = PP.RIGHT "*", indent = 1, - children = map (lay_mu_rec true) mu_list} - else Node{start = "", finish = "", childsep = PP.RIGHT "*", indent = 1, - children = map (lay_mu_rec true) mu_list} - - and lay_mu_rec parenthesise (tau,rho)= - if omit_region_info orelse (not(print_word_regions()) - andalso isWordRegion rho) then - lay_tau_rec parenthesise tau - else layout_pair (lay_tau_rec false tau, lay_node rho) + fun lay_tau_rec parenthesise ty = + case ty of + TYVAR v => layout_tyvar v + | FUN(mus1,areff,mus2) => + let val children = [layout_arg_res mus1, layout_arrow_rec areff, layout_arg_res mus2] + in if parenthesise then + Node{start = "(", finish = ")", indent = 1, childsep = PP.NOSEP, children = children} + else Node{start="", finish="", indent=1, childsep=PP.NOSEP, children=children} + end + | CONSTYPE(tyname,[],[],[]) => + leaf (TyName.pr_TyName tyname) + | CONSTYPE(tyname,mu_list,place_list,arreff_list) => + if omit_region_info + then case layout_tuple' (lay_mu_rec true) mu_list + of SOME mu_tree => + Node{start = "", finish = "", indent = 0, + childsep = PP.RIGHT " ", + children = [mu_tree, leaf (TyName.pr_TyName tyname)]} + | NONE => leaf (TyName.pr_TyName tyname) + else + let val mu_tree = layout_tuple' (lay_mu_rec true) mu_list + val rho_tree = layout_list' lay_node place_list + val effect_tree = layout_list' lay_node arreff_list + in case layout_tuple'' [mu_tree,rho_tree,effect_tree] + of SOME t => Node{start = "", finish = "", indent = 0, + childsep = PP.RIGHT " ", + children = [t, leaf (TyName.pr_TyName tyname)]} + | NONE => leaf (TyName.pr_TyName tyname) + end + | RECORD [] => leaf "unit" + | RECORD mu_list => + if parenthesise then Node{start = "(", finish = ")", childsep = PP.RIGHT "*", indent = 1, + children = map (lay_mu_rec true) mu_list} + else Node{start = "", finish = "", childsep = PP.RIGHT "*", indent = 1, + children = map (lay_mu_rec true) mu_list} + | BOX (tau,rho) => if omit_region_info then + lay_tau_rec parenthesise tau + else layout_pair (lay_tau_rec false tau, lay_node rho) + and lay_mu_rec parenthesise tau = lay_tau_rec parenthesise tau and layout_arg_res [mu] = lay_mu_rec true mu | layout_arg_res mus = layout_list (lay_mu_rec true) mus @@ -403,41 +338,42 @@ struct (* unification *) fun u ((node1,node2), cone) = - if E.is_arrow_effect node1 + if E.is_arrow_effect node1 then E.unifyEps(node1,node2) cone - else E.unifyRho(node1, node2) cone + else E.unifyRho(node1, node2) cone - fun unify_ty (ty1, ty2:Type) cone: E.cone = - let val effs1 = ann_ty0 ty1 [] - val effs2 = ann_ty0 ty2 [] - in - List.foldl u cone (BasisCompat.ListPair.zipEq(effs1,effs2)) - handle X => let val (lay_ty,_) = mk_layout false; - fun dump(ty) = PP.outputTree(fn s => TextIO.output(!Flags.log, s), lay_ty ty, !Flags.colwidth) - in - TextIO.output(!Flags.log, "ty1 = \n"); dump ty1; - TextIO.output(!Flags.log, "ty2 = \n"); dump ty2; - die ("unify: types do not unify. Exception " ^ exnName X ^ - " raised; length(effs1) = " ^ Int.toString(length effs1) ^ - " and length(effs2) = " ^ Int.toString (length effs2) ^ ". ") - end - end - - fun unify_mu (mu1, mu2:mu) cone: E.cone = - List.foldl u cone (BasisCompat.ListPair.zipEq(ann_mu0 (mu1, []),ann_mu0 (mu2, []))) - handle (X as Report.DeepError _) => raise X - | X => let val (_,lay_mu) = mk_layout false; - fun dump(mu) = PP.outputTree(fn s => TextIO.output(!Flags.log, s), lay_mu mu, !Flags.colwidth) - in - TextIO.output(!Flags.log, "mu1 = \n"); dump mu1; - TextIO.output(!Flags.log, "mu2 = \n"); dump mu2; - die ("unify: types with places do not unify: " ^ General.exnMessage X) - end + fun unify_ty (ty1, ty2:Type) cone : E.cone = + let val effs1 = ann_ty ty1 [] + val effs2 = ann_ty ty2 [] + in + List.foldl u cone (ListPair.zipEq(effs1,effs2)) + handle X => let val (lay_ty,_) = mk_layout false; + fun dump ty = PP.outputTree(fn s => TextIO.output(!Flags.log, s), lay_ty ty, !Flags.colwidth) + in + TextIO.output(!Flags.log, "ty1 = "); dump ty1; + TextIO.output(!Flags.log, "\nty2 = "); dump ty2; + die ("unify: types do not unify. Exception " ^ exnName X ^ + " raised; length(effs1) = " ^ Int.toString(length effs1) ^ + " and length(effs2) = " ^ Int.toString (length effs2) ^ ". ") + end + end - fun unify_mus (mus1, mus2) cone: E.cone = - List.foldl (uncurry unify_mu) cone - (BasisCompat.ListPair.zipEq(mus1,mus2)) handle BasisCompat.ListPair.UnequalLengths => - die "unify_mus: lists have different lengths" + fun unify_mu (mu1, mu2:mu) cone : E.cone = + List.foldl u cone (ListPair.zipEq(ann_mu (mu1, []),ann_mu (mu2, []))) + handle (X as Report.DeepError _) => raise X + | X => let val (_,lay_mu) = mk_layout false; + fun dump mu = PP.outputTree(fn s => TextIO.output(!Flags.log, s), lay_mu mu, !Flags.colwidth) + in + TextIO.output(!Flags.log, "mu1 = "); dump mu1; + TextIO.output(!Flags.log, "\nmu2 = "); dump mu2; + die ("unify: types with places do not unify: " ^ General.exnMessage X) + end + + fun unify_mus (mus1, mus2) cone : E.cone = + List.foldl (uncurry unify_mu) cone + (ListPair.zipEq(mus1,mus2)) + handle ListPair.UnequalLengths => + die "unify_mus: lists have different lengths" (* type schemes: bound variable must be listed in bottom-up depth first search order. No cycles amongst bound effect variables @@ -453,33 +389,6 @@ struct | ann_alphas ((_,NONE)::xs) acc = ann_alphas xs acc | ann_alphas ((_,SOME e)::xs) acc = ann_alphas xs (e::acc) - (* locate a corresponding arrow effect *) - fun locate_effect_ty (e:effect) (a:effect option) t0 t1 : effect option = - case a of SOME _ => a | NONE => - (case (t0,t1) of - (TYVAR _, TYVAR _) => NONE - | (CONSTYPE (tn0,mus0,rs0,es0), CONSTYPE (tn1,mus1,rs1,es1)) => locate_effect_mus e a mus0 mus1 - | (RECORD mus0, RECORD mus1) => locate_effect_mus e a mus0 mus1 - | (FUN (mus0,ae0,mus0'), FUN (mus1,ae1,mus1')) => - if E.eq_effect (ae0,e) then SOME ae1 - else let val es0 = E.represents ae0 - val es1 = E.represents ae1 - in case (List.filter E.is_arrow_effect es0, List.filter E.is_arrow_effect es1) of - ([e0],[e1]) => if E.eq_effect(e,e0) then SOME e1 else NONE - | _ => NONE - end - | _ => die "locate_effect_ty: type mismatch!") - and locate_effect_mus e a mus0 mus1 = - case a of SOME _ => a | NONE => - case (mus0,mus1) of - (nil,nil) => a - | ((ty0,_)::mus0, (ty1,_)::mus1) => - locate_effect_mus e (locate_effect_ty e a ty0 ty1) mus0 mus1 - | _ => die "locate_effect_mus: non-matching number of mus" - - fun locate_arrow_effect (e:effect) t0 t1 : effect option = - locate_effect_ty e NONE t0 t1 - (* Type schemes *) datatype sigma = @@ -528,8 +437,7 @@ struct in (* subtract the bound rhos *) List.app (fn bound_rho => E.get_visited bound_rho := true) rhos; - List.filter (fn free_rho => not(!(E.get_visited free_rho)) - andalso not(isTopWordRegion free_rho)) rhos_in_put_nodes + List.filter (fn free_rho => not(!(E.get_visited free_rho))) rhos_in_put_nodes before List.app (fn bound_rho => E.get_visited bound_rho := false) rhos end @@ -539,13 +447,14 @@ struct in fun ftv_sigma (FORALL(_,_,alphas,tau)) : tyvar list = let - fun ftv (t,(seen,acc)) = - case t of - TYVAR tv => if mem tv seen then (seen,acc) else (tv::seen,tv::acc) - | CONSTYPE(_,mus,_,_) => ftv_mus (mus,(seen,acc)) - | RECORD mus => ftv_mus (mus,(seen,acc)) - | FUN(mus1,_,mus2) => ftv_mus (mus2,ftv_mus (mus1,(seen,acc))) - and ftv_mus (mus,p) = List.foldr (fn ((ty,_),p) => ftv(ty,p)) p mus + fun ftv (t,(seen,acc)) = + case t of + TYVAR tv => if mem tv seen then (seen,acc) else (tv::seen,tv::acc) + | CONSTYPE(_,mus,_,_) => ftv_mus (mus,(seen,acc)) + | RECORD mus => ftv_mus (mus,(seen,acc)) + | FUN(mus1,_,mus2) => ftv_mus (mus2,ftv_mus (mus1,(seen,acc))) + | BOX(tau,_) => ftv(tau,(seen,acc)) + and ftv_mus (mus,p) = List.foldr ftv p mus in #2 (ftv(tau,(map #1 alphas,nil))) end @@ -558,178 +467,70 @@ struct end fun insert_alphas (alphas, FORALL(rhos,epss,_,tau)) = - let (* A type variable in alphas may be associated with different regions - when occuring as a mu in tau. However, the same region cannot be - associated with different type variables. Here is a property that - should hold: - - For each mu=(tv,r) in tau, - a) rt(r) = RT_BOT - b) tv in alphas implies r in rhos. - c) for any other mu'=(tv',r) in tau, tv=tv' - - Moreover, for any n-array type name tn, the type name has associated - with it m >= n auxiliary region variables and we assume that the region - variable associated with the i'th type variable is given by the function - - RV : TyName x N => N - - Thus, for a region-annotated datatype declaration - - datatype ([tv1..tv..tvn],[r0..r..rm],[..]) tn = - C1 of ty1 | ... | Ck of tyk - - it holds that for each mu=(tv,r) in ty1...tyk, we have - - 1) tv = tvi for some i in {1,...,n} (!) - 2) mu=(tvi,rj) and j = RV(tn,i) - - (!) Notice that the type schemes for the datatype constructors are - guaranteed to be closed (enforced by the SML definition). - - When this check is enabled, compiling SMLtoJS fails with - a message "Impossible: RType.quantified type variable - 'a56 associated with a non-quantified region r2546", - which happens during spreading of pickler code for - IntFinMapPT. - *) - - fun is_abs_tv tv = List.exists (fn (tv',_) => tv=tv') alphas - type tvenv = tyvar option IntFinMap.map - fun chk (E:tvenv) (ty,rhoOpt) : tvenv = - case ty of - TYVAR tv => - if is_abs_tv tv then - (case rhoOpt of - NONE => E (* either toplevel or argument to CONSTYPE *) - | SOME rho => - let val key = E.key_of_eps_or_rho rho - in case IntFinMap.lookup E key of - NONE => (* rho not in rhos *) - die ("quantified type variable " ^ L.pr_tyvar tv ^ - " associated with a non-quantified region " ^ - pr_place rho) - | SOME NONE => (* rho in rhos *) - (case E.get_place_ty rho of - SOME E.BOT_RT => IntFinMap.add(key,SOME tv,E) - | SOME rt => die ("quantified type variable " ^ L.pr_tyvar tv ^ - " associated with region " ^ pr_place rho ^ - " of type " ^ E.show_runType rt) - | NONE => die ("quantified type variable " ^ L.pr_tyvar tv ^ - " associated with node " ^ pr_place rho ^ - ", which has no runtype") - ) - | SOME (SOME tv') => - if tv'<>tv then - die ("quantified type variable " ^ L.pr_tyvar tv ^ - " is associated with the region " ^ pr_place rho ^ - ", which is also associated with the type variable " ^ - L.pr_tyvar tv') - else E - end) - else E - | RECORD mus => chks E mus (* memo: check rhoOpt *) - | CONSTYPE(tn,mus,rhos,effs) => chks E mus (* memo: check rhoOpt *) - | FUN(mus1,_,mus2) => chks (chks E mus1) mus2 (* memo: check rhoOpt *) - and chks E nil = E - | chks E ((ty,rho)::mus) = chks (chk E (ty,SOME rho)) mus -(* - val E0 = IntFinMap.fromList (map (fn r => (E.key_of_eps_or_rho r,NONE)) rhos) - val _ = chk E0 (tau,NONE) -*) - in FORALL(rhos,epss,alphas,tau) - end + FORALL(rhos,epss,alphas,tau) fun drop_alphas (FORALL(rhos,epss,_,tau)) = FORALL(rhos,epss,[],tau) fun mk_lay_sigma_aux (omit_region_info:bool) : - StringTree list * arroweffect list * (tyvar*arroweffect option) list * Type -> PP.StringTree = - let - val (lay_ty, _) = mk_layout omit_region_info - fun lay_sig (rho_trees,epsilons,alphas,tau) = - (case(rho_trees,epsilons,alphas) of - ([],[],[]) => if !Flags.print_types then lay_ty tau else PP.LEAF "" - | _ => - let val children = - if print_effects() then - (*print regions and effect and -perhaps- types: *) - rho_trees @ map lay_node_short epsilons @ - (if !Flags.print_types then map layout_tyvar' alphas - else []) - else (if print_regions() then rho_trees - else []) @ - (if !Flags.print_types then map layout_tyvar (map #1 alphas) - else []) - val binders = PP.HNODE{start="",finish="",childsep=PP.RIGHT ",", - children=children} - in if !Flags.print_types - then - Node{start = "all ", finish = "", indent = 3, - childsep = PP.RIGHT ".", - children = [binders,lay_ty tau]} - else (case children - of [] => PP.LEAF "" - | _ => if print_regions() orelse - print_effects() - then Node{start = "[", finish = "]", - indent = 1, childsep = PP.NOSEP, - children = [binders]} - else binders) - end - ) - in - lay_sig - end + StringTree list * arroweffect list * (tyvar*arroweffect option) list * Type -> PP.StringTree = + let + val (lay_ty, _) = mk_layout omit_region_info + fun lay_sig (rho_trees,epsilons,alphas,tau) = + (case(rho_trees,epsilons,alphas) of + ([],[],[]) => if !Flags.print_types then lay_ty tau else PP.LEAF "" + | _ => + let val children = + if print_effects() then + (*print regions and effect and -perhaps- types: *) + rho_trees @ map lay_node_short epsilons @ + (if !Flags.print_types then map layout_tyvar' alphas + else []) + else (if print_regions() then rho_trees + else []) @ + (if !Flags.print_types then map layout_tyvar (map #1 alphas) + else []) + val binders = PP.HNODE{start="",finish="",childsep=PP.RIGHT ",", + children=children} + in if !Flags.print_types + then + Node{start = "all ", finish = "", indent = 3, + childsep = PP.RIGHT ".", + children = [binders,lay_ty tau]} + else (case children + of [] => PP.LEAF "" + | _ => if print_regions() orelse + print_effects() + then Node{start = "[", finish = "]", + indent = 1, childsep = PP.NOSEP, + children = [binders]} + else binders) + end + ) + in + lay_sig + end fun mk_lay_sigma omit_region_info = let val f = mk_lay_sigma_aux omit_region_info in fn (FORALL (raw as (rhos,epss,alphas,tau))) => - f(map lay_node rhos, epss, alphas, tau) + f(map lay_node rhos, epss, alphas, tau) end - fun mk_lay_sigma' (omit_region_info: bool) (rhos,epss,tyvars,tau): PP.StringTree = + fun mk_lay_sigma' (omit_region_info: bool) (rhos,epss,tyvars,tau) : PP.StringTree = mk_lay_sigma(omit_region_info)(FORALL(rhos,epss,tyvars,tau)) fun mk_lay_sigma'' (lay_bind: 'b -> StringTree option) omit_region_info = let val f = mk_lay_sigma_aux omit_region_info in fn (rhos,epss,alphas,tau) => - let val ts = List.foldr (fn (rho,acc) => case lay_bind rho of - SOME t => t::acc | _ => acc) [] rhos - in f(ts, epss, alphas, tau) - end + let val ts = List.foldr (fn (rho,acc) => + case lay_bind rho of + SOME t => t::acc + | _ => acc) [] rhos + in f(ts, epss, alphas, tau) + end end - (* maybe_increase_runtype(mu as (tau,rho)) increases the runType of rho to - be the least upper bound of its current runType and the runType of tau. - This must be done during instantiation of type schemes when (tau,rho) - is the result of instantiating (alpha',rho') where rho' has runtype BOT_RT *) - - fun maybe_increase_runtype (mu as (tau,rho)) cone = - let val old = case E.get_place_ty rho of SOME old => old | _ => die "maybe_increase_runtype" - val new = runtype tau - in - if old<>new then - if E.eq_effect(rho, E.toplevel_region_withtype_bot) then (* This should not happen too often ; ughhh *) - (tau, E.toplevelRhoFromTy new) - else - ((case E.lub_runType(old,new) of - E.WORD_RT => - (E.unifyRho(E.toplevel_region_withtype_word, rho) cone; mu) (* the toplevel region is already in the cone, so the resulting cone is unaltered (the entry for rho could be gc'ed) *) - | rt => (E.setRunType rho rt; mu)) - handle X => - let val (_,lay_mu) = mk_layout false; - fun dump mu = PP.outputTree(fn s => TextIO.output(!Flags.log, s), lay_mu mu, !Flags.colwidth) - in TextIO.output(!Flags.log, "mu = ") - ; dump mu - ; TextIO.output(!Flags.log, "\n") - ; TextIO.output(!Flags.log, "new: " ^ E.show_runType new ^ "\n") - ; TextIO.output(!Flags.log, "old: " ^ E.show_runType old ^ "\n") - ; die "maybe_increase_runtype" - end) - else mu - end - (* instantiation of type schemes *) (* inst: sigma*il -> cone -> (Type * cone) @@ -741,7 +542,7 @@ struct is traversed, but not copied). *) - type il = effect list * effect list * Type list (* instantiation lists *) + type il = effect list * effect list * mu list (* instantiation lists *) fun mk_il x = x fun un_il x = x @@ -755,22 +556,19 @@ struct val _ = PP.outputTree(logsay,lay_ty tau,!Flags.colwidth) val _ = logsay ("\nSr = " ^ concat (map (fn (rho, rho') => show_rho rho ^ "->" ^show_rho rho' ^ ",") Sr)) *) - fun fst (x,y) = x - fun cp_var node = case E.get_instance node of ref(SOME node') => (true,node') | _ => (false,node) fun applySt ([],alpha) = NONE - | applySt (((alpha',_),ty)::rest, alpha) = - if alpha=alpha' then SOME ty + | applySt (((alpha',_),mu)::rest, alpha) = + if alpha=alpha' then SOME mu else applySt(rest,alpha) (* cp: copy as much of the body of the type scheme as is necessary *) fun cp_rho rho = cp_var rho - fun cp_eps eps = cp_var eps fun cp_ty ty = @@ -780,57 +578,52 @@ struct | SOME ty' => (true, ty')) | RECORD mus => let val l = map cp_mu mus - in if List.exists fst l - then (true, RECORD(map #2 l)) - else (false, ty) + in if List.exists (#1) l + then (true, RECORD(map #2 l)) + else (false, ty) end | CONSTYPE(tyname,mus,aux_places,aux_arreffs) => let val l1 = map cp_mu mus - val (b1, mus1) = if List.exists fst l1 + val (b1, mus1) = if List.exists (#1) l1 then (true, map #2 l1) else (false, mus) val l2 = map cp_rho aux_places val (b2, aux_places1) = - if List.exists fst l2 + if List.exists (#1) l2 then (true, map #2 l2) else (false, aux_places) val l3 = map cp_eps aux_arreffs val (b3, aux_arreffs1) = - if List.exists fst l3 + if List.exists (#1) l3 then (true, map #2 l3) else (false, aux_arreffs) - in - if b1 orelse b2 orelse b3 - then (true, - CONSTYPE(tyname,mus1,aux_places1,aux_arreffs1)) - else (false, ty) + in if b1 orelse b2 orelse b3 + then (true, + CONSTYPE(tyname,mus1,aux_places1,aux_arreffs1)) + else (false, ty) end | FUN(mus1,arreff,mus3) => let val l1 = map cp_mu mus1 - val (b1, mus1') = if List.exists fst l1 + val (b1, mus1') = if List.exists (#1) l1 then (true, map #2 l1) else (false, mus1) val (b2, arreff') = cp_eps arreff val l3 = map cp_mu mus3 - val (b3, mus3') = if List.exists fst l3 + val (b3, mus3') = if List.exists (#1) l3 then (true, map #2 l3) else (false, mus3) - in - if b1 orelse b2 orelse b3 - then (true, FUN(mus1',arreff',mus3')) - else (false, ty) + in if b1 orelse b2 orelse b3 + then (true, FUN(mus1',arreff',mus3')) + else (false, ty) + end + | BOX(tau,rho) => + let val (chng1, tau1) = cp_ty tau + val (chng2, rho2) = cp_rho rho + in if chng1 orelse chng2 then (true, BOX(tau1,rho2)) + else (false, ty) end - and cp_mu (mu as (tau,rho)) = - let val (chng1, tau1) = cp_ty tau - val (chng2, rho2) = cp_rho rho - in - if chng1 orelse chng2 - then case tau of - TYVAR _ => (true, maybe_increase_runtype(tau1,rho2)cone) - | _ =>(true,(tau1, rho2)) - else (false,mu) - end + and cp_mu mu = cp_ty mu val _ = List.app E.setInstance Sr val _ = List.app E.setInstance Se @@ -868,51 +661,13 @@ struct fun ann_sigma (FORALL(_,_,alphas,ty)) : effect list -> effect list = ann_ty ty o ann_alphas alphas - (* update_runtypes(actuals,formals) -> unit: - * make sure runtypes of actuals >= runtypes of formals. - *) - - fun runtype_place place = - case E.get_place_ty place of - SOME rt => rt - | NONE => die "runtype_place" - - fun update_runtypes ([],[]) = () - | update_runtypes (rho_a::actuals,rho_f::formals) = - let val rt_a = runtype_place rho_a - val rt_lub = E.lub_runType(rt_a,runtype_place rho_f) - handle X => ( print ("RType.update_runtypes: Failed to find lub_runtype for " - ^ pr_place rho_a ^ " and " ^ pr_place rho_f ^ "\n") - ; raise X - ) - val _ = if rt_lub = rt_a then () - else E.setRunType rho_a rt_lub - in update_runtypes(actuals,formals) - end - | update_runtypes _ = die "update_runtypes" - - fun unify_with_toplevel_wordregion (cone, rhos) = - let val rhos = List.filter isWordRegion rhos - in foldl (fn (rho, cone) => - E.unifyRho(E.toplevel_region_withtype_word, rho) cone) - cone rhos - end - fun instClever (FORALL([],[],[],tau),il) cone = (tau, cone, [], []) | instClever (sigma as FORALL(rhos,epsilons,alphas,tau), il as (places,arreffs,types)) cone = let - (*val _ = Profile.profileOn();*) - (* set types of places according to rhos *) - val _ = update_runtypes(places, rhos) -(* - val _ = app (fn rho => case E.get_place_ty rho - of SOME E.WORD_RT => die "instClever.quantified word region!!" - | _ => ()) rhos -*) - val S = (BasisCompat.ListPair.zipEq(alphas,types), - BasisCompat.ListPair.zipEq(rhos,places), - BasisCompat.ListPair.zipEq(epsilons,arreffs)) + val S = (ListPair.zipEq(alphas,types), + ListPair.zipEq(rhos,places), + ListPair.zipEq(epsilons,arreffs)) handle _ => die "inst: type scheme and \ \instantiation list have different arity" val (Ty,cone,updates,spuriousPairs) = instAux(S, tau) cone @@ -923,16 +678,11 @@ struct val () = print (PP.flatten1(mk_lay_sigma false sigma) ^ "\n") in raise X end - - -(* val cone = unify_with_toplevel_wordregion (cone, places) *) in (Ty,cone,updates,spuriousPairs) end fun inst sigma_il cone = let val (a,cone,c,_) = instClever sigma_il cone - val places = #1(#2 sigma_il) - val cone = unify_with_toplevel_wordregion (cone, places) in (a,cone) end @@ -954,12 +704,6 @@ struct noSome (E.level_of effect) ".potentially_generalisable: not variable" > n - fun tickSomeBound () = () - fun tickNoBound () = () - - fun checkSigma (sigma as FORALL([],[],[],tau)) = (tickNoBound(); sigma) - | checkSigma sigma = (tickSomeBound(); sigma) - exception MONOMORPHIC of E.cone * sigma fun visit node = E.get_visited node := true @@ -974,12 +718,10 @@ struct then reachable_node :: acc else acc else acc) [] reachable_nodes - in - List.app unvisit principal_nodes; - - case secondary_epss of - [] => cone - | (x::xs) => List.foldl (fn (eps,cone) => E.unifyEps(eps,x) cone) cone xs + in List.app unvisit principal_nodes; + case secondary_epss of + [] => cone + | (x::xs) => List.foldl (fn (eps,cone) => E.unifyEps(eps,x) cone) cone xs end) (* partition_rhos rhos partitions rhos into region variables that have the @@ -987,47 +729,42 @@ struct fun skey rho = case E.get_place_ty rho of SOME rt => E.ord_runType rt | _ => die "skey" - fun partition_rhos (rhos:place list): place list list = - let val sorted_rhos = ListSort.sort (fn rho1 => fn rho2=> skey rho1 <= skey rho2) rhos + fun partition_rhos (rhos:place list) : place list list = + let val sorted_rhos = ListSort.sort (fn rho1 => fn rho2 => skey rho1 <= skey rho2) rhos fun runs ([],acc) = acc | runs (x::xs,(y::ys)::acc) = if skey x = skey y then runs(xs,(x::y::ys)::acc) else runs(xs,[x]::(y::ys)::acc) | runs (x::xs,nil::acc) = runs(xs,[x]::acc) | runs (x::xs,[]) = runs(xs,[x]::nil) -(* - fun runs [] = [] - | runs (x::xs) = - let val (run1, rest)= EdList.splitFirst (fn rho => skey rho <> skey x) xs (* DELETE *) - handle _ => (xs, []) - in (x::run1) :: runs rest - end -*) in runs (sorted_rhos,nil) end - fun unifyRhos (rhos as [], cone): place * cone = - die ".unifyRhos applied to empty list of region variables" - | unifyRhos (rho::rhos, cone) = - (rho, List.foldl (fn (rho',cone)=> E.unifyRho(rho',rho) cone) cone rhos) - - fun unify_rho_partition (cone0, partition: place list list): place list * E.cone = - List.foldr (fn ((l : place list), (representatives,cone)) => - let val (rho', cone) = unifyRhos(l, cone) - in (rho' :: representatives, cone) end - ) ([], cone0) partition - - fun unifyEpss (epss as [], cone): place * cone = - die ".unifyEpss applied to empty list of effect variables" - | unifyEpss (eps::epss, cone) = - (eps, List.foldl (fn (eps',cone) => - E.unifyEps(eps',eps) cone) cone epss) - - fun unify_eps_partition (cone0, partition: place list list): effect list * E.cone = - List.foldr (fn ((l : place list), (representatives,cone)) => - let val (eps', cone) = unifyEpss(l, cone) - in (eps' :: representatives, cone) end - )([], cone0) partition + local + fun unifyRhos (rhos as [], cone) : place * cone = + die ".unifyRhos applied to empty list of region variables" + | unifyRhos (rho::rhos, cone) = + (rho, List.foldl (fn (rho',cone)=> E.unifyRho(rho',rho) cone) cone rhos) + + fun unifyEpss (epss as [], cone) : place * cone = + die ".unifyEpss applied to empty list of effect variables" + | unifyEpss (eps::epss, cone) = + (eps, List.foldl (fn (eps',cone) => + E.unifyEps(eps',eps) cone) cone epss) + in + fun unify_rho_partition (cone, partition: place list list): place list * E.cone = + List.foldr (fn ((l : place list), (representatives,cone)) => + let val (rho, cone) = unifyRhos(l, cone) + in (rho :: representatives, cone) + end + ) ([], cone) partition + + fun unify_eps_partition (cone, partition: place list list): effect list * E.cone = + List.foldr (fn ((l : place list), (representatives,cone)) => + let val (eps, cone) = unifyEpss(l, cone) + in (eps :: representatives, cone) end + ) ([], cone) partition + end (* set_pix_primary(bound_primary, tau_nodes_in_fixed_order) assigns the pix field of each member of bound_primary to the leftmost position in tau_nodes_in_fixed_order at @@ -1057,22 +794,6 @@ struct fun set_pix_of_secondary_rhos rhos : unit = List.app (fn rho => (E.pix rho := skey rho * ~10)) rhos -(* - fun check_eff s e = - let fun check_rho s r = (* mael 2004-10-19 *) - let val k = E.key_of_eps_or_rho r - in if k = 1 andalso not(E.eq_effect(E.toplevel_region_withtype_top,r)) then - die ("check_eff: " ^ s) - else () - end - in - if E.is_put e orelse E.is_get e then - check_rho (s ^ ".putget") (E.rho_of e) - else if E.is_rho e then check_rho (s ^ ".rho") e - else () - end -*) - fun pr_mu s mu = print ("\n" ^ s ^ ": " ^ PP.flatten1(#2 (mk_layout false) mu) ^ "\n") @@ -1081,18 +802,8 @@ struct fun regEffClos0 (pr_lv, B: E.cone, B_0: int, phi: E.effect, tau: Type, ann: E.effect list) : E.cone * sigma = let - (*val _ = Profile.profileOn()*) -(* - val _ = logsay("\nregEffClos enter, tau = "); - val (lay_ty, _) = mk_layout false - val _ = PP.outputTree(logsay,lay_ty tau,!Flags.colwidth) -*) val n = B_0 -(* - val _ = print ("\nphi = " ^ PP.flatten1(E.layout_effect_deep phi) ^ "\n") -*) val B_1 = E.lower B_0 phi B - val annotations = ann_ty tau [] (* if there are no potentially generalisable nodes, we can escape right away, @@ -1101,29 +812,11 @@ struct else raise MONOMORPHIC(B_1,FORALL([],[],[],tau)) (* make sure there is at most one generalisable secondary effect variable *) - val reachable_nodes = E.subgraph annotations - -(* - val _ = app (check_eff "regEffClos2") reachable_nodes - handle X => - let - val _ = logsay("\nregEffClos enter, tau = "); - val (lay_ty, _) = mk_layout false - val _ = PP.outputTree(logsay,lay_ty tau,!Flags.colwidth) - val _ = print ("\nphi = " ^ PP.flatten1(E.layout_effect_deep phi) ^ "\n") - in raise X - end - *) - - val B_2 = unify_generic_secondary_epss(B_1,n,reachable_nodes, annotations) - -(* - val _ = app (check_eff "regEffClos3") reachable_nodes -*) + val B_2 = unify_generic_secondary_epss(B_1, n, E.subgraph annotations, annotations) val subgraph = E.contract_effects annotations - (* nodes in "subgraph" are listed in bottom-up order, without - duplicates *) + (* nodes in "subgraph" are listed in bottom-up order, without + duplicates *) val frv_tau = List.filter E.is_rho subgraph (* no duplicates in frv_tau *) val pfrv_tau = pfrv tau (* syntactic order *) @@ -1151,24 +844,11 @@ struct val epss_tvs = List.filter (potentially_generalisable n) (E.setminus(E.remove_duplicates ann,fev_tau)) -(* - val () = - case ann of - nil => () - | _ => pr_effects ("Quantified special effect vars for function " ^ pr_lv()) epss_tvs -*) - val bound_epss = List.filter (potentially_generalisable n) (fev_tau @ epss_tvs) (* bottom-up order *) val _ = set_pix_primary(E.setminus(bound_epss,problematic_secondary_fev_tau), pfev_tau @ epss_tvs) val sigma = FORALL(bound_rhos, bound_epss, [], tau) - - (* debugging - val _ = logsay("regEffClos leave, sigma = \n"); - val lay_sigma = mk_lay_sigma false - val _ = PP.outputTree(logsay,lay_sigma sigma,!Flags.colwidth) - *) in - (B_3, sigma) (*before Profile.profileOff()*) + (B_3, sigma) end handle MONOMORPHIC result => result | X => (print "regEffClos failed\n"; raise X) @@ -1201,19 +881,6 @@ struct in sigma' end -(* - fun alpha_rename'((rhos,epss,tau), B: E.cone): sigma = - let - val c = E.push B - val (rhos', c) = E.renameRhos(rhos,c) - val (epss', c) = E.renameEpss(epss,c) - val (tau',c) = inst (FORALL(rhos,epss,[],tau),(rhos',epss',[])) c - val sigma' = FORALL(rhos', epss', [], tau') - val (_, c) = E.pop c - in - sigma' - end -*) (* normalised type schemes: bound region and effect variables annotated with positions indicating where in the type they @@ -1227,50 +894,38 @@ struct fun pair_pix node = (node, !(E.pix node)) - fun intsort l = ListSort.sort (fn i: int => fn j: int => i<=j) l - fun show_int_list (l:int list) = concat (map (fn i => " " ^ Int.toString i)l) - - fun tell_int_list msg (l: int list) = - (logsay(msg ^ show_int_list l ^ "\n"); l) + fun intsort l = ListSort.sort (fn i:int => fn j => i<=j) l fun layout_sigma sigma = mk_lay_sigma false sigma fun alpha_equal (sigma1 as FORALL(rhos1,epsilons1,alphas1,tau1), sigma2 as FORALL(rhos2,epsilons2,alphas2,tau2)) cone : bool = (* MAEL MEMO: here we could probably also check equality of the instantiated effects associated with the alphas *) let val cone = E.push cone - (*val _ = logsay "enter alpha_equal\n" - val _ = logsay "sigma1=\n" - val _ = PP.outputTree(logsay,layout_sigma sigma1,!Flags.colwidth) - val _ = logsay "sigma2=\n" - val _ = PP.outputTree(logsay,layout_sigma sigma2,!Flags.colwidth) - *) val () = case (alphas1, alphas2) of (nil, nil) => () | _ => die "alpha_equal: quantified alphas not supported" val rhos_and_ints1 = map pair_pix rhos1 val rhos_and_ints2 = map pair_pix rhos2 - val epsilons_and_ints1 = map pair_pix epsilons1 val eps_indices = map #2 epsilons_and_ints1 + val epsilons_and_ints1 = map pair_pix epsilons1 + val eps_indices = map #2 epsilons_and_ints1 val epsilons_and_ints2 = map pair_pix epsilons2 in (map #2 rhos_and_ints1 = map #2 rhos_and_ints2 (* int list equality: bound region variables occur in the same syntactic positions in sigma1 and sigma2 *) andalso - ((* logsay "quantification of places in same positions\n";*) - (*tell_int_list "eps1_indices"*) (intsort(eps_indices)) = - (*tell_int_list "eps2_indices"*) (intsort(map #2 epsilons_and_ints2)) (* int list equality *) ) + ((intsort eps_indices) = (intsort(map #2 epsilons_and_ints2)) (* int list equality *) ) andalso let - (*val _ = logsay "same positions of bound effect vars\n"*) val (fresh_rhos, cone) = E.freshRhos(rhos1, cone) val (fresh_epss', cone) = E.freshEpss(epsilons1,cone) - val fresh_epss'_with_ints = BasisCompat.ListPair.zipEq(fresh_epss', eps_indices) + val fresh_epss'_with_ints = ListPair.zipEq(fresh_epss', eps_indices) val (fresh_epss'', cone) = E.freshEpss(epsilons1,cone) - val fresh_epss''_with_ints = BasisCompat.ListPair.zipEq(fresh_epss'', eps_indices) + val fresh_epss''_with_ints = ListPair.zipEq(fresh_epss'', eps_indices) val (fresh_rhos_of_epss, cone) = E.freshRhos(epsilons1, cone) val _ = List.app (fn (eps, rho) => E.edge(eps, E.mkPut rho)) - (BasisCompat.ListPair.zipEq(fresh_epss',fresh_rhos_of_epss)) + (ListPair.zipEq(fresh_epss',fresh_rhos_of_epss)) val _ = List.app (fn (eps, rho) => E.edge(eps, E.mkPut rho)) - (BasisCompat.ListPair.zipEq(fresh_epss'',fresh_rhos_of_epss)) + (ListPair.zipEq(fresh_epss'',fresh_rhos_of_epss)) val Se' = map (fn (bound_eps,ix) => (bound_eps, case List.find (fn (new_eps,ix') => ix=ix') fresh_epss'_with_ints of SOME (e,_) => e @@ -1279,7 +934,7 @@ struct epsilons_and_ints1 val (tau', cone, updates, _) = - instAux(([],BasisCompat.ListPair.zipEq(rhos1,fresh_rhos),Se'),tau1) cone + instAux(([],ListPair.zipEq(rhos1,fresh_rhos),Se'),tau1) cone handle x => (say "first call\n"; List.app (fn node => say(PP.flatten1(E.layout_effect node))) (rhos1 @ epsilons1); raise x) @@ -1292,27 +947,26 @@ struct epsilons_and_ints2 val (tau'', cone, updates, _) = - instAux(([],BasisCompat.ListPair.zipEq(rhos2,fresh_rhos), Se''),tau2) cone + instAux(([],ListPair.zipEq(rhos2,fresh_rhos), Se''),tau2) cone handle x => (say "second call\n"; List.app (fn node => say(PP.flatten1(E.layout_effect node))) (rhos2 @ epsilons2); raise x) in (List.all E.eq_effect - (BasisCompat.ListPair.zipEq - (E.remove_duplicates(pfrv tau'), - E.remove_duplicates(pfrv tau''))) - ) + (ListPair.zipEq + (E.remove_duplicates(pfrv tau'), + E.remove_duplicates(pfrv tau''))) + ) andalso ((*logsay "regions correspond\n";*) List.all E.sameEffect - (BasisCompat.ListPair.zipEq - (E.remove_duplicates(pfev tau'), - E.remove_duplicates(pfev tau''))) - ) + (ListPair.zipEq + (E.remove_duplicates(pfev tau'), + E.remove_duplicates(pfev tau''))) + ) end - ) footnote' (fn b => ((*logsay ("leave alpha_equal: " ^ Bool.string b ^ "\n");*) E.pop cone)) - end handle BasisCompat.ListPair.UnequalLengths => - ((*logsay "leave alpha_equal: false\n";*) false (*before say "zip raised"*) ) + ) footnote' (fn b => (E.pop cone)) + end handle ListPair.UnequalLengths => false (**************************) (* Matching type schemes *) @@ -1325,21 +979,17 @@ struct instantiation list, according to the partitioning given by origins. *) - fun select_and_unify (oldvars: '_var list, origins, unify, cone): '_var list * cone = - let - val a = Array.fromList oldvars - val var_classes = map (map (fn ix => Array.sub(a, ix))) origins - in - unify(cone, var_classes) + fun select_and_unify (oldvars: 'a list, origins, unify, cone): 'a list * cone = + let val a = Array.fromList oldvars + val var_classes = map (map (fn ix => Array.sub(a, ix))) origins + in unify(cone, var_classes) end handle _ => raise FAIL_MATCH "select_and_unify" fun mk_transformer (origins as (rho_origins: int list list, eps_origins: int list list)) ((old_rhos:place list, old_epss:effect list,taus), cone) : il * cone = - let - val (new_rhos, cone) = select_and_unify(old_rhos,rho_origins,unify_rho_partition,cone) - val (new_epss, cone) = select_and_unify(old_epss, eps_origins, unify_eps_partition, cone) - in - ((new_rhos,new_epss,taus), cone) + let val (new_rhos, cone) = select_and_unify(old_rhos, rho_origins, unify_rho_partition, cone) + val (new_epss, cone) = select_and_unify(old_epss, eps_origins, unify_eps_partition, cone) + in ((new_rhos,new_epss,taus), cone) end (* l:int list = find_origin(vars : effect list)(var': effect) @@ -1350,15 +1000,13 @@ struct scheme. *) fun find_origin vars var' = - let - fun search(ix, vars as [], acc) = (acc:int list) - | search(ix, var::vars,acc) = - if E.eq_effect(var, var') (* intuitively: var was mapped to var' by the - instantiating substitution *) - then search(ix+1,vars,ix::acc) - else search(ix+1,vars,acc) - in - search(0,vars,[]) + let fun search (ix, vars as [], acc) = (acc:int list) + | search (ix, var::vars,acc) = + if E.eq_effect(var, var') (* intuitively: var was mapped to var' by the + instantiating substitution *) + then search(ix+1,vars,ix::acc) + else search(ix+1,vars,acc) + in search(0,vars,[]) end (* vars2 = select_empty(origins, vars1) @@ -1375,10 +1023,9 @@ struct *) fun enumerate l = - let fun loop(ix, []) = [] - | loop(ix, _ :: xs) = [ix] :: loop(ix+1,xs) - in - loop(0, l) + let fun loop (ix, []) = [] + | loop (ix, _ :: xs) = [ix] :: loop(ix+1,xs) + in loop(0, l) end (* (transformer: il * cone -> il * cone) = matchSchemes(sigma, sigma') @@ -1402,50 +1049,38 @@ struct fun failwith (x,sigma,sigma') = (fail_aux(sigma,sigma'); - raise x - ) + raise x) fun matchSchemes (sigma as FORALL(rhos, epss,[],tau), sigma' as FORALL(rhos', epss',[],tau')) : (il * cone) -> (il * cone) = - (let - (* debugging - val lay_sigma = mk_lay_sigma false - val _ = logsay("matchSchemes enter, sigma = \n"); - val _ = PP.outputTree(logsay,lay_sigma sigma,!Flags.colwidth) - val _ = logsay("\nmatchSchemes enter, sigma' = \n"); - val _ = PP.outputTree(logsay,lay_sigma sigma',!Flags.colwidth) - *) - val rhos'_origins = map (find_origin rhos) rhos' - val add_rhos = select_empty(rhos'_origins, rhos') - - (* val _ = logsay("\nadd_rhos = " ^ show_rhos add_rhos ^ "\n"); debugging*) - - val rhos'_origins_extended = - case add_rhos of - [] => (* common special case: *) rhos'_origins - | _ => merge(enumerate add_rhos, + (let + val rhos'_origins = map (find_origin rhos) rhos' + val add_rhos = select_empty(rhos'_origins, rhos') + + val rhos'_origins_extended = + case add_rhos of + [] => rhos'_origins (* common special case *) + | _ => merge(enumerate add_rhos, map (map(add(List.length add_rhos))) rhos'_origins) - val epss'_origins = map (find_origin epss) epss' - val add_epss = select_empty(epss'_origins, epss') - val epss'_origins_extended = - case add_epss of - [] => (* common special case: *) epss'_origins - | _ => merge(enumerate add_epss, - map (map(add(List.length add_epss))) epss'_origins) + val epss'_origins = map (find_origin epss) epss' + val add_epss = select_empty(epss'_origins, epss') + val epss'_origins_extended = + case add_epss of + [] => epss'_origins (* common special case *) + | _ => merge(enumerate add_epss, + map (map(add(List.length add_epss))) epss'_origins) - val thin = mk_transformer(rhos'_origins_extended, epss'_origins_extended) - in - fn ((old_rhos, old_epss, old_taus), cone) => - (let val (new_rhos, cone) = E.cloneRhos(add_rhos, cone) - val (new_epss, cone) = E.cloneEpss(add_epss, cone) - in - thin ((new_rhos@old_rhos, new_epss @ old_epss, old_taus), cone) - end handle x => failwith (x,sigma,sigma')) - end handle x => failwith(x,sigma,sigma') - ) - | matchSchemes _ = raise FAIL_MATCH "matchSchemes: type scheme had bound type variables" + val thin = mk_transformer(rhos'_origins_extended, epss'_origins_extended) + in + fn ((old_rhos, old_epss, old_taus), cone) => + (let val (new_rhos, cone) = E.cloneRhos(add_rhos, cone) + val (new_epss, cone) = E.cloneEpss(add_epss, cone) + in thin ((new_rhos@old_rhos, new_epss @ old_epss, old_taus), cone) + end handle x => failwith (x,sigma,sigma')) + end handle x => failwith(x,sigma,sigma')) + | matchSchemes _ = raise FAIL_MATCH "matchSchemes: type scheme had bound type variables" (* Whether word32 and int32 (and word64 and int64) types are boxed @@ -1499,140 +1134,83 @@ struct c_function_effects mu = the `rhos_for_result' to be annotated on a ccall with return type-and-place mu; see comment in MUL_EXP.*) - - (*unify_rhos_on_same_tyvars mu = for each pair of occurences of - (tyvar, rho1) & (tyvar, rho2), unify rho1 & rho2. To do this, an - environment ttr maps a tyvar that has been seen before to the rho - it was seen with.*) - - fun unify_rhos_on_same_tyvars mu B = #2 (unify_rhos_on_same_tyvars0 (mu, - (L.TyvarMap.empty : place L.TyvarMap.map, B : cone))) - and unify_rhos_on_same_tyvars0 ((tau, rho), (ttr, B)) = - (case tau of - TYVAR tyvar => - (case L.TyvarMap.lookup ttr tyvar of - SOME rho' => (ttr, E.unifyRho (rho, rho') B) - | NONE => (L.TyvarMap.add (tyvar, rho, ttr), B)) - | CONSTYPE (tyname, mus, _, _) => - unify_rhos_on_same_tyvars00 (mus, (ttr, B)) - | RECORD mus => unify_rhos_on_same_tyvars00 (mus, (ttr, B)) - | FUN (mus1, _, mus2) => - unify_rhos_on_same_tyvars00 (mus1, - (unify_rhos_on_same_tyvars00 (mus2, (ttr, B))))) - and unify_rhos_on_same_tyvars00 (mus, (ttr, B)) = - List.foldl unify_rhos_on_same_tyvars0 (ttr, B) mus - (*c_function_effects mus = the `rhos_for_result' to be annotated on a ccall; see comment in MUL_EXP.*) local fun size_of_tyname tyname = - if TyName.unboxed tyname then SOME 0 - else if TyName.eq (tyname, TyName.tyName_REAL) then - SOME (RegConst.size_of_real ()) - else if (TyName.eq (tyname, TyName.tyName_WORD32) - orelse TyName.eq (tyname, TyName.tyName_INT32) - orelse TyName.eq (tyname, TyName.tyName_INT64) - orelse TyName.eq (tyname, TyName.tyName_WORD64)) then - (* boxed because RegConst.unboxed_tyname(tyname) returned false! *) - SOME (RegConst.size_of_record [1]) (* 2001-02-17, Niels - dummy list [1] with one element! *) - else if (TyName.eq (tyname, TyName.tyName_STRING) - orelse TyName.eq (tyname, TyName.tyName_CHARARRAY) - orelse TyName.eq (tyname, TyName.tyName_ARRAY) - orelse TyName.eq (tyname, TyName.tyName_VECTOR)) then NONE - else die ("S (CCALL ...): \nI am sorry, but c functions returning " - ^ TyName.pr_TyName tyname - ^ " are not supported yet.\n") - - fun below_list _ = NONE (*i.e., `yes, we are below a list constructor'*) - - fun c_function_effects1 in_list ((tau_schema,_),(tau, rho)) = - case (tau_schema, tau) - of (TYVAR _, _) => [] - | (CONSTYPE (_, mus_schema, _, _), CONSTYPE (tyname, mus, rhos, epss)) => - if TyName.eq (tyname, TyName.tyName_LIST) then - (case (mus_schema, mus, rhos) of - ([mu1_schema], [mu1], [rho1]) => - (*rho is for cons cells & rho1 is for auxiliary pairs*) - [(rho, NONE), (rho1, NONE)] @ c_function_effects1 below_list (mu1_schema,mu1) - | _ => die "c_function_effects1: strange list type") - else [(rho, in_list (size_of_tyname tyname))] - | (RECORD nil, RECORD nil) => [(rho, SOME 0)] (*unit is not allocated*) - | (RECORD mus_schema, RECORD mus) => - (rho, in_list (SOME (RegConst.size_of_record mus))) - :: List.concat (map (c_function_effects1 in_list) (BasisCompat.ListPair.zipEq(mus_schema,mus) - handle _ => die "c_function_effects1.zip")) - (*it is assumed that List.concat does not concat the lists in - opposite order, i.e., that concat_list [[1,2], [3], [4]] is - [1,2,3,4] and not [4,3,1,2]*) - | (FUN _, FUN (mus, eps0, mus')) => die "c_function_effects1 (FUN ...)" - | _ => die "c_function_effects1: schema does not match instance" - in - fun c_function_effects (FORALL(_,_,_,tau), mu) : (place * int option) list = - case tau - of FUN(_,_,[mu_schema]) => c_function_effects1 (fn i=>i) (mu_schema, mu) - | _ => die "c_function_effects.expecting function type with one return value" - end - - local - fun add_rho (rho,acc) = - case E.get_place_ty rho of - SOME E.WORD_RT => acc - | SOME _ => if !(E.get_visited rho) then acc - else (E.get_visited rho := true; rho::acc) - | NONE => die "add_rho" - fun add_rhos (rhos,acc) = foldl add_rho acc rhos - fun fv_mus (mus,acc) = foldl fv_mu acc mus - and fv_mu ((tau,rho),acc) = - case tau of - TYVAR tyvar => acc - | CONSTYPE (tyname, mus, rhos, nil) => fv_mus(mus,add_rho(rho,add_rhos(rhos,acc))) - | CONSTYPE (tyname, _, _, _) => die "frv_except_tyvar_rhos.non-empty arrow-effect set" - | RECORD mus => fv_mus(mus,add_rho(rho,acc)) - | FUN (mus, eps0, mus') => acc - (*die "frv_except_tyvar_rhos1"*) - (* support 'pointer' : 'a -> foreignptr function with 'a instantiated to a function *) + if TyName.unboxed tyname then SOME 0 + else if TyName.eq (tyname, TyName.tyName_REAL) then + SOME (RegConst.size_of_real ()) + else if (TyName.eq (tyname, TyName.tyName_WORD32) + orelse TyName.eq (tyname, TyName.tyName_INT32) + orelse TyName.eq (tyname, TyName.tyName_INT64) + orelse TyName.eq (tyname, TyName.tyName_WORD64)) then + (* boxed because RegConst.unboxed_tyname(tyname) returned false! *) + SOME (RegConst.size_of_record [1]) (* 2001-02-17, Niels - dummy list [1] with one element! *) + else if (TyName.eq (tyname, TyName.tyName_STRING) + orelse TyName.eq (tyname, TyName.tyName_CHARARRAY) + orelse TyName.eq (tyname, TyName.tyName_ARRAY) + orelse TyName.eq (tyname, TyName.tyName_VECTOR)) then NONE + else die ("S (CCALL ...): \nI am sorry, but c functions returning " + ^ TyName.pr_TyName tyname + ^ " are not supported yet.\n") + + fun c_function_effects1 {below:bool} (tau_schema,tau) : (place * int option) list = + (* tau: result type instance; tau_schema: result type schema *) + case (tau_schema, tau) of + (TYVAR _, _) => [] + | (CONSTYPE (_, mus_schema, _, _), CONSTYPE (tyname, mus, rhos, epss)) => + if TyName.eq (tyname, TyName.tyName_LIST) then + (case (mus_schema, mus, rhos) of + ([mu1_schema], [mu1], [rho1]) => (* rho1 is for auxiliary pairs *) + (rho1, NONE) :: c_function_effects1 {below=true} (mu1_schema,mu1) + | _ => die "c_function_effects1: strange list type") + else [] + | (BOX(CONSTYPE (_, mus_schema, _, _),_), BOX(CONSTYPE (tyname, mus, rhos, epss),rho)) => + [(rho, if below then NONE else size_of_tyname tyname)] + | (RECORD nil, RECORD nil) => [] (*unit is not allocated*) + | (BOX(RECORD mus_schema,_), BOX(RECORD mus,rho)) => + (rho, if below then NONE else SOME (RegConst.size_of_record mus)) + :: List.concat (map (c_function_effects1 {below=below}) + (ListPair.zipEq(mus_schema,mus) + handle _ => die "c_function_effects1.zip")) + (*it is assumed that List.concat does not concat the lists in + opposite order, i.e., that concat_list [[1,2], [3], [4]] is + [1,2,3,4] and not [4,3,1,2]*) + | (FUN _, FUN (mus, eps0, mus')) => die "c_function_effects1 (FUN ...)" + | _ => die "c_function_effects1: schema does not match instance" in - fun frv_except_tyvar_rhos mus = - let val rhos = fv_mus (mus, nil) - in rhos before app (fn r => E.get_visited r := false) rhos - end + fun c_function_effects (FORALL(_,_,_,tau), mu:mu) : (place * int option) list = + case tau of + FUN(_,_,[mu_schema]) => c_function_effects1 {below=false} (mu_schema, mu) + | _ => die "c_function_effects.expecting function type with one return value" end - fun sigma_for_c_function tyvars mu B = - let val B = unify_rhos_on_same_tyvars mu B - val tyvars = map (fn tv => (tv,NONE)) tyvars - in - (case mu of - (FUN (mus1, eps0, mus2), rho) => - let (* val _ = pr_mu "cf1" mu *) - val rhos_get = frv_except_tyvar_rhos mus1 - val rhos_put = frv_except_tyvar_rhos mus2 -(* val _ = pr_effects "rhos_get" rhos_get - val _ = pr_effects "rhos_put" rhos_put -*) - val _ = - case map E.mkGet rhos_get @ map E.mkPut rhos_put of - nil => () - | rhos_gets_puts => - (*insert effects on the arrow in mu*) - E.edge (eps0, E.mkUnion rhos_gets_puts) - in - let (* val _ = pr_mu "cf2" mu *) - val (B, sigma) = generalize_all (B, 0, tyvars, #1 mu) - handle X => (print ("generalize_all failed\n"); raise X) - in (sigma, B) - end + fun sigma_for_c_function tyvars ty B = + let val tyvars = map (fn tv => (tv,NONE)) tyvars + in case ty of + FUN (mus1, eps0, mus2) => + let val rhos_get = pfrvMus mus1 + val rhos_put = pfrvMus mus2 + val _ = + case map E.mkGet rhos_get @ map E.mkPut rhos_put of + nil => () + | rhos_gets_puts => (*insert effects on the arrow in mu*) + E.edge (eps0, E.mkUnion rhos_gets_puts) + in + let val (B, sigma) = generalize_all (B, 0, tyvars, ty) + handle X => (print ("generalize_all failed\n"); raise X) + in (sigma, B) end - | _ => die "sigma_for_c_function") - end + end + | _ => die "sigma_for_c_function" + end (* Picklers *) - val pu_mu : Type Pickle.pu -> (Type * place) Pickle.pu - = Pickle.cache "mu" (fn pu_Type => Pickle.nameGen "RType.mu" - (Pickle.pairGen(pu_Type,E.pu_effect))) + val pu_mu : Type Pickle.pu -> mu Pickle.pu = fn x => x - val pu_mus : Type Pickle.pu -> (Type * place) list Pickle.pu + val pu_mus : Type Pickle.pu -> mu list Pickle.pu = Pickle.cache "mus" (Pickle.nameGen "RType.mus" o Pickle.listGen o pu_mu) val pu_Type = @@ -1640,6 +1218,7 @@ struct | toInt (CONSTYPE _) = 1 | toInt (RECORD _) = 2 | toInt (FUN _) = 3 + | toInt (BOX _) = 4 fun fun_TYVAR _ = Pickle.con1 TYVAR (fn TYVAR a => a | _ => die "pu_Type.TYVAR") L.pu_tyvar @@ -1653,7 +1232,12 @@ struct Pickle.debugUnpickle "FUN" (Pickle.con1 FUN (fn FUN a => a | _ => die "pu_Type.FUN") (Pickle.tup3Gen0(pu_mus pu_Type,E.pu_effect,pu_mus pu_Type))) - in Pickle.dataGen("RType.Type",toInt,[fun_TYVAR,fun_CONSTYPE,fun_RECORD,fun_FUN]) + fun fun_BOX pu_Type = + Pickle.debugUnpickle "BOX" + (Pickle.con1 BOX (fn BOX a => a | _ => die "pu_Type.BOX") + (Pickle.pairGen0(pu_Type,E.pu_effect))) + + in Pickle.dataGen("RType.Type",toInt,[fun_TYVAR,fun_CONSTYPE,fun_RECORD,fun_FUN,fun_BOX]) end val pu_mu = pu_mu pu_Type @@ -1661,8 +1245,7 @@ struct val pu_sigma = Pickle.convert (FORALL, fn FORALL a => a) (Pickle.tup4Gen0(E.pu_effects,E.pu_effects,pu_tyvars,Pickle.debugUnpickle "Type" pu_Type)) - -end; (* RType ends here *) +end (* functor TestRType() = diff --git a/src/Compiler/Regions/RegFlow.sml b/src/Compiler/Regions/RegFlow.sml index 8ad3e00b4..9119e75be 100644 --- a/src/Compiler/Regions/RegFlow.sml +++ b/src/Compiler/Regions/RegFlow.sml @@ -155,15 +155,13 @@ struct fun connect_to_global rho : unit= case Eff.get_place_ty rho of - SOME Eff.WORD_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_word) - | SOME Eff.STRING_RT => add_edge_iter(rho,Eff.toplevel_region_withtype_string) + 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_word); 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); @@ -339,7 +337,7 @@ struct | SELECT(_, tr) => mk_graph tr | DEREF tr => mk_graph tr | REF(_,tr) => mk_graph tr - | ASSIGN(_,tr1,tr2) => (mk_graph tr1; mk_graph tr2) + | ASSIGN(tr1,tr2) => (mk_graph tr1; mk_graph tr2) | EQUAL(_,tr1, tr2) => (mk_graph tr1; mk_graph tr2) | CCALL(_,trs) => List.app mk_graph trs | RESET_REGIONS(_,tr) => mk_graph tr diff --git a/src/Compiler/Regions/RegInf.sml b/src/Compiler/Regions/RegInf.sml index fc41cf55b..5b359e00d 100644 --- a/src/Compiler/Regions/RegInf.sml +++ b/src/Compiler/Regions/RegInf.sml @@ -75,12 +75,10 @@ struct let val free_rhos_and_epss = ann_mus mus [] val B' = foldl (uncurry (Effect.lower(Effect.level B - 1))) B free_rhos_and_epss handle _ => die "Below.lower failed\n" - in - popAndClean B' - handle _ => die "Below.popAndClean failed\n" + in popAndClean B' + handle _ => die "Below.popAndClean failed\n" end - fun retract (B, body as Exp.TR(e, Exp.Mus mus, phi), delta_phi_body: Effect.delta_phi, discharged_basis: effect list ref, @@ -106,9 +104,7 @@ struct end | retract (B, t,_,_,_,_) = (B, delta_emp) - - - fun inferEffects (device: string -> unit) = + fun inferEffects (device: string -> unit) : cone * rse * (place,unit)Exp.trip -> cone = let val layoutExp = Exp.layoutLambdaExp(if print_regions() then (fn rho => SOME(PP.LEAF("at " @@ -181,19 +177,23 @@ struct fun gc_compute_delta (rse,free,(ty0,rho0)) = if dangling_pointers() then (delta_emp,nil) else - let + let val fv_sigma = RType.ferv_sigma (*was: frv_sigma*) - fun effects_lv (lv, acc: effect list) : effect list = - case RSE.lookupLvar rse lv - of SOME(_,_,_,sigma,p,_,_) => p :: fv_sigma sigma @ acc - | NONE => die "gc_compute_delta.effects_lv" - fun effects_ex (ex, acc: effect list) : effect list = - case RSE.lookupExcon rse ex - of SOME (ty,p) => p :: fv_sigma (RType.type_to_scheme ty) @ acc - | NONE => die "gc_compute_delta.effects_ex" - val (lvs,exs) = case free - of SOME p => p - | NONE => die "gc_compute_delta.free variables not annotated" + fun effects_lv (lv, acc: effect list) : effect list = + case RSE.lookupLvar rse lv of + SOME(_,_,_,sigma,SOME p,_,_) => p :: fv_sigma sigma @ acc + | SOME(_,_,_,sigma,NONE,_,_) => fv_sigma sigma @ acc + | NONE => die "gc_compute_delta.effects_lv" + fun effects_ex (ex, acc: effect list) : effect list = + case RSE.lookupExcon rse ex of + SOME mu => + (case RType.unBOX mu of + SOME(ty,p) => p :: fv_sigma (RType.type_to_scheme ty) @ acc + | NONE => fv_sigma (RType.type_to_scheme mu) @ acc) + | NONE => die "gc_compute_delta.effects_ex" + val (lvs,exs) = case free of + SOME p => p + | NONE => die "gc_compute_delta.free variables not annotated" (* fun warn s = print ("**WARNING: " ^ s ^ "\n") @@ -236,53 +236,51 @@ struct spurious_tyvars end - val effects = Effect.remove_duplicates effects - - val effects_not = - [rho0, - Effect.toplevel_arreff, - Effect.toplevel_region_withtype_top, - Effect.toplevel_region_withtype_bot, - Effect.toplevel_region_withtype_word, - Effect.toplevel_region_withtype_string, - Effect.toplevel_region_withtype_pair, - Effect.toplevel_region_withtype_array, - Effect.toplevel_region_withtype_ref, - Effect.toplevel_region_withtype_triple] @ - RType.ferv_sigma(RType.type_to_scheme ty0) - val effects = Effect.setminus(effects, effects_not) - - val effects = map (fn e => if Effect.is_rho e then Effect.mkGet e - else if Effect.is_put e orelse Effect.is_get e then - die "gc_compute_delta.put or get" - else e) effects - val _ = app (fn e => if Effect.is_rho e then die "gc_compute_delta.is_rho" - else ()) effects + val effects = Effect.remove_duplicates effects + + val effects_not = + [rho0, + Effect.toplevel_arreff, + Effect.toplevel_region_withtype_top, + Effect.toplevel_region_withtype_bot, + Effect.toplevel_region_withtype_string, + Effect.toplevel_region_withtype_pair, + Effect.toplevel_region_withtype_array, + Effect.toplevel_region_withtype_ref, + Effect.toplevel_region_withtype_triple] @ + RType.ferv_sigma(RType.type_to_scheme ty0) + val effects = Effect.setminus(effects, effects_not) + + val effects = map (fn e => if Effect.is_rho e then Effect.mkGet e + else if Effect.is_put e orelse Effect.is_get e then + die "gc_compute_delta.put or get" + else e) effects + val _ = app (fn e => if Effect.is_rho e then die "gc_compute_delta.is_rho" + else ()) effects (* - val _ = print ("New effects are " ^ PP.flatten1 (PP.layout_list Effect.layout_effect_deep effects) ^ "\n") + val _ = print ("New effects are " ^ PP.flatten1 (PP.layout_list Effect.layout_effect_deep effects) ^ "\n") *) - (* Statistics *) - fun incr r n = r := !r + n - val _ = if length effects > 0 then + (* Statistics *) + fun incr r n = r := !r + n + val _ = if length effects > 0 then (gc_arrow_effect_update := true; - incr Flags.Statistics.no_dangling_pointers_changes 1; - incr Flags.Statistics.no_dangling_pointers_changes_total (length effects)) - else () - in (Effect.Lf effects, es_tvs) - end + incr Flags.Statistics.no_dangling_pointers_changes 1; + incr Flags.Statistics.no_dangling_pointers_changes_total (length effects)) + else () + in (Effect.Lf effects, es_tvs) + end val effects_not = - [Effect.toplevel_arreff, - Effect.toplevel_region_withtype_top, - Effect.toplevel_region_withtype_bot, - Effect.toplevel_region_withtype_word, - Effect.toplevel_region_withtype_string, - Effect.toplevel_region_withtype_pair, - Effect.toplevel_region_withtype_array, - Effect.toplevel_region_withtype_ref, - Effect.toplevel_region_withtype_triple] - - fun R (B:cone, rse: rse, t as Exp.TR(e, mt: Exp.metaType, phi: effect)): cone * Effect.delta_phi = + [Effect.toplevel_arreff, + Effect.toplevel_region_withtype_top, + Effect.toplevel_region_withtype_bot, + Effect.toplevel_region_withtype_string, + Effect.toplevel_region_withtype_pair, + Effect.toplevel_region_withtype_array, + Effect.toplevel_region_withtype_ref, + Effect.toplevel_region_withtype_triple] + + fun R (B:cone, rse: rse, (t as Exp.TR(e, mt: Exp.metaType, phi: effect)) : (place,unit)Exp.trip) : cone * Effect.delta_phi = let (* val () = if !count_visited mod 100 = 0 then @@ -311,7 +309,7 @@ struct let val (il, B) = f(il, B) in il_r:= (il, fn p => p); (case RSE.lookupLvar rse lvar of - SOME(_,_,_,sigma,place0,_, _) => + SOME(_,_,_,sigma,_,_, _) => let val (tau_1, B, updates: (effect * Effect.delta_phi)list, spuriousPairs: (effect * RType.Type)list) = instClever (sigma,il) B @@ -320,8 +318,9 @@ struct PP.flatten1(RType.mk_lay_sigma false sigma) ^ "\n") val B = case mt of - Exp.Mus [(tau, _)] => - let val B' = unify_ty (tau,tau_1) B handle _ => die "unify_ty failed\n" + Exp.Mus [mu] => + let val tau = case RType.unBOX mu of SOME (ty,_) => ty | NONE => mu + val B' = unify_ty (tau,tau_1) B handle _ => die "unify_ty failed\n" in List.app update_increment updates; List.app (update_areff o #1) updates (* takes time; mael 2015-05-07 *) handle _ => die "update_areff in VAR case"; @@ -346,10 +345,10 @@ struct *) val effs = effs' @ effs val effs = Effect.setminus(effs, effects_not) - val effs = map (fn e => if Effect.is_rho e then Effect.mkGet e - else if Effect.is_put e orelse Effect.is_get e then - die "R.VAR.put or get" - else e) effs + val effs = map (fn e => if Effect.is_rho e then Effect.mkGet e + else if Effect.is_put e orelse Effect.is_get e then + die "R.VAR.put or get" + else e) effs val effs = Effect.remove_duplicates effs in (e,Effect.Lf effs) end) @@ -388,31 +387,39 @@ struct (B,delta_emp) ts | Exp.FN{pat, body, alloc, free} => (case mt of - Exp.Mus [mu0 as (ty,_)] => - (case RType.unFUN ty of - SOME(mus2,eps_phi0,mus1) => - let - val rse' = foldl (fn ((lvar, mu as (tau,rho)), rse) => - RSE.declareLvar(lvar, (false,false,[], - RType.type_to_scheme tau, rho,NONE,NONE), - rse)) rse - (ListPair.zip(map #1 pat, mus2)) - val (B, delta_body) = R(B,rse', body) - val (delta_gc,es_tvs) = gc_compute_delta(rse,free,mu0) - val B = List.foldl (fn (e,B) => Effect.unifyEps (eps_phi0,e) B) B es_tvs - val delta = delta_body && delta_gc - val lev_eps = case Effect.level_of eps_phi0 of - SOME n => n - | NONE => die "bad arrow effect (FN)" - val B = lower_delta lev_eps delta B - in - update_increment(eps_phi0, delta); - update_areff eps_phi0; (* takes time; mael 2015-05-07 *) - (B, delta_emp) - end - | NONE => die "R: FN expression had bad meta type") - | _ => die "R: FN expression had bad meta type") - + Exp.Mus [mu0] => + (case RType.unBOX mu0 of + SOME(ty,rho) => + (case RType.unFUN ty of + SOME(mus2,eps_phi0,mus1) => + let + val rse' = foldl (fn ((lvar, mu), rse) => + let val (tau,rho) = + case RType.unBOX mu of + SOME(ty,rho) => (ty,SOME rho) + | NONE => (mu,NONE) + in RSE.declareLvar(lvar, (false,false,[], + RType.type_to_scheme tau, + rho,NONE,NONE), + rse) + end) rse + (ListPair.zip(map #1 pat, mus2)) + val (B, delta_body) = R(B,rse', body) + val (delta_gc,es_tvs) = gc_compute_delta(rse,free,(ty,rho)) + val B = List.foldl (fn (e,B) => Effect.unifyEps (eps_phi0,e) B) B es_tvs + val delta = delta_body && delta_gc + val lev_eps = case Effect.level_of eps_phi0 of + SOME n => n + | NONE => die "bad arrow effect (FN)" + val B = lower_delta lev_eps delta B + in + update_increment(eps_phi0, delta); + update_areff eps_phi0; (* takes time; mael 2015-05-07 *) + (B, delta_emp) + end + | NONE => die "R: FN expected function type") + | NONE => die "R: FN expected boxed function type") + | _ => die "R: FN expression had bad meta type") | Exp.LETREGION_B{B = B1, discharged_phi, body} => let @@ -445,8 +452,8 @@ struct | Exp.LET{pat = nil, bind = bind, scope} => (* wild card *) let val (B,d1) = R(B,rse,bind) val (B,d2) = R(B,rse,scope) - in (B, d1 && d2) - end + in (B, d1 && d2) + end | Exp.LET _ => die "LET.multiple bindings not implemented." | Exp.FIX{shared_clos = rho0, functions, @@ -459,15 +466,18 @@ struct let val sigma = RType.FORALL(rhovec,epsvec,[],tau0) val rse = foldl (fn ((tv,NONE),rse) => rse | ((tv,SOME e),rse) => RSE.declareTyVar (tv,e,rse)) rse alphavec - in RSE.declareLvar(f,(true,true,[],sigma, rho0, SOME occ, NONE),rse) + in RSE.declareLvar(f,(true,true,[],sigma, SOME rho0, SOME occ, NONE),rse) end fun doOneRhs rse {lvar = f,occ,tyvars = alphasr as ref alphavec, rhos = rhosr as ref rhovec, epss = epssr as ref epsvec, Type = tau0, formal_regions, - bind as Exp.TR(_,Exp.Mus[(tau4,rho4)],phi4)} = + bind as Exp.TR(_,Exp.Mus[mu4],phi4)} = let - fun Rrec (B3,sigma_3hat,previous_functions_ok:bool) = + val (tau4,rho4) = case RType.unBOX mu4 of + SOME p => p + | NONE => die "doOneRhs.expecting boxed mu" + fun Rrec (B3,sigma_3hat,previous_functions_ok:bool) = let (* val _ = sayLn("fix:entering Rrec " ^ Lvar.pr_lvar f ^ ":" ^ show_sigma sigma_3hat) @@ -478,9 +488,9 @@ struct handle _ => die("failed to rename type scheme " ^ show_sigma sigma_3hat) (* - val _ = sayLn("after rename , sigma is " ^ show_sigma sigma3_hat_save) + val _ = sayLn("after rename , sigma is " ^ show_sigma sigma3_hat_save) *) - val rse' = RSE.declareLvar(f,(true,true,[],(*sigma3_hat_save*) sigma_3hat, rho0, SOME occ, NONE),rse) (*mads 5/2/97*) + val rse' = RSE.declareLvar(f,(true,true,[],(*sigma3_hat_save*) sigma_3hat, SOME rho0, SOME occ, NONE),rse) (*mads 5/2/97*) val bv_sigma3_hat as (rhos,epsilons,_) = RType.bv sigma_3hat val B3' = pushLayer(sort(epsilons@rhos), B3) handle _ => die "pushLayer failed\n" @@ -501,7 +511,7 @@ struct *) val (_, B5) = pop B5 val (newrhos,newepss,_) = RType.bv sigma_5hat - (* val _ = sayLn("sigma_5hat is " ^ show_sigma (sigma_5hat)) *) + (* val _ = sayLn("sigma_5hat is " ^ show_sigma (sigma_5hat)) *) (*val _ = Profile.profileOn();*) fun update_quantified_effectvars () = if eq_effects (!epssr, newepss) then () @@ -514,15 +524,6 @@ struct (!epssr) val () = epssr := newepss val newalphavec = !alphasr -(* map (fn (tv, NONE) => (tv,NONE) - | (tv, SOME e) => (* find the effectvar in tau0 and return the corresponding effectvar in tau5_hat *) - if List.exists (fn e' => Effect.eq_effect(e,e')) changed then - case RType.locate_arrow_effect e tau0 tau4 of - SOME e => (tv, SOME e) - | NONE => die "update_quantified_effectvars; maybe unify effect variables" - else (tv,SOME e) - ) alphavec -*) in alphasr := newalphavec end) @@ -550,7 +551,7 @@ struct ^ Lvar.pr_lvar f ^ "\n" ^ msg) in (* update bindings in syntax tree *) - (*sayLn("fix: looping for " ^ Lvar.pr_lvar f);*) + (*sayLn("fix: looping for " ^ Lvar.pr_lvar f);*) (*log_sigma(RType.insert_alphas(alphavec,sigma_5hat), f);*) rhosr:= newrhos; update_quantified_effectvars(); @@ -560,7 +561,7 @@ struct in (fn B => Rrec(B, RType.FORALL(rhovec,epsvec,[],tau0),true)) end - | doOneRhs _ _ = die "doOneRhs.wrong bind" + | doOneRhs _ _ = die "doOneRhs.wrong bind" fun loop {B, fcn=[], previous_were_ok=true, rse} = B | loop {B, fcn=[], previous_were_ok=false, rse} = loop {B=B,fcn=functions,previous_were_ok=true,rse=rse} @@ -574,25 +575,28 @@ struct rhos as ref rhovec, epss as ref epsvec, Type = tau0, formal_regions,bind}, rse) = let val sigma1hat' = RType.FORALL(rhovec,epsvec,alphavec,tau0) - in RSE.declareLvar(f,(true,true,[],sigma1hat', rho0, SOME occ, NONE),rse) + in RSE.declareLvar(f,(true,true,[],sigma1hat', SOME rho0, SOME occ, NONE),rse) end val B1 = loop {B=B,fcn=functions,previous_were_ok=true, rse=foldl addBindingForRhs rse functions} val rse' = foldl addBindingForScope rse functions in - R(B1, rse', t2) + R(B1, rse', t2) end | Exp.APP(t1,t2) => let val (B,d1) = R(B,rse,t1) val eps_phi0 = case t1 of - Exp.TR(_, Exp.Mus [(ty,_)],_) => - (case RType.unFUN ty of - SOME(_,eps_phi0,_) => eps_phi0 - | NONE => die "APP: not function") - | _ => die "APP: not function" + Exp.TR(_, Exp.Mus [mu],_) => + (case RType.unBOX mu of + SOME(ty,_) => + (case RType.unFUN ty of + SOME(_,eps_phi0,_) => eps_phi0 + | NONE => die "APP: not function") + | NONE => die "APP: not boxed function") + | _ => die "APP: not function" val (B,d2) = R(B,rse,t2) val d0 = current_increment eps_phi0 val d = d0 && d1 && d2 @@ -606,11 +610,14 @@ struct let val (B,d1) = R(B,rse,t1) val eps_phi0 = case t2 of - Exp.TR(_, Exp.Mus [(ty,_)],_) => - (case RType.unFUN ty of - SOME(_,eps_phi0,_) => eps_phi0 - | NONE => die "HANDLE: not function") - | _ => die "HANDLE: not function" + Exp.TR(_, Exp.Mus [mu],_) => + (case RType.unBOX mu of + SOME(ty,_) => + (case RType.unFUN ty of + SOME(_,eps_phi0,_) => eps_phi0 + | NONE => die "HANDLE: not function") + | NONE => die "HANDLE: not boxed function") + | _ => die "HANDLE: not function" val (B,d2) = R(B,rse,t2) in (B, current_increment eps_phi0 && d1 && d2) (*(B, Effect.Lf[eps_phi0] && d1 && d2)*) @@ -627,12 +634,12 @@ struct | Exp.EXCON (_, SOME (_,t)) => R(B,rse,t) | Exp.DEEXCON (_, t) => R(B,rse,t) | Exp.RECORD (_, ts) => foldr(fn (t, (B, d)) => - let val (B', d') = R(B,rse,t) in (B', d && d') end) + let val (B', d') = R(B,rse,t) in (B', d && d') end) (B,delta_emp) ts | Exp.SELECT (_, t) => R(B,rse,t) | Exp.DEREF t => R(B,rse,t) | Exp.REF (_, t) => R(B,rse,t) - | Exp.ASSIGN (_,t1,t2) => + | Exp.ASSIGN (t1,t2) => let val (B,d1) = R(B,rse,t1) val (B,d2) = R(B,rse,t2) in (B, d1 && d2) @@ -644,10 +651,10 @@ struct in (B, d1 && d2) end | Exp.CCALL (_, ts) => foldr(fn (t,(B, d)) => - let val (B', d') = R(B,rse,t) in (B', d && d') end) + let val (B', d') = R(B,rse,t) in (B', d && d') end) (B,delta_emp) ts | Exp.BLOCKF64 (_, ts) => foldr(fn (t, (B, d)) => - let val (B', d') = R(B,rse,t) in (B', d && d') end) + let val (B', d') = R(B,rse,t) in (B', d && d') end) (B,delta_emp) ts | Exp.SCRATCHMEM _ => (B, delta_emp) | Exp.EXPORT (_, t) => R(B,rse,t) @@ -662,28 +669,26 @@ struct (B, delta_emp) ) ) (* case *) - handle AbortExp => raise AbortExp - | _ => - (device "Region inference failed (function R)\n"; - device "Smallest enclosing expression:\n"; - PP.outputTree(device,layoutExp(e),!Flags.colwidth); - device "Region Static Environment:\n"; - PP.outputTree(device,RSE.layout(rse),!Flags.colwidth); - device "\n"; - raise AbortExp - ) + handle AbortExp => raise AbortExp + | _ => + (device "Region inference failed (function R)\n"; + device "Smallest enclosing expression:\n"; + PP.outputTree(device,layoutExp e,!Flags.colwidth); + device "Region Static Environment:\n"; + PP.outputTree(device,RSE.layout rse,!Flags.colwidth); + device "\n"; + raise AbortExp + ) end (* let fun R_sw ...*) - fun loopR (B,rse,tr) = - let val _ = gc_arrow_effect_update := false - val _ = Effect.reset(); + fun loopR (B:cone,rse:rse,tr : (place,unit)Exp.trip) : cone = + let val _ = gc_arrow_effect_update := false + val _ = Effect.reset(); val B = #1(R (B,rse,tr)) handle AbortExp => Crash.impossible "R failed" - (* for toplas submission: insert call show_visited *) - val B = (* show_visited *) B - in if !gc_arrow_effect_update then loopR (B,rse,tr) - else B - end + in if !gc_arrow_effect_update then loopR (B,rse,tr) + else B + end in Effect.algorithm_R:=true; loopR @@ -691,4 +696,4 @@ struct type ('a,'b)trip = ('a,'b)Exp.trip -end; (*R*) +end diff --git a/src/Compiler/Regions/RegionExp.sml b/src/Compiler/Regions/RegionExp.sml index 9f7287bb9..83852f660 100644 --- a/src/Compiler/Regions/RegionExp.sml +++ b/src/Compiler/Regions/RegionExp.sml @@ -1,165 +1,169 @@ structure RegionExp: REGION_EXP = struct - structure Lam = LambdaExp - structure R = RType - structure Eff = Effect - structure Lvar = Lvars - structure PP = PrettyPrint - - val print_regions = Flags.is_on0 "print_regions" - val print_word_regions = Flags.is_on0 "print_word_regions" - val print_effects = Flags.is_on0 "print_effects" - - fun uncurry f (a,b) = f a b - - fun die s = Crash.impossible ("RegionExp." ^ s) - - fun quote s = "\"" ^ String.toString s ^ "\"" - - type lvar = Lvar.lvar - type con = Con.con - type excon = Excon.excon - type TyName = TyName.TyName - type place = Eff.place - type effect = Eff.effect - type cone = Eff.cone - type tyvar = Lam.tyvar - val pr_tyvar = Lam.pr_tyvar - - type Type = R.Type - and sigma = R.sigma - and il = R.il - and coneLayer = Eff.coneLayer - - datatype constructorKind = CONSTANT | VALUE_CARRYING - datatype datbinds = DATBINDS of (TyName * (con * constructorKind * sigma) list) list list - - datatype metaType = - (* describes normal expressions: *) - Mus of (Type*place) list - (* To allow the result of a declaration: *) - | Frame of {declared_lvars: {lvar : lvar, - compound : bool, - create_region_record : bool, - regvars : RegVar.regvar list, - sigma: sigma ref, - place: place}list, - declared_excons: (excon* (Type*place)option) list} - | RaisedExnBind (* to be a raised Bind exception. *) - - - datatype ('a,'b) LambdaPgm = PGM of - {expression: ('a,'b)trip, - export_datbinds: datbinds, - export_basis: effect list} - - (* list of mutual recursive datatype declarations *) - - and ('a,'b)trip = TR of ('a,'b)LambdaExp * metaType * effect - and ('a,'b)LambdaExp = - VAR of {lvar: lvar, il_r : (il * (il * cone -> il * cone)) ref, fix_bound: bool} - | INTEGER of IntInf.int * Type * 'a - | WORD of IntInf.int * Type * 'a - | STRING of string * 'a - | REAL of string * 'a - | F64 of string * 'a - | UB_RECORD of ('a,'b) trip list - | FN of {pat : (lvar * (Type*place)) list, - body : ('a,'b)trip, - alloc: 'a, - free: (lvar list * excon list) option} (*region inference without dangling pointers*) - | LETREGION_B of {B: effect list ref, discharged_phi: effect list ref, body: ('a,'b)trip} - | LET of {pat : (lvar * (tyvar*effect option) list * Type * place) list, - bind : ('a,'b)trip, - scope: ('a,'b)trip} - | FIX of {shared_clos: 'a, - functions : {lvar : lvar, - occ : (il * (il * cone -> il * cone)) ref list ref, - tyvars : (tyvar*effect option) list ref, - rhos: place list ref, - epss: effect list ref, - Type : Type, - formal_regions: 'b list option, - bind : ('a,'b)trip} list, - scope : ('a,'b)trip} - | APP of ('a,'b)trip * ('a,'b)trip - | EXCEPTION of excon * bool * (Type*place) * 'a * ('a,'b)trip - (* Type*place: of exception constructor - bool: true if exception is nullary *) - | RAISE of ('a,'b)trip - | HANDLE of ('a,'b)trip * ('a,'b)trip - | SWITCH_I of {switch: ('a,'b,IntInf.int) Switch, precision: int} - | SWITCH_W of {switch: ('a,'b,IntInf.int) Switch, precision: int} - | SWITCH_S of ('a,'b,string) Switch - | SWITCH_C of ('a,'b,con) Switch - | SWITCH_E of ('a,'b,excon) Switch - | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a} - | CON1 of {con : con, il : il, alloc: 'a} * ('a,'b)trip - | DECON of {con : con, il : il} * ('a,'b)trip - | EXCON of excon * ('a * ('a,'b)trip) option (* nullary excons are looked up in dyn env. *) - | DEEXCON of excon * ('a,'b)trip - | RECORD of 'a * ('a,'b)trip list - | SELECT of int * ('a,'b)trip - | DEREF of ('a,'b)trip - | REF of 'a * ('a,'b)trip - | ASSIGN of 'a * ('a,'b)trip * ('a,'b)trip - | DROP of ('a,'b)trip (* to do wild cards properly; drops the type *) - | EQUAL of {mu_of_arg1: Type * place , mu_of_arg2: Type*place, alloc: 'a} * ('a,'b)trip * ('a,'b)trip - | CCALL of {name : string, - mu_result : Type * place, - rhos_for_result : ('a * int option) list} - * ('a,'b)trip list - | BLOCKF64 of 'a * ('a,'b)trip list - | SCRATCHMEM of int * 'a (* bytes; type string *) - | EXPORT of {name : string, - mu_arg : Type * place, (*mu of argument to c function*) - mu_res : Type * place} - * ('a,'b)trip (* The ML function *) - | RESET_REGIONS of {force: bool, alloc : 'a, regions_for_resetting: 'a list} * ('a,'b)trip (* for programmer-directed resetting of regions; - * resetting is forced iff "force" is true. - * Forced resetting is not guaranteed to be sound *) - | FRAME of {declared_lvars: {lvar : lvar, + +structure Lam = LambdaExp +structure R = RType +structure Eff = Effect +structure Lvar = Lvars +structure PP = PrettyPrint + +val print_regions = Flags.is_on0 "print_regions" +val print_effects = Flags.is_on0 "print_effects" + +fun uncurry f (a,b) = f a b + +fun die s = Crash.impossible ("RegionExp." ^ s) + +fun quote s = "\"" ^ String.toString s ^ "\"" + +type lvar = Lvar.lvar +type con = Con.con +type excon = Excon.excon +type TyName = TyName.TyName +type place = Eff.place +type effect = Eff.effect +type cone = Eff.cone +type tyvar = Lam.tyvar +val pr_tyvar = Lam.pr_tyvar + +type Type = R.Type + and mu = R.mu + and sigma = R.sigma + and il = R.il + and coneLayer = Eff.coneLayer + +datatype constructorKind = CONSTANT | VALUE_CARRYING +datatype datbinds = DATBINDS of (TyName * (con * constructorKind * sigma) list) list list + +datatype metaType = + (* describes normal expressions: *) + Mus of mu list + (* To allow the result of a declaration: *) + | Frame of {declared_lvars: {lvar : lvar, + compound : bool, + create_region_record : bool, regvars : RegVar.regvar list, sigma: sigma ref, - place: place} list, - declared_excons: (excon * (Type*place) option) list} - (* a frame is the result of a structure-level - * declaration. - *) - - and ('a,'b,'c) Switch = SWITCH of ('a,'b)trip * - ('c * ('a,'b)trip) list * ('a,'b)trip option - - fun cons_if_there(NONE, l) = l - | cons_if_there(SOME x, l) = x::l - - (* mkPhiTr(tr) traverses tr and collects the arrow effects - that are bound locally in tr (in FIX and LETREGION). - It also collects all effect nodes that decorate subexpressions. - *) - - fun mkPhiTr(TR(e,_,phi)) acc = mkPhiExp e (phi::acc) - and mkPhiExp(e) acc = - let fun mkPhiSw(SWITCH(tr0, l, opt))acc = - mkPhiTr tr0 (foldl (uncurry mkPhiTr) acc - (cons_if_there(opt,map #2 l))) + place: place option} list, + declared_excons: (excon * mu option) list} + + | RaisedExnBind (* to be a raised Bind exception. *) + + +datatype ('a,'b) LambdaPgm = PGM of + {expression: ('a,'b)trip, + export_datbinds: datbinds, + export_basis: effect list} + + (* list of mutual recursive datatype declarations *) + + and ('a,'b)trip = TR of ('a,'b)LambdaExp * metaType * effect + and ('a,'b)LambdaExp = + VAR of {lvar: lvar, il_r : (il * (il * cone -> il * cone)) ref, fix_bound: bool} + | INTEGER of IntInf.int * Type * 'a option (* NONE if unboxed *) + | WORD of IntInf.int * Type * 'a option (* NONE if unboxed *) + | STRING of string * 'a + | REAL of string * 'a + | F64 of string + | UB_RECORD of ('a,'b) trip list (* unboxed records *) + | FN of {pat : (lvar * mu) list, + body : ('a,'b)trip, + alloc: 'a, + free: (lvar list * excon list) option} (*region inference without dangling pointers*) + | LETREGION_B of {B: effect list ref, discharged_phi: effect list ref, body: ('a,'b)trip} + | LET of {pat : (lvar * (tyvar*effect option) list * Type * place option) list, (* memo: delete tyvar list *) + bind : ('a,'b)trip, + scope: ('a,'b)trip} + | FIX of {shared_clos: 'a, + functions : {lvar : lvar, + occ: (il * (il * cone -> il * cone)) ref list ref, + tyvars : (tyvar*effect option) list ref, (* spurious tyvars are annotated with effects *) + rhos: place list ref, + epss: effect list ref, + Type : Type, + formal_regions: 'b list option, + bind : ('a,'b)trip} list, + scope : ('a,'b)trip} + | APP of ('a,'b)trip * ('a,'b)trip + | EXCEPTION of excon * bool * mu * 'a * ('a,'b)trip + (* mu: of exception constructor + bool: true if exception is nullary *) + | RAISE of ('a,'b)trip + | HANDLE of ('a,'b)trip * ('a,'b)trip + | SWITCH_I of {switch: ('a,'b,IntInf.int) Switch, precision: int} + | SWITCH_W of {switch: ('a,'b,IntInf.int) Switch, precision: int} + | SWITCH_S of ('a,'b,string) Switch + | SWITCH_C of ('a,'b,con) Switch + | SWITCH_E of ('a,'b,excon) Switch + | CON0 of {con : con, il : il, aux_regions: 'a list, alloc: 'a option} (* NONE if unboxed *) + | CON1 of {con : con, il : il, alloc: 'a option} * ('a,'b)trip (* NONE if unboxed *) + | DECON of {con : con, il : il} * ('a,'b)trip + | EXCON of excon * ('a * ('a,'b)trip) option (* nullary excons are looked up in dyn env. *) + | DEEXCON of excon * ('a,'b)trip + | RECORD of 'a option * ('a,'b)trip list + | SELECT of int * ('a,'b)trip + | DEREF of ('a,'b)trip + | REF of 'a * ('a,'b)trip + | ASSIGN of ('a,'b)trip * ('a,'b)trip + | DROP of ('a,'b)trip (* to do wild cards properly; drops the type *) + | EQUAL of {mu_of_arg1: mu, mu_of_arg2: mu} * ('a,'b)trip * ('a,'b)trip + | CCALL of {name : string, + mu_result : mu, (*mu of result from c function*) + rhos_for_result : ('a * int option) list} + * ('a,'b)trip list (* Calling C functions *) + + | BLOCKF64 of 'a * ('a,'b)trip list + | SCRATCHMEM of int * 'a (* bytes; type string *) + + (*`rhos_for_result' is technical; see comment in signature MUL_EXP*) + + | EXPORT of {name : string, + mu_arg : mu, (*mu of argument to c function*) + mu_res : mu} + * ('a,'b)trip (* The ML function *) + + | RESET_REGIONS of {force: bool, regions_for_resetting: 'a list} + * ('a,'b)trip (* for programmer-directed resetting of regions; + * resetting is forced iff "force" is true. + * Forced resetting is not guaranteed to be sound *) + | FRAME of {declared_lvars: {lvar : lvar, + regvars : RegVar.regvar list, + sigma: sigma ref, + place: place option} list, + declared_excons: (excon * mu option) list} + (* a frame is the result of a structure-level + * declaration. + *) + + and ('a,'b,'c) Switch = SWITCH of ('a,'b)trip * + ('c * ('a,'b)trip) list * ('a,'b)trip option + +fun cons_if_there (NONE, l) = l + | cons_if_there (SOME x, l) = x::l + +(* mkPhiTr(tr) traverses tr and collects the arrow effects + that are bound locally in tr (in FIX and LETREGION). + It also collects all effect nodes that decorate subexpressions. + *) + +fun mkPhiTr (TR(e,_,phi)) acc = mkPhiExp e (phi::acc) +and mkPhiExp e acc = + let fun mkPhiSw (SWITCH(tr0, l, opt))acc = + mkPhiTr tr0 (foldl (uncurry mkPhiTr) acc + (cons_if_there(opt,map #2 l))) in case e of UB_RECORD(ts) => foldl (uncurry mkPhiTr) acc ts | FN {body, ...} => mkPhiTr body acc - | LETREGION_B{B: effect list ref, body: ('a,'b)trip, ...} => - mkPhiTr body (!B @ acc) - | LET{pat, bind,scope} => mkPhiTr scope (mkPhiTr bind acc) + | LETREGION_B{B, body, ...} => mkPhiTr body (!B @ acc) + | LET{pat,bind,scope} => mkPhiTr scope (mkPhiTr bind acc) | FIX{shared_clos,functions,scope} => - let - val acc' = foldl (fn ({epss as ref arreffs,bind, ...}, acc) => - mkPhiTr bind (arreffs @ acc)) - acc - functions - in - mkPhiTr scope acc' - end + let val acc' = foldl (fn ({epss as ref arreffs,bind, ...}, acc) => + mkPhiTr bind (arreffs @ acc)) + acc functions + in mkPhiTr scope acc' + end | APP(tr1, tr2) => mkPhiTr tr1 (mkPhiTr tr2 acc) | EXCEPTION(_,_,_,_, tr) => mkPhiTr tr acc | RAISE tr => mkPhiTr tr acc @@ -180,7 +184,7 @@ struct | DEREF tr => mkPhiTr tr acc | REF (_,tr) => mkPhiTr tr acc | DROP (tr) => mkPhiTr tr acc - | ASSIGN (_,tr1,tr2) => mkPhiTr tr1 (mkPhiTr tr2 acc) + | ASSIGN (tr1,tr2) => mkPhiTr tr1 (mkPhiTr tr2 acc) | EQUAL (_,tr1,tr2) => mkPhiTr tr1 (mkPhiTr tr2 acc) | CCALL (_,trs) => foldl (uncurry mkPhiTr) acc trs | BLOCKF64 (_,trs) => foldl (uncurry mkPhiTr) acc trs @@ -189,161 +193,137 @@ struct | RESET_REGIONS (_, tr) => mkPhiTr tr acc | FRAME _ => acc | _ => acc - end - - fun mkPhi(tr,exported_regvars_and_arroweffects) = - mkPhiTr tr exported_regvars_and_arroweffects - - fun countletregions _ = () - - - (*****************************) - (* *) - (* Pretty printing *) - (* *) - (*****************************) - - fun isWordRegion(rho) = - case Eff.get_place_ty rho of - SOME Eff.WORD_RT => true - | _ => false - - type StringTree = PP.StringTree - fun layPair(t1,t2) = PP.NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT", ", - children = [t1, t2]} - - fun get_opt l = foldr (fn (opt, acc) => - case opt of SOME t => t::acc | NONE => acc) [] l - - - val printcount = ref 1 (* controls when effects are printed *) + end - local - val (layTau, layMu) = R.mk_layout false (* do not omit region info in frames *) - fun layMus mus = PP.NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT",", - children = map layMu mus} - in - fun layout_declared_lvar{lvar, regvars, sigma = ref sigma, place} = - if not(print_word_regions()) andalso isWordRegion place then - PP.NODE{start = Lvar.pr_lvar lvar ^ ": ", finish = "", - indent = 5, childsep = PP.NOSEP, children = [R.mk_lay_sigma false sigma]} - else - PP.NODE{start = Lvar.pr_lvar lvar ^ ": (", finish = ")", +fun mkPhi (tr,exported_regvars_and_arroweffects) = + mkPhiTr tr exported_regvars_and_arroweffects + +(*****************************) +(* *) +(* Pretty printing *) +(* *) +(*****************************) + +type StringTree = PP.StringTree +fun layPair (t1,t2) = PP.NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT", ", + children = [t1, t2]} + +fun get_opt l = foldr (fn (SOME t,acc) => t::acc | (NONE,acc) => acc) [] l + +local + val (layTau, layMu) = R.mk_layout false (* do not omit region info in frames *) + fun layMus mus = PP.NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT",", + children = map layMu mus} +in +fun layout_declared_lvar {lvar, regvars, sigma = ref sigma, place} = + case place of + NONE => PP.NODE{start = Lvar.pr_lvar lvar ^ ": ", finish = "", + indent = 5, childsep = PP.NOSEP, children = [R.mk_lay_sigma false sigma]} + | SOME place => + PP.NODE{start = Lvar.pr_lvar lvar ^ ": (", finish = ")", indent = 5, childsep = PP.RIGHT",", children = [R.mk_lay_sigma false sigma, - Eff.layout_effect place]} + Eff.layout_effect place]} - fun layout_declared_lvar'{lvar, compound, create_region_record, regvars, sigma, place} = - layout_declared_lvar{lvar=lvar,regvars=regvars,sigma=sigma,place=place} +fun layout_declared_lvar' {lvar, compound, create_region_record, regvars, sigma, place} = + layout_declared_lvar{lvar=lvar,regvars=regvars,sigma=sigma,place=place} - fun layout_declared_excon(excon,mu_opt) = PP.LEAF(Excon.pr_excon(excon)) +fun layout_declared_excon (excon,mu_opt) = PP.LEAF(Excon.pr_excon(excon)) (* memo: "of mu" maybe *) - fun layMeta (Mus mus) = layMus mus - | layMeta (Frame{declared_lvars, declared_excons}) = - let val l1 = map layout_declared_lvar' declared_lvars - val l2 = map layout_declared_excon declared_excons - in PP.NODE{start = "{|", finish = "|}", indent = 2, childsep = PP.RIGHT ", ", children = l1 @ l2} - end - | layMeta (RaisedExnBind) = PP.LEAF "raisedBind" +fun layMeta (Mus mus) = layMus mus + | layMeta (Frame{declared_lvars, declared_excons}) = + let val l1 = map layout_declared_lvar' declared_lvars + val l2 = map layout_declared_excon declared_excons + in PP.NODE{start = "{|", finish = "|}", indent = 2, childsep = PP.RIGHT ", ", children = l1 @ l2} + end + | layMeta RaisedExnBind = PP.LEAF "raisedBind" - end; +end - fun mkLay (omit_region_info: bool) (layout_alloc: 'a -> StringTree option) - (layout_bind: 'b -> StringTree option) = +infix ?> +fun (opt:'a option) ?> (f:'a -> 'b option) : 'b option = + case opt of + NONE => NONE + | SOME x => f x + +fun mkLay (omit_region_info: bool) + (layout_alloc: 'a -> StringTree option) + (layout_bind: 'b -> StringTree option) = let open PP - fun alloc_string alloc = case (layout_alloc alloc) of SOME t => " " ^PP.flatten1 t | NONE => "" + fun alloc_string a = case layout_alloc a of SOME t => " " ^ PP.flatten1 t | NONE => "" fun layList f l = NODE{start = "[", finish = "]", indent = 1, childsep = RIGHT ",", children = map f l} - fun layHlist f l = HNODE{start = "[", finish = "]", childsep = RIGHT ",", - children = map f l} + children = map f l} infix ^^ (* s ^^ st_opt: tag the string tree option st_opt onto the string s *) fun s ^^ NONE = s - | s ^^ (SOME st') = s ^ PP.flatten1(st') + | s ^^ (SOME st) = s ^ PP.flatten1 st fun pp_fun_allocation a = case layout_alloc a of - SOME st => PP.flatten1 st - | NONE => "" + SOME st => PP.flatten1 st + | NONE => "" val (layTau, layMu) = R.mk_layout omit_region_info fun layMus mus = NODE{start = "(", finish = ")", indent = 1, childsep = RIGHT",", children = map layMu mus} + fun layVarMu (x,mu) = LEAF (concat[Lvar.pr_lvar x, ":", PP.flatten1(layMu mu)]) + + fun layPatFn [] = LEAF("() => ") + | layPatFn [(x,mu)] = NODE{start = "", finish = "=>", indent = 0, childsep = NOSEP, + children = [layVarMu(x,mu)]} + | layPatFn pat = HNODE{start = "(", finish = ") =>", childsep = RIGHT",", + children = map layVarMu pat} - fun layVarMu(x,mu) = LEAF (concat[Lvar.pr_lvar x, ":", PP.flatten1(layMu mu)]) - - fun layPatFn [] = LEAF("() => ") - | layPatFn [(x,mu)] = NODE{start = "", finish = "=>", indent = 0, childsep = NOSEP, - children = [layVarMu(x,mu)]} - | layPatFn pat = HNODE{start = "(", finish = ") =>", childsep = RIGHT",", - children = map layVarMu pat} - -(*old - fun layVarLet(lvar,_,[],[], tau) = - NODE{start = Lvar.pr_lvar lvar ^ ":", finish = "", indent =2 , childsep = RIGHT" ", - children = [layTau tau]} - | layVarLet(lvar,_,alphas,effs, tau) = - NODE{start = Lvar.pr_lvar lvar ^ ":", finish = "", indent =2 , childsep = RIGHT" ", - children = [HNODE{start = "/\\", finish = "", childsep = NOSEP, - children = map (LEAF o Lam.pr_tyvar) alphas}, - HNODE{start = "", finish = ". ", childsep = NOSEP, - children = map Eff.layout_effect effs}, - layTau tau]} -old*) - fun layVarSigma (lvar,alphas,rhos,epss, tau,p) = + fun layVarSigma (lvar,alphas,rhos,epss,tau,p) = let val sigma_t = R.mk_lay_sigma' omit_region_info (rhos, epss, alphas, tau) val start:string = Lvar.pr_lvar lvar ^ " " ^ (if !Flags.print_types then ":" else "") - val sigma_rho_t = if print_regions() andalso !Flags.print_types andalso - (print_word_regions() orelse not(isWordRegion p)) then - NODE{start = "(", finish = ")", childsep = RIGHT",", - indent = 1, - children = [sigma_t, Eff.layout_effect p]} - else sigma_t - + val sigma_rho_t = + if print_regions() andalso !Flags.print_types + then case p of + SOME p => NODE{start = "(", finish = ")", childsep = RIGHT",", + indent = 1, + children = [sigma_t, Eff.layout_effect p]} + | NONE => sigma_t + else sigma_t in PP.NODE{start = start, finish = "", indent = size start +1, childsep = PP.NOSEP, children = [sigma_rho_t]} end - - fun layPatLet [] = LEAF("_") (* wild card *) - | layPatLet [one as (lvar,tyvars,tau,p)] = - layVarSigma(lvar,tyvars,[],[],tau,p) + | layPatLet [one as (lvar,tyvars,tau,p)] = layVarSigma(lvar,tyvars,[],[],tau,p) | layPatLet pat = HNODE{start = "(", finish = ")", childsep = RIGHT",", - children = map (fn (lvar,tyvars,tau,p) => - layVarSigma(lvar,tyvars,[],[],tau,p)) pat} - - fun layoutSwitch laytrip show_const (SWITCH(lamb,rules,wildcardOpt)) = - let - fun child(x,lamb) = - PP.NODE{start="",finish="",indent=0, - children=[PP.LEAF (show_const x), - laytrip(lamb,0)], - childsep=PP.RIGHT " => "} - val t1 = PP.NODE{start="(case ",finish=" ",indent=6, childsep = PP.NOSEP, - children=[laytrip(lamb,0)]} - val t2 = PP.NODE{start = "of " , finish = ") (*case*) ", indent = 3, - childsep=PP.LEFT " | ", - children = (map child rules) @ - (case wildcardOpt of - NONE => [] - | SOME lamb => - [PP.NODE{start="",finish="",indent=0, - children=[PP.LEAF "_", - laytrip(lamb,0)], - childsep=PP.RIGHT " => "}])} - - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.NOSEP, - children = [t1,t2]} - end + children = map (fn (lvar,tyvars,tau,p) => + layVarSigma(lvar,tyvars,[],[],tau,p)) pat} + + fun layoutSwitch laytrip show_const (SWITCH(lamb,rules,wildcardOpt)) = + let fun child(x,lamb) = + PP.NODE{start="",finish="",indent=0, + children=[PP.LEAF (show_const x), + laytrip(lamb,0)], + childsep=PP.RIGHT " => "} + val t1 = PP.NODE{start="(case ",finish=" ",indent=6, childsep = PP.NOSEP, + children=[laytrip(lamb,0)]} + val t2 = PP.NODE{start = "of " , finish = ") (*case*) ", indent = 3, + childsep=PP.LEFT " | ", + children = (map child rules) @ + (case wildcardOpt of + NONE => [] + | SOME lamb => + [PP.NODE{start="",finish="",indent=0, + children=[PP.LEAF "_", + laytrip(lamb,0)], + childsep=PP.RIGHT " => "}])} + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.NOSEP, + children = [t1,t2]} + end fun lay_il (lvar_string:string, terminator: string, il) : StringTree = let val (rhos,epss,taus)= R.un_il(il) @@ -351,7 +331,7 @@ old*) val rhos_opt = if print_regions() then SOME(layHlist Eff.layout_effect rhos) else NONE val epss_opt = if print_effects() then SOME(layList Eff.layout_effect epss) else NONE in - case get_opt [taus_opt,rhos_opt,epss_opt] of + case get_opt [taus_opt,rhos_opt,epss_opt] of [] => LEAF(lvar_string ^ terminator) | l => NODE{start = lvar_string ^ "(", finish = ")" ^ terminator, indent = 1, childsep = RIGHT", ", children = l} @@ -360,338 +340,264 @@ old*) (* precedence levels: lam : 1 + - etc : 2 app : 3 *) - (* n is precedence of parent - or 0 if no parens around lamb are needed *) - - fun layBin(bop:string, n, t1, t2, a) = - case layout_alloc a of - NONE => (* put parenthesis, if precedence dictates it *) - if n>=2 then - NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - else - NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - | SOME t_alloc => (* assume allocation string is short: flatten it and use it as terminator *) - let val s_alloc = PP.flatten1 t_alloc - in NODE{start = "(", finish = ") " ^ s_alloc, indent =1, childsep = PP.RIGHT bop, - children = [layTrip(t1,2), layTrip(t2,2)]} - end + (* n is precedence of parent - or 0 if no parens around lamb are needed *) - and layExp(lamb: ('a, 'b) LambdaExp,n): StringTree = - case lamb of - VAR{lvar, il_r, fix_bound=false} => - (case R.un_il(#1(!il_r)) of - ([],[],[]) => LEAF(Lvar.pr_lvar lvar) - | _ => lay_il(Lvar.pr_lvar lvar, "", #1(! il_r))) -(*old -(types,rhos,epss) => NODE{start = Lvar.pr_lvar lvar^"(", finish = ")", indent = 1, childsep = RIGHT", ", - children = [layList layTau types, - layHlist Eff.layout_effect rhos, - layList Eff.layout_effect epss]}) -*) - - | VAR{lvar, il_r, fix_bound=true} => - lay_il(Lvar.pr_lvar lvar, "", #1(! il_r)) - - | INTEGER(i,t,a) => LEAF(IntInf.toString i ^^ layout_alloc a) - | WORD(w,t,a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ layout_alloc a) - | STRING(s, a) => LEAF(quote s ^^ layout_alloc a) - | REAL(r, a) => LEAF(r ^^ layout_alloc a) - | F64(r, a) => LEAF((r ^ "f64") ^^ layout_alloc a) - | UB_RECORD(args) => - PP.NODE{start = "<", finish = ">" , indent = 1, childsep = PP.RIGHT", ", - children = map (fn trip => layTrip(trip,0)) args} - | CON0{con, il, aux_regions, alloc} => (* nullary constructor *) - let - val alloc_s = - case (layout_alloc alloc) of SOME t => " " ^PP.flatten1 t | NONE => "" - in PP.LEAF(Con.pr_con con ^ alloc_s) (*lay_il(Con.pr_con con, alloc_s, il)*) - end - | CON1({con, il, alloc}, trip) => (* unary constructor *) - let - val alloc_s = - case (layout_alloc alloc) of SOME t => " " ^PP.flatten1 t | NONE => "" - val t1 = PP.LEAF(Con.pr_con con^alloc_s) (* lay_il(Con.pr_con con, alloc_s, il)*) - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", - children = [t1, layTrip(trip,3)]} - end - | DECON({con, il},trip) => (* destruction *) - let - val t1 = PP.LEAF ("decon_"^Con.pr_con con) (*lay_il("decon_" ^ Con.pr_con con , "", il)*) - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", - children = [t1, layTrip(trip,3)]} - end + fun layBin (bop:string, n, t1, t2, a) = + case layout_alloc a of + NONE => (* put parenthesis, if precedence dictates it *) + if n>=2 then NODE{start = "(", finish = ")", indent = 1, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + else NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + | SOME t_alloc => (* assume allocation string is short: flatten it and use it as terminator *) + let val s_alloc = PP.flatten1 t_alloc + in NODE{start = "(", finish = ") " ^ s_alloc, indent =1, childsep = PP.RIGHT bop, + children = [layTrip(t1,2), layTrip(t2,2)]} + end - | EXCON(excon, NONE) => (* nullary exception constructor *) - PP.LEAF(Excon.pr_excon excon) - | EXCON(excon, SOME (alloc,t)) => (* unary exception constructor *) - let - val alloc_s = alloc_string alloc - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", - children = [PP.LEAF(Excon.pr_excon excon ^ alloc_s), layTrip(t,3)]} - end - | RECORD(alloc, args) => - let - val alloc_s = alloc_string alloc - in - PP.NODE{start = "(", finish = ")" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", - children = map (fn trip => layTrip(trip,0)) args} - end - | SELECT(i, trip) => - PP.NODE{start = "#"^Int.toString i ^ " ", finish = "", indent = 4, childsep = PP.NOSEP, - children = [layTrip(trip,3)]} - | FN{pat, body, alloc, free}=> layLam((pat,body,alloc), n, "") - | APP(TR(VAR{lvar, il_r, fix_bound=true},_,_), t2) => - let - (* f il (exp) + and layExp (lamb: ('a, 'b) LambdaExp,n) : StringTree = + case lamb of + VAR{lvar, il_r, fix_bound=false} => + (case R.un_il(#1(!il_r)) of + ([],[],[]) => LEAF(Lvar.pr_lvar lvar) + | _ => lay_il(Lvar.pr_lvar lvar, "", #1(! il_r))) + | VAR{lvar, il_r, fix_bound=true} => + lay_il(Lvar.pr_lvar lvar, "", #1(! il_r)) + | INTEGER(i,t,a) => LEAF(IntInf.toString i ^^ (a ?> layout_alloc)) + | WORD(w,t,a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ (a ?> layout_alloc)) + | STRING(s, a) => LEAF(quote s ^^ layout_alloc a) + | REAL(r, a) => LEAF(r ^^ layout_alloc a) + | F64 r => LEAF(r ^ "f64") + | UB_RECORD(args) => + PP.NODE{start = "<", finish = ">" , indent = 1, childsep = PP.RIGHT", ", + children = map (fn trip => layTrip(trip,0)) args} + | CON0{con, il, aux_regions, alloc} => (* nullary constructor *) + let val alloc_s = + case (alloc ?> layout_alloc) of + NONE => "" + | SOME t => " " ^ PP.flatten1 t + in PP.LEAF(Con.pr_con con ^ alloc_s) (*lay_il(Con.pr_con con, alloc_s, il)*) + end + | CON1({con, il, alloc}, trip) => (* unary constructor *) + let val alloc_s = + case (alloc ?> layout_alloc) of + NONE => "" + | SOME t => " " ^ PP.flatten1 t + val t1 = PP.LEAF(Con.pr_con con ^ alloc_s) (* lay_il(Con.pr_con con, alloc_s, il)*) + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + children = [t1, layTrip(trip,3)]} + end + | DECON({con, il},trip) => (* destruction *) + let val t1 = PP.LEAF ("decon_"^Con.pr_con con) (*lay_il("decon_" ^ Con.pr_con con , "", il)*) + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + children = [t1, layTrip(trip,3)]} + end + | EXCON(excon, NONE) => (* nullary exception constructor *) + PP.LEAF(Excon.pr_excon excon) + | EXCON(excon, SOME (alloc,t)) => (* unary exception constructor *) + let val alloc_s = alloc_string alloc + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + children = [PP.LEAF(Excon.pr_excon excon ^ alloc_s), layTrip(t,3)]} + end + | RECORD(SOME alloc, args) => + let val alloc_s = alloc_string alloc + in PP.NODE{start = "(", finish = ")" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", + children = map (fn trip => layTrip(trip,0)) args} + end + | RECORD(NONE, []) => PP.LEAF "()" + | SELECT(i, trip) => + PP.NODE{start = "#"^Int.toString i ^ " ", finish = "", indent = 4, childsep = PP.NOSEP, + children = [layTrip(trip,3)]} + | FN{pat, body, alloc, free} => layLam((pat,body,alloc), n, "") + | APP(TR(VAR{lvar, il_r, fix_bound=true},_,_), t2) => + let (* f il (exp) OR f il (exp) *) - - val t1 = lay_il(Lvar.pr_lvar lvar, "", #1(! il_r)) - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", - children = [t1, layTrip(t2,3)]} - end - | APP(t1, t2) => - NODE{start = if n>3 then "(" else "", - finish = if n>3 then ")" else "", - childsep = RIGHT " ", indent = 1, - children = [layTrip(t1,3), layTrip(t2,4)]} - | EXCEPTION _ => layout_let_fix_and_exception lamb - | HANDLE(t1,t2) => - NODE{start = if n>=2 then "(" else "", - finish = if n>=2 then ")" else "", - childsep = RIGHT " handle ", indent = 1, - children = [layTrip(t1,2), layTrip(t2,2)]} - | RAISE(t1) => - NODE{start = if n>=3 then "raise(" else "raise ", - finish = if n>=3 then ")" else "", - childsep = NOSEP, indent = 6, - children = [layTrip(t1,2)]} - | LET{pat, bind, scope} => layout_let_fix_and_exception lamb - | FIX _ => layout_let_fix_and_exception lamb - | REF(alloc, t) => - let val s = alloc_string alloc - in PP.NODE{start = if n>3 then "(ref " ^ s ^ " " - else "ref " ^ s ^ " ", - finish = if n>3 then ")" else "", - indent = 6, childsep = PP.NOSEP, - children = [layTrip(t,4)]} - end - | DEREF t => - PP.NODE{start = if n>3 then "(! " else " ! ", - finish = if n>3 then ")" else "", - indent = 3, childsep = PP.NOSEP, - children = [layTrip(t,4)]} - | ASSIGN(alloc,t1,t2) => - let val s = alloc_string alloc - in PP.NODE{start = "(" , finish = ")"^s, indent = 1, childsep = PP.RIGHT " := ", - children = [layTrip(t1,2), layTrip(t2,2)]} - end - | DROP(t) => layTrip(t,n) -(* - PP.NODE{start = if n>3 then "(drop " - else "drop ", - finish = if n>3 then ")" else "", - indent = 6, childsep = PP.NOSEP, - children = [layTrip(t,4)]} -*) - | EQUAL({mu_of_arg1,mu_of_arg2, alloc},arg1,arg2) => - let val eq = if print_regions() then "=" ^ alloc_string alloc else "=" - val ty = if !(Flags.print_types) + val t1 = lay_il(Lvar.pr_lvar lvar, "", #1(! il_r)) + in PP.NODE{start = "", finish = "", indent = 0, childsep = PP.RIGHT " ", + children = [t1, layTrip(t2,3)]} + end + | APP(t1, t2) => + NODE{start = if n>3 then "(" else "", + finish = if n>3 then ")" else "", + childsep = RIGHT " ", indent = 1, + children = [layTrip(t1,3), layTrip(t2,4)]} + | EXCEPTION _ => layout_let_fix_and_exception lamb + | HANDLE(t1,t2) => + NODE{start = if n>=2 then "(" else "", + finish = if n>=2 then ")" else "", + childsep = RIGHT " handle ", indent = 1, + children = [layTrip(t1,2), layTrip(t2,2)]} + | RAISE(t1) => + NODE{start = if n>=3 then "raise(" else "raise ", + finish = if n>=3 then ")" else "", + childsep = NOSEP, indent = 6, + children = [layTrip(t1,2)]} + | LET{pat, bind, scope} => layout_let_fix_and_exception lamb + | FIX _ => layout_let_fix_and_exception lamb + | REF(alloc, t) => + let val s = alloc_string alloc + in PP.NODE{start = if n>3 then "(ref " ^ s ^ " " + else "ref " ^ s ^ " ", + finish = if n>3 then ")" else "", + indent = 6, childsep = PP.NOSEP, + children = [layTrip(t,4)]} + end + | DEREF t => + PP.NODE{start = if n>3 then "(! " else " ! ", + finish = if n>3 then ")" else "", + indent = 3, childsep = PP.NOSEP, + children = [layTrip(t,4)]} + | ASSIGN(t1,t2) => + PP.NODE{start = "(" , finish = ")", indent = 1, childsep = PP.RIGHT " := ", + children = [layTrip(t1,2), layTrip(t2,2)]} + | DROP t => layTrip(t,n) + | EQUAL({mu_of_arg1,mu_of_arg2},arg1,arg2) => + let val eq = "=" + val ty = if !(Flags.print_types) then concat["(* domain of = is: ", - PP.flatten1(layMu mu_of_arg1), "*", - PP.flatten1(layMu mu_of_arg2), " *)"] - else "" - in - PP.NODE{start= if n>=2 then "(" else "", - finish = if n>=2 then ")" else "", - indent = 0, childsep = PP.RIGHT (eq^ty), - children = [layTrip(arg1,2), layTrip(arg2, 2)]} - end - | CCALL ({name, mu_result, rhos_for_result}, args) => - PP.NODE {start = "ccall(", finish = "):" - ^ (if !Flags.print_types then PP.flatten1(layMu mu_result) else "") - ^ (if print_regions() then - PP.flatten1(layHlist (PP.LEAF o alloc_string o #1) rhos_for_result) - else ""), - indent = 6, childsep = PP.RIGHT ", ", - children = PP.LEAF name :: (map (fn t => layTrip(t,0)) args)} - | BLOCKF64(alloc, args) => - let - val alloc_s = alloc_string alloc - in - PP.NODE{start = "{", finish = "}" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", - children = map (fn trip => layTrip(trip,0)) args} - end - | SCRATCHMEM(n,alloc) => - let val alloc_s = alloc_string alloc - in PP.LEAF ("scratch(" ^ Int.toString n ^ ")" ^ alloc_s) - end - | EXPORT ({name, mu_arg, mu_res}, arg) => - PP.NODE {start = "_export(" ^ name ^ ", ", finish = "):" - ^ (if !Flags.print_types then PP.flatten1(layMu mu_arg) ^ "->" ^ PP.flatten1(layMu mu_res) - else ""), - indent = 6, childsep = PP.RIGHT ", ", - children = [PP.LEAF name, layTrip(arg,0)]} - | RESET_REGIONS({force, alloc,regions_for_resetting}, t) => - let val fcn = if force then "forceResetting " else "resetRegions " - val aux_regions_t = HNODE{start="[",finish="]", childsep=NOSEP, - children=[layHlist (fn a => PP.LEAF(alloc_string a)) regions_for_resetting]} - in PP.NODE{start = "(" ^ fcn , finish = ")" ^ (if print_regions() then alloc_string alloc else ""), - indent = size fcn + 2, childsep = PP.NOSEP, - children = [aux_regions_t,layTrip(t,0)]} - end - | LETREGION_B{B = ref [], body,...} => layTrip(body,n) - | LETREGION_B{B, body,...} => - (case Eff.layoutEtas (!B) of - [] => layTrip(body,n) - | binders => - let - val t1 = - NODE{start = "letregion ", finish = " ", childsep = NOSEP, indent = 10, - children = [HNODE{start = "", finish = "", childsep = RIGHT", ", - children = binders}]} - val t2 = - NODE{start = "in ", finish = "", childsep = NOSEP, indent = 3, - children = [layTrip(body,0)]} - val t3 = - NODE{start = "end (*", finish = "*)", childsep = NOSEP, indent = 6, - children = [HNODE{start = "", finish = "", childsep = RIGHT", ", - children = binders}]} - in NODE{start = "", finish = "", indent = 0, childsep = NOSEP, children = [t1,t2,t3]} - end - ) - | SWITCH_I {switch,precision} => layoutSwitch layTrip IntInf.toString switch - | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch - | SWITCH_S(sw) => layoutSwitch layTrip (fn s => s) sw - | SWITCH_C(sw) => layoutSwitch layTrip Con.pr_con sw - | SWITCH_E(sw) => layoutSwitch layTrip Excon.pr_excon sw - | FRAME{declared_lvars, declared_excons} => - let val l1 = map layout_declared_lvar declared_lvars - val l2 = map layout_declared_excon declared_excons - in NODE{start = "{|", finish = "|}", indent = 0, childsep = NOSEP, - children = l1 @ l2} - end - - | _ => LEAF "pretty-printing of this region expression not yet implemented" - - and layTrip(TR(e,Mus mus,rea),n) = - let val t1 = - case (e, mus) of - (FN{pat, body, alloc, free}, [(ty,_)])=> - (case R.unFUN ty of - SOME (_,eps,_) => - layLam((pat,body,alloc), n, - PP.flatten1(Eff.layout_effect eps) ^ " ") - | NONE => layExp(e,n)) - | _ => layExp(e,n) - val tick = (printcount:= !printcount+1; !printcount) - in - t1 - (* if false (*tick mod 10 = 0*) then*) -(*for more info: - case e of - - LETREGION_B _ => (*mads: comment out "LETREGION_B" to get effects on all subexpressions*) - let (*val t2 = layMus mus*) - val t3 = Eff.layout_effect_deep rea - in NODE{start = "(", finish = ")", indent = 1, childsep = RIGHT":", - children = [t1,(*t2,*)t3]} + PP.flatten1(layMu mu_of_arg1), "*", + PP.flatten1(layMu mu_of_arg2), " *)"] + else "" + in PP.NODE{start= if n>=2 then "(" else "", + finish = if n>=2 then ")" else "", + indent = 0, childsep = PP.RIGHT (eq^ty), + children = [layTrip(arg1,2), layTrip(arg2,2)]} end - | _ => t1 -(* else t1*) -for more info*) - end - | layTrip(TR(e, _, rea), n) = layExp(e,n) + | CCALL ({name, mu_result, rhos_for_result}, args) => + PP.NODE {start = "ccall(", + finish = "):" + ^ (if !Flags.print_types then PP.flatten1(layMu mu_result) else "") + ^ (if print_regions() then + PP.flatten1(layHlist (PP.LEAF o alloc_string o #1) rhos_for_result) + else ""), + indent = 6, childsep = PP.RIGHT ", ", + children = PP.LEAF name :: (map (fn t => layTrip(t,0)) args)} + | BLOCKF64(alloc, args) => + let val alloc_s = alloc_string alloc + in PP.NODE{start = "{", finish = "}" ^ alloc_s, indent = 1, childsep = PP.RIGHT", ", + children = map (fn trip => layTrip(trip,0)) args} + end + | SCRATCHMEM(n,alloc) => + let val alloc_s = alloc_string alloc + in PP.LEAF ("scratch(" ^ Int.toString n ^ ")" ^ alloc_s) + end + | EXPORT ({name, mu_arg, mu_res}, arg) => + PP.NODE {start = "_export(" ^ name ^ ", ", + finish = "):" + ^ (if !Flags.print_types then PP.flatten1(layMu mu_arg) ^ "->" ^ PP.flatten1(layMu mu_res) + else ""), + indent = 6, childsep = PP.RIGHT ", ", + children = [PP.LEAF name, layTrip(arg,0)]} + | RESET_REGIONS({force, regions_for_resetting}, t) => + let val fcn = if force then "forceResetting " else "resetRegions " + val aux_regions_t = HNODE{start="[",finish="]", childsep=NOSEP, + children=[layHlist (fn a => PP.LEAF(alloc_string a)) regions_for_resetting]} + in PP.NODE{start = "(" ^ fcn , finish = ")", + indent = size fcn + 2, childsep = PP.NOSEP, + children = [aux_regions_t,layTrip(t,0)]} + end + | LETREGION_B{B = ref [], body,...} => layTrip(body,n) + | LETREGION_B{B, body,...} => + (case Eff.layoutEtas (!B) of + [] => layTrip(body,n) + | binders => + let val t1 = + NODE{start = "letregion ", finish = " ", childsep = NOSEP, indent = 10, + children = [HNODE{start = "", finish = "", childsep = RIGHT", ", + children = binders}]} + val t2 = + NODE{start = "in ", finish = "", childsep = NOSEP, indent = 3, + children = [layTrip(body,0)]} + val t3 = + NODE{start = "end (*", finish = "*)", childsep = NOSEP, indent = 6, + children = [HNODE{start = "", finish = "", childsep = RIGHT", ", + children = binders}]} + in NODE{start = "", finish = "", indent = 0, childsep = NOSEP, children = [t1,t2,t3]} + end + ) + | SWITCH_I {switch,precision} => layoutSwitch layTrip IntInf.toString switch + | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch + | SWITCH_S(sw) => layoutSwitch layTrip (fn s => s) sw + | SWITCH_C(sw) => layoutSwitch layTrip Con.pr_con sw + | SWITCH_E(sw) => layoutSwitch layTrip Excon.pr_excon sw + | FRAME{declared_lvars, declared_excons} => + let val l1 = map layout_declared_lvar declared_lvars + val l2 = map layout_declared_excon declared_excons + in NODE{start = "{|", finish = "|}", indent = 0, childsep = NOSEP, + children = l1 @ l2} + end + | _ => LEAF "pretty-printing of this region expression not yet implemented" + and layTrip (TR(e, _, _), n) = layExp(e,n) - and layLam((pat,body,alloc), n, eps: string) = + and layLam ((pat,body,alloc), n, eps: string) = (* (fn eps alloc pat => lamb ) *) - let - val start_s = concat["fn ", eps, pp_fun_allocation alloc, " "] - val pat_t = layPatFn pat - val first_line = NODE{start = start_s, finish = "", indent = size(start_s), - children = [pat_t], childsep = NOSEP} - in - PP.NODE{start= if n>1 then "(" else "", - finish=if n>1 then ")" else "", - indent=1, childsep = PP.NOSEP, - children=[first_line,layTrip(body,1)]} + let val start_s = concat["fn ", eps, pp_fun_allocation alloc, " "] + val pat_t = layPatFn pat + val first_line = NODE{start = start_s, finish = "", indent = size(start_s), + children = [pat_t], childsep = NOSEP} + in PP.NODE{start= if n>1 then "(" else "", + finish=if n>1 then ")" else "", + indent=1, childsep = PP.NOSEP, + children=[first_line,layTrip(body,1)]} end + and layout_let_fix_and_exception lexp = - let - val inInfo = ref "" - fun layout_rec lexp = + let fun layout_rec lexp = case lexp of - LET{pat, bind, scope = t2 as TR(e2,_,_)} => - let - val (binds, body) = layout_rec e2 - val _ = inInfo := "(* let *)" - in - (mk_valbind(pat,bind)::binds, body) - end - | FIX({shared_clos,functions,scope = t2 as TR(e2, _,_)}) => - let - val (binds', body) = layout_rec e2 - val _ = inInfo := "(* fix *)" - in - (mk_mutual_binding (layout_alloc shared_clos,rev functions):: binds', body) - end - | EXCEPTION(excon, nullary, mu, alloc, scope as TR(e2, _,_)) => - let - val (binds', body) = layout_rec e2 - val _ = inInfo := "(* exn *)" - in -(* ((append_info_with_name omit_region_info " (* exn value or name " " *)" info *) - (mk_excon_binding(excon,nullary, layout_alloc alloc, mu)::binds', body) - end - - | LETREGION_B{B = ref [], body as TR(e',_,_),...} => layout_rec e' - | LETREGION_B{B , body as TR(e',_,_),...} => - (case Eff.layoutEtas(!B) of [] => layout_rec e' - | _ => ([], layExp(lexp,0))) - | _ => ([],layExp(lexp,0)) - - val (l, body) = layout_rec lexp - val bindings = NODE{start = "", finish = "", childsep = RIGHT "; ", indent = 0, children = l} - in - PP.NODE{start= "let ", - finish=" end " (* ^ (!inInfo) *), (*martin*) - indent=4, - children=[bindings,body], - childsep=LEFT (" in " (* ^ (!inInfo) *) )} (*martin*) + LET{pat, bind, scope = t2 as TR(e2,_,_)} => + let val (binds, body) = layout_rec e2 + in (mk_valbind(pat,bind)::binds, body) + end + | FIX({shared_clos,functions,scope = t2 as TR(e2, _,_)}) => + let val (binds', body) = layout_rec e2 + in (mk_mutual_binding (layout_alloc shared_clos,rev functions):: binds', body) + end + | EXCEPTION(excon, nullary, mu, alloc, scope as TR(e2, _,_)) => + let val (binds', body) = layout_rec e2 + in (mk_excon_binding(excon,nullary, layout_alloc alloc, mu)::binds', body) + end + | LETREGION_B{B = ref [], body as TR(e',_,_),...} => layout_rec e' + | LETREGION_B{B , body as TR(e',_,_),...} => + (case Eff.layoutEtas(!B) of [] => layout_rec e' + | _ => ([], layExp(lexp,0))) + | _ => ([],layExp(lexp,0)) + val (l, body) = layout_rec lexp + val bindings = NODE{start = "", finish = "", childsep = RIGHT "; ", indent = 0, children = l} + in PP.NODE{start= "let ", + finish=" end ", + indent=4, + children=[bindings,body], + childsep=LEFT " in "} end and mk_valbind (pat, t) = - let - val child1 = layPatLet pat - in - NODE{start = "val ",finish="",childsep=RIGHT " = ", - indent=4, children=[child1, layTrip(t,0)] } - end + let val child1 = layPatLet pat + in NODE{start = "val ",finish="",childsep=RIGHT " = ", + indent=4, children=[child1, layTrip(t,0)] } + end + and mk_excon_binding (excon, nullary, alloc_t, mu) = (* exception EXCON : mu (* exn value or name at RHO *) or excpetion EXCON : mu *) - (case alloc_t of - NONE => NODE{start = "exception ",finish="",childsep=RIGHT " : ", - indent=4, children=[LEAF(Excon.pr_excon excon), layMu mu] } - | SOME t => NODE{start = "exception ",finish="",childsep=RIGHT " ", - indent=4, children=[LEAF(Excon.pr_excon excon), LEAF ":", layMu mu, - LEAF("(* exn value or name " ^ PP.flatten1 t ^ " *)")]} - ) + case alloc_t of + NONE => NODE{start = "exception ",finish="",childsep=RIGHT " : ", + indent=4, children=[LEAF(Excon.pr_excon excon), layMu mu] } + | SOME t => NODE{start = "exception ",finish="",childsep=RIGHT " ", + indent=4, children=[LEAF(Excon.pr_excon excon), LEAF ":", layMu mu, + LEAF("(* exn value or name " ^ PP.flatten1 t ^ " *)")]} + and mk_mutual_binding (opt_alloc, functions) = - let fun mk_fix({lvar,occ,tyvars=ref tyvars,rhos = ref rhos,epss= ref epss,Type, formal_regions, bind as TR(FN{pat, body, ...},_,_)}) - (no, rest_of_mutual_binding) = + let fun mk_fix({lvar,occ,tyvars=ref tyvars, rhos = ref rhos,epss= ref epss,Type, + formal_regions, bind as TR(FN{pat, body, ...},_,_)}) + (no, rest_of_mutual_binding) = (* fun f at rho : sigma (x_1, ..., x_n) = @@ -711,120 +617,109 @@ for more info*) *) (no-1, (case formal_regions of - NONE=> - let - val sigma_t = R.mk_lay_sigma' omit_region_info (rhos,epss,tyvars,Type) - val alloc_s = case opt_alloc of NONE => "" | SOME t => PP.flatten1 t - val t1 = let val s: string = Lvar.pr_lvar lvar ^ " " ^ alloc_s ^ - (if !Flags.print_types then ":" else "") - in PP.NODE{start = s, finish = "", indent = size s +1, - childsep = PP.NOSEP, children = [sigma_t]} - end - val formals = PP.HNODE{start="(", finish = ") =", childsep = PP.RIGHT ", ", - children = map (fn (lvar,_) => PP.LEAF(Lvar.pr_lvar lvar)) - pat} - val keyword = if no = 1 then "fun " else "and " - val body_t = PP.NODE{start = "", finish ="", indent = 4, childsep = PP.NOSEP, - children = [layTrip(body, 0)]} - in - PP.NODE{start = keyword , finish = "", indent = 4, childsep = PP.NOSEP, + NONE => + let val sigma_t = R.mk_lay_sigma' omit_region_info (rhos,epss,tyvars,Type) + val alloc_s = case opt_alloc of NONE => "" | SOME t => PP.flatten1 t + val t1 = let val s: string = Lvar.pr_lvar lvar ^ " " ^ alloc_s ^ + (if !Flags.print_types then ":" else "") + in PP.NODE{start = s, finish = "", indent = size s +1, + childsep = PP.NOSEP, children = [sigma_t]} + end + val formals = PP.HNODE{start="(", finish = ") =", childsep = PP.RIGHT ", ", + children = map (fn (lvar,_) => PP.LEAF(Lvar.pr_lvar lvar)) + pat} + val keyword = if no = 1 then "fun " else "and " + val body_t = PP.NODE{start = "", finish ="", indent = 4, childsep = PP.NOSEP, + children = [layTrip(body, 0)]} + in PP.NODE{start = keyword , finish = "", indent = 4, childsep = PP.NOSEP, children = [t1, formals, body_t]} - end + end + | SOME formals => + let fun layout_bind' b = case layout_bind b of SOME t => t | _ => die ".layout_bind'" + val region_binder_trees = PP.HNODE{start="", finish = "", childsep = PP.RIGHT ", ", + children = map layout_bind' formals} + val formals_t = PP.NODE{start = "(", finish = ") = ", indent = 1, childsep = PP.RIGHT", ", + children = region_binder_trees :: map layVarMu pat} + val alloc_s = case opt_alloc of + NONE => "" + | SOME t => PP.flatten1 t + val fun_f = + (if no = 1 then + "fun " ^ Lvar.pr_lvar lvar ^ alloc_s + else + "and " ^ Lvar.pr_lvar lvar) ^ alloc_s + + val header = PP.NODE{start = fun_f, finish ="", indent = 0, childsep = PP.NOSEP, + children = [formals_t]} + val body_t = PP.NODE{start = "", finish ="", indent = 4, childsep = PP.NOSEP, + children = [layTrip(body, 0)]} + in PP.NODE{start = "" , finish = "", indent = 0, childsep = PP.NOSEP, + children = [header, body_t]} - | SOME formals => - let - fun layout_bind' b = case layout_bind b of SOME t => t | _ => die ".layout_bind'" - val region_binder_trees = PP.HNODE{start="", finish = "", childsep = PP.RIGHT ", ", - children = map layout_bind' formals} - val formals_t = PP.NODE{start = "(", finish = ") = ", indent = 1, childsep = PP.RIGHT", ", - children = region_binder_trees :: map layVarMu pat} - val alloc_s = case opt_alloc of - NONE => "" - | SOME t => PP.flatten1 t - - val fun_f = - (if no = 1 then - "fun " ^ Lvar.pr_lvar lvar ^ alloc_s - else - "and " ^ Lvar.pr_lvar lvar) ^ alloc_s - - val header = PP.NODE{start = fun_f, finish ="", indent = 0, childsep = PP.NOSEP, - children = [formals_t]} - val body_t = PP.NODE{start = "", finish ="", indent = 4, childsep = PP.NOSEP, - children = [layTrip(body, 0)]} - in - PP.NODE{start = "" , finish = "", indent = 0, childsep = PP.NOSEP, - children = [header, body_t]} - - end + end + ) + :: rest_of_mutual_binding ) - :: rest_of_mutual_binding - ) - | mk_fix _ _ = die "mk_fix: rhs of fix does not begin with lambda" - in - PP.NODE{start = "", finish = "", indent = 0, - childsep = PP.NOSEP, - children = #2(foldl (uncurry mk_fix) (length functions,[]) functions)} - end + | mk_fix _ _ = die "mk_fix: rhs of fix does not begin with lambda" + in + PP.NODE{start = "", finish = "", indent = 0, + childsep = PP.NOSEP, + children = #2(foldl (uncurry mk_fix) (length functions,[]) functions)} + end in - (fn e => layExp(e,0), + (fn e => layExp(e,0), fn t => layTrip(t,0), layMus, layMeta) end - - fun layoutLambdaExp(layout_alloc: ('a -> StringTree option)) - (layout_binder: ('b -> StringTree option)) - (e: ('a, 'b)LambdaExp) :StringTree = - #1(mkLay(not(print_regions())) - layout_alloc layout_binder) e - - fun layoutLambdaExp' e = - layoutLambdaExp - (if print_regions() - then (fn rho => SOME(PP.LEAF("at " ^ PP.flatten1(Eff.layout_effect rho)))) - else (fn _ => NONE)) - (fn _ => NONE) - e - - - fun layoutLambdaTrip(layout_alloc: ('a -> StringTree option)) - (layout_binder: ('b -> StringTree option)) - (t: ('a, 'b)trip) :StringTree = - #2(mkLay(not(print_regions())) - layout_alloc layout_binder) t - - fun layoutLambdaPgm(layout_alloc: ('a -> StringTree option)) - (layout_binder: ('b -> StringTree option)) - (p: ('a, 'b)LambdaPgm as - PGM{expression = TR(lamb,meta,rea), - export_datbinds = DATBINDS dblist, - export_basis}):StringTree = - let - val layout_sigma = R.mk_lay_sigma (not(print_regions())) +fun layoutLambdaExp (layout_alloc: ('a -> StringTree option)) + (layout_binder: ('b -> StringTree option)) + (e: ('a, 'b)LambdaExp) :StringTree = + #1(mkLay(not(print_regions())) + layout_alloc layout_binder) e + +fun layoutLambdaExp' e = + layoutLambdaExp + (if print_regions() + then (fn rho => SOME(PP.LEAF("at " ^ PP.flatten1(Eff.layout_effect rho)))) + else (fn _ => NONE)) + (fn _ => NONE) + e + +fun layoutLambdaTrip (layout_alloc: ('a -> StringTree option)) + (layout_binder: ('b -> StringTree option)) + (t: ('a, 'b)trip) :StringTree = + #2(mkLay(not(print_regions())) + layout_alloc layout_binder) t + +fun layoutLambdaPgm (layout_alloc: ('a -> StringTree option)) + (layout_binder: ('b -> StringTree option)) + (p: ('a, 'b)LambdaPgm as + PGM{expression = TR(lamb,meta,rea), + export_datbinds = DATBINDS dblist, + export_basis}):StringTree = + let val layout_sigma = R.mk_lay_sigma (not(print_regions())) val (layExp,layTrip,layMus,layMeta) = mkLay(not(print_regions())) - layout_alloc layout_binder + layout_alloc layout_binder val layoutcb = - map (fn (con,_,sigma) =>PP.NODE{start="",finish="",indent=0, - children=[PP.LEAF (Con.pr_con con), - layout_sigma sigma], - childsep=PP.RIGHT " : "}) + map (fn (con,_,sigma) => PP.NODE{start="",finish="",indent=0, + children=[PP.LEAF (Con.pr_con con), + layout_sigma sigma], + childsep=PP.RIGHT " : "}) fun layoutdb (tyname,cb) = - let - val tynameT = PP.LEAF(TyName.pr_TyName tyname) - val cbT = PP.NODE{start="{",finish="}",indent=0, - children=layoutcb cb, - childsep=PP.RIGHT", "} - in - PP.NODE{start="",finish="",indent=0, - children=[tynameT,cbT], - childsep=PP.RIGHT" : "} - end + let val tynameT = PP.LEAF(TyName.pr_TyName tyname) + val cbT = PP.NODE{start="{",finish="}",indent=0, + children=layoutcb cb, + childsep=PP.RIGHT", "} + in PP.NODE{start="",finish="",indent=0, + children=[tynameT,cbT], + childsep=PP.RIGHT" : "} + end fun layoutMutualRec_db db = - PP.NODE{start="EXPORT DATATYPE: ",finish="; ",indent=3, - children=map layoutdb db,childsep=PP.LEFT" and "} + PP.NODE{start="EXPORT DATATYPE: ",finish="; ",indent=3, + children=map layoutdb db,childsep=PP.LEFT" and "} val dbTs = map layoutMutualRec_db dblist val lambT = layoutLambdaExp layout_alloc layout_binder lamb val t1 = PP.NODE{start="",finish="",indent=0, @@ -834,74 +729,66 @@ for more info*) val t3 = PP.NODE{start = "EFFECT: ", finish = "", childsep = PP.NOSEP, indent = 2, children = [Eff.layout_effect_deep rea]} val t4 = PP.NODE{start = "EXPORT REGION BASIS: [", finish = "]", indent = 1, childsep = PP.RIGHT ", ", - children = Eff.layoutEtas export_basis} - in - PP.NODE{start = "", finish = "", indent = 0, childsep = PP.NOSEP, children = [t1,t4,t2,t3]} - end + children = Eff.layoutEtas export_basis} + in + PP.NODE{start = "", finish = "", indent = 0, childsep = PP.NOSEP, children = [t1,t4,t2,t3]} + end - fun normPgm(PGM{expression, export_datbinds, export_basis}, tick: unit -> int) = - let -(* - val count = ref initval - fun tick() = (count:= !count+1; !count) -*) - val normVar = Eff.setkey tick - - fun normTrip(TR(e,_,_)) = norm e - and norm e = - let - fun normsw(SWITCH(tr1,rhsides, tr_opt)) = - (normTrip tr1; - app (fn (_, tr) => normTrip tr) rhsides; - case tr_opt of NONE => () - | SOME tr => normTrip tr) - in - case e of - UB_RECORD ts => app normTrip ts - | FN{body,...} => normTrip body - | LETREGION_B{B,body,...} => - (app normVar (!B); - normTrip body) - | LET{bind, scope, ...} => (normTrip bind; normTrip scope) - | FIX{functions, scope, ...} => - (app (fn {rhos, epss, bind, ...} => - (app normVar (!rhos); - app normVar (!epss); - normTrip bind)) functions; - normTrip scope) - | APP(tr1,tr2) => (normTrip tr1; normTrip tr2) - | EXCEPTION(_,_,_,_,body) => normTrip body - | RAISE(tr) => normTrip tr - | HANDLE(tr1,tr2) => (normTrip tr1; normTrip tr2) - | SWITCH_I {switch, precision} => normsw switch - | SWITCH_W {switch, precision} => normsw switch - | SWITCH_S(sw) => normsw sw - | SWITCH_C(sw) => normsw sw - | SWITCH_E(sw) => normsw sw - | CON0 _ => () - | CON1 (_,tr) => normTrip tr - | DECON (_,tr) => normTrip tr - | EXCON (_,NONE) => () - | EXCON (_,SOME(_,tr)) => normTrip tr - | DEEXCON (_,tr) => normTrip tr - | RECORD (_,trs) => app normTrip trs - | SELECT (_,tr) => normTrip tr - | DEREF tr => normTrip tr - | REF (_,tr) => normTrip tr - | ASSIGN (_,tr1,tr2) => (normTrip tr1; normTrip tr2) - | EQUAL (_,tr1,tr2) => (normTrip tr1; normTrip tr2) - | CCALL (_,trs) => app normTrip trs - | BLOCKF64 (_,trs) => app normTrip trs - | SCRATCHMEM _ => () - | EXPORT (_, tr) => normTrip tr - | RESET_REGIONS (_, tr) => normTrip tr - | FRAME{declared_lvars, ...} =>() - | _ => () - end +fun normPgm (PGM{expression, export_datbinds, export_basis}, tick: unit -> int) = + let val normVar = Eff.setkey tick + fun normTrip (TR(e,_,_)) = norm e + and norm e = + let fun normsw (SWITCH(tr1,rhsides, tr_opt)) = + (normTrip tr1; + app (fn (_, tr) => normTrip tr) rhsides; + case tr_opt of NONE => () + | SOME tr => normTrip tr) + in case e of + UB_RECORD ts => app normTrip ts + | FN{body,...} => normTrip body + | LETREGION_B{B,body,...} => + (app normVar (!B); + normTrip body) + | LET{bind, scope, ...} => (normTrip bind; normTrip scope) + | FIX{functions, scope, ...} => + (app (fn {rhos, epss, bind, ...} => + (app normVar (!rhos); + app normVar (!epss); + normTrip bind)) functions; + normTrip scope) + | APP(tr1,tr2) => (normTrip tr1; normTrip tr2) + | EXCEPTION(_,_,_,_,body) => normTrip body + | RAISE(tr) => normTrip tr + | HANDLE(tr1,tr2) => (normTrip tr1; normTrip tr2) + | SWITCH_I {switch, precision} => normsw switch + | SWITCH_W {switch, precision} => normsw switch + | SWITCH_S(sw) => normsw sw + | SWITCH_C(sw) => normsw sw + | SWITCH_E(sw) => normsw sw + | CON0 _ => () + | CON1 (_,tr) => normTrip tr + | DECON (_,tr) => normTrip tr + | EXCON (_,NONE) => () + | EXCON (_,SOME(_,tr)) => normTrip tr + | DEEXCON (_,tr) => normTrip tr + | RECORD (_,trs) => app normTrip trs + | SELECT (_,tr) => normTrip tr + | DEREF tr => normTrip tr + | REF (_,tr) => normTrip tr + | ASSIGN (tr1,tr2) => (normTrip tr1; normTrip tr2) + | EQUAL (_,tr1,tr2) => (normTrip tr1; normTrip tr2) + | CCALL (_,trs) => app normTrip trs + | BLOCKF64 (_,trs) => app normTrip trs + | SCRATCHMEM _ => () + | EXPORT (_, tr) => normTrip tr + | RESET_REGIONS (_, tr) => normTrip tr + | FRAME{declared_lvars, ...} =>() + | _ => () + end in - (* re_number exported region and effect variables *) - (*app (*(Eff.setkey tick)*) normVar export_basis; commented out; mads *) - (* re_number bound variables in expression*) - normTrip expression + (* re_number exported region and effect variables *) + (*app (*(Eff.setkey tick)*) normVar export_basis; commented out; mads *) + (* re_number bound variables in expression*) + normTrip expression end - end +end diff --git a/src/Compiler/Regions/RegionFlowGraphProfiling.sml b/src/Compiler/Regions/RegionFlowGraphProfiling.sml index 5f5e5cf8e..d1cce09d0 100644 --- a/src/Compiler/Regions/RegionFlowGraphProfiling.sml +++ b/src/Compiler/Regions/RegionFlowGraphProfiling.sml @@ -31,12 +31,10 @@ structure RegionFlowGraphProfiling : REGION_FLOW_GRAPH_PROFILING = fun show_atkind (AtInf.ATTOP _) = "attop" | show_atkind (AtInf.ATBOT _) = "atbot" | show_atkind (AtInf.SAT _) = "sat" - | show_atkind (AtInf.IGNORE) = die "show_atkind" fun get_info_actual (AtInf.ATTOP i) = i | get_info_actual (AtInf.ATBOT i) = i | get_info_actual (AtInf.SAT i) = i - | get_info_actual _ = die "get_info_actual" (* Ordering for storage modes. ATBOT < ATTOP and SAT < ATTOP. *) fun maxAtKind ak1 (SOME ak2) = @@ -49,8 +47,7 @@ structure RegionFlowGraphProfiling : REGION_FLOW_GRAPH_PROFILING = | (AtInf.ATTOP _, AtInf.SAT _) => ak1 | (AtInf.ATTOP _, AtInf.ATTOP _) => ak1 | (AtInf.ATBOT _, AtInf.SAT _) => ak2 - | (AtInf.SAT _, AtInf.ATBOT _) => ak1 - | _ => die ("maxAtKind("^(show_atkind ak1)^","^(show_atkind ak2)^")")) + | (AtInf.SAT _, AtInf.ATBOT _) => ak1) | maxAtKind ak1 NONE = ak1 (*--------------------------------------------------------------------------------------* diff --git a/src/Compiler/Regions/RegionStatEnv.sml b/src/Compiler/Regions/RegionStatEnv.sml index 52bfdf372..6dd51ee68 100644 --- a/src/Compiler/Regions/RegionStatEnv.sml +++ b/src/Compiler/Regions/RegionStatEnv.sml @@ -34,26 +34,27 @@ structure RegionStatEnv: REGION_STAT_ENV = type il = R.il type cone = R.cone + type con = Con.con (* Unqualified value constructors. *) + type excon = Excon.excon (* Unqualified exception constructors.*) + type TyName = TyName.TyName + type lvar = Lvar.lvar (* Unique lambda identifiers. *) + type sigma = R.sigma + and Type = R.Type + and mu = R.mu + and place = R.place + type instance_list = (il * (il * cone -> il * cone)) ref list - type lvar_env_range = bool * bool * RegVar.regvar list * R.sigma * R.place + type lvar_env_range = bool * bool * RegVar.regvar list * sigma * place option * instance_list ref option * (il ->unit)option type regionStatEnv = {tyname_env : arity TyNameMap.map, con_env : R.sigma ConMap.map, - excon_env : (R.Type * R.place) ExconMap.map, + excon_env : mu ExconMap.map, lvar_env : lvar_env_range LvarMap.map, regvar_env : E.effect RegVar.Map.map, tyvar_env : effectvar L.TyvarMap.map } - type con = Con.con (* Unqualified value constructors. *) - type excon = Excon.excon (* Unqualified exception constructors.*) - type TyName = TyName.TyName - type lvar = Lvar.lvar (* Unique lambda identifiers. *) - type TypeAndPlaceScheme = R.sigma - and TypeAndPlace = (R.Type * R.place) - and Type = R.Type - and place = R.place val empty: regionStatEnv = {tyname_env = TyNameMap.empty, con_env = ConMap.empty, @@ -97,57 +98,49 @@ structure RegionStatEnv: REGION_STAT_ENV = fun mk_nil_sigma c lev0 = let val alpha = L.fresh_tyvar() - val alpha_ty = R.mkTYVAR alpha - val (rho,c) = E.freshRho c (* bot-region for tyvar *) - val (rho',c) = E.freshRhoWithTy(E.PAIR_RT, c) (* aux region for pairs *) - val (c,nil_sigma) = R.generalize_all (c, lev0, [(alpha,NONE)], mkListType((alpha_ty,rho), rho')) + val alpha_mu = R.mkTYVAR alpha + val (rho,c) = E.freshRhoWithTy(E.PAIR_RT, c) (* aux region for pairs *) + val (c,nil_sigma) = R.generalize_all (c, lev0, [(alpha,NONE)], mkListType(alpha_mu, rho)) in (c, nil_sigma) end - fun mk_cons_sigma c lev0 rt_list = + fun mk_cons_sigma c lev0 = let val alpha = L.fresh_tyvar() - val alpha_ty = R.mkTYVAR alpha - val (rho,c) = E.freshRho c (* bot-region for tyvar *) - val (rho',c) = E.freshRhoWithTy(E.PAIR_RT, c) (* aux region for pairs *) - val (rho'',c) = E.freshRhoWithTy(rt_list, c) (* region for result list *) - val alpha_rho_list = (mkListType((alpha_ty,rho), rho'), rho'') - val (arreff, c) = E.freshEps c - val _ = E.edge(arreff, E.mkPut rho'') - - val cons_mu = R.mkFUN([(R.mkRECORD[(alpha_ty,rho),alpha_rho_list], rho')], - arreff, - [alpha_rho_list]) + val alpha_mu = R.mkTYVAR alpha + val (rho,c) = E.freshRhoWithTy(E.PAIR_RT, c) (* aux region for pairs *) + val list_mu = mkListType(alpha_mu, rho) + val (arreff,c) = E.freshEps c + val cons_mu = R.mkFUN([R.mkBOX(R.mkRECORD[alpha_mu,list_mu], rho)], + arreff, + [list_mu]) val (c,cons_sigma) = R.generalize_all (c, lev0, [(alpha,NONE)], cons_mu) in (c, cons_sigma) end fun mkFragConsTy mu1 ae (mu,rho,rho0) = - R.mkFUN([mu1],ae,[(R.mkCONSTYPE(TyName.tyName_FRAG, [mu], [rho], []), rho0)]) + R.mkFUN([mu1],ae,[R.mkBOX(R.mkCONSTYPE(TyName.tyName_FRAG, [mu], [rho], []), rho0)]) fun mk_quote_sigma c lev0 = let val alpha = L.fresh_tyvar() - val alpha_ty = R.mkTYVAR alpha + val alpha_mu = R.mkTYVAR alpha val (rho1,c) = E.freshRhoWithTy(E.STRING_RT, c) (* region for auxiliary strings *) val (rho2,c) = E.freshRhoWithTy(E.TOP_RT, c) (* region for result frag *) - val (rho3,c) = E.freshRho c (* bot-region for tyvar *) val (arreff, c) = E.freshEps c val _ = E.edge(arreff, E.mkPut rho2) - val quote_ty = mkFragConsTy (R.mkCONSTYPE(TyName.tyName_STRING,[],[],[]),rho1) - arreff ((alpha_ty,rho3),rho1,rho2) + val quote_ty = mkFragConsTy (R.mkBOX(R.mkCONSTYPE(TyName.tyName_STRING,[],[],[]),rho1)) + arreff (alpha_mu,rho1,rho2) val (c,quote_sigma) = R.generalize_all (c, lev0, [(alpha,NONE)], quote_ty) in (c, quote_sigma) end fun mk_antiquote_sigma c lev0 = let val alpha = L.fresh_tyvar() - val alpha_ty = R.mkTYVAR alpha + val alpha_mu = R.mkTYVAR alpha val (rho1,c) = E.freshRhoWithTy(E.STRING_RT, c) (* region for auxiliary strings *) val (rho2,c) = E.freshRhoWithTy(E.TOP_RT, c) (* region for result frag *) - val (rho3,c) = E.freshRho c (* bot-region for tyvar *) val (arreff, c) = E.freshEps c val _ = E.edge(arreff, E.mkPut rho2) - val antiquote_ty = mkFragConsTy (alpha_ty,rho3) - arreff ((alpha_ty,rho3),rho1,rho2) + val antiquote_ty = mkFragConsTy alpha_mu arreff (alpha_mu,rho1,rho2) val (c,antiquote_sigma) = R.generalize_all (c, lev0, [(alpha,NONE)], antiquote_ty) in (c, antiquote_sigma) end @@ -159,22 +152,16 @@ structure RegionStatEnv: REGION_STAT_ENV = end fun mk_intinf_sigma c lev0 = - let val (rInt31,c) = E.freshRhoWithTy(E.WORD_RT, c) - val (rBool,c) = E.freshRhoWithTy(E.WORD_RT, c) - val (rListPair,c) = E.freshRhoWithTy(E.PAIR_RT, c) - val (rList,c) = E.freshRhoWithTy(E.WORD_RT, c) - val (rIntInf,c) = E.freshRhoWithTy(E.WORD_RT, c) + let val (rListPair,c) = E.freshRhoWithTy(E.PAIR_RT, c) val (rRec,c) = E.freshRhoWithTy(E.PAIR_RT, c) - val bool_mu = (R.mkCONSTYPE(TyName.tyName_BOOL,[],[],[]), rBool) - val int31_mu = (R.mkCONSTYPE(TyName.tyName_INT31,[],[],[]),rInt31) - val digits_mu = (mkListType(int31_mu,rListPair),rList) - val arg_mu = (R.mkRECORD[(*digits= *)digits_mu, (*negative= *)bool_mu],rRec) - val intinf_mu = (R.mkCONSTYPE(TyName.tyName_INTINF,[],[rRec,rListPair],[]), rIntInf) + val bool_mu = R.mkCONSTYPE(TyName.tyName_BOOL,[],[],[]) + val int31_mu = R.mkCONSTYPE(TyName.tyName_INT31,[],[],[]) + val digits_mu = mkListType(int31_mu,rListPair) + val arg_mu = R.mkBOX(R.mkRECORD[digits_mu,bool_mu],rRec) + val intinf_mu = R.mkCONSTYPE(TyName.tyName_INTINF,[],[rRec,rListPair],[]) val (ae, c) = E.freshEps c - val _ = E.edge(ae, E.mkPut rIntInf) val f = R.mkFUN([arg_mu],ae,[intinf_mu]) - val (c,intinf_sigma) = - R.generalize_all (c, lev0, [], f) + val (c,intinf_sigma) = R.generalize_all (c, lev0, [], f) in (c,intinf_sigma) end @@ -183,14 +170,12 @@ structure RegionStatEnv: REGION_STAT_ENV = val c = E.push c val (c, nil_sigma) = mk_nil_sigma c lev0 - val (c, cons_sigma) = mk_cons_sigma c lev0 E.TOP_RT (* boxed version *) - val (c, cons_sigma_unboxed) = mk_cons_sigma c lev0 E.WORD_RT (* unboxed version *) + val (c, cons_sigma) = mk_cons_sigma c lev0 val (c, bool_sigma) = mk_bool_sigma c lev0 val (c, quote_sigma) = mk_quote_sigma c lev0 val (c, antiquote_sigma) = mk_antiquote_sigma c lev0 val (c, intinf_sigma) = mk_intinf_sigma c lev0 in - val cons_sigma_unboxed = cons_sigma_unboxed val conenv0 = ConMap.fromList [(Con.con_TRUE, bool_sigma), (Con.con_FALSE, bool_sigma), (Con.con_NIL, nil_sigma), @@ -201,7 +186,7 @@ structure RegionStatEnv: REGION_STAT_ENV = end val excon_env0 = ExconMap.fromList - (map (fn excon => (excon, (R.exnType,E.toplevel_region_withtype_top))) + (map (fn excon => (excon, R.mkBOX(R.exnType,E.toplevel_region_withtype_top))) [Excon.ex_DIV, Excon.ex_MATCH, Excon.ex_BIND, Excon.ex_OVERFLOW, Excon.ex_INTERRUPT, Excon.ex_SUBSCRIPT, Excon.ex_SIZE]) @@ -217,11 +202,11 @@ structure RegionStatEnv: REGION_STAT_ENV = ("greg_ref", E.toplevel_region_withtype_ref)]) val initial: regionStatEnv = {tyname_env = tyname_env0, - con_env = conenv0, - excon_env = excon_env0, - lvar_env = LvarMap.empty (*lvar_env0*), + con_env = conenv0, + excon_env = excon_env0, + lvar_env = LvarMap.empty, regvar_env = regvar_env0, - tyvar_env = L.TyvarMap.empty} + tyvar_env = L.TyvarMap.empty} fun declareTyName (tyname,arity,{tyname_env, con_env,excon_env, lvar_env,regvar_env,tyvar_env}) = @@ -288,19 +273,9 @@ structure RegionStatEnv: REGION_STAT_ENV = tyvar_env = L.TyvarMap.plus(tyvar_env,tyvar_env')} fun lookupTyVar (rse : regionStatEnv as {tyvar_env,...}) = L.TyvarMap.lookup tyvar_env - fun lookupRegVar (rse : regionStatEnv as {regvar_env,...}) = RegVar.Map.lookup regvar_env - fun lookupTyName (rse : regionStatEnv as {tyname_env,...}) = TyNameMap.lookup tyname_env - - (* To deal with togling of representation of lists we check here in the - * lookupCon function if unboxing of datatypes is enabled: - *) - - fun lookupCon (rse : regionStatEnv as {con_env,...}) con = - if Con.eq(con,Con.con_CONS) then SOME cons_sigma_unboxed - else ConMap.lookup con_env con - + fun lookupCon (rse : regionStatEnv as {con_env,...}) con = ConMap.lookup con_env con fun lookupExcon (rse : regionStatEnv as {excon_env,...}) = ExconMap.lookup excon_env fun lookupLvar (rse : regionStatEnv as {lvar_env,...}) = LvarMap.lookup lvar_env fun FoldLvar f b (rse: regionStatEnv as {lvar_env, ...}) = LvarMap.Fold f b lvar_env @@ -319,12 +294,13 @@ structure RegionStatEnv: REGION_STAT_ENV = type cone = E.cone fun pr_effect e = PP.flatten1(Effect.layout_effect e) + fun warn n = print ("** WARNING: free effect with wrong level: " ^ pr_effect n ^ "\n") fun rhos_epss_free_rse (rse: regionStatEnv) = let val rhos_epss = FoldLvar (fn ((_,(_,_,_,sigma,rho,_,_)),acc) => - R.ann_sigma sigma (rho::acc)) [] rse + R.ann_sigma sigma (case rho of SOME rho => rho::acc | NONE => acc)) [] rse val rhos_epss = FoldExcon (fn ((_,mu),acc) => R.ann_mus [mu] acc) rhos_epss rse val rhos_epss = FoldTyVar (fn ((_,e),acc) => e::acc) rhos_epss rse @@ -362,18 +338,19 @@ structure RegionStatEnv: REGION_STAT_ENV = end fun rhos_epss_free_rse' (rse: regionStatEnv) = - let val rhos_epss = FoldLvar (fn ((_,(_,_,_,sigma,rho,_,_)),acc) => - R.ferv_sigma sigma @ (rho::acc)) [] rse - val rhos_epss = FoldExcon (fn ((_,(ty,rho)),acc) => - R.ferv_sigma (R.type_to_scheme ty) @ (rho::acc)) rhos_epss rse - val rhos_epss = FoldTyVar (fn ((_,e),acc) => e::acc) rhos_epss rse - val rhos_epss = E.remove_duplicates rhos_epss - fun closure ([],acc) = acc - | closure (rho_eps::rest,acc) = - closure(rest, let in - if E.is_arrow_effect rho_eps then - foldl (fn (node, acc) => - let in + let val rhos_epss = FoldLvar (fn ((_,(_,_,_,sigma,rho,_,_)),acc) => + R.ferv_sigma sigma @ + (case rho of SOME rho => rho::acc | NONE => acc)) + [] rse + val rhos_epss = FoldExcon (fn ((_,mu),acc) => + R.ferv_sigma (R.type_to_scheme mu) @ acc) + rhos_epss rse + val rhos_epss = FoldTyVar (fn ((_,e),acc) => e::acc) rhos_epss rse + val rhos_epss = E.remove_duplicates rhos_epss + fun closure ([],acc) = acc + | closure (rho_eps::rest,acc) = + closure(rest, if E.is_arrow_effect rho_eps then + foldl (fn (node, acc) => if E.is_arrow_effect node then node::acc else if E.is_put node orelse E.is_get node then E.rho_of node :: acc @@ -383,18 +360,18 @@ structure RegionStatEnv: REGION_STAT_ENV = TextIO.output(!Flags.log, "atomic effect:\n"); dump(E.layout_effect_deep(node)); die "mkConeToplevel.closure.node not arrow effect or get/put effect") - end) - acc (E.represents rho_eps) - else if E.is_rho rho_eps then rho_eps :: acc - else acc - end) + ) + acc (E.represents rho_eps) + else if E.is_rho rho_eps then rho_eps :: acc + else acc + ) val rhos_epss = E.sort(E.remove_duplicates(closure(rhos_epss,[]))) - in rhos_epss - end + in rhos_epss + end fun mkConeToplevel (rse: regionStatEnv) : cone = - (E.reset_cone E.emptyCone; - E.pushLayer(rhos_epss_free_rse rse,E.emptyCone)) + (E.reset_cone E.emptyCone; + E.pushLayer(rhos_epss_free_rse rse,E.emptyCone)) fun equal_sigma (sigma1,sigma2) = R.alpha_equal (sigma1,sigma2) E.initCone @@ -403,28 +380,31 @@ structure RegionStatEnv: REGION_STAT_ENV = | eq_regvars _ = false fun equal_lvar_res ((b1,b1',rvs1,sigma1,place1,_,_),(b2,b2',rvs2,sigma2,place2,_,_)) = - b1=b2 andalso b1' =b2' andalso E.eq_effect(place1,place2) andalso - equal_sigma(sigma1,sigma2) andalso eq_regvars (rvs1,rvs2) + b1 = b2 andalso b1' = b2' + andalso (case (place1, place2) of + (SOME p1,SOME p2) => E.eq_effect(p1,p2) + | (NONE, NONE) => true + | _ => false) + andalso equal_sigma(sigma1,sigma2) andalso eq_regvars (rvs1,rvs2) fun equal_con_res (sigma1,sigma2) = equal_sigma (sigma1,sigma2) - fun equal_excon_res ((tau1,place1),(tau2,place2)) = - E.eq_effect(place1,place2) andalso - equal_sigma(R.type_to_scheme tau1,R.type_to_scheme tau2) + fun equal_excon_res (mu1,mu2) = + equal_sigma(R.type_to_scheme mu1,R.type_to_scheme mu2) local fun tyname_env_restrict (tyname_env,tynames) = - TyNameMap.restrict(TyName.pr_TyName,tyname_env,tynames) - handle TyNameMap.Restrict s => die ("restrict; I cannot find tyname " ^ s ^ " in the environment") + TyNameMap.restrict(TyName.pr_TyName,tyname_env,tynames) + handle TyNameMap.Restrict s => die ("restrict; I cannot find tyname " ^ s ^ " in the environment") fun con_env_restrict (con_env,cons) = - ConMap.restrict(Con.pr_con,con_env,cons) - handle ConMap.Restrict s => die ("restrict; I cannot find con " ^ s ^ " in the environment") + ConMap.restrict(Con.pr_con,con_env,cons) + handle ConMap.Restrict s => die ("restrict; I cannot find con " ^ s ^ " in the environment") fun excon_env_restrict (excon_env,excons) = - ExconMap.restrict(Excon.pr_excon,excon_env,excons) - handle ExconMap.Restrict s => die ("restrict; I cannot find excon " ^ s ^ " in the environment") + ExconMap.restrict(Excon.pr_excon,excon_env,excons) + handle ExconMap.Restrict s => die ("restrict; I cannot find excon " ^ s ^ " in the environment") fun lvar_env_restrict (lvar_env,lvars) = - LvarMap.restrict(Lvar.pr_lvar,lvar_env,lvars) - handle LvarMap.Restrict s => die ("restrict; I cannot find lvar " ^ s ^ " in the environment") + LvarMap.restrict(Lvar.pr_lvar,lvar_env,lvars) + handle LvarMap.Restrict s => die ("restrict; I cannot find lvar " ^ s ^ " in the environment") in fun restrict ({tyname_env, con_env, excon_env,lvar_env,regvar_env=_,tyvar_env=_}, {tynames,cons,excons,lvars}) = @@ -437,48 +417,58 @@ structure RegionStatEnv: REGION_STAT_ENV = end fun places_effectvarsRSE rse = - let val rhos_epss = rhos_epss_free_rse rse - val rhos = List.filter E.is_rho rhos_epss - val epss = List.filter E.is_arrow_effect rhos_epss - in (rhos,epss) - end + let val rhos_epss = rhos_epss_free_rse rse + val rhos = List.filter E.is_rho rhos_epss + val epss = List.filter E.is_arrow_effect rhos_epss + in (rhos,epss) + end fun places_effectvarsRSE' rse = - let val rhos_epss = rhos_epss_free_rse' rse - val rhos = List.filter E.is_rho rhos_epss - val epss = List.filter E.is_arrow_effect rhos_epss - in (rhos,epss) - end + let val rhos_epss = rhos_epss_free_rse' rse + val rhos = List.filter E.is_rho rhos_epss + val epss = List.filter E.is_arrow_effect rhos_epss + in (rhos,epss) + end type StringTree = PP.StringTree val layout_scheme = R.mk_lay_sigma false (* do not omit region info *) val (_,layout_mu) = R.mk_layout false (* do not omit region info *) - fun layout_pair (_,_,_,sigma,p,_,_) = PP.NODE{start= "(", finish = ")", indent = 1, childsep = PP.RIGHT ",", - children = [layout_scheme sigma, E.layout_effect p]} + fun layout_pair (_,_,_,sigma,p,_,_) = + case p of + SOME p => PP.NODE{start= "(", finish = ")", indent = 1, childsep = PP.RIGHT ",", + children = [layout_scheme sigma, E.layout_effect p]} + | NONE => layout_scheme sigma + fun layout_arity (a,b,c) = - PP.NODE{start = "(", finish = ")", - indent = 1, childsep = PP.RIGHT ", ", - children = PP.LEAF (Int.toString a) :: - (map (PP.LEAF o E.show_runType) b) @ [PP.LEAF (Int.toString c)]} + PP.NODE{start = "(", finish = ")", + indent = 1, childsep = PP.RIGHT ", ", + children = PP.LEAF (Int.toString a) :: + (map (PP.LEAF o E.show_runType) b) @ [PP.LEAF (Int.toString c)]} - fun layout_tyname_env e = TyNameMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o TyName.pr_TyName) layout_arity e + fun layout_tyname_env e = + TyNameMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o TyName.pr_TyName) layout_arity e - fun layout_con_env e = ConMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o Con.pr_con) layout_scheme e + fun layout_con_env e = + ConMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o Con.pr_con) layout_scheme e - fun layout_excon_env e = ExconMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o Excon.pr_excon) layout_mu e + fun layout_excon_env e = + ExconMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o Excon.pr_excon) layout_mu e - fun layout_lvar_env e = LvarMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o Lvar.pr_lvar) layout_pair e + fun layout_lvar_env e = + LvarMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o Lvar.pr_lvar) layout_pair e - fun layout_regvar_env e = RegVar.Map.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o RegVar.pr) E.layout_effect e + fun layout_regvar_env e = + RegVar.Map.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o RegVar.pr) E.layout_effect e - fun layout_tyvar_env e = L.TyvarMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} - (PP.LEAF o L.pr_tyvar) E.layout_effect e + fun layout_tyvar_env e = + L.TyvarMap.layoutMap {start = "{", eq = " -> ", finish = "}", sep = ","} + (PP.LEAF o L.pr_tyvar) E.layout_effect e fun layout (rse as {tyname_env, con_env, excon_env,lvar_env,regvar_env,tyvar_env}) = PP.NODE{start = "RegionStaticEnvironment:", finish = "(end of RegionStatEnvironment)", @@ -491,10 +481,12 @@ structure RegionStatEnv: REGION_STAT_ENV = layout_tyvar_env tyvar_env]} val debug_man_enrich = Flags.is_on0 "debug_man_enrich" + fun debug (s, b) = if debug_man_enrich() then (if b then log("\nRSE." ^ s ^ ": enrich succeeded.") else log("\nRSE." ^ s ^ ": enrich failed."); b) else b + fun debug1 (s, b,lvenv,lvenv1) = if debug_man_enrich() then (if b then log("\nRSE." ^ s ^ ": enrich succeeded.") @@ -507,8 +499,9 @@ structure RegionStatEnv: REGION_STAT_ENV = else b - fun enrich ({tyname_env, con_env, excon_env,lvar_env,regvar_env,tyvar_env}, - {tyname_env=tyname_env1, con_env=con_env1, excon_env=excon_env1,lvar_env=lvar_env1,regvar_env=regvar_env1,tyvar_env=tyvar_env1}) = + fun enrich ({tyname_env, con_env, excon_env,lvar_env,regvar_env,tyvar_env}:regionStatEnv, + {tyname_env=tyname_env1, con_env=con_env1, excon_env=excon_env1, + lvar_env=lvar_env1,regvar_env=regvar_env1,tyvar_env=tyvar_env1}:regionStatEnv) = debug("TyNameMap", TyNameMap.enrich (op =) (tyname_env,tyname_env1)) andalso debug("ConMap", ConMap.enrich equal_con_res (con_env,con_env1)) andalso debug("ExconMap", ExconMap.enrich equal_excon_res (excon_env,excon_env1)) andalso @@ -541,8 +534,8 @@ structure RegionStatEnv: REGION_STAT_ENV = List.foldl (fn (ex,acc) => case lookupExcon rse ex of NONE => die "spuriousTyvars.ex" - | SOME(ty,_) => - case R.ftv_ty ty of + | SOME mu => + case R.ftv_ty mu of nil => acc | tvs => spuriousJoin (R.ftv_minus(tvs,R.ftv_ty ty0)) acc @@ -558,17 +551,19 @@ structure RegionStatEnv: REGION_STAT_ENV = Pickle.convert (fn ((b1,b2,rvs),s,p) => (b1,b2,rvs,s,p,NONE,NONE), fn (b1,b2,rvs,s,p,NONE,NONE) => ((b1,b2,rvs),s,p) | _ => die "pu_lvar_env_range") - (Pickle.tup3Gen0(Pickle.tup3Gen0(Pickle.bool,Pickle.bool,Pickle.listGen RegVar.pu),Pickle.debugUnpickle "sigma" R.pu_sigma,Pickle.debugUnpickle "effect" E.pu_effect)) + (Pickle.tup3Gen0(Pickle.tup3Gen0(Pickle.bool,Pickle.bool,Pickle.listGen RegVar.pu),Pickle.debugUnpickle "sigma" R.pu_sigma,Pickle.debugUnpickle "effect" (Pickle.optionGen E.pu_effect))) val pu : regionStatEnv Pickle.pu = Pickle.debugUnpickle "regionStatEnv" (Pickle.convert (fn (te:arity TyNameMap.map,ce: R.sigma ConMap.map, - ee:(R.Type*R.place) ExconMap.map,le) => {tyname_env=te,con_env=ce,excon_env=ee,lvar_env=le, - regvar_env=RegVar.Map.empty,tyvar_env=L.TyvarMap.empty}, - fn {tyname_env=te,con_env=ce,excon_env=ee,lvar_env=le,regvar_env=_,tyvar_env=_} => (te,ce,ee,le)) - (Pickle.tup4Gen0(TyNameMap.pu TyName.pu pu_arity, - ConMap.pu Con.pu (Pickle.debugUnpickle "con_env_range" R.pu_sigma), - ExconMap.pu Excon.pu (Pickle.debugUnpickle "excon_env_range" R.pu_mu), - LvarMap.pu Lvar.pu (Pickle.debugUnpickle "lvar_env_range" pu_lvar_env_range))) + ee:mu ExconMap.map,le) => + {tyname_env=te,con_env=ce,excon_env=ee,lvar_env=le, + regvar_env=RegVar.Map.empty,tyvar_env=L.TyvarMap.empty}, + fn {tyname_env=te,con_env=ce,excon_env=ee,lvar_env=le, + regvar_env=_,tyvar_env=_} => (te,ce,ee,le)) + (Pickle.tup4Gen0(TyNameMap.pu TyName.pu pu_arity, + ConMap.pu Con.pu (Pickle.debugUnpickle "con_env_range" R.pu_sigma), + ExconMap.pu Excon.pu (Pickle.debugUnpickle "excon_env_range" R.pu_mu), + LvarMap.pu Lvar.pu (Pickle.debugUnpickle "lvar_env_range" pu_lvar_env_range))) ) end diff --git a/src/Compiler/Regions/SPREAD_EXPRESSION.sml b/src/Compiler/Regions/SPREAD_EXPRESSION.sml index 4295cb136..2cce34609 100644 --- a/src/Compiler/Regions/SPREAD_EXPRESSION.sml +++ b/src/Compiler/Regions/SPREAD_EXPRESSION.sml @@ -1,7 +1,6 @@ -(*$SPREAD_EXPRESSION: LAMBDA_EXP REGION_EXP REGION_STAT_ENV*) signature SPREAD_EXPRESSION = - sig + sig structure E : LAMBDA_EXP structure E': REGION_EXP structure RegionStatEnv: REGION_STAT_ENV @@ -18,5 +17,4 @@ signature SPREAD_EXPRESSION = val spreadPgm: cone * RegionStatEnv.regionStatEnv * E.LambdaPgm -> cone * RegionStatEnv.regionStatEnv * (place,unit)E'.LambdaPgm - - end; + end diff --git a/src/Compiler/Regions/SpreadDataType.sml b/src/Compiler/Regions/SpreadDataType.sml index d67d25d00..91fe707ce 100644 --- a/src/Compiler/Regions/SpreadDataType.sml +++ b/src/Compiler/Regions/SpreadDataType.sml @@ -1,10 +1,10 @@ (* -* The purpose of SpreadDatatype is to analyse datatype declarations -* and find out for each type name what its arity is (not just the -* type arity, which is given in the input program) but also the -* region and effect arity). Moreover, the module infers a region-polymorphic -* type scheme for each value constructor declared in the source program. -*) + * The purpose of SpreadDatatype is to analyse datatype declarations + * and find out for each type name what its arity is (not just the + * type arity, which is given in the input program) but also the + * region and effect arity). Moreover, the module infers a region-polymorphic + * type scheme for each value constructor declared in the source program. + *) structure SpreadDatatype: SPREAD_DATATYPE = struct @@ -32,9 +32,9 @@ struct fun die s = Crash.impossible ("SpreadDatatype." ^ s) fun noSome x msg = - case x of - SOME it => it - | NONE => die msg + case x of + SOME it => it + | NONE => die msg fun apply_n f 0 = [] | apply_n f n = f() :: apply_n f (n-1) @@ -45,16 +45,15 @@ struct (* one target_datbind for each set of mutually recursive datatype bindings *) type target_datbind = target_db list - (**************************) (* *) (* arities *) (* *) (**************************) - fun merge_runtypes([], l2) = l2 - | merge_runtypes(l1, []) = l1 - | merge_runtypes(l1 as (x::xs), l2 as (y::ys)) = + fun merge_runtypes ([], l2) = l2 + | merge_runtypes (l1, []) = l1 + | merge_runtypes (l1 as (x::xs), l2 as (y::ys)) = let val i1 = Effect.ord_runType x val i2 = Effect.ord_runType y in @@ -75,7 +74,6 @@ struct type arity = int * Effect.runType list * eff_arity val arity0 = (0, [], zero) - infix ++ fun ((a,b,c) ++ (a',b',c')) = (a+a':int, merge_runtypes(b,b'), eplus(c,c')) fun plus (a,b,c)(a',b',c') = (a+a':int, merge_runtypes(b,b'), eplus(c,c')) @@ -88,11 +86,9 @@ struct have to be found by analysis of the type declarations. *) - fun layout_arity (a,b,c) = PP.LEAF ("(" ^ Int.toString a ^ "," ^ Int.toString(length(b)) ^ "," ^ Int.toString c ^ ")") - (* All type names in a mutually recursive datbind have the same region and effect arity; these are computed by summing up the arities found for individual type names: *) @@ -109,45 +105,47 @@ struct | mk_abstract (a,b,1) = (a,b,one) | mk_abstract _ = Crash.impossible "SpreadDataType.mk_abstract" - fun mk_concrete(a,b,c) = (a,b,eff_arity_int c) + fun mk_concrete (a,b,c) = (a,b,eff_arity_int c) fun infer_arity_ty rse (current_tynames: tyname list) (tau: E.Type): arity = - (case tau of - E.TYVARtype _ => arity0 + case tau of + E.TYVARtype _ => arity0 (* this does not give a contribution to the arity: all occurrences of the same type variable in the source expression are translated into the same pair of a type variable and a region variable in the target. All the other forms of types contribute at least with one region to the arity. *) - | E.ARROWtype(taus1,taus2) => - foldl (uncurry plus) - (foldl (uncurry plus) (0,[Effect.TOP_RT],one) (* closures have runtype TOP_RT *) - (map (infer_arity_ty rse current_tynames) taus1) - ) - (map (infer_arity_ty rse current_tynames) taus2) - - | E.CONStype(types,tyname) => - foldr (uncurry plus) arity0 (map (infer_arity_ty rse current_tynames) types) - ++ (if List.exists (fn tn => TyName.eq(tn,tyname)) current_tynames - then arity0 - else (0,[R.runtype(R.mkCONSTYPE(tyname,[],[],[]))],zero) ++ + | E.ARROWtype(taus1,taus2) => + foldl (uncurry plus) + (foldl (uncurry plus) (0,[Effect.TOP_RT],one) (* closures have runtype TOP_RT *) + (map (infer_arity_ty rse current_tynames) taus1) + ) + (map (infer_arity_ty rse current_tynames) taus2) + + | E.CONStype(types,tyname) => + foldr (uncurry plus) arity0 (map (infer_arity_ty rse current_tynames) types) + ++ (if List.exists (fn tn => TyName.eq(tn,tyname)) current_tynames + then arity0 + else + (case R.runtype(R.mkCONSTYPE(tyname,[],[],[])) of + SOME rt => (0,[rt],zero) + | NONE => arity0) ++ let val (global, local_rse) = rse - in - (case RSE.lookupTyName local_rse tyname of - SOME arity => mk_abstract(zap_ty_arity(RSE.un_arity arity)) - | NONE => (case RSE.lookupTyName global tyname of - SOME arity => mk_abstract(zap_ty_arity(RSE.un_arity arity)) - | NONE => die ("infer_arity_ty. Type name: " - ^ TyName.pr_TyName tyname))) + in case RSE.lookupTyName local_rse tyname of + SOME arity => mk_abstract(zap_ty_arity(RSE.un_arity arity)) + | NONE => + case RSE.lookupTyName global tyname of + SOME arity => mk_abstract(zap_ty_arity(RSE.un_arity arity)) + | NONE => die ("infer_arity_ty. Type name: " + ^ TyName.pr_TyName tyname) end) - | E.RECORDtype(types) => - foldr (uncurry plus) (0,[case types of [] => Effect.WORD_RT - | [_,_] => Effect.PAIR_RT - | [_,_,_] => Effect.TRIPLE_RT - | _ => Effect.TOP_RT],zero) - (map (infer_arity_ty rse current_tynames) types) - ) + | E.RECORDtype nil => arity0 + | E.RECORDtype types => + foldr (uncurry plus) (0,[case types of [_,_] => Effect.PAIR_RT + | [_,_,_] => Effect.TRIPLE_RT + | _ => Effect.TOP_RT],zero) + (map (infer_arity_ty rse current_tynames) types) fun infer_arity_conbind_list rse current_tynames conbind_list = foldr @@ -187,75 +185,73 @@ struct | arreff::rest => ((*arreff_resource:= rest; always choose the same "fresh" variable! *) arreff) - fun spread_ty_to_mu (tyvar_to_place: tyvar -> place option, - get_with_rt: Effect.runType -> place, + fun spread_ty_to_mu (get_with_rt: Effect.runType -> place, get_eps: unit -> effect, being_defined: tyname -> bool, fresh_rhos: place list, fresh_epss: effect list, - common_place: place, + common_place: place option, rse, global_rse, - ty: E.Type): R.Type * R.effect = + ty: E.Type): R.mu = let - fun extend (tau': R.Type): R.Type*R.effect = - (tau', get_with_rt(R.runtype tau')) + fun extend (tau: R.Type): R.mu = + case R.runtype tau of + SOME rt => R.mkBOX(tau, get_with_rt rt) + | NONE => tau fun get_list_with_runtypes (runtypes: R.runType list): R.effect list = map get_with_rt runtypes - fun ty_to_mu (tau: E.Type): R.Type*R.effect= - case tau of - E.TYVARtype alpha => - let val place = noSome (tyvar_to_place alpha) - "ty_to_mu: tyvar not in domain" - in (R.mkTYVAR alpha, place) - end - | E.ARROWtype(taus1,taus2) => - extend(R.mkFUN(map ty_to_mu taus1, get_eps(), map ty_to_mu taus2)) - | E.CONStype(taus, tyname) => - if being_defined tyname - then (R.mkCONSTYPE(tyname, map ty_to_mu taus, fresh_rhos,fresh_epss), - common_place) - else (* tyname not in the current datbind. - Look for it amongst previously declared datbinds: *) - (case spread_constructed_type(rse, tyname, taus) of - SOME mu => mu - | NONE => (* look for it in the global rse *) - (case spread_constructed_type(global_rse, tyname, taus) of - SOME mu => mu - | NONE => die ("ty_to_mu: \ - \ undeclared type name: " ^ TyName.pr_TyName tyname) - ) - ) - | E.RECORDtype(taus) => - extend(R.mkRECORD(map ty_to_mu taus)) - - and spread_constructed_type (rse, tyname, taus) : (R.Type*R.effect) option = - case RSE.lookupTyName rse tyname of - SOME arity => - let val (number_of_alphas, rho_runtypes, number_of_epsilons) = - RSE.un_arity arity - in - SOME(extend(R.mkCONSTYPE(tyname, map ty_to_mu taus, - get_list_with_runtypes rho_runtypes, - apply_n get_eps number_of_epsilons))) - end - | NONE => NONE - + fun ty_to_mu (tau: E.Type) : R.mu = + case tau of + E.TYVARtype alpha => R.mkTYVAR alpha + | E.ARROWtype(taus1,taus2) => + extend(R.mkFUN(map ty_to_mu taus1, get_eps(), map ty_to_mu taus2)) + | E.CONStype(taus, tyname) => + if being_defined tyname + then let val tau = R.mkCONSTYPE(tyname, map ty_to_mu taus, fresh_rhos,fresh_epss) + in case common_place of + SOME p => R.mkBOX(tau,p) + | NONE => tau + end + else (* tyname not in the current datbind. + Look for it amongst previously declared datbinds: *) + (case spread_constructed_type(rse, tyname, taus) of + SOME mu => mu + | NONE => (* look for it in the global rse *) + (case spread_constructed_type(global_rse, tyname, taus) of + SOME mu => mu + | NONE => die ("ty_to_mu: \ + \ undeclared type name: " ^ TyName.pr_TyName tyname) + ) + ) + | E.RECORDtype taus => + extend(R.mkRECORD(map ty_to_mu taus)) + + and spread_constructed_type (rse, tyname, taus) : R.mu option = + case RSE.lookupTyName rse tyname of + SOME arity => + let val (number_of_alphas, rho_runtypes, number_of_epsilons) = + RSE.un_arity arity + in SOME(extend(R.mkCONSTYPE(tyname, map ty_to_mu taus, + get_list_with_runtypes rho_runtypes, + apply_n get_eps number_of_epsilons))) + end + | NONE => NONE in - ty_to_mu ty + ty_to_mu ty end fun mk_rse_constructors (target_db: target_db) con_rse: rse= - foldl (fn ((con,_,sigma), con_rse) => - RSE.declareCon(con, sigma, con_rse)) - con_rse - (#2 target_db) (* the list of constructors for one type name *) + foldl (fn ((con,_,sigma), con_rse) => + RSE.declareCon(con, sigma, con_rse)) + con_rse + (#2 target_db) (* the list of constructors for one type name *) fun mk_rse_one_mutual_recursion (target_dbs: target_datbind) con_rse = - foldl (uncurry mk_rse_constructors) con_rse target_dbs + foldl (uncurry mk_rse_constructors) con_rse target_dbs (************************************************************************) @@ -275,8 +271,8 @@ struct fun spreadDatbind (level_of_TE:int)(global_rse: rse)(datbind: datbind) - (rse, datbind'_acc: target_datbind list,cone) : - (rse * target_datbind list * cone) = + (rse, datbind'_acc: target_datbind list,cone) + : (rse * target_datbind list * cone) = let val current_tynames: tyname list = map (#2) datbind; @@ -295,20 +291,25 @@ struct use the same region for their values: *) val (common_place,cone) = - let (* see CompileDec.sml for information about the unboxing scheme *) - val rt = case current_tynames - of tn::_ => if TyName.unboxed tn then Effect.WORD_RT - else Effect.TOP_RT - | _ => Effect.TOP_RT - in Effect.freshRhoWithTy(rt, cone) - end + let (* see CompileDec.sml for information about the unboxing scheme *) + val rt = case current_tynames of + tn::_ => if TyName.unboxed tn then NONE + else SOME Effect.TOP_RT + | _ => SOME Effect.TOP_RT + in case rt of + SOME rt => + let val (rho,cone) = Effect.freshRhoWithTy(rt, cone) + in (SOME rho,cone) + end + | NONE => (NONE, cone) + end (*mads val _ = TextIO.output(TextIO.stdOut,PP.flatten(PP.format(80,layout_arity(mk_concrete( common_arity)))))*) val (l,cone) = foldr (fn (rt,(l,cone)) => - let val (rho,cone) = Effect.freshRhoWithTy(rt,cone) - in ((rt,rho)::l, cone) - end) (nil, cone) (#2 common_arity) + let val (rho,cone) = Effect.freshRhoWithTy(rt,cone) + in ((rt,rho)::l, cone) + end) (nil, cone) (#2 common_arity) val fresh_aux_rhos = map #2 l (* val (fresh_aux_rhos,cone) = fresh_list(Effect.freshRho,length(#2 common_arity),cone) @@ -330,34 +331,23 @@ struct target_db list * cone = let val (tyvar_list, tyname, conbind_list) = db - val (tyvar_conversion0,cone) = - foldr - (fn (alpha,(rho_list, cone)) => - let val (rho, cone') = - Effect.freshRhoWithTy (Effect.BOT_RT, cone) - in - ((alpha, rho):: rho_list, cone') - end) ([], cone) tyvar_list - val new_mus0 = map (fn (alpha,rho) => (R.mkTYVAR alpha, rho)) - tyvar_conversion0 - val tyvarPairMap0 = - foldr - (fn ((alpha,rho), m) => E.TyvarMap.add (alpha, rho, m)) - E.TyvarMap.empty tyvar_conversion0 - + val new_mus0 = map R.mkTYVAR tyvar_list val result_type = - R.mkCONSTYPE(tyname,new_mus0, fresh_aux_rhos, fresh_aux_arreffs) + R.mkCONSTYPE(tyname, new_mus0, fresh_aux_rhos, fresh_aux_arreffs) + + val result_mu = case common_place of + SOME rho => R.mkBOX(result_type,rho) + | NONE => result_type fun spreadCon (con, tau_opt) (acc as (list,cone) : ((Con.con * E'.constructorKind * R.sigma)list * cone)) = (case tau_opt of SOME tau => let val mu1 = spread_ty_to_mu( - E.TyvarMap.lookup tyvarPairMap0, (get_place rho_resource), (get_eps arreff_resource), (fn tyname => List.exists (fn tn => TyName.eq(tn, tyname)) - current_tynames), + current_tynames), fresh_aux_rhos, fresh_aux_arreffs, common_place, @@ -365,12 +355,12 @@ struct global_rse, tau) val (eps, cone) = Effect.freshEps cone - val _ = Effect.edge(eps, Effect.mkPut common_place) (* inserted 21/5/96 mads*) + val () = case common_place of SOME p => Effect.edge(eps, Effect.mkPut p) + | NONE => () (* inserted 21/5/96 mads*) val tvs = map (fn tv => (tv,NONE)) tyvar_list val (cone,sigma) = R.generalize_all(cone,level_of_TE,tvs, - R.mkFUN([mu1],eps,[(result_type, - common_place)])) + R.mkFUN([mu1],eps,[result_mu])) in ((con, E'.VALUE_CARRYING, sigma)::list,cone) end @@ -430,4 +420,4 @@ struct (rse1, E'.DATBINDS(rev reversed_target_datbind)) end; -end; (* SpreadDatatype *) +end diff --git a/src/Compiler/Regions/SpreadExpression.sml b/src/Compiler/Regions/SpreadExpression.sml index 5bd3e77df..f4f61bbf2 100644 --- a/src/Compiler/Regions/SpreadExpression.sml +++ b/src/Compiler/Regions/SpreadExpression.sml @@ -1,14 +1,10 @@ - (* -* -* The module introduces region and effect variables into the -* input lambda expression. This is done in such a way that the subsequent -* phases of translation will not have to generate fresh region or effect -* variables. In other words, all generation of fresh region and effect -* variables takes place in SpreadExpression. - -*) - + * The module introduces region and effect variables into the + * input lambda expression. This is done in such a way that the subsequent + * phases of translation will not have to generate fresh region or effect + * variables. In other words, all generation of fresh region and effect + * variables takes place in SpreadExpression. + *) structure SpreadExpression: SPREAD_EXPRESSION = struct @@ -71,11 +67,11 @@ struct fun print_tree t = PP.outputTree(print, t, !Flags.colwidth) fun print_mu (tau,rho) = print_tree (PP.NODE{start="(",finish=")",childsep=PP.RIGHT",",indent=1, - children=[R.mk_lay_sigma' false ([],[],[],tau), Eff.layout_effect rho]}) + children=[R.mk_lay_sigma' false ([],[],[],tau), Eff.layout_effect rho]}) fun print_effects effects = print_tree (PP.NODE{start="{",finish="}",childsep=PP.RIGHT",",indent=1, - children=map Eff.layout_effect effects}) + children=map Eff.layout_effect effects}) fun print_tau tau = print_tree (R.mk_lay_sigma' false ([],[],[],tau)) fun print_sigma sigma = print_tree (R.mk_lay_sigma false sigma) @@ -99,34 +95,34 @@ struct if not(tag_values()) then B else let - fun rhos_sigma lv : place list = - case lookupLvar rse lv - of SOME(_,_,sigma,p,_,_) => [p] @ R.frv_sigma sigma - | NONE => die "gc_no_dangling_pointers.rhos_sigma" - fun rhos_sigma' ex : place list = - case lookupExcon rse ex - of SOME mu => R.frv_mu mu - | NONE => die "gc_no_dangling_pointers.rhos_sigma" - val (lvs,exs) = LB.freevars (blvs,e) - val rhos = List.foldl (fn (lv, acc) => rhos_sigma lv @ acc) nil lvs - val rhos = List.foldl (fn (ex, acc) => rhos_sigma' ex @ acc) rhos exs - val rhos_not = R.frv_mu (R.mkFUN(mus1,eps,mus2),rho) - val rhos = Eff.setminus(Eff.remove_duplicates rhos, rhos_not) - fun drop_rho_p (r:place) = - Eff.eq_effect(r, Eff.toplevel_region_withtype_top) - orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_bot) - orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_string) - orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_real) - - val rhos = (List.filter (not o Eff.is_wordsize o valOf o Eff.get_place_ty) rhos) - handle _ => die "gc_no_dangling_pointers.rhos" - val rhos = List.filter (not o drop_rho_p) rhos + fun rhos_sigma lv : place list = + case lookupLvar rse lv + of SOME(_,_,sigma,p,_,_) => [p] @ R.frv_sigma sigma + | NONE => die "gc_no_dangling_pointers.rhos_sigma" + fun rhos_sigma' ex : place list = + case lookupExcon rse ex + of SOME mu => R.frv_mu mu + | NONE => die "gc_no_dangling_pointers.rhos_sigma" + val (lvs,exs) = LB.freevars (blvs,e) + val rhos = List.foldl (fn (lv, acc) => rhos_sigma lv @ acc) nil lvs + val rhos = List.foldl (fn (ex, acc) => rhos_sigma' ex @ acc) rhos exs + val rhos_not = R.frv_mu (R.mkFUN(mus1,eps,mus2),rho) + val rhos = Eff.setminus(Eff.remove_duplicates rhos, rhos_not) + fun drop_rho_p (r:place) = + Eff.eq_effect(r, Eff.toplevel_region_withtype_top) + orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_bot) + orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_string) + orelse Eff.eq_effect(r, Eff.toplevel_region_withtype_real) + + val rhos = (List.filter (not o Eff.is_wordsize o valOf o Eff.get_place_ty) rhos) + handle _ => die "gc_no_dangling_pointers.rhos" + val rhos = List.filter (not o drop_rho_p) rhos (* - val B = List.foldl (fn (r,B) => Eff.lower (Eff.level B) r B) B rhos + val B = List.foldl (fn (r,B) => Eff.lower (Eff.level B) r B) B rhos *) - val phi = mkUnion (map Eff.mkGet rhos) - val (eps2,B) = freshEps B - val _ = edge (eps2,phi) + val phi = mkUnion (map Eff.mkGet rhos) + val (eps2,B) = freshEps B + val _ = edge (eps2,phi) in Eff.unifyEps (eps,eps2) B end *) @@ -141,7 +137,7 @@ struct fun declareMany (rho,rse)([],[]) = rse | declareMany (rho,rse)((lvar,regvars,tyvars,sigma_hat,bind):: rest1, occ::occ1) = - declareMany(rho,RSE.declareLvar(lvar,(true,true,regvars,sigma_hat, rho, SOME occ, NONE), rse))(rest1,occ1) + declareMany(rho,RSE.declareLvar(lvar,(true,true,regvars,sigma_hat,SOME rho,SOME occ,NONE), rse))(rest1,occ1) | declareMany _ _ = die ".declareMany" @@ -154,31 +150,30 @@ struct fun adjust_instances (transformer, occ as ref l) = app (fn r as ref(il, f)=> r:= (il, transformer o f)) l - fun mkRhs (rse,rho)([],[],[]) = (rse,[]) - | mkRhs (rse,rho)((lvar,regvars,tyvars,sigma_hat,bind)::rest1, - (t1,tau1,sigma1,tvs1)::rest2, - occ::rest3) = - let - val (brhos, bepss,_) = R.bv sigma1 - val transformer = R.matchSchemes(sigma_hat, sigma1) handle R.FAIL_MATCH msg => - die ("mkRhs: lvar = " ^ Lvars.pr_lvar lvar ^ "\n" ^ msg) - val _ = adjust_instances(transformer, occ) - val function = {lvar = lvar, occ = occ, tyvars = ref tvs1, rhos = ref brhos, epss = ref bepss, - Type = tau1, formal_regions = NONE, bind = t1} - val rse2 = RSE.declareLvar(lvar,(true, true, regvars, R.insert_alphas(tvs1, sigma1), - rho, SOME occ, NONE), rse) - val (rse2', l) = mkRhs(rse2,rho)(rest1,rest2,rest3) - in - (rse2', function::l) - end - | mkRhs _ _ = die ".mkRhs" + fun mkRhs (rse,rho) ([],[],[]) = (rse,[]) + | mkRhs (rse,rho) ((lvar,regvars,tyvars,sigma_hat,bind)::rest1, + (t1,tau1,sigma1,tvs1)::rest2, + occ::rest3) = + let val (brhos, bepss,_) = R.bv sigma1 + val transformer = R.matchSchemes (sigma_hat, sigma1) + handle R.FAIL_MATCH msg => + die ("mkRhs: lvar = " ^ Lvars.pr_lvar lvar ^ "\n" ^ msg) + val _ = adjust_instances (transformer, occ) + val function = {lvar = lvar, occ = occ, tyvars = ref tvs1, rhos = ref brhos, epss = ref bepss, + Type = tau1, formal_regions = NONE, bind = t1} + val rse2 = RSE.declareLvar(lvar,(true, true, regvars, R.insert_alphas(tvs1, sigma1), + SOME rho, SOME occ, NONE), rse) + val (rse2', l) = mkRhs (rse2,rho) (rest1,rest2,rest3) + in (rse2', function::l) + end + | mkRhs _ _ = die ".mkRhs" exception Abort fun die_from_S e = (TextIO.output(TextIO.stdOut, - "Failed to spread expression:" ^ - PP.flatten(PP.format(200, E.layoutLambdaExp e )) ^ "\n"); + "Failed to spread expression:" ^ + PP.flatten(PP.format(200, E.layoutLambdaExp e )) ^ "\n"); raise Abort) fun save_il(instances_opt, il_r) = @@ -202,7 +197,7 @@ struct fun Below(B, mus) = let val free_rhos_and_epss = R.ann_mus mus [] val B' = List.foldl (uncurry (Eff.lower(Eff.level B - 1))) - B free_rhos_and_epss + B free_rhos_and_epss in Eff.popAndClean(B') end @@ -213,26 +208,26 @@ struct if false (*preserve_tail_calls()*) andalso cont = TAIL then (* (Eff.restrain B, t, TAIL) *) let val free_rhos_and_epss = R.ann_mus mus [] val B = List.foldl (uncurry (Eff.lower(Eff.level B - 1))) - B free_rhos_and_epss -(* val _ = app (fn effect => - let val effect = if Eff.is_get effect orelse Eff.is_put effect then Eff.rho_of effect - else effect - in Eff.unify_with_toplevel_effect effect - end) (Eff.topLayer B) *) - val B = List.foldl (fn (eff,B) => Eff.lower 1 eff B) B (Eff.topLayer B) + B free_rhos_and_epss +(* val _ = app (fn effect => + let val effect = if Eff.is_get effect orelse Eff.is_put effect then Eff.rho_of effect + else effect + in Eff.unify_with_toplevel_effect effect + end) (Eff.topLayer B) *) + val B = List.foldl (fn (eff,B) => Eff.lower 1 eff B) B (Eff.topLayer B) (* - val phi' = mkUnion([]) - val (discharged_phi,_) = observeDelta(Eff.level B - 1, Eff.Lf[phi],phi') + val phi' = mkUnion([]) + val (discharged_phi,_) = observeDelta(Eff.level B - 1, Eff.Lf[phi],phi') (* - val _ = app (fn effect => - let val effect = if Eff.is_get effect orelse Eff.is_put effect then Eff.rho_of effect - else effect - in Eff.unify_with_toplevel_effect effect - end) discharged_phi + val _ = app (fn effect => + let val effect = if Eff.is_get effect orelse Eff.is_put effect then Eff.rho_of effect + else effect + in Eff.unify_with_toplevel_effect effect + end) discharged_phi *) val B = List.foldl (fn (eff,B) => lower 1 eff B) B discharged_phi *) -(* val B = Eff.restrain B *) +(* val B = Eff.restrain B *) in (#2 (Eff.pop B), t, TAIL, tvs) end else @@ -244,7 +239,7 @@ struct in (B_keep, E'.TR(E'.LETREGION_B{B= ref B_discharge, discharged_phi = ref discharged_phi, body = t}, E'.Mus mus, phi'), - NOTAIL, tvs) + NOTAIL, tvs) end | retract (B, t, c, tvs) = (B, t, c, tvs) @@ -316,6 +311,7 @@ struct val (freshType, freshMu) = R.freshType lookup +(* fun freshTypes (cone:cone, types: E.Type list) = case types of [] => ([],cone) @@ -323,7 +319,7 @@ struct val (taus, cone) = freshTypes(cone,rest) in (tau::taus, cone) end - +*) fun freshTypesWithPlaces (cone:cone, types: E.Type list) = case types of [] => ([],cone) @@ -337,10 +333,10 @@ struct let (*val _ = TextIO.output(TextIO.stdOut, "mk_sigma_hat_list: " ^ Lvars.pr_lvar lvar ^ "\n")*) val B = Eff.push B (* for generalize_all *) - val (tau_x_ml, tau_1_ml) = - case Type of - E.ARROWtype p => p - | _ => die "mk_sigma_hat_list" + val (tau_x_ml, tau_1_ml) = + case Type of + E.ARROWtype p => p + | _ => die "mk_sigma_hat_list" val (tau_0, B) = freshType(Type,B) val (B,sigma) = R.generalize_all(B,retract_level,map (fn tv => (tv,NONE)) tyvars,tau_0) val sigma_hat = R.drop_alphas sigma @@ -352,7 +348,7 @@ struct fun newInstance (A: cone,sigma:R.sigma, taus: E.Type list): cone*R.Type*R.il = let val (rhos, epss, alphas) = R.bv sigma - val (taus', A) = freshTypes(A,taus) + val (taus', A) = freshTypesWithPlaces(A,taus) val (rhos', A) = Eff.freshRhosPreserveRT(rhos, A) val (epss', A) = Eff.freshEpss(epss, A) val il = R.mk_il(rhos',epss',taus') @@ -364,27 +360,70 @@ struct (* get_exn_mu(mu') if mu' is the type and place of a nullary exception constructor, return mu'; otherwise mu' = (mu_1 -> mu_2, rho): return mu_2 *) - fun get_exn_mu (mu as (ty,_)) = - case R.unFUN ty of - SOME(_,_,[mu2]) => mu2 - | _ => mu - - fun maybe_explicit_rho (rse:rse) (B:cone) (rt:Eff.runType) (rv_opt:RegVar.regvar option) : place * cone = - case rv_opt of - NONE => Eff.freshRhoWithTy(rt, B) - | SOME rv => case RSE.lookupRegVar rse rv of - SOME rho => - (case Eff.get_place_ty rho of - NONE => die "impossible: maybe_explicit_rho" - | SOME Eff.BOT_RT => (rho,B) before Eff.setRunType rho rt - | SOME rt' => if rt = rt' then (rho,B) - else deepError rv ("Mismatching region types " - ^ Eff.show_runType rt ^ " and " - ^ Eff.show_runType rt' ^ " for " - ^ "explicit region variable `" - ^ RegVar.pr rv)) - | NONE => deepError rv ("Explicit region variable `" ^ RegVar.pr rv - ^ " is not in scope.") + fun get_exn_mu mu = + case R.unBOX mu of + SOME (ty,_) => + (case R.unFUN ty of + SOME(_,_,[mu2]) => mu2 + | _ => mu) + | NONE => mu + + fun maybe_explicit_rho (rse:rse) (B:cone) (tau:R.Type) (rv_opt:RegVar.regvar option) : place * R.mu * cone = + let val rt = case R.runtype tau of + SOME rt => rt + | NONE => die "maybe_explicit_rho: expecting boxed type" + val (rho,B) = + case rv_opt of + NONE => Eff.freshRhoWithTy(rt, B) + | SOME rv => + case RSE.lookupRegVar rse rv of + SOME rho => + (case Eff.get_place_ty rho of + NONE => die "impossible: maybe_explicit_rho" + | SOME Eff.BOT_RT => (rho,B) before Eff.setRunType rho rt + | SOME rt' => if rt = rt' then (rho,B) + else deepError rv ("Mismatching region types " + ^ Eff.show_runType rt ^ " and " + ^ Eff.show_runType rt' ^ " for " + ^ "explicit region variable `" + ^ RegVar.pr rv)) + | NONE => deepError rv ("Explicit region variable `" ^ RegVar.pr rv + ^ " is not in scope.") + in (rho, R.mkBOX(tau,rho), B) + end + + fun maybe_explicit_rho_opt (rse:rse) (B:cone) (tau:R.Type) (rv_opt:RegVar.regvar option) : place option * R.mu * cone = + let val (rho:place option,B) = + case rv_opt of + NONE => + (case R.runtype tau of + SOME rt => + let val (rho,B) = Eff.freshRhoWithTy(rt, B) + in (SOME rho,B) + end + | NONE => (NONE,B)) + | SOME rv => + case RSE.lookupRegVar rse rv of + SOME rho => + (case R.runtype tau of + NONE => deepError rv ("Cannot associate explicit region variable `" + ^ RegVar.pr rv ^ " with value of unboxed type") + | SOME rt => + (case Eff.get_place_ty rho of + NONE => die "impossible: maybe_explicit_rho" + | SOME Eff.BOT_RT => (SOME rho,B) before Eff.setRunType rho rt + | SOME rt' => if rt = rt' then (SOME rho,B) + else deepError rv ("Mismatching region types " + ^ Eff.show_runType rt ^ " and " + ^ Eff.show_runType rt' ^ " for " + ^ "explicit region variable `" + ^ RegVar.pr rv))) + | NONE => deepError rv ("Explicit region variable `" ^ RegVar.pr rv + ^ " is not in scope.") + in case rho of + SOME p => (rho, R.mkBOX(tau,p), B) + | NONE => (rho, tau, B) + end fun meetSwitch _ TAIL = TAIL | meetSwitch TAIL _ = TAIL @@ -398,24 +437,24 @@ struct let val B = pushIfNotTopLevel(toplevel,B) (* for retract *) val (B,t0 as E'.TR(e', meta_0, phi_0),_,tvs0) = spread(B,e0,false,NOTAIL) - val mus_0 = unMus "spreadSwitch" meta_0 - val mu_0 as (_,object_rho) = - case mus_0 of [mu_0] => mu_0 | _ => die "S. ill-typed object of switch" + val mu_0 = case unMus "spreadSwitch" meta_0 of + [mu_0] => mu_0 + | _ => die "S. ill-typed object of switch" val B = List.foldl (uncurry (fn mu => R.unify_mu(get_exn_mu mu,mu_0))) - B excon_mus + B excon_mus val (B, new_choices, contAcc, tvsAcc) = - List.foldr (fn ((c, e), (B, ts, contAcc, tvsAcc)) => - let val (B, t, cont, tvs) = spread(B,e,toplevel,cont) - in (B, t:: ts, meetSwitch cont contAcc,spuriousJoin tvs tvsAcc) - end) (B,[],NOTAIL,tvs0) choices + List.foldr (fn ((c, e), (B, ts, contAcc, tvsAcc)) => + let val (B, t, cont, tvs) = spread(B,e,toplevel,cont) + in (B, t:: ts, meetSwitch cont contAcc,spuriousJoin tvs tvsAcc) + end) (B,[],NOTAIL,tvs0) choices val (B, new_last, contAcc, tvsAcc) = - case last of - NONE => (B,NONE,contAcc,tvsAcc) - | SOME e_last => let val (B, t_last, cont, tvs) = spread(B,e_last,toplevel,cont) - in (B, SOME t_last, meetSwitch cont contAcc, spuriousJoin tvs tvsAcc) - end + case last of + NONE => (B,NONE,contAcc,tvsAcc) + | SOME e_last => let val (B, t_last, cont, tvs) = spread(B,e_last,toplevel,cont) + in (B, SOME t_last, meetSwitch cont contAcc, spuriousJoin tvs tvsAcc) + end (* unify types of branches - when they are not frames or raised Bind types *) @@ -424,27 +463,36 @@ struct SOME(E'.TR(_,E'.Mus mus1,_)) => (List.foldl (fn (E'.TR(_,E'.Mus mus,_),B) => R.unify_mus(mus,mus1)B | (E'.TR(_, _, _),B) => B) - B + B (case new_last of NONE => new_choices | SOME t' => t'::new_choices), E'.Mus mus1) - | SOME _ => die "spreadSwitch" + | SOME _ => die "spreadSwitch" | NONE => case List.find (fn E'.TR(_,E'.Frame _, _) => true | _ => false) new_choices of SOME (E'.TR(_,metatype,_)) => (B,metatype) | NONE => (B, E'.RaisedExnBind) (* val accumulate effects*) - val phi = Eff.mkUnion(phi_0:: Eff.mkGet object_rho:: - (fn rest => case new_last of NONE => rest - | SOME (E'.TR(_,_,phi_n)) => phi_n ::rest) - (map (fn E'.TR(_,_,phi_i)=> phi_i) new_choices) - ) + val phis = map (fn E'.TR(_,_,phi_i) => phi_i) new_choices + val phis = case new_last of NONE => phis + | SOME (E'.TR(_,_,phi_n)) => phi_n :: phis + val phis = phi_0 :: phis + val phis = case R.unBOX mu_0 of + SOME(_,object_rho) => Eff.mkGet object_rho :: phis + | NONE => phis val e' = E'.SWITCH(t0,ListPair.zip(map #1 choices, new_choices), new_last) in - retract(B,E'.TR(con(e'), metatype,phi), contAcc, tvsAcc) + retract(B,E'.TR(con(e'), metatype, Eff.mkUnion phis), contAcc, tvsAcc) end handle X as Report.DeepError _ => raise X | X => die ("spreadSwitch: cannot spread; exception " ^ exnName X ^ " raised") + fun freshBoxMu s B tau = + case R.runtype tau of + NONE => die ("freshBoxMu: " ^ s) + | SOME rt => let val (rho,B) = Eff.freshRhoWithTy(rt, B) + in (B, rho, R.mkBOX(tau,rho)) + end + fun spreadSwitch' (B:cone) spread con excon_mus (E.SWITCH(e0: E.LambdaExp, choices: (('c * 'ignore) * E.LambdaExp) list, @@ -455,14 +503,18 @@ struct (case e of E.VAR{lvar, instances : E.Type list, regvars} => (case RSE.lookupLvar rse lvar of - SOME(compound,create_region_record,formal_regvars, - sigma,place0,instances_opt, transformer) => + SOME(compound,create_region_record,formal_regvars, + sigma,place0opt,instances_opt, transformer) => let val (B, tau, il_1) = newInstance(B,sigma,instances) val il_r = ref (il_1, fn p => p) val _ = save_il(instances_opt, il_r) - val fix_bound = compound andalso create_region_record - val phi = if fix_bound then Eff.mkGet place0 else Eff.empty + val fix_bound = compound andalso create_region_record + val phi = if fix_bound then + case place0opt of + SOME place0 => Eff.mkGet place0 + | NONE => die "S.VAR:expecting boxed fix-bound function" + else Eff.empty val () = case regvars of [] => () @@ -499,46 +551,51 @@ struct nil (#3(R.bv sigma), #3(R.un_il il_1)) handle ListPair.UnequalLengths => die "VAR:instantiation list error" + val mu = case place0opt of + SOME p => R.mkBOX(tau,p) + | NONE => tau in - (B,E'.TR(E'.VAR{lvar = lvar, fix_bound=fix_bound, il_r = il_r}, - E'.Mus [(tau,place0)], phi), - NOTAIL, + (B,E'.TR(E'.VAR{lvar = lvar, fix_bound=fix_bound, il_r = il_r}, + E'.Mus [mu], phi), + NOTAIL, tvs_spurious) end | NONE => die "spreadExp: free lvar" ) | E.INTEGER (i,tau_ml) => - let val (mu as (tau,rho), B) = freshMu(tau_ml,B) - in (B,E'.TR(E'.INTEGER(i, tau, rho),E'.Mus[mu], Eff.mkPut rho), - NOTAIL, - []) - end + let val (mu, B) = freshMu(tau_ml,B) + val (tau,rho_opt) = R.unbox mu + val phi = case rho_opt of SOME rho => Eff.mkPut rho | NONE => Eff.empty + in (B,E'.TR(E'.INTEGER(i, tau, rho_opt),E'.Mus[mu], phi), + NOTAIL, + []) + end | E.WORD (i, tau_ml) => - let val (mu as (tau,rho), B) = freshMu(tau_ml,B) - in (B,E'.TR(E'.WORD(i, tau, rho),E'.Mus[mu], Eff.mkPut rho), - NOTAIL, - []) - end + let val (mu, B) = freshMu(tau_ml,B) + val (tau,rho_opt) = R.unbox mu + val phi = case rho_opt of SOME rho => Eff.mkPut rho | NONE => Eff.empty + in (B,E'.TR(E'.WORD(i, tau, rho_opt),E'.Mus[mu], phi), + NOTAIL, + []) + end | E.STRING(s: string,rv_opt)=> - let val (rho, B) = maybe_explicit_rho rse B Eff.STRING_RT rv_opt - val tau = R.stringType - in (B,E'.TR(E'.STRING(s, rho),E'.Mus [(tau,rho)], Eff.mkPut rho), - NOTAIL, - []) - end + let val (rho, mu, B) = maybe_explicit_rho rse B R.stringType rv_opt + in (B, E'.TR(E'.STRING(s, rho),E'.Mus [mu], Eff.mkPut rho), + NOTAIL, + []) + end | E.REAL(r: string,rv_opt)=> - let val (rho, B) = maybe_explicit_rho rse B Eff.TOP_RT rv_opt - val tau = R.realType - in (B,E'.TR(E'.REAL(r, rho),E'.Mus [(tau,rho)], Eff.mkPut rho), - NOTAIL, - []) - end + let val (rho, mu, B) = maybe_explicit_rho rse B R.realType rv_opt + in (B, E'.TR(E'.REAL(r, rho),E'.Mus [mu], Eff.mkPut rho), + NOTAIL, + []) + end | E.F64 r => - let val (mu as (_,rho), B) = freshMu(E.f64Type,B) - in (B,E'.TR(E'.F64(r, rho),E'.Mus[mu], Eff.mkPut rho), - NOTAIL, - []) - end + let val (mu, B) = freshMu(E.f64Type,B) + in (B, E'.TR(E'.F64 r,E'.Mus[mu], Eff.empty), + NOTAIL, + []) + end | E.PRIM(E.UB_RECORDprim, args) => (* For simplicity, we demand that the arguments of UB_RECORDprim must themselves have a singleton list of type and places. Thus we do not allow, for example @@ -556,38 +613,41 @@ struct end) (B,[],[],[],[]) args val phi = Eff.mkUnion(rev phis) val mus = rev mus - val triples = rev triples + val triples = rev triples in (B, E'.TR(E'.UB_RECORD triples, E'.Mus mus, phi), - NOTAIL, + NOTAIL, tvs) end | E.FN{pat: (E.lvar * E.Type) list, body: E.LambdaExp} => let val (mus, B) = freshTypesWithPlaces (B, map #2 pat) - val rse' = List.foldl (fn ((lvar, mu as (tau,rho)), rse) => - RSE.declareLvar(lvar, (false,false,[],R.type_to_scheme tau, rho,NONE,NONE), rse)) rse - (ListPair.zip(map #1 pat, mus)) + val rse' = List.foldl (fn ((lvar, mu), rse) => + let val (tau,rho_opt) = R.unbox mu + in RSE.declareLvar(lvar, (false,false,[], + R.type_to_scheme tau, + rho_opt,NONE,NONE), rse) + end) rse + (ListPair.zip(map #1 pat, mus)) val (B,t1 as E'.TR(e1',meta1, phi1), _, tvs) = spreadExp(B,rse',body,false,TAIL) val mu_list1 = unMus "S.FN" meta1 val (eps, B) = Eff.freshEps B val _ = Eff.edge(eps, phi1) val (rho, B) = Eff.freshRhoWithTy(Eff.TOP_RT, B) - val ty0 = R.mkFUN(mus,eps,mu_list1) - val (free, tvs') = + val (free, tvs') = if dangling_pointers() then (NONE, nil) - else + else (*region inference without dangling pointers*) let val free = LB.freevars e in (SOME free, RSE.spuriousTyvars rse ty0 free) end in (B, E'.TR(E'.FN{pat = ListPair.zip(map #1 pat, mus), body = t1, alloc = rho, free=free}, - E'.Mus [(ty0, rho)], Eff.mkPut(rho)), - NOTAIL, + E'.Mus [R.mkBOX(ty0,rho)], Eff.mkPut(rho)), + NOTAIL, spuriousJoin tvs' tvs) end | E.APP(e1_ML: E.LambdaExp, e2_ML: E.LambdaExp,_) => @@ -600,10 +660,10 @@ struct | _ => false val B = if simple_application then B else pushIfNotTopLevel(toplevel,B) - val (B,t1 as E'.TR(e1, meta1, phi1), _, tvs1) = S(B,e1_ML, false, NOTAIL) + val (B,t1 as E'.TR(e1, meta1, phi1), _, tvs1) = S(B,e1_ML, false, NOTAIL) val (ty,rho_0) = case unMus "S.APP" meta1 of - [p] => p + [mu] => noSome (R.unBOX mu) "S.APP: expecting boxed function" | _ => die "E.APP.singleton mus expected" val (mus2,eps_phi0,mus1) = case R.unFUN ty of @@ -632,8 +692,8 @@ struct val (B, t2 as E'.TR(e2, meta2, phi2), cont, tvs2) = S(B, e2_ML, toplevel, cont) in (B, E'.TR(E'.LET{pat = nil, - bind = t1, scope = t2}, meta2, Eff.mkUnion([phi1,phi2])), - cont, + bind = t1, scope = t2}, meta2, Eff.mkUnion([phi1,phi2])), + cont, spuriousJoin tvs1 tvs2) end @@ -642,28 +702,28 @@ struct val B = pushIfNotTopLevel(toplevel,B) (* for retract *) val (B, t1 as E'.TR(e1, meta, phi1), _, tvs1) = S(B, e1_ML, false, NOTAIL) val mus = unMus "S.LET" meta - fun loop_pat([], [], B, rse, pat'_list) = (B,rse, rev pat'_list) - | loop_pat((lvar,alphas,tau_ML):: rest_bind, (tau_1, rho_1):: mu_rest, - B, rse, pat'_list) = - let - val sigma = R.type_to_scheme tau_1 -(* val _ = log_sigma(R.insert_alphas(alphas, sigma),lvar)*) - val alphas = map (fn tv => (tv,NONE)) alphas (* TODO MAEL: for those in tvs1, SOME eps, where eps is fresh... *) - val rse = RSE.declareLvar(lvar, - (false,false,[],R.insert_alphas(alphas, sigma), - rho_1, NONE, NONE),rse) - in - loop_pat(rest_bind, mu_rest, B, rse, - (lvar,alphas, tau_1, rho_1) :: pat'_list) - end - | loop_pat _ = die ".loop_pat: length of pattern and list of types and places differ" + fun loop_pat ([], [], B, rse, pat'_list) = (B,rse, rev pat'_list) + | loop_pat ((lvar,alphas,tau_ML):: rest_bind, mu1 :: mu_rest, + B, rse, pat'_list) = + let val (tau1,rho_opt) = R.unbox mu1 + val sigma = R.type_to_scheme tau1 +(* val _ = log_sigma(R.insert_alphas(alphas, sigma),lvar)*) + val alphas = map (fn tv => (tv,NONE)) alphas (* TODO MAEL: for those in tvs1, SOME eps, where eps is fresh... *) + val rse = RSE.declareLvar(lvar, + (false,false,[],R.insert_alphas(alphas, sigma), + rho_opt, NONE, NONE),rse) + in + loop_pat(rest_bind, mu_rest, B, rse, + (lvar,alphas,tau1,rho_opt) :: pat'_list) + end + | loop_pat _ = die ".loop_pat: length of pattern and list of types and places differ" val (B,rse, pat'_list) = loop_pat(pat, mus, B, rse, []) val (B, t2 as E'.TR(e2, meta2, phi2),cont,tvs2) = spreadExp(B,rse,e2_ML,toplevel,cont) in retract(B, E'.TR(E'.LET{pat = pat'_list, bind = t1, scope = t2}, meta2, Eff.mkUnion([phi1,phi2])), - cont, + cont, spuriousJoin tvs1 tvs2) end @@ -711,10 +771,10 @@ good *) val (B,sigma_hat_list) = mk_sigma_hat_list(B,retract_level) functions val (B,rse2,functions',tvs) = spreadFcns(B,rho,retract_level,rse)(repl(functions,sigma_hat_list)) val (B, t2 as E'.TR(_, meta2, phi2), cont, tvs2) = spreadExp(B, rse2, scope,toplevel,cont) - val e' = E'.FIX{shared_clos = rho,functions = functions',scope = t2} + val e' = E'.FIX{shared_clos=rho,functions = functions',scope = t2} in retract(B, E'.TR(e', meta2, Eff.mkUnion([phi1,phi2])), - cont, + cont, spuriousJoin tvs tvs2) end (* FIX *) @@ -722,13 +782,14 @@ good *) let val B = pushIfNotTopLevel(toplevel,B); (* for pop in retract *) val (ty,nullary) = - case ty_opt of - SOME ty1 => (E.ARROWtype([ty1], [exn_ty]),false) - | NONE => (exn_ty, true) - val (mu as (tau, rho), B) = freshMu(ty, B) + case ty_opt of + SOME ty1 => (E.ARROWtype([ty1], [exn_ty]),false) + | NONE => (exn_ty, true) + val (mu, B) = freshMu(ty, B) + val (tau,rho) = noSome (R.unBOX mu) "S.EXCEPTION: expecting boxed type" (* lower all the region and effect variables of mu to have level 2 (not 0), - so that they cannot be generalised ever. Level 2, because it is generated - in this program unit, unless unified with another lower-level rho. *) + so that they cannot be generalised over. Level 2, because it is generated + in this program unit, unless unified with another lower-level rho. *) (* val B = EdList.foldL (Eff.lower 2) B (R.ann_mus [mu] []) *) @@ -739,17 +800,20 @@ good *) (* if exception constructor is unary: unify place of exception constructor and place of its result type. Note: I think - we could have chosen not to identify these two regions *) + we could have chosen not to identify these two regions, but + both have runtype RT_TOP... *) val B = case R.unFUN tau of - SOME(_,_,mus as [(tau_res, rho_res)]) => - Eff.unifyRho(rho_res, rho) B - | _ => B + SOME(_,_,mus as [mu_res]) => + let val (_,rho_res) = noSome (R.unBOX mu_res) "S.EXCEPTION: expecting boxed result" + in Eff.unifyRho (rho_res, rho) B + end + | _ => B val rse' = RSE.declareExcon(excon, mu, rse) val (B, t2 as E'.TR(e2', meta2, phi2), cont, tvs) = spreadExp(B,rse',e2, toplevel, cont) in retract(B, E'.TR(E'.EXCEPTION(excon, nullary, mu, rho, t2), meta2, Eff.mkUnion([Eff.mkPut rho,phi2])), - cont, + cont, tvs) end @@ -783,23 +847,26 @@ good *) val mus2 = unMus "S.HANDLE2" meta2 in case mus2 of - [(ty,rho2)] => - (case R.unFUN ty of - SOME(mus21,arreff,mus22) => - let val B = R.unify_mus(mus22,mus1) B - val phi = Eff.mkUnion([phi1,phi2,arreff,Eff.mkGet rho2]) - (* lower all the region and effect variables of mus21 to have level 2 (not 0), - so that they cannot be generalised ever. Level 2, because it is generated - in this program unit, unless unified with another lower-level rho. *) - val B = List.foldl (uncurry (Eff.lower 2)) - B (R.ann_mus mus21 []) - in - retract(B, E'.TR( E'.HANDLE(t1,t2), E'.Mus mus22, phi), - NOTAIL, - spuriousJoin tvs1 tvs2) - end - | NONE => die "S: ill-typed handle expression") - | _ => die "S: ill-typed handle expression" + [mu2] => + (case R.unBOX mu2 of + NONE => die "S.HANDLE: expecting boxed handler" + | SOME(ty,rho2) => + (case R.unFUN ty of + SOME(mus21,arreff,mus22) => + let val B = R.unify_mus(mus22,mus1) B + val phi = Eff.mkUnion([phi1,phi2,arreff,Eff.mkGet rho2]) + (* lower all the region and effect variables of mus21 to have level 2 (not 0), + so that they cannot be generalised ever. Level 2, because it is generated + in this program unit, unless unified with another lower-level rho. *) + val B = List.foldl (uncurry (Eff.lower 2)) + B (R.ann_mus mus21 []) + in + retract(B, E'.TR( E'.HANDLE(t1,t2), E'.Mus mus22, phi), + NOTAIL, + spuriousJoin tvs1 tvs2) + end + | NONE => die "S: ill-typed handle expression")) + | _ => die "S: ill-typed handle expression" end | E.PRIM(E.REFprim{instance,regvar}, [e1]) => (* @@ -811,13 +878,12 @@ good *) let val (B, t1 as E'.TR(e1', meta1, phi1), _,tvs) = S(B,e1, false, NOTAIL) val mus1 = unMus "S.REFprim" meta1 - val (rho_new, B) = maybe_explicit_rho rse B Eff.REF_RT regvar + val tau = R.mkCONSTYPE(TyName.tyName_REF, mus1,[],[]) + val (rho_new, mu, B) = maybe_explicit_rho rse B tau regvar val phi = Eff.mkUnion([Eff.mkPut rho_new, phi1]) - val mus = [(R.mkCONSTYPE(TyName.tyName_REF, mus1,[],[]),rho_new)] - in - (B, E'.TR(E'.REF (rho_new, t1), E'.Mus mus,phi), - NOTAIL, - tvs) + in (B, E'.TR(E'.REF (rho_new, t1), E'.Mus [mu],phi), + NOTAIL, + tvs) end | E.PRIM(E.DEREFprim{instance}, [e1])=> @@ -829,18 +895,20 @@ good *) let val B = pushIfNotTopLevel(toplevel,B) val (B, t1 as E'.TR(e1', meta1, phi1), _, tvs) = S(B,e1, false, NOTAIL) - val mus1 = unMus "S.DEREFprim" meta1 in - case mus1 of - [(ty, rho)] => - (case R.unCONSTYPE ty of - SOME(tyname_ref, mus, [], []) => - retract(B, E'.TR(E'.DEREF t1, E'.Mus mus, - Eff.mkUnion([Eff.mkGet rho, phi1])), - NOTAIL, - tvs) - | _ => die "S: ill-typed rereferencing") - | _ => die "S: ill-typed rereferencing" + case unMus "S.DEREFprim" meta1 of + [mu] => + (case R.unBOX mu of + SOME(ty,rho) => + (case R.unCONSTYPE ty of + SOME(tyname_ref, mus, [], []) => + retract(B, E'.TR(E'.DEREF t1, E'.Mus mus, + Eff.mkUnion([Eff.mkGet rho, phi1])), + NOTAIL, + tvs) + | _ => die "S: ill-typed dereferencing") + | NONE => die "S: DEREF") + | _ => die "S: ill-typed dereferencing" end | E.PRIM(E.ASSIGNprim{instance}, [e1, e2]) => @@ -855,8 +923,8 @@ good *) (Note: in multiplicity inference, the put effect should not be counted: it does not generate a new ref object and hence does not require allocation of more space. - Moreover, the put effect causes the region to be passed to := at runtime; it seems more - natural to leave out the put effect. + Moreover, the put effect causes the region to be passed to := at runtime; it seems more + natural to leave out the put effect. *) let @@ -866,19 +934,20 @@ good *) val mus1 = unMus "S.ASSIGNprim1" meta1 val mus2 = unMus "S.ASSIGNprim2" meta2 in case (mus1,mus2) of - ([(ty1,rho1)], [mu2]) => - (case R.unCONSTYPE ty1 of - SOME(ref_tyname, [mu1],[],[]) => - let val B = R.unify_mu(mu1,mu2)B - val (rho3, B) = Eff.freshRhoWithTy(Eff.WORD_RT, B) - val phi = Eff.mkUnion([(*Eff.mkPut rho1,mael*) Eff.mkGet rho1, Eff.mkPut rho3,phi1, phi2]) - in - retract(B, E'.TR(E'.ASSIGN(rho3,t1,t2), E'.Mus [(R.unitType, rho3)], phi), - NOTAIL, - spuriousJoin tvs1 tvs2) - end - | _ => die "S: ill-typed assignment") - | _ => die "S: ill-typed assignment" + ([mu1], [mu2]) => + (case R.unBOX mu1 of + SOME(ty1,rho1) => + (case R.unCONSTYPE ty1 of + SOME(ref_tyname, [mu1],[],[]) => + let val B = R.unify_mu (mu1,mu2) B + val phi = Eff.mkUnion([(*Eff.mkPut rho1,mael*) Eff.mkGet rho1,phi1, phi2]) + in retract(B, E'.TR(E'.ASSIGN(t1,t2), E'.Mus [R.unitType], phi), + NOTAIL, + spuriousJoin tvs1 tvs2) + end + | _ => die "S: ill-typed assignment") + | NONE => die "S: ASSIGN: expecting boxed mu") + | _ => die "S: ill-typed assignment" end @@ -892,14 +961,14 @@ good *) val B = pushIfNotTopLevel(toplevel,B); (* for retract *) val (B, t1 as E'.TR(e1', meta1, phi1), _, tvs) = S(B,e1, false, NOTAIL) (* val mus1 = unMus "S.DROPprim" meta1 *) - in - retract(B, E'.TR(E'.DROP t1, E'.Mus [], phi1), NOTAIL, tvs) - end + in + retract(B, E'.TR(E'.DROP t1, E'.Mus [], phi1), NOTAIL, tvs) + end | E.SWITCH_I {switch: IntInf.int E.Switch, precision} => - (spreadSwitch B S (fn sw => E'.SWITCH_I{switch=sw,precision=precision}) [] (switch,toplevel,cont)) + (spreadSwitch B S (fn sw => E'.SWITCH_I{switch=sw,precision=precision}) [] (switch,toplevel,cont)) | E.SWITCH_W {switch: IntInf.int E.Switch, precision} => - (spreadSwitch B S (fn sw => E'.SWITCH_W{switch=sw,precision=precision}) [] (switch,toplevel,cont)) + (spreadSwitch B S (fn sw => E'.SWITCH_W{switch=sw,precision=precision}) [] (switch,toplevel,cont)) | E.SWITCH_S(stringsw: string E.Switch) => (spreadSwitch B S E'.SWITCH_S [] (stringsw,toplevel,cont)) | E.SWITCH_C(consw: (E.con*E.lvar option) E.Switch) => (spreadSwitch' B S E'.SWITCH_C [] (consw,toplevel,cont)) @@ -912,15 +981,18 @@ good *) | E.PRIM(E.CONprim{con, instances, regvar}, []) => let val sigma = noSome (RSE.lookupCon rse con) ".S: constructor not in RSE" - val (B, tau', il) = newInstance(B,sigma,instances) - val aux_regions = (case R.unCONSTYPE tau' of + val (B, tau, il) = newInstance(B,sigma,instances) + val aux_regions = (case R.unCONSTYPE tau of SOME(_,_,rhos,_) => rhos | NONE => die "S: nullary constructor not of constructed type") - val (rho, B) = maybe_explicit_rho rse B (R.runtype tau') regvar + val (rho, mu, B) = maybe_explicit_rho_opt rse B tau regvar + val rhos = case rho of + SOME p => p :: aux_regions + | NONE => aux_regions in - (B, E'.TR(E'.CON0{con=con, il = il, aux_regions=aux_regions, alloc = rho}, E'.Mus [(tau',rho)], - Eff.mkUnion(map Eff.mkPut (rho::aux_regions))), - NOTAIL, []) + (B, E'.TR(E'.CON0{con=con, il = il, aux_regions=aux_regions, alloc = rho}, E'.Mus [mu], + Eff.mkUnion(map Eff.mkPut rhos)), + NOTAIL, []) end | E.PRIM(E.CONprim{con, instances, regvar}, [arg]) => let @@ -933,18 +1005,25 @@ good *) val (B, t1 as E'.TR(e1', meta1', phi1), _, tvs) = S(B, arg, false, NOTAIL) val mu1' = unMus "S.CONprim" meta1' val B = R.unify_mus(mu1',mu1) B - val rho = #2 mu2 + val (rho,phi) = + case R.unBOX mu2 of + SOME(_,p) => (SOME p, Eff.mkUnion [phi1,Eff.mkPut p]) + | NONE => (NONE, phi1) val B = case regvar of NONE => B | SOME rv => case RSE.lookupRegVar rse rv of - SOME rho' => Eff.unifyRho (rho',rho) B + SOME rho' => + (case rho of + SOME rho => Eff.unifyRho (rho',rho) B + | NONE => deepError rv ("Cannot associate explicit region variable `" ^ RegVar.pr rv + ^ " with unboxed value constructor")) | NONE => deepError rv ("Explicit region variable `" ^ RegVar.pr rv ^ " not in scope") in - (B, E'.TR(E'.CON1({con=con, il = il, alloc = rho},t1), E'.Mus mus2, - Eff.mkUnion([phi1,Eff.mkPut rho])), - NOTAIL, + (B, E'.TR(E'.CON1({con=con, il=il, alloc=rho},t1), E'.Mus mus2, + phi), + NOTAIL, tvs) end | E.PRIM(E.DECONprim{con, instances,...}, [arg]) => @@ -952,18 +1031,20 @@ good *) val B = pushIfNotTopLevel(toplevel,B) (* for retract *) val sigma = noSome (RSE.lookupCon rse con) "S (DECONprim): constructor not in RSE" val (B, tau', il) = newInstance(B,sigma,instances) - val (mu1,arreff,mus2,mu2) = + val (mus1,arreff,mus2,mu2) = case R.unFUN tau' of - SOME(mu1,areff, mus2 as [mu2]) => (mu1,areff,mus2,mu2) - | _ => die "S: unary constructor not functional" + SOME(mus1,areff, mus2 as [mu2]) => (mus1,areff,mus2,mu2) + | _ => die "S: unary constructor not functional" val (B, t1 as E'.TR(e1', meta1', phi1), _, tvs) = S(B, arg, false, NOTAIL) - val mu1' = unMus "S.DECONprim" meta1' - val B = R.unify_mus(mu1',mus2) B - in - retract(B, E'.TR(E'.DECON({con=con, il = il},t1), E'.Mus mu1, - Eff.mkUnion([phi1,Eff.mkGet(#2 mu2)])), - NOTAIL, - tvs) + val mus1' = unMus "S.DECONprim" meta1' + val B = R.unify_mus(mus1',mus2) B + val phi = case R.unBOX mu2 of + SOME (_,r) => Eff.mkUnion [phi1,Eff.mkGet r] + | NONE => phi1 + in retract(B, E'.TR(E'.DECON({con=con, il=il},t1), E'.Mus mus1, + phi), + NOTAIL, + tvs) end | E.PRIM(E.EXCONprim excon, []) => let @@ -973,49 +1054,52 @@ good *) *) in (B, E'.TR(E'.EXCON(excon,NONE), E'.Mus [mu], Eff.mkUnion([])), - NOTAIL, + NOTAIL, []) end | E.PRIM(E.EXCONprim excon, [arg]) => (case S(B,arg, false, NOTAIL) of (* expression denotes value *) (B,t_arg as E'.TR(arg_e, E'.Mus mus, phi_arg), _, tvs) => - let - val mu = noSome (RSE.lookupExcon rse excon) ".S: unary exception constructor not in RSE" - in - case R.unFUN (#1 mu) of - SOME(mus1,arreff,mus_result as [(_, rho_result)]) => - let - val B = R.unify_mus(mus1,mus) B - val phi = Eff.mkPut(rho_result) - in - (B, E'.TR(E'.EXCON(excon,SOME (rho_result,t_arg)), - E'.Mus mus_result, Eff.mkUnion([phi,phi_arg])), - NOTAIL, - tvs) - end - | _ => die "S: unary exception constructor ill-typed" - end + let val mu = noSome (RSE.lookupExcon rse excon) ".S: unary exception constructor not in RSE" + val (tau,_) = noSome (R.unBOX mu) ".S: unary exception constructor function not boxed" + in case R.unFUN tau of + SOME(mus1,arreff,mus_result as [mu_result]) => + let val (_,rho_result) = noSome (R.unBOX mu_result) ".S: unary exception constructor not boxed" + val B = R.unify_mus(mus1,mus) B + val phi = Eff.mkPut rho_result (* maybe unify region for function and region for exception *) + in + (B, E'.TR(E'.EXCON(excon,SOME (rho_result,t_arg)), + E'.Mus mus_result, Eff.mkUnion([phi,phi_arg])), + NOTAIL, + tvs) + end + | _ => die "S: unary exception constructor ill-typed" + end (* expression denotes frame or failing top-level binding : *) | (B,t_arg as E'.TR(arg_e, E'.RaisedExnBind, phi_arg), _, _) => die "S: exception constructor applied to frame or raised Bind exception" - | _ => die "S(B,PRIM(EXCON...),...)" + | _ => die "S(B,PRIM(EXCON...),...)" ) | E.PRIM(E.DEEXCONprim excon, [arg]) => let val B = pushIfNotTopLevel(toplevel,B) (* for retract *) - val (tau, p) = noSome (RSE.lookupExcon rse excon) "S (DEEXCONprim): exception constructor not in RSE" - val (mu1,arreff,mus2,mu2) = + val mu = noSome (RSE.lookupExcon rse excon) "S (DEEXCONprim): exception constructor not in RSE" + val (tau,p) = noSome (R.unBOX mu) "S (DEEXCONprim): expecting boxed type" + val (mus1,arreff,mus2,mu2) = case R.unFUN tau of - SOME(mu1,areff, mus2 as [mu2]) => (mu1,areff,mus2,mu2) + SOME(mus1,areff, mus2 as [mu2]) => (mus1,areff,mus2,mu2) | _ => die "S: unary exception constructor not functional" val (B, t1 as E'.TR(e1', meta1', phi1), _, tvs) = S(B, arg, false, NOTAIL) - val mu1' = unMus "S.DEEXCONprim" meta1' - val B = R.unify_mus(mu1',mus2) B + val mus1' = unMus "S.DEEXCONprim" meta1' + val B = R.unify_mus(mus1',mus2) B + val rho = case R.unBOX mu2 of + SOME (_,p) => p + | NONE => die "expecting boxed exception type" in - retract(B, E'.TR(E'.DEEXCON(excon,t1), E'.Mus mu1, - Eff.mkUnion([phi1,Eff.mkGet(#2 mu2)])), - NOTAIL, + retract(B, E'.TR(E'.DEEXCON(excon,t1), E'.Mus mus1, + Eff.mkUnion([phi1,Eff.mkGet rho])), + NOTAIL, tvs) end | E.PRIM(E.RECORDprim rv_opt,args) => @@ -1024,49 +1108,56 @@ good *) in (B, trip::trips, spuriousJoin tvs' tvs) end) (B,[],[]) args val tau = R.mkRECORD(map (fn E'.TR(_,E'.Mus [mu],_) => mu | _ => die "S.record: boxed arg") trips) - val (rho,B) = maybe_explicit_rho rse B (R.runtype tau) rv_opt - (*val (rho,B) = Eff.freshRhoWithTy(R.runtype tau, B)*) - val phi = Eff.mkUnion(Eff.mkPut rho :: map (fn E'.TR(_,_,phi) => phi) trips) + val (rho, mu, B) = maybe_explicit_rho_opt rse B tau rv_opt + val phis = map (fn E'.TR(_,_,phi) => phi) trips + val phis = case rho of + SOME p => Eff.mkPut p :: phis + | NONE => phis + val phi = Eff.mkUnion phis in - (B, E'.TR(E'.RECORD(rho, trips), E'.Mus [(tau, rho)], phi), - NOTAIL, + (B, E'.TR(E'.RECORD(rho, trips), E'.Mus [mu], phi), + NOTAIL, tvs) end - | E.PRIM(E.SELECTprim i, [arg as E.VAR _]) => + | E.PRIM(E.SELECTprim i, [arg as E.VAR _]) => (* avoid retract for this case *) let val (B, t1 as E'.TR(e1', meta1, phi1), _, tvs) = S(B,arg, false, NOTAIL) - val mus1 = unMus "S.SELECTprim-VAR" meta1 val (mus,rho) = - case mus1 of - [(ty,rho)] => - (case R.unRECORD ty of - SOME mus => (mus,rho) - | NONE => die "S (select) : not record type") - | _ => die "S (select) : not record type" + case unMus "S.SELECTprim-VAR" meta1 of + [mu] => + (case R.unBOX mu of + SOME (ty,rho) => + (case R.unRECORD ty of + SOME mus => (mus,rho) + | NONE => die "S (select) : not record type") + | NONE => die "S (select) : not boxed record type") + | _ => die "S (select) : not record type" val mu = List.nth(mus,i) handle Subscript => die "S (select) : select index out of range" val phi = Eff.mkUnion([Eff.mkGet rho, phi1]) in (B, E'.TR(E'.SELECT(i, t1), E'.Mus [mu], phi), - NOTAIL, + NOTAIL, tvs) end | E.PRIM(E.SELECTprim i, [arg]) => let val B = pushIfNotTopLevel(toplevel,B) (* for retract *) val (B, t1 as E'.TR(e1', meta1, phi1), _, tvs) = S(B,arg, false, NOTAIL) - val mus1 = unMus "S.SELECTprim" meta1 val (mus,rho) = - case mus1 of - [(ty,rho)] => - (case R.unRECORD ty of - SOME mus => (mus,rho) - | NONE => die "S (select) : not record type") - | _ => die "S (select) : not record type" + case unMus "S.SELECTprim" meta1 of + [mu] => + (case R.unBOX mu of + SOME (ty,rho) => + (case R.unRECORD ty of + SOME mus => (mus,rho) + | NONE => die "S (select) : not record type") + | NONE => die "S (select) : not boxed record type") + | _ => die "S (select) : not record type" val mu = List.nth(mus,i) handle Subscript => die "S (select) : select index out of range" val phi = Eff.mkUnion([Eff.mkGet rho, phi1]) in retract(B, E'.TR(E'.SELECT(i, t1), E'.Mus [mu], phi), - NOTAIL, + NOTAIL, tvs) end @@ -1085,16 +1176,14 @@ good *) val (B, t2 as E'.TR(e2', meta2, phi2),_,tvs2) = S(B,arg2,false,NOTAIL) val mus1 = unMus "S.EQUALprim1" meta1 val mus2 = unMus "S.EQUALprim2" meta2 - val (rho,B) = Eff.freshRhoWithTy(Eff.WORD_RT, B) - val mus = [(R.boolType,rho)] - val phi = Eff.mkUnion(phi1::phi2::Eff.mkPut rho :: - map Eff.mkGet(List.filter Eff.is_rho (R.ann_mus (mus1 @ mus2) []))) + val phi = Eff.mkUnion(phi1 :: phi2 :: + map Eff.mkGet(List.filter Eff.is_rho (R.ann_mus (mus1 @ mus2) []))) val (mu1,mu2) = case (mus1,mus2) of ([mu1],[mu2]) => (mu1,mu2) | _ => die "S: ill-typed equality" in - retract(B, E'.TR(E'.EQUAL({mu_of_arg1 = mu1, mu_of_arg2 = mu2, alloc = rho},t1,t2), - E'.Mus mus, phi), - NOTAIL, + retract(B, E'.TR(E'.EQUAL({mu_of_arg1 = mu1, mu_of_arg2 = mu2},t1,t2), + E'.Mus [R.boolType], phi), + NOTAIL, spuriousJoin tvs1 tvs2) end @@ -1120,44 +1209,44 @@ good *) | E.PRIM (E.CCALLprim {name, instances, tyvars, Type}, es) => (let val B = pushIfNotTopLevel (toplevel, B) (* for retract *) - val (B, sigma) = - let val B = Eff.push B (* for sigma *) - val (mu, B) = freshMu (Type, B) - handle X => (print "CCALL-1.1\n"; raise X) - val (sigma, B) = R.sigma_for_c_function tyvars mu B - handle X => (print "CCALL-1.2\n"; raise X) - val B = #2(Eff.pop B) - handle X => (print "CCALL-1.3\n"; raise X) - in (B, sigma) (* for sigma *) - end handle X => (print "CCALL-1\n"; raise X) - (*much of the rest is analogous to the case for (APP (VAR ..., ...))*) - val (B, tau, _) = newInstance (B, sigma, instances) - handle X => (print "CCALL-2\n"; raise X) - in - (case R.unFUN tau of - SOME (mus_a, eps_phi0, [mu_r]) => - let - val (B, trs', mus_es, phis, tvs) = - List.foldr (fn (e, (B, trs', mus_es, phis, tvs)) => + val (B, sigma) = + let val B = Eff.push B (* for sigma *) + val (ty, B) = freshType (Type, B) + handle X => (print "CCALL-1.1\n"; raise X) + val (sigma, B) = R.sigma_for_c_function tyvars ty B + handle X => (print "CCALL-1.2\n"; raise X) + val B = #2(Eff.pop B) + handle X => (print "CCALL-1.3\n"; raise X) + in (B, sigma) (* for sigma *) + end handle X => (print "CCALL-1\n"; raise X) + (*much of the rest is analogous to the case for (APP (VAR ..., ...))*) + val (B, tau, _) = newInstance (B, sigma, instances) + handle X => (print "CCALL-2\n"; raise X) + in + (case R.unFUN tau of + SOME (mus_a, eps_phi0, [mu_r]) => + let + val (B, trs', mus_es, phis, tvs) = + List.foldr (fn (e, (B, trs', mus_es, phis, tvs)) => let val (B, tr' as E'.TR (_, meta', phi), _, tvs') = S (B, e, false, NOTAIL) val mus' = unMus "S.CCALLprim" meta' - in (case mus' of - [mu'] => (B, tr' :: trs', mu' :: mus_es, phi :: phis, spuriousJoin tvs' tvs) - | _ => die "S: CCALL argument had not precisely one mu") - end) (B, [], [], [], []) es - val B = R.unify_mus (mus_a, mus_es) B - handle X => (print "CCALL-3\n"; raise X) - val rhos_for_result = R.c_function_effects (sigma,mu_r) - handle X => (print "CCALL-4\n"; raise X) - val e' = E'.CCALL ({name = name, mu_result = mu_r, - rhos_for_result = rhos_for_result}, trs') - in - retract (B, E'.TR (e', E'.Mus [mu_r], Eff.mkUnion (eps_phi0 :: phis)), - NOTAIL, + in (case mus' of + [mu'] => (B, tr' :: trs', mu' :: mus_es, phi :: phis, spuriousJoin tvs' tvs) + | _ => die "S: CCALL argument had not precisely one mu") + end) (B, [], [], [], []) es + val B = R.unify_mus (mus_a, mus_es) B + handle X => (print "CCALL-3\n"; raise X) + val rhos_for_result = R.c_function_effects (sigma,mu_r) + handle X => (print "CCALL-4\n"; raise X) + val e' = E'.CCALL ({name = name, mu_result = mu_r, + rhos_for_result = rhos_for_result}, trs') + in + retract (B, E'.TR (e', E'.Mus [mu_r], Eff.mkUnion (eps_phi0 :: phis)), + NOTAIL, tvs) - end - | _ => die "CCALL: tau not function type") - end handle (X as Report.DeepError _) => raise X + end + | _ => die "CCALL: tau not function type") + end handle (X as Report.DeepError _) => raise X | X => (print ("CCALL FAILED\n"); raise X)) | E.PRIM(E.BLOCKF64prim, args) => @@ -1165,27 +1254,24 @@ good *) let val (B, trip, _, tvs') = S(B,arg, false, NOTAIL) in (B, trip::trips, spuriousJoin tvs' tvs) end) (B,[],[]) args - val () = List.app (fn E'.TR(_,E'.Mus [(tau,rho)],_) => - if R.isF64Type tau then () + val () = List.app (fn E'.TR(_,E'.Mus [mu],_) => + if R.isF64Type mu then () else die "S.blockf64: expecting f64 type" | _ => die "S.blockf64: expecting one mu") trips - val tau = R.stringType -(* val (rho,B) = maybe_explicit_rho rse B (R.runtype tau) rv_opt *) - val (rho,B) = Eff.freshRhoWithTy(R.runtype tau, B) + val (B, rho, mu) = freshBoxMu "BLOCKF64prim" B R.stringType val phi = Eff.mkUnion(Eff.mkPut rho :: map (fn E'.TR(_,_,phi) => phi) trips) in - (B, E'.TR(E'.BLOCKF64(rho, trips), E'.Mus [(tau, rho)], phi), - NOTAIL, + (B, E'.TR(E'.BLOCKF64(rho, trips), E'.Mus [mu], phi), + NOTAIL, tvs) end | E.PRIM(E.SCRATCHMEMprim n, []) => - let val tau = R.stringType - val (rho,B) = Eff.freshRhoWithTy(R.runtype tau, B) + let val (B, rho, mu) = freshBoxMu "SCRATCHMEMprim" B R.stringType val phi = Eff.mkPut rho in - (B, E'.TR(E'.SCRATCHMEM(n,rho), E'.Mus [(tau, rho)], phi), - NOTAIL, + (B, E'.TR(E'.SCRATCHMEM(n,rho), E'.Mus [mu], phi), + NOTAIL, []) end @@ -1195,46 +1281,45 @@ good *) \/v \in frev(mu). v is toplevel ------------------------------------------------ _export(name,mu1,mu2,e) : [unit], phi - *) + *) (let val B = pushIfNotTopLevel (toplevel, B) (* for retract *) - val (B, tr' as E'.TR (_, meta, phi), _, tvs) = S (B, e0, false, NOTAIL) + val (B, tr' as E'.TR (_, meta, phi), _, tvs) = S (B, e0, false, NOTAIL) val mus = unMus "S.EXPORTprim" meta - in case mus of - [(ty,rho)] => - (case R.unFUN ty of - SOME([mu1],eps_phi0,[mu2]) => - let (*val (mu1',B) = freshMu(instance_arg,B) - val B = R.unify_mu(mu1,mu1')B - val (mu2',B) = freshMu(instance_res,B) - val B = R.unify_mu(mu2,mu2')B *) - val e' = E'.EXPORT ({name=name, mu_arg=mu1, mu_res=mu2}, tr') - val (mu,B) = - let val (fresh_rho,B) = Eff.freshRhoWithTy(Eff.WORD_RT, B) - in ((R.unitType, fresh_rho),B) - end - val effects = R.ann_mus mus [] + in case mus of + [mu] => + let val (ty,rho) = noSome (R.unBOX mu) "S.EXPORT: expecting boxed function" + in case R.unFUN ty of + SOME([mu1],eps_phi0,[mu2]) => + let (*val (mu1',B) = freshMu(instance_arg,B) + val B = R.unify_mu(mu1,mu1')B + val (mu2',B) = freshMu(instance_res,B) + val B = R.unify_mu(mu2,mu2')B *) + val e' = E'.EXPORT ({name=name, mu_arg=mu1, mu_res=mu2}, tr') + val mu = R.unitType + val effects = R.ann_mus mus [] (* - val _ = ( print "effects before unification with toplevel effects: " - ; print_effects effects - ; print "\n") + val _ = ( print "effects before unification with toplevel effects: " + ; print_effects effects + ; print "\n") *) - (* First, lower effects to top-level(i.e., level 1) *) - val B = foldl (fn (e,B) => Eff.lower 1 e B) B effects - val B = Eff.unify_with_toplevel_rhos_eps (B, effects) + (* First, lower effects to top-level(i.e., level 1) *) + val B = foldl (fn (e,B) => Eff.lower 1 e B) B effects + val B = Eff.unify_with_toplevel_rhos_eps (B, effects) (* - val _ = ( print "effects after unification with toplevel effects: " - ; print_effects effects - ; print "\n") + val _ = ( print "effects after unification with toplevel effects: " + ; print_effects effects + ; print "\n") *) - in - retract (B, E'.TR (e', E'.Mus [mu], (*was: eps_phi0*) phi), - NOTAIL, - tvs) - end - | _ => die "EXPORT: function does not have function type") - | _ => die "EXPORT: function does not have function type" - end handle X => (print "EXPORT-1\n"; raise X)) + in + retract (B, E'.TR (e', E'.Mus [mu], (*was: eps_phi0*) phi), + NOTAIL, + tvs) + end + | _ => die "EXPORT: function does not have function type" + end + | _ => die "EXPORT: function does not have function type" + end handle X => (print "EXPORT-1\n"; raise X)) | E.PRIM(E.RESET_REGIONSprim{instance = _}, [e0 as (E.VAR _)] ) => (* @@ -1250,15 +1335,14 @@ good *) let val (B, t as E'.TR(e',meta0,_), _, tvs) = S(B,e0,false,NOTAIL) val mus0 = unMus "S.RESET_REGIONSprim" meta0 - val (fresh_rho,B) = Eff.freshRhoWithTy(Eff.WORD_RT, B) - val mu = (R.unitType, fresh_rho) - val phi = Eff.mkUnion(map Eff.mkPut(fresh_rho::List.filter Eff.is_rho (R.ann_mus mus0 []))) + val mu = R.unitType + val phi = Eff.mkUnion(map Eff.mkPut(List.filter Eff.is_rho (R.ann_mus mus0 []))) in case e' of E'.VAR{il_r as ref il, ...} => (case R.un_il (#1 il) of ([],[],[]) => - (B,E'.TR(E'.RESET_REGIONS({force = false, alloc = fresh_rho, regions_for_resetting = []},t), E'.Mus [mu], phi), - NOTAIL, + (B,E'.TR(E'.RESET_REGIONS({force=false, regions_for_resetting = []},t), E'.Mus [mu], phi), + NOTAIL, tvs) | _ => crash_resetting false) | _ => crash_resetting false @@ -1269,15 +1353,14 @@ good *) let val (B, t as E'.TR(e',meta0,_), _, tvs) = S(B,e0,false,NOTAIL) val mus0 = unMus "S.FORCE_RESET_REGIONSprim" meta0 - val (fresh_rho,B) = Eff.freshRhoWithTy(Eff.WORD_RT, B) - val mu = (R.unitType, fresh_rho) - val phi = Eff.mkUnion(map Eff.mkPut(fresh_rho::List.filter Eff.is_rho (R.ann_mus mus0 []))) + val mu = R.unitType + val phi = Eff.mkUnion(map Eff.mkPut(List.filter Eff.is_rho (R.ann_mus mus0 []))) in case e' of E'.VAR{il_r as ref il, ...} => (case R.un_il (#1 il) of ([],[],[]) => - (B,E'.TR(E'.RESET_REGIONS({force = true, alloc = fresh_rho, regions_for_resetting = []},t), E'.Mus [mu], phi), - NOTAIL, + (B,E'.TR(E'.RESET_REGIONS({force=true, regions_for_resetting = []},t), E'.Mus [mu], phi), + NOTAIL, tvs) | _ => crash_resetting true) | _ => crash_resetting true @@ -1288,19 +1371,19 @@ good *) let val new_declared_lvars' = List.foldr( fn (lvar, acc) => let val (compound,create_region_record,regvars,sigma,p,_,_) = - noSome (RSE.lookupLvar rse lvar) "declared lvar of frame not in scope" + noSome (RSE.lookupLvar rse lvar) "declared lvar of frame not in scope" in {lvar=lvar, compound=compound, create_region_record=create_region_record, - regvars=regvars,sigma=ref sigma, place=p} :: acc + regvars=regvars,sigma=ref sigma, place=p} :: acc end) [](map #lvar declared_lvars) - val new_declared_lvars = - map (fn {lvar,regvars,sigma,place,...} => {lvar=lvar,regvars=regvars,sigma=sigma,place=place}) new_declared_lvars' + val new_declared_lvars = + map (fn {lvar,regvars,sigma,place,...} => {lvar=lvar,regvars=regvars,sigma=sigma,place=place}) new_declared_lvars' val new_declared_excons = List.foldr( fn (excon, acc) => (excon,RSE.lookupExcon rse excon)::acc) [](map #1 declared_excons) in (B,E'.TR(E'.FRAME{declared_lvars = new_declared_lvars, declared_excons = new_declared_excons}, E'.Frame{declared_lvars = new_declared_lvars', declared_excons = new_declared_excons}, Eff.empty), - NOTAIL, + NOTAIL, []) end | _ => die "S: unknown expression" @@ -1340,7 +1423,7 @@ good *) and spreadFcns (B,rho,retract_level,rse) functions (* each one: (lvar,tyvars,sigma_hat,bind) *) = let val occs = map (fn _ => ref [] : (R.il * (R.il * cone -> R.il * cone)) ref list ref) functions - val rse1 = declareMany(rho,rse)(functions, occs) + val rse1 = declareMany (rho,rse) (functions, occs) val proper_rec : bool = case functions of [f] => proper_recursive f @@ -1358,9 +1441,9 @@ good *) val (B, t1 as E'.TR(_, meta1, phi1),_,tvs') = spreadExp(B, rse1', bind,false,NOTAIL) val (tau1,rho1) = case unMus "spreadFcns" meta1 of - [p] => p + [p] => noSome (R.unBOX p) "spreadRhss: expecting boxed function type" | _ => die "spreadFcns: expecting singleton mus" - val B = Eff.unifyRho(rho1,rho) B + val B = Eff.unifyRho (rho1,rho) B val _ = count_RegEffClos:= !count_RegEffClos + 1 val ((tvs'',tvs1,B),sigma1) = @@ -1427,5 +1510,4 @@ good *) end handle Abort => die "spreadPgm: SpreadExpression failed" | Bind => die "spreadPgm: uncaught exception Bind" | Match => die "spreadPgm: uncaught exception Match" - -end (* SpreadExpression *) +end diff --git a/src/Runtime/GC.c b/src/Runtime/GC.c index 0dadfc3e4..58b81e760 100644 --- a/src/Runtime/GC.c +++ b/src/Runtime/GC.c @@ -1757,7 +1757,7 @@ gc(Context ctx, uintptr_t **sp, size_t reg_map) if ( verbose_gc ) { - double RI = 0.0, GC = 0.0, FRAG = 0.0; + double FRAG = 0.0; size_t bytes_to_space; size_t pages_to_space; //size_t copied_bytes = alloc_period; @@ -1818,7 +1818,7 @@ gc(Context ctx, uintptr_t **sp, size_t reg_map) L_gc = L1 - L2; P_ri = 100.0 * (R_ri + L_ri) / (R_ri + L_ri + R_gc + L_gc); P_gc = 100.0 * (R_gc + L_gc) / (R_ri + L_ri + R_gc + L_gc); - + /* RI = 100.0 * ( ((double)((double)to_space_old + (double)lobjs_aftergc_old + (double)alloc_period + (double)lobjs_period - (double)bytes_from_space - (double)lobjs_beforegc)) / ((double)((double)to_space_old + (double)lobjs_aftergc_old + (double)alloc_period + @@ -1829,7 +1829,7 @@ gc(Context ctx, uintptr_t **sp, size_t reg_map) ((double)(to_space_old + lobjs_aftergc_old + alloc_period + lobjs_period - bytes_to_space - lobjs_aftergc))); - + */ FRAG = 100.0 - 100.0 * (((double)(bytes_from_space + lobjs_beforegc)) / ((double)(sizeof(void *)*ALLOCATABLE_WORDS_IN_REGION_PAGE*pages_from_space + lobjs_beforegc))); diff --git a/test_dev/hanoi.sml b/test_dev/hanoi.sml index f3e5beffa..da540f94b 100644 --- a/test_dev/hanoi.sml +++ b/test_dev/hanoi.sml @@ -4,19 +4,19 @@ let infix < infix > - fun out_str(s) = prim("printStringML", s) - fun printNum(i:int):unit = prim ("printNum",i) + fun out_str (s:string) : unit = prim("printStringML", s) + fun printNum (i:int) : unit = prim ("printNum",i) - fun neq(x,y) = if xy then false else true + fun neq (x,y) = if xy then false else true - fun show_move(i,j) = + fun show_move (i,j) = (out_str "move "; printNum i; out_str "to "; printNum j; out_str "\n ") - fun hanoi(n, from, to, via)= + fun hanoi (n, from, to, via)= if neq(n,0) then () else (hanoi(n-1, from, via, to); show_move(from,to);