diff options
| -rw-r--r-- | sucl/Makefile | 22 | ||||
| -rw-r--r-- | sucl/cli.icl | 35 | ||||
| -rw-r--r-- | sucl/history.icl | 1 | ||||
| -rw-r--r-- | sucl/law.icl | 2 | ||||
| -rw-r--r-- | sucl/loop.dcl | 6 | ||||
| -rw-r--r-- | sucl/loop.icl | 8 | ||||
| -rw-r--r-- | sucl/newfold.icl | 29 | ||||
| -rw-r--r-- | sucl/newtest.icl | 100 | ||||
| -rw-r--r-- | sucl/strat.dcl | 2 | ||||
| -rw-r--r-- | sucl/strat.icl | 4 | ||||
| -rw-r--r-- | sucl/trace.dcl | 5 | ||||
| -rw-r--r-- | sucl/trace.icl | 2 |
12 files changed, 184 insertions, 32 deletions
diff --git a/sucl/Makefile b/sucl/Makefile index 7732f75..79dd004 100644 --- a/sucl/Makefile +++ b/sucl/Makefile @@ -27,17 +27,21 @@ $(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)/cli.abc: cli.icl cli.dcl absmodule.dcl coreclean.dcl law.dcl strat.dcl rule.dcl basic.dcl -$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl -$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl dnc.dcl basic.dcl -$(SYS)/loop.abc: loop.icl loop.dcl trace.dcl strat.dcl history.dcl rule.dcl graph.dcl basic.dcl -$(SYS)/strat.abc: strat.icl strat.dcl history.dcl spine.dcl dnc.dcl rule.dcl graph.dcl pfun.dcl basic.dcl -$(SYS)/history.abc: history.icl history.dcl spine.dcl rule.dcl graph.dcl basic.dcl -$(SYS)/spine.abc: spine.icl spine.dcl rule.dcl pfun.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)/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 +$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl basic.dcl +$(SYS)/loop.abc: loop.icl loop.dcl strat.dcl trace.dcl spine.dcl history.dcl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl +$(SYS)/strat.abc: strat.icl strat.dcl spine.dcl history.dcl rule.dcl dnc.dcl graph.dcl pfun.dcl basic.dcl $(SYS)/absmodule.abc: absmodule.icl absmodule.dcl rule.dcl -$(SYS)/trace.abc: trace.icl trace.dcl rule.dcl +$(SYS)/trace.abc: trace.icl trace.dcl spine.dcl history.dcl rule.dcl basic.dcl +$(SYS)/spine.abc: spine.icl spine.dcl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl +$(SYS)/history.abc: history.icl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl $(SYS)/complete.abc: complete.icl complete.dcl graph.dcl -$(SYS)/rewr.abc: rewr.icl rewr.dcl graph.dcl pfun.dcl basic.dcl +$(SYS)/rewr.abc: rewr.icl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl $(SYS)/trd.abc: trd.icl trd.dcl rule.dcl graph.dcl basic.dcl $(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl $(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl diff --git a/sucl/cli.icl b/sucl/cli.icl index 5ce09a6..0f2d2c9 100644 --- a/sucl/cli.icl +++ b/sucl/cli.icl @@ -2,11 +2,12 @@ implementation module cli // $Id$ -import absmodule -import coreclean import law +import coreclean import strat +import absmodule import rule +import dnc import basic import StdEnv @@ -117,12 +118,18 @@ Abstype implementation. > stripexports main (tdefs,(es,as,ts,rs)) = (tdefs,([User m i|User m i<-es;m=main],as,ts,rs)) > exports (tdefs,(es,as,ts,rs)) = es +*/ + +exports :: Cli -> [SuclSymbol] +exports m = m.exportedsymbols +/* > typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts */ typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable -typerule _ _ = undef +typerule m sym += fst (maxtypeinfo m.typerules sym) /* > rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs @@ -166,7 +173,12 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym > constrs ((tes,tas,tcs),defs) = tcs > complete ((tes,tas,tcs),(es,as,ts,rs)) = mkclicomplete tcs (fst.maxtypeinfo ts) +*/ + +complete :: Cli -> [SuclSymbol] -> Bool +complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules) +/* > showcli = printcli > mkclicomplete @@ -181,7 +193,24 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym > = foldmap superset (corecomplete tsym) tcs tsym syms, otherwise > where trule = typerule (hd syms) > (tdef,(tsym,targs)) = dnc (const "in mkclicomplete") (rulegraph trule) (rhs trule) +*/ + +mkclicomplete :: + [(SuclTypeSymbol,[SuclSymbol])] + (SuclSymbol->Rule SuclTypeSymbol tvar) + [SuclSymbol] + -> Bool + | == tvar + +mkclicomplete tcs typerule [] = False +mkclicomplete tcs typerule syms +| not tdef + = False += foldmap superset (corecomplete tsym) tcs tsym syms + where trule = typerule (hd syms) + (tdef,(tsym,_)) = dnc (const "in mkclicomplete") (rulegraph trule) (ruleroot trule) +/* ------------------------------------------------------------------------ > printcli :: module symbol node typesymbol typenode -> [char] diff --git a/sucl/history.icl b/sucl/history.icl index 4ece980..a8d7c66 100644 --- a/sucl/history.icl +++ b/sucl/history.icl @@ -2,7 +2,6 @@ implementation module history // $Id$ -import spine import rule import graph import pfun diff --git a/sucl/law.icl b/sucl/law.icl index 1f14ee4..8ec781a 100644 --- a/sucl/law.icl +++ b/sucl/law.icl @@ -6,8 +6,8 @@ import coreclean import strat import spine import rule -import graph import dnc +import graph import basic import StdEnv diff --git a/sucl/loop.dcl b/sucl/loop.dcl index 2fcbe3f..d49c0d4 100644 --- a/sucl/loop.dcl +++ b/sucl/loop.dcl @@ -3,18 +3,18 @@ definition module loop // $Id$ from strat import Strategy -from spine import Answer from trace import Trace +from spine import Answer from history import HistoryAssociation,HistoryPattern from rule import Rgraph,Rule from graph import Graph from StdOverloaded import == from strat import Substrategy,Subspine // for Strategy +from trace import History,Transformation // for Trace +from spine import Spine // for Answer from graph import Node // for Strategy from basic import Optional // for Answer -from spine import Spine // for Answer -from trace import History,Transformation // for Trace loop :: (((Graph sym pvar) pvar var -> ub:Bool) -> Strategy sym var pvar (Answer sym var pvar)) diff --git a/sucl/loop.icl b/sucl/loop.icl index 85d1233..ef750e5 100644 --- a/sucl/loop.icl +++ b/sucl/loop.icl @@ -2,10 +2,10 @@ implementation module loop // $Id$ -import trace import strat -import history +import trace import spine +import history import rewr import rule import graph @@ -245,7 +245,9 @@ loop strategy matchable (initheap,rule) sargs = arguments rule; initsroot = ruleroot rule; initsubject = rulegraph rule listselect :: [.Bool] [.elem] -> [.elem] -listselect _ _ = undef +listselect [True:bs] [x:xs] = [x:listselect bs xs] +listselect [False:bs] [x:xs] = listselect bs xs +listselect _ _ = [] initrule :: ![var] diff --git a/sucl/newfold.icl b/sucl/newfold.icl index 6958f4b..31d5a79 100644 --- a/sucl/newfold.icl +++ b/sucl/newfold.icl @@ -2,6 +2,10 @@ implementation module newfold // $Id$ +import trace +import rule +import StdEnv + /* newfold.lit - New folding function @@ -86,8 +90,25 @@ occurs within any subtrace. >|| = mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise > = newextract trc foldarea trace, otherwise > where (recursive,recurseresult) = recurse foldarea fnsymbol trace +*/ + +fullfold :: + (Etracer sym var pvar) + ((Rgraph sym var)->(sym,[var])) + sym + (Trace sym var pvar) + -> ([Bool],[Rule sym var],[Rgraph sym var]) + +fullfold trc foldarea fnsymbol trace +| recursive + = recurseresult += 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, and new areas), obtained by folding the trace. `Recurse' tries to fold @@ -193,7 +214,15 @@ in the supertrace. > rgraph * ** -> > bool -> > bool +*/ +:: Etracer sym var pvar :== + (Trace sym var pvar) + (Rgraph sym var) + Bool + -> Bool + +/* > extract > :: etracer * ** *** -> > (rgraph * **->(*,[**])) -> diff --git a/sucl/newtest.icl b/sucl/newtest.icl index 9b65610..7c9e4bb 100644 --- a/sucl/newtest.icl +++ b/sucl/newtest.icl @@ -4,6 +4,13 @@ implementation module newtest import cli import coreclean +import newfold +import complete +import trd +import loop +import trace +import rule +import graph import canon import basic import StdEnv @@ -138,7 +145,19 @@ these tuples. > [rule * **], || Resulting rewrite rules > [rgraph * **] || New areas for further symbolic reduction (not necessarily canonical) > ) +*/ + +:: Symredresult sym var tsym tvar + :== ( Rgraph sym var // The initial area in canonical form + , sym // The assigned symbol + , [Bool] // Strictness annotations + , Rule tsym tvar // Type rule + , Trace sym var var // Truncated and folded trace + , [Rule sym var] // Resulting rewrite rules + , [Rgraph sym var] // New areas for further symbolic reduction (not necessarily canonical) + ) +/* > listopt :: [char] -> [[char]] -> [char] > listopt main = listnew main.loadclis @@ -253,7 +272,7 @@ these tuples. fullsymred :: [SuclSymbol] // Fresh function symbols Cli // Module to optimise - -> [Symredresult symbol node typesymbol typenode] + -> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable] fullsymred freshsymbols cli = results @@ -265,11 +284,6 @@ fullsymred freshsymbols cli labelarea` = labelarea (map getinit results) freshsymbols canonise` = canonise (typerule cli) suclheap -initareas = undef -getareas = undef -symredarea = undef -getinit = undef - /* `Initareas cli' is the list of initial rooted graphs that must be symbolically reduced. An initial rooted graph is formed by applying an @@ -290,7 +304,23 @@ its type rule. > getareas :: symredresult * ** **** ***** -> [rgraph * **] > getareas (area,symbol,stricts,trule,trace,rules,areas) = areas +*/ + +initareas :: Cli -> [Rgraph SuclSymbol SuclVariable] +initareas cli += map (initialise suclheap) (exports cli) + where initialise [root:nodes] symbol + = mkrgraph root (updategraph root (symbol,args) emptygraph) + where args = map2 const nodes targs + targs = arguments (typerule cli symbol) +getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var +getinit (area,symbol,stricts,trule,trace,rules,areas) = area + +getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var] +getareas (area,symbol,stricts,trule,trace,rules,areas) = areas + +/* `Symredarea' is the function that does symbolic reduction of a single area. @@ -311,13 +341,38 @@ area. > complete' = (~).converse matchable' (mkrgraph () emptygraph) > matchable' = matchable (complete cli) > strategy' = clistrategy cli +*/ + +:: Unit = Unit + +symredarea :: + ((Rgraph SuclSymbol SuclVariable)->(SuclSymbol,[SuclVariable])) + Cli + (Rgraph SuclSymbol SuclVariable) + -> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable + +symredarea foldarea cli area += (area,symbol,stricts,trule,trace,rules,areas) + where agraph = rgraphgraph area; aroot = rgraphroot area + (symbol,aargs) = foldarea area + arule = mkrule aargs aroot agraph + trule = ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule + trace = loop strategy` matchable` (removeMembers suclheap (varlist agraph [aroot]),arule) + (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace + matchable` = matchable (complete cli) + strategy` = clistrategy cli +/* > trc :: symbol -> trace symbol node node -> rgraph symbol node -> bool -> bool > trc symbol trace area recursive > = error (lay ("Trace is recursive in area":printrgraph showsymbol shownode area:printtrace symbol showsymbol shownode shownode trace)), if esymbol symbol & recursive > = recursive, otherwise +*/ + +trc symbol trace area recursive = recursive +/* > esymbol (User m "E") = True > esymbol symbol = False @@ -403,7 +458,20 @@ area. > matchable complete patterns rgraph > = ~coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern])|pattern<-patterns] [rgraphroot rgraph] +*/ + +matchable :: + ([sym]->Bool) + [Rgraph sym pvar] + (Rgraph sym var) + -> Bool + | == sym + & == var + & == pvar +matchable complete patterns rgraph += not (coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern]) \\ pattern<-patterns] [rgraphroot rgraph]) +/* ------------------------------------------------------------------------ `Ctyperule' cli (sym,args)' is the typerule of an occurrence of symbol @@ -424,7 +492,25 @@ sym with the given arguments, curried if there are too few. > (troot',tgraph',theap') = foldr build (troot,tgraph,typeheap--nodelist tgraph (troot:targs)) targs'' > build targ (troot,tgraph,tnode:tnodes) > = (tnode,updategraph tnode (fn,[targ,troot]) tgraph,tnodes) +*/ -> newsymbols main = map (User main.("New_"++)) identifiers +ctyperule :: + (Int -> tsym) // The arrow type symbol for functions of given arity + [tvar] // Fresh type variables + (sym->Rule tsym tvar) // Type rule of a symbol + (sym,[var]) // Node to abstract + -> Rule tsym tvar + | == tvar + +ctyperule fn typeheap typerule (sym,args) += mkrule targs` troot` tgraph` + where targs = arguments trule; troot = ruleroot trule; tgraph = rulegraph trule + trule = typerule sym + (targs`,targs``) = claim args targs + (troot`,tgraph`,_) = foldr build (troot,tgraph,removeMembers typeheap (varlist tgraph [troot:targs])) targs`` + build targ (troot,tgraph,[tnode:tnodes]) + = (tnode,updategraph tnode (fn 1,[targ,troot]) tgraph,tnodes) +/* +> newsymbols main = map (User main.("New_"++)) identifiers */ diff --git a/sucl/strat.dcl b/sucl/strat.dcl index 01589e0..1123a78 100644 --- a/sucl/strat.dcl +++ b/sucl/strat.dcl @@ -2,8 +2,8 @@ definition module strat // $Id$ -from history import History from spine import Answer +from history import History from rule import Rule from graph import Graph,Node from StdOverloaded import == diff --git a/sucl/strat.icl b/sucl/strat.icl index 0f938b8..04ea9f9 100644 --- a/sucl/strat.icl +++ b/sucl/strat.icl @@ -2,10 +2,10 @@ implementation module strat // $Id$ -import history import spine -import dnc +import history import rule +import dnc import graph import pfun import basic diff --git a/sucl/trace.dcl b/sucl/trace.dcl index f8e884d..6aafc88 100644 --- a/sucl/trace.dcl +++ b/sucl/trace.dcl @@ -2,9 +2,12 @@ definition module trace // $Id$ -from history import History,HistoryAssociation,HistoryPattern from spine import Answer +from history import History,HistoryAssociation,HistoryPattern from rule import Rule + +// Transitive necessities + from spine import Spine,Subspine // for Answer from rule import Rgraph // for History from basic import Optional // for Answer diff --git a/sucl/trace.icl b/sucl/trace.icl index 7429566..f2ff7b3 100644 --- a/sucl/trace.icl +++ b/sucl/trace.icl @@ -2,8 +2,8 @@ implementation module trace // $Id$ -import history import spine +import history import rule import StdEnv |