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

Add several debugging constructs

Fixed bug where varset was too strict and could hang
Fixed bug where the new funcdef array could be too small if functions disappear
parent 0813d733
......@@ -314,4 +314,4 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
= file <<< x writeList xs
= file <<< x <<< nl writeList xs
......@@ -114,9 +114,9 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label rgraph
= ((id (labelrgraph,foldsingleton single nosingle rgraph)) <--- "canon.foldarea ends") ---> "canon.foldarea begins"
where single root sym args = args
nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph])
= (((labelrgraph<---"canon.foldarea.labelrgraph begins")--->"canon.foldarea.labelrgraph ends",(foldsingleton single nosingle rgraph<---"canon.foldarea.foldsingleton ends")--->"canon.foldarea.foldsingleton begins") <--- "canon.foldarea ends") ---> "canon.foldarea begins"
where single root sym args = map (\arg->(arg<---"newfold.foldarea.single.arg begins")--->"newfold.foldarea.single.arg ends") args
nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg begins")--->"newfold.foldarea.nosingle.arg ends") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
......
......@@ -7,6 +7,7 @@ from strat import Strategy
from rule import Rule
from graph import Graph
from StdOverloaded import ==
from StdFile import <<<
// Transitive necessities
......@@ -29,3 +30,5 @@ mkcli ::
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
-> Cli
instance <<< Cli
......@@ -105,7 +105,7 @@ Abstype implementation.
> stripexports :: [char] -> cli -> cli
*/
:: Cli :== Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
:: Cli = CliAlias (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable)
/*
> cli == module symbol node typesymbol typenode
......@@ -121,14 +121,14 @@ Abstype implementation.
*/
exports :: Cli -> [SuclSymbol]
exports m = m.exportedsymbols
exports (CliAlias m) = m.exportedsymbols
/*
> typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
typerule m sym
typerule (CliAlias m) sym
= maxtyperule m.typerules sym
/*
......@@ -153,7 +153,7 @@ typerule m sym
*/
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
clistrategy {arities=as,typeconstructors=tcs,typerules=ts,rules=rs} matchable
clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable
= ( checkarity (extendfn as (typearity o maxtyperule ts)) // Checks curried occurrences and strict arguments
o checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...)
o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
......@@ -182,7 +182,7 @@ maxstricts defs sym = extendfn defs corestricts sym
*/
complete :: Cli -> [SuclSymbol] -> Bool
complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
complete (CliAlias m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/*
> showcli = printcli
......@@ -326,10 +326,20 @@ mkcli ::
-> Cli
mkcli typerules stricts exports constrs bodies
= { arities = map (mapsnd fst) bodies
= CliAlias
{ arities = map (mapsnd fst) bodies
, typeconstructors = constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, rules = map (mapsnd snd) bodies
}
instance <<< Cli
where (<<<) file (CliAlias m)
= file <<< "=== Arities ===" <<< nl
writeList m.arities
<<< "=== Type Rules ===" <<< nl
writeList m.typerules
<<< "=== Rules ===" <<< nl
writeList m.rules
......@@ -440,11 +440,11 @@ stc_funcdefs ::
, .{#FunDef} // Converted function definitions
)
stc_funcdefs stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varheap0 srrs oldfundefs
stc_funcdefs stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varheap0 srrs oldfundefs0
= ((exprheap1,varheap1,new_fundefs)<---"convert.stc_funcdefs ends")--->"convert.stc_funcdefs begins"
where new_fundef_limit = foldr max 0 [gi.glob_object+1\\{srr_assigned_symbol = SuclUser (SK_Function gi)}<-srrs | gi.glob_module==main_dcl_module_n]
where new_fundef_limit = foldr max n_oldfundefs [gi.glob_object+1\\{srr_assigned_symbol = SuclUser (SK_Function gi)}<-srrs | gi.glob_module==main_dcl_module_n]
(exprheap1,varheap1,new_fundefs)
= (store_newfuns--->"convert.store_newfuns begins from stc_funcdefs") stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varheap0 srrs (copy_oldfuns oldfundefs initialarray)
= (store_newfuns--->"convert.store_newfuns begins from stc_funcdefs") stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varheap0 srrs (copy_oldfuns oldfundefs1 initialarray)
initialarray = {nofundef i\\i<-[0..new_fundef_limit-1]}
nofundef funindex
= { fun_symb = noident
......@@ -471,11 +471,15 @@ stc_funcdefs stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varhe
, fi_dynamics = []
, fi_properties = 0
}
(n_oldfundefs,oldfundefs1) = usize oldfundefs0
copy_oldfuns srcfundefs dstfundefs
= ((id (foldlArrayStWithIndex copyone srcfundefs dstfundefs))<---"convert.copy_oldfuns ends")--->"convert.copy_oldfuns begins"
copy_oldfuns srcfundefs0 dstfundefs0
= (foldlArrayStWithIndex copyone srcfundefs1 dstfundefs1<---"convert.copy_oldfuns ends")--->sizes
where copyone i srcfundef dstfundefs
= ({dstfundefs & [i]=srcfundef} <--- ("convert.copy_oldfuns.copyone "+++toString i+++" ends")) ---> ("convert.copy_oldfuns.copyone "+++toString i+++" begins")
(srcsize,srcfundefs1) = usize srcfundefs0
(dstsize,dstfundefs1) = usize dstfundefs0
sizes = "convert.copy_oldfuns begins (#srcfundefs="+++toString srcsize+++" #dstfundefs="+++toString dstsize+++")"
store_newfuns stringtype dcl_mods main_dcl_module_n firstnewindex exprheap0 varheap0 [] fundefs0
= (exprheap0,varheap0,fundefs0)<---"convert.store_newfuns ends (no more srrs)"
......
......@@ -97,20 +97,20 @@ varcontents (GraphAlias pfun) v
graphvars :: .(Graph sym var) !.[var] -> (.[var],.[var]) | == var
graphvars graph roots
= graphvars` [] graph roots
= (graphvars` [] graph roots<---"graph.graphvars ends")--->"graph.graphvars begins"
// Finds bound and free variables in a graph
// Excludes the variables only reachable through "prune"
graphvars` :: .[var] .(Graph sym var) .[var] -> (.[var],.[var]) | == var
graphvars` prune graph roots
= snd (foldlr ns (prune,([],[])) roots)
where ns var (seen,boundfree=:(bound,free))
| isMember var seen = (seen,boundfree)
| not def = ([var:seen],(bound,[var:free]))
= (seen`,([var:bound`],free`))
where (seen`,(bound`,free`)) = foldlr ns ([var:seen],boundfree) args
= (snd (foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`") (prune,([],[])) roots)<---"graph.graphvars` ends")--->"graph.graphvars` begins"
where ns var seenboundfree
| isMember var seen = seenboundfree<---"graph.graphvars`.ns ends (already seen)"
| not def = ([var:seen],(bound,[var:free]))<---"graph.graphvars`.ns ends (open variable)"
= (seen`,([var:bound`],free`))<---"graph.graphvars`.ns ends (closed variable)"
where (seen`,(bound`,free`)) = foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`.ns") ([var:seen],boundfree) args
(def,(_,args)) = varcontents graph var
(seen,boundfree=:(bound,free)) = seenboundfree
varlist :: .(Graph sym var) !.[var] -> .[var] | == var
varlist graph roots
= depthfirst arguments id roots
......
......@@ -9,6 +9,8 @@ from history import HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from graph import Graph
from StdOverloaded import ==
from StdFile import <<<
from StdString import toString
from strat import Substrategy,Subspine // for Strategy
from trace import History,Transformation // for Trace
......@@ -24,6 +26,9 @@ loop
| == sym
& == var
& == pvar
& toString sym // Debugging
& toString var // Debugging
& <<< var // Debugging
initrule
:: ![var]
......
......@@ -11,7 +11,7 @@ import rule
import graph
import pfun
import basic
from general import Yes,No,--->
from general import Yes,No
import StdEnv
/*
......@@ -224,11 +224,14 @@ loop
| == sym
& == var
& == pvar
& toString sym // Debugging
& toString var // Debugging
& <<< var // Debugging
loop strategy matchable (initheap,rule)
= maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
where maketrace history failinfo instdone stricts sroot subject heap
= result
where result = maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
maketrace history failinfo instdone stricts sroot subject heap
= Trace stricts (mkrule sargs sroot subject) answer history transf
where answer = makernfstrategy history (strategy matchable`) rnfnodes sroot subject
transf = transform sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
......
......@@ -39,5 +39,8 @@ fullfold ::
| == sym
& == var
& == pvar
& toString var
& <<< var
& toString sym
instance <<< FuncBody sym var | toString sym & ==,toString var
......@@ -110,6 +110,9 @@ fullfold ::
| == sym
& == var
& == pvar
& toString var
& <<< var
& toString sym
fullfold trc foldarea fnsymbol trace
| recursive ---> "newfold.fullfold begins"
......@@ -137,30 +140,36 @@ recurse ::
| == sym
& == var
& == pvar
& toString var
& <<< var
& toString sym
recurse foldarea fnsymbol
= (f ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
where f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,newhist`) trace
= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
where f newhisthist trace
| (trace--->trace) $ False
= error "shouldn't happen"
f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
| (isEmpty (pclosed--->"pclosed for isEmpty")--->"f: Reduce: isEmpty?") && (superset (popen--->"popen for superset") (ropen--->"ropen for superset")--->"f: Reduce: superset?")
= ((f--->"newfold.recurse.f begins (from Reduce)") (newhist`,newhist`) trace <--- "newfold.recurse.f ends (valid Reduce)") ---> "f: Reduce"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(pclosed,popen) = graphvars (rgraph--->"rgraph for (pclosed,popen)") (rargs--->"rargs for (pclosed,popen)") ---> "get (pclosed,popen)"
(_,ropen) = graphvars (rgraph--->"rgraph for ropen") [rroot--->"rroot for ropen"] ---> "get ropen"
newhist` = [(rroot,rgraph):newhist--->"newhist"]
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
f newhisthist (Trace stricts rule answer history (Annotate trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,hist) trace
= ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
(pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)"
(_,ropen) = graphvars rgraph [rroot] ---> "get ropen"
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
f newhisthist (Trace stricts rule answer history transf)
= foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf)
= ((foldtips--->"newfold.foldtips begins from newfold.recurse") foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) <--- "newfold.recurse.f ends (other transformation)") ---> "f: default"
where rroot = ruleroot rule; rgraph = rulegraph rule
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
/*
......@@ -182,26 +191,26 @@ foldtips ::
& == pvar
foldtips foldarea foldcont
= ft
= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends"
where ft hist trace
= case transf
of Stop
-> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule)
-> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)"
where deltanodes = foldoptional [] getdeltanodes answer
rnfnodes = foldoptional [ruleroot rule] (const []) answer
Instantiate yestrace notrace
-> ft` (ft hist yestrace) (ft hist notrace)
where ft` (False,yessra) (False,nosra) = exres
-> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.match") hist yestrace) ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.fail") hist notrace)
where ft` (False,yessra) (False,nosra) = exres <--- "newfold.foldtips.ft ends (Instantiate/no)"
ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
= (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas))
= (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)"
Reduce reductroot trace
-> ft` (ft (fst hist,fst hist) trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
-> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Reduce") (fst hist,fst hist) trace)
where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Reduce/no)"
ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)"
Annotate trace
-> ft` (ft hist trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
-> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Annotate") hist trace)
where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Annotate/no)"
ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)"
where (Trace stricts rule answer _ transf) = trace
exres = (False,newextract noetrc foldarea trace)
......
......@@ -174,9 +174,10 @@ where (<<<) file srr
<<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl
<<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
<<< "Strictness: " <<< srr.srr_strictness <<< nl
<<< "Type rule: ..." <<< nl
//<<< "Type rule: ..." <<< nl
<<< srr.srr_trace <<< nl
//<<< "Function definition: ..." <<< nl
//<<< "Function definition:" <<< nl
//<<< srr.srr_function_def
<<< "Areas:" <<< nl
writeareas srr.srr_areas
<<< "==[END]==" <<< nl
......@@ -307,7 +308,7 @@ fullsymred freshsymbols cli
generate result = (map canonise` (getareas result) <--- "newtest.fullsymred.generate begins") ---> "newtest.fullsymred.generate begins"
process area = (symredarea foldarea` cli area <--- "newtest.fullsymred.process ends") ---> "newtest.fullsymred.process begins"
foldarea` = ((id (foldarea (labelarea` o canonise`))) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
labelarea` = (labelarea (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins"
canonise` = (canonise (typerule cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins"
......
......@@ -29,32 +29,33 @@ supercompile ::
)
supercompile dcl_mods main_dcl_module_n fun_defs0 var_heap expression_heap predefs0 logfile0
# logfile = stderr
// Determine defined functions
# (sucl_typerules,sucl_stricts,sucl_bodies,sucl_kinds,fun_defs1) = cts_function main_dcl_module_n fun_defs0
// Determine exported functions
# (predefs1,sucl_exports) = cts_exports dcl_mods predefs0 main_dcl_module_n
// Get constructor lists of algebraic types
# sucl_constrs = cts_getconstrs dcl_mods
// Build abstract CLI module
# sucl_module = mkcli sucl_typerules sucl_stricts sucl_exports sucl_constrs sucl_bodies
// Generate fresh function symbols
# (n_fun_defs,fun_defs3) = usize fun_defs1
# fresh_symbols = [SuclUser (SK_Function (mkglobal main_dcl_module_n i)) \\ i<-[n_fun_defs..]]
// Do the job!
# logfile = logfile <<< "Start fullsymred." <<< nl
# symredresults = fullsymred fresh_symbols sucl_module
# logfile = sfoldl (<<<) (logfile<<<"All symredresults." <<< nl) symredresults
# n_symredresults = length symredresults
# logfile = logfile <<< "Number of generated functions: " <<< n_symredresults <<< nl
// Create and fill new fundef array
# (pds,predefs2) = predefs1![PD_StringType]
# (expression_heap`,var_heap`,fundefs4) = stc_funcdefs pds dcl_mods main_dcl_module_n n_fun_defs expression_heap var_heap symredresults fun_defs3
// Determine which were the newly generated functions
# (newlimit,fundefs5) = usize fundefs4
# generated_range = {ir_from=n_fun_defs,ir_to=newlimit}
# logfile = logfile <<< "New functions from " <<< n_fun_defs <<< " to " <<< newlimit <<< " (not included)" <<< nl
# logfile = logfile <<< "Remaining " <<< (n_symredresults-(newlimit-n_fun_defs)) <<< " should be exported" <<< nl
# logfile = stderr
// Determine defined functions
# (sucl_typerules,sucl_stricts,sucl_bodies,sucl_kinds,fun_defs1) = cts_function main_dcl_module_n fun_defs0
// Determine exported functions
# (predefs1,sucl_exports) = cts_exports dcl_mods predefs0 main_dcl_module_n
// Get constructor lists of algebraic types
# sucl_constrs = cts_getconstrs dcl_mods
// Build abstract CLI module
# sucl_module = mkcli sucl_typerules sucl_stricts sucl_exports sucl_constrs sucl_bodies
#! logfile = logfile <<< sucl_module
// Generate fresh function symbols
# (n_fun_defs,fun_defs3) = usize fun_defs1
# fresh_symbols = [SuclUser (SK_Function (mkglobal main_dcl_module_n i)) \\ i<-[n_fun_defs..]]
// Do the job!
# logfile = logfile <<< "Start fullsymred." <<< nl
# symredresults = fullsymred fresh_symbols sucl_module
# logfile = sfoldl (<<<) (logfile<<<"All symredresults." <<< nl) symredresults
# n_symredresults = length symredresults
# logfile = logfile <<< "Number of generated functions: " <<< n_symredresults <<< nl
// Create and fill new fundef array
# (pds,predefs2) = predefs1![PD_StringType]
# (expression_heap`,var_heap`,fundefs4) = stc_funcdefs pds dcl_mods main_dcl_module_n n_fun_defs expression_heap var_heap symredresults fun_defs3
// Determine which were the newly generated functions
# (newlimit,fundefs5) = usize fundefs4
# generated_range = {ir_from=n_fun_defs,ir_to=newlimit}
# logfile = logfile <<< "New functions from " <<< n_fun_defs <<< " to " <<< newlimit <<< " (not included)" <<< nl
# logfile = logfile <<< "Remaining " <<< (n_symredresults-(newlimit-n_fun_defs)) <<< " should be exported" <<< nl
= logfile $ (fundefs5,var_heap`,expression_heap`,generated_range,predefs2,logfile0)
mkglobal gmod gob = {glob_module = gmod, glob_object = gob}
......
Markdown is supported
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