Commit d3232609 authored by Vincent Zweije's avatar Vincent Zweije
Browse files

This commit was generated by cvs2svn to compensate for changes in r622,

which included commits to RCS files with non-trunk default branches.
parent 98c7d393
......@@ -28,8 +28,8 @@ $(SYS)/%.abc: %.icl
$(SYS)/supercompile.abc: supercompile.icl supercompile.dcl convert.dcl
$(SYS)/convert.abc: convert.icl convert.dcl coreclean.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/newtest.abc: newtest.icl newtest.dcl newfold.dcl cli.dcl canon.dcl coreclean.dcl loop.dcl trace.dcl spine.dcl history.dcl complete.dcl trd.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/newfold.abc: newfold.icl newfold.dcl trace.dcl spine.dcl history.dcl rule.dcl
$(SYS)/extract.abc: extract.icl extract.dcl
$(SYS)/newfold.abc: newfold.icl newfold.dcl extract.dcl trace.dcl spine.dcl history.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/extract.abc: extract.icl extract.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/cli.abc: cli.icl cli.dcl law.dcl coreclean.dcl strat.dcl absmodule.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/canon.abc: canon.icl canon.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
......
......@@ -2,6 +2,13 @@ implementation module extract
// $Id$
import rule
import dnc
import graph
import basic
from general import Yes,No
import StdEnv
/*
extract.lit - Folding of subject graphs
......@@ -52,38 +59,43 @@ areas for parts that aren't folded.
`Self' determines whether an instance of a history graph is the history
graph itself. We don't want to fold back something we unfolded earlier!
*/
> actualfold ::
> [**] ->
> [**] ->
> (rgraph * **->(*,[**])) ->
> (***->**->bool) ->
> (*,[***]) ->
> [(***,graph * ***)] ->
> rule * ** ->
> optional (rule * **,[rgraph * **])
> actualfold deltanodes rnfnodes foldarea self foldcont hist rule
> = Absent, if list3=[]
> = Present (mkrule rargs rroot rgraph'',areas'), otherwise
> where rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule
> list2 = map (pairwith (findoccs hist rule)) (nodelist rgraph [rroot]--nodelist rgraph rargs)
> || list2: list combining every node with list of every instantiable history graph
> list3 = [(rnode,hgraph,mapping)|(rnode,(((hroot,hgraph),mapping):rest))<-list2]
> || list3: list combining every instantiable node with first instantiable history graph
> rgraph'
> = foldr foldrec rgraph list3
> where foldrec (rnode,hgraph,mapping) = updategraph rnode (mapsnd (map (lookup mapping)) foldcont)
> (rgraph'',areas') = finishfold foldarea fixednodes singlenodes rroot rgraph'
> fixednodes = intersect (mkset (argnodes++foldednodes++rnfnodes)) (nodelist rgraph' [rroot])
> singlenodes = intersect deltanodes (nodelist rgraph' [rroot])
> argnodes = nodelist rgraph' rargs
> foldednodes = map fst3 list3
actualfold ::
[var]
[var]
((Rgraph sym var)->Node sym var)
(pvar->var->bool)
(sym,[pvar])
[(pvar,Graph sym pvar)]
(Rule sym var)
-> Optional (Rule sym var,[Rgraph sym var])
| == var
& == pvar
actualfold deltanodes rnfnodes foldarea self foldcont hist rule
| isEmpty list3
= No
= Yes (mkrule rargs rroot rgraph``,areas`)
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
list2 = map (pairwith (findoccs hist rule)) (removeMembers (varlist rgraph [rroot]) (varlist rgraph rargs))
// list2: list combining every node with list of every instantiable history graph
list3 = [(rnode,hgraph,mapping) \\ (rnode,[((hroot,hgraph),mapping):_])<-list2]
// list3: list combining every instantiable node with first instantiable history graph
rgraph`
= foldr foldrec rgraph list3
where foldrec (rnode,hgraph,mapping) = updategraph rnode (mapsnd (map (lookup mapping)) foldcont)
(rgraph``,areas`) = finishfold foldarea fixednodes singlenodes rroot rgraph`
fixednodes = intersect (removeDup (argnodes++foldednodes++rnfnodes)) (varlist rgraph` [rroot])
singlenodes = intersect deltanodes (varlist rgraph` [rroot])
argnodes = varlist rgraph` rargs
foldednodes = map fst3 list3
/*
> findoccs
> :: [(***,graph * ***)] ->
> rule * ** ->
......@@ -107,37 +119,67 @@ graph itself. We don't want to fold back something we unfolded earlier!
> = disjoint inner outer
> where inner = map (lookup mapping) (fst (nodeset hgraph [hroot]))
> outer = nodelist (prunegraph rnode rgraph) (rroot:rargs)--[rnode]
*/
findoccs ::
[(pvar,Graph sym pvar)]
(Rule sym var)
var
-> [((pvar,Graph sym pvar),[(pvar,var)])]
| == var
& == pvar
findoccs hist rule rnode
= [ ((hroot,hgraph),mapping)
\\ ((hroot,hgraph),(seen,mapping,[]))<-list1 // Find instantiable history rgraphs...
| unshared rnode (hroot,hgraph) mapping // ...which don't have shared contents
]
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
list1
= [((hroot,hgraph),inst (hroot,hgraph))\\(hroot,hgraph)<-hist]
where inst (hroot,hgraph)
= instantiate (hgraph,rgraph) (hroot,rnode) ([],[],[])
// list1: all instantiation attempts at rnode with the history rgraphs
unshared rnode (hroot,hgraph) mapping
= disjoint inner outer
where inner = map (lookup mapping) (fst (graphvars hgraph [hroot]))
outer = removeMembers (varlist (prunegraph rnode rgraph) [rroot:rargs]) [rnode]
instantiate = undef
/*
------------------------------------------------------------------------
Splitting a rule into areas to fold to a certain area
*/
> splitrule
> :: (rgraph * **->(*,[**])) ->
> [**] ->
> [**] ->
> rule * ** ->
> rgraph * ** ->
> (rule * **,[rgraph * **])
> splitrule fold rnfnodes deltanodes rule area
> = (mkrule rargs rroot rgraph'',area':areas)
> where
> rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule
> aroot = rgraphroot area; agraph = rgraphgraph area
> (rgraph'',areas) = finishfold fold fixednodes deltanodes rroot rgraph'
> fixednodes = intersect (mkset (aroot:nodelist rgraph' rargs++rnfnodes)) (nodelist rgraph' [rroot])
> rgraph' = updategraph aroot (fold area') rgraph
> area' = mkrgraph aroot agraph'
> agraph' = foldr addnode emptygraph ins
> ins = nodelist agraph [aroot]--outs
> outs = nodelist (prunegraph aroot rgraph) (rroot:rargs++snd (nodeset agraph [aroot]))--[aroot]
> addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node))
splitrule ::
((Rgraph sym var)->Node sym var)
[var]
[var]
(Rule sym var)
(Rgraph sym var)
-> (Rule sym var,[Rgraph sym var])
| == var
splitrule fold rnfnodes deltanodes rule area
= (mkrule rargs rroot rgraph``,[area`:areas])
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
aroot = rgraphroot area; agraph = rgraphgraph area
(rgraph``,areas) = finishfold fold fixednodes deltanodes rroot rgraph`
fixednodes = intersect (removeDup [aroot:varlist rgraph` rargs++rnfnodes]) (varlist rgraph` [rroot])
rgraph` = updategraph aroot (fold area`) rgraph
area` = mkrgraph aroot agraph`
agraph` = foldr addnode emptygraph ins
ins = removeMembers (varlist agraph [aroot]) outs
outs = removeMembers (varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]) [aroot]
addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node))
/*
------------------------------------------------------------
......@@ -145,38 +187,36 @@ Splitting a rule into areas to fold to a certain area
by introducing areas for parts of the graph that are not fixed in some
way (e.g. when part of the pattern of the rule, already folded, or
bearing a delta function symbol).
> finishfold
> :: (rgraph * **->(*,[**])) ->
> [**] ->
> [**] ->
> ** ->
> graph * ** ->
> (graph * **,[rgraph * **])
> finishfold foldarea fixednodes singlenodes root graph
> = (graph',areas)
> where graph' = foldr foldarea' graph areas
> foldarea' area = updategraph (rgraphroot area) (foldarea area)
> areas = depthfirst generate process arearoots
> process aroot
> = mkrgraph aroot (foldr addnode emptygraph ins)
> where outs_and_aroot = nodelist (prunegraph aroot graph) arearoots++fixednodes
> ins = aroot:nodelist graph [aroot]--outs_and_aroot
> generate area
> = snd (nodeset agraph [aroot])--fixednodes
> where aroot = rgraphroot area; agraph = rgraphgraph area
> arearoots = mkset (root:singlenodes++singfixargs)--fixednodes
> singfixargs = concat (map arguments (singlenodes++fixednodes))
> arguments node
> = args, if def
> = [], otherwise
> where (def,(sym,args)) = dnc (const "in finishfold/1") graph node
> addnode node
> = updategraph node cnt, if def
> = id, otherwise
> where (def,cnt) = dnc (const "in finishfold/2") graph node
*/
finishfold ::
((Rgraph sym var)->Node sym var)
[var]
[var]
var
(Graph sym var)
-> (Graph sym var,[Rgraph sym var])
| == var
finishfold foldarea fixednodes singlenodes root graph
= (graph`,areas)
where graph` = foldr foldarea` graph areas
foldarea` area = updategraph (rgraphroot area) (foldarea area)
areas = depthfirst generate process arearoots
process aroot
= mkrgraph aroot (foldr addnode emptygraph ins)
where outs_and_aroot = varlist (prunegraph aroot graph) arearoots++fixednodes
ins = [aroot:removeMembers (varlist graph [aroot]) outs_and_aroot]
generate area
= removeMembers (snd (graphvars agraph [aroot])) fixednodes
where aroot = rgraphroot area; agraph = rgraphgraph area
arearoots = removeMembers (removeDup [root:singlenodes++singfixargs]) fixednodes
singfixargs = flatten (map arguments (singlenodes++fixednodes))
arguments node
= if def args []
where (def,(_,args)) = dnc (const "in finishfold/1") graph node
addnode node
= if def (updategraph node cnt) id
where (def,cnt) = dnc (const "in finishfold/2") graph node
......@@ -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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment