diff options
Diffstat (limited to 'sucl/newfold.icl')
| -rw-r--r-- | sucl/newfold.icl | 221 |
1 files changed, 142 insertions, 79 deletions
diff --git a/sucl/newfold.icl b/sucl/newfold.icl index 31d5a79..604c60f 100644 --- a/sucl/newfold.icl +++ b/sucl/newfold.icl @@ -2,8 +2,13 @@ implementation module newfold // $Id$ +import extract import trace +import spine import rule +import dnc +import graph +import basic import StdEnv /* @@ -77,19 +82,6 @@ folded, this is done. The remaining subtraces of the trace (which is possibly the whole trace) are folded in their own right. Introduced recursion is applied if it occurs within any subtrace. - -> fullfold :: -> etracer * ** *** -> -> (rgraph * **->(*,[**])) -> -> * -> -> trace * ** *** -> -> ([bool],[rule * **],[rgraph * **]) - -> fullfold trc foldarea fnsymbol trace -> = recurseresult, if recursive ->|| = mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise -> = newextract trc foldarea trace, otherwise -> where (recursive,recurseresult) = recurse foldarea fnsymbol trace */ fullfold :: @@ -98,6 +90,9 @@ fullfold :: sym (Trace sym var pvar) -> ([Bool],[Rule sym var],[Rgraph sym var]) + | == sym + & == var + & == pvar fullfold trc foldarea fnsymbol trace | recursive @@ -105,9 +100,6 @@ fullfold trc foldarea fnsymbol trace = newextract trc foldarea trace where (recursive,recurseresult) = recurse foldarea fnsymbol trace -recurse = undef -newextract = undef - /* `Recurse foldarea fnsymbol trace' is a pair `(recursive,recurseresult)'. `Recurseresult' is the derived function definition (strictness, rules, @@ -116,33 +108,42 @@ the areas in the trace to recursive function calls when at all possible. The allowed patterns for the autorecursion are derived from the top of the trace. If no recursive function call can be found, `recurseresult' is `False'. +*/ -> recurse :: -> (rgraph * **->(*,[**])) -> -> * -> -> trace * ** *** -> -> (bool,([bool],[rule * **],[rgraph * **])) - -> recurse foldarea fnsymbol -> = f ([],[]) -> where f (newhist,hist) (Trace stricts rule answer history (Reduce reductroot trace)) -> = f (newhist',newhist') trace, if pclosed=[] & superset popen ropen -> where rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule -> (pclosed,popen) = nodeset rgraph rargs -> (rclosed,ropen) = nodeset rgraph [rroot] -> newhist' = (rroot,rgraph):newhist -> f (newhist,hist) (Trace stricts rule answer history (Annotate trace)) -> = f (newhist',hist) trace, if pclosed=[] & superset popen ropen -> where rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule -> (pclosed,popen) = nodeset rgraph rargs -> (rclosed,ropen) = nodeset rgraph [rroot] -> newhist' = (rroot,rgraph):newhist -> f (newhist,hist) (Trace stricts rule answer history transf) -> = foldtips foldarea (fnsymbol,lhs rule) (mkset newhist',mkset hist) (Trace stricts rule answer history transf) -> where rroot = rhs rule; rgraph = rulegraph rule -> newhist' = (rroot,rgraph):newhist +recurse :: + ((Rgraph sym var)->(sym,[var])) + sym + -> (Trace sym var pvar) + -> (Bool,([Bool],[Rule sym var],[Rgraph sym var])) + | == sym + & == var + & == pvar + +recurse foldarea fnsymbol += f ([],[]) + where f (newhist,hist) (Trace stricts rule answer history (Reduce reductroot trace)) + | isEmpty pclosed && superset popen ropen + = f (newhist`,newhist`) trace + where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + (pclosed,popen) = graphvars rgraph rargs + (_,ropen) = graphvars rgraph [rroot] + newhist` = [(rroot,rgraph):newhist] + f (newhist,hist) (Trace stricts rule answer history (Annotate trace)) + | isEmpty pclosed && superset popen ropen + = f (newhist`,hist) trace + where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + (pclosed,popen) = graphvars rgraph rargs + (_,ropen) = graphvars rgraph [rroot] + newhist` = [(rroot,rgraph):newhist] + f (newhist,hist) (Trace stricts rule answer history transf) + = foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) + where rroot = ruleroot rule; rgraph = rulegraph rule + newhist` = [(rroot,rgraph):newhist] + +foldtips = undef +/* `Foldtips foldarea foldcont hist trace' folds all occurrences of (rooted graphs in hist) in the tips of the trace. It returns a list of rules, which are the results of folding, and a list of areas for which @@ -286,8 +287,47 @@ This is a version of `extract' that does not use the collector argument. > isreduce (Reduce reductroot trace) = True > isreduce transf = False +*/ + +newextract :: + (Etracer sym var pvar) + ((Rgraph sym var)->(sym,[var])) + (Trace sym var pvar) + -> ([Bool],[Rule sym var],[Rgraph sym var]) + | == sym + & == var + & == pvar + +newextract trc newname (Trace stricts rule answer history transf) +| recursive + = (stricts,[recrule],recareas) += subex transf + where subex (Reduce reductroot trace) = newextract trc newname trace + subex (Annotate trace) = newextract trc newname trace + subex (Instantiate yestrace notrace) + = (stricts,yesrules++norules,yesareas++noareas) + where (yesstricts,yesrules,yesareas) = newextract trc newname yestrace + (nostricts,norules,noareas) = newextract trc newname notrace + subex Stop = (stricts,[mkrule rargs rroot stoprgraph],stopareas) + + (recursive,unsafearea) + = if (isreduce transf) + (foldoptional (False,undef) (findspinepart rule transf) answer) + (False,abort "newextract: not a Reduce transformation") + + (recrule,recareas) = splitrule newname rnfnodes deltanodes rule unsafearea + (stoprgraph,stopareas) = finishfold newname rnfnodes deltanodes rroot rgraph + + rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + rnfnodes = foldoptional (cons rroot) (const id) answer (varlist rgraph rargs) + deltanodes = foldoptional [] getdeltanodes answer +isreduce (Reduce reductroot trace) = True +isreduce transf = False + + +/* `Findspinepart toprule rule spine (transformation,trace)' is a pair with a boolean determining whether some instance of the `spine', determined using `toprule', occurs in a residu of itself in `trace'. @@ -317,7 +357,33 @@ to its root. > extgraph' sgraph rule > = extgraph sgraph rgraph (nodelist rgraph (lhs rule)) > where rgraph = rulegraph rule +*/ + +findspinepart :: (Rule sym var) (Transformation sym var pvar) (Spine sym var pvar) -> (Bool,Rgraph sym var) | == sym & == var & == pvar + +findspinepart rule transf spine += snd (foldspine pair stop stop force stop (const stop) partial (const stop) redex stop spine) + where pair node (pattern,recursion) + = (pattern`,recursion`) + where pattern` + = if def (updategraph node cnt pattern) pattern + (def,cnt) = dnc (const "in findspinepart") graph node + recursion` + | findpattern (pattern`,node) (spinenodes spine) node transf + = (True,mkrgraph node pattern`) + = recursion + force _ res = res + partial rule matching _ (pattern,recursion) = (extgraph` graph rule matching pattern,recursion) + redex rule matching = (extgraph` graph rule matching emptygraph,norecursion) + stop = (emptygraph,norecursion) + norecursion = (False,abort "findspinepart: no part of spine found") + graph = rulegraph rule + +extgraph` sgraph rule += extgraph sgraph rgraph (varlist rgraph (arguments rule)) + where rgraph = rulegraph rule +/* `Findpattern pattern rule residuroot transformation trace' bepaalt of een instance van `pattern' voorkomt in een residu van `residuroot' in de `trace'. @@ -325,56 +391,53 @@ een instance van `pattern' voorkomt in een residu van `residuroot' in de Omwille van optimalisatie worden, met behulp van `transformation' en `rule', alleen nieuw toegevoegde nodes na een rewrite in de trace bekeken. De rest is toch niet veranderd. +*/ +findpattern :: (Graph sym var2,var2) [var] var (Transformation sym var pvar) -> Bool | == sym & == var & == var2 & == pvar -> findpattern :: (graph * ****,****) -> [**] -> ** -> transformation * ** *** -> bool - -> findpattern pattern thespinenodes residuroot transf -> = False, if ~member thespinenodes residuroot || Root of residu no longer in spine - must have come to RNF. +findpattern pattern thespinenodes residuroot transf +| isMember residuroot thespinenodes + = False // Root of residu no longer in spine - must have come to RNF. -> findpattern pattern thespinenodes residuroot (Reduce reductroot trace) -> = fp (redirect residuroot) trace -> where fp residuroot (Trace stricts rule answer history transf) -> = True, if or [instance pattern (graph,node)|node<-nodelist graph [residuroot]] -> where graph = rulegraph rule -> fp = findpattern' pattern -> redirect = adjust (last thespinenodes) reductroot id +findpattern pattern thespinenodes residuroot (Reduce reductroot trace) += fp (redirect residuroot) trace + where fp residuroot (Trace stricts rule answer history transf) + | or [isinstance pattern (graph,node) \\ node<-varlist graph [residuroot]] + = True + where graph = rulegraph rule + fp residuroot trace = findpattern` pattern residuroot trace + redirect = adjust (last thespinenodes) reductroot id -> findpattern pattern thespinenodes residuroot (Instantiate yestrace notrace) -> = findpattern' pattern residuroot yestrace\/findpattern' pattern residuroot notrace +findpattern pattern thespinenodes residuroot (Instantiate yestrace notrace) += findpattern` pattern residuroot yestrace || findpattern` pattern residuroot notrace -> findpattern pattern thespinenodes residuroot (Annotate trace) -> = findpattern' pattern residuroot trace +findpattern pattern thespinenodes residuroot (Annotate trace) += findpattern` pattern residuroot trace -> findpattern pattern thespinenodes residuroot Stop -> = False +findpattern pattern thespinenodes residuroot Stop += False -> findpattern' :: (graph * ****,****) -> ** -> trace * ** *** -> bool +findpattern` :: (Graph sym var2,var2) var (Trace sym var pvar) -> Bool | == sym & == var & == var2 & == pvar -> findpattern' pattern residuroot (Trace stricts rule answer history transf) -> = findpattern pattern thespinenodes residuroot transf -> where thespinenodes = foldoptional [] spinenodes answer +findpattern` pattern residuroot (Trace stricts rule answer history transf) += findpattern pattern thespinenodes residuroot transf + where thespinenodes = foldoptional [] spinenodes answer +/* `Getdeltanodes spine' is the list of nodes in the spine that we don't want to introduce new functions for because they contain a delta symbol or a strict argument. - -> getdeltanodes -> :: spine * ** *** -> -> [**] - -Uses foldspine with - - **** == (bool,[**]) - ***** == [**] - -> getdeltanodes -> = foldspine pair none (True,[]) force none (const none) partial (const none) redex none -> where pair node (forced,nodes) = cond forced (node:nodes) nodes -> none = (False,[]) -> force nodes = (True,nodes) -> partial rule matching nodes = (False,nodes) -> redex rule matching = none - */ + +getdeltanodes :: + (Spine sym var pvar) + -> [var] + +getdeltanodes spine += foldspine pair none (True,[]) force none (const none) partial (const none) redex none spine + where pair node (forced,nodes) = if forced [node:nodes] nodes + none = (False,[]) + force _ nodes = (True,nodes) + partial _ _ _ nodes = (False,nodes) + redex _ _ = none |