Commit d1bd5d3b authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Adjusted Lifting to compile with GHC 7.10

parent e829466a
......@@ -2,6 +2,7 @@
Module : $Header$
Description : Lifting of lambda-expressions and local functions
Copyright : (c) 2001 - 2003 Wolfgang Lux
2011 - 2015 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -17,10 +18,14 @@
Then all local function declarations are collected and lifted to the
top-level.
-}
{-# LANGUAGE CPP #-}
module Transformations.Lift (lift) where
import Control.Monad (liftM, liftM2)
#if __GLASGOW_HASKELL__ >= 710
import Control.Applicative ((<$>))
#else
import Control.Applicative ((<$>), (<*>))
#endif
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List
import qualified Data.Map as Map (Map, empty, insert, lookup)
......@@ -39,14 +44,17 @@ import Env.Value
lift :: ValueEnv -> Module -> (Module, ValueEnv)
lift tyEnv (Module ps m es is ds) = (lifted, valueEnv s')
where
(ds', s') = S.runState (mapM (abstractDecl "" []) ds) initState
(ds', s') = S.runState (mapM (absDecl "" []) ds) initState
initState = LiftState m tyEnv Map.empty
lifted = Module ps m es is $ concatMap liftFunDecl ds'
-- Abstraction:
-- -----------------------------------------------------------------------------
-- Abstraction
-- -----------------------------------------------------------------------------
-- Besides adding the free variables to every (local) function, the
-- abstraction pass also has to update the type environment in order to
-- reflect the new types of the expanded functions. As usual we use a
-- reflect the new types of the expanded functions. As usual, we use a
-- state monad transformer in order to pass the type environment
-- through. The environment constructed in the abstraction phase maps
-- each local function declaration onto its replacement expression,
......@@ -82,22 +90,20 @@ withLocalAbstractEnv ae act = do
S.modify $ \ s -> s { abstractEnv = old }
return res
abstractDecl :: String -> [Ident] -> Decl -> LiftM Decl
abstractDecl _ lvs (FunctionDecl p f eqs) =
FunctionDecl p f `liftM` mapM (abstractEquation lvs) eqs
abstractDecl pre lvs (PatternDecl p t rhs) =
PatternDecl p t `liftM` abstractRhs pre lvs rhs
abstractDecl _ _ d = return d
absDecl :: String -> [Ident] -> Decl -> LiftM Decl
absDecl _ lvs (FunctionDecl p f eqs) = FunctionDecl p f
<$> mapM (absEquation lvs) eqs
absDecl pre lvs (PatternDecl p t rhs) = PatternDecl p t <$> absRhs pre lvs rhs
absDecl _ _ d = return d
abstractEquation :: [Ident] -> Equation -> LiftM Equation
abstractEquation lvs (Equation p lhs@(FunLhs f ts) rhs) =
Equation p lhs `liftM` abstractRhs (idName f ++ ".") (lvs ++ bv ts) rhs
abstractEquation _ _ = error "Lift.abstractEquation: no pattern match"
absEquation :: [Ident] -> Equation -> LiftM Equation
absEquation lvs (Equation p lhs@(FunLhs f ts) rhs) =
Equation p lhs <$> absRhs (idName f ++ ".") (lvs ++ bv ts) rhs
absEquation _ _ = error "Lift.absEquation: no pattern match"
abstractRhs :: String -> [Ident] -> Rhs -> LiftM Rhs
abstractRhs pre lvs (SimpleRhs p e _) =
flip (SimpleRhs p) [] `liftM` abstractExpr pre lvs e
abstractRhs _ _ _ = error "Lift.abstractRhs: no pattern match"
absRhs :: String -> [Ident] -> Rhs -> LiftM Rhs
absRhs pre lvs (SimpleRhs p e _) = flip (SimpleRhs p) [] <$> absExpr pre lvs e
absRhs _ _ _ = error "Lift.absRhs: no simple RHS"
-- Within a declaration group we have to split the list of declarations
-- into the function and value declarations. Only the function
......@@ -142,27 +148,26 @@ abstractRhs _ _ _ = error "Lift.abstractRhs: no pattern match"
-- the desugarer at present may duplicate code. While there is no problem
-- with local variable declaration being duplicated, we must avoid to
-- lift local function declarations more than once. Therefore
-- 'abstractFunDecls' transforms only those function declarations
-- 'absFunDecls' transforms only those function declarations
-- that have not been lifted and discards the other declarations. Note
-- that it is easy to check whether a function has been lifted by
-- checking whether an entry for its untransformed name is still present
-- in the type environment.
abstractDeclGroup :: String -> [Ident]
-> [Decl] -> Expression -> LiftM Expression
abstractDeclGroup pre lvs ds e = do
absDeclGroup :: String -> [Ident] -> [Decl] -> Expression -> LiftM Expression
absDeclGroup pre lvs ds e = do
m <- getModuleIdent
abstractFunDecls pre (lvs ++ bv vds) (scc bv (qfv m) fds) vds e
where (fds,vds) = partition isFunDecl ds
abstractFunDecls :: String -> [Ident]
-> [[Decl]] -> [Decl] -> Expression
-> LiftM Expression
abstractFunDecls pre lvs [] vds e = do
vds' <- mapM (abstractDecl pre lvs) vds
e' <- abstractExpr pre lvs e
absFunDecls pre (lvs ++ bv vds) (scc bv (qfv m) fds) vds e
where (fds, vds) = partition isFunDecl ds
-- TODO: too complicated?
absFunDecls :: String -> [Ident] -> [[Decl]] -> [Decl] -> Expression
-> LiftM Expression
absFunDecls pre lvs [] vds e = do
vds' <- mapM (absDecl pre lvs) vds
e' <- absExpr pre lvs e
return (Let vds' e')
abstractFunDecls pre lvs (fds:fdss) vds e = do
absFunDecls pre lvs (fds:fdss) vds e = do
m <- getModuleIdent
env <- getAbstractEnv
let fs = bv fds
......@@ -172,18 +177,18 @@ abstractFunDecls pre lvs (fds:fdss) vds e = do
[Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]
bindF fvs' f = Map.insert f (apply (mkFun m pre f) fvs')
isLifted tyEnv f = null $ lookupValue f tyEnv
fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) getValueEnv
modifyValueEnv $ abstractFunTypes m pre fvs fs'
(fds',e') <- withLocalAbstractEnv env' $ do
fds'' <- mapM (abstractFunDecl pre fvs lvs)
fs' <- (\tyEnv -> filter (not . isLifted tyEnv) fs) <$> getValueEnv
modifyValueEnv $ absFunTypes m pre fvs fs'
(fds', e') <- withLocalAbstractEnv env' $ do
fds'' <- mapM (absFunDecl pre fvs lvs)
[d | d <- fds, any (`elem` fs') (bv d)]
e'' <- abstractFunDecls pre lvs fdss vds e
return (fds'',e'')
e'' <- absFunDecls pre lvs fdss vds e
return (fds'', e'')
return (Let fds' e')
abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]
-> ValueEnv -> ValueEnv
abstractFunTypes m pre fvs fs tyEnv = foldr abstractFunType tyEnv fs
absFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]
-> ValueEnv -> ValueEnv
absFunTypes m pre fvs fs tyEnv = foldr abstractFunType tyEnv fs
where tys = map (varType tyEnv) fvs
abstractFunType f tyEnv' =
qualBindFun m (liftIdent pre f)
......@@ -192,50 +197,49 @@ abstractFunTypes m pre fvs fs tyEnv = foldr abstractFunType tyEnv fs
(unbindFun f tyEnv')
where ty = foldr TypeArrow (varType tyEnv' f) tys
abstractFunDecl :: String -> [Ident] -> [Ident] -> Decl -> LiftM Decl
abstractFunDecl pre fvs lvs (FunctionDecl p f eqs) =
abstractDecl pre lvs (FunctionDecl p f' (map (addVars f') eqs))
absFunDecl :: String -> [Ident] -> [Ident] -> Decl -> LiftM Decl
absFunDecl pre fvs lvs (FunctionDecl p f eqs) =
absDecl pre lvs (FunctionDecl p f' (map (addVars f') eqs))
where
f' = liftIdent pre f
addVars f1 (Equation p1 (FunLhs _ ts) rhs) =
Equation p1 (FunLhs f1 (map VariablePattern fvs ++ ts)) rhs
addVars _ _ = error "Lift.abstractFunDecl.addVars: no pattern match"
abstractFunDecl pre _ _ (ForeignDecl p cc ie f ty) =
addVars _ _ = error "Lift.absFunDecl.addVars: no pattern match"
absFunDecl pre _ _ (ForeignDecl p cc ie f ty) =
return $ ForeignDecl p cc ie (liftIdent pre f) ty
abstractFunDecl _ _ _ _ = error "Lift.abstractFunDecl: no pattern match"
absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"
abstractExpr :: String -> [Ident] -> Expression -> LiftM Expression
abstractExpr _ _ l@(Literal _) = return l
abstractExpr pre lvs var@(Variable v)
absExpr :: String -> [Ident] -> Expression -> LiftM Expression
absExpr _ _ l@(Literal _) = return l
absExpr pre lvs var@(Variable v)
| isQualified v = return var
| otherwise = do
env <- getAbstractEnv
case Map.lookup (unqualify v) env of
getAbstractEnv >>= \env -> case Map.lookup (unqualify v) env of
Nothing -> return var
Just v' -> abstractExpr pre lvs v'
abstractExpr _ _ c@(Constructor _) = return c
abstractExpr pre lvs (Apply e1 e2) =
liftM2 Apply (abstractExpr pre lvs e1) (abstractExpr pre lvs e2)
abstractExpr pre lvs (Let ds e) = abstractDeclGroup pre lvs ds e
abstractExpr pre lvs (Case r ct e alts) =
liftM2 (Case r ct) (abstractExpr pre lvs e)
(mapM (abstractAlt pre lvs) alts)
abstractExpr pre lvs (Typed e ty) = flip Typed ty `liftM`
abstractExpr pre lvs e
abstractExpr _ _ _ = internalError "Lift.abstractExpr"
abstractAlt :: String -> [Ident] -> Alt -> LiftM Alt
abstractAlt pre lvs (Alt p t rhs) =
Alt p t `liftM` abstractRhs pre (lvs ++ bv t) rhs
-- Lifting:
Just v' -> absExpr pre lvs v'
absExpr _ _ c@(Constructor _) = return c
absExpr pre lvs (Apply e1 e2) = Apply <$> absExpr pre lvs e1
<*> absExpr pre lvs e2
absExpr pre lvs (Let ds e) = absDeclGroup pre lvs ds e
absExpr pre lvs (Case r ct e bs) = Case r ct <$> absExpr pre lvs e
<*> mapM (absAlt pre lvs) bs
absExpr pre lvs (Typed e ty) = flip Typed ty <$> absExpr pre lvs e
absExpr _ _ e = internalError $ "Lift.absExpr: " ++ show e
absAlt :: String -> [Ident] -> Alt -> LiftM Alt
absAlt pre lvs (Alt p t rhs) = Alt p t <$> absRhs pre (lvs ++ bv t) rhs
-- -----------------------------------------------------------------------------
-- Lifting
-- -----------------------------------------------------------------------------
-- After the abstraction pass, all local function declarations are lifted
-- to the top-level.
liftFunDecl :: Decl -> [Decl]
liftFunDecl (FunctionDecl p f eqs) = (FunctionDecl p f eqs' : concat dss')
where (eqs', dss') = unzip $ map liftEquation eqs
liftFunDecl d = [d]
liftFunDecl d = [d]
liftVarDecl :: Decl -> (Decl, [Decl])
liftVarDecl (PatternDecl p t rhs) = (PatternDecl p t rhs', ds')
......
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