Commits

Paweł Wieczorek committed 45646ad Merge

merge

  • Participants
  • Parent commits 5e2b001, 125e784

Comments (0)

Files changed (63)

 build-depends: mtl -any, mtl -any, 
                containers,
                base,  array -any, array -any,
-               transformers -any
+               transformers
 stability:
 homepage:
 package-url:
 default-extensions:
 other-extensions:
 extensions: NoMonomorphismRestriction FlexibleInstances
-            GeneralizedNewtypeDeriving
+            GeneralizedNewtypeDeriving MultiParamTypeClasses
 extra-libraries:
 extra-lib-dirs:
 includes:
 install-includes:
 include-dirs:
 hs-source-dirs: src
-other-modules: Selen.TypeChecker
+other-modules: Selen.Compiler.CPS.Analysis
+               Selen.Compiler.CPS.Analysis.CFA0 Selen.Compiler.CPS.Traversals
+               Selen.Data Selen.Compiler.CPS.Analysis.Basic Selen.TypeChecker
                Selen.Compiler.CPS.Optimalizations.Hoisting
                Selen.Compiler.CPS.ClosureConversion Selen.Control.Monad
-               Selen.Class.Pretty Selen.Lang.FL
-               Selen.Lang.Core Selen.Lang.Defs Selen.Lang.IR.CPS
-               Selen.Lang.Core.Tree Selen.Lang.FL.Tree Selen.Control.FreshMonad
-               Selen.Data.Graph Selen.Compiler.CPS
+               Selen.Class.Pretty Selen.Lang.FL Selen.Lang.Core Selen.Lang.Defs
+               Selen.Lang.IR.CPS Selen.Lang.Core.Tree Selen.Lang.FL.Tree
+               Selen.Control.FreshMonad Selen.Data.Graph Selen.Compiler.CPS
                Selen.Compiler.CPS.Optimalizations Selen.Compiler.CPS.Monad
                Selen.Compiler.CPS.Optimalizations.ConstantFolding
                Selen.Compiler.CPS.Optimalizations.EtaUncurry

File src/Selen/Compiler/CPS.hs

 import qualified Selen.Compiler.CPS.Optimalizations.BetaExpansion   as PBeta
 import qualified Selen.Compiler.CPS.Optimalizations.Hoisting        as PHoisting
 import Selen.Compiler.CPS.ClosureConversion
+import Selen.Compiler.CPS.Analysis()
 import Control.Monad
 
 optimalizeUnit :: Ir -> IO Ir
         , PHoisting.reduce
         , PFolding.reduce
         ]
+

File src/Selen/Compiler/CPS/Analysis.hs

+{-
+ -  Copyrights(C) 2012
+ -  by Pawel Wieczorek <wieczyk gmail com>
+ -}
+
+module Selen.Compiler.CPS.Analysis
+    ( module Selen.Compiler.CPS.Analysis.Basic
+    , module Selen.Compiler.CPS.Analysis.CFA0
+    ) where
+
+
+{-------------------------------------------------------------------------
+ -- Exports
+ -}
+
+import Selen.Compiler.CPS.Analysis.Basic
+
+import Selen.Compiler.CPS.Analysis.CFA0
+
+

File src/Selen/Compiler/CPS/Analysis/Basic.hs

+{-
+ -  Copyrights(C) 2012
+ -  by Pawel Wieczorek <wieczyk gmail com>
+ -}
+
+module Selen.Compiler.CPS.Analysis.Basic
+    ( VarBoundBy(..)
+    , WithBasicAnalysis
+    , withBasicAnalysis
+
+    -- interface
+    , isEscapingVar
+    , varUsageCount
+    ) where
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+import Selen.Lang.IR.CPS
+import Selen.Lang.Defs
+import Selen.Compiler.CPS.Traversals
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans
+import Selen.Control.FreshMonad
+import Selen.Compiler.CPS.Monad hiding (BoundBy(..))
+
+{-------------------------------------------------------------------------
+ -- Data
+ -}
+
+data VarBoundBy
+    = BbyPRIMOP IrPrimOp [IrValue]
+    | BbyFIX [VarName] Ir
+    | BbyRECORD [(IrValue, IrAccPath)]
+    | BbySELECT
+    | BbyOFFSET
+    | BbyARG
+    deriving (Eq, Show)
+
+{-------------------------------------------------------------------------
+ -- Internal Monad
+ -}
+
+type AnalysisM m = StateT BasicAnalysisInfo m
+
+{-------------------------------------------------------------------------
+ -- Internal state
+ -}
+
+data BasicAnalysisInfo = MkBasicAnalysisInfo
+    { mapVarUsageCount      :: Map VarName Int
+    , mapVarBoundBy            :: Map VarName VarBoundBy
+    , setEscapingVars       :: Set VarName
+    , setKnownCalls         :: Set VarName
+    }
+
+defaultBasicAnalysisInfo :: BasicAnalysisInfo
+defaultBasicAnalysisInfo = MkBasicAnalysisInfo
+    { mapVarUsageCount      = Map.empty
+    , mapVarBoundBy            = Map.empty
+    , setEscapingVars       = Set.empty
+    , setKnownCalls         = Set.empty
+    }
+
+addVarBoundBy :: TransformationMonad m => VarName -> VarBoundBy -> AnalysisM m ()
+addVarBoundBy var bby = do
+    bai <- get
+    let bbymap = mapVarBoundBy bai
+    put $ bai { mapVarBoundBy = Map.insert var bby bbymap }
+
+
+incVarUsageCount :: TransformationMonad m => VarName -> AnalysisM m ()
+incVarUsageCount var = do
+    bai <- get
+    let ucmap = mapVarUsageCount bai
+    put $ bai { mapVarUsageCount = Map.alter msucc var ucmap }
+ where
+    msucc = maybe (Just 1) (Just . succ)
+
+addEscapingVar :: TransformationMonad m => VarName -> AnalysisM m ()
+addEscapingVar var = do
+    bai <- get
+    let escs = setEscapingVars bai
+    put $ bai { setEscapingVars = Set.insert var escs }
+
+{-------------------------------------------------------------------------
+ -- Helpers
+ -}
+
+whenVar :: Monad m => (VarName -> m ()) -> IrValue -> m ()
+whenVar f (VVAR fn) = f fn
+whenVar _ _ = return ()
+
+{-------------------------------------------------------------------------
+ -- Analysis
+ -}
+
+basicAnalysis_ :: TransformationMonad m => Ir -> AnalysisM m ()
+basicAnalysis_ ir = bottomUpTraversal_ (\_ -> trans) ir
+ where
+    trans (APP fn acargs) = do
+        mapM_ (lift . whenVar addEscapingVar) acargs
+        mapM_ (lift . whenVar incVarUsageCount) acargs
+        lift $ whenVar incVarUsageCount fn
+
+    trans (PRIMOP pop ins outs _) = do
+        mapM_ (lift . addBby) outs
+     where
+        addBby vn = addVarBoundBy vn (BbyPRIMOP pop ins)
+
+    trans (FIX defs _) = do
+        mapM_ (lift . addBby) defs
+     where
+        addBby (fn, fnargs, fnbody) = do
+            addVarBoundBy fn (BbyFIX fnargs fnbody)
+            mapM_ (\vn -> addVarBoundBy vn BbyARG) fnargs
+
+    trans (SWITCH val _) = do
+        lift . whenVar incVarUsageCount $ val
+
+    trans (SELECT _ val vn _) = do
+        lift $ whenVar incVarUsageCount val
+        lift $ addVarBoundBy vn (BbySELECT)
+
+    trans (OFFSET _ val vn _) = do
+        lift $ whenVar incVarUsageCount val
+        lift $ addVarBoundBy vn (BbyOFFSET)
+
+    trans (RECORD fields vn _) = do
+        lift $ addVarBoundBy vn (BbyRECORD fields)
+        lift $ mapM_ (whenVar incVarUsageCount . fst) fields
+
+basicAnalysis :: TransformationMonad m => Ir -> m BasicAnalysisInfo
+basicAnalysis ir = do
+    execStateT (basicAnalysis_ ir) defaultBasicAnalysisInfo
+
+
+{-------------------------------------------------------------------------
+ -- Exported monad
+ -}
+
+newtype TransformationMonad m => WithBasicAnalysis m a
+    = MkWithBasicAnalysis (ReaderT BasicAnalysisInfo m a)
+    deriving (Monad, MonadTrans, FreshMonad, TransformationMonad)
+
+withBasicAnalysis :: TransformationMonad m => WithBasicAnalysis m a -> Ir -> m a
+withBasicAnalysis (MkWithBasicAnalysis m) ir = do
+    bai <- basicAnalysis ir
+    runReaderT m bai
+
+{-------------------------------------------------------------------------
+ -- Analysis data interface
+ -}
+
+isEscapingVar :: TransformationMonad m => VarName -> WithBasicAnalysis m Bool
+isEscapingVar vn = MkWithBasicAnalysis $ do
+    bai <- ask
+    return $ Set.member vn $ setEscapingVars bai
+
+varUsageCount :: TransformationMonad m => VarName -> WithBasicAnalysis m Int
+varUsageCount vn = MkWithBasicAnalysis $ do
+    bai <- ask
+    return $ Map.findWithDefault 0 vn (mapVarUsageCount bai)
+

File src/Selen/Compiler/CPS/Analysis/CFA0.hs

+{-
+ -  Copyrights(C) 2012
+ -  by Pawel Wieczorek <wieczyk gmail com>
+ -}
+
+
+module Selen.Compiler.CPS.Analysis.CFA0
+    ( Q
+    , q_empty
+    , q_enqueue
+    , q_dequeue
+) where
+
+{-------------------------------------------------------------------------
+ -- 0-CFA Analysis
+ -}
+
+{-------------------------------------------------------------------------
+ -- TODO: Work-list algorithm
+ -}
+
+data Q a = Q [a] [a]
+
+q_empty :: Q a
+q_empty = q_create []
+
+q_create :: [a] -> Q a
+q_create xs = Q xs []
+
+q_enqueue :: a -> Q a -> Q a
+q_enqueue a (Q xs1 xs2) = Q xs1 (a:xs2)
+
+q_dequeue :: Q a -> Maybe (Q a, a)
+q_dequeue (Q [] []) = Nothing
+q_dequeue (Q (x:xs1) xs2) = Just $ (Q xs1 xs2, x)
+q_dequeue (Q [] xs2) = q_dequeue (Q (reverse xs2) [])
+
+{-------------------------------------------------------------------------
+ --
+ -}
+

File src/Selen/Compiler/CPS/Monad.hs

     , module Selen.Lang.Defs
     , module Control.Monad.Trans.Maybe
     , BoundBy(..)
-    , topDownTraversal
-    , topDownTraversal'
-    , bottomUpTraversal
     , TransformationMonad(..)
     , varIsUsed
     , varIsUsedN
     , varIsNotUsed
-    , composeTransformations
     , gatherInfo
     , Compiler
     , resetState
     ) where
 
 import Selen.Class.Pretty
+import Selen.Data
 import Selen.Lang.IR.CPS
 import Selen.Control.FreshMonad
 import Selen.Lang.Defs
 import qualified Data.Set as Set
 import Data.Set (Set)
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Selen.Compiler.CPS.Analysis.CFA0()
 
 {-------------------------------------------------------------------------
  -- Term information
     tick            = lift tick
     getRoundNo      = lift getRoundNo
 
+instance TransformationMonad m => TransformationMonad (StateT s m) where
+    varUsedCount    = lift . varUsedCount
+    varEscapes      = lift . varEscapes
+    varBoundBy      = lift . varBoundBy
+    getFunc         = lift . getFunc
+    translog        = lift . translog
+    isIrreducible   = lift . isIrreducible
+    markIrreducible = lift . markIrreducible
+    tick            = lift tick
+    getRoundNo      = lift getRoundNo
+
+
+instance TransformationMonad m => TransformationMonad (ReaderT s m) where
+    varUsedCount    = lift . varUsedCount
+    varEscapes      = lift . varEscapes
+    varBoundBy      = lift . varBoundBy
+    getFunc         = lift . getFunc
+    translog        = lift . translog
+    isIrreducible   = lift . isIrreducible
+    markIrreducible = lift . markIrreducible
+    tick            = lift tick
+    getRoundNo      = lift getRoundNo
+
 varIsUsed :: TransformationMonad m => VarName -> m Bool
 varIsUsed v = do
     uc <- varUsedCount v
  -- Compiler
  -}
 
-type Compiler a = StateT CompilerState (FreshT IO) a
+-- bad design, problem with overlapping instances TransformationMonad (StateT s m)
+newtype Compiler a = MkCompiler (StateT CompilerState (FreshT IO) a)
+
+instance Monad Compiler where
+    return x   = MkCompiler (return x)
+    fail   x   = MkCompiler (fail x)
+    -- Compiler a -> (b -> Compiler b) -> Compiler b
+    (MkCompiler m) >>= f = MkCompiler $ do
+        x <- m
+        let (MkCompiler m') = f x
+        m'
+
+instance MonadState CompilerState Compiler where
+    put = undefined
+    get = undefined
+
 
 runCompiler :: Int -> Compiler a -> IO a
-runCompiler s m = do
+runCompiler s (MkCompiler m) = do
     ((a,_),_) <- runFreshT (runStateT m defaultCompilerState) s
     return a
 
 getTicks :: Compiler Integer
 getTicks = get >>= return . ticks
 
-instance TransformationMonad (StateT CompilerState (FreshT IO)) where
+instance FreshMonad Compiler where
+    freshString = MkCompiler freshString
+
+instance MonadIO Compiler where
+    liftIO = MkCompiler . liftIO
+
+--instance TransformationMonad (StateT CompilerState (FreshT IO)) where
+instance TransformationMonad Compiler where
     varUsedCount v = do
         st <- getIrInfo
         case (Map.lookup v (infUsedCount st)) of
         mapM_ incUsedVal vs
         mapM_ incEscapesVal vs
 
-{-------------------------------------------------------------------------
- -- Helper
- -}
-
-composeTransformations :: TransformationMonad m => [Ir -> m (Maybe Ir)] -> Ir -> m (Maybe Ir)
-composeTransformations xs ir0 = do
-    let f ir trans = do
-        _ir <- trans ir
-        case _ir of
-            Nothing  -> return ir
-            Just tir -> return tir
-
-
-    ir' <- foldM f ir0 xs
-    return . Just $ ir'
 
 {-------------------------------------------------------------------------
- -- The top-down traversals
+ -- Helpers
+ --
  -}
 
--- TODO: topDown and bottomUp could be a parametrized universal traversal
-
-topDownTraversal :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
-topDownTraversal trans = compute []
- where
-    compute stack ir0 = do
-        mir <- runMaybeT (trans stack ir0)
-        case mir of
-            Nothing  ->         walk stack ir0
-            Just ir1 -> tick >> walk stack ir1
-
-    walk stack (FIX defs expr) = do
-        let fns    = map proj3_1 defs
-        let nstack = fns:stack
-        ndefs <- mapM (walkDef nstack) defs
-        nexpr <- compute stack expr
-        return $ FIX ndefs nexpr
-     where
-        walkDef _ (fn, fnargs, fnbody) = do
-            nfnbody <- compute ([fn]:stack) fnbody
-            return (fn, fnargs, nfnbody)
-
-    walk stack (PRIMOP pop vs rs exprs) = do
-        nexprs <- mapM (compute stack) exprs
-        return $ PRIMOP pop vs rs nexprs
-
-    walk stack (SWITCH v exprs) = do
-        nexprs <- mapM (compute stack) exprs
-        return $ SWITCH v nexprs
-
-    walk stack (RECORD rs v expr) = do
-        nexpr <- compute stack expr
-        return $ RECORD rs v nexpr
-
-    walk stack (OFFSET off path var expr) = do
-        nexpr <- compute stack expr
-        return $ OFFSET off path var nexpr
-
-    walk stack (SELECT off path var expr) = do
-        nexpr <- compute stack expr
-        return $ SELECT off path var nexpr
-
-    walk _ ir@(APP _ _) = do
-        return ir
-
-topDownTraversal' :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
-topDownTraversal' trans = compute []
- where
-    compute stack ir0 = do
-        mir <- runMaybeT (trans stack ir0)
-        case mir of
-            Nothing  ->         walk stack ir0
-            Just ir1 -> tick >> return ir1
-
-    walk stack (FIX defs expr) = do
-        let fns    = map proj3_1 defs
-        let nstack = fns:stack
-        ndefs <- mapM (walkDef nstack) defs
-        nexpr <- compute stack expr
-        return $ FIX ndefs nexpr
-     where
-        walkDef _ (fn, fnargs, fnbody) = do
-            nfnbody <- compute ([fn]:stack) fnbody
-            return (fn, fnargs, nfnbody)
-
-    walk stack (PRIMOP pop vs rs exprs) = do
-        nexprs <- mapM (compute stack) exprs
-        return $ PRIMOP pop vs rs nexprs
-
-    walk stack (SWITCH v exprs) = do
-        nexprs <- mapM (compute stack) exprs
-        return $ SWITCH v nexprs
-
-    walk stack (RECORD rs v expr) = do
-        nexpr <- compute stack expr
-        return $ RECORD rs v nexpr
-
-    walk stack (OFFSET off path var expr) = do
-        nexpr <- compute stack expr
-        return $ OFFSET off path var nexpr
-
-    walk stack (SELECT off path var expr) = do
-        nexpr <- compute stack expr
-        return $ SELECT off path var nexpr
-
-    walk _ ir@(APP _ _) = do
-        return ir
-
-{-------------------------------------------------------------------------
- -- The bottom-up traversals
- -}
-
-bottomUpTraversal :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
-bottomUpTraversal trans = walk []
- where
-    compute stack ir0 = do
-        mir <- runMaybeT (trans stack ir0)
-        case mir of
-            Nothing  ->         return ir0
-            Just ir1 -> tick >> return ir1
-
-    walk stack ir@(APP _ _) = do
-        compute stack ir
-
-    walk stack (PRIMOP pop ins outs exprs) = do
-        nexprs <- mapM (walk stack) exprs
-        compute stack (PRIMOP pop ins outs nexprs)
-
-    walk stack (SWITCH val exprs) = do
-        nexprs <- mapM (walk stack) exprs
-        compute stack (SWITCH val nexprs)
-
-    walk stack (SELECT off val var expr) = do
-        nexpr <- walk stack expr
-        compute stack (SELECT off val var nexpr)
-
-    walk stack (OFFSET off val var expr) = do
-        nexpr <- walk stack expr
-        compute stack (OFFSET off val var nexpr)
-
-    walk stack (RECORD fields var expr) = do
-        nexpr <- walk stack expr
-        compute stack (RECORD fields var nexpr)
-
-    walk stack (FIX defs expr) = do
-        let fns    = map proj3_1 defs
-        let nstack = fns:stack
-        ndefs <- mapM (walkDef nstack) defs
-        nexpr <- walk nstack expr
-        compute stack (FIX ndefs nexpr)
-     where
-        walkDef nstack (fn, fnargs, fnbody) = do
-            nfnbody <- walk nstack fnbody
-            return (fn, fnargs, nfnbody)
-
-
 {-------------------------------------------------------------------------
  -- Helpers
  --
             ti  <- getTicks
             return (ir1, ti:tis)
 
-nth :: (Eq b, Num b, Enum b) => b -> [a] -> a -> a
-nth 0 (x:_) _  = x
-nth _ []    d  = d
-nth n (_:xs) d = nth (pred n) xs d
-
-proj3_1 :: (a,b,c) -> a
-proj3_1 (a, _, _) = a
-
-proj3_2 :: (a,b,c) -> b
-proj3_2 (_, b, _) = b
-
+-- nth :: (Eq b, Num b, Enum b) => b -> [a] -> a -> a
 withFunc :: TransformationMonad m
          => VarName -> ( ([VarName], Ir) -> MaybeT m a) -> MaybeT m a
 withFunc fn mf = getFunc fn >>= maybe (fail "Unknown function") mf

File src/Selen/Compiler/CPS/Optimalizations.hs

  -}
 
 module Selen.Compiler.CPS.Optimalizations
-    ( 
+    (
     ) where
 
 {-
 import Control.Monad
 import Selen.Control.FreshMonad
 -}
+
+newtype TransformationName
+    = MkTransformationName { unTransformationName :: String }
+    deriving (Eq, Show, Ord)
+

File src/Selen/Compiler/CPS/Optimalizations/BetaExpansion.hs

 
 import Selen.Class.Pretty
 import Selen.Compiler.CPS.Monad
+import Selen.Compiler.CPS.Traversals
 --import Control.Monad
 --import Data.Foldable (foldrM)
 --import Data.List

File src/Selen/Compiler/CPS/Optimalizations/ConstantFolding.hs

 import Selen.Lang.IR.CPS
 import Selen.Class.Pretty
 import Selen.Compiler.CPS.Monad
+import Selen.Compiler.CPS.Traversals
 import Control.Monad
 import Data.Foldable (foldrM)
 import Data.Map (Map)

File src/Selen/Compiler/CPS/Optimalizations/EtaUncurry.hs

 import Selen.Lang.IR.CPS
 import Selen.Compiler.CPS.Monad
 import Selen.Control.FreshMonad
+import Selen.Compiler.CPS.Traversals
 
 {-------------------------------------------------------------------------
  -- Reduce

File src/Selen/Compiler/CPS/Optimalizations/Hoisting.hs

 import Selen.Control.Monad
 import Selen.Compiler.CPS.Monad
 import qualified Data.Set as Set
+import Selen.Compiler.CPS.Traversals
 
 {-------------------------------------------------------------------------
  -- Reduce
 
     checkDef fvs (_, _, fnbody) = noFVsetIrM fvs fnbody
 
-

File src/Selen/Compiler/CPS/Traversals.hs

+{-
+ -  Copyrights(C) 2012
+ -  by Pawel Wieczorek <wieczyk gmail com>
+ -}
+
+module Selen.Compiler.CPS.Traversals
+    ( topDownTraversal
+    , topDownTraversal'
+    , bottomUpTraversal
+    , bottomUpTraversal_
+    , composeTransformations
+    ) where
+
+import Selen.Data
+import Selen.Lang.IR.CPS
+import Selen.Lang.Defs
+import Selen.Control.Monad
+import Control.Monad.Trans.Maybe
+import Selen.Compiler.CPS.Monad
+
+{-------------------------------------------------------------------------
+ -- Helper
+ -}
+
+composeTransformations :: TransformationMonad m => [Ir -> m (Maybe Ir)] -> Ir -> m (Maybe Ir)
+composeTransformations xs ir0 = do
+    let f ir trans = do
+        _ir <- trans ir
+        case _ir of
+            Nothing  -> return ir
+            Just tir -> return tir
+
+
+    ir' <- foldM f ir0 xs
+    return . Just $ ir'
+
+{-------------------------------------------------------------------------
+ -- The top-down traversals
+ -}
+
+-- TODO: topDown and bottomUp could be a parametrized universal traversal
+
+topDownTraversal :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
+topDownTraversal trans = compute []
+ where
+    compute stack ir0 = do
+        mir <- runMaybeT (trans stack ir0)
+        case mir of
+            Nothing  ->         walk stack ir0
+            Just ir1 -> tick >> walk stack ir1
+
+    walk stack (FIX defs expr) = do
+        let fns    = map proj3_1 defs
+        let nstack = fns:stack
+        ndefs <- mapM (walkDef nstack) defs
+        nexpr <- compute stack expr
+        return $ FIX ndefs nexpr
+     where
+        walkDef _ (fn, fnargs, fnbody) = do
+            nfnbody <- compute ([fn]:stack) fnbody
+            return (fn, fnargs, nfnbody)
+
+    walk stack (PRIMOP pop vs rs exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        return $ PRIMOP pop vs rs nexprs
+
+    walk stack (SWITCH v exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        return $ SWITCH v nexprs
+
+    walk stack (RECORD rs v expr) = do
+        nexpr <- compute stack expr
+        return $ RECORD rs v nexpr
+
+    walk stack (OFFSET off path var expr) = do
+        nexpr <- compute stack expr
+        return $ OFFSET off path var nexpr
+
+    walk stack (SELECT off path var expr) = do
+        nexpr <- compute stack expr
+        return $ SELECT off path var nexpr
+
+    walk _ ir@(APP _ _) = do
+        return ir
+
+topDownTraversal' :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
+topDownTraversal' trans = compute []
+ where
+    compute stack ir0 = do
+        mir <- runMaybeT (trans stack ir0)
+        case mir of
+            Nothing  ->         walk stack ir0
+            Just ir1 -> tick >> return ir1
+
+    walk stack (FIX defs expr) = do
+        let fns    = map proj3_1 defs
+        let nstack = fns:stack
+        ndefs <- mapM (walkDef nstack) defs
+        nexpr <- compute stack expr
+        return $ FIX ndefs nexpr
+     where
+        walkDef _ (fn, fnargs, fnbody) = do
+            nfnbody <- compute ([fn]:stack) fnbody
+            return (fn, fnargs, nfnbody)
+
+    walk stack (PRIMOP pop vs rs exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        return $ PRIMOP pop vs rs nexprs
+
+    walk stack (SWITCH v exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        return $ SWITCH v nexprs
+
+    walk stack (RECORD rs v expr) = do
+        nexpr <- compute stack expr
+        return $ RECORD rs v nexpr
+
+    walk stack (OFFSET off path var expr) = do
+        nexpr <- compute stack expr
+        return $ OFFSET off path var nexpr
+
+    walk stack (SELECT off path var expr) = do
+        nexpr <- compute stack expr
+        return $ SELECT off path var nexpr
+
+    walk _ ir@(APP _ _) = do
+        return ir
+
+{-------------------------------------------------------------------------
+ -- The bottom-up traversals
+ -}
+
+bottomUpTraversal :: TransformationMonad m => ([[VarName]] -> Ir -> MaybeT m Ir) -> Ir -> m Ir
+bottomUpTraversal trans = walk []
+ where
+    compute stack ir0 = do
+        mir <- runMaybeT (trans stack ir0)
+        case mir of
+            Nothing  ->         return ir0
+            Just ir1 -> tick >> return ir1
+
+    walk stack ir@(APP _ _) = do
+        compute stack ir
+
+    walk stack (PRIMOP pop ins outs exprs) = do
+        nexprs <- mapM (walk stack) exprs
+        compute stack (PRIMOP pop ins outs nexprs)
+
+    walk stack (SWITCH val exprs) = do
+        nexprs <- mapM (walk stack) exprs
+        compute stack (SWITCH val nexprs)
+
+    walk stack (SELECT off val var expr) = do
+        nexpr <- walk stack expr
+        compute stack (SELECT off val var nexpr)
+
+    walk stack (OFFSET off val var expr) = do
+        nexpr <- walk stack expr
+        compute stack (OFFSET off val var nexpr)
+
+    walk stack (RECORD fields var expr) = do
+        nexpr <- walk stack expr
+        compute stack (RECORD fields var nexpr)
+
+    walk stack (FIX defs expr) = do
+        let fns    = map proj3_1 defs
+        let nstack = fns:stack
+        ndefs <- mapM (walkDef nstack) defs
+        nexpr <- walk nstack expr
+        compute stack (FIX ndefs nexpr)
+     where
+        walkDef nstack (fn, fnargs, fnbody) = do
+            nfnbody <- walk nstack fnbody
+            return (fn, fnargs, nfnbody)
+
+bottomUpTraversal_ :: Monad m => ([[VarName]] -> Ir -> MaybeT m ()) -> Ir -> m ()
+bottomUpTraversal_ trans = walk []
+ where
+    compute stack ir0 = do
+        _ <- runMaybeT (trans stack ir0)
+        return ()
+
+    walk stack ir@(APP _ _) = do
+        compute stack ir
+
+    walk stack ir@(PRIMOP _ _ _ exprs) = do
+        _ <- mapM (walk stack) exprs
+        compute stack ir
+
+    walk stack ir@(SWITCH _ exprs) = do
+        _ <- mapM (walk stack) exprs
+        compute stack ir
+
+    walk stack ir@(SELECT _ _ _ expr) = do
+        _ <- walk stack expr
+        compute stack ir
+
+    walk stack ir@(OFFSET _ _ _ expr) = do
+        _ <- walk stack expr
+        compute stack ir
+
+    walk stack ir@(RECORD _ _ expr) = do
+        _ <- walk stack expr
+        compute stack ir
+
+    walk stack ir@(FIX defs expr) = do
+        let fns    = map proj3_1 defs
+        let nstack = fns:stack
+        _ <- mapM (walkDef nstack) defs
+        _ <- walk nstack expr
+        compute stack ir
+     where
+        walkDef nstack (fn, fnargs, fnbody) = do
+            nfnbody <- walk nstack fnbody
+            return (fn, fnargs, nfnbody)
+
+{-------------------------------------------------------------------------
+ -- Traverse
+
+data TraversarType = BottomUpTraversal | TopDownTraversal
+
+traverseIr :: Monad m
+                   => ([[VarName]] -> Ir -> MaybeT m Ir)
+                   -> m ()
+                   -> TraversarType
+                   -> Ir -> m Ir
+traverseIr trans trigger travType = compute []
+ where
+
+    compute stack ir0 = do
+        irEnter <- enterT stack ir
+        irRec   <- walk stack
+
+    computeNode stack ir0 = do
+        mir <- runMaybeT (trans stack ir0)
+        maybe (return ir0) (\x -> trigger >> return x)
+
+    enterT stack ir = case travType of
+        TopDownTraversal  -> computeNode stack ir
+        BottomUpTraversal -> return ir
+
+    returnT stack ir = case travType of
+        TopDownTraversal  -> return ir
+        BottomUpTraversal -> computeNode stack ir
+
+    walk stack (FIX defs expr) = do
+        let fns    = map proj3_1 defs
+        let nstack = fns:stack
+        ndefs <- mapM (walkDef nstack) defs
+        nexpr <- compute stack expr
+        return $ FIX ndefs nexpr
+     where
+        walkDef _ (fn, fnargs, fnbody) = do
+            nfnbody <- compute ([fn]:stack) fnbody
+            return (fn, fnargs, nfnbody)
+
+    walk stack (PRIMOP pop vs rs exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        returnT $ PRIMOP pop vs rs nexprs
+
+    walk stack (SWITCH v exprs) = do
+        nexprs <- mapM (compute stack) exprs
+        returnT $ SWITCH v nexprs
+
+    walk stack (RECORD rs v expr) = do
+        nexpr <- compute stack expr
+        returnT $ RECORD rs v nexpr
+
+    walk stack (OFFSET off path var expr) = do
+        nexpr <- compute stack expr
+        returnT $ OFFSET off path var nexpr
+
+    walk stack (SELECT off path var expr) = do
+        nexpr <- compute stack expr
+        returnT $ SELECT off path var nexpr
+
+    walk _ ir@(APP _ _) = do
+        return ir
+ -}
+

File src/Selen/Control/FreshMonad.hs

 import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
 import Control.Monad.State
 import Control.Monad.Identity
 
 instance FreshMonad m => FreshMonad (StateT s m) where
     freshString = lift freshString
 
+instance FreshMonad m => FreshMonad (ReaderT s m) where
+    freshString = lift freshString
+
 instance MonadIO m => MonadIO (FreshT m) where
     liftIO m = FreshT (\s0 -> liftIO m >>= \a -> return (a,s0))
 

File src/Selen/Data.hs

+{-
+ -  Copyrights(C) 2012
+ -  by Pawel Wieczorek <wieczyk gmail com>
+ -}
+
+module Selen.Data
+    ( proj3_1
+    , proj3_2
+    , proj3_3
+    , nth
+    ) where
+
+{-------------------------------------------------------------------------
+ -- Tuples
+ -}
+
+proj3_1 :: (a,b,c) -> a
+proj3_1 (a, _, _) = a
+
+proj3_2 :: (a,b,c) -> b
+proj3_2 (_, b, _) = b
+
+proj3_3 :: (a,b,c) -> c
+proj3_3 (_, _, c) = c
+
+
+{-------------------------------------------------------------------------
+ -- Lists
+ -}
+
+nth :: (Eq b, Num b, Enum b) => b -> [a] -> a -> a
+nth 0 (x:_) _  = x
+nth _ []    d  = d
+nth n (_:xs) d = nth (pred n) xs d
+

File test/01.sl

-DEF main =
-    let k = fun (x:int) => fun (y:int) => x
-    in k 1 2

File test/02.sl

-DEF main = 1 + 2

File test/03.sl

-SIG main : int
-DEF main = (fun x => fun (y:int) => x) 1 2

File test/04.sl

-DEF main = (fun (x:int) (y:int) => x + y) 1
-

File test/05.sl

-DEF main =
-    let add = fun (x:int) => 5 + x
-     in add 3
-

File test/06.sl

-DEF main = 
-    let nil c1 c2 = c1 in
-    let cons x xs d1 d2 = d2 x xs in
-    let isnil ys = ys 1 (fun q w => 0) in
-    let iscons bs = bs 0 (fun e r => 1) in
-    let head zs = zs 0 (fun a b => a) in
-    let list1 = cons 10 nil in
-    head list1 

File test/07.sl

-DEF main = 
-    let nil c1 c2 = c1 in
-    let cons x xs d1 d2 = d2 x xs in
-    let cons2 xx xxs dd1 dd2 = dd2 xx xxs in
-    let isnil ys = ys 1 (fun q w => 0) in
-    let iscons bs = bs 0 (fun e r => 1) in
-    let head zs = zs 0 (fun a b => a) in
-    let tail zs = zs 0 (fun aa bb => bb) in
-    let list1 = cons 10 (cons2 20 nil) in
-    head (tail list1)

File test/08.sl

-DEF main =
-    if a == a
-        then 10
-        else 20

File test/09.sl

-DEF main =
-    if (a == b) && (a == b)
-        then 10
-        else 20

File test/10.sl

-SIG add : int -> int -> int
-DEF add (x:int) (y:int) = x + y
-DEF main = add 1 2

File test/11.sl

-SIG frac : int -> int -> int
-DEF frac aux n =
-    if n == 0
-        then aux
-        else frac (n*aux) (n - 1)
-DEF main = frac 1 0
-

File test/12.sl

-DEF nil c1 c2 = c1
-DEF cons x xs c1 c2 = c2 x xs
-DEF map f xs = xs nil (fun y ys => cons (f y) (map f ys))
-DEF list = cons 0 (cons 1 (cons 2 nil))
-DEF head xs = xs 0 (fun x xs => x)
-DEF main = head (map (fun x => x + 1) list)

File test/13.sl

-DEF nil c1 c2 = c1
-DEF cons x xs d1 d2 = d2 x xs
-DEF cons2 xx xxs dd1 dd2 = dd2 xx xxs
-DEF isnil ys = ys 1 (fun q w => 0)
-DEF iscons bs = bs 0 (fun e r => 1)
-DEF head zs = zs 0 (fun a b => a)
-DEF tail zs = zs 0 (fun aa bb => bb)
-DEF list1 = cons 10 (cons2 20 nil)
-DEF main = head (tail list1)

File test/14.sl

-SIG add : int -> int -> int
-DEF add x y = x + y
-DEF main = add 1 2 * add 1 3

File test/16.sl

-SIG f : int -> int -> int
-SIG g : int -> int
-DEF f x (y:int) = g x
-DEF g x = f x x
-
-DEF main = 4
-

File test/basic/K_01.sl

+DEF main =
+    let k = fun (x:int) => fun (y:int) => x
+    in k 1 2

File test/basic/K_02.sl

+SIG main : int
+DEF main = (fun x => fun (y:int) => x) 1 2

File test/basic/K_partial.sl

+DEF main = (fun (x:int) (y:int) => x + y) 1
+

File test/basic/add_01.sl

+DEF main = 1 + 2

File test/basic/add_1_2.sl

+SIG add : int -> int -> int
+DEF add (x:int) (y:int) = x + y
+DEF main = add 1 2

File test/basic/inc3by5.sl

+DEF main =
+    let add = fun (x:int) => 5 + x
+     in add 3
+

File test/beta_contraction/head_list.sl

+DEF main = 
+    let nil c1 c2 = c1 in
+    let cons x xs d1 d2 = d2 x xs in
+    let isnil ys = ys 1 (fun q w => 0) in
+    let iscons bs = bs 0 (fun e r => 1) in
+    let head zs = zs 0 (fun a b => a) in
+    let list1 = cons 10 nil in
+    head list1 

File test/beta_contraction/head_tail_list.sl

+DEF main = 
+    let nil c1 c2 = c1 in
+    let cons x xs d1 d2 = d2 x xs in
+    let cons2 xx xxs dd1 dd2 = dd2 xx xxs in
+    let isnil ys = ys 1 (fun q w => 0) in
+    let iscons bs = bs 0 (fun e r => 1) in
+    let head zs = zs 0 (fun a b => a) in
+    let tail zs = zs 0 (fun aa bb => bb) in
+    let list1 = cons 10 (cons2 20 nil) in
+    head (tail list1)

File test/beta_contraction/head_tail_list_defs.sl

+DEF nil c1 c2 = c1
+DEF cons x xs d1 d2 = d2 x xs
+DEF cons2 xx xxs dd1 dd2 = dd2 xx xxs
+DEF isnil ys = ys 1 (fun q w => 0)
+DEF iscons bs = bs 0 (fun e r => 1)
+DEF head zs = zs 0 (fun a b => a)
+DEF tail zs = zs 0 (fun aa bb => bb)
+DEF list1 = cons 10 (cons2 20 nil)
+DEF main = head (tail list1)

File test/conditions/a_eq_a.sl

+DEF main =
+    if a == a
+        then 10
+        else 20

File test/conditions/a_eq_b_twice.sl

+DEF main =
+    if (a == b) && (a == b)
+        then 10
+        else 20

File test/fib01.sl

-SIG fib : int -> int
-DEF fib n =
-    if n == 0
-        then 1
-        else if n == 1
-            then 1
-            else fib (n-1) + fib (n-2)
-DEF main = fib 0

File test/fib02.sl

-SIG fib : int -> int
-DEF fib n =
-    if n == 0
-        then 1
-        else if n == 1
-            then 1
-            else fib (n-1) + fib (n-2)
-DEF main = fib 1

File test/fib03.sl

-SIG fib : int -> int
-DEF fib n =
-    if n == 0
-        then 1
-        else if n == 1
-            then 1
-            else fib (n-1) + fib (n-2)
-DEF main = fib 3

File test/frac01.sl

-SIG frac : int -> int -> int
-DEF frac aux n =
-    if n == 0
-        then aux
-        else frac (n*aux) (n - 1)
-DEF main = frac 1 0
-

File test/frac02.sl

-SIG frac : int -> int -> int
-DEF frac aux n =
-    if n == 0
-        then aux
-        else frac (n*aux) (n - 1)
-DEF main = frac 1 2
-

File test/frac03.sl

-SIG frac : int ->  int -> int
-DEF frac aux n =
-    if n == 0
-        then aux
-        else frac (n*aux) (n - 1)
-DEF main = frac 1 5
-

File test/frac04.sl

-SIG frac2 : int -> int -> int
-DEF frac2 aux n =
-    if n == 0
-        then aux
-        else frac2 (n*aux) (n - 1)
-
-SIG frac : int -> int
-DEF frac x = frac2 1 x
-DEF main = frac 3
-

File test/inliner/add_1_2_mult_add_1_3.sl

+SIG add : int -> int -> int
+DEF add x y = x + y
+DEF main = add 1 2 * add 1 3

File test/inliner/fib_0.sl

+SIG fib : int -> int
+DEF fib n =
+    if n == 0
+        then 1
+        else if n == 1
+            then 1
+            else fib (n-1) + fib (n-2)
+DEF main = fib 0

File test/inliner/fib_1.sl

+SIG fib : int -> int
+DEF fib n =
+    if n == 0
+        then 1
+        else if n == 1
+            then 1
+            else fib (n-1) + fib (n-2)
+DEF main = fib 1

File test/inliner/fib_3.sl

+SIG fib : int -> int
+DEF fib n =
+    if n == 0
+        then 1
+        else if n == 1
+            then 1
+            else fib (n-1) + fib (n-2)
+DEF main = fib 3

File test/inliner/frac_tail_1_0.sl

+SIG frac : int -> int -> int
+DEF frac aux n =
+    if n == 0
+        then aux
+        else frac (n*aux) (n - 1)
+DEF main = frac 1 0
+

File test/inliner/frac_tail_1_2.sl

+SIG frac : int -> int -> int
+DEF frac aux n =
+    if n == 0
+        then aux
+        else frac (n*aux) (n - 1)
+DEF main = frac 1 2
+

File test/inliner/frac_tail_1_5.sl

+SIG frac : int ->  int -> int
+DEF frac aux n =
+    if n == 0
+        then aux
+        else frac (n*aux) (n - 1)
+DEF main = frac 1 5
+

File test/inliner/frac_tail_helper_3.sl

+SIG frac2 : int -> int -> int
+DEF frac2 aux n =
+    if n == 0
+        then aux
+        else frac2 (n*aux) (n - 1)
+
+SIG frac : int -> int
+DEF frac x = frac2 1 x
+DEF main = frac 3
+

File test/inliner/head_map_list.sl

+DEF nil c1 c2 = c1
+DEF cons x xs c1 c2 = c2 x xs
+DEF map f xs = xs nil (fun y ys => cons (f y) (map f ys))
+DEF list = cons 0 (cons 1 (cons 2 nil))
+DEF head xs = xs 0 (fun x xs => x)
+DEF main = head (map (fun x => x + 1) list)

File test/inliner/mutual_not_wf.sl

+SIG f : int -> int -> int
+SIG g : int -> int
+DEF f x (y:int) = g x
+DEF g x = f x x
+
+DEF main = 4
+

File test/inliner/rebuild_nat_3.sl

+SIG rebuild : int -> int
+DEF succ n = n + 1
+DEF pred n = n - 1
+
+DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
+DEF main = rebuild 3
+

File test/inliner/rebuild_nat_3_add_2.sl

+SIG rebuild : int -> int
+DEF succ n = n + 1
+DEF pred n = n - 1
+
+DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
+DEF main = rebuild 3 + rebuild 2
+

File test/inliner/rebuild_nat_rebuild_3_add_2.sl

+SIG rebuild : int -> int
+DEF succ n = n + 1
+DEF pred n = n - 1
+
+DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
+DEF main = rebuild (rebuild 3 + rebuild 2)
+

File test/rebuild01.sl

-SIG rebuild : int -> int
-DEF succ n = n + 1
-DEF pred n = n - 1
-
-DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
-DEF main = rebuild 3
-

File test/rebuild02.sl

-SIG rebuild : int -> int
-DEF succ n = n + 1
-DEF pred n = n - 1
-
-DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
-DEF main = rebuild 3 + rebuild 2
-

File test/rebuild03.sl

-SIG rebuild : int -> int
-DEF succ n = n + 1
-DEF pred n = n - 1
-
-DEF rebuild n = if n == 0 then 0 else succ (rebuild (pred n))
-DEF main = rebuild (rebuild 3 + rebuild 2)
-