ddc-core-simpl 0.4.2.1 → 0.4.3.1

raw patch · 37 files changed

+934/−798 lines, 37 filesdep −ddc-basedep ~basedep ~ddc-coredep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: ddc-base

Dependency ranges changed: base, ddc-core, transformers

API changes (from Hackage documentation)

Files

• DDC/Core/Analysis/Arity.hs +2/−2
• DDC/Core/Analysis/Usage.hs +4/−0
• DDC/Core/Simplifier/Apply.hs +32/−20
• DDC/Core/Simplifier/Base.hs +1/−2
• DDC/Core/Simplifier/Lexer.hs +2/−3
• DDC/Core/Simplifier/Parser.hs +4/−5
• DDC/Core/Simplifier/Recipe.hs +0/−2
• DDC/Core/Simplifier/Result.hs +2/−2
• DDC/Core/Transform/AnonymizeX.hs +1/−1
• DDC/Core/Transform/Beta.hs +7/−7
• DDC/Core/Transform/Boxing.hs +15/−15
• DDC/Core/Transform/Elaborate.hs +1/−1
• DDC/Core/Transform/Eta.hs +43/−40
• DDC/Core/Transform/Flatten.hs +1/−1
• DDC/Core/Transform/FoldCase.hs +2/−1
• DDC/Core/Transform/Forward.hs +5/−1
• DDC/Core/Transform/Inline/Templates.hs +3/−3
• DDC/Core/Transform/Lambdas.hs +284/−403
• DDC/Core/Transform/Lambdas/Base.hs +103/−0
• DDC/Core/Transform/Lambdas/Lift.hs +184/−0
• DDC/Core/Transform/Namify.hs +10/−6
• DDC/Core/Transform/Prune.hs +26/−25
• DDC/Core/Transform/Rewrite.hs +4/−5
• DDC/Core/Transform/Rewrite/Disjoint.hs +6/−8
• DDC/Core/Transform/Rewrite/Env.hs +2/−4
• DDC/Core/Transform/Rewrite/Error.hs +1/−1
• DDC/Core/Transform/Rewrite/Match.hs +5/−5
• DDC/Core/Transform/Rewrite/Parser.hs +14/−14
• DDC/Core/Transform/Rewrite/Rule.hs +64/−63
• DDC/Core/Transform/Snip.hs +3/−5
• DDC/Core/Transform/Thread.hs +1/−1
• DDC/Core/Transform/TransformUpX.hs +36/−114
• DDC/Core/Transform/Unshare.hs +48/−25
• DDC/Type/Transform/Alpha.hs +2/−1
• DDC/Type/Transform/AnonymizeT.hs +8/−6
• LICENSE +1/−1
• ddc-core-simpl.cabal +7/−5

@@ -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        -> []

@@ -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 }  

@@ -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+ 

@@ -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.

@@ -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 "<simplifier spec>" 0 0)) + = map (\t -> Located (SourcePos "<simplifier spec>" 0 0) t)   $ lexer readName str  

@@ -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 "<simplifier spec>" 0 0)+ = let  kend    = Located (SourcePos "<simplifier spec>" 0 0) KEnd         toks    = lexSimplifier readName str ++ [kend]    in   P.runTokenParser show "<simplifier spec>"                  (pSimplifier details)@@ -152,7 +151,7 @@  -- | Parse an inlining specification. pInlinerSpec -        :: (Ord n, Show n)+        :: Ord n         => Parser n (ModuleName, InlineSpec n)  pInlinerSpec 

@@ -91,8 +91,6 @@ snipOver  = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True })  -- -- Compound ------------------------------------------------------------------- -- | Conversion to administrative normal-form. anormalize 

@@ -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 ------------------------------------------------------------

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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'  

@@ -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]

@@ -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 _

@@ -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' }  

@@ -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

@@ -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 

@@ -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+

@@ -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+

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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 [] [] []  

@@ -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

@@ -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,

@@ -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

@@ -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 ()  

@@ -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.

@@ -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)

@@ -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) 

@@ -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

@@ -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)  

@@ -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) 

@@ -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

@@ -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: