Commit 64ea0a45 authored by Vincent Zweije's avatar Vincent Zweije
Browse files

Bugfix: add current node to spine nodes when checking history

Add lots of debugging code
Changes to make partly Clean-2.0 compilable
parent e83bec5e
This diff is collapsed.
......@@ -227,7 +227,7 @@ frontEndInterface opts mod_ident dcl_modules functions_and_macros predef_symbols
# heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps}
// (components, fun_defs, error) = showTypes components 0 fun_defs error
// (dcl_mods, out) = showDclModules dcl_mods out
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
(components, fun_defs, out) = showComponents components 0 False fun_defs out
#! fe ={ fe_icl =
// {icl_mod & icl_functions=fun_defs }
......@@ -392,10 +392,10 @@ do_fusion fusionstyle main_dcl_module_n common_defs imported_funs dcl_types used
= transformGroups cleanup_info main_dcl_module_n (components -*-> "Transform") fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics type_def_infos var_heap type_heaps expression_heap
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out, files)
FS_online
# (opened,logfile,files) = fopen "C:\Vincent\Sucl\supercom.log" FWriteText files
# (opened,logfile,files) = fopen "C:\\Vincent\\Sucl\\supercom.log" FWriteText files
| not opened
-> abort "Could not open supercompilation log file"
# (fun_defs,var_heap,expression_heap,supercompile_range,predef_symbols,logfile) = supercompile dcl_mods main_dcl_module_n (fun_defs -*-> "Supercompile") var_heap expression_heap predef_symbols logfile
# (fun_defs,var_heap,expression_heap,supercompile_range,predef_symbols,logfile) = supercompile dcl_mods main_dcl_module_n icl_common (fun_defs -*-> "Supercompile") var_heap expression_heap predef_symbols logfile
# (closed,files) = fclose logfile files
| not closed
-> abort "Could not close supercompilation log file"
......
......@@ -1709,7 +1709,7 @@ where
where
r2={r1 & [s]=el}
r1={r0 & [i]=array.[i] \\ i<-[0..s-1]}
r0 = _createArray (s+1)
r0 = undef // _createArray (s+1)
s = size array
0.2*/
copy_array array = {x \\ x <-: array}
......@@ -2118,8 +2118,8 @@ where
# (alts, free_vars, gs) = build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs
= ([alt:alts], fvs ++ free_vars, gs)
build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState
-> (AlgebraicPattern, [FreeVar], !*GenericState)
// build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState
// -> (AlgebraicPattern, [FreeVar], !*GenericState)
build_alt
i n type_def_mod def_symbol=:{ds_ident, ds_arity} cons_info
gs=:{gs_heaps, gs_predefs, gs_main_dcl_module_n}
......@@ -2240,8 +2240,8 @@ where
# vars = [var : left_vars ++ right_vars]
= (case_expr, vars, heaps)
build_cons_app :: !Index !DefinedSymbol !*Heaps
-> (!Expression, [FreeVar], !*Heaps)
// build_cons_app :: !Index !DefinedSymbol !*Heaps
// -> (!Expression, [FreeVar], !*Heaps)
build_cons_app cons_mod def_symbol=:{ds_arity} heaps
# names = ["x" +++ toString k \\ k <- [1..ds_arity]]
# (var_exprs, vars, heaps) = buildVarExprs names heaps
......@@ -2308,8 +2308,8 @@ where
# (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs
= ([alt:alts], fvs ++ free_vars, gs)
build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState
-> (AlgebraicPattern, [FreeVar], !*GenericState)
// build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState
// -> (AlgebraicPattern, [FreeVar], !*GenericState)
build_alt
iso_dir i n type_def_mod def_symbol=:{ds_ident, ds_arity, ds_index}
fun_arg_vars type_def gs=:{gs_heaps, gs_modules}
......@@ -2329,8 +2329,8 @@ where
}
= (alg_pattern, cons_arg_vars, {gs & gs_heaps = gs_heaps})
build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState
-> ([!Expression], !*GenericState)
// build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState
// -> ([!Expression], !*GenericState)
build_cons_args iso_dir [] [] fun_arg_vars type_def gs = ([], gs)
build_cons_args iso_dir [arg_type:arg_types] [cons_arg_var:cons_arg_vars] fun_arg_vars type_def gs
# (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs
......@@ -2403,8 +2403,8 @@ where
# (tv, heaps) = buildTypeVar name heaps
= (makeAType (TV tv) (TA_Var av), heaps)
buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState
-> (!FunDef, !*GenericState)
//buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState
// -> (!FunDef, !*GenericState)
buildIsomapForTypeDef
fun_def_sym group_index type_def_mod
type_def=:{td_name, td_index, td_arity, td_pos}
......@@ -2497,8 +2497,8 @@ where
# (var_expr, gs_heaps) = buildExprForTypeVar type_var arg_type_vars arg_vars gs_predefs gs_heaps
= (var_expr, {gs & gs_heaps = gs_heaps})
buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState
-> (!FunDef, !*GenericState)
//buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState
// -> (!FunDef, !*GenericState)
buildInstance
def_sym group_index
instance_def=:{ins_type, ins_generic, ins_pos, ins_ident}
......@@ -2676,8 +2676,8 @@ where
= find_in_array (inc index) array el
buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState
-> (!FunDef, !*GenericState)
//buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState
// -> (!FunDef, !*GenericState)
buildKindConstInstance
def_sym group_index
generic_module generic_def_sym kind=:(KindArrow kinds)
......@@ -3225,7 +3225,7 @@ buildVarExpr name heaps=:{hp_var_heap, hp_expression_heap}
# heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }
= (var, fv, heaps)
buildVarExprs :: ![String] !*Heaps -> (![Expression], [!FreeVar], !*Heaps)
//buildVarExprs :: ![String] !*Heaps -> (![Expression], [!FreeVar], !*Heaps)
buildVarExprs [] heaps = ([], [], heaps)
buildVarExprs [name:names] heaps
# (expr, var, heaps) = buildVarExpr name heaps
......
......@@ -6,7 +6,7 @@ COCL = cocl
#COCLFLAGS = -lat
SYS = Clean\ System\ Files
MODULES = basic pretty pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
MODULES = cleanversion basic pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
ABC = $(patsubst %,$(SYS)/%.abc,$(MODULES))
......@@ -47,5 +47,6 @@ $(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl
$(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
$(SYS)/graph.abc: graph.icl graph.dcl pfun.dcl basic.dcl
$(SYS)/pfun.abc: pfun.icl pfun.dcl basic.dcl
$(SYS)/pretty.abc: pretty.icl pretty.dcl
#$(SYS)/pretty.abc: pretty.icl pretty.dcl
$(SYS)/basic.abc: basic.icl basic.dcl
$(SYS)/cleanversion.abc: cleanversion.icl cleanversion.dcl
......@@ -213,5 +213,8 @@ zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
// Sequential evaluation of left and right arguments
($) infixr :: !.a .b -> .b
// List subtraction (lazier than removeMembers)
(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
// Write a list of things, each one terminated by a newline
(writeList) infixl :: !*File [a] -> .File | <<< a
......@@ -299,7 +299,7 @@ stub modulename functionname message
= abort (modulename+++": "+++functionname+++": "+++message)
superset :: .[a] -> .(.[a] -> Bool) | == a
superset set = isEmpty o (removeMembers set)
superset set = isEmpty o ((--) set)
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
......@@ -311,6 +311,14 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
($) infixr :: !.a .b -> .b
($) x y = y
// List subtraction (lazier than removeMembers)
(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
(--) [] ys = []
(--) [x:xs] ys = f maybeeqs
where (noteqs,maybeeqs) = span ((<>)x) ys
f [] = [x:xs--noteqs] // x wasn't in ys
f [y:ys] = xs--(noteqs++ys) // x==y
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
......
......@@ -9,10 +9,10 @@ from StdOverloaded import ==
// Canonises area into task expression
// so equivalent ones can be detected through '==' comparison.
canonise ::
(sym -> Rule tsym tvar) // Get type rule of a symbol (for eta expansion)
[var2] // Heap (nodespace) for consistent relabeling
(Rgraph sym var1) // Input rooted graph
-> Rgraph sym var2 // Canonised rooted graph
(sym -> Int) // Get arity of a symbol (for eta expansion)
[var2] // Heap (nodespace) for consistent relabeling
(Rgraph sym var1) // Input rooted graph
-> Rgraph sym var2 // Canonised rooted graph
| == var1
// Fold an area in a subject graph
......@@ -23,6 +23,7 @@ foldarea ::
| == var
labelarea ::
(sym->Bool) // Whether a function symbol can be reused for a generated function
[Rgraph sym var] // List of areas to be labeled
[sym] // List of symbols to assign to them
(Rgraph sym var) // Rooted graph to label
......
......@@ -59,9 +59,9 @@ steps:
*/
canonise :: (sym -> Rule tsym tvar) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise typerule heap rg
= ((relabel heap o etaexpand typerule o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
canonise :: (sym -> Int) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise arity heap rg
= ((relabel heap o etaexpand arity o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
/*
......@@ -75,7 +75,7 @@ canonise typerule heap rg
splitrg :: (Rgraph sym Int) -> Rgraph sym Int
splitrg rgraph
= foldsingleton single rgraph rgraph
where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (removeMembers localheap [root]))) emptygraph)
where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph)
/*
> uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num
......@@ -89,12 +89,11 @@ splitrg rgraph
> root = rgraphroot rgraph; graph = rgraphgraph rgraph
*/
etaexpand :: (sym->Rule tsym tvar) (Rgraph sym Int) -> Rgraph sym Int
etaexpand typerule rgraph
etaexpand :: (sym->Int) (Rgraph sym Int) -> Rgraph sym Int
etaexpand arity rgraph
= f (nc root)
where f (True,(sym,args))
= mkrgraph root (updategraph root (sym,fst (claim targs (args++(removeMembers localheap (varlist graph [root]))))) graph)
where targs = arguments (typerule sym)
= mkrgraph root (updategraph root (sym,take (arity sym) (args++(localheap--(varlist graph [root])))) graph)
f cont = rgraph
nc = varcontents graph
root = rgraphroot rgraph; graph = rgraphgraph rgraph
......@@ -115,8 +114,8 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label 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]))
where single root sym args = map (\arg->(arg<---"canon.foldarea.single.arg ends")--->"canon.foldarea.single.arg begins") args
nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg ends")--->"newfold.foldarea.nosingle.arg begins") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
......@@ -139,18 +138,18 @@ foldarea label rgraph
> aroot = rgraphroot area; agraph = rgraphgraph area
*/
labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea areas labels rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
labelarea :: (sym->Bool) [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea reusable areas labels rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") reusable ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
where nolabel = abort "canon: labelarea: no label assigned to area"
maketable :: [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable [] _ = [] <--- "canon.maketable ends empty"
maketable [area:areas] labels
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") areas labels`] <--- "canon.maketable ends nonempty"
maketable :: (sym->Bool) [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable _ [] _ = [] <--- "canon.maketable ends empty"
maketable reusable [area:areas] labels
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") reusable areas labels`] <--- "canon.maketable ends nonempty"
where (label,labels`) = getlabel (nc aroot) labels
getlabel (True,(asym,aargs)) labels
| not (or (map (fst o nc) aargs))
| reusable asym && not (or (map (fst o nc) aargs))
= (asym,labels)
getlabel acont [label:labels]
= (label,labels)
......
definition module cleanversion
//1.3
from StdString import String
//3.1
/*2.0
:: String :== {#Char}
0.2*/
implementation module cleanversion
//1.3
from StdString import String
//3.1
/*2.0
:: String :== {#Char}
0.2*/
......@@ -17,6 +17,7 @@ from graph import Node
:: Cli
arity :: Cli SuclSymbol -> Int
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
exports :: Cli -> [SuclSymbol]
complete :: Cli -> [SuclSymbol] -> Bool
......@@ -24,11 +25,11 @@ clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) ->
// Build a cli structure
mkcli ::
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])]
[SuclSymbol]
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)] // Type rules of local and imported functions
[(SuclSymbol,[Bool])] // Strictness information derived from function types
[SuclSymbol] // Exported symbols
[(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])] // (Algebraic) types with their constructors, and the constructors' type info
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))] // Function bodies with their arities and their rules
-> Cli
instance <<< Cli
......@@ -9,6 +9,7 @@ import absmodule
import rule
import dnc
import basic
import general
import StdEnv
/*
......@@ -123,6 +124,11 @@ Abstype implementation.
exports :: Cli -> [SuclSymbol]
exports (CliAlias m) = m.exportedsymbols
// Determine the arity of a core clean symbol
arity :: Cli SuclSymbol -> Int
arity (CliAlias m) sym
= extendfn m.arities (length o arguments o (extendfn m.typerules coretyperule)) sym
/*
> typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/
......@@ -160,8 +166,9 @@ clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) m
o checkimport islocal // Checks for delta symbols
o checkconstr (flip isMember (flatten (map snd tcs))) // Checks for constructors
) (corestrategy matchable) // Checks rules for symbols in the language core (IF, _AP, ...)
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
islocal rsym = True // Symbols in the language core are always completely known
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)// User-defined symbols can be imported, so they're known if we have a list of rules for them
islocal rsym = True // Symbols in the language core (the rest) are always completely known
// This includes lifted case symbols; we lifted them ourselves, after all
typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
typearity ti = length (arguments ti)
......@@ -321,17 +328,17 @@ mkcli ::
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])]
[SuclSymbol]
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
-> Cli
mkcli typerules stricts exports constrs bodies
= CliAlias
{ arities = map (mapsnd fst) bodies
, typeconstructors = constrs
, typeconstructors = map (mapsnd (map fst)) constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, typerules = typerules++flatten ((map (map (mapsnd fst) o snd)) constrs)
, stricts = stricts++flatten ((map (map (mapsnd snd) o snd)) constrs)
, rules = map (mapsnd snd) bodies
}
......
......@@ -9,6 +9,9 @@ from coreclean import SuclTypeSymbol,SuclTypeVariable,SuclSymbol,SuclSymbolKind,
from checksupport import DclModule
from syntax import FunDef,FunType,ExpressionHeap
from predef import PredefinedSymbols,PredefinedSymbol
/*2.0
from StdArray import Array
0.2*/
// Transitively required stuff
from newfold import FuncBody
......@@ -16,7 +19,7 @@ from trace import Trace,Transformation
from spine import Answer,Spine,Subspine
from history import History,HistoryAssociation,HistoryPattern
from rule import Rgraph
from StdString import String
from cleanversion import String
from checksupport import CommonDefs,ConversionTable,Declarations
from syntax import Ident,Priority,FunctionBody,Optional,SymbolType,Position,DefOrImpFunKind,FunInfo,SymbolPtr,TypeVar,AType,AType,TypeContext,AttributeVar,AttrInequality,FunCall,Index,Level,FreeVar,FreeVar,ExprInfoPtr,BITVECT,Ptr,Specials,SymbolTableEntry,TypeVarInfoPtr,TypeAttribute,Annotation,Type,Context,Global,DefinedSymbol,Type,VarInfoPtr,AttrVarInfoPtr,Expression,VarInfoPtr,Ptr,ExprInfo,PtrN,HeapN,PtrN,STE_Kind,TypeVarInfo,VarInfo,AttrVarInfo,CheckedTypeDef,ClassDef,ClassInstance,ConsDef,Declaration,GenericDef,IndexRange,MemberDef,SelectorDef,ATypeVar,DeclarationRecord,GenericClassInfos,GenericType,InstanceType,TypeDef,TypeKind,TypeRhs,GenericClassInfo
from containers import NumberSet
......@@ -44,12 +47,15 @@ cts_exports ::
, [SuclSymbol] // Exported symbols
)
//Cocl to Sucl for (algebraic) type specifications
cts_getconstrs ::
{#DclModule} // Info from used DCL modules
-> [(SuclTypeSymbol,[SuclSymbol])] // List of constructor symbols for each type symbol
{#DclModule} // Info from used DCL modules
Int // Index of current module in DCL module array
CommonDefs // CommonDefs in ICL module (excluding FunDefs)
-> [(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
// List of constructor symbols for each type symbol
//Sucl to Cocl for function bodies
//1.3
stc_funcdefs ::
PredefinedSymbol // Compiler-predefined String symbol
{#.DclModule} // DCL for looking up constructor types
......@@ -64,3 +70,20 @@ stc_funcdefs ::
, .(Heap VarInfo) // Remaining variable space
, .{#FunDef} // Converted function definitions
)
//3.1
/*2.0
stc_funcdefs ::
PredefinedSymbol
{#.DclModule}
Int
Int
*ExpressionHeap
*(Heap VarInfo)
[Symredresult SuclSymbol .SuclVariable a b]
*(c FunDef)
-> ( .ExpressionHeap
, .(Heap VarInfo)
, .{#FunDef}
)
| Array c FunDef
0.2*/
This diff is collapsed.
......@@ -15,7 +15,7 @@ from graph import Graph,Node
from syntax import SymbolPtr,SymbolTableEntry,STE_Kind,Index,Level,Global,TypeSymbProperties,SignClassification,PropClassification,TypeVarInfoPtr,TypeVarInfo,ExprInfo,VarInfo
from general import BITVECT
from Heap import Ptr,PtrN,HeapN
from StdString import String
from cleanversion import String
:: SuclTypeSymbol
= SuclUSER (Global Index) // A user-defined type symbol (index into com_type_def array)
......@@ -28,6 +28,7 @@ from StdString import String
| SuclDYNAMIC
| SuclFILE
| SuclWORLD
| SuclERROR // Type error
:: SuclTypeVariable
= SuclANONYMOUS Int
......@@ -72,6 +73,9 @@ instance <<< SuclSymbolKind
instance toString SuclVariable
instance <<< SuclVariable
instance toString (Ptr a)
instance <<< (Ptr a)
// Get the type rule and strictness of a built in core clean symbol
coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
corestricts :: SuclSymbol -> [Bool]
......
......@@ -10,6 +10,7 @@ import basic
import StdCompare
import syntax
//import StdEnv
import general
:: SuclTypeSymbol
= SuclUSER (Global Index)
......@@ -22,6 +23,7 @@ import syntax
| SuclDYNAMIC
| SuclFILE
| SuclWORLD
| SuclERROR // Type error
:: SuclTypeVariable
= SuclANONYMOUS Int
......@@ -63,6 +65,7 @@ where (==) (SuclUSER tsid1 ) (SuclUSER tsid2 ) = tsid1==tsid2
(==) SuclDYNAMIC SuclDYNAMIC = True
(==) SuclFILE SuclFILE = True
(==) SuclWORLD SuclWORLD = True
(==) SuclERROR SuclERROR = True
(==) _ _ = False
instance toString SuclTypeSymbol
......@@ -76,6 +79,7 @@ where toString (SuclUSER tsid ) = toString tsid
toString SuclDYNAMIC = "Dynamic"
toString SuclFILE = "File"
toString SuclWORLD = "World"
toString SuclERROR = "Error"
instance <<< SuclTypeSymbol
where (<<<) file tsym = file <<< toString tsym
......@@ -107,7 +111,7 @@ where (==) (SuclUser id1 ) (SuclUser id2 ) = id1 == id2
instance toString SuclSymbol
where toString (SuclUser sk ) = toString sk
toString (SuclCase eptr) = "<anonymous lifted case function>"
toString (SuclCase eptr) = "<anonymous lifted case function for expression "+++toString eptr+++">"
toString (SuclApply int ) = "Apply/"+++toString int
toString (SuclInt int ) = toString int
toString (SuclReal real) = toString real
......@@ -131,13 +135,13 @@ where toString SK_Unknown = "Unknown"
instance <<< SymbKind
where (<<<) file sk = file <<< toString sk
instance toString Global a | toString a
instance toString (Global a) | toString a
where toString {glob_module,glob_object} = toString glob_module+++"."+++toString glob_object
instance toString Ptr a
instance toString (Ptr a)
where toString p = "p:"+++toString (ptrToInt p)
instance <<< Ptr a
instance <<< (Ptr a)
where (<<<) file p = file <<< toString p
instance == SymbKind
......@@ -197,8 +201,7 @@ coretyperule (SuclChar _) = consttyperule SuclCHAR
coretyperule (SuclReal _) = consttyperule SuclREAL
coretyperule (SuclBool _) = consttyperule SuclBOOL
coretyperule (SuclString _) = consttyperule SuclSTRING
coretyperule (SuclUser _) = abort "coreclean: coretyperule: untyped user symbol"
coretyperule (SuclCase _) = abort "coreclean: coretyperule: untyped case symbol"
coretyperule sym = error ("coreclean: coretyperule: untyped user symbol: "+++toString sym)
consttyperule tsym
= mkrule [] root (updategraph root (tsym,[]) emptygraph)
......@@ -216,3 +219,4 @@ corecomplete SuclSTRING = const False
corecomplete SuclDYNAMIC = const False
corecomplete SuclFILE = const False
corecomplete SuclWORLD = const False
corecomplete SuclERROR = const False
......@@ -3,7 +3,7 @@ definition module dnc
// $Id$
from graph import Graph,Node
from StdString import String
from cleanversion import String
from StdOverloaded import ==
// dnc is like varcontents, but can give a more reasonable error message
......
......@@ -80,7 +80,7 @@ actualfold deltanodes rnfnodes foldarea self foldcont hist rule
= 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 = map (pairwith (findoccs hist rule)) (varlist rgraph [rroot]--varlist rgraph rargs)
// list2: list combining every node with list of every instantiable history graph
list3 = [(rnode,mapping) \\ (rnode,[mapping:_])<-list2]
......@@ -120,7 +120,7 @@ findoccs hist rule rnode
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]
outer = varlist (prunegraph rnode rgraph) [rroot:rargs]--[rnode]
/*
------------------------------------------------------------------------
......@@ -148,8 +148,8 @@ splitrule fold rnfnodes deltanodes rule area
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]
ins = varlist agraph [aroot]--outs
outs = varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]--[aroot]
addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node))
......@@ -180,11 +180,11 @@ finishfold foldarea fixednodes singlenodes root graph
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]
ins = [aroot:varlist graph [aroot]--outs_and_aroot]
generate area
= removeMembers (snd (graphvars agraph [aroot])) fixednodes
= snd (graphvars agraph [aroot])--fixednodes
where aroot = rgraphroot area; agraph = rgraphgraph area
arearoots = removeMembers (removeDup [root:singlenodes++singfixargs]) fixednodes
arearoots = removeDup [root:singlenodes++singfixargs]--fixednodes
singfixargs = flatten (map arguments (singlenodes++fixednodes))
arguments node
......
......@@ -4,7 +4,8 @@ definition module graph