new (higher) level of abstraction

Data.hs

@@ -10,19 +10,23 @@ data Program = Program [FDef] [GDef]
 
 data Contract = Contract Name Pat
 data Step a = Transient a | Variants [(Contract, a)] | Stop | Decompose [a] | Fold a Renaming deriving (Show)
-data Tree = Node Expr (Step Tree) 
+data Graph a = Node a (Step (Graph a))
+type Tree a = Graph a
+type Node a = Tree a
 
 -- We use type synonyms to make declarations more clear (and expressive)
-type Subst = [(Name, Expr)]
-type NameSupply = [Name]
 type Name = String
 type Renaming = [(Name, Name)]
-type Task = (Expr, Program)
+type Subst = [(Name, Expr)]
+type NameSupply = [Name]
+
+type Conf = Expr
 type Value = Expr
+type Task = (Conf, Program)
 type Env = [(Name, Value)]
 
-type Machine = NameSupply -> Expr -> Step Expr
-type MachineGen = Program -> Machine
+type Machine a = NameSupply -> a -> Step a
+type MachineGen p a = p -> Machine a
 
 instance Show Expr where
 	show (Var n) = n

DataUtil.hs

@@ -40,6 +40,10 @@ isVar :: Expr -> Bool
 isVar (Var _) = True
 isVar _ = False
 
+isValue :: Expr -> Bool
+isValue (Ctr _ args) = and $ map isValue args 
+isValue _ = False
+
 -- list of local fails and local successes 
 rawRenaming :: (Expr, Expr) -> [Maybe (Name, Name)]
 rawRenaming ((Var x), (Var y)) = [Just (x, y)]
@@ -141,7 +145,7 @@ readP1 p@(Program fs gs) s = next (readFDef s) (readGDef s) where
 
 printTree t = unlines $ take 1000 $ pprintTree "" "" t
 
-pprintTree :: String -> String -> Tree -> [String]
+pprintTree :: String -> String -> Graph Conf -> [String]
 pprintTree indent msg (Node expr next) = make next where
 	make (Fold _ ren) = (indent ++ msg) : [indent ++ "|__" ++  (show expr) ++ "__↑" ++ (show ren)]
 	make Stop = (indent ++ msg) : [indent ++ "|__" ++  (show expr)]

Deforester.hs

@@ -11,7 +11,7 @@ deforest :: Task -> Task
 deforest (e, p) =
 	residuate $ simplify $ foldTree $ buildFTree (buildMachine p) e
 
-simplify :: Tree -> Tree
+simplify :: Graph Conf -> Graph Conf
 simplify (Node e (Decompose ts)) = (Node e (Decompose $ map simplify ts))
 simplify (Node e (Variants cs)) = Node e $ Variants [(c, simplify t) | (c, t) <- cs]
 simplify (Node e (Transient t)) | isBase e t = Node e $ Transient $ simplify t 

Driving.hs

@@ -5,20 +5,20 @@ import DataUtil
 
 -- Builds an infinite (in a general case) process tree using a provided state machine.
 
-buildTree :: Machine -> Expr -> Tree
+buildTree :: Machine Conf -> Conf -> Graph Conf
 buildTree m e = buildTree' m nameSupply e
 
-buildTree' :: Machine -> NameSupply -> Expr -> Tree
+buildTree' :: Machine Conf -> NameSupply -> Conf -> Graph Conf
 buildTree' m ns t = case m ns t of
 	Decompose driven -> Node t $ Decompose (map (buildTree' m ns) driven)
 	Transient term -> Node t $ Transient (buildTree' m ns term)
 	Stop -> Node t Stop
 	Variants cs -> 
 		Node t $ Variants [(c, buildTree' m (unused c ns) e) | (c, e) <- cs]
 
-buildMachine :: MachineGen
+buildMachine :: MachineGen Program Conf
 buildMachine p = drive where
-	drive :: Machine
+	drive :: Machine Conf
 	drive ns (Var _) = Stop
 	drive ns (Ctr _ []) = Stop
 	drive ns (Ctr _ args) = Decompose args

Folding.hs

@@ -5,16 +5,16 @@ import DataUtil
 import Driving
 
 -- folding of foldable infinite tree into a graph
-foldTree :: Tree -> Tree
+foldTree :: Tree Conf -> Graph Conf
 foldTree t = tieKnot [] t
 
 -- we tie a knot only for calls
 -- it is enough in the first-order settings
-tieKnot :: [Tree] -> Tree -> Tree
+tieKnot :: [Node Conf] -> Tree Conf -> Graph Conf
 tieKnot ts t@(Node e _) = n where
 	n:_ = [Node e (Fold k r) | k <- ts, Just r <- [renaming (expr k) e], isCall e] ++ [(traverse ts t)]
 
-traverse :: [Tree] -> Tree -> Tree
+traverse :: [Node Conf] -> Tree Conf -> Graph Conf
 traverse ts (Node e (Transient c)) = t where
 	t = Node e $ Transient $ tieKnot (t:ts) c
 traverse ts (Node e (Decompose cs)) = t where 

Generator.hs

@@ -9,12 +9,12 @@ isBase e1 (Node _ (Transient t)) = isBase e1 t
 isBase e1 (Node _ (Fold (Node e2 _) _)) = e1 == e2
 isBase e1 (Node e2 Stop) = False
 
-residuate :: Tree -> Task
+residuate :: Graph Conf -> Task
 residuate tree = (expr, program) where
 	(expr, program, _) = res nameSupply [] tree
 
 --- generation of residual program
-res :: NameSupply -> [(Expr, Expr)] -> Tree -> (Expr, Program, NameSupply)
+res :: NameSupply -> [(Conf, Conf)] -> Graph Conf -> (Conf, Program, NameSupply)
 res ns mp (Node e Stop) = (e, Program [] [], ns)
 
 res ns mp (Node (Ctr cname _) (Decompose ts)) = (Ctr cname args, p1, ns1) where
@@ -45,7 +45,7 @@ res ns mp (Node e (Fold (Node base _) ren)) = (call, Program [] [], ns) where
 
 -- proceeds a list of trees 
 -- the main goal is to handle name supply
-make :: NameSupply -> [(Expr, Expr)] -> [Tree] -> ([Expr], Program, NameSupply)
+make :: NameSupply -> [(Conf, Conf)] -> [Graph Conf] -> ([Conf], Program, NameSupply)
 make ns mp ts = foldl f ([], Program [] [], ns) ts where 
 	f (gens, Program fs gs, ns1) tree = (gens ++ [g], Program (fs ++ fs1) (gs ++ gs1), ns2) where 
 		(g, Program fs1 gs1, ns2) = res ns1 mp tree

Interpreter.hs

@@ -30,9 +30,14 @@ intStep p (GCall gname (e:es)) =
 intStep p (Let binding e2) =
 	subst [binding] e2
 
-isValue :: Expr -> Bool
-isValue (Ctr _ args) = and $ map isValue args 
-isValue _ = False
+-- big-step semantics
+eval :: Program -> Expr -> Expr
+eval p (Ctr name args) = 
+	Ctr name $ map (eval p) args
+
+eval p (FCall name args) = 
+	eval p (subst (zip vs args) t) where
+		(FDef _ vs t) = fDef p name
 
 sll_trace :: Task -> Subst -> (Value, Integer)
 sll_trace (e, prog) s = intC prog (subst s e)

Prototype.hs

@@ -18,10 +18,10 @@ transform (expr, program) =
 -- Build foldable tree, - ensures that the size of expressions
 -- in nodes are limited (by whistle).
 
-buildFTree :: Machine -> Expr -> Tree
+buildFTree :: Machine Conf -> Conf -> Tree Conf
 buildFTree m e = buildFTree' m nameSupply e
 
-buildFTree' :: Machine -> NameSupply -> Expr -> Tree
+buildFTree' :: Machine Conf -> NameSupply -> Conf -> Tree Conf
 buildFTree' d (n:ns) e | whistle e = buildFTree' d ns $ generalize n e
 buildFTree' d ns     t | otherwise = case d ns t of
 	Decompose driven -> Node t $ Decompose (map (buildFTree' d ns) driven)

Supercompiler.hs

@@ -12,11 +12,11 @@ supercompile :: Task -> Task
 supercompile (expr, program) =
 	residuate $ simplify $ foldTree $ buildFTree (addPropagation $ buildMachine program) expr
 
-addPropagation :: Machine -> Machine
+addPropagation :: Machine Conf -> Machine Conf
 addPropagation dr = f where
 	f ns e = propagateContract (dr ns e)
 
-propagateContract :: Step Expr -> Step Expr
+propagateContract :: Step Conf -> Step Conf
 propagateContract (Variants vs) = 
 	Variants [(c, subst [(v, Ctr cn $ map Var vs)] e) | (c@(Contract v (Pat cn vs)), e) <- vs]
 propagateContract step = step

TreeInterpreter.hs

@@ -4,7 +4,7 @@ import Data
 import DataUtil
 import Maybe
 
-intTree :: Tree -> Env -> Value
+intTree :: Tree Conf -> Env -> Value
 intTree (Node e Stop) env = 
 	subst env e 
 
@@ -20,7 +20,7 @@ intTree (Node _ (Transient t)) env =
 intTree (Node e (Variants cs)) env = 
 	 head $ catMaybes $ map (try env) cs
 
-try :: Env -> (Contract, Tree) -> (Maybe Expr)
+try :: Env -> (Contract, Tree Conf) -> (Maybe Expr)
 try env (Contract v (Pat pn vs), t) = 
 	if cn == pn then (Just $ intTree t extendedEnv) else Nothing where 
 		c@(Ctr cn args) = subst env (Var v)