diff options
author | johnvg | 2011-05-10 13:45:26 +0000 |
---|---|---|
committer | johnvg | 2011-05-10 13:45:26 +0000 |
commit | 851602809c397be0fa3bde9ed89eca0a9ebdd927 (patch) | |
tree | c2dd6a8facb349d1c78de019bc2d19822998f0b7 /sucl/newtest.icl | |
parent | delete portToNewSyntax (diff) |
delete sucl, the same files can be found in the branch sucl
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1940 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
Diffstat (limited to 'sucl/newtest.icl')
-rw-r--r-- | sucl/newtest.icl | 568 |
1 files changed, 0 insertions, 568 deletions
diff --git a/sucl/newtest.icl b/sucl/newtest.icl deleted file mode 100644 index f7e2787..0000000 --- a/sucl/newtest.icl +++ /dev/null @@ -1,568 +0,0 @@ -implementation module newtest - -// $Id$ - -import cli -import coreclean -import newfold -import complete -import trd -import loop -import trace -import rule -import graph -import canon -import basic -import general -import StdEnv - -/* - -newtest.lit - Testing the new trace implementation -================================================== - -Description ------------ - -Describe in a few paragraphs what this module defines. - ------------------------------------------------------------- - -Interface ---------- - -Exported identifiers: - -> %export -> all || List of all clasp modules -> list || List a clean module -> listopt || List rules with introduction -> listfull || List full processing of optimization ->|| listtrace || List the trace for a clean module -> optfiles || Optimize files obeying a pattern -> optimize || Optimize a clean module - -Required types: - - identifier - type@source.lit type@source.lit - ... - ------------------------------------------------------------- - -Includes --------- - -> %include "dnc.lit" - -> %include "../src/basic.lit" -> %include "../src/hunt.lit" -> %include "../src/pfun.lit" -> %include "../src/graph.lit" -> %include "../src/rule.lit" -> %include "../src/trd.lit" -> %include "../src/spine.lit" -> %include "strat.lit" -> %include "trace.lit" -> %include "loop.lit" -> %include "../src/clean.lit" -> %include "../src/module.lit" -> %include "cli.lit" -> %include "../src/complete.lit" ->|| %include "fold.lit" -> %include "newfold.lit" -> %include "../src/canon.lit" - ------------------------------------------------------------- - -Implementation --------------- - ------------------------------------------------------------------------- - -> optfiles :: [char] -> [sys_message] -> optfiles -> = optimize.foldr addmodule [].glob.join ' '.expand [".cli"] (getpath ["."] "CLIPATH") - -> addmodule filename modules -> = subcli scont filename -> where subcli success ".cli" = success "" -> subcli success ('/':cs) = subcli scont cs -> subcli success (c:cs) = subcli (success.(c:)) cs -> subcli success cs = modules -> scont = (:modules) - -> all = (foldr addmodule [].glob.join ' '.expand [".cli"] (getpath ["."] "CLIPATH")) "*" - -> optimize :: [[char]] -> [sys_message] - -> optimize modules -> = complaints++loads++concat (map optone goodnames)++[Stdout "Done.\n",Exit (#complaints)] -> where allnames = [(module,findfiles readable [".cli"] (getpath ["."] "CLIPATH") module)|module<-modules] -> badnames = [module|(module,[])<-allnames] -> goodnames = [(module,cliname,init cliname++"o")|(module,cliname:clinames)<-allnames] -> complaints -> = [], if badnames=[] -> = [Stderr ("Warning: cannot find module"++showmodules badnames++" (ignored).\n")], otherwise -> where showmodules [module] -> = ": "++showstring module -> showmodules modules -> = "s: "++join ',' (map showstring modules) -> loads -> = [], if goodnames=[] -> = [Stdout ("Loaded modules: "++join ',' [module|(module,cli,clo)<-goodnames]++".\n")], otherwise -> cli = loadclis (map snd3 goodnames) -> optone (module,cliname,cloname) -> = [ Stdout ("Optimizing "++module++" ("++showstring cliname++") to "++show cloname++"..."), -> Tofile cloname (listnew module cli), -> Stdout "\n" -> ] - ------------------------------------------------------------------------- - -`Newfunction' is the type of a new function produced by symbolic -reduction applied to a cli module. Symbolic reduction on a cli module -actually produces a list of new functions. - -> newfunction * ** **** ***** -> == ( *, || Assigned symbol of the new function -> rule * **, || Initial rule of the new function -> [bool], || Strictness annotations -> rule **** *****, || Type rule -> bool, || Export annotation -> [rule * **], || Rewrite rules -> bool || Import annotation -> ) - -`Symredresult' is the output produced by symbolic reduction applied to -an area. Symbolic reduction on an area actually produces a list of -these tuples. - -> symredresult * ** **** ***** -> == ( rgraph * **, || The initial area in canonical form -> *, || The assigned symbol -> [bool], || Strictness annotations -> rule **** *****, || Type rule -> trace * ** **, || Truncated and folded trace -> [rule * **], || Resulting rewrite rules -> [rgraph * **] || New areas for further symbolic reduction (not necessarily canonical) -> ) -*/ - -:: Symredresult sym var tsym tvar - = { srr_task_expression :: Rgraph sym var // The initial area in canonical form - , srr_assigned_symbol :: sym // The assigned symbol - , srr_strictness :: [Bool] // Strictness annotations - , srr_arity :: Int // Arity - , srr_typerule :: Rule tsym tvar // Type rule - , srr_trace :: Trace sym var var // Truncated and folded trace - , srr_function_def :: FuncDef sym var // Resulting rewrite rules - , srr_areas :: [Rgraph sym var] // New areas for further symbolic reduction (not necessarily canonical) - } - -instance toString (Symredresult sym var tsym tvar) | toString sym & toString var & Eq var -where toString srr - = "Task: "+++toString srr.srr_task_expression+++ - "\nSymbol: "+++toString srr.srr_assigned_symbol+++ - "\nStrictness: "+++listToString srr.srr_strictness+++ - "\nArity: "+++toString srr.srr_arity+++ - "\nTyperule: "+++"<typerule>"+++ - "\nTrace: "+++"<trace>"+++ - "\nFunction definition: "+++"<funcdef>"+++ - "\nAreas: "+++listToString srr.srr_areas+++"\n" - -instance <<< (Symredresult sym var tsym tvar) | toString sym & <<<,==,toString var -where (<<<) file0 srr - = file7 - where file1 - = file0 <<< "==[BEGIN]==" <<< nl - <<< "Task expression: " <<< srr.srr_task_expression <<< nl - <<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl - <<< "Strictness: " <<< srr.srr_strictness <<< nl - //<<< "Type rule: ..." <<< nl - file2 = printtrace srr.srr_assigned_symbol toString toString toString "" srr.srr_trace file1 - file3 = file2 <<< "Function definition:" <<< nl - file4 = printfuncdef toString toString srr.srr_function_def file3 - file5 = file4 <<< "Areas:" <<< nl - file6 = printareas toString toString " " srr.srr_areas file5 - file7 = file6 <<< "==[END]==" <<< nl - -printareas :: (sym->String) (var->String) String [Rgraph sym var] *File -> .File | == var -printareas showsym showvar indent areas file -= foldl (flip (printarea showsym showvar indent)) file areas - -printarea showsym showvar indent area file -= file <<< indent <<< hd (printgraphBy showsym showvar (rgraphgraph area) [rgraphroot area]) <<< nl - -(writeareas) infixl :: *File [Rgraph sym var] -> .File | toString sym & toString,== var -(writeareas) file xs = sfoldl (<<<) file xs - -/* -> listopt :: [char] -> [[char]] -> [char] - -> listopt main = listnew main.loadclis - -> listnew :: [char] -> cli -> [char] - -> listnew main cli = (lay.printnew cli.map (makenew cli).filter hasusersym.fullsymred main.stripexports main) cli - -> printnew -> :: cli -> -> [newfunction symbol node typesymbol typenode] -> -> [[char]] - -> printnew cli results -> = (implementation exports++"MODULE "++modulename++";"): -> prefix [""] (showimports [symbol|(symbol,initialrule,stricts,trule,exported,rules,True)<-results])++ -> showtypes ((map (uncurry cleanalias).aliases) cli) (map (printalgebra (typerule cli)) (constrs cli))++ -> prefix ["","MACRO"] ((concat.map (uncurry cleanmacro).macros) cli)++ -> concat (map (shownewrules cli) [(symbol,initialrule,(trule,stricts),rules)|(symbol,initialrule,stricts,trule,exported,rules,imported)<-results;rules~=[]]) -> where exports = [symbol|(symbol,initialrule,stricts,trule,True,rules,imported)<-results] -> implementation [User module "Start"] = "" -> implementation exports = "IMPLEMENTATION " -> getmodule (User module ident) = module -> modulename = hd (map getmodule exports++["empty"]) - -> showimports symbols -> = map showblock (partition getmodule getident symbols) -> where getmodule (User module ident) = module -> getident (User module ident) = ident -> showblock (module,idents) -> = "FROM "++module++" IMPORT "++join ',' idents++";" - -> showtypes aliastexts algebralines -> = prefix ["","TYPE"] (prefix [""] (concat aliastexts)++prefix [""] algebralines) - -> prefix xs [] = [] -> prefix xs ys = xs++ys - -> shownewrules cli (symbol,initialrule,tinfo,rules) -> = prefix ("":"<<":cleanrule symbol initialrule++[">>","RULE"]) (cleantyperule symbol tinfo:concat (map (cleanrule symbol) rules)) - -> makenew -> :: cli -> -> symredresult symbol node typesymbol typenode -> -> newfunction symbol node typesymbol typenode - -> makenew cli (area,symbol,stricts,trule,Trace initialstricts initialrule answer history results,rules,areas) -> = (symbol,initialrule,stricts,trule,exported,rules',imported) -> where exported = member (exports cli) symbol -> imported = member (imports cli) symbol -> rules' = filter ((~).unchanged) rules -> unchanged rule -> = def & root=initialroot & sym=symbol -> where root = rhs rule; graph = rulegraph rule -> (def,(sym,args')) = dnc (const "in makenew") graph root -> initialroot = rhs initialrule - -> hasusersym -> :: symredresult symbol node typesymbol typenode -> -> bool - -> hasusersym (area,symbol,stricts,trule,trace,rules,areas) = usersym symbol - ------------------------------------------------------------------------- - -> listfull :: [char] -> [[char]] -> [char] -> listfull main filenames -> = (lay.map (showfull cli).fullsymred main) cli -> where cli = stripexports main (loadclis (main:filenames)) - -> showfull -> :: cli -> -> symredresult symbol node typesymbol typenode -> -> [char] - -> showfull cli (area,symbol,stricts,trule,trace,rules,areas) -> = hline++ -> "::: AREA :::\n"++ -> printrgraph showsymbol shownode area++ -> "\n\n::: ASSIGNED SYMBOL :::\n"++ -> showsymbol symbol++ -> "\n\n::: DERIVED TYPE RULE :::\n"++ -> printrule showtypesymbol showtypenode trule++ -> "\n\n::: TRACE :::\n"++ -> lay (printtrace symbol showsymbol shownode shownode trace)++ -> "\n\n::: DERIVED STRICTNESS :::\n"++ -> map strictchar stricts++ -> "\n::: RULES :::\n"++ -> lay (map (((showsymbol symbol++" ")++).printrule showsymbol shownode) rules)++ -> "\n::: NEW AREAS :::\n"++ -> lay (map (printrgraph showsymbol shownode) areas)++ -> hline - -> hline = rep 72 '='++"\n" - -> fullsymred -> :: [char] -> -> cli -> -> [symredresult symbol node typesymbol typenode] - -> fullsymred main cli -> = results -> where results = depthfirst generate process (initareas cli) -> generate result = map canonise' (getareas result) -> process area = symredarea foldarea' cli area - -> foldarea' = foldarea (labelarea'.canonise') -> labelarea' = labelarea (map getinit results) (newsymbols main) -> canonise' = canonise (typerule cli) heap -*/ - -fullsymred :: - [SuclSymbol] // Fresh function symbols - Cli // Module to optimise - -> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable] - -fullsymred freshsymbols cli - = results - where results = depthfirst generate process (initareas cli) - generate result = map canonise` (getareas result) - process area = symredarea foldarea` cli area - - foldarea` = foldarea (labelarea` o canonise`) - labelarea` = labelarea isSuclUserSym (map getinit results) freshsymbols - canonise` = canonise (arity cli) suclheap - -isSuclUserSym (SuclUser _) = True -isSuclUserSym _ = False - -/* -`Initareas cli' is the list of initial rooted graphs that must be -symbolically reduced. An initial rooted graph is formed by applying an -exported symbol to its full complement of open arguments according to -its type rule. - -> initareas :: cli -> [rgraph symbol node] - -> initareas cli -> = map (initialise heap) (exports cli) -> where initialise (root:nodes) symbol -> = mkrgraph root (updategraph root (symbol,args) emptygraph) -> where args = map2 const nodes targs -> targs = lhs (typerule cli symbol) - -> getinit :: symredresult * ** **** ***** -> rgraph * ** -> getinit (area,symbol,stricts,trule,trace,rules,areas) = area - -> 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 srr -= srr.srr_task_expression - -getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var] -getareas srr -= srr.srr_areas - -/* -`Symredarea' is the function that does symbolic reduction of a single -area. - -> symredarea -> :: (rgraph symbol node->(symbol,[node])) -> -> cli -> -> rgraph symbol node -> -> symredresult symbol node typesymbol typenode - -> 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 typeheap (ctyperule FN typeheap (typerule cli)) arule -> trace = loop strategy' complete' matchable' (heap--nodelist agraph [aroot],arule) -> (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace -> 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 -= { srr_task_expression = area - , srr_assigned_symbol = symbol - , srr_strictness = stricts - , srr_arity = length aargs - , srr_typerule = trule - , srr_trace = trace - , srr_function_def = rules - , srr_areas = 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` (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 - ------------------------------------------------------------------------- - -> printelem symbol (result,optsra) -> = ( indent "subtrace: " (printresult symbol showsymbol shownode shownode result)++ -> foldoptional [] printsra optsra -> ) - -> printsra (stricts,rules,areas) -> = ( ("stricts: "++map strictchar stricts): -> indent "rules: " (map (showrule showsymbol shownode) rules)++ -> indent "areas: " (map (showrgraph showsymbol shownode) areas) -> ) - -> printsras (strictss,rules,areas) -> = ( showlist (showstring.map strictchar) strictss: -> indent "rules: " (map (showrule showsymbol shownode) rules)++ -> indent "areas: " (map (showrgraph showsymbol shownode) areas) -> ) - -> trsym (User module "New_ab") = True -> trsym = const False - -> looping :: * -> rule * ** -> bool -> looping symbol rule -> = rdef & rsym=symbol & rargs=args -> where args = lhs rule; root = rhs rule; graph = rulegraph rule -> (rdef,(rsym,rargs)) = dnc (const "in looping") graph root - ------------------------------------------------------------------------- - - listtrace :: [char] -> [[char]] -> [char] - listtrace main = lay.map clitraces.mktraces.stripexports main.loadclis.(main:) - -> clitraces :: (symbol,(trace symbol node node,[rule symbol node])) -> [char] -> clitraces (sym,(trace,rules)) = lay (printtrace sym showsymbol shownode shownode trace) - - mktraces :: cli -> [(symbol,(trace symbol node node,[rule symbol node]))] - mktraces cli - = depthfirst - ( foldr addsymbols []. - snd. - snd - ) - (pairwith clisymred') - (exports cli) - where clisymred' symbol - = clisymred ((~=hd heap).rhs) cli symbol (initrule heap (lhs.typerule cli) symbol) - -> addsymbols :: rule * *** -> [*] -> [*] -> addsymbols rule rest -> = foldr (addsymbol.dnc (const "in addsymbols") rgraph) rest nodes -> where nodes = nodelist rgraph (rroot:lroots) -> rgraph = rulegraph rule -> rroot = rhs rule -> lroots = lhs rule -> addsymbol (def,(sym,args)) = cond def (sym:) id - ------------------------------------------------------------------------- - -> list :: [char] -> [[char]] -> [char] - -> list main = showcli.stripexports main.loadclis.(main:) - ------------------------------------------------------------------------- - - clisymred :: (rule symbol **->bool) -> cli -> symbol -> ([**],rule symbol **) -> (trace symbol ** node,[rule symbol **]) - - clisymred unchanged cli symbol rule - = ( mapsnd (filter unchanged) - . pairwith tips - . onresults (foldtrace symbol) - . loop strategy' complete' matchable' - ) rule - where complete' - = (~).converse matchable' (mkrgraph () emptygraph) - matchable' = matchable (complete cli) - strategy' = clistrategy cli - -> matchable :: ([*]->bool)->[rgraph * ***]->rgraph * **->bool - -> 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 -sym with the given arguments, curried if there are too few. - -> ctyperule -> :: **** -> -> [*****] -> -> (*->rule **** *****) -> -> (*,[**]) -> -> rule **** ***** - -> ctyperule fn typeheap typerule (sym,args) -> = mkrule targs' troot' tgraph' -> where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule -> trule = typerule sym -> (targs',targs'') = claim args targs -> (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) -*/ - -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,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 -*/ |