diff --git a/DDC/Core/Analysis/Arity.hs b/DDC/Core/Analysis/Arity.hs --- a/DDC/Core/Analysis/Arity.hs +++ b/DDC/Core/Analysis/Arity.hs @@ -35,7 +35,7 @@ -- | Empty arities context. -emptyArities :: Ord n => Arities n +emptyArities :: Arities n emptyArities = (Map.empty, []) @@ -101,7 +101,7 @@ -- | Retrieve binders from case pattern, so we can extend the arity context. -- We don't know anything about their values, so record as 0. -aritiesOfPat :: Ord n => Pat n -> [(Bind n, Int)] +aritiesOfPat :: Pat n -> [(Bind n, Int)] aritiesOfPat p = case p of PDefault -> [] diff --git a/DDC/Core/Analysis/Usage.hs b/DDC/Core/Analysis/Usage.hs --- a/DDC/Core/Analysis/Usage.hs +++ b/DDC/Core/Analysis/Usage.hs @@ -97,7 +97,9 @@ , moduleImportCaps = importCaps , moduleImportValues = importValues , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = body }) = ModuleCore @@ -109,7 +111,9 @@ , moduleImportCaps = importCaps , moduleImportValues = importValues , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = usageX body } diff --git a/DDC/Core/Simplifier/Apply.hs b/DDC/Core/Simplifier/Apply.hs --- a/DDC/Core/Simplifier/Apply.hs +++ b/DDC/Core/Simplifier/Apply.hs @@ -6,7 +6,7 @@ , applySimplifierX , applyTransformX) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Fragment @@ -15,23 +15,25 @@ import DDC.Core.Transform.Beta import DDC.Core.Transform.Bubble import DDC.Core.Transform.Elaborate -import DDC.Core.Transform.Eta as Eta +import DDC.Core.Transform.Eta as Eta import DDC.Core.Transform.Flatten -import DDC.Core.Transform.Forward as Forward +import DDC.Core.Transform.Forward as Forward import DDC.Core.Transform.Inline -import DDC.Core.Transform.Lambdas import DDC.Core.Transform.Namify import DDC.Core.Transform.Prune import DDC.Core.Transform.Rewrite -import DDC.Core.Transform.Snip as Snip -import DDC.Core.Transform.FoldCase as FoldCase -import DDC.Type.Env (KindEnv, TypeEnv) -import Data.Typeable (Typeable) +import qualified DDC.Core.Transform.Lambdas as Lambdas +import qualified DDC.Core.Transform.Snip as Snip +import qualified DDC.Core.Transform.FoldCase as FoldCase + +import DDC.Data.Name +import DDC.Type.Env (KindEnv, TypeEnv) +import Data.Typeable (Typeable) import Control.Monad.State.Strict -import DDC.Base.Name -import qualified DDC.Base.Pretty as P -import qualified Data.Set as Set -import Prelude hiding ((<$>)) +import qualified DDC.Data.Pretty as P +import qualified DDC.Core.Env.EnvX as EnvX +import qualified Data.Set as Set +import Prelude hiding ((<$>)) -- Modules -------------------------------------------------------------------- @@ -149,13 +151,18 @@ -> let config = Forward.Config (const FloatAllow) False in return $ forwardModule profile config mm - FoldCase config -> res $ foldCase config mm + FoldCase config -> res $ FoldCase.foldCase config mm Inline getDef -> res $ inline getDef Set.empty mm - Lambdas -> res $ lambdasModule profile mm + + Lambdas + -> res + $ Lambdas.evalState "l" + $ Lambdas.lambdasModule profile mm + Namify namK namT -> namifyUnique namK namT mm >>= res Prune -> res $ pruneModule profile mm Rewrite rules -> res $ rewriteModule rules mm - Snip config -> res $ snip config mm + Snip config -> res $ Snip.snip config mm -- Expressions ---------------------------------------------------------------- @@ -286,14 +293,18 @@ -> State s (TransformResult (Exp a n)) applyTransformX !profile !kenv !tenv !spec !xx - = let res x = return $ resultDone (show $ ppr spec) x + = let res x = return $ resultDone (show $ ppr spec) x + env = EnvX.fromPrimEnvs + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) in case spec of Id -> res xx Anonymize -> res $ anonymizeX xx Beta config -> return $ betaReduce profile config xx Bubble -> res $ bubbleX kenv tenv xx Elaborate{} -> res $ elaborateX xx - Eta config -> return $ Eta.etaX profile config kenv tenv xx + Eta config -> return $ Eta.etaX profile config env xx Flatten -> res $ flatten xx Forward @@ -301,10 +312,11 @@ in return $ forwardX profile config xx Inline getDef -> res $ inline getDef Set.empty xx - FoldCase config -> res $ foldCase config xx + FoldCase config -> res $ FoldCase.foldCase config xx Lambdas -> res $ xx Namify namK namT -> namifyUnique namK namT xx >>= res - Prune -> return $ pruneX profile kenv tenv xx + Prune -> return $ pruneX profile env xx Rewrite rules -> return $ rewriteX rules xx - Snip config -> res $ snip config xx + Snip config -> res $ Snip.snip config xx + diff --git a/DDC/Core/Simplifier/Base.hs b/DDC/Core/Simplifier/Base.hs --- a/DDC/Core/Simplifier/Base.hs +++ b/DDC/Core/Simplifier/Base.hs @@ -19,7 +19,7 @@ import DDC.Core.Transform.Namify import DDC.Core.Exp import DDC.Type.Env -import DDC.Base.Pretty +import DDC.Data.Pretty import qualified DDC.Core.Transform.Snip as Snip import qualified DDC.Core.Transform.Eta as Eta import qualified DDC.Core.Transform.Beta as Beta @@ -120,7 +120,6 @@ -- | Introduce let-bindings for nested applications. | Snip Snip.Config - -- | Function to get the inliner template (unfolding) for the given name. diff --git a/DDC/Core/Simplifier/Lexer.hs b/DDC/Core/Simplifier/Lexer.hs --- a/DDC/Core/Simplifier/Lexer.hs +++ b/DDC/Core/Simplifier/Lexer.hs @@ -3,7 +3,6 @@ ( Tok(..) , lexSimplifier) where -import DDC.Data.Token import DDC.Data.SourcePos import Data.Char @@ -11,10 +10,10 @@ lexSimplifier :: (String -> Maybe n) -- ^ Function to read a name. -> String -- ^ String to parse. - -> [Token (Tok n)] + -> [Located (Tok n)] lexSimplifier readName str - = map (\t -> Token t (SourcePos "" 0 0)) + = map (\t -> Located (SourcePos "" 0 0) t) $ lexer readName str diff --git a/DDC/Core/Simplifier/Parser.hs b/DDC/Core/Simplifier/Parser.hs --- a/DDC/Core/Simplifier/Parser.hs +++ b/DDC/Core/Simplifier/Parser.hs @@ -9,15 +9,14 @@ import DDC.Core.Module import DDC.Type.Env import DDC.Core.Simplifier.Lexer -import DDC.Data.Token import DDC.Data.SourcePos -import DDC.Base.Parser (pTok) +import DDC.Control.Parser (pTok) import Data.Set (Set) import qualified DDC.Core.Transform.Snip as Snip import qualified DDC.Core.Transform.Beta as Beta import qualified DDC.Core.Transform.Eta as Eta import qualified DDC.Core.Transform.FoldCase as FoldCase -import qualified DDC.Base.Parser as P +import qualified DDC.Control.Parser as P import qualified Data.Map as Map import qualified Data.Set as Set @@ -55,7 +54,7 @@ -> Either P.ParseError (Simplifier s a n) parseSimplifier readName details str - = let kend = Token KEnd (SourcePos "" 0 0) + = let kend = Located (SourcePos "" 0 0) KEnd toks = lexSimplifier readName str ++ [kend] in P.runTokenParser show "" (pSimplifier details) @@ -152,7 +151,7 @@ -- | Parse an inlining specification. pInlinerSpec - :: (Ord n, Show n) + :: Ord n => Parser n (ModuleName, InlineSpec n) pInlinerSpec diff --git a/DDC/Core/Simplifier/Recipe.hs b/DDC/Core/Simplifier/Recipe.hs --- a/DDC/Core/Simplifier/Recipe.hs +++ b/DDC/Core/Simplifier/Recipe.hs @@ -91,8 +91,6 @@ snipOver = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True }) - - -- Compound ------------------------------------------------------------------- -- | Conversion to administrative normal-form. anormalize diff --git a/DDC/Core/Simplifier/Result.hs b/DDC/Core/Simplifier/Result.hs --- a/DDC/Core/Simplifier/Result.hs +++ b/DDC/Core/Simplifier/Result.hs @@ -5,9 +5,9 @@ , NoInformation , resultDone) where -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.Typeable -import qualified DDC.Base.Pretty as P +import qualified DDC.Data.Pretty as P -- TransformResult ------------------------------------------------------------ diff --git a/DDC/Core/Transform/AnonymizeX.hs b/DDC/Core/Transform/AnonymizeX.hs --- a/DDC/Core/Transform/AnonymizeX.hs +++ b/DDC/Core/Transform/AnonymizeX.hs @@ -8,7 +8,7 @@ import DDC.Core.Module import DDC.Core.Exp import DDC.Type.Transform.AnonymizeT -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import Data.List import Data.Set (Set) import qualified Data.Set as Set diff --git a/DDC/Core/Transform/Beta.hs b/DDC/Core/Transform/Beta.hs --- a/DDC/Core/Transform/Beta.hs +++ b/DDC/Core/Transform/Beta.hs @@ -7,7 +7,6 @@ , Info (..) , betaReduce) where -import DDC.Base.Pretty import DDC.Core.Exp.Annot import DDC.Core.Fragment import DDC.Core.Transform.TransformUpX @@ -15,11 +14,13 @@ import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteXX import DDC.Core.Simplifier.Result + +import DDC.Data.Pretty +import DDC.Core.Env.EnvX (EnvX) import Control.Monad.Writer (Writer, runWriter, tell) import Data.Typeable (Typeable) -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env import Prelude hiding ((<$>)) +import qualified DDC.Core.Env.EnvX as EnvX ------------------------------------------------------------------------------- @@ -97,7 +98,7 @@ betaReduce profile config x = {-# SCC betaReduce #-} let (x', info) = runWriter - $ transformUpMX (betaReduce1 profile config) Env.empty Env.empty x + $ transformUpMX (betaReduce1 profile config) EnvX.empty x -- Check if any actual work was performed progress @@ -124,12 +125,11 @@ :: Ord n => Profile n -- ^ Language profile. -> Config -- ^ Beta tranform config. - -> KindEnv n -- ^ Current kind environment. - -> TypeEnv n -- ^ Current type environment. + -> EnvX n -- ^ Current environment -> Exp a n -- ^ Expression to transform. -> Writer Info (Exp a n) -betaReduce1 _profile config _kenv _tenv xx +betaReduce1 _profile config _env xx = let ret info x = tell info >> return x in case xx of diff --git a/DDC/Core/Transform/Boxing.hs b/DDC/Core/Transform/Boxing.hs --- a/DDC/Core/Transform/Boxing.hs +++ b/DDC/Core/Transform/Boxing.hs @@ -20,7 +20,6 @@ where import DDC.Core.Module import DDC.Core.Exp.Annot -import DDC.Core.Pretty import DDC.Type.Transform.Instantiate import Data.Maybe @@ -73,7 +72,7 @@ -- Module ----------------------------------------------------------------------------------------- -- | Manage boxing in a module. boxingModule - :: (Show a, Show n, Pretty n, Ord n) + :: Ord n => Config a n -> Module a n -> Module a n boxingModule config mm @@ -110,12 +109,12 @@ -- Convert literals to their unboxed form, followed by a boxing conversion. XCon a (DaConPrim n tLit) | Just RepBoxed <- configRepOfType config tLit - -> let Just tLitU = configConvertRepType config RepUnboxed tLit - Just nU = configUnboxLitName config n + , Just tLitU <- configConvertRepType config RepUnboxed tLit + , Just nU <- configUnboxLitName config n - Just xLit = configConvertRepExp config RepBoxed a tLitU - $ XCon a (DaConPrim nU tLitU) - in xLit + , Just xLit <- configConvertRepExp config RepBoxed a tLitU + $ XCon a (DaConPrim nU tLitU) + -> xLit -- Use unboxed versions of primops by unboxing their arguments then -- reboxing their results. @@ -129,6 +128,7 @@ tPrimBoxed tPrimUnboxed xsArgsAll' + -- Unbox primitive applications. XApp a _ _ | Just (n, xsArgsAll) <- takeXPrimApps xx , Just n' <- configUnboxPrimOpName config n @@ -147,7 +147,7 @@ -> let xsArgsAll' = map (boxingX config) xsArgsAll in boxingForeignSea config a xx xFn tForeign xsArgsAll' - + -- Unbox literal patterns in alternatives. XCase a xScrut alts | p : _ <- [ p | AAlt (PData p@DaConPrim{} []) _ <- alts] , Just tLit1 <- configValueTypeOfLitName config (daConName p) @@ -187,7 +187,7 @@ -- * Assumes that the type of the primitive is in prenex form. -- boxingPrimitive - :: (Ord n, Pretty n, Show a, Show n) + :: Ord n => Config a n -> a -> Bool -- ^ Primitive is being run at the call site. -> Exp a n -- ^ Whole primitive application, for debugging. @@ -212,7 +212,7 @@ -- Get the unboxed version of the types of parameters and return value. tPrimUnboxedInst <- instantiateTs tPrimUnboxed tsArgs - let (tsParamUnboxed, tResultUnboxed) + let (_tsParamUnboxed, tResultUnboxed) = takeTFunArgResult tPrimUnboxedInst -- If the primitive is being run at the call site then we need to @@ -227,10 +227,10 @@ -- If not then the primop is partially applied or something else is wrong. -- The Tetra to Salt conversion will give a proper error message -- if the primop is indeed partially applied. - (if not ( length xsArgs == length tsParamBoxed - && length xsArgs == length tsParamUnboxed) - then Nothing - else Just ()) +-- (if not ( length xsArgs == length tsParamBoxed +-- && length xsArgs == length tsParamUnboxed) +-- then Nothing +-- else Just ()) -- We got a type for each argument, so the primop is fully applied -- and we can do the boxing/unboxing transform. @@ -259,7 +259,7 @@ -- * Assumes that the type of the imported thing is in prenex form. -- boxingForeignSea - :: (Ord n, Pretty n) + :: Ord n => Config a n -> a -> Exp a n -- ^ Whole function application, for debugging. -> Exp a n -- ^ Functional expression. diff --git a/DDC/Core/Transform/Elaborate.hs b/DDC/Core/Transform/Elaborate.hs --- a/DDC/Core/Transform/Elaborate.hs +++ b/DDC/Core/Transform/Elaborate.hs @@ -7,7 +7,7 @@ where import DDC.Core.Exp import DDC.Core.Module -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import DDC.Data.ListUtils import Control.Monad import Control.Arrow diff --git a/DDC/Core/Transform/Eta.hs b/DDC/Core/Transform/Eta.hs --- a/DDC/Core/Transform/Eta.hs +++ b/DDC/Core/Transform/Eta.hs @@ -20,12 +20,12 @@ import DDC.Core.Transform.BoundT import DDC.Core.Simplifier.Result import DDC.Core.Pretty -import DDC.Type.Env (TypeEnv, KindEnv) import DDC.Type.Transform.AnonymizeT import Control.Monad.Writer (Writer, tell, runWriter) import Data.Typeable -import qualified DDC.Type.Env as Env -import Prelude hiding ((<$>)) +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Env.EnvX as EnvX +import Prelude hiding ((<$>)) ------------------------------------------------------------------------------- @@ -78,14 +78,19 @@ -> TransformResult (Module a n) etaModule profile config mm - = let cconfig = Check.configOfProfile profile - kenv' = Env.union (profilePrimKinds profile) (moduleKindEnv mm) - tenv' = Env.union (profilePrimTypes profile) (moduleTypeEnv mm) + = let + -- Slurp type checker config. + cconfig = Check.configOfProfile profile + + -- Slurp the top level environment. + env = moduleEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + mm -- Run the eta transform. - (mm', info) - = runWriter - $ etaM config cconfig kenv' tenv' mm + (mm', info) = runWriter $ etaM config cconfig env mm -- Check if any actual work was performed progress @@ -104,20 +109,17 @@ etaX :: (Ord n, Show n, Show a, Pretty n) => Profile n -- ^ Language profile. -> Config -- ^ Eta-transform config. - -> KindEnv n -- ^ Kind environment. - -> TypeEnv n -- ^ Type environment. + -> EnvX n -- ^ Type checker environment. -> Exp a n -- ^ Expression to transform. -> TransformResult (Exp a n) -etaX profile config kenv tenv xx +etaX profile config env xx = let cconfig = Check.configOfProfile profile - kenv' = Env.union (profilePrimKinds profile) kenv - tenv' = Env.union (profilePrimTypes profile) tenv -- Run the eta transform. (xx', info) = runWriter - $ etaM config cconfig kenv' tenv' xx + $ etaM config cconfig env xx -- Check if any actual work was performed progress @@ -137,33 +139,32 @@ etaM :: (Show a, Ord n, Pretty n, Show n) => Config -- ^ Eta-transform config. -> Check.Config n -- ^ Type checker config. - -> KindEnv n -- ^ Kind environment. - -> TypeEnv n -- ^ Type environment. + -> EnvX n -- ^ Type checker environment. -> c a n -- ^ Do eta-expansion in this thing. -> Writer Info (c a n) instance Eta Module where - etaM config cconfig kenv tenv mm - = do let kenv' = Env.union (moduleKindEnv mm) kenv - let tenv' = Env.union (moduleTypeEnv mm) tenv - xx' <- etaM config cconfig kenv' tenv' (moduleBody mm) + etaM config cconfig envx mm + = do -- The top level environment of the module is added + -- by the etaModule wrapper, so we don't need to do it again. + xx' <- etaM config cconfig envx (moduleBody mm) return $ mm { moduleBody = xx' } instance Eta Exp where - etaM config cconfig kenv tenv xx - = let down = etaM config cconfig kenv tenv + etaM config cconfig env xx + = let down = etaM config cconfig env in case xx of XVar a _ | configExpand config - , Right tX <- Check.typeOfExp cconfig kenv tenv xx + , Right tX <- Check.typeOfExp cconfig env xx -> do etaExpand a tX xx XApp a _ _ | configExpand config - , Right tX <- Check.typeOfExp cconfig kenv tenv xx + , Right tX <- Check.typeOfExp cconfig env xx -> do -- Decend into the arguments first. -- We don't need to decend into the function part because @@ -175,26 +176,28 @@ etaExpand a tX $ xApps a x xs_eta XLAM a b x - -> do let kenv' = Env.extend b kenv - x' <- etaM config cconfig kenv' tenv x + -> do let env' = EnvX.extendT b env + x' <- etaM config cconfig env' x return $ XLAM a b x' XLam a b x - -> do let tenv' = Env.extend b tenv - x' <- etaM config cconfig kenv tenv' x + -> do let env' = EnvX.extendX b env + x' <- etaM config cconfig env' x return $ XLam a b x' XLet a lts x2 -> do lts' <- down lts let (bs1, bs0) = bindsOfLets lts - let kenv' = Env.extends bs1 kenv - let tenv' = Env.extends bs0 tenv - x2' <- etaM config cconfig kenv' tenv' x2 + + let env' = EnvX.extendsT bs1 + $ EnvX.extendsX bs0 env + + x2' <- etaM config cconfig env' x2 return $ XLet a lts' x2' XCase a x alts -> do x' <- down x - alts' <- mapM (etaM config cconfig kenv tenv) alts + alts' <- mapM (etaM config cconfig env) alts return $ XCase a x' alts' XCast a cc x @@ -205,8 +208,8 @@ instance Eta Lets where - etaM config cconfig kenv tenv lts - = let down = etaM config cconfig kenv tenv + etaM config cconfig env lts + = let down = etaM config cconfig env in case lts of LLet b x -> do x' <- down x @@ -214,8 +217,8 @@ LRec bxs -> do let bs = map fst bxs - let tenv' = Env.extends bs tenv - xs' <- mapM (etaM config cconfig kenv tenv') + let env' = EnvX.extendsX bs env + xs' <- mapM (etaM config cconfig env') $ map snd bxs return $ LRec (zip bs xs') @@ -224,12 +227,12 @@ instance Eta Alt where - etaM config cconfig kenv tenv alt + etaM config cconfig env alt = case alt of AAlt p x -> do let bs = bindsOfPat p - let tenv' = Env.extends bs tenv - x' <- etaM config cconfig kenv tenv' x + let env' = EnvX.extendsX bs env + x' <- etaM config cconfig env' x return $ AAlt p x' diff --git a/DDC/Core/Transform/Flatten.hs b/DDC/Core/Transform/Flatten.hs --- a/DDC/Core/Transform/Flatten.hs +++ b/DDC/Core/Transform/Flatten.hs @@ -125,7 +125,7 @@ flatten1 x = x -liftAcrossX :: Ord n => [Bind n] -> [Bind n] -> Exp a n -> Exp a n +liftAcrossX :: [Bind n] -> [Bind n] -> Exp a n -> Exp a n liftAcrossX bsDepth bsLevels x = let depth = length [b | b@(BAnon _) <- bsDepth] levels = length [b | b@(BAnon _) <- bsLevels] diff --git a/DDC/Core/Transform/FoldCase.hs b/DDC/Core/Transform/FoldCase.hs --- a/DDC/Core/Transform/FoldCase.hs +++ b/DDC/Core/Transform/FoldCase.hs @@ -28,7 +28,7 @@ --------------------------------------------------------------------------------------------------- -type FoldCase a n = State (M.Map n (DaCon n, [Exp a n])) +type FoldCase a n = State (M.Map n (DaCon n (Type n), [Exp a n])) foldCase :: (Ord n, TransformDownMX (FoldCase a n) c) => Config @@ -43,6 +43,7 @@ => Config -> Exp a n -> FoldCase a n (Exp a n) + -- Collect ---------------------------------------------------------------------------------------- foldCaseX _ diff --git a/DDC/Core/Transform/Forward.hs b/DDC/Core/Transform/Forward.hs --- a/DDC/Core/Transform/Forward.hs +++ b/DDC/Core/Transform/Forward.hs @@ -7,7 +7,7 @@ , forwardModule , forwardX) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Analysis.Usage import DDC.Core.Exp.Annot import DDC.Core.Module @@ -138,7 +138,9 @@ , moduleImportCaps = importCaps , moduleImportValues = importValues , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = body }) = do body' <- forwardWith profile config bindings body @@ -151,7 +153,9 @@ , moduleImportCaps = importCaps , moduleImportValues = importValues , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = body' } diff --git a/DDC/Core/Transform/Inline/Templates.hs b/DDC/Core/Transform/Inline/Templates.hs --- a/DDC/Core/Transform/Inline/Templates.hs +++ b/DDC/Core/Transform/Inline/Templates.hs @@ -39,7 +39,7 @@ -- about lifting indices in templates when we go under binders. -- lookupTemplateFromModules - :: (Eq n, Ord n, Show n) + :: (Ord n, Show n) => Map ModuleName (InlineSpec n) -- ^ Inliner specifications for the modules. -> [Module a n] -- ^ Modules to use for inliner templates. @@ -62,7 +62,7 @@ lookupTemplateFromModule - :: (Eq n, Ord n, Show n) + :: Ord n => InlineSpec n -- ^ Inliner specification for this module. -> Module a n -- ^ Module to use for inliner templates. -> n @@ -81,7 +81,7 @@ -- | Decide whether we should inline the binding with this name based on the -- provided inliner specification. shouldInline - :: (Ord n, Show n) + :: Ord n => InlineSpec n -> n -> Bool shouldInline spec n diff --git a/DDC/Core/Transform/Lambdas.hs b/DDC/Core/Transform/Lambdas.hs --- a/DDC/Core/Transform/Lambdas.hs +++ b/DDC/Core/Transform/Lambdas.hs @@ -1,7 +1,11 @@ module DDC.Core.Transform.Lambdas - (lambdasModule) + ( lambdasModule + , evalState + , newVar) where +import DDC.Core.Transform.Lambdas.Lift +import DDC.Core.Transform.Lambdas.Base import DDC.Core.Fragment import DDC.Core.Collect.Support import DDC.Core.Transform.SubstituteXX @@ -9,17 +13,14 @@ import DDC.Core.Exp.Annot.Context import DDC.Core.Exp.Annot.Ctx import DDC.Core.Exp.Annot -import DDC.Type.Collect -import DDC.Base.Pretty -import DDC.Base.Name -import Data.Function -import Data.List -import Data.Set (Set) -import Data.Map (Map) -import qualified DDC.Core.Check as Check -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set -import qualified Data.Map as Map +import DDC.Type.Transform.SubstituteT +import DDC.Data.Pretty +import DDC.Data.Name +import qualified DDC.Type.Env as Env +import qualified DDC.Type.DataDef as DataDef +import qualified DDC.Core.Env.EnvX as EnvX +import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Maybe @@ -29,167 +30,208 @@ :: ( Show a, Pretty a , Show n, Pretty n, Ord n, CompoundName n) => Profile n - -> Module a n -> Module a n + -> Module a n + -> S (Module a n) lambdasModule profile mm - = let + = do -- Take the top-level environment of the module. - defs = moduleDataDefs mm - kenv = moduleKindEnv mm - tenv = moduleTypeEnv mm - c = Context - kenv tenv - (Env.fromList - [BName n t | (n, ImportCapAbstract t) <- moduleImportCaps mm]) - (CtxTop defs kenv tenv) + let env = moduleEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + mm - x' = lambdasLoopX profile c $ moduleBody mm + let c = Context env (CtxTop env) + x' <- lambdasLoopX profile c $ moduleBody mm - in beautifyModule + return $ mm { moduleBody = x' } ---------------------------------------------------------------------------------------------------- --- | Result of lambda lifter recursion. -data Result a n - = Result - Bool -- Whether we've made progress in this pass. - [(Bind n, Exp a n)] -- Lifted bindings - -instance Ord n => Monoid (Result a n) where - mempty - = Result False [] - - mappend (Result p1 lts1) (Result p2 lts2) - = Result (p1 || p2) (lts1 ++ lts2) - - -- Exp -------------------------------------------------------------------------------------------- lambdasLoopX :: (Show n, Show a, Pretty n, Pretty a, CompoundName n, Ord n) => Profile n -- ^ Language profile. -> Context a n -- ^ Enclosing context. -> Exp a n -- ^ Expression to perform lambda lifting on. - -> Exp a n -- Replacement expression. + -> S (Exp a n) -- Replacement expression. lambdasLoopX p c xx - = let (xx1, Result progress _) = lambdasX p c xx - in if progress then lambdasLoopX p c xx1 - else xx1 + = do (xx1, Result progress _) + <- lambdasTopX p c xx + if progress + then lambdasLoopX p c xx1 + else return xx1 +-- | Handle the expression that defines the body of the module +-- separately. The body is a letrec that contains the top level +-- bindings, and we don't want to lift them out further. +lambdasTopX p c xx + = case xx of + XLet a lts xBody + -> do (lts', r1) <- lambdasTopLets p c a xBody lts + (x', r2) <- enterLetBody c a lts xBody (lambdasTopX p) + return ( foldr (XLet a) x' lts' + , mappend r1 r2) + + _ -> lambdasX p c xx + + +-- | Handle the top-level group of bindings. +lambdasTopLets p c a xBody lts + = case lts of + LRec bxs + -> do (bxs', r) <- lambdasLetRec p c a [] bxs xBody + return ([LRec bxs'], r) + + _ -> lambdasLets p c a xBody lts + + +--------------------------------------------------------------------------------------------------- -- | Perform a single pass of lambda lifting in an expression. lambdasX :: (Show n, Show a, Pretty n, Pretty a, CompoundName n, Ord n) => Profile n -- ^ Language profile. -> Context a n -- ^ Enclosing context. -> Exp a n -- ^ Expression to perform lambda lifting on. - -> ( Exp a n -- Replacement expression - , Result a n) -- Lifter result. + -> S ( Exp a n -- Replacement expression + , Result a n) -- Lifter result. lambdasX p c xx = case xx of - XVar{} -> (xx, mempty) - XCon{} -> (xx, mempty) + XVar{} + -> return (xx, mempty) + + XCon a (DaConBound nCon) + -> do mResult <- etaXConApp p c a xx nCon [] + case mResult of + Nothing -> return (xx, mempty) + Just result -> return result + + XCon{} + -> return (xx, mempty) -- Lift type lambdas to top-level. XLAM a b x0 -> enterLAM c a b x0 $ \c' x - -> let (x', r) = lambdasX p c' x - xx' = XLAM a b x' - Result _ bxs = r + -> do (x', r) <- lambdasX p c' x + let xx' = XLAM a b x' + let Result _ bxs = r -- Decide whether to lift this lambda to top-level. -- If there are multiple nested lambdas then we want to lift -- the whole group at once, rather than lifting each one -- individually. - liftMe = isLiftyContext (contextCtx c) && null bxs - - in if liftMe - then let us' = supportEnvFlags - $ support Env.empty Env.empty xx' + let liftMe = isLiftyContext (contextCtx c) && null bxs + if liftMe + then do + let us' = supportEnvFlags + $ support Env.empty Env.empty xx' - (xCall, bLifted, xLifted) - = liftLambda p c us' a [(True, b)] x' + (xCall, bLifted, xLifted) + <- liftLambda p c us' a [(True, b)] x' - in ( xCall - , Result True (bxs ++ [(bLifted, xLifted)])) + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) - else (xx', r) + else return (xx', r) -- Lift value lambdas to top-level. XLam a b x0 -> enterLam c a b x0 $ \c' x - -> let (x', r) = lambdasX p c' x - xx' = XLam a b x' - Result _ bxs = r + -> do (x', r) <- lambdasX p c' x + let xx' = XLam a b x' + let Result _ bxs = r -- Decide whether to lift this lambda to top-level. - liftMe = isLiftyContext (contextCtx c) && null bxs + let liftMe = isLiftyContext (contextCtx c) && null bxs - in if liftMe - then let us' = supportEnvFlags + if liftMe + then do + let us' = supportEnvFlags $ support Env.empty Env.empty xx' - (xCall, bLifted, xLifted) - = liftLambda p c us' a [(False, b)] x' + (xCall, bLifted, xLifted) + <- liftLambda p c us' a [(False, b)] x' - in ( xCall - , Result True (bxs ++ [(bLifted, xLifted)])) - else (xx', r) + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) + else return (xx', r) + -- Lift suspensions to top-level. -- These behave like zero-arity lambda expressions, - -- they suspspend evaluation but do not abstract over a value. + -- they suspend evaluation but do not abstract over a value. XCast a cc@CastBox x0 -> enterCastBody c a cc x0 $ \c' x - -> let (x', r) = lambdasX p c' x - xx' = XCast a CastBox x' - Result _ bxs = r + -> do (x', r) <- lambdasX p c' x + let xx' = XCast a CastBox x' + let Result _ bxs = r -- Decide whether to lift this box to top-level. - liftMe = isLiftyContext (contextCtx c) && null bxs + let liftMe = isLiftyContext (contextCtx c) && null bxs - in if liftMe - then let us' = supportEnvFlags - $ support Env.empty Env.empty xx' + if liftMe + then do + let us' = supportEnvFlags + $ support Env.empty Env.empty xx' - (xCall, bLifted, xLifted) - = liftLambda p c us' a [] (XCast a CastBox x') + (xCall, bLifted, xLifted) + <- liftLambda p c us' a [] (XCast a CastBox x') - in ( xCall - , Result True (bxs ++ [(bLifted, xLifted)])) + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) - else (xx', r) + else return (xx', r) + -- Eta-expand partially applied data contructors. + XApp a x1 x2 + | (XCon _a (DaConBound nCon), xsArg) <- takeXApps1 x1 x2 + -> do + mResult <- etaXConApp p c a x1 nCon xsArg + case mResult of + Just result + -> return result + + _ -> do (x1', r1) <- enterAppLeft c a x1 x2 (lambdasX p) + (x2', r2) <- enterAppRight c a x1 x2 (lambdasX p) + return ( XApp a x1' x2' + , mappend r1 r2) + + -- Boilerplate. XApp a x1 x2 - -> let (x1', r1) = enterAppLeft c a x1 x2 (lambdasX p) - (x2', r2) = enterAppRight c a x1 x2 (lambdasX p) - in ( XApp a x1' x2' - , mappend r1 r2) + -> do (x1', r1) <- enterAppLeft c a x1 x2 (lambdasX p) + (x2', r2) <- enterAppRight c a x1 x2 (lambdasX p) + return ( XApp a x1' x2' + , mappend r1 r2) XLet a lts x - -> let (lts', r1) = lambdasLets p c a x lts - (x', r2) = enterLetBody c a lts x (lambdasX p) - in ( foldr (XLet a) x' lts' - , mappend r1 r2) + -> do (lts', r1) <- lambdasLets p c a x lts + (x', r2) <- enterLetBody c a lts x (lambdasX p) + return ( foldr (XLet a) x' lts' + , mappend r1 r2) XCase a x alts - -> let (x', r1) = enterCaseScrut c a x alts (lambdasX p) - (alts', r2) = lambdasAlts p c a x [] alts - in ( XCase a x' alts' - , mappend r1 r2) + -> do (x', r1) <- enterCaseScrut c a x alts (lambdasX p) + (alts', r2) <- lambdasAlts p c a x [] alts + return ( XCase a x' alts' + , mappend r1 r2) XCast a cc x -> lambdasCast p c a cc x - XType{} -> (xx, mempty) - XWitness{} -> (xx, mempty) + XType{} + -> return (xx, mempty) + XWitness{} + -> return (xx, mempty) + -- Lets ------------------------------------------------------------------------------------------- -- | Perform lambda lifting in some let-bindings. lambdasLets @@ -197,33 +239,20 @@ => Profile n -> Context a n -> a -> Exp a n -> Lets a n - -> ([Lets a n], Result a n) + -> S ([Lets a n], Result a n) lambdasLets p c a xBody lts = case lts of - LLet b x - -> let (x', r) = enterLetLLet c a b x xBody (lambdasX p) - in ([LLet b x'], r) + -> do (x', r) <- enterLetLLet c a b x xBody (lambdasX p) + return ([LLet b x'], r) LRec bxs - | isLiftyContext (contextCtx c) - -- Some fragments only allow letrecs to bind lambdas. - -- If all the bindings are lambdas, we can safely convert it to a - -- sequence of nonrecursive lets, as the recursion will be lifted to the - -- top level. - , Just _ <- sequence $ map (takeXLamFlags . snd) bxs - -> let (bxs', r) = lambdasLetRecLiftAll p c a bxs - in (map (uncurry LLet) bxs', r) + -> do (bxs', r) <- lambdasLetRecLiftAll p c a bxs + return (map (uncurry LLet) bxs', r) - -- If any bindings aren't lambdas, we know the fragment must - -- allow general recursion in letrecs anyway, and can leave it as a letrec. - | otherwise - -> let (bxs', r) = lambdasLetRec p c a [] bxs xBody - in ([LRec bxs'], r) - LPrivate{} - -> ([lts], mempty) + -> return ([lts], mempty) -- LetRec ----------------------------------------------------------------------------------------- @@ -232,28 +261,30 @@ :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) => Profile n -> Context a n -> a -> [(Bind n, Exp a n)] -> [(Bind n, Exp a n)] -> Exp a n - -> ([(Bind n, Exp a n)], Result a n) + -> S ([(Bind n, Exp a n)], Result a n) lambdasLetRec _ _ _ _ [] _ - = ([], mempty) + = return ([], mempty) lambdasLetRec p c a bxsAcc ((b, x) : bxsMore) xBody - = let (x', r1) = enterLetLRec c a bxsAcc b x bxsMore xBody (lambdasX p) + = do (x', r1) + <- enterLetLRec c a bxsAcc b x bxsMore xBody (lambdasX p) - in case contextCtx c of + case contextCtx c of -- If we're at top-level then drop lifted bindings here. CtxTop{} - -> let (bxs', Result p2 bxs2) - = lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody - Result p1 bxsLifted = r1 - in ( bxsLifted ++ ((b, x') : bxs') - , Result (p1 || p2) bxs2 ) + -> do (bxs', Result p2 bxs2) + <- lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody + let Result p1 bxsLifted = r1 + return ( bxsLifted ++ ((b, x') : bxs') + , Result (p1 || p2) bxs2 ) _ - -> let (bxs', r2) = lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody - in ( (b, x') : bxs' - , mappend r1 r2 ) + -> do (bxs', r2) + <- lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody + return ( (b, x') : bxs' + , mappend r1 r2 ) -- | When all the bindings in a letrec are lambdas, lift them all together. @@ -262,68 +293,89 @@ => Profile n -> Context a n -> a -> [(Bind n, Exp a n)] - -> ([(Bind n, Exp a n)], Result a n) + -> S ([(Bind n, Exp a n)], Result a n) lambdasLetRecLiftAll p c a bxs - = let + = let -- Wrap the context in the letrec + ctx before b x after + = enterLetLRec c a before b x after x (\c' _ -> c') + in do + -- The union of free variables of all the mutually recursive bindings must be used, -- as any lifted function may call the other lifted functions. - us = Set.unions - $ map (supportEnvFlags . support Env.empty Env.empty) - $ map snd bxs + let us = Set.unions + $ map (supportEnvFlags . support Env.empty Env.empty) + $ map snd bxs -- However, the functions we are lifting should not be treated as free variables - us' = Set.filter (\(_,bo) -> not $ any (boundMatchesBind bo . fst) bxs) - $ us + let us' = Set.filter + (\(_, bo) -> not $ any (boundMatchesBind bo . fst) bxs) + $ us - -- Lift each function with a different context - lift _before [] = [] + -- Lift each of the bindings in its own context. + -- We allow the group of bindings to contain ones with outer lambda + -- abstractions that need to be lifted, along with non-functional + -- bindings that stay in place. + let lift _before [] + = return [] - lift before ((b, x) : after) - = let Just (lams, xx) = takeXLamFlags x - c' = ctx before b x after - l' = liftLambda p c' us' a lams xx - in (b, l') : lift (before ++ [(b,x)]) after + lift before ((b, x) : after) + = case takeXLamFlags x of + -- The right of this binding has an outer abstraction, + -- so we need to lift it to top-level. + Just (lams, xx) + -> do let c' = ctx before b x after + l' <- liftLambda p c' us' a lams xx + ls <- lift (before ++ [(b,x)]) after + return $ Right (b, l') : ls - ls = lift [] bxs + -- The right of this binding does not have any outer + -- abstractions, so we can leave it in place. + Nothing + -> do ls <- lift (before ++ [(b, x)]) after + return $ Left (b, x) : ls + ls <- lift [] bxs + -- The call to each lifted function - calls = map (\(b,(xC,_,_)) -> (b,xC)) ls + let stripCall (Left (b, x)) = (b, x) + stripCall (Right (b, (xC, _, _))) = (b, xC) + let calls = map stripCall ls -- Substitute the original name of the recursive function with a call to its new name, -- including passing along any free variables. -- Here, we need to unwrap the newly-created lambdas for the free variables, -- as capture-avoiding substitution would rename them - the opposite of what we want. - sub x = case takeXLamFlags x of - Just (lams, xx) -> makeXLamFlags a lams (substituteXXs calls xx) - Nothing -> substituteXXs calls x + let sub x = case takeXLamFlags x of + Just (lams, xx) -> makeXLamFlags a lams (substituteXXs calls xx) + Nothing -> substituteXXs calls x -- The result bindings to add at the top-level, with all the new names substituted in - res = map (\(_, (_, bL, xL)) -> (bL, sub xL)) ls - in (calls, Result True res) + let stripResult (Left _) = Nothing + stripResult (Right (_, (_, bL, xL))) = Just (bL, sub xL) - where - -- Wrap the context in the letrec - ctx before b x after - = enterLetLRec c a before b x after x (\c' _ -> c') + let res = mapMaybe stripResult ls + return (calls, Result True res) + + -- Alts ------------------------------------------------------------------------------------------- -- | Perform lambda lifting in the right of a single alternative. lambdasAlts :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) => Profile n -> Context a n -> a -> Exp a n -> [Alt a n] -> [Alt a n] - -> ([Alt a n], Result a n) + -> S ([Alt a n], Result a n) lambdasAlts _ _ _ _ _ [] - = ([], mempty) + = return ([], mempty) lambdasAlts p c a xScrut altsAcc (AAlt w x : altsMore) - = let (x', r1) = enterCaseAlt c a xScrut altsAcc w x altsMore (lambdasX p) - (alts', r2) = lambdasAlts p c a xScrut (AAlt w x' : altsAcc) altsMore - in ( AAlt w x' : alts' - , mappend r1 r2) + = do (x', r1) <- enterCaseAlt c a xScrut altsAcc w x altsMore (lambdasX p) + (alts', r2) <- lambdasAlts p c a xScrut (AAlt w x' : altsAcc) altsMore + return ( AAlt w x' : alts' + , mappend r1 r2) -- Cast ------------------------------------------------------------------------------------------- @@ -332,269 +384,98 @@ :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) => Profile n -> Context a n -> a -> Cast a n -> Exp a n - -> (Exp a n, Result a n) + -> S (Exp a n, Result a n) lambdasCast p c a cc x = case cc of CastWeakenEffect{} - -> let (x', r) = enterCastBody c a cc x (lambdasX p) - in ( XCast a cc x', r) + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return ( XCast a cc x', r) CastPurify{} - -> let (x', r) = enterCastBody c a cc x (lambdasX p) - in (XCast a cc x', r) + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) CastBox - -> let (x', r) = enterCastBody c a cc x (lambdasX p) - in (XCast a cc x', r) + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) CastRun - -> let (x', r) = enterCastBody c a cc x (lambdasX p) - in (XCast a cc x', r) - - ---------------------------------------------------------------------------------------------------- --- | Check if this is a context that we should lift lambda abstractions out of. -isLiftyContext :: Ctx a n -> Bool -isLiftyContext ctx - = case ctx of - -- Don't lift out of the top-level context. - -- There's nowhere else to lift to. - CtxTop{} -> False - CtxLetLLet{} -> not $ isTopLetCtx ctx - CtxLetLRec{} -> not $ isTopLetCtx ctx - - -- Don't lift if we're inside more lambdas. - -- We want to lift the whole binding group together. - CtxLAM{} -> False - CtxLam{} -> False - - -- We can't do code generation for abstractions in these contexts, - -- so they need to be lifted. - CtxAppLeft{} -> True - CtxAppRight{} -> True - CtxLetBody{} -> True - CtxCaseScrut{} -> True - CtxCaseAlt{} -> True - CtxCastBody{} -> True - - ---------------------------------------------------------------------------------------------------- --- | Construct the call site, and new lifted binding for a lambda lifted --- abstraction. -liftLambda - :: (Show a, Show n, Pretty n, Ord n, CompoundName n, Pretty a) - => Profile n -- ^ Language profile. - -> Context a n -- ^ Context of the original abstraction. - -> Set (Bool, Bound n) -- ^ Free variables in the body of the abstraction. - -> a - -> [(Bool, Bind n)] -- ^ The lambdas, and whether they are type or value - -> Exp a n - -> ( Exp a n - , Bind n, Exp a n) - -liftLambda p c fusFree a lams xBody - = let ctx = contextCtx c - kenv = contextKindEnv c - tenv = contextTypeEnv c - - -- The complete abstraction that we're lifting out. - xLambda = makeXLamFlags a lams xBody - - -- Name of the enclosing top-level binding. - Just nTop = takeTopNameOfCtx ctx - - -- Names of other supers bound at top-level. - nsSuper = takeTopLetEnvNamesOfCtx ctx - - -- Name of the new lifted binding. - nLifted = extendName nTop ("Lift_" ++ encodeCtx ctx) - uLifted = UName nLifted - - - -- Build the type checker configuration for this context. - (defs, _, _) = topOfCtx (contextCtx c) - config = Check.configOfProfile p - - config' = config - { Check.configDataDefs - = mappend defs (Check.configDataDefs config) - - , Check.configGlobalCaps - = contextGlobalCaps c } - - -- Function to get the type of an expression in this context. - -- If there are type errors in the input program then some - -- either the lambda lifter is broken or some other transform - -- has messed up. - typeOfExp x - = case Check.typeOfExp - config' (contextKindEnv c) (contextTypeEnv c) - x - of Left err - -> error $ renderIndent $ vcat - [ text "ddc-core-simpl.liftLambda: type error in lifted expression" - , ppr err] - Right t -> t - - - -- Decide whether we want to bind the given variable as a new parameter - -- on the lifted super. We don't need to bind primitives, other supers, - -- or any variable bound by the abstraction itself. - keepVar fu@(_, u) - | (False, UName n) <- fu = not $ Set.member n nsSuper - | (_, UPrim{}) <- fu = False - | any (boundMatchesBind u . snd) lams - = False - | otherwise = True - - fusFree_filtered - = filter keepVar - $ Set.toList fusFree - - - -- Join in the types of the free variables. - joinType (f, u) - = case f of - True | Just t <- Env.lookup u kenv - -> ((f, u), t) - - False | Just t <- Env.lookup u tenv - -> ((f, u), t) - - _ -> error $ unlines - [ "ddc-core-simpl.joinType: cannot find type of free var." - , show (f, u) ] - - futsFree_types - = map joinType fusFree_filtered - - - -- Add in type variables that are free in the types of free value variables. - -- We need to bind these as well in the new super. - expandFree ((f, u), t) - | False <- f = [(f, u)] - ++ [(True, ut) | ut <- Set.toList - $ freeVarsT Env.empty t] - | otherwise = [(f, u)] - - fusFree_body = [(True, ut) | ut <- Set.toList - $ freeVarsT Env.empty $ typeOfExp xLambda] - - futsFree_expandFree - = map joinType - $ Set.toList $ Set.fromList - $ (concatMap expandFree $ futsFree_types) - ++ fusFree_body - - -- Sort free vars so the type variables come out the front. - futsFree - = sortBy (compare `on` (not . fst . fst)) - $ futsFree_expandFree - - - -- At the call site, apply all the free variables of the lifted - -- function as new arguments. - makeArg (True, u) = XType a (TVar u) - makeArg (False, u) = XVar a u - - xCall = xApps a (XVar a uLifted) - $ map makeArg $ map fst futsFree - - - -- ISSUE #330: Lambda lifter doesn't work with anonymous binders. - -- For the lifted abstraction, wrap it in new lambdas to bind all of - -- its free variables. - makeBind ((True, (UName n)), t) = (True, BName n t) - makeBind ((False, (UName n)), t) = (False, BName n t) - makeBind fut - = error $ "ddc-core-simpl.liftLamba: unhandled binder " ++ show fut - - -- Make the new super. - bsParam = map makeBind futsFree - - xLifted = makeXLamFlags a bsParam xLambda - - - -- Get the type of the bound expression, which we need when building - -- the type of the new super. - tLifted = typeOfExp xLifted - bLifted = BName nLifted tLifted - - in ( xCall - , bLifted, xLifted) + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) ---------------------------------------------------------------------------------------------------- --- | Beautify the names of lifted lamdba abstractions. --- The lifter itself names new abstractions after the context they come from. --- This is an easy way of generating unique names, but the names are too --- verbose to want to show to users, or put in the symbol table of the --- resulting binary. --- --- The beautifier renames the bindings of lifted abstractions to --- fun$L0, fun$L1 etc, where 'fun' is the name of the top-level binding --- it was lifted out of. --- -beautifyModule - :: forall a n. (Ord n, Show n, CompoundName n) - => Module a n -> Module a n +------------------------------------------------------------------------------- +-- | Eta-expand partially applied data constructors. +-- The code generator only handles fully applied data constructors, +-- so we eta-expand partially applied ones so that they get turned +-- into thunks. +etaXConApp + :: (Show a, Pretty a, Pretty n, Ord n, Show n, CompoundName n) + => Profile n -- ^ Language Profile. + -> Context a n -- ^ Current context of transform. + -> a -- ^ Annotation from constructor applicatin onde. + -> Exp a n -- ^ Expression holding constructor. + -> n -- ^ Name of constructor. + -> [Exp a n] -- ^ Arguments to constructor. + -> S (Maybe ( Exp a n + , Result a n)) -beautifyModule mm - = mm { moduleBody = beautifyX $ moduleBody mm } +etaXConApp !p !c !a !x1 !nCon !xsArg + -- Lookup the type of the constructor. + | ctx <- contextCtx c + , case ctx of + CtxAppLeft{} -> False + _ -> True - where - -- If the given binder is for an abstraction that we have lifted, - -- then produce a new nice name for it. - makeRenamer - :: Map n Int -> Bind n - -> (Map n Int, Maybe (n, (n, Type n))) - makeRenamer acc b - | BName n t <- b - , Just (nBase, str) <- splitName n - , isPrefixOf "Lift_" str - = case Map.lookup nBase acc of - Nothing -> ( Map.insert nBase 0 acc - , Just ( extendName nBase str - , (extendName nBase ("L" ++ show (0 :: Int)), t))) + , envX <- topOfCtx ctx + , defs <- EnvX.envxDataDefs envX + , Just dataCtor <- Map.lookup nCon (DataDef.dataDefsCtors defs) - Just n' -> ( Map.insert nBase (n' + 1) acc - , Just ( extendName nBase str - , (extendName nBase ("L" ++ show (n' + 1)), t))) + -- We're expecting an argument for each of the type and term parameters. + , arityT <- length $ DataDef.dataCtorTypeParams dataCtor + , arityX <- length $ DataDef.dataCtorFieldTypes dataCtor + , arity <- arityT + arityX - | otherwise = (acc, Nothing) + -- Check if the constructor is partially applied. + , arityX >= 1 + , args <- length xsArg + , args /= arity + = do + -- Make binders for the new type parameters. + (bsT, usT) + <- fmap unzip + $ mapM (\(i, t) -> newVar (show i) t) + $ [ (i, typeOfBind b) + | i <- [0..arityT - 1] + | b <- DataDef.dataCtorTypeParams dataCtor ] - -- Beautify bindings. - beautifyBXs a bxs - = let bsRenames :: [(n, (n, Type n))] - bsRenames = catMaybes $ snd - $ mapAccumL makeRenamer (Map.empty :: Map n Int) - $ map fst bxs + let sub = zip (DataDef.dataCtorTypeParams dataCtor) + (map TVar usT) - bxsSubsts :: [(Bind n, Exp a n)] - bxsSubsts = [ (BName n t, XVar a (UName n')) - | (n, (n', t)) <- bsRenames] + -- Make binders for the new term parameters. + (bsX, usX) + <- fmap unzip + $ mapM (\(i, t) -> newVar (show i) (substituteTs sub t)) + $ [ (i, t) + | i <- [0 .. arityX - 1] + | t <- DataDef.dataCtorFieldTypes dataCtor ] - renameBind (b, x) - | BName n t <- b - , Just (n', _) <- lookup n bsRenames - = (BName n' t, x) - - | otherwise = (b, x) - - in map (\(b, x) -> (b, substituteXXs bxsSubsts x)) - $ map renameBind bxs + -- Transform all the arguments. + let downArg xArg = enterAppRight c a x1 xArg (lambdasX p) + (xsArg', rs) <- fmap unzip $ mapM downArg xsArg - -- Beautify bindings in top-level let-expressions. - beautifyX xx - = case xx of - XLet a (LRec bxs) xBody - -> let bxs' = beautifyBXs a bxs - in XLet a (LRec bxs') (beautifyX xBody) + -- Build application of our new abstraction. + return $ Just + $ ( xApps a + ( xLAMs a bsT $ xLams a bsX + $ xApps a (XCon a (DaConBound nCon)) + $ [ XType a (TVar u) | u <- usT] + ++ [ XVar a u | u <- usX]) + xsArg' - XLet a (LLet b x) xBody - -> let [(b', x')] = beautifyBXs a [(b, x)] - in XLet a (LLet b' x') (beautifyX xBody) + , mconcat (Result True [] : rs)) - _ -> xx + | otherwise + = return Nothing diff --git a/DDC/Core/Transform/Lambdas/Base.hs b/DDC/Core/Transform/Lambdas/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Lambdas/Base.hs @@ -0,0 +1,103 @@ + +module DDC.Core.Transform.Lambdas.Base + ( S, evalState + , newVar + , newVarExtend + , Result (..) + , isLiftyContext) +where +import DDC.Core.Exp.Annot.Ctx +import DDC.Core.Exp.Annot +import DDC.Data.Name +import qualified Control.Monad.State.Strict as S + + +--------------------------------------------------------------------------------------------------- +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State (String, Int) + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: String -> S a -> a +evalState n c + = S.evalState c (n, 0) + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVar + :: CompoundName n + => String -- ^ Informational name to add. + -> Type n -- ^ Type of the new binder. + -> S (Bind n, Bound n) + +newVar prefix t + = do (n, i) <- S.get + let name' = newVarName (n ++ "$" ++ prefix ++ "$" ++ show i) + S.put (n, i + 1) + return (BName name' t, UName name') + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVarExtend + :: CompoundName n + => n -- ^ Base name. + -> String -- ^ Informational name to ad. + -> Type n -- ^ Type of the new binder. + -> S (Bind n, Bound n) + +newVarExtend name prefix t + = do (n, i) <- S.get + let name' = extendName name (n ++ "$" ++ prefix ++ "$" ++ show i) + S.put (n, i + 1) + return (BName name' t, UName name') + + + +--------------------------------------------------------------------------------------------------- +-- | Result of lambda lifter recursion. +data Result a n + = Result + { -- | Whether we've made any progress in this pass. + _resultProgress :: Bool + + -- | Bindings that we've already lifted out, + -- and should be added at top-level. + , _resultBindings :: [(Bind n, Exp a n)] + } + + +instance Monoid (Result a n) where + mempty + = Result False [] + + mappend (Result p1 lts1) (Result p2 lts2) + = Result (p1 || p2) (lts1 ++ lts2) + + +--------------------------------------------------------------------------------------------------- +-- | Check if this is a context that we should lift lambda abstractions out of. +isLiftyContext :: Ctx a n -> Bool +isLiftyContext ctx + = case ctx of + -- Don't lift out of the top-level context. + -- There's nowhere else to lift to. + CtxTop{} -> False + CtxLetLLet{} -> not $ isTopLetCtx ctx + CtxLetLRec{} -> not $ isTopLetCtx ctx + + -- Don't lift if we're inside more lambdas. + -- We want to lift the whole binding group together. + CtxLAM{} -> False + CtxLam{} -> False + + -- We can't do code generation for abstractions in these contexts, + -- so they need to be lifted. + CtxAppLeft{} -> True + CtxAppRight{} -> True + CtxLetBody{} -> True + CtxCaseScrut{} -> True + CtxCaseAlt{} -> True + CtxCastBody{} -> True + diff --git a/DDC/Core/Transform/Lambdas/Lift.hs b/DDC/Core/Transform/Lambdas/Lift.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Lambdas/Lift.hs @@ -0,0 +1,184 @@ + +module DDC.Core.Transform.Lambdas.Lift + (liftLambda) +where +import DDC.Core.Transform.Lambdas.Base +import DDC.Core.Fragment +import DDC.Core.Exp.Annot.Context +import DDC.Core.Exp.Annot.Ctx +import DDC.Core.Exp.Annot +import DDC.Core.Collect +import DDC.Data.Pretty +import DDC.Data.Name +import Data.Function +import Data.List +import Data.Set (Set) +import qualified DDC.Core.Check as Check +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Env.EnvX as EnvX +import qualified Data.Set as Set +import qualified Data.Map as Map + + +--------------------------------------------------------------------------------------------------- +-- | Construct the call site, and new lifted binding for a lambda lifted +-- abstraction. +liftLambda + :: (Show a, Show n, Pretty n, Ord n, CompoundName n, Pretty a) + => Profile n -- ^ Language profile. + -> Context a n -- ^ Context of the original abstraction. + -> Set (Bool, Bound n) -- ^ Free variables in the body of the abstraction. + -> a + -> [(Bool, Bind n)] -- ^ Parameters of the current lambda abstraction. + -> Exp a n -- ^ Body of the current lambda abstraction. + -> S ( Exp a n + , Bind n, Exp a n) + +liftLambda p c fusFree a bfsParam xBody + = do + -- Name of the enclosing top-level binding. + let Just nTop = takeTopNameOfCtx (contextCtx c) + + -- Names of other supers bound at top-level. + let nsSuper = takeTopLetEnvNamesOfCtx (contextCtx c) + + -- The complete abstraction that we're lifting out. + let xLambda = makeXLamFlags a bfsParam xBody + + -- Get the list of new parameters we need to add to our super. + -- These bind all the variables that were free in the abstraction + -- group that we're lifting out. + let fusFree_filtered + = filter (needParamForFreeBound nsSuper bfsParam) + $ Set.toList fusFree + + + -- Lookup the types of those variables from the context, + -- so we can add the correct types for the parameters of the new super. + let joinType (f@True, u) + | Just t <- EnvX.lookupT u (contextEnv c) + = ((f, u), t) + + joinType (f@False, u) + | Just t <- EnvX.lookupX u (contextEnv c) + = ((f, u), t) + + joinType (f, u) + = error $ unlines + [ "ddc-core-simpl.liftLambda: cannot find type of free variable." + , show (f, u) + , show (Map.keys $ EnvX.envxMap (contextEnv c)) ] + + let futsFree_types + = map joinType fusFree_filtered + + + -- Add in type variables that are free in the types of free + -- value variables. We need to bind these as well in the new super. + let expandFree ((f@True, u), _) + = [(f, u)] + + expandFree ((f@False, u), t) + = [(f, u)] + ++ [(True, ut) | ut <- Set.toList + $ freeVarsT Env.empty t] + + let fusFree_body + = [(True, ut) | ut <- Set.toList + $ freeVarsT Env.empty $ typeOfExp p c xLambda] + + let futsFree_expandFree + = map joinType + $ Set.toList $ Set.fromList + $ (concatMap expandFree $ futsFree_types) + ++ fusFree_body + + + -- Sort free vars so the type variables come out the front. + let futsFree + = sortBy (compare `on` (not . fst . fst)) + $ futsFree_expandFree + + + -- Make the new super. + -- For the lifted abstraction, wrap it in new lambdas to bind all of + -- its free variables. + -- ISSUE #330: Lambda lifter doesn't work with anonymous binders. + let makeBind ((True, (UName n)), t) = (True, BName n t) + makeBind ((False, (UName n)), t) = (False, BName n t) + makeBind fut + = error $ "ddc-core-simpl.liftLamba: unhandled binder " ++ show fut + + let bsParam = map makeBind futsFree + let xLifted = makeXLamFlags a bsParam xLambda + + -- Make a binder for the new super. + (bLifted, uLifted) + <- newVarExtend nTop "L" + $ typeOfExp p c xLifted + + -- At the point where the original abstraction group was, + -- call our new lifted super instead. + let makeArg (True, u) = XType a (TVar u) + makeArg (False, u) = XVar a u + + let xCall = xApps a (XVar a uLifted) + $ map makeArg $ map fst futsFree + + -- All done. + return ( xCall + , bLifted, xLifted) + + +--------------------------------------------------------------------------------------------------- +-- | Decide whether we need to bind the given variable as a new parameter +-- on the lifted super. +needParamForFreeBound + :: (Ord n) + => Set n -- ^ Names of supers at top level. + -> [(Bool, Bind n)] -- ^ Parameters of the current lambda abstraction. + -> (Bool, Bound n) -- ^ Bound variable, and whether it is a type (True) or not. + -> Bool + +needParamForFreeBound nsSuper bfsParam (bType, u) + -- We don't need new parameters for supers that are already + -- at top level, as we can reference those directly. + | not bType + , UName n <- u + = not $ Set.member n nsSuper + + -- We don't need new parameters for primitives, + -- as we can reference those directly. + | UPrim{} <- u + = False + + -- We don't need new paramters for variables that + -- are already bound by the abstractions that we're lifting. + | any (boundMatchesBind u . snd) bfsParam + = False + + -- We need a new parameter for this free variable. + | otherwise + = True + + +-- Function to get the type of an expression in the given context. +typeOfExp + :: (Pretty a, Show a, Show n, Pretty n, Eq n, Ord n) + => Profile n -- ^ Language profile. + -> Context a n -- ^ Current context. + -> Exp a n -- ^ Expression we want the type for. + -> Type n + +typeOfExp p c x + = case Check.typeOfExp + (Check.configOfProfile p) + (contextEnv c) x + of Left err + -> error $ renderIndent $ vcat + [ text "ddc-core-simpl.liftLambda: type error in lifted expression" + , ppr err] + + Right t + -> t + diff --git a/DDC/Core/Transform/Namify.hs b/DDC/Core/Transform/Namify.hs --- a/DDC/Core/Transform/Namify.hs +++ b/DDC/Core/Transform/Namify.hs @@ -8,8 +8,8 @@ where import DDC.Core.Module import DDC.Core.Exp -import DDC.Type.Collect -import DDC.Type.Compounds +import DDC.Core.Collect +import DDC.Type.Exp.Simple import Control.Monad import DDC.Type.Env (Env, KindEnv, TypeEnv) import qualified DDC.Type.Sum as Sum @@ -82,14 +82,19 @@ TCon{} -> return tt - TForall b t + TAbs b t -> do (tnam', b') <- pushT tnam b t' <- namify tnam' xnam t - return $ TForall b' t' + return $ TAbs b' t' TApp t1 t2 -> liftM2 TApp (down t1) (down t2) + TForall b t + -> do (tnam', b') <- pushT tnam b + t' <- namify tnam' xnam t + return $ TForall b' t' + TSum ts -> do ts' <- mapM down $ Sum.toList ts return $ TSum $ Sum.fromList (Sum.kindOfSum ts) ts' @@ -193,8 +198,7 @@ -- | Rewrite level-0 anonymous binders. -rewriteX :: Ord n - => Namifier s n +rewriteX :: Namifier s n -> Namifier s n -> Bound n -> State s (Bound n) diff --git a/DDC/Core/Transform/Prune.hs b/DDC/Core/Transform/Prune.hs --- a/DDC/Core/Transform/Prune.hs +++ b/DDC/Core/Transform/Prune.hs @@ -18,16 +18,15 @@ import DDC.Core.Check import DDC.Core.Module import DDC.Core.Exp -import DDC.Type.Env -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.Typeable -import Control.Monad.Writer (Writer, runWriter, tell) +import Control.Monad.Writer (Writer, runWriter, tell) +import DDC.Core.Env.EnvX (EnvX) import qualified Data.Map as Map import qualified DDC.Core.Transform.SubstituteXX as S -import qualified DDC.Type.Equiv as T -import qualified DDC.Type.Compounds as T +import qualified DDC.Type.Exp.Simple as T import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Env as Env +import qualified DDC.Core.Env.EnvT as EnvT import Prelude hiding ((<$>)) @@ -71,27 +70,30 @@ = mm | otherwise - = mm { moduleBody - = result - $ pruneX profile (moduleKindEnv mm) (moduleTypeEnv mm) - $ moduleBody mm } + = let env = moduleEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + mm + in mm { moduleBody + = result $ pruneX profile env + $ moduleBody mm } -- | Erase pure let-bindings in an expression that have no uses. pruneX :: (Show a, Show n, Ord n, Pretty n) - => Profile n -- ^ Profile of the language we're in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment + => Profile n -- ^ Profile of the language we're in + -> EnvX n -- ^ Type checker environment. -> Exp a n -> TransformResult (Exp a n) -pruneX profile kenv tenv xx +pruneX profile env xx = {-# SCC pruneX #-} let (xx', info) - = transformTypeUsage profile kenv tenv - (transformUpMX pruneTrans kenv tenv) + = transformTypeUsage profile env + (transformUpMX pruneTrans env) xx progress (PruneInfo r) @@ -110,9 +112,9 @@ -- We generate these annotations here then pass the result off to -- deadCodeTrans to actually erase dead bindings. -- -transformTypeUsage profile kenv tenv trans xx +transformTypeUsage profile env trans xx = let config = configOfProfile profile - rr = checkExp config kenv tenv Recon DemandNone xx + rr = checkExp config env Recon DemandNone xx in case fst rr of Right (xx1, _, _) -> let xx2 = usageX xx1 @@ -133,14 +135,13 @@ -- | Apply the dead-code transform to an annotated expression. pruneTrans - :: (Show a, Show n, Ord n, Pretty n) - => KindEnv n - -> TypeEnv n - -> Exp (Annot a n) n + :: Ord n + => EnvX n -- ^ Type checker environment. + -> Exp (Annot a n) n -- ^ Expression to transform. -> Writer PruneInfo (Exp (Annot a n) n) -pruneTrans _ _ xx +pruneTrans _ xx = case xx of XLet a@(usedMap, antec) (LLet b x1) x2 | isUnusedBind b usedMap @@ -161,7 +162,7 @@ where weakEff antec = CastWeakenEffect - $ T.crushEffect Env.empty + $ T.crushEffect EnvT.empty $ annotEffect antec @@ -194,7 +195,7 @@ = all contained $ map T.takeTApps $ sumList - $ T.crushEffect Env.empty eff + $ T.crushEffect EnvT.empty eff where contained (c : _args) = case c of diff --git a/DDC/Core/Transform/Rewrite.hs b/DDC/Core/Transform/Rewrite.hs --- a/DDC/Core/Transform/Rewrite.hs +++ b/DDC/Core/Transform/Rewrite.hs @@ -5,7 +5,7 @@ , rewriteModule , rewriteX) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Exp.Annot as X import DDC.Core.Module import Data.Map (Map) @@ -18,7 +18,7 @@ import qualified DDC.Core.Transform.SubstituteXX as S import qualified DDC.Type.Transform.SubstituteT as S import qualified DDC.Core.Transform.BoundX as L -import qualified DDC.Type.Compounds as T +import qualified DDC.Type.Exp.Simple as T import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe @@ -350,7 +350,7 @@ -- | Check whether we can satisfy this constraint using witnesses -- in the rewrite nevironment. -satisfiedContraint :: (Ord n, Show n) => RE.RewriteEnv a n -> Type n -> Bool +satisfiedContraint :: Ord n => RE.RewriteEnv a n -> Type n -> Bool satisfiedContraint env c = RE.containsWitness c env || RD.checkDisjoint c env @@ -358,8 +358,7 @@ -- | Wrap an expression in an effect weakning. -weakeff :: Ord n - => a -> Maybe (Effect n) +weakeff :: a -> Maybe (Effect n) -> Exp a n -> Exp a n weakeff a meff x diff --git a/DDC/Core/Transform/Rewrite/Disjoint.hs b/DDC/Core/Transform/Rewrite/Disjoint.hs --- a/DDC/Core/Transform/Rewrite/Disjoint.hs +++ b/DDC/Core/Transform/Rewrite/Disjoint.hs @@ -4,12 +4,10 @@ , checkDistinct ) where import DDC.Core.Exp -import DDC.Type.Predicates -import DDC.Type.Compounds +import DDC.Type.Exp.Simple as T import qualified DDC.Core.Transform.Rewrite.Env as RE -import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as Sum -import qualified DDC.Type.Equiv as TC +import qualified DDC.Core.Env.EnvT as EnvT -- | Check whether a disjointness property is true in the given @@ -59,7 +57,7 @@ -- > = True -- checkDisjoint - :: (Ord n, Show n) + :: Ord n => Type n -- ^ Type of property we want -- eg @Disjoint e1 e2@ -> RE.RewriteEnv a n -- ^ Environment we're rewriting in. @@ -69,8 +67,8 @@ -- The type must have the form "Disjoint e1 e2" | [TCon (TyConWitness TwConDisjoint), fs, gs] <- takeTApps c = and [ areDisjoint env g f - | f <- sumList $ TC.crushEffect Env.empty fs - , g <- sumList $ TC.crushEffect Env.empty gs ] + | f <- sumList $ T.crushEffect EnvT.empty fs + , g <- sumList $ T.crushEffect EnvT.empty gs ] | otherwise = False @@ -80,7 +78,7 @@ -- | Check whether two atomic effects are disjoint. areDisjoint - :: (Ord n, Show n) + :: Ord n => RE.RewriteEnv a n -> Effect n -> Effect n diff --git a/DDC/Core/Transform/Rewrite/Env.hs b/DDC/Core/Transform/Rewrite/Env.hs --- a/DDC/Core/Transform/Rewrite/Env.hs +++ b/DDC/Core/Transform/Rewrite/Env.hs @@ -13,9 +13,7 @@ , liftValue) where import DDC.Core.Exp -import qualified DDC.Type.Exp as T -import qualified DDC.Type.Compounds as T -import qualified DDC.Type.Predicates as T +import qualified DDC.Type.Exp.Simple as T import qualified DDC.Type.Transform.BoundT as L import qualified DDC.Core.Transform.BoundX as L import Data.Maybe (fromMaybe, listToMaybe, isJust) @@ -52,7 +50,7 @@ -- | An empty environment. -empty :: Ord n => RewriteEnv a n +empty :: RewriteEnv a n empty = RewriteEnv [] [] [] diff --git a/DDC/Core/Transform/Rewrite/Error.hs b/DDC/Core/Transform/Rewrite/Error.hs --- a/DDC/Core/Transform/Rewrite/Error.hs +++ b/DDC/Core/Transform/Rewrite/Error.hs @@ -49,7 +49,7 @@ ppr Rhs = text "rhs" -instance (Pretty a, Show a, Pretty n, Show n, Eq n) +instance (Pretty a, Pretty n, Show n, Eq n) => Pretty (Error a n) where ppr err = case err of diff --git a/DDC/Core/Transform/Rewrite/Match.hs b/DDC/Core/Transform/Rewrite/Match.hs --- a/DDC/Core/Transform/Rewrite/Match.hs +++ b/DDC/Core/Transform/Rewrite/Match.hs @@ -10,14 +10,14 @@ import DDC.Core.Exp import Data.Set (Set) import Data.Map (Map) -import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as Sum import qualified DDC.Type.Transform.AnonymizeT as T import qualified DDC.Core.Transform.AnonymizeX as T import qualified DDC.Core.Transform.Reannotate as T -import qualified DDC.Type.Equiv as TE +import qualified DDC.Type.Exp.Simple as T import qualified Data.Map as Map import qualified Data.Set as Set +import qualified DDC.Core.Env.EnvT as EnvT ------------------------------------------------------------------------------- @@ -132,8 +132,8 @@ -> Maybe (Subst n) matchT t1 t2 vs subst - = let t1' = unpackSumT $ TE.crushSomeT Env.empty t1 - t2' = unpackSumT $ TE.crushSomeT Env.empty t2 + = let t1' = unpackSumT $ T.crushSomeT EnvT.empty t1 + t2' = unpackSumT $ T.crushSomeT EnvT.empty t2 in case (t1', t2') of -- Constructor names must be equal. -- @@ -183,7 +183,7 @@ | Set.member n vs , Just t1'' <- Map.lookup n subst - , TE.equivT t1'' t2' + , T.equivT EnvT.empty t1'' t2' -> Just subst -- Both are variables but it's not a template variable, diff --git a/DDC/Core/Transform/Rewrite/Parser.hs b/DDC/Core/Transform/Rewrite/Parser.hs --- a/DDC/Core/Transform/Rewrite/Parser.hs +++ b/DDC/Core/Transform/Rewrite/Parser.hs @@ -6,8 +6,8 @@ import DDC.Core.Exp import DDC.Core.Parser import DDC.Core.Lexer.Tokens -import qualified DDC.Base.Parser as P -import qualified DDC.Type.Compounds as T +import qualified DDC.Control.Parser as P +import qualified DDC.Type.Exp.Simple as T import qualified DDC.Core.Transform.Rewrite.Rule as R @@ -25,7 +25,7 @@ = do bs <- pRuleBinders c (cs,lhs) <- pRuleCsLhs c hole <- pRuleHole c - pTok KEquals + pSym SEquals rhs <- pExp c return $ R.mkRewriteRule bs cs lhs hole rhs @@ -49,7 +49,7 @@ = P.many (do n <- pName r <- pRule c - pTok KSemiColon + pSym SSemiColon return (n,r)) @@ -60,7 +60,7 @@ pRuleBinders c = P.choice [ do bs <- P.many1 (pBinders c) - pTok KDot + pSym SDot return $ concat bs , return [] ] @@ -73,7 +73,7 @@ = P.choice [ do cs <- P.many1 $ P.try (do cc <- pTypeApp c - pTok KArrowEquals + pSym SArrowEquals return cc) lhs <- pExp c return (cs,lhs) @@ -87,11 +87,11 @@ => Context n -> Parser n (Maybe (Exp P.SourcePos n)) pRuleHole c = P.optionMaybe - $ do pTok KUnderscore - pTok KBraceBra + $ do pSym SUnderscore + pSym SBraceBra e <- pExp c - pTok KBraceKet - pTok KUnderscore + pSym SBraceKet + pSym SUnderscore return e @@ -106,8 +106,8 @@ => Context n -> Parser n [(R.BindMode, Bind n)] pBinders c = P.choice - [ pBindersBetween c R.BMSpec (pTok KSquareBra) (pTok KSquareKet) - , pBindersBetween c (R.BMValue 0) (pTok KRoundBra) (pTok KRoundKet) + [ pBindersBetween c R.BMSpec (pSym SSquareBra) (pSym SSquareKet) + , pBindersBetween c (R.BMValue 0) (pSym SRoundBra) (pSym SRoundKet) ] @@ -115,8 +115,8 @@ :: Ord n => Context n -> R.BindMode - -> Parser n () - -> Parser n () + -> Parser n a + -> Parser n a -> Parser n [(R.BindMode,Bind n)] pBindersBetween c bm bra ket diff --git a/DDC/Core/Transform/Rewrite/Rule.hs b/DDC/Core/Transform/Rewrite/Rule.hs --- a/DDC/Core/Transform/Rewrite/Rule.hs +++ b/DDC/Core/Transform/Rewrite/Rule.hs @@ -21,24 +21,21 @@ import DDC.Core.Pretty () import DDC.Core.Collect import DDC.Core.Pretty () -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Base.Pretty +import DDC.Core.Env.EnvX (EnvX) +import DDC.Data.Pretty import qualified DDC.Core.Analysis.Usage as U import qualified DDC.Core.Check as C import qualified DDC.Core.Collect as C import qualified DDC.Core.Transform.SpreadX as S -import qualified DDC.Type.Check as T -import qualified DDC.Type.Compounds as T import qualified DDC.Type.Env as T -import qualified DDC.Type.Equiv as T -import qualified DDC.Type.Predicates as T -import qualified DDC.Type.Subsumes as T +import qualified DDC.Type.Exp.Simple as T import qualified DDC.Type.Transform.SpreadT as S import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified DDC.Type.Env as Env - +import qualified DDC.Core.Env.EnvT as EnvT +import qualified DDC.Core.Env.EnvX as EnvX -- | A rewrite rule. For example: -- @@ -136,8 +133,7 @@ -- You then need to apply 'checkRewriteRule' to check it. -- mkRewriteRule - :: Ord n - => [(BindMode,Bind n)] -- ^ Variables bound by the rule. + :: [(BindMode,Bind n)] -- ^ Variables bound by the rule. -> [Type n] -- ^ Extra constraints on the rule. -> Exp a n -- ^ Left-hand side of the rule. -> Maybe (Exp a n) -- ^ Extra part of left, can be out of context. @@ -165,30 +161,30 @@ checkRewriteRule :: (Show a, Ord n, Show n, Pretty n) => C.Config n -- ^ Type checker config. - -> T.Env n -- ^ Kind environment. - -> T.Env n -- ^ Type environment. + -> EnvX n -- ^ Type checker environment. -> RewriteRule a n -- ^ Rule to check -> Either (Error a n) (RewriteRule (C.AnTEC a n) n) -checkRewriteRule config kenv tenv +checkRewriteRule config env (RewriteRule bs cs lhs hole rhs _ _ _) = do -- Extend the environments with variables bound by the rule. - let (kenv', tenv', bs') = extendBinds bs kenv tenv - let csSpread = map (S.spreadT kenv') cs + let (env', bs') = extendBinds bs env + let kenv' = EnvX.kindEnvOfEnvX env' + let csSpread = map (S.spreadT kenv') cs -- Check that all constraints are valid types. - mapM_ (checkConstraint config kenv') csSpread + mapM_ (checkConstraint config) csSpread -- Typecheck, spread and annotate with type information (lhs', _, _) - <- checkExp config kenv' tenv' Lhs lhs + <- checkExp config env' Lhs lhs -- If the extra left part is there, typecheck and annotate it. hole' <- case hole of Just h - -> do (h',_,_) <- checkExp config kenv' tenv' Lhs h + -> do (h',_,_) <- checkExp config env' Lhs h return $ Just h' Nothing -> return Nothing @@ -200,11 +196,11 @@ -- Check the full left hand side. (lhs_full', tLeft, effLeft) - <- checkExp config kenv' tenv' Lhs lhs_full + <- checkExp config env' Lhs lhs_full -- Check the full right hand side. (rhs', tRight, effRight) - <- checkExp config kenv' tenv' Rhs rhs + <- checkExp config env' Rhs rhs -- Check that types of both sides are equivalent. let err = ErrorTypeConflict @@ -219,7 +215,7 @@ -- Check that the closure of the right is smaller than that -- of the left, and add a weakclo cast if nessesary. - cloWeak <- makeClosureWeakening config kenv' tenv' lhs_full' rhs' + cloWeak <- makeClosureWeakening config env' lhs_full' rhs' -- Check that all the bound variables are mentioned -- in the left-hand side. @@ -259,38 +255,42 @@ extendBinds :: Ord n => [(BindMode, Bind n)] - -> KindEnv n -> TypeEnv n - -> (T.KindEnv n, T.TypeEnv n, [(BindMode, Bind n)]) + -> EnvX n + -> (EnvX n, [(BindMode, Bind n)]) -extendBinds binds kenv tenv - = go binds kenv tenv [] +extendBinds binds env0 + = go binds env0 [] where - go [] k t acc - = (k,t,acc) + go [] env acc + = (env, acc) - go ((bm,b):bs) k t acc - = let b' = S.spreadX k t b - (k',t') = case bm of - BMSpec -> (T.extend b' k, t) - BMValue _ -> (k, T.extend b' t) + go ((bm,b):bs) env acc + = let kenv = EnvX.kindEnvOfEnvX env + tenv = EnvX.typeEnvOfEnvX env + b' = S.spreadX kenv tenv b + env' = case bm of + BMSpec -> EnvX.extendT b' env + BMValue _ -> EnvX.extendX b' env - in go bs k' t' (acc ++ [(bm,b')]) + in go bs env' (acc ++ [(bm,b')]) -- | Type check the expression on one side of the rule. checkExp :: (Show a, Ord n, Show n, Pretty n) - => C.Config n - -> KindEnv n -- ^ Kind environment of expression. - -> TypeEnv n -- ^ Type environment of expression. + => C.Config n -- ^ Type checker config. + -> EnvX n -- ^ Type checker environment. -> Side -- ^ Side that the expression appears on for errors. -> Exp a n -- ^ Expression to check. -> Either (Error a n) (Exp (C.AnTEC a n) n, Type n, Effect n) -checkExp defs kenv tenv side xx - = let xx' = S.spreadX kenv tenv xx - in case fst $ C.checkExp defs kenv tenv C.Recon C.DemandNone xx' of +checkExp defs env side xx + = let kenv = EnvX.kindEnvOfEnvX env + tenv = EnvX.typeEnvOfEnvX env + xx' = S.spreadX kenv tenv xx + + in case fst $ C.checkExp defs env C.Recon C.DemandNone xx' of Left err -> Left $ ErrorTypeCheck side xx' err Right rhs -> return rhs @@ -299,12 +299,11 @@ checkConstraint :: (Ord n, Show n, Pretty n) => C.Config n - -> KindEnv n -- ^ Kind environment of the constraint. -> Type n -- ^ The constraint type to check. -> Either (Error a n) (Kind n) -checkConstraint config kenv tt - = case T.checkSpec config kenv tt of +checkConstraint config tt + = case C.checkSpec config tt of Left _err -> Left $ ErrorBadConstraint tt Right (_, k) | T.isWitnessType tt -> return k @@ -320,8 +319,9 @@ -> Either (Error a n) () checkEquiv tLeft tRight err - | T.equivT tLeft tRight = return () - | otherwise = Left err + | T.equivT EnvT.empty tLeft tRight + = return () + | otherwise = Left err -- Weaken --------------------------------------------------------------------- @@ -331,7 +331,7 @@ -- If the right has more effects than the left then return an error. -- makeEffectWeakening - :: (Ord n, Show n) + :: Ord n => Kind n -- ^ Should be the effect kind. -> Effect n -- ^ Effect of the left of the rule. -> Effect n -- ^ Effect of the right of the rule. @@ -341,13 +341,13 @@ makeEffectWeakening k effLeft effRight onError -- When the effect of the left matches that of the right -- then we don't have to do anything else. - | T.equivT effLeft effRight + | T.equivT EnvT.empty effLeft effRight = return Nothing -- When the effect of the right is smaller than that of -- the left then we need to wrap it in an effect weaking -- so the rewritten expression retains its original effect. - | T.subsumesT k effLeft effRight + | T.subsumesT EnvT.empty k effLeft effRight = return $ Just effLeft -- When the effect of the right is more than that of the left @@ -363,22 +363,21 @@ -- makeClosureWeakening :: (Ord n, Pretty n, Show n) - => C.Config n -- ^ Type-checker config - -> T.Env n -- ^ Kind environment. - -> T.Env n -- ^ Type environment. - -> Exp (C.AnTEC a n) n -- ^ Expression on the left of the rule. - -> Exp (C.AnTEC a n) n -- ^ Expression on the right of the rule. + => C.Config n -- ^ Type-checker config + -> EnvX n -- ^ Type checker environment. + -> Exp (C.AnTEC a n) n -- ^ Expression on the left of the rule. + -> Exp (C.AnTEC a n) n -- ^ Expression on the right of the rule. -> Either (Error a n) [Exp (C.AnTEC a n) n] -makeClosureWeakening config kenv tenv lhs rhs - = let lhs' = removeEffects config kenv tenv lhs +makeClosureWeakening config env lhs rhs + = let lhs' = removeEffects config env lhs supportLeft = support Env.empty Env.empty lhs' daLeft = supportDaVar supportLeft wiLeft = supportWiVar supportLeft spLeft = supportSpVar supportLeft - rhs' = removeEffects config kenv tenv rhs + rhs' = removeEffects config env rhs supportRight = support Env.empty Env.empty rhs' daRight = supportDaVar supportRight wiRight = supportWiVar supportRight @@ -403,16 +402,17 @@ removeEffects :: (Ord n, Pretty n, Show n) => C.Config n -- ^ Type-checker config - -> T.Env n -- ^ Kind environment - -> T.Env n -- ^ Type environment + -> EnvX n -- ^ Type checker environment. -> Exp a n -- ^ Target expression - has all effects replaced with bottom. -> Exp a n -removeEffects config = transformUpX remove + +removeEffects config + = transformUpX remove where - remove kenv _tenv x + remove _env x - | XType a et <- x - , Right (_, k) <- T.checkSpec config kenv et + | XType a et <- x + , Right (_, k) <- C.checkSpec config et , T.isEffectKind k = XType a $ T.tBot T.kEffect @@ -423,7 +423,7 @@ -- Structural Checks ---------------------------------------------------------- -- | Check for rule variables that have no uses. checkUnmentionedBinders - :: (Ord n, Show n) + :: Ord n => [(BindMode, Bind n)] -> Exp (C.AnTEC a n) n -> Either (Error a n) () @@ -472,8 +472,9 @@ go_t _ (TVar _) = return () go_t _ (TCon _) = return () - go_t a t@(TForall _ _) = Left $ ErrorNotFirstOrder (XType a t) + go_t a t@(TAbs _ _) = Left $ ErrorNotFirstOrder (XType a t) go_t a (TApp l r) = go_t a l >> go_t a r + go_t a t@(TForall _ _) = Left $ ErrorNotFirstOrder (XType a t) go_t _ (TSum _) = return () diff --git a/DDC/Core/Transform/Snip.hs b/DDC/Core/Transform/Snip.hs --- a/DDC/Core/Transform/Snip.hs +++ b/DDC/Core/Transform/Snip.hs @@ -9,7 +9,7 @@ import DDC.Core.Module import DDC.Core.Exp.Annot import qualified DDC.Core.Transform.BoundX as L -import qualified DDC.Type.Compounds as T +import qualified DDC.Type.Exp.Simple as T ------------------------------------------------------------------------------- @@ -209,8 +209,7 @@ -- Unlike the `buildNormalisedFunApp` function above, this one -- wants the function part to be normalised as well. buildNormalisedFunApp - :: Ord n - => Config -- ^ Snipper configuration. + :: Config -- ^ Snipper configuration. -> a -- ^ Annotation to use. -> Int -- ^ Arity of the function part. -> Exp a n -- ^ Function part. @@ -284,8 +283,7 @@ -- | Sort function arguments into either the atomic ones, -- or compound ones. splitArgs - :: Ord n - => Config + :: Config -> [(Exp a n, a)] -> [( Exp a n -- Expression to use as the new argument. , a -- Annoation for the argument application. diff --git a/DDC/Core/Transform/Thread.hs b/DDC/Core/Transform/Thread.hs --- a/DDC/Core/Transform/Thread.hs +++ b/DDC/Core/Transform/Thread.hs @@ -11,7 +11,7 @@ where import DDC.Core.Module import DDC.Core.Exp.Annot -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Transform.Reannotate import DDC.Core.Check (AnTEC (..)) import DDC.Type.Env (KindEnv, TypeEnv) diff --git a/DDC/Core/Transform/TransformUpX.hs b/DDC/Core/Transform/TransformUpX.hs --- a/DDC/Core/Transform/TransformUpX.hs +++ b/DDC/Core/Transform/TransformUpX.hs @@ -1,42 +1,30 @@ - -- | General purpose tree walking boilerplate. module DDC.Core.Transform.TransformUpX ( TransformUpMX(..) , transformUpX - , transformUpX' - - -- * Via the Simple AST - , transformSimpleUpMX - , transformSimpleUpX - , transformSimpleUpX') + , transformUpX') where import DDC.Core.Module import DDC.Core.Exp.Annot -import DDC.Core.Transform.Annotate -import DDC.Core.Transform.Deannotate -import DDC.Type.Env (KindEnv, TypeEnv) import Data.Functor.Identity import Control.Monad -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Exp.Simple.Exp as S +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Env.EnvX as EnvX -- | Bottom up rewrite of all core expressions in a thing. transformUpX :: forall (c :: * -> * -> *) a n . (Ord n, TransformUpMX Identity c) - => (KindEnv n -> TypeEnv n -> Exp a n -> Exp a n) + => (EnvX n -> Exp a n -> Exp a n) -- ^ The worker function is given the current kind and type environments. - -> KindEnv n -- ^ Initial kind environment. - -> TypeEnv n -- ^ Initial type environment. + -> EnvX n -- ^ Initial environment. -> c a n -- ^ Transform this thing. -> c a n -transformUpX f kenv tenv xx +transformUpX f env xx = runIdentity - $ transformUpMX - (\kenv' tenv' x -> return (f kenv' tenv' x)) - kenv tenv xx + $ transformUpMX (\env' x -> return (f env' x)) env xx -- | Like transformUpX, but without using environments. @@ -50,7 +38,7 @@ -> c a n transformUpX' f xx - = transformUpX (\_ _ -> f) Env.empty Env.empty xx + = transformUpX (\_ -> f) EnvX.empty xx ------------------------------------------------------------------------------- @@ -58,154 +46,88 @@ -- | Bottom-up monadic rewrite of all core expressions in a thing. transformUpMX :: Ord n - => (KindEnv n -> TypeEnv n -> Exp a n -> m (Exp a n)) + => (EnvX n -> Exp a n -> m (Exp a n)) -- ^ The worker function is given the current -- kind and type environments. - -> KindEnv n -- ^ Initial kind environment. - -> TypeEnv n -- ^ Initial type environment. + -> EnvX n -- ^ Initial environment. -> c a n -- ^ Transform this thing. -> m (c a n) instance Monad m => TransformUpMX m Module where - transformUpMX f kenv tenv !mm - = do x' <- transformUpMX f kenv tenv $ moduleBody mm + transformUpMX f env !mm + = do x' <- transformUpMX f env $ moduleBody mm return $ mm { moduleBody = x' } instance Monad m => TransformUpMX m Exp where - transformUpMX f kenv tenv !xx - = (f kenv tenv =<<) + transformUpMX f env !xx + = (f env =<<) $ case xx of XVar{} -> return xx XCon{} -> return xx XLAM a b x1 -> liftM3 XLAM (return a) (return b) - (transformUpMX f (Env.extend b kenv) tenv x1) + (transformUpMX f (EnvX.extendT b env) x1) XLam a b x1 -> liftM3 XLam (return a) (return b) - (transformUpMX f kenv (Env.extend b tenv) x1) + (transformUpMX f (EnvX.extendX b env) x1) XApp a x1 x2 -> liftM3 XApp (return a) - (transformUpMX f kenv tenv x1) - (transformUpMX f kenv tenv x2) + (transformUpMX f env x1) + (transformUpMX f env x2) XLet a lts x - -> do lts' <- transformUpMX f kenv tenv lts - let kenv' = Env.extends (specBindsOfLets lts') kenv - let tenv' = Env.extends (valwitBindsOfLets lts') tenv - x' <- transformUpMX f kenv' tenv' x + -> do lts' <- transformUpMX f env lts + + let env' = EnvX.extendsX (valwitBindsOfLets lts') + $ EnvX.extendsT (specBindsOfLets lts') + $ env + + x' <- transformUpMX f env' x return $ XLet a lts' x' XCase a x alts -> liftM3 XCase (return a) - (transformUpMX f kenv tenv x) - (mapM (transformUpMX f kenv tenv) alts) + (transformUpMX f env x) + (mapM (transformUpMX f env) alts) XCast a c x -> liftM3 XCast (return a) (return c) - (transformUpMX f kenv tenv x) + (transformUpMX f env x) XType{} -> return xx XWitness{} -> return xx instance Monad m => TransformUpMX m Lets where - transformUpMX f kenv tenv xx + transformUpMX f env xx = case xx of LLet b x -> liftM2 LLet (return b) - (transformUpMX f kenv tenv x) + (transformUpMX f env x) LRec bxs -> do let (bs, xs) = unzip bxs - let tenv' = Env.extends bs tenv - xs' <- mapM (transformUpMX f kenv tenv') xs + let env' = EnvX.extendsX bs env + xs' <- mapM (transformUpMX f env') xs return $ LRec $ zip bs xs' LPrivate{} -> return xx instance Monad m => TransformUpMX m Alt where - transformUpMX f kenv tenv alt + transformUpMX f env alt = case alt of AAlt p@(PData _ bsArg) x - -> let tenv' = Env.extends bsArg tenv + -> let env' = EnvX.extendsX bsArg env in liftM2 AAlt (return p) - (transformUpMX f kenv tenv' x) + (transformUpMX f env' x) AAlt PDefault x -> liftM2 AAlt (return PDefault) - (transformUpMX f kenv tenv x) - - --- Simple --------------------------------------------------------------------- --- | Like `transformUpMX`, but the worker takes the Simple version of the AST. --- --- * To avoid repeated conversions between the different versions of the AST, --- the worker should return `Nothing` if the provided expression is unchanged. -transformSimpleUpMX - :: (Ord n, TransformUpMX m c, Monad m) - => (KindEnv n -> TypeEnv n -> S.Exp a n -> m (Maybe (S.Exp a n))) - -- ^ The worker function is given the current - -- kind and type environments. - -> KindEnv n -- ^ Initial kind environment. - -> TypeEnv n -- ^ Initial type environment. - -> c a n -- ^ Transform thing thing. - -> m (c a n) - -transformSimpleUpMX f kenv0 tenv0 xx0 - = let - f' kenv tenv xx - = do let a = annotOfExp xx - let sxx = deannotate (const Nothing) xx - msxx' <- f kenv tenv sxx - case msxx' of - Nothing -> return $ xx - Just sxx' -> return $ annotate a sxx' - - in transformUpMX f' kenv0 tenv0 xx0 - - --- | Like `transformUpX`, but the worker takes the Simple version of the AST. --- --- * To avoid repeated conversions between the different versions of the AST, --- the worker should return `Nothing` if the provided expression is unchanged. -transformSimpleUpX - :: forall (c :: * -> * -> *) a n - . (Ord n, TransformUpMX Identity c) - => (KindEnv n -> TypeEnv n -> S.Exp a n -> Maybe (S.Exp a n)) - -- ^ The worker function is given the current - -- kind and type environments. - -> KindEnv n -- ^ Initial kind environment. - -> TypeEnv n -- ^ Initial type environment. - -> c a n -- ^ Transform this thing. - -> c a n - -transformSimpleUpX f kenv tenv xx - = runIdentity - $ transformSimpleUpMX - (\kenv' tenv' x -> return (f kenv' tenv' x)) - kenv tenv xx - - --- | Like `transformUpX'`, but the worker takes the Simple version of the AST. --- --- * To avoid repeated conversions between the different versions of the AST, --- the worker should return `Nothing` if the provided expression is unchanged. -transformSimpleUpX' - :: forall (c :: * -> * -> *) a n - . (Ord n, TransformUpMX Identity c) - => (S.Exp a n -> Maybe (S.Exp a n)) - -- ^ The worker function is given the current - -- kind and type environments. - -> c a n -- ^ Transform this thing. - -> c a n - -transformSimpleUpX' f xx - = transformSimpleUpX (\_ _ -> f) Env.empty Env.empty xx - + (transformUpMX f env x) diff --git a/DDC/Core/Transform/Unshare.hs b/DDC/Core/Transform/Unshare.hs --- a/DDC/Core/Transform/Unshare.hs +++ b/DDC/Core/Transform/Unshare.hs @@ -13,7 +13,7 @@ ------------------------------------------------------------------------------- -- | Apply the unsharing transform to a module. unshareModule - :: (Ord n, Show n) + :: (Show a, Ord n, Show n) => Module (AnTEC a n) n -> Module (AnTEC a n) n unshareModule !mm @@ -52,7 +52,8 @@ -- imported module. -- addParamsImportValue - :: ImportValue n -> (ImportValue n, Map n (Type n)) + :: ImportValue n (Type n) + -> (ImportValue n (Type n), Map n (Type n)) addParamsImportValue iv = case iv of @@ -77,15 +78,19 @@ TVar{} -> Just $ tUnit `tFun` tt TCon{} -> Just $ tUnit `tFun` tt - TForall b tBody + TAbs b tBody -> do tBody' <- addParamsT tBody - return $ TForall b tBody' + return $ TAbs b tBody' TApp{} -> case takeTFun tt of Nothing -> Just $ tUnit `tFun` tt Just _ -> Nothing + TForall b tBody + -> do tBody' <- addParamsT tBody + return $ TForall b tBody' + TSum{} -> Nothing @@ -175,7 +180,7 @@ -- we've already added an extra unit parameter to. When we find them, -- add the matching unit argument. -- -addArgsX :: (Show n, Ord n) +addArgsX :: (Show n, Ord n, Show a) => Map n (Type n) -- ^ Map of names of CAFs that we've added -- parameters to, to their transformed types. -> Exp (AnTEC a n) n -- ^ Transform this expression. @@ -189,9 +194,12 @@ in case xx of -- Add an extra argument for a monomorphic CAF. - XVar _a (UName n) + XVar a (UName n) -> case Map.lookup n nts of - Just tF -> fst $ wrapAppX xx tF + Just tF + -> let xx' = XVar (a { annotType = tF }) (UName n) + in wrapAppX a tF xx' + Nothing -> xx XVar{} -> xx @@ -214,11 +222,12 @@ = let downX = addArgsX nts tA = annotType $ annotOfExp xx in case xx of - XVar _a (UName n) + XVar a (UName n) -> case Map.lookup n nts of Just tF - -> let (x1, t1) = wrapAtsX xx tF ats - (x2, _) = wrapAppX x1 t1 + -> let xx' = XVar (a { annotType = tF }) (UName n) + (x1, t1) = wrapAtsX xx' tF ats + x2 = wrapAppX a t1 x1 in x2 Nothing @@ -254,25 +263,38 @@ -- Wrap an expression with an application of a unit value. -wrapAppX :: Exp (AnTEC a n) n +wrapAppX :: (Show a, Show n) + => AnTEC a n -> Type n - -> (Exp (AnTEC a n) n, Type n) + -> Exp (AnTEC a n) n + -> Exp (AnTEC a n) n -wrapAppX xF tF - = case takeTFun tF of - Just (_, tResult) - -> let a = annotOfExp xF - aR = a { annotType = tResult } - aV = a { annotType = tF } - aU = a { annotType = tUnit } - xF' = mapAnnotOfExp (const aV) xF - in ( XApp aR xF' (xUnit aU) - , tResult) +wrapAppX a tF xF + | Just (_, tResult) <- takeTFun tF + = let a' = annotOfExp xF + aR = a' { annotType = tResult } + aV = a' { annotType = tF } + aU = a' { annotType = tUnit } + xF' = mapAnnotOfExp (const aV) xF + in XApp aR xF' (xUnit aU) - Nothing - -> (xF, tF) + -- ISSUE #384: Unshare transform produces AST node with wrong type annotation. + | Just (bs, tBody) <- takeTForalls tF + = let Just us = sequence + $ map takeSubstBoundOfBind bs + xF' = makeXLamFlags a [(True, b) | b <- bs] + $ wrapAppX a tBody + $ xApps a xF (map (XType a) $ map TVar us) + + in xF' + + + | otherwise + = xF + + -- Apply the given type arguments to an expression. wrapAtsX !xF !tF [] = (xF, tF) @@ -297,7 +319,8 @@ -- the give map. updateExportSource :: Ord n - => Map n (Type n) -> ExportSource n -> ExportSource n + => Map n (Type n) + -> ExportSource n (Type n) -> ExportSource n (Type n) updateExportSource mm ex = case ex of diff --git a/DDC/Type/Transform/Alpha.hs b/DDC/Type/Transform/Alpha.hs --- a/DDC/Type/Transform/Alpha.hs +++ b/DDC/Type/Transform/Alpha.hs @@ -16,8 +16,9 @@ = case tt of TVar u -> TVar (alpha f u) TCon c -> TCon (alpha f c) - TForall b t -> TForall (alpha f b) (alpha f t) + TAbs b t -> TAbs (alpha f b) (alpha f t) TApp t1 t2 -> TApp (alpha f t1) (alpha f t2) + TForall b t -> TForall (alpha f b) (alpha f t) TSum ts -> TSum (alpha f ts) diff --git a/DDC/Type/Transform/AnonymizeT.hs b/DDC/Type/Transform/AnonymizeT.hs --- a/DDC/Type/Transform/AnonymizeT.hs +++ b/DDC/Type/Transform/AnonymizeT.hs @@ -4,8 +4,7 @@ , AnonymizeT(..) , pushAnonymizeBindT) where -import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import Data.List import qualified DDC.Type.Sum as T @@ -36,13 +35,17 @@ TCon{} -> tt - TForall b t + TAbs b t -> let (kstack', b') = pushAnonymizeBindT kstack b - in TForall b' (anonymizeWithT kstack' t) + in TAbs b' (anonymizeWithT kstack' t) TApp t1 t2 -> TApp (anonymizeWithT kstack t1) (anonymizeWithT kstack t2) + TForall b t + -> let (kstack', b') = pushAnonymizeBindT kstack b + in TForall b' (anonymizeWithT kstack' t) + TSum ss -> TSum (anonymizeWithT kstack ss) @@ -68,8 +71,7 @@ -- | Push a binding occurrence of a level-1 variable on the stack, -- returning the anonyized binding occurrence and the new stack. pushAnonymizeBindT - :: Ord n - => [Bind n] -- ^ Stack for Spec binders (level-1) + :: [Bind n] -- ^ Stack for Spec binders (level-1) -> Bind n -> ([Bind n], Bind n) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/ddc-core-simpl.cabal b/ddc-core-simpl.cabal --- a/ddc-core-simpl.cabal +++ b/ddc-core-simpl.cabal @@ -1,5 +1,5 @@ Name: ddc-core-simpl -Version: 0.4.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,14 +14,13 @@ Library Build-Depends: - base >= 4.6 && < 4.9, + base >= 4.6 && < 4.10, array >= 0.4 && < 0.6, deepseq >= 1.3 && < 1.5, containers == 0.5.*, - transformers == 0.4.*, + transformers == 0.5.*, mtl == 2.2.1.*, - ddc-base == 0.4.2.*, - ddc-core == 0.4.2.* + ddc-core == 0.4.3.* Exposed-modules: DDC.Core.Analysis.Arity @@ -57,6 +56,7 @@ DDC.Core.Transform.TransformModX DDC.Core.Transform.TransformUpX DDC.Core.Transform.Unshare + DDC.Core.Simplifier DDC.Type.Transform.Alpha @@ -68,6 +68,8 @@ DDC.Core.Simplifier.Lexer DDC.Core.Transform.Inline.Templates + DDC.Core.Transform.Lambdas.Base + DDC.Core.Transform.Lambdas.Lift DDC.Core.Transform.Rewrite.Error GHC-options: