diff --git a/DDC/Core/Analysis/Arity.hs b/DDC/Core/Analysis/Arity.hs --- a/DDC/Core/Analysis/Arity.hs +++ b/DDC/Core/Analysis/Arity.hs @@ -22,10 +22,8 @@ , arityFromType , arityOfExp) where -import DDC.Core.Predicates -import DDC.Core.Compounds import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Data.ListUtils import Control.Monad import Data.Maybe @@ -37,7 +35,7 @@ -- | Empty arities context. -emptyArities :: Ord n => Arities n +emptyArities :: Arities n emptyArities = (Map.empty, []) @@ -78,10 +76,10 @@ aritiesImports = catMaybes - $ [ case arityFromType t of - Just a -> Just (BName n t, a) + $ [ case arityFromType (typeOfImportValue isrc) of + Just a -> Just (BName n (typeOfImportValue isrc), a) Nothing -> Nothing - | (n, (_, t)) <- Map.toList $ moduleImportTypes mm ] + | (n, isrc) <- moduleImportValues mm ] in emptyArities `extendsArities` aritiesImports @@ -103,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 -> [] @@ -119,7 +117,8 @@ XLAM _ _ e -> liftM (+ 1) $ arityOfExp e -- Determine a data constructor's arity from its type. - XCon _ dc -> arityFromType (typeOfDaCon dc) + XCon _ (DaConPrim _ t) + -> arityFromType t -- Anything else we'll need to apply one at a time _ -> Just 0 diff --git a/DDC/Core/Analysis/Usage.hs b/DDC/Core/Analysis/Usage.hs --- a/DDC/Core/Analysis/Usage.hs +++ b/DDC/Core/Analysis/Usage.hs @@ -10,10 +10,11 @@ , usageX) where import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import Data.List import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (mapMaybe) -- Used ----------------------------------------------------------------------- @@ -25,8 +26,8 @@ -- | Bound variable is destructed by a case-expression. | UsedDestruct - -- | Bound variable is used inside a @weakclo@ cast. - | UsedInCast + -- | Bound variable is used inside a @weakclo@ cast. + | UsedInCast -- | Bound variable has an occurrence that is not one of the above. | UsedOcc @@ -71,6 +72,14 @@ = foldl' plusUsedMap m ms +-- | Remove some binds from a usage map +removeUsedMap :: Ord n => UsedMap n -> [Bind n] -> UsedMap n +removeUsedMap (UsedMap m) bs + = UsedMap + $ foldr Map.delete m + $ mapMaybe takeNameOfBind bs + + -- Module --------------------------------------------------------------------- -- | Annotate all binding occurrences of variables in an expression -- with how they are used. @@ -78,21 +87,33 @@ :: Ord n => Module a n -> Module (UsedMap n, a) n -usageModule +usageModule (ModuleCore { moduleName = name - , moduleExportKinds = exportKinds + , moduleIsHeader = isHeader , moduleExportTypes = exportTypes - , moduleImportKinds = importKinds + , moduleExportValues = exportValues , moduleImportTypes = importTypes + , moduleImportCaps = importCaps + , moduleImportValues = importValues + , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs + , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = body }) = ModuleCore { moduleName = name - , moduleExportKinds = exportKinds + , moduleIsHeader = isHeader , moduleExportTypes = exportTypes - , moduleImportKinds = importKinds + , moduleExportValues = exportValues , moduleImportTypes = importTypes + , moduleImportCaps = importCaps + , moduleImportValues = importValues + , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs + , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = usageX body } @@ -126,7 +147,8 @@ | ( used2, x2') <- usageX' x2 , UsedMap us2 <- used2 , used2' <- UsedMap (Map.map (map UsedInLambda) us2) - -> ( used2' + , cleared <- removeUsedMap used2' [b1] + -> ( cleared , XLAM (used2', a) b1 x2') -- Wrap usages from the body in UsedInLambda to signal that if we move @@ -135,7 +157,8 @@ | ( used2, x2') <- usageX' x2 , UsedMap us2 <- used2 , used2' <- UsedMap (Map.map (map UsedInLambda) us2) - -> ( used2' + , cleared <- removeUsedMap used2' [b1] + -> ( cleared , XLam (used2', a) b1 x2') XApp a x1 x2 @@ -158,7 +181,9 @@ | ( used1, lts') <- usageLets lts , ( used2, x2') <- usageX' x2 , used' <- used1 `plusUsedMap` used2 - -> ( used' + , cleared <- removeUsedMap used' + $ uncurry (++) (bindsOfLets lts) + -> ( cleared , XLet (used', a) lts' x2') -- Wrap usages in the Alts in UsedInAlt to signal that if we move @@ -179,13 +204,14 @@ -> ( used' , XCast (used', a) c' x1') - XType t - -> (empty, XType t) + XType a t + -> ( empty + , XType (empty, a) t) - XWitness w + XWitness a w | (used', w') <- usageWitness w -> ( used' - , XWitness w') + , XWitness (used', a) w') -- | Annotate binding occurences of named variables with usage information. @@ -206,15 +232,12 @@ , used' <- sumUsedMap useds' -> (used', LRec $ zip bs xs') - LLetRegions b bs - -> (empty, LLetRegions b bs) - - LWithRegion b - -> (empty, LWithRegion b) + LPrivate b mt bs + -> (empty, LPrivate b mt bs) -- | Annotate binding occurrences of named value variables with --- usage information. +-- usage information. usageCast :: Ord n => Cast a n @@ -224,21 +247,11 @@ CastWeakenEffect eff -> (empty, CastWeakenEffect eff) - CastWeakenClosure xs - | (useds, xs') <- unzip $ map usageX' xs - , UsedMap used' <- sumUsedMap useds - , usedCasts <- Map.map (map $ const UsedInCast) used' - -> (UsedMap usedCasts, CastWeakenClosure xs') - CastPurify w | (used, w') <- usageWitness w -> (used, CastPurify w') - CastForget w - | (used, w') <- usageWitness w - -> (used, CastForget w') - - CastSuspend -> (empty, CastSuspend) + CastBox -> (empty, CastBox) CastRun -> (empty, CastRun) @@ -274,12 +287,6 @@ , (used2, w2') <- usageWitness w2 , used' <- plusUsedMap used1 used2 -> (empty, WApp (used', a) w1' w2') - - WJoin a w1 w2 - | (used1, w1') <- usageWitness w1 - , (used2, w2') <- usageWitness w2 - , used' <- plusUsedMap used1 used2 - -> (empty, WJoin (used', a) w1' w2') WType a t -> (empty, WType (empty, a) t) diff --git a/DDC/Core/Simplifier/Apply.hs b/DDC/Core/Simplifier/Apply.hs --- a/DDC/Core/Simplifier/Apply.hs +++ b/DDC/Core/Simplifier/Apply.hs @@ -6,107 +6,175 @@ , applySimplifierX , applyTransformX) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Module import DDC.Core.Exp import DDC.Core.Fragment import DDC.Core.Simplifier.Base import DDC.Core.Transform.AnonymizeX -import DDC.Core.Transform.Snip as Snip -import DDC.Core.Transform.Flatten import DDC.Core.Transform.Beta -import DDC.Core.Transform.Eta as Eta -import DDC.Core.Transform.Prune -import DDC.Core.Transform.Forward as Forward import DDC.Core.Transform.Bubble +import DDC.Core.Transform.Elaborate +import DDC.Core.Transform.Eta as Eta +import DDC.Core.Transform.Flatten +import DDC.Core.Transform.Forward as Forward import DDC.Core.Transform.Inline import DDC.Core.Transform.Namify +import DDC.Core.Transform.Prune import DDC.Core.Transform.Rewrite -import DDC.Core.Transform.Elaborate -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 Control.DeepSeq -import qualified DDC.Base.Pretty as P -import qualified Data.Set as Set +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 -------------------------------------------------------------------- -- | Apply a simplifier to a module. -- -- The state monad can be used by `Namifier` functions to generate fresh names. ---- --- ISSUE #277: Make 'applySimplifier' return a TransformResult --- Applying a simplifier to an expression yields a TransformResult --- with the transform log, and we should get one for a module as well. -- applySimplifier - :: (Show a, Ord n, Show n, Pretty n, NFData a, NFData n) - => Profile n -- ^ Profile of language we're working in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment + :: (Show a, Pretty a, Ord n, Show n, Pretty n, CompoundName n) + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment -> Simplifier s a n -- ^ Simplifier to apply -> Module a n -- ^ Module to simplify - -> State s (Module a n) + -> State s (TransformResult (Module a n)) applySimplifier !profile !kenv !tenv !spec !mm - = case spec of + = let down = applySimplifier profile kenv tenv + in case spec of Seq t1 t2 - -> do !mm' <- applySimplifier profile kenv tenv t1 mm - applySimplifier profile kenv tenv t2 mm' + -> do tm <- down t1 mm + tm' <- down t2 (result tm) + let info = + case (resultInfo tm, resultInfo tm') of + (TransformInfo i1, TransformInfo i2) -> SeqInfo i1 i2 + + let again = resultAgain tm || resultAgain tm' + let progress = resultProgress tm || resultProgress tm' + + return TransformResult + { result = result tm' + , resultAgain = again + , resultProgress = progress + , resultInfo = TransformInfo info } + + Fix i s + -> do tm <- applyFixpoint profile kenv tenv i s mm + let info = + case resultInfo tm of + TransformInfo info1 -> FixInfo i info1 + + return TransformResult + { result = result tm + , resultAgain = resultAgain tm + , resultProgress = resultProgress tm + , resultInfo = TransformInfo info } + Trans t1 -> applyTransform profile kenv tenv t1 mm - - Fix 0 _ - -> return mm - Fix !n !s - -> do !mm' <- applySimplifier profile kenv tenv s mm - applySimplifier profile kenv tenv (Fix (n - 1) s) mm' +-- | Apply a transform until it stops progressing, or a maximum number of times +applyFixpoint + :: (Show a, Pretty a, Ord n, Show n, Pretty n, CompoundName n) + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment + -> Int -- ^ Maximum number of times to apply + -> Simplifier s a n -- ^ Transform to apply. + -> Module a n -- ^ Module to simplify. + -> State s (TransformResult (Module a n)) +applyFixpoint !profile !kenv !tenv !i' !spec !mm' + = go i' mm' False + where + simp = applySimplifier profile kenv tenv spec + + go 0 mm progress + = do tm <- simp mm + return tm { resultProgress = progress } + + go i mm progress + = do tm <- simp mm + case resultAgain tm of + False + -> return tm { resultProgress = progress } + + True + -> do tm' <- go (i-1) (result tm) True + + let info + = case (resultInfo tm, resultInfo tm') of + (TransformInfo i1, TransformInfo i2) + -> SeqInfo i1 i2 + + return TransformResult + { result = result tm' + , resultAgain = resultProgress tm' + , resultProgress = resultProgress tm' + , resultInfo = TransformInfo info } + -- | Apply a transform to a module. applyTransform - :: (Show a, Ord n, Show n, Pretty n) - => Profile n -- ^ Profile of language we're working in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment + :: (Show a, Pretty a, Ord n, Show n, Pretty n, CompoundName n) + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment -> Transform s a n -- ^ Transform to apply. -> Module a n -- ^ Module to simplify. - -> State s (Module a n) + -> State s (TransformResult (Module a n)) applyTransform !profile !_kenv !_tenv !spec !mm - = case spec of - Id -> return mm - Anonymize -> return $ anonymizeX mm - Snip config -> return $ snip config mm - Flatten -> return $ flatten mm - Beta config -> return $ result $ betaReduce config mm - Eta config -> return $ result $ Eta.etaModule config profile mm + = let res x = return $ resultDone (show $ ppr spec) x + in case spec of + Id -> res mm + Anonymize -> res $ anonymizeX mm + Beta config -> return $ betaReduce profile config mm + Bubble -> res $ bubbleModule mm + Elaborate -> res $ elaborateModule mm + Eta config -> return $ Eta.etaModule profile config mm + Flatten -> res $ flatten mm Forward -> let config = Forward.Config (const FloatAllow) False - in return $ result $ forwardModule profile config mm + in return $ forwardModule profile config mm - Bubble -> return $ bubbleModule mm - Namify namK namT -> namifyUnique namK namT mm - Inline getDef -> return $ inline getDef Set.empty mm - Rewrite rules -> return $ rewriteModule rules mm - Prune -> return $ pruneModule profile mm - Elaborate -> return $ elaborateModule mm + FoldCase config -> res $ FoldCase.foldCase config mm + Inline getDef -> res $ inline getDef Set.empty 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.snip config mm + + -- Expressions ---------------------------------------------------------------- -- | Apply a simplifier to an expression. -- -- The state monad can be used by `Namifier` functions to generate fresh names. -- applySimplifierX - :: (Show a, Show n, Ord n, Pretty n) - => Profile n -- ^ Profile of language we're working in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment + :: (Show a, Pretty a, Show n, Ord n, Pretty n, CompoundName n) + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment -> Simplifier s a n -- ^ Simplifier to apply -> Exp a n -- ^ Expression to simplify -> State s (TransformResult (Exp a n)) @@ -118,43 +186,43 @@ -> do tx <- down t1 xx tx' <- down t2 (result tx) - let info = - case (resultInfo tx, resultInfo tx') of - (TransformInfo i1, TransformInfo i2) -> SeqInfo i1 i2 - + let info = + case (resultInfo tx, resultInfo tx') of + (TransformInfo i1, TransformInfo i2) -> SeqInfo i1 i2 + let again = resultAgain tx || resultAgain tx' let progress = resultProgress tx || resultProgress tx' - return TransformResult + return TransformResult { result = result tx' , resultAgain = again , resultProgress = progress , resultInfo = TransformInfo info } - Fix i s - -> do tx <- applyFixpointX profile kenv tenv i s xx - let info = - case resultInfo tx of - TransformInfo info1 -> FixInfo i info1 - - return TransformResult + Fix i s + -> do tx <- applyFixpointX profile kenv tenv i s xx + let info = + case resultInfo tx of + TransformInfo info1 -> FixInfo i info1 + + return TransformResult { result = result tx , resultAgain = resultAgain tx , resultProgress = resultProgress tx , resultInfo = TransformInfo info } - + Trans t1 -> applyTransformX profile kenv tenv t1 xx -- | Apply a simplifier until it stops progressing, or a maximum number of times applyFixpointX - :: (Show a, Show n, Ord n, Pretty n) - => Profile n -- ^ Profile of language we're working in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment - -> Int -- ^ Maximum number of times to apply - -> Simplifier s a n -- ^ Simplifier to apply. + :: (Show a, Pretty a, Show n, Ord n, Pretty n, CompoundName n) + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment + -> Int -- ^ Maximum number of times to apply + -> Simplifier s a n -- ^ Simplifier to apply. -> Exp a n -- ^ Exp to simplify. -> State s (TransformResult (Exp a n)) @@ -170,19 +238,19 @@ go i xx progress = do tx <- simp xx case resultAgain tx of - False + False -> return tx { resultProgress = progress } - True + True -> do tx' <- go (i-1) (result tx) True - let info + let info = case (resultInfo tx, resultInfo tx') of - (TransformInfo i1, TransformInfo i2) + (TransformInfo i1, TransformInfo i2) -> SeqInfo i1 i2 - return TransformResult - { result = result tx' + return TransformResult + { result = result tx' , resultAgain = resultProgress tx' , resultProgress = resultProgress tx' , resultInfo = TransformInfo info } @@ -217,31 +285,38 @@ -- | Apply a single transform to an expression. applyTransformX :: (Show a, Show n, Ord n, Pretty n) - => Profile n -- ^ Profile of language we're working in - -> KindEnv n -- ^ Kind environment - -> TypeEnv n -- ^ Type environment + => Profile n -- ^ Profile of language we're working in + -> KindEnv n -- ^ Kind environment + -> TypeEnv n -- ^ Type environment -> Transform s a n -- ^ Transform to apply. -> Exp a n -- ^ Exp to transform. -> 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 - Snip config -> res $ snip config 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 env xx Flatten -> res $ flatten xx - Inline getDef -> res $ inline getDef Set.empty xx - Beta config -> return $ betaReduce config xx - Eta config -> return $ Eta.etaX config profile kenv tenv xx - Prune -> return $ pruneX profile kenv tenv xx Forward -> let config = Forward.Config (const FloatAllow) False in return $ forwardX profile config xx - Bubble -> res $ bubbleX kenv tenv xx + Inline getDef -> res $ inline getDef Set.empty xx + FoldCase config -> res $ FoldCase.foldCase config xx + Lambdas -> res $ xx Namify namK namT -> namifyUnique namK namT xx >>= res + Prune -> return $ pruneX profile env xx Rewrite rules -> return $ rewriteX rules xx - Elaborate{} -> res $ elaborateX xx - + Snip config -> res $ Snip.snip config xx + + diff --git a/DDC/Core/Simplifier/Base.hs b/DDC/Core/Simplifier/Base.hs --- a/DDC/Core/Simplifier/Base.hs +++ b/DDC/Core/Simplifier/Base.hs @@ -10,20 +10,20 @@ -- * Transform Results , TransformResult(..) - , TransformInfo(..) - , NoInformation - , resultDone) + , TransformInfo(..) + , NoInformation + , resultDone) where import DDC.Core.Simplifier.Result import DDC.Core.Transform.Rewrite.Rule 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 -import Data.Monoid +import qualified DDC.Core.Transform.FoldCase as FoldCase -- Simplifier ----------------------------------------------------------------- @@ -38,7 +38,7 @@ -- | Keep applying a transform until it reports that further -- applications won't be helpful, bailing out after a maximum number -- of applications. - | Fix Int (Simplifier s a n) + | Fix Int (Simplifier s a n) instance Monoid (Simplifier s a n) where @@ -68,40 +68,35 @@ -- | Rewrite named binders to anonymous deBruijn binders. | Anonymize - -- | Introduce let-bindings for nested applications. - | Snip Snip.Config - - -- | Flatten nested let and case expressions. - | Flatten - -- | Perform beta reduction when the argument is not a redex. | Beta Beta.Config + -- | Float casts outwards. + | Bubble + + -- | Elaborate possible Const and Distinct witnesses that aren't + -- otherwise in the program. + | Elaborate + -- | Perform eta expansion and reduction. | Eta Eta.Config - -- | Remove unused, pure let bindings. - | Prune + -- | Flatten nested let and case expressions. + | Flatten -- | Float single-use bindings forward into their use sites. | Forward - -- | Float casts outwards. - | Bubble - - -- | Elaborate possible Const and Distinct witnesses that aren't - -- otherwise in the program. - | Elaborate + -- | Fold case expressions. + | FoldCase FoldCase.Config -- | Inline definitions into their use sites. | Inline { -- | Get the unfolding for a named variable. transInlineDef :: InlinerTemplates a n } - -- | Apply general rule-based rewrites. - | Rewrite - { -- | List of rewrite rules along with their names. - transRules :: NamedRewriteRules a n } + -- | Perform lambda lifting. + | Lambdas -- | Rewrite anonymous binders to fresh named binders. | Namify @@ -115,7 +110,18 @@ -- environment. , transMkNamifierX :: Env n -> Namifier s n } + -- | Remove unused, pure let bindings. + | Prune + -- | Apply general rule-based rewrites. + | Rewrite + { -- | List of rewrite rules along with their names. + transRules :: NamedRewriteRules a n } + + -- | Introduce let-bindings for nested applications. + | Snip Snip.Config + + -- | Function to get the inliner template (unfolding) for the given name. type InlinerTemplates a n = (n -> Maybe (Exp a n)) @@ -130,15 +136,18 @@ = case ss of Id -> text "Id" Anonymize -> text "Anonymize" - Snip{} -> text "Snip" - Flatten -> text "Flatten" Beta{} -> text "Beta" + Bubble -> text "Bubble" + Elaborate -> text "Elaborate" Eta{} -> text "Eta" - Prune -> text "Prune" + Flatten -> text "Flatten" Forward -> text "Forward" - Bubble -> text "Bubble" + FoldCase{} -> text "FoldCase" Inline{} -> text "Inline" + Lambdas{} -> text "Lambdas" Namify{} -> text "Namify" + Prune -> text "Prune" Rewrite{} -> text "Rewrite" - Elaborate -> text "Elaborate" + Snip{} -> text "Snip" + diff --git a/DDC/Core/Simplifier/Lexer.hs b/DDC/Core/Simplifier/Lexer.hs --- a/DDC/Core/Simplifier/Lexer.hs +++ b/DDC/Core/Simplifier/Lexer.hs @@ -3,7 +3,6 @@ ( Tok(..) , lexSimplifier) where -import DDC.Data.Token import DDC.Data.SourcePos import Data.Char @@ -11,10 +10,10 @@ lexSimplifier :: (String -> Maybe n) -- ^ Function to read a name. -> String -- ^ String to parse. - -> [Token (Tok n)] + -> [Located (Tok n)] lexSimplifier readName str - = map (\t -> Token t (SourcePos "" 0 0)) + = map (\t -> Located (SourcePos "" 0 0) t) $ lexer readName str diff --git a/DDC/Core/Simplifier/Parser.hs b/DDC/Core/Simplifier/Parser.hs --- a/DDC/Core/Simplifier/Parser.hs +++ b/DDC/Core/Simplifier/Parser.hs @@ -9,19 +9,19 @@ 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.Base.Parser as P +import qualified DDC.Core.Transform.FoldCase as FoldCase +import qualified DDC.Control.Parser as P import qualified Data.Map as Map import qualified Data.Set as Set -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Auxilliary information that may be used by a simplifier. data SimplifierDetails s a n = SimplifierDetails @@ -40,7 +40,7 @@ , simplifierTemplates :: [Module a n] } -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | A parser of simplifier specifications. type Parser n a = P.Parser (Tok n) a @@ -54,7 +54,7 @@ -> Either P.ParseError (Simplifier s a n) parseSimplifier readName details str - = let kend = Token KEnd (SourcePos "" 0 0) + = let kend = Located (SourcePos "" 0 0) KEnd toks = lexSimplifier readName str ++ [kend] in P.runTokenParser show "" (pSimplifier details) @@ -151,7 +151,7 @@ -- | Parse an inlining specification. pInlinerSpec - :: (Ord n, Show n) + :: Ord n => Parser n (ModuleName, InlineSpec n) pInlinerSpec @@ -192,21 +192,21 @@ = case name of "Id" -> Just Id "Anonymize" -> Just Anonymize - - "Snip" -> Just (Snip Snip.configZero) - "SnipOver" -> Just (Snip Snip.configZero { Snip.configSnipOverApplied = True }) - - "Eta" -> Just (Eta Eta.configZero { Eta.configExpand = True }) - - "Flatten" -> Just Flatten - "Beta" -> Just (Beta Beta.configZero) "BetaLets" -> Just (Beta Beta.configZero { Beta.configBindRedexes = True }) - - "Prune" -> Just Prune - "Forward" -> Just Forward "Bubble" -> Just Bubble "Elaborate" -> Just Elaborate + "Eta" -> Just (Eta Eta.configZero { Eta.configExpand = True }) + "Flatten" -> Just Flatten + "Forward" -> Just Forward + "FoldCase" -> Just (FoldCase FoldCase.configZero + { FoldCase.configCaseOfConstructor = True + , FoldCase.configCaseOfCase = True }) + "Lambdas" -> Just Lambdas + "Prune" -> Just Prune + "Snip" -> Just (Snip Snip.configZero) + "SnipOver" -> Just (Snip Snip.configZero { Snip.configSnipOverApplied = True }) + "SnipBody" -> Just (Snip Snip.configZero { Snip.configSnipLetBody = True }) _ -> Nothing | otherwise @@ -232,5 +232,4 @@ pModuleName = P.pTokMaybe f where f (KCon n) = Just $ ModuleName [n] f _ = Nothing - diff --git a/DDC/Core/Simplifier/Recipe.hs b/DDC/Core/Simplifier/Recipe.hs --- a/DDC/Core/Simplifier/Recipe.hs +++ b/DDC/Core/Simplifier/Recipe.hs @@ -4,19 +4,20 @@ ( -- * Atomic recipies idsimp , anonymize - , snip - , snipOver - , flatten , beta , betaLets - , prune - , forward , bubble , elaborate + , flatten + , forward + , lambdas + , snip + , snipOver + , prune -- * Compound recipies , anormalize - , rewriteSimp) + , rewriteSimp) where import DDC.Core.Simplifier.Base import DDC.Core.Transform.Namify @@ -39,21 +40,6 @@ anonymize = Trans Anonymize --- | Introduce let-bindings for nested applications. -snip :: Simplifier s a n -snip = Trans (Snip Snip.configZero) - - --- | Introduce let-bindings for nested applications. -snipOver :: Simplifier s a n -snipOver = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True }) - - --- | Flatten nested let and case expressions. -flatten :: Simplifier s a n -flatten = Trans Flatten - - -- | Perform beta reduction beta :: Simplifier s a n beta = Trans (Beta Beta.configZero) @@ -64,16 +50,6 @@ betaLets = Trans (Beta Beta.configZero { Beta.configBindRedexes = True }) --- | Remove unused, pure let bindings. -prune :: Simplifier s a n -prune = Trans Prune - - --- | Float single-use bindings forward into their use sites. -forward :: Simplifier s a n -forward = Trans Forward - - -- | Float casts outwards. bubble :: Simplifier s a n bubble = Trans Bubble @@ -85,6 +61,36 @@ elaborate = Trans Elaborate +-- | Flatten nested let and case expressions. +flatten :: Simplifier s a n +flatten = Trans Flatten + + +-- | Float single-use bindings forward into their use sites. +forward :: Simplifier s a n +forward = Trans Forward + + +-- | Lift out nested lambda expressions to top-level. +lambdas :: Simplifier s a n +lambdas = Trans Lambdas + + +-- | Remove unused, pure let bindings. +prune :: Simplifier s a n +prune = Trans Prune + + +-- | Introduce let-bindings for nested applications. +snip :: Simplifier s a n +snip = Trans (Snip Snip.configZero) + + +-- | Introduce let-bindings for nested applications. +snipOver :: Simplifier s a n +snipOver = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True }) + + -- Compound ------------------------------------------------------------------- -- | Conversion to administrative normal-form. anormalize @@ -104,7 +110,7 @@ rewriteSimp :: Int -- ^ Maximum number of iterations. -> NamedRewriteRules a n -- ^ Rewrite rules to apply. - -> Simplifier s a n + -> Simplifier s a n rewriteSimp maxIters rules = let rewrite = Trans $ Rewrite rules diff --git a/DDC/Core/Simplifier/Result.hs b/DDC/Core/Simplifier/Result.hs --- a/DDC/Core/Simplifier/Result.hs +++ b/DDC/Core/Simplifier/Result.hs @@ -5,9 +5,9 @@ , NoInformation , resultDone) where -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.Typeable -import qualified DDC.Base.Pretty as P +import qualified DDC.Data.Pretty as P -- TransformResult ------------------------------------------------------------ diff --git a/DDC/Core/Transform/AnonymizeX.hs b/DDC/Core/Transform/AnonymizeX.hs --- a/DDC/Core/Transform/AnonymizeX.hs +++ b/DDC/Core/Transform/AnonymizeX.hs @@ -8,12 +8,12 @@ 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 -import qualified Data.Map as Map + -- | Rewrite all binders in a thing to anonymous form. anonymizeX :: (Ord n, AnonymizeX c) => c n -> c n anonymizeX xx @@ -27,8 +27,8 @@ -- The stacks contains existing anonymous binders that we have entered into, -- and named binders that we have rewritten. All bound occurrences of variables -- will be replaced by references into these stacks. - anonymizeWithX - :: forall n. Ord n + anonymizeWithX + :: forall n. Ord n => Set n -- ^ Don't anonymize level-0 binders with these names. -> [Bind n] -- ^ Stack for Spec binders (level-1). -> [Bind n] -- ^ Stack for Data and Witness binders (level-0). @@ -36,12 +36,12 @@ instance AnonymizeX (Module a) where anonymizeWithX keep kstack tstack mm@ModuleCore{} - = let - -- We need to keep exported names, + = let + -- We need to keep exported names, -- because the export list can't deal with anonymous binders. - keep' = Set.union keep - $ Set.fromList - $ Map.keys $ moduleExportTypes mm + keep' = Set.union keep + $ Set.fromList + $ map fst $ moduleExportTypes mm x' = anonymizeWithX keep' kstack tstack (moduleBody mm) @@ -54,9 +54,9 @@ let down = anonymizeWithX keep kstack tstack in case xx of XVar _ UPrim{} -> xx - XCon{} -> xx + XCon{} -> xx - XVar a u@(UName{}) + XVar a u@(UName{}) | Just ix <- findIndex (boundMatchesBind u) tstack -> XVar a (UIx ix) @@ -74,14 +74,14 @@ in XLam a b' (anonymizeWithX keep kstack tstack' x) XLet a lts x - -> let (kstack', tstack', lts') + -> let (kstack', tstack', lts') = pushAnonymizeLets keep kstack tstack lts in XLet a lts' (anonymizeWithX keep kstack' tstack' x) - XCase a x alts -> XCase a (down x) (map down alts) - XCast a c x -> XCast a (down c) (down x) - XType t -> XType (anonymizeWithT kstack t) - XWitness w -> XWitness (down w) + XCase a x alts -> XCase a (down x) (map down alts) + XCast a c x -> XCast a (down c) (down x) + XType a t -> XType a (anonymizeWithT kstack t) + XWitness a w -> XWitness a (down w) instance AnonymizeX (Cast a) where @@ -89,10 +89,8 @@ = let down = anonymizeWithX keep kstack tstack in case cc of CastWeakenEffect eff -> CastWeakenEffect (anonymizeWithT kstack eff) - CastWeakenClosure xs -> CastWeakenClosure (map down xs) CastPurify w -> CastPurify (down w) - CastForget w -> CastForget (down w) - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun @@ -111,7 +109,7 @@ instance AnonymizeX (Witness a) where anonymizeWithX keep kstack tstack ww - = let down = anonymizeWithX keep kstack tstack + = let down = anonymizeWithX keep kstack tstack in case ww of WVar a u@(UName _) | Just ix <- findIndex (boundMatchesBind u) tstack @@ -120,31 +118,30 @@ WVar a u -> WVar a u WCon a c -> WCon a c WApp a w1 w2 -> WApp a (down w1) (down w2) - WJoin a w1 w2 -> WJoin a (down w1) (down w2) WType a t -> WType a (anonymizeWithT kstack t) instance AnonymizeX Bind where anonymizeWithX _keep kstack _tstack bb = let t' = anonymizeWithT kstack $ typeOfBind bb - in replaceTypeOfBind t' bb + in replaceTypeOfBind t' bb -- Push ---------------------------------------------------------------------- --- | Push a binding occurrence of a level-0 on the stack, +-- | Push a binding occurrence of a level-0 on the stack, -- returning the anonyized binding occurrence and the new stack. -pushAnonymizeBindX - :: Ord n +pushAnonymizeBindX + :: Ord n => Set n -- ^ Don't anonymize binders with these names. -> [Bind n] -- ^ Stack for Spec binders (level-1) -> [Bind n] -- ^ Stack for Value and Witness binders (level-0) - -> Bind n + -> Bind n -> ([Bind n], Bind n) pushAnonymizeBindX keep kstack tstack b@(BName n _) | Set.member n keep = let b' = anonymizeWithX keep kstack tstack b - in (tstack, b') + in (tstack, b') pushAnonymizeBindX keep kstack tstack b@BNone{} = let b' = anonymizeWithX keep kstack tstack b @@ -158,15 +155,15 @@ in (tstack', BAnon t') --- | Push a binding occurrence on the stack, +-- | Push a binding occurrence on the stack, -- returning the anonyized binding occurrence and the new stack. -- Used in the definition of `anonymize`. -pushAnonymizeBindXs - :: Ord n +pushAnonymizeBindXs + :: Ord n => Set n -- ^ Don't anonymize binders with these names. -> [Bind n] -- ^ Stack for Spec binders (level-1) -> [Bind n] -- ^ Stack for Value and Witness binders (level-0) - -> [Bind n] + -> [Bind n] -> ([Bind n], [Bind n]) pushAnonymizeBindXs keep kstack tstack bs @@ -175,12 +172,12 @@ tstack bs -pushAnonymizeLets - :: Ord n +pushAnonymizeLets + :: Ord n => Set n - -> [Bind n] - -> [Bind n] - -> Lets a n + -> [Bind n] + -> [Bind n] + -> Lets a n -> ([Bind n], [Bind n], Lets a n) pushAnonymizeLets keep kstack tstack lts @@ -190,18 +187,15 @@ (tstack', b') = pushAnonymizeBindX keep kstack tstack b in (kstack, tstack', LLet b' x') - LRec bxs + LRec bxs -> let (bs, xs) = unzip bxs (tstack', bs') = pushAnonymizeBindXs keep kstack tstack bs xs' = map (anonymizeWithX keep kstack tstack') xs bxs' = zip bs' xs' in (kstack, tstack', LRec bxs') - LLetRegions b bs + LPrivate b mt bs -> let (kstack', b') = mapAccumL pushAnonymizeBindT kstack b (tstack', bs') = pushAnonymizeBindXs keep kstack' tstack bs - in (kstack', tstack', LLetRegions b' bs') - - LWithRegion{} - -> (kstack, tstack, lts) + in (kstack', tstack', LPrivate b' mt bs') diff --git a/DDC/Core/Transform/Beta.hs b/DDC/Core/Transform/Beta.hs --- a/DDC/Core/Transform/Beta.hs +++ b/DDC/Core/Transform/Beta.hs @@ -7,24 +7,22 @@ , Info (..) , betaReduce) where -import DDC.Base.Pretty -import DDC.Core.Collect -import DDC.Core.Exp -import DDC.Core.Predicates +import DDC.Core.Exp.Annot +import DDC.Core.Fragment import DDC.Core.Transform.TransformUpX import DDC.Core.Transform.SubstituteTX import DDC.Core.Transform.SubstituteWX import DDC.Core.Transform.SubstituteXX import DDC.Core.Simplifier.Result -import Control.Monad.Writer (Writer, runWriter, tell) -import Data.Monoid (Monoid, mempty, mappend) -import Data.Typeable (Typeable) -import DDC.Type.Env (Env) -import DDC.Type.Compounds -import qualified DDC.Type.Env as Env -import qualified Data.Set as Set +import DDC.Data.Pretty +import DDC.Core.Env.EnvX (EnvX) +import Control.Monad.Writer (Writer, runWriter, tell) +import Data.Typeable (Typeable) +import Prelude hiding ((<$>)) +import qualified DDC.Core.Env.EnvX as EnvX + ------------------------------------------------------------------------------- data Config = Config @@ -92,14 +90,15 @@ betaReduce :: forall (c :: * -> * -> *) a n . (Ord n, TransformUpMX (Writer Info) c) - => Config - -> c a n + => Profile n -- ^ Language profile. + -> Config -- ^ Beta transform config. + -> c a n -- ^ Thing to transform. -> TransformResult (c a n) -betaReduce config x +betaReduce profile config x = {-# SCC betaReduce #-} let (x', info) = runWriter - $ transformUpMX (betaReduce1 config) Env.empty Env.empty x + $ transformUpMX (betaReduce1 profile config) EnvX.empty x -- Check if any actual work was performed progress @@ -108,10 +107,10 @@ -> (ty + wit + val + lets') > 0 in TransformResult - { result = x' + { result = x' , resultAgain = progress - , resultProgress = progress - , resultInfo = TransformInfo info } + , resultProgress = progress + , resultInfo = TransformInfo info } -- | Do a single beta reduction for this application. @@ -124,72 +123,46 @@ -- betaReduce1 :: Ord n - => Config - -> Env n - -> Env n - -> Exp a n + => Profile n -- ^ Language profile. + -> Config -- ^ Beta tranform config. + -> EnvX n -- ^ Current environment + -> Exp a n -- ^ Expression to transform. -> Writer Info (Exp a n) -betaReduce1 config _kenv tenv xx +betaReduce1 _profile config _env xx = let ret info x = tell info >> return x + in case xx of -- Substitute type arguments into type abstractions. -- If the type argument of the redex does not appear as an -- argument of the result then we need to add a closure weakening -- for the case where t2 was a region variable or handle. - XApp a (XLAM _ b11 x12) (XType t2) + XApp _a (XLAM _ b11 x12) (XType _a2 t2) | isRegionKind $ typeOfBind b11 - -> let sup = support Env.empty Env.empty x12 - - usUsed = Set.unions - [ supportTyConXArg sup - , supportSpVarXArg sup ] - - usesBind = any (flip boundMatchesBind b11) - $ Set.toList usUsed - - fvs2 = freeT Env.empty t2 - - in ret mempty { infoTypes = 1} - $ if usesBind || Set.null fvs2 - then substituteTX b11 t2 x12 - else XCast a (CastWeakenClosure [XType t2]) - $ substituteTX b11 t2 x12 + -> ret mempty { infoTypes = 1} + $ substituteTX b11 t2 x12 -- Substitute type arguments into type abstractions, -- Where the argument is not a region type. - XApp _ (XLAM _ b11 x12) (XType t2) + XApp _a (XLAM _ b11 x12) (XType _ t2) -> ret mempty { infoTypes = 1 } - $ substituteTX b11 t2 x12 + $ substituteTX b11 t2 x12 -- Substitute witness arguments into witness abstractions. - XApp a (XLam _ b11 x12) (XWitness w2) - -> let usesBind = any (flip boundMatchesBind b11) - $ Set.toList $ freeX tenv x12 - fvs2 = freeX Env.empty w2 - in ret mempty { infoWits = 1 } - $ if usesBind || Set.null fvs2 - then substituteWX b11 w2 x12 - else XCast a (CastWeakenClosure [XWitness w2]) - $ substituteWX b11 w2 x12 - + XApp _a (XLam _ b11 x12) (XWitness _a2 w2) + -> ret mempty { infoWits = 1 } + $ substituteWX b11 w2 x12 -- Substitute value arguments into value abstractions. XApp a (XLam _ b11 x12) x2 | canBetaSubstX x2 - -> let usesBind = any (flip boundMatchesBind b11) - $ Set.toList $ freeX tenv x12 - fvs2 = freeX Env.empty x2 - in ret mempty { infoValues = 1 } - $ if usesBind || Set.null fvs2 - then substituteXX b11 x2 x12 - else XCast a (CastWeakenClosure [x2]) - $ substituteXX b11 x2 x12 + -> ret mempty { infoValues = 1 } + $ substituteXX b11 x2 x12 | configBindRedexes config -> ret mempty { infoValuesLetted = 1 } - $ XLet a (LLet b11 x2) x12 + $ XLet a (LLet b11 x2) x12 | otherwise -> ret mempty { infoValuesSkipped = 1 } @@ -213,10 +186,10 @@ XLam{} -> True XLAM{} -> True - XApp _ x1 (XType _) + XApp _ x1 XType{} -> canBetaSubstX x1 - XApp _ x1 (XWitness _) + XApp _ x1 XWitness{} -> canBetaSubstX x1 _ -> False diff --git a/DDC/Core/Transform/Boxing.hs b/DDC/Core/Transform/Boxing.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Boxing.hs @@ -0,0 +1,390 @@ +-- | Manage representation of numeric values in a module. +-- +-- [Note: Boxing and Partial Application] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Unlike in Haskell, we do not allow explictly unboxed types in the source +-- program because we don't want to deal with partial applications of +-- functions to unboxed values. With our current setup we always have a version +-- of each function that accepts boxed values, so we never need to do generic +-- application involving unboxed values. Fast-path function specialisations +-- that take unboxed parameters should be created separately, and not replace +-- the existing slow-path, fully boxed version. Taking this approach is possible +-- in a strict language because the boxed and unboxed values have the same +-- semantic meaning. Boxing of values does not imply "lifting" of the associated +-- semantic domain. +-- +module DDC.Core.Transform.Boxing + ( Rep (..) + , Config (..) + , boxingModule) +where +import DDC.Core.Module +import DDC.Core.Exp.Annot +import DDC.Type.Transform.Instantiate +import Data.Maybe + + +--------------------------------------------------------------------------------------------------- +-- | Representation of the values of some type. +data Rep + -- | These types don't contain any values. + = RepNone + + -- | Values of this type are uncomitted to a particular representation, + -- they just describe a set of logical values. + | RepBoxed + + -- | Values of this type are represented in unboxed form. + | RepUnboxed + deriving (Eq, Ord, Show) + + +data Config a n + = Config + { -- | Get the representation of this type. + configRepOfType :: Type n -> Maybe Rep + + -- | Get the type for a different representation of the given one. + , configConvertRepType :: Rep -> Type n -> Maybe (Type n) + + -- | Convert a value between representations. + , configConvertRepExp :: Rep -> a -> Type n -> Exp a n -> Maybe (Exp a n) + + -- | Take the type of a literal name, if there is one. + , configValueTypeOfLitName :: n -> Maybe (Type n) + + -- | Take the type of a primitive operator name, if it is one. + -- The primops can be polytypic, but must have prenex rank-1 types. + , configValueTypeOfPrimOpName :: n -> Maybe (Type n) + + -- | Take the type of a foreign function name, if it is one. + -- The function can be polymorphic, but must have a prenex rank-1 type. + , configValueTypeOfForeignName :: n -> Maybe (Type n) + + -- | Convert a literal name to its unboxed version. + , configUnboxLitName :: n -> Maybe n + + -- | Covnert a primop name to its unboxed version. + , configUnboxPrimOpName :: n -> Maybe n + } + + +-- Module ----------------------------------------------------------------------------------------- +-- | Manage boxing in a module. +boxingModule + :: Ord n + => Config a n -> Module a n -> Module a n + +boxingModule config mm + = let + -- Use explicitly unboxed types when importing foreign sea functions. + boxingImport imp + = case imp of + ImportValueSea v t + -> ImportValueSea v $ boxingForeignSeaType config t + _ -> imp + + -- Use explicitly unboxed types when exporting foreign sea functions. + nsImportSea = [ n | (n, ImportValueSea _ _) <- moduleImportValues mm] + boxingExport expt + = case expt of + ExportSourceLocal n t + | elem n nsImportSea + -> ExportSourceLocal n $ boxingForeignSeaType config t + _ -> expt + + in mm { moduleBody + = boxingX config (moduleBody mm) + + , moduleExportValues + = [(n, boxingExport expt) | (n, expt) <- moduleExportValues mm ] + + , moduleImportValues + = [(n, boxingImport impt) | (n, impt) <- moduleImportValues mm ] } + + +boxingX config xx + = case xx of + + -- Convert literals to their unboxed form, followed by a boxing conversion. + XCon a (DaConPrim n tLit) + | Just RepBoxed <- configRepOfType config tLit + , Just tLitU <- configConvertRepType config RepUnboxed tLit + , Just nU <- configUnboxLitName config n + + , 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. + XCast _ CastRun xx'@(XApp a _ _) + | Just (n, xsArgsAll) <- takeXPrimApps xx' + , Just n' <- configUnboxPrimOpName config n + -> let Just tPrimBoxed = configValueTypeOfPrimOpName config n + Just tPrimUnboxed = configValueTypeOfPrimOpName config n' + xsArgsAll' = map (boxingX config) xsArgsAll + in boxingPrimitive config a True xx' (XVar a (UPrim n' tPrimUnboxed)) + tPrimBoxed tPrimUnboxed + xsArgsAll' + + -- Unbox primitive applications. + XApp a _ _ + | Just (n, xsArgsAll) <- takeXPrimApps xx + , Just n' <- configUnboxPrimOpName config n + -> let Just tPrimBoxed = configValueTypeOfPrimOpName config n + Just tPrimUnboxed = configValueTypeOfPrimOpName config n' + xsArgsAll' = map (boxingX config) xsArgsAll + in boxingPrimitive config a False xx (XVar a (UPrim n' tPrimUnboxed)) + tPrimBoxed tPrimUnboxed + xsArgsAll' + + -- Foreign calls + XApp a _ _ + | Just (xFn@(XVar _ (UName n)), xsArgsAll) + <- takeXApps xx + , Just tForeign <- configValueTypeOfForeignName config n + -> 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) + , Just RepBoxed <- configRepOfType config tLit1 + -> let alts' = map (boxingAlt config) alts + in boxingCase config a tLit1 xScrut alts' + + -- Boilerplate. + XVar{} -> xx + XCon{} -> xx + XLAM a b x -> XLAM a b (boxingX config x) + XLam a b x -> XLam a b (boxingX config x) + XApp a x1 x2 -> XApp a (boxingX config x1) (boxingX config x2) + XLet a lts x -> XLet a (boxingLts config lts) (boxingX config x) + XCase a x alts -> XCase a (boxingX config x) (map (boxingAlt config) alts) + XCast a c x -> XCast a c (boxingX config x) + XType{} -> xx + XWitness{} -> xx + +boxingLts config lts + = case lts of + LLet b x -> LLet b (boxingX config x) + LRec bxs -> LRec [(b, boxingX config x) | (b, x) <- bxs] + LPrivate{} -> lts + +boxingAlt config alt + = case alt of + AAlt p x -> AAlt p (boxingX config x) + + +--------------------------------------------------------------------------------------------------- +-- | Marshall arguments and return values of primitive operations. +-- If something goes wrong then just return the original expression and leave it to +-- follow on transforms to report the error. The code generator won't be able to +-- convert the original expression. +-- +-- * Assumes that the type of the primitive is in prenex form. +-- +boxingPrimitive + :: Ord n + => Config a n -> a + -> Bool -- ^ Primitive is being run at the call site. + -> Exp a n -- ^ Whole primitive application, for debugging. + -> Exp a n -- ^ Functional expression. + -> Type n -- ^ Type of the boxed version of the primitive. + -> Type n -- ^ Type of the unboxed version of the primitive. + -> [Exp a n] -- ^ Arguments to the primitive. + -> Exp a n + +boxingPrimitive config a bRun xx xFn tPrimBoxed tPrimUnboxed xsArgsAll + = fromMaybe xx go + where + go = do + -- Split off the type args. + let (asArgs, tsArgs) = unzip [(a', t) | XType a' t <- xsArgsAll] + let xsArgs = drop (length tsArgs) xsArgsAll + + -- Get the boxed version of the types of parameters and return value. + tPrimBoxedInst <- instantiateTs tPrimBoxed tsArgs + let (tsParamBoxed, _tResultBoxed) + = takeTFunArgResult tPrimBoxedInst + + -- Get the unboxed version of the types of parameters and return value. + tPrimUnboxedInst <- instantiateTs tPrimUnboxed tsArgs + let (_tsParamUnboxed, tResultUnboxed) + = takeTFunArgResult tPrimUnboxedInst + + -- If the primitive is being run at the call site then we need to + -- re-box the result AFTER it has been run, not before. + let tResultUnboxed' + | not bRun = tResultUnboxed + | otherwise = case takeTSusp tResultUnboxed of + Just (_, t) -> t + Nothing -> tResultUnboxed + + -- We must end up with a type of each argument. + -- 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 ()) + + -- We got a type for each argument, so the primop is fully applied + -- and we can do the boxing/unboxing transform. + let xsArgs' = [ (let t = fromMaybe xArg + $ configConvertRepExp config RepUnboxed a tArgInst xArg + in t) + | xArg <- xsArgs + | tArgInst <- tsParamBoxed ] + + -- Construct the result expression, running it if necessary. + let xtsArgsU = [ XType a' t | t <- tsArgs | a' <- asArgs ] + let xResultU = xApps a xFn (xtsArgsU ++ xsArgs') + let xResultRunU + | not bRun = xResultU + | otherwise = XCast a CastRun xResultU + + let xResultV = fromMaybe xResultRunU + $ configConvertRepExp config RepBoxed a tResultUnboxed' xResultRunU + + return xResultV + + +--------------------------------------------------------------------------------------------------- +-- Marshall arguments and return values of foreign imported functions. +-- +-- * Assumes that the type of the imported thing is in prenex form. +-- +boxingForeignSea + :: Ord n + => Config a n -> a + -> Exp a n -- ^ Whole function application, for debugging. + -> Exp a n -- ^ Functional expression. + -> Type n -- ^ Type of the foreign function. + -> [Exp a n] -- ^ Arguments to the foreign function. + -> Exp a n + +boxingForeignSea config a xx xFn tF xsArg + = fromMaybe xx go + where go = do + -- Split off the type args. + let (_asArg, tsArgType) = unzip [(a', t) | XType a' t <- xsArg] + let xsArgVal = drop (length tsArgType) xsArg + + -- Get the argument and return types of the function. + -- Unlike primitives, foreign functions are not polytypic, so we can + -- just erase any outer foralls to reveal the types of the args. + let (tsArgVal, tResult) + = takeTFunArgResult + $ eraseTForalls tF + + -- We must end up with a type for each argument. + (if not (length xsArgVal == length tsArgVal) + then Nothing + else Just ()) + + -- For each argument, if it has an unboxed representation then unbox it. + let unboxArg xArg tArg + = fromMaybe xArg + $ configConvertRepExp config RepUnboxed a tArg xArg + + let xsArgValU = zipWith unboxArg xsArgVal tsArgVal + let xExpU = xApps a xFn ([XType a t | t <- tsArgType] ++ xsArgValU) + + -- If the result has a boxed representation then box it. + let boxResult tRes xRes + = fromMaybe xRes + $ do tResU <- configConvertRepType config RepUnboxed tRes + configConvertRepExp config RepBoxed a tResU xExpU + + return $ boxResult tResult xExpU + + +-- | Marshall arguments and return values for function imported from Sea land. +boxingForeignSeaType + :: Config a n -> Type n -> Type n + +boxingForeignSeaType config tForeign + = let + -- Split the type into quantifiers, parameter and result types. + (bsForall, tBody) + = fromMaybe ([], tForeign) + $ takeTForalls tForeign + + (tsParam, tResult) + = takeTFunArgResult tBody + + -- If there is an unboxed representation of each parameter and result + -- type, then use that. + unboxType tThing + = fromMaybe tThing + $ configConvertRepType config RepUnboxed tThing + + tsParamU = map unboxType tsParam + tResultU = unboxType tResult + + -- Build the converted type back out of its parts. + Just tBodyU = tFunOfList (tsParamU ++ [tResultU]) + tForeignU = foldr TForall tBodyU bsForall + + in tForeignU + + +--------------------------------------------------------------------------------------------------- +-- For case expressions that match against literals, like +-- +-- case e1 of +-- { 5# -> e2; _ -> e3 } +-- +-- Unbox the scrutinee and convert the alternatives to match against +-- unboxed literals. +-- +-- case convert# [Nat] [Nat#] e1 of +-- { 5## -> e2; _ -> e3 } +-- +boxingCase + :: Config a n + -> a -> Type n + -> Exp a n + -> [Alt a n] + -> Exp a n + +boxingCase config a tLit1 xScrut alts + = let + unboxAlt (AAlt (PData (DaConPrim n tLit) []) x) + | Just RepBoxed <- configRepOfType config tLit + , Just nU <- configUnboxLitName config n + , Just tLitU <- configConvertRepType config RepUnboxed tLit + = Just (AAlt (PData (DaConPrim nU tLitU) []) x) + + unboxAlt alt@(AAlt PDefault _) = Just alt + unboxAlt _ = Nothing + + Just alts_unboxed + = sequence $ map unboxAlt alts + + Just xScrut' = configConvertRepExp config RepUnboxed a tLit1 xScrut + alts_default = ensureDefault alts_unboxed + + in XCase a xScrut' $ alts_default + + +-- | Ensure that there is a default alternative in this list, +-- if not then make the last one the default. +-- We need do this to handle the case when the unboxed type does not have +-- all its constructors listed in the data defs. If it doesn't then the +-- case exhaustiveness checker will compilain when checking the result code. +ensureDefault :: [Alt a n] -> [Alt a n] +ensureDefault alts + | _ : _ <- [alt | alt@(AAlt PDefault _) <- alts] + = alts + + | AAlt (PData _ []) x : rest <- reverse alts + = reverse rest ++ [AAlt PDefault x] + + | otherwise + = alts + diff --git a/DDC/Core/Transform/Bubble.hs b/DDC/Core/Transform/Bubble.hs --- a/DDC/Core/Transform/Bubble.hs +++ b/DDC/Core/Transform/Bubble.hs @@ -9,11 +9,9 @@ , bubbleX) where import DDC.Core.Collect -import DDC.Core.Transform.LiftX -import DDC.Core.Predicates -import DDC.Core.Compounds +import DDC.Core.Transform.BoundX import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Type.Env (KindEnv, TypeEnv) import qualified DDC.Type.Env as Env import qualified DDC.Type.Sum as Sum @@ -40,8 +38,8 @@ = let -- Bubble the expression, yielding any casts that floated out -- to top-level. - (cs, x') = bubble kenv tenv x - Just a = takeAnnotOfExp x' + (cs, x') = bubble kenv tenv x + a = annotOfExp x' -- Reattach top-level casts. in dropAllCasts kenv tenv a cs x' @@ -124,7 +122,7 @@ -- but we can float the others further outwards. LLet b x -> let (cs, x') = bubble kenv tenv x - Just a = takeAnnotOfExp x' + a = annotOfExp x' (cs', xc') = dropCasts kenv tenv a [] [b] cs x' in (cs', LLet b xc') @@ -135,15 +133,15 @@ bubbleRec (b, x) = let (cs, x') = bubble kenv tenv' x - Just a = takeAnnotOfExp x' + a = annotOfExp x' in (b, dropAllCasts kenv tenv' a cs x') bxs' = map bubbleRec bxs in ([], LRec bxs') - LLetRegions{} -> ([], lts) - LWithRegion{} -> ([], lts) + LPrivate{} + -> ([], lts) instance Bubble Alt where @@ -158,7 +156,7 @@ -- variables bound by the pattern. bubble kenv tenv (AAlt p x) = let bs = bindsOfPat p - Just a = takeAnnotOfExp x' + a = annotOfExp x' tenv' = Env.extends bs tenv (cs, x') = bubble kenv tenv' x (csUp, xcHere) = dropCasts kenv tenv' a [] bs cs x' @@ -197,7 +195,7 @@ -- code is easier to read. packCasts :: Ord n => KindEnv n -> TypeEnv n -> a -> [Cast a n] -> [Cast a n] -packCasts kenv tenv a vs +packCasts _kenv _tenv _a vs = let -- Sort casts into weakeff, weakclo and any others. -- We'll collect the weakeff and weakclo casts together. @@ -209,76 +207,17 @@ CastWeakenEffect eff : cs -> collect (eff : weakEffs) weakClos others cs - CastWeakenClosure xs : cs - -> collect weakEffs (xs ++ weakClos) others cs - c : cs -> collect weakEffs weakClos (c : others) cs - (effs, xsClos, csOthers) + (effs, csOthers, _) = collect [] [] [] vs - xsClos_packed - = packWeakenClosureXs kenv tenv a xsClos - in (if null effs then [] else [CastWeakenEffect (TSum $ Sum.fromList kEffect effs)]) - ++ (if null xsClos_packed - then [] - else [CastWeakenClosure xsClos_packed]) ++ csOthers - - --- | Pack the expressions given to a `WeakenClosure` to just the ones that we --- care about. We only need region variables, and value variables with --- open types. -packWeakenClosureXs - :: Ord n - => KindEnv n -> TypeEnv n - -> a -> [Exp a n] -> [Exp a n] - -packWeakenClosureXs kenv tenv a xx - = let - eat fvsSp fvsDa [] - = (fvsSp, fvsDa) - - eat fvsSp fvsDa (x : xs) - = let sup = support Env.empty Env.empty x - fvsSp' = supportSpVar sup - fvsDa' = supportDaVar sup - in eat (Set.union fvsSp fvsSp') (Set.union fvsDa fvsDa') xs - - (vsSp, vsDa) = eat Set.empty Set.empty xx - - in [XType (TVar u) | u <- Set.toList vsSp] - ++ [XVar a u | u <- Set.toList vsDa, keepBound kenv tenv u] - - --- | When packing vars given to a closure weakening, we only need to keep --- vars that have open types or contain region handles. -keepBound :: Ord n => KindEnv n -> TypeEnv n -> Bound n -> Bool -keepBound _kenv tenv u - | Just t <- Env.lookup u tenv - , sup <- support Env.empty Env.empty t - , Set.null (supportSpVar sup) - , all (not . isRegionHandle) $ Set.toList $ supportTyCon sup - = False - - | otherwise - = True - - --- | Treat primitive constructors with region kind as region handles. --- Region handles are only really a part of the 'Disciple Core Eval' --- language, but they're easy to check for even if the name type 'n' --- hasn't been revealed. -isRegionHandle :: Bound n -> Bool -isRegionHandle u - = case u of - UPrim _ k -> isRegionKind k - _ -> False -- Dropping ------------------------------------------------------------------- diff --git a/DDC/Core/Transform/Elaborate.hs b/DDC/Core/Transform/Elaborate.hs --- a/DDC/Core/Transform/Elaborate.hs +++ b/DDC/Core/Transform/Elaborate.hs @@ -7,7 +7,7 @@ where import DDC.Core.Exp import DDC.Core.Module -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import DDC.Data.ListUtils import Control.Monad import Control.Arrow @@ -54,12 +54,8 @@ instance Elaborate (Cast a) where - elaborate us cst - = case cst of - CastWeakenClosure es - -> CastWeakenClosure $ map (elaborate us) es - _ -> cst - + elaborate _us cst = cst + instance Elaborate (Alt a) where elaborate us (AAlt p x) = AAlt p (elaborate us x) @@ -78,7 +74,7 @@ LLet b x -> (us, LLet b (down x)) LRec bs -> (us, LRec $ map (second down) bs) - LLetRegions brs bws + LPrivate brs mt bws | urs@(_:_) <- takeSubstBoundsOfBinds brs -> let -- Mutable regions bound here. @@ -97,7 +93,7 @@ ++ zip urs ursTail in ( us ++ urs - , LLetRegions brs $ bws ++ distinctWits ++ constWits ) + , LPrivate brs mt $ bws ++ distinctWits ++ constWits ) _ -> (us, lts) diff --git a/DDC/Core/Transform/Eta.hs b/DDC/Core/Transform/Eta.hs --- a/DDC/Core/Transform/Eta.hs +++ b/DDC/Core/Transform/Eta.hs @@ -14,18 +14,18 @@ where import qualified DDC.Core.Check as Check import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Fragment -import DDC.Core.Transform.LiftX -import DDC.Core.Transform.LiftT +import DDC.Core.Transform.BoundX +import DDC.Core.Transform.BoundT import DDC.Core.Simplifier.Result -import DDC.Core.Compounds import DDC.Core.Pretty -import DDC.Type.Env (TypeEnv, KindEnv) +import DDC.Type.Transform.AnonymizeT import Control.Monad.Writer (Writer, tell, runWriter) -import Data.Monoid (Monoid, mempty, mappend) -import qualified DDC.Type.Env as Env import Data.Typeable +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Env.EnvX as EnvX +import Prelude hiding ((<$>)) ------------------------------------------------------------------------------- @@ -72,20 +72,25 @@ -- | Eta-transform expressions in a module. etaModule :: (Ord n, Show n, Pretty n, Show a) - => Config - -> Profile n + => Profile n + -> Config -> Module a n -> TransformResult (Module a n) -etaModule config profile mm - = let cconfig = Check.configOfProfile profile - kenv' = Env.union (profilePrimKinds profile) (moduleKindEnv mm) - tenv' = Env.union (profilePrimTypes profile) (moduleTypeEnv mm) +etaModule profile config 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 @@ -102,22 +107,19 @@ -- | Eta-transform an expression. etaX :: (Ord n, Show n, Show a, Pretty n) - => Config -- ^ Eta-transform config. - -> Profile n -- ^ Language profile. - -> KindEnv n -- ^ Kind environment. - -> TypeEnv n -- ^ Type environment. + => Profile n -- ^ Language profile. + -> Config -- ^ Eta-transform config. + -> EnvX n -- ^ Type checker environment. -> Exp a n -- ^ Expression to transform. -> TransformResult (Exp a n) -etaX config profile 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 @@ -134,36 +136,35 @@ ------------------------------------------------------------------------------- class Eta (c :: * -> * -> *) where - etaM :: (Ord n, Pretty n, Show n) + 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,22 +217,22 @@ 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') - LLetRegions{} -> return lts - LWithRegion{} -> return lts + LPrivate{} + -> return lts 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' @@ -243,7 +246,9 @@ -> Writer Info (Exp a n) etaExpand a tX xx - = do let btsMore = expandableArgs tX + -- Anonymize the type, so any references to foralls will become anonymous. + -- Then, when we add the anonymous bindings, it will work out. + = do let btsMore = expandableArgs $ anonymizeT tX xx' <- etaExpand' a 0 0 [] btsMore xx return xx' @@ -281,7 +286,7 @@ etaExpand' a levels1 levels0 args ((True, t) : ts) xx = do let depth1 = length $ filter ((== True) . fst) ts xx' <- etaExpand' a (levels1 + 1) levels0 - (args ++ [XType (TVar (UIx depth1))]) + (args ++ [XType a (TVar (UIx depth1))]) ts xx diff --git a/DDC/Core/Transform/Flatten.hs b/DDC/Core/Transform/Flatten.hs --- a/DDC/Core/Transform/Flatten.hs +++ b/DDC/Core/Transform/Flatten.hs @@ -3,13 +3,10 @@ module DDC.Core.Transform.Flatten (flatten) where -import DDC.Core.Transform.LiftT import DDC.Core.Transform.TransformUpX import DDC.Core.Transform.AnonymizeX -import DDC.Core.Transform.LiftX -import DDC.Core.Exp -import DDC.Core.Compounds -import DDC.Type.Predicates +import DDC.Core.Transform.BoundX +import DDC.Core.Exp.Annot import Data.Functor.Identity @@ -32,7 +29,29 @@ => Exp a n -> Exp a n +-- Run ---------------------------------------------------- +flatten1 (XCast a1 CastRun (XLet a2 lts x2)) + = XLet a2 lts $ flatten1 (XCast a1 CastRun x2) + + -- Let ---------------------------------------------------- +-- Special case when nested let is (let b = x in b): +-- @ +-- let b1 = (let ^ = def2 in ^0) in +-- x1 +-- +-- ==> let b1 = def2 in +-- x1 +-- @ +-- +flatten1 (XLet a1 (LLet b1 + (XLet _ (LLet (BAnon _) def2) (XVar _ (UIx 0)))) + x1) + = flatten1 + $ XLet a1 (LLet b1 def2) + x1 + +-- Let ---------------------------------------------------- -- Flatten Nested Lets. -- @ -- let b1 = (let b2 = def2 in x2) in @@ -61,37 +80,6 @@ x1' --- Drag 'letregion' out of the top-level of a binding. --- @ --- let b1 = letregion b2 in x2 in --- x1 --- --- => letregion b2 in --- let b1 = x2 in --- x1 --- @ --- --- NOTE: For region allocation this increases the lifetime of the region. --- Maybe use a follow on transform to reduce the lifetime again. --- -flatten1 (XLet a1 (LLet b1 - inner@(XLet a2 (LLetRegions b2 bs2) x2)) - x1) - | all isBName b2 - = flatten1 - $ XLet a1 (LLet b1 - (anonymizeX inner)) - x1 - - | otherwise - = let x1' = liftAcrossT [] b2 - $ liftAcrossX [b1] bs2 x1 - in XLet a2 (LLetRegions b2 bs2) - $ flatten1 - $ XLet a1 (LLet (zapX b1) x2) - x1' - - -- Flatten single-alt case expressions. -- @ -- let b1 = case x1 of @@ -137,20 +125,10 @@ 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] in liftAtDepthX levels depth x -liftAcrossT :: Ord n => [Bind n] -> [Bind n] -> Exp a n -> Exp a n -liftAcrossT bsDepth bsLevels x - = let depth = length [b | b@(BAnon _) <- bsDepth] - levels = length [b | b@(BAnon _) <- bsLevels] - in liftAtDepthT levels depth x - - --- | Erase the type of a data binder. -zapX :: Bind n -> Bind n -zapX b = replaceTypeOfBind (tBot kData) b diff --git a/DDC/Core/Transform/FoldCase.hs b/DDC/Core/Transform/FoldCase.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/FoldCase.hs @@ -0,0 +1,84 @@ + +module DDC.Core.Transform.FoldCase + ( Config (..) + , configZero + , foldCase + , foldCaseX ) +where +import DDC.Core.Exp.Annot +import DDC.Core.Transform.TransformDownX +import Control.Monad.State.Strict +import qualified Data.Map.Strict as M +import qualified DDC.Type.Env as Env + +data Config + = Config + { -- | Perform the case-of-constructor transformation. + configCaseOfConstructor :: Bool + + -- | Perform the case-of-case transformation. + -- Not implemented yet. + , configCaseOfCase :: Bool } + +configZero :: Config +configZero + = Config + { configCaseOfConstructor = False + , configCaseOfCase = False } + + +--------------------------------------------------------------------------------------------------- +type FoldCase a n = State (M.Map n (DaCon n (Type n), [Exp a n])) + +foldCase :: (Ord n, TransformDownMX (FoldCase a n) c) + => Config + -> c a n + -> c a n + +foldCase config xx + = {-# SCC foldCase #-} + evalState (transformDownMX (\_ _ -> foldCaseX config) Env.empty Env.empty xx) M.empty + +foldCaseX :: Ord n + => Config + -> Exp a n + -> FoldCase a n (Exp a n) + + +-- Collect ---------------------------------------------------------------------------------------- +foldCaseX _ + x@(XLet _ (LLet (BName b _) ex) _) + | Just (dc, args) <- takeXConApps ex + = do + modify (M.insert b (dc, args)) + return x + + +-- Case of Constructor ---------------------------------------------------------------------------- +-- @ +-- let x = Con y z in +-- case x of +-- Con a b -> x1 +-- +-- ==> let x = Con y z in +-- let a = y in +-- let b = z in +-- x1 +-- @ +-- +foldCaseX config + x@(XCase _ (XVar _ (UName n)) [alt]) + | configCaseOfConstructor config + , AAlt (PData dc binds) rest <- alt + = do + seen <- gets (M.lookup n) + return $ case seen of + Just (dc', args') | dc == dc' + -> foldr (\(x', bnd) next -> XLet (annotOfExp x') (LLet bnd x') next) + rest (zip (filter (not . isXType) args') binds) + + _ -> x + + +-- Default case. +foldCaseX _ x = return x diff --git a/DDC/Core/Transform/Forward.hs b/DDC/Core/Transform/Forward.hs --- a/DDC/Core/Transform/Forward.hs +++ b/DDC/Core/Transform/Forward.hs @@ -7,23 +7,22 @@ , forwardModule , forwardX) where -import DDC.Base.Pretty +import DDC.Data.Pretty import DDC.Core.Analysis.Usage -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Module import DDC.Core.Simplifier.Base import DDC.Core.Transform.Reannotate import DDC.Core.Fragment -import DDC.Core.Predicates -import DDC.Core.Compounds import Data.Map (Map) import Control.Monad -import Control.Monad.Writer (Writer, runWriter, tell) -import Data.Monoid (Monoid, mempty, mappend) +import Control.Monad.Writer (Writer, runWriter, tell) import Data.Typeable import qualified Data.Map as Map -import qualified DDC.Core.Transform.SubstituteXX as S +import qualified DDC.Core.Transform.SubstituteXX as S +import Prelude hiding ((<$>)) + ------------------------------------------------------------------------------- -- | Summary of number of bindings floated. data ForwardInfo @@ -57,9 +56,10 @@ ------------------------------------------------------------------------------- -- | Fine control over what should be floated. data FloatControl - = FloatAllow -- ^ Allow binding to be floated, but don't require it. - | FloatDeny -- ^ Prevent a binding being floated, at all times. - | FloatForce -- ^ Force a binding to be floated, at all times. + = FloatAllow -- ^ Allow binding to be floated, but don't require it. + | FloatDeny -- ^ Prevent a binding being floated, at all times. + | FloatForce -- ^ Force a binding to be floated, at all times. + | FloatForceUsedOnce -- ^ Force a binding to be floated if it's only used once. deriving (Eq, Show) data Config a n @@ -103,17 +103,17 @@ forwardX profile config xx = let (x',info) = runWriter - $ forwardWith profile config Map.empty - $ usageX xx + $ forwardWith profile config Map.empty + $ usageX xx progress (ForwardInfo _ s f) = s + f > 0 in TransformResult - { result = x' + { result = x' , resultProgress = progress info , resultAgain = False - , resultInfo = TransformInfo info } + , resultInfo = TransformInfo info } ------------------------------------------------------------------------------- @@ -131,20 +131,32 @@ forwardWith profile config bindings (ModuleCore { moduleName = name - , moduleExportKinds = exportKinds + , moduleIsHeader = isHeader , moduleExportTypes = exportTypes - , moduleImportKinds = importKinds + , moduleExportValues = exportValues , moduleImportTypes = importTypes + , moduleImportCaps = importCaps + , moduleImportValues = importValues + , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs + , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal , moduleBody = body }) - = do body' <- forwardWith profile config bindings body - return ModuleCore - { moduleName = name - , moduleExportKinds = exportKinds - , moduleExportTypes = exportTypes - , moduleImportKinds = importKinds - , moduleImportTypes = importTypes - , moduleBody = body' } + = do body' <- forwardWith profile config bindings body + return ModuleCore + { moduleName = name + , moduleIsHeader = isHeader + , moduleExportTypes = exportTypes + , moduleExportValues = exportValues + , moduleImportTypes = importTypes + , moduleImportCaps = importCaps + , moduleImportValues = importValues + , moduleImportDataDefs = importDataDefs + , moduleImportTypeDefs = importTypeDefs + , moduleDataDefsLocal = dataDefsLocal + , moduleTypeDefsLocal = typeDefsLocal + , moduleBody = body' } instance Forward Exp where @@ -155,10 +167,10 @@ XVar a u@(UName n) -> case Map.lookup n bindings of Just xx' -> do - tell mempty { infoSubsts = 1 } - return xx' + tell mempty { infoSubsts = 1 } + return xx' Nothing -> - return $ XVar (snd a) u + return $ XVar (snd a) u XVar a u -> return $ XVar (snd a) u XCon a u -> return $ XCon (snd a) u @@ -173,18 +185,29 @@ , configFloatLetBody config -> down x1 - -- Always float atomic bindings (variables, constructors) - XLet _ (LLet b x1) x2 + -- A special case for atomic anonymous bindings. + -- Always float atomic bindings (variables, constructors), + -- but only if they're still atomic after forwarding them: + -- if x1 is a variable to be replaced with a function, then + -- substituting x1 into x2 could duplicate that. + XLet (_, a) (LLet b@(BAnon _) x1) x2 | isAtomX x1 - -> do - -- Record that we've moved this binding. - tell mempty { infoInspected = 1 - , infoBindings = 1 } + -> do + x1' <- down x1 + if isAtomX x1' + then do + -- Record that we've moved this binding. + tell mempty { infoInspected = 1 + , infoBindings = 1 } - -- Slow, but handles anonymous binders and shadowing - down $ S.substituteXX b x1 x2 + -- Slower, but handles anonymous binders and shadowing + down $ S.substituteXX b x1 x2 - XLet (UsedMap um, a') lts@(LLet (BName n _) x1) x2 + else do + tell mempty { infoInspected = 1} + liftM (XLet a $ LLet b x1') (down x2) + + XLet (UsedMap um, a') lts@(LLet (BName n t) x1) x2 -> do let control = configFloatControl config $ reannotate snd lts @@ -203,27 +226,41 @@ FloatForce -> True FloatAllow -> isFun && isApplied - if shouldFloat + FloatForceUsedOnce + | Just usage <- Map.lookup n um + , length usage == 1 + -> True + | otherwise + -> False + + -- Always float atomic bindings (variables, constructors). + x1' <- down x1 + + if shouldFloat || isAtomX x1' then do -- Record that we've moved this binding. tell mempty { infoInspected = 1 , infoBindings = 1 } - x1' <- down x1 let bindings' = Map.insert n x1' bindings forwardWith profile config bindings' x2 else do tell mempty { infoInspected = 1} - liftM2 (XLet a') (down lts) (down x2) + -- Note that @n@ has been shadowed + let bindings' = Map.delete n bindings + x2' <- forwardWith profile config bindings' x2 + + return $ XLet a' (LLet (BName n t) x1') x2' + XLet (_, a') lts x -> liftM2 (XLet a') (down lts) (down x) - XCase a x alts -> liftM2 (XCase (snd a)) (down x) (mapM down alts) - XCast a c x -> liftM2 (XCast (snd a)) (down c) (down x) - XType t -> return $ XType t - XWitness w -> return $ XWitness (reannotate snd w) + XCase a x alts -> liftM2 (XCase (snd a)) (down x) (mapM down alts) + XCast a c x -> liftM2 (XCast (snd a)) (down c) (down x) + XType a t -> return (XType (snd a) t) + XWitness a w -> return (XWitness (snd a) (reannotate snd w)) filterUsedInCasts :: [Used] -> [Used] @@ -233,14 +270,11 @@ instance Forward Cast where - forwardWith profile config bindings xx - = let down = forwardWith profile config bindings - in case xx of + forwardWith _profile _config _bindings xx + = case xx of CastWeakenEffect eff -> return $ CastWeakenEffect eff - CastWeakenClosure xs -> liftM CastWeakenClosure (mapM down xs) CastPurify w -> return $ CastPurify (reannotate snd w) - CastForget w -> return $ CastForget (reannotate snd w) - CastSuspend -> return $ CastSuspend + CastBox -> return $ CastBox CastRun -> return $ CastRun @@ -255,11 +289,11 @@ -> liftM LRec $ mapM (\(b,x) -> do x' <- down x - return (b, x')) + return (b, x')) bxs - LLetRegions b bs -> return $ LLetRegions b bs - LWithRegion b -> return $ LWithRegion b + LPrivate b mt bs + -> return $ LPrivate b mt bs instance Forward Alt where diff --git a/DDC/Core/Transform/Inline.hs b/DDC/Core/Transform/Inline.hs --- a/DDC/Core/Transform/Inline.hs +++ b/DDC/Core/Transform/Inline.hs @@ -64,8 +64,7 @@ in case lts of LLet b x -> LLet b (enter b x) LRec bxs -> LRec [(b, enter b x) | (b, x) <- bxs] - LLetRegions{} -> lts - LWithRegion{} -> lts + LPrivate{} -> lts instance Inline Alt where diff --git a/DDC/Core/Transform/Inline/Templates.hs b/DDC/Core/Transform/Inline/Templates.hs --- a/DDC/Core/Transform/Inline/Templates.hs +++ b/DDC/Core/Transform/Inline/Templates.hs @@ -1,9 +1,9 @@ -- | Retrieving inliner templates from a list of modules. module DDC.Core.Transform.Inline.Templates - ( InlineSpec(..) + ( InlineSpec(..) , lookupTemplateFromModules - , lookupTemplateFromModule ) + , lookupTemplateFromModule ) where import DDC.Core.Exp import DDC.Core.Module @@ -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 @@ -71,7 +71,7 @@ lookupTemplateFromModule spec mm n | shouldInline spec n , XLet _ (LRec bxs) _ <- moduleBody mm - , Just (_,x) <- find (\(BName n' _, _) -> n == n') bxs + , Just (_,x) <- find (\(BName n' _, _) -> n == n') bxs = Just $ anonymizeX x | otherwise @@ -81,7 +81,7 @@ -- | Decide whether we should inline the binding with this name based on the -- provided inliner specification. shouldInline - :: (Ord n, Show n) + :: Ord n => InlineSpec n -> n -> Bool shouldInline spec n diff --git a/DDC/Core/Transform/Lambdas.hs b/DDC/Core/Transform/Lambdas.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Lambdas.hs @@ -0,0 +1,481 @@ + +module DDC.Core.Transform.Lambdas + ( 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 +import DDC.Core.Module +import DDC.Core.Exp.Annot.Context +import DDC.Core.Exp.Annot.Ctx +import DDC.Core.Exp.Annot +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 + + +--------------------------------------------------------------------------------------------------- +-- | Perform lambda lifting in a module. +lambdasModule + :: ( Show a, Pretty a + , Show n, Pretty n, Ord n, CompoundName n) + => Profile n + -> Module a n + -> S (Module a n) + +lambdasModule profile mm + = do + -- Take the top-level environment of the module. + let env = moduleEnvX + (profilePrimKinds profile) + (profilePrimTypes profile) + (profilePrimDataDefs profile) + mm + + let c = Context env (CtxTop env) + x' <- lambdasLoopX profile c $ moduleBody mm + + return + $ mm { moduleBody = x' } + + +-- 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. + -> S (Exp a n) -- Replacement expression. + +lambdasLoopX p c xx + = 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. + -> S ( Exp a n -- Replacement expression + , Result a n) -- Lifter result. + +lambdasX p c xx + = case xx of + 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 + -> 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. + 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' + + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) + + else return (xx', r) + + + -- Lift value lambdas to top-level. + XLam a b x0 + -> enterLam c a b x0 $ \c' x + -> 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. + 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 [(False, b)] x' + + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) + + else return (xx', r) + + + -- Lift suspensions to top-level. + -- These behave like zero-arity lambda expressions, + -- they suspend evaluation but do not abstract over a value. + XCast a cc@CastBox x0 + -> enterCastBody c a cc x0 $ \c' x + -> 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. + 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 [] (XCast a CastBox x') + + return ( xCall + , Result True (bxs ++ [(bLifted, xLifted)])) + + 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 + -> 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 + -> 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 + -> 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{} + -> return (xx, mempty) + + XWitness{} + -> return (xx, mempty) + + +-- Lets ------------------------------------------------------------------------------------------- +-- | Perform lambda lifting in some let-bindings. +lambdasLets + :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) + => Profile n -> Context a n + -> a -> Exp a n + -> Lets a n + -> S ([Lets a n], Result a n) + +lambdasLets p c a xBody lts + = case lts of + LLet b x + -> do (x', r) <- enterLetLLet c a b x xBody (lambdasX p) + return ([LLet b x'], r) + + LRec bxs + -> do (bxs', r) <- lambdasLetRecLiftAll p c a bxs + return (map (uncurry LLet) bxs', r) + + LPrivate{} + -> return ([lts], mempty) + + +-- LetRec ----------------------------------------------------------------------------------------- +-- | Perform lambda lifting in the right of a single let-rec binding. +lambdasLetRec + :: (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 + -> S ([(Bind n, Exp a n)], Result a n) + +lambdasLetRec _ _ _ _ [] _ + = return ([], mempty) + +lambdasLetRec p c a bxsAcc ((b, x) : bxsMore) xBody + = do (x', r1) + <- enterLetLRec c a bxsAcc b x bxsMore xBody (lambdasX p) + + case contextCtx c of + + -- If we're at top-level then drop lifted bindings here. + CtxTop{} + -> 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 ) + + _ + -> 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. +lambdasLetRecLiftAll + :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) + => Profile n -> Context a n + -> a + -> [(Bind n, Exp a n)] + -> S ([(Bind n, Exp a n)], Result a n) + +lambdasLetRecLiftAll p c a bxs + = 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. + 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 + let us' = Set.filter + (\(_, bo) -> not $ any (boundMatchesBind bo . fst) bxs) + $ us + + -- 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) + = 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 + + -- 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 + 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. + 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 + let stripResult (Left _) = Nothing + stripResult (Right (_, (_, bL, xL))) = Just (bL, sub xL) + + 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] + -> S ([Alt a n], Result a n) + +lambdasAlts _ _ _ _ _ [] + = return ([], mempty) + +lambdasAlts p c a xScrut altsAcc (AAlt w x : altsMore) + = 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 ------------------------------------------------------------------------------------------- +-- | Perform lambda lifting in the body of a Cast expression. +lambdasCast + :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n) + => Profile n -> Context a n + -> a -> Cast a n -> Exp a n + -> S (Exp a n, Result a n) + +lambdasCast p c a cc x + = case cc of + CastWeakenEffect{} + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return ( XCast a cc x', r) + + CastPurify{} + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) + + CastBox + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) + + CastRun + -> do (x', r) <- enterCastBody c a cc x (lambdasX p) + return (XCast a cc x', r) + + +------------------------------------------------------------------------------- +-- | 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)) + +etaXConApp !p !c !a !x1 !nCon !xsArg + -- Lookup the type of the constructor. + | ctx <- contextCtx c + , case ctx of + CtxAppLeft{} -> False + _ -> True + + , envX <- topOfCtx ctx + , defs <- EnvX.envxDataDefs envX + , Just dataCtor <- Map.lookup nCon (DataDef.dataDefsCtors defs) + + -- 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 + + -- 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 ] + + let sub = zip (DataDef.dataCtorTypeParams dataCtor) + (map TVar usT) + + -- 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 ] + + -- Transform all the arguments. + let downArg xArg = enterAppRight c a x1 xArg (lambdasX p) + (xsArg', rs) <- fmap unzip $ mapM downArg xsArg + + -- 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' + + , mconcat (Result True [] : rs)) + + | otherwise + = return Nothing + diff --git a/DDC/Core/Transform/Lambdas/Base.hs b/DDC/Core/Transform/Lambdas/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Lambdas/Base.hs @@ -0,0 +1,103 @@ + +module DDC.Core.Transform.Lambdas.Base + ( S, evalState + , newVar + , newVarExtend + , Result (..) + , isLiftyContext) +where +import DDC.Core.Exp.Annot.Ctx +import DDC.Core.Exp.Annot +import DDC.Data.Name +import qualified Control.Monad.State.Strict as S + + +--------------------------------------------------------------------------------------------------- +-- | State holding a variable name prefix and counter to +-- create fresh variable names. +type S = S.State (String, Int) + + +-- | Evaluate a desguaring computation, +-- using the given prefix for freshly introduced variables. +evalState :: String -> S a -> a +evalState n c + = S.evalState c (n, 0) + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVar + :: CompoundName n + => String -- ^ Informational name to add. + -> Type n -- ^ Type of the new binder. + -> S (Bind n, Bound n) + +newVar prefix t + = do (n, i) <- S.get + let name' = newVarName (n ++ "$" ++ prefix ++ "$" ++ show i) + S.put (n, i + 1) + return (BName name' t, UName name') + + +-- | Allocate a new named variable, yielding its associated bind and bound. +newVarExtend + :: CompoundName n + => n -- ^ Base name. + -> String -- ^ Informational name to ad. + -> Type n -- ^ Type of the new binder. + -> S (Bind n, Bound n) + +newVarExtend name prefix t + = do (n, i) <- S.get + let name' = extendName name (n ++ "$" ++ prefix ++ "$" ++ show i) + S.put (n, i + 1) + return (BName name' t, UName name') + + + +--------------------------------------------------------------------------------------------------- +-- | Result of lambda lifter recursion. +data Result a n + = Result + { -- | Whether we've made any progress in this pass. + _resultProgress :: Bool + + -- | Bindings that we've already lifted out, + -- and should be added at top-level. + , _resultBindings :: [(Bind n, Exp a n)] + } + + +instance Monoid (Result a n) where + mempty + = Result False [] + + mappend (Result p1 lts1) (Result p2 lts2) + = Result (p1 || p2) (lts1 ++ lts2) + + +--------------------------------------------------------------------------------------------------- +-- | Check if this is a context that we should lift lambda abstractions out of. +isLiftyContext :: Ctx a n -> Bool +isLiftyContext ctx + = case ctx of + -- Don't lift out of the top-level context. + -- There's nowhere else to lift to. + CtxTop{} -> False + CtxLetLLet{} -> not $ isTopLetCtx ctx + CtxLetLRec{} -> not $ isTopLetCtx ctx + + -- Don't lift if we're inside more lambdas. + -- We want to lift the whole binding group together. + CtxLAM{} -> False + CtxLam{} -> False + + -- We can't do code generation for abstractions in these contexts, + -- so they need to be lifted. + CtxAppLeft{} -> True + CtxAppRight{} -> True + CtxLetBody{} -> True + CtxCaseScrut{} -> True + CtxCaseAlt{} -> True + CtxCastBody{} -> True + diff --git a/DDC/Core/Transform/Lambdas/Lift.hs b/DDC/Core/Transform/Lambdas/Lift.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Lambdas/Lift.hs @@ -0,0 +1,184 @@ + +module DDC.Core.Transform.Lambdas.Lift + (liftLambda) +where +import DDC.Core.Transform.Lambdas.Base +import DDC.Core.Fragment +import DDC.Core.Exp.Annot.Context +import DDC.Core.Exp.Annot.Ctx +import DDC.Core.Exp.Annot +import DDC.Core.Collect +import DDC.Data.Pretty +import DDC.Data.Name +import Data.Function +import Data.List +import Data.Set (Set) +import qualified DDC.Core.Check as Check +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Env.EnvX as EnvX +import qualified Data.Set as Set +import qualified Data.Map as Map + + +--------------------------------------------------------------------------------------------------- +-- | Construct the call site, and new lifted binding for a lambda lifted +-- abstraction. +liftLambda + :: (Show a, Show n, Pretty n, Ord n, CompoundName n, Pretty a) + => Profile n -- ^ Language profile. + -> Context a n -- ^ Context of the original abstraction. + -> Set (Bool, Bound n) -- ^ Free variables in the body of the abstraction. + -> a + -> [(Bool, Bind n)] -- ^ Parameters of the current lambda abstraction. + -> Exp a n -- ^ Body of the current lambda abstraction. + -> S ( Exp a n + , Bind n, Exp a n) + +liftLambda p c fusFree a bfsParam xBody + = do + -- Name of the enclosing top-level binding. + let Just nTop = takeTopNameOfCtx (contextCtx c) + + -- Names of other supers bound at top-level. + let nsSuper = takeTopLetEnvNamesOfCtx (contextCtx c) + + -- The complete abstraction that we're lifting out. + let xLambda = makeXLamFlags a bfsParam xBody + + -- Get the list of new parameters we need to add to our super. + -- These bind all the variables that were free in the abstraction + -- group that we're lifting out. + let fusFree_filtered + = filter (needParamForFreeBound nsSuper bfsParam) + $ Set.toList fusFree + + + -- Lookup the types of those variables from the context, + -- so we can add the correct types for the parameters of the new super. + let joinType (f@True, u) + | Just t <- EnvX.lookupT u (contextEnv c) + = ((f, u), t) + + joinType (f@False, u) + | Just t <- EnvX.lookupX u (contextEnv c) + = ((f, u), t) + + joinType (f, u) + = error $ unlines + [ "ddc-core-simpl.liftLambda: cannot find type of free variable." + , show (f, u) + , show (Map.keys $ EnvX.envxMap (contextEnv c)) ] + + let futsFree_types + = map joinType fusFree_filtered + + + -- Add in type variables that are free in the types of free + -- value variables. We need to bind these as well in the new super. + let expandFree ((f@True, u), _) + = [(f, u)] + + expandFree ((f@False, u), t) + = [(f, u)] + ++ [(True, ut) | ut <- Set.toList + $ freeVarsT Env.empty t] + + let fusFree_body + = [(True, ut) | ut <- Set.toList + $ freeVarsT Env.empty $ typeOfExp p c xLambda] + + let futsFree_expandFree + = map joinType + $ Set.toList $ Set.fromList + $ (concatMap expandFree $ futsFree_types) + ++ fusFree_body + + + -- Sort free vars so the type variables come out the front. + let futsFree + = sortBy (compare `on` (not . fst . fst)) + $ futsFree_expandFree + + + -- Make the new super. + -- For the lifted abstraction, wrap it in new lambdas to bind all of + -- its free variables. + -- ISSUE #330: Lambda lifter doesn't work with anonymous binders. + let makeBind ((True, (UName n)), t) = (True, BName n t) + makeBind ((False, (UName n)), t) = (False, BName n t) + makeBind fut + = error $ "ddc-core-simpl.liftLamba: unhandled binder " ++ show fut + + let bsParam = map makeBind futsFree + let xLifted = makeXLamFlags a bsParam xLambda + + -- Make a binder for the new super. + (bLifted, uLifted) + <- newVarExtend nTop "L" + $ typeOfExp p c xLifted + + -- At the point where the original abstraction group was, + -- call our new lifted super instead. + let makeArg (True, u) = XType a (TVar u) + makeArg (False, u) = XVar a u + + let xCall = xApps a (XVar a uLifted) + $ map makeArg $ map fst futsFree + + -- All done. + return ( xCall + , bLifted, xLifted) + + +--------------------------------------------------------------------------------------------------- +-- | Decide whether we need to bind the given variable as a new parameter +-- on the lifted super. +needParamForFreeBound + :: (Ord n) + => Set n -- ^ Names of supers at top level. + -> [(Bool, Bind n)] -- ^ Parameters of the current lambda abstraction. + -> (Bool, Bound n) -- ^ Bound variable, and whether it is a type (True) or not. + -> Bool + +needParamForFreeBound nsSuper bfsParam (bType, u) + -- We don't need new parameters for supers that are already + -- at top level, as we can reference those directly. + | not bType + , UName n <- u + = not $ Set.member n nsSuper + + -- We don't need new parameters for primitives, + -- as we can reference those directly. + | UPrim{} <- u + = False + + -- We don't need new paramters for variables that + -- are already bound by the abstractions that we're lifting. + | any (boundMatchesBind u . snd) bfsParam + = False + + -- We need a new parameter for this free variable. + | otherwise + = True + + +-- Function to get the type of an expression in the given context. +typeOfExp + :: (Pretty a, Show a, Show n, Pretty n, Eq n, Ord n) + => Profile n -- ^ Language profile. + -> Context a n -- ^ Current context. + -> Exp a n -- ^ Expression we want the type for. + -> Type n + +typeOfExp p c x + = case Check.typeOfExp + (Check.configOfProfile p) + (contextEnv c) x + of Left err + -> error $ renderIndent $ vcat + [ text "ddc-core-simpl.liftLambda: type error in lifted expression" + , ppr err] + + Right t + -> t + diff --git a/DDC/Core/Transform/Namify.hs b/DDC/Core/Transform/Namify.hs --- a/DDC/Core/Transform/Namify.hs +++ b/DDC/Core/Transform/Namify.hs @@ -8,8 +8,8 @@ where import DDC.Core.Module import DDC.Core.Exp -import DDC.Type.Collect -import DDC.Type.Compounds +import DDC.Core.Collect +import DDC.Type.Exp.Simple import Control.Monad import DDC.Type.Env (Env, KindEnv, TypeEnv) import qualified DDC.Type.Sum as Sum @@ -49,7 +49,7 @@ -- | Namify a thing, -- not reusing names already in the program. namifyUnique - :: (Ord n, Namify c, BindStruct c) + :: (Ord n, Namify c, BindStruct (c n) n) => (KindEnv n -> Namifier s n) -- ^ Make a namifier for level-1 names. -> (TypeEnv n -> Namifier s n) -- ^ Make a namifier for level-0 names. -> c n @@ -76,17 +76,25 @@ namify tnam xnam tt = let down = namify tnam xnam in case tt of - TVar u -> liftM TVar (rewriteT tnam u) + TVar u + -> liftM TVar (rewriteT tnam u) TCon{} -> return tt + TAbs b t + -> do (tnam', b') <- pushT tnam b + t' <- namify tnam' xnam 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' - TApp t1 t2 -> liftM2 TApp (down t1) (down t2) TSum ts -> do ts' <- mapM down $ Sum.toList ts return $ TSum $ Sum.fromList (Sum.kindOfSum ts) ts' @@ -105,7 +113,6 @@ WVar a u -> liftM (WVar a) (rewriteX tnam xnam u) WCon{} -> return ww WApp a w1 w2 -> liftM2 (WApp a) (down w1) (down w2) - WJoin a w1 w2 -> liftM2 (WJoin a) (down w1) (down w2) WType a t -> liftM (WType a) (down t) @@ -143,21 +150,16 @@ x2' <- namify tnam xnam' x2 return $ XLet a (LRec (zip bs' xs')) x2' - XLet a (LLetRegions b bs) x2 + XLet a (LPrivate b mt bs) x2 -> do (tnam', b') <- pushTs tnam b (xnam', bs') <- pushXs tnam' xnam bs x2' <- namify tnam' xnam' x2 - return $ XLet a (LLetRegions b' bs') x2' - - XLet a (LWithRegion u) x2 - -> do u' <- rewriteX tnam xnam u - x2' <- down x2 - return $ XLet a (LWithRegion u') x2' + return $ XLet a (LPrivate b' mt bs') x2' - XCase a x1 alts -> liftM3 XCase (return a) (down x1) (mapM down alts) - XCast a c x -> liftM3 XCast (return a) (down c) (down x) - XType t -> liftM XType (down t) - XWitness w -> liftM XWitness (down w) + XCase a x1 alts -> liftM2 (XCase a) (down x1) (mapM down alts) + XCast a c x -> liftM2 (XCast a) (down c) (down x) + XType a t -> liftM (XType a) (down t) + XWitness a w -> liftM (XWitness a) (down w) instance Namify (Alt a) where @@ -175,14 +177,8 @@ = let down = namify tnam xnam in case cc of CastWeakenEffect eff -> liftM CastWeakenEffect (down eff) - - CastWeakenClosure xs - -> do xs' <- mapM down xs - return $ CastWeakenClosure xs' - CastPurify w -> liftM CastPurify (down w) - CastForget w -> liftM CastForget (down w) - CastSuspend -> return CastSuspend + CastBox -> return CastBox CastRun -> return CastRun @@ -202,8 +198,7 @@ -- | Rewrite level-0 anonymous binders. -rewriteX :: Ord n - => Namifier s n +rewriteX :: Namifier s n -> Namifier s n -> Bound n -> State s (Bound n) diff --git a/DDC/Core/Transform/Prune.hs b/DDC/Core/Transform/Prune.hs --- a/DDC/Core/Transform/Prune.hs +++ b/DDC/Core/Transform/Prune.hs @@ -18,20 +18,16 @@ 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 Data.Monoid (Monoid, mempty, mappend) +import Control.Monad.Writer (Writer, runWriter, tell) +import DDC.Core.Env.EnvX (EnvX) import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Collect as C -import qualified DDC.Core.Transform.SubstituteXX as S -import qualified DDC.Core.Transform.Trim as Trim -import qualified DDC.Type.Compounds as T -import qualified DDC.Type.Sum as TS -import qualified DDC.Type.Transform.Crush as T +import qualified DDC.Core.Transform.SubstituteXX as S +import qualified DDC.Type.Exp.Simple as T +import qualified DDC.Type.Sum as TS +import qualified DDC.Core.Env.EnvT as EnvT +import Prelude hiding ((<$>)) ------------------------------------------------------------------------------- @@ -60,10 +56,10 @@ ------------------------------------------------------------------------------- -- | Erase pure let-bindings in a module that have no uses. pruneModule - :: (Show a, Show n, Ord n, Pretty n) - => Profile n -- ^ Profile of the language we're in - -> Module a n - -> Module a n + :: (Show a, Show n, Ord n, Pretty n) + => Profile n -- ^ Profile of the language we're in + -> Module a n + -> Module a n pruneModule profile mm -- If the language fragment has untracked effects then we can't do @@ -74,34 +70,37 @@ = 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 - -> Exp a n - -> TransformResult (Exp a n) + :: (Show a, Show n, Ord n, Pretty n) + => 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) = r > 0 in TransformResult - { result = xx' + { result = xx' , resultAgain = progress info , resultProgress = progress info , resultInfo = TransformInfo info } @@ -113,18 +112,19 @@ -- We generate these annotations here then pass the result off to -- deadCodeTrans to actually erase dead bindings. -- -transformTypeUsage profile kenv tenv trans xx - = case checkExp (configOfProfile profile) kenv tenv xx of - Right (xx1, _, _,_) +transformTypeUsage profile env trans xx + = let config = configOfProfile profile + rr = checkExp config env Recon DemandNone xx + in case fst rr of + Right (xx1, _, _) -> let xx2 = usageX xx1 (x', info) = runWriter (trans xx2) x'' = reannotate (\(_, AnTEC { annotTail = a }) -> a) x' in (x'', info) - Left err + Left _ -> error $ renderIndent - $ vcat [ text "DDC.Core.Transform.Prune: core type error" - , ppr err ] + $ vcat [ text "ddc-core-simpl.Prune: core type error" ] ------------------------------------------------------------------------------- @@ -135,28 +135,26 @@ -- | 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 - -> Writer PruneInfo + :: 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 , isContainedEffect $ annotEffect antec -> do -- We still need to substitute value into casts - let x2' = transformUpX' Trim.trimX $ S.substituteXX b x1 x2 + let x2' = S.substituteXX b x1 x2 -- Record that we've erased a binding. tell mempty {infoBindingsErased = 1} -- return $ XCast a (weakEff antec) - $ XCast a (weakClo a x1) $ x2' _ -> return xx @@ -164,20 +162,10 @@ where weakEff antec = CastWeakenEffect - $ T.crushEffect + $ T.crushEffect EnvT.empty $ annotEffect antec - weakClo a x1 - = CastWeakenClosure - $ Trim.trimClosures a - ( (map (XType . TVar) - $ Set.toList - $ C.freeT Env.empty x1) - ++ (map (XVar a) - $ Set.toList - $ C.freeX Env.empty x1)) - -- | Check whether this binder has no uses, -- not including weakclo casts, beause we'll substitute the bound -- expression directly into those. @@ -187,7 +175,7 @@ BName n _ -> case Map.lookup n um of Just useds -> filterUsedInCasts useds == [] - Nothing -> True + Nothing -> True BNone _ -> True _ -> False @@ -207,16 +195,16 @@ = all contained $ map T.takeTApps $ sumList - $ T.crushEffect eff + $ T.crushEffect EnvT.empty eff where contained (c : _args) = case c of - TCon (TyConSpec TcConAlloc) -> True - TCon (TyConSpec TcConDeepAlloc) -> True - TCon (TyConSpec TcConRead) -> True + TCon (TyConSpec TcConAlloc) -> True + TCon (TyConSpec TcConDeepAlloc) -> True + TCon (TyConSpec TcConRead) -> True TCon (TyConSpec TcConHeadRead) -> True TCon (TyConSpec TcConDeepRead) -> True - _ -> False + _ -> False contained [] = False diff --git a/DDC/Core/Transform/Rewrite.hs b/DDC/Core/Transform/Rewrite.hs --- a/DDC/Core/Transform/Rewrite.hs +++ b/DDC/Core/Transform/Rewrite.hs @@ -5,12 +5,11 @@ , rewriteModule , rewriteX) where -import DDC.Base.Pretty -import DDC.Core.Exp +import DDC.Data.Pretty +import DDC.Core.Exp.Annot as X import DDC.Core.Module import Data.Map (Map) import DDC.Core.Simplifier.Base (TransformResult(..), TransformInfo(..)) -import qualified DDC.Core.Compounds as X import qualified DDC.Core.Transform.AnonymizeX as A import qualified DDC.Core.Transform.Rewrite.Disjoint as RD import qualified DDC.Core.Transform.Rewrite.Env as RE @@ -18,9 +17,8 @@ import DDC.Core.Transform.Rewrite.Rule import qualified DDC.Core.Transform.SubstituteXX as S import qualified DDC.Type.Transform.SubstituteT as S -import qualified DDC.Core.Transform.Trim as Trim -import qualified DDC.Core.Transform.LiftX as L -import qualified DDC.Type.Compounds as T +import qualified DDC.Core.Transform.BoundX as L +import qualified DDC.Type.Exp.Simple as T import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe @@ -28,6 +26,7 @@ import Control.Monad.Writer (tell, runWriter) import Data.List import Data.Typeable +import Prelude hiding ((<$>)) -- Log ------------------------------------------------------------------------ @@ -208,7 +207,7 @@ = let -- only get value-level bindings bs' = filter (isBMValue . fst) bs - bas' = lookupFromSubst bs' sub + bas' = lookupFromSubst a bs' sub -- check if it looks like something has already been unfolded isUIx x = case x of @@ -221,7 +220,7 @@ -- find kind-values and sub those in as well bsK' = filter ((== BMSpec) . fst) bs - basK = lookupFromSubst bsK' sub + basK = lookupFromSubst a bsK' sub basK' = concatMap (\(b,x) -> case X.takeXType x of Just t -> [(b,t)] @@ -316,16 +315,16 @@ , ruleConstraints = constrs , ruleRight = rhs , ruleWeakEff = eff - , ruleWeakClo = clo } + , ruleWeakClo = _clo } = rule -- Try to find a substitution for the left of the rule. (m, rest) <- matchWithRule rule env f args RM.emptySubstInfo -- Check constraints, perform substitution and add weakens if necessary. - let Just a = X.takeAnnotOfExp f + let a = X.annotOfExp f - let bas2 = lookupFromSubst binds m + let bas2 = lookupFromSubst a binds m let rhs2 = A.anonymizeX rhs let (bas3,lets) = wrapLets a binds bas2 let rhs3 = L.liftX (length lets) rhs2 @@ -333,10 +332,6 @@ -- Substitute bindings into the effect of the right of the rule. let eff' = liftM (substT bas3) eff - -- Substitute bindings into the closure of the right of the rule. - let clo' = Trim.trimClosures a - $ map (S.substituteXArgs bas3) clo - -- Substitute bindings into rule constraints and -- check that they are all satisfied by the environment. let constrs' = map (substT bas3) constrs @@ -346,7 +341,6 @@ -- Build the rewritten expression. let x' = X.xLets a lets $ weakeff a eff' - $ weakclo a clo' $ S.substituteXArgs bas3 rhs3 -- Add the remaining arguments from the original expression @@ -356,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 @@ -364,25 +358,13 @@ -- | 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 = maybe x (\e -> XCast a (CastWeakenEffect e) x) meff --- | Wrap an expression in a closure weakening. -weakclo :: Ord n - => a -> [Exp a n] - -> Exp a n -> Exp a n - -weakclo a clos x - = case clos of - [] -> x - _ -> XCast a (CastWeakenClosure clos) x - - wrapLets :: Ord n => a @@ -410,7 +392,7 @@ -- | Substitute type bindings into a type. substT :: Ord n => [(Bind n, Exp a n)] -> Type n -> Type n substT bas x - = let sub = [(b, t) | (b, XType t) <- bas ] + = let sub = [(b, t) | (b, XType _ t) <- bas ] in S.substituteTs sub x @@ -506,7 +488,7 @@ -- Try to match against entire rule with no inlining. -- Eg (unbox (box 5)) - | Just a <- X.takeAnnotOfExp f + | a <- X.annotOfExp f , lhs_full <- XApp a (ruleLeft rule) hole , rule_full <- rule { ruleLeft = lhs_full, ruleLeftHole = Nothing} , Just subst <- matchWithRule rule_full env f args sub @@ -541,12 +523,14 @@ -- -- Eg: RULE [x : %] (x : Int x). ... -- -lookupFromSubst :: Ord n - => [(BindMode,Bind n)] +lookupFromSubst + :: Ord n + => a + -> [(BindMode,Bind n)] -> (Map n (Exp a n), Map n (Type n)) -> [(Bind n, Exp a n)] -lookupFromSubst bs m +lookupFromSubst a1 bs m = let bas = catMaybes $ map (lookupX m) bs in map (\(b, a) -> (A.anonymizeX b, A.anonymizeX a)) bas @@ -556,7 +540,7 @@ lookupX (_,tys) (BMSpec, b@(BName n _)) | Just t <- Map.lookup n tys - = Just (b, XType t) + = Just (b, XType a1 t) lookupX _ _ = Nothing diff --git a/DDC/Core/Transform/Rewrite/Disjoint.hs b/DDC/Core/Transform/Rewrite/Disjoint.hs --- a/DDC/Core/Transform/Rewrite/Disjoint.hs +++ b/DDC/Core/Transform/Rewrite/Disjoint.hs @@ -4,11 +4,10 @@ , checkDistinct ) where import DDC.Core.Exp -import DDC.Type.Predicates -import DDC.Type.Compounds -import qualified DDC.Core.Transform.Rewrite.Env as RE -import qualified DDC.Type.Sum as Sum -import qualified DDC.Type.Transform.Crush as TC +import DDC.Type.Exp.Simple as T +import qualified DDC.Core.Transform.Rewrite.Env as RE +import qualified DDC.Type.Sum as Sum +import qualified DDC.Core.Env.EnvT as EnvT -- | Check whether a disjointness property is true in the given @@ -53,23 +52,23 @@ -- Example: -- -- > checkDisjoint --- > (Disjoint (Read r1 + Read r2) (Write r3)) --- > [Distinct r1 r3, Distinct r2 r3] +-- > (Disjoint (Read r1 + Read r2) (Write r3)) +-- > [Distinct r1 r3, Distinct r2 r3] -- > = 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. + -> RE.RewriteEnv a n -- ^ Environment we're rewriting in. -> Bool checkDisjoint c env -- 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 fs - , g <- sumList $ TC.crushEffect gs ] + | f <- sumList $ T.crushEffect EnvT.empty fs + , g <- sumList $ T.crushEffect EnvT.empty gs ] | otherwise = False @@ -79,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 @@ -117,15 +116,15 @@ -- checkDistinct :: Ord n - => Type n -- ^ Type of the property we want, + => Type n -- ^ Type of the property we want, -- eg @Distinct r1 r2@ - -> RE.RewriteEnv a n -- ^ Environment we're rewriting in. + -> RE.RewriteEnv a n -- ^ Environment we're rewriting in. -> Bool checkDistinct c env -- It's of the form "Distinct r q" | (TCon (TyConWitness (TwConDistinct _)) : args) - <- takeTApps c + <- takeTApps c = all (uncurry $ areDistinct env) (combinations args) | otherwise @@ -186,7 +185,7 @@ concrete r = case r of UPrim _ _ -> True - _ -> RE.containsRegion r env + _ -> RE.containsRegion r env check w | (TCon (TyConWitness (TwConDistinct _)) : args) @@ -199,5 +198,5 @@ rgn b = case b of UPrim _ t -> TCon (TyConBound b t) - _ -> TVar b + _ -> TVar b diff --git a/DDC/Core/Transform/Rewrite/Env.hs b/DDC/Core/Transform/Rewrite/Env.hs --- a/DDC/Core/Transform/Rewrite/Env.hs +++ b/DDC/Core/Transform/Rewrite/Env.hs @@ -13,11 +13,9 @@ , 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.Transform.LiftT as L -import qualified DDC.Core.Transform.LiftX as L +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) @@ -43,7 +41,7 @@ -- | Assoc of known values -- If going to inline them, they must only reference de bruijn binds -- these are value-level bindings, so be careful lifting. - , defs :: [[RewriteDef a n]] } + , defs :: [[RewriteDef a n]] } deriving (Show,Eq) @@ -52,7 +50,7 @@ -- | An empty environment. -empty :: Ord n => RewriteEnv a n +empty :: RewriteEnv a n empty = RewriteEnv [] [] [] @@ -75,7 +73,7 @@ -- If it's a letregion, remember the region's name and any witnesses. -- extendLets :: Ord n => Lets a n -> RewriteEnv a n -> RewriteEnv a n -extendLets (LLetRegions bs cs) renv +extendLets (LPrivate bs _mt cs) renv = foldl (flip extend) (foldl extendB renv bs) cs where extendB (env@RewriteEnv{witnesses = ws, letregions = rs}) b @@ -91,22 +89,20 @@ -> env extend' b (r:rs') = (b:r) : rs' - extend' b [] = [[b]] + extend' b [] = [[b]] extendLets (LLet b def) env = insertDef b (Just def') (liftValue b env) where def' = case b of - BAnon{} -> L.liftX 1 def - _ -> def + BAnon{} -> L.liftX 1 def + _ -> def extendLets (LRec bs) env = foldl lift' env (map fst bs) where lift' e b = insertDef b Nothing (liftValue b e) -extendLets _ env = env - -- Witnesses ------------------------------------------------------------------ -- | Check if the witness map in the given environment. --- @@ -160,7 +156,7 @@ = env { defs = extend' $ defs env } where extend' (r:rs') = ((b,def):r) : rs' - extend' [] = [[(b,def)]] + extend' [] = [[(b,def)]] hasDef :: (Ord n, L.MapBoundX (Exp a) n) @@ -192,9 +188,9 @@ match b' i ds = fmap (fmap $ L.liftX i) - $ listToMaybe - $ map snd - $ filter (T.boundMatchesBind b' . fst) ds + $ listToMaybe + $ map snd + $ filter (T.boundMatchesBind b' . fst) ds orM (Just x) _ = Just x orM Nothing y = y diff --git a/DDC/Core/Transform/Rewrite/Error.hs b/DDC/Core/Transform/Rewrite/Error.hs --- a/DDC/Core/Transform/Rewrite/Error.hs +++ b/DDC/Core/Transform/Rewrite/Error.hs @@ -4,7 +4,7 @@ where import DDC.Core.Exp import DDC.Core.Check () -import DDC.Type.Pretty +import DDC.Core.Pretty import qualified DDC.Core.Check as C @@ -49,7 +49,8 @@ ppr Rhs = text "rhs" -instance (Show a, Pretty n, Show n, Eq n) => Pretty (Error a n) where +instance (Pretty a, Pretty n, Show n, Eq n) + => Pretty (Error a n) where ppr err = case err of ErrorTypeCheck s x e diff --git a/DDC/Core/Transform/Rewrite/Match.hs b/DDC/Core/Transform/Rewrite/Match.hs --- a/DDC/Core/Transform/Rewrite/Match.hs +++ b/DDC/Core/Transform/Rewrite/Match.hs @@ -8,16 +8,16 @@ , match) where import DDC.Core.Exp -import DDC.Type.Transform.Crush import Data.Set (Set) import Data.Map (Map) 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 Data.Map as Map -import qualified Data.Set as Set +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.Exp.Simple as T +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified DDC.Core.Env.EnvT as EnvT ------------------------------------------------------------------------------- @@ -62,12 +62,12 @@ Nothing -> return $ insertx n r m Just x -> -- Check if they're equal. Anonymize so names don't matter. - -- Reannotate so annotations are ignored. - let x' = T.anonymizeX $ T.reannotate (const ()) x - r' = T.anonymizeX $ T.reannotate (const ()) r - in if x' == r' - then Just m - else Nothing + -- Reannotate so annotations are ignored. + let x' = T.anonymizeX $ T.reannotate (const ()) x + r' = T.anonymizeX $ T.reannotate (const ()) r + in if x' == r' + then Just m + else Nothing match m _ (XVar _ v1) (XVar _ v2) | v1 == v2 = Just m @@ -76,19 +76,19 @@ | c1 == c2 = Just m match m bs (XApp _ x11 x12) (XApp _ x21 x22) - = do m' <- match m bs x11 x21 - match m' bs x12 x22 + = do m' <- match m bs x11 x21 + match m' bs x12 x22 match m bs (XCast _ c1 x1) (XCast _ c2 x2) - | eqCast c1 c2 + | eqCast c1 c2 = match m bs x1 x2 -match (xs, tys) bs (XType t1) (XType t2) - = do tys' <- matchT t1 t2 bs tys - return (xs, tys') +match (xs, tys) bs (XType _ t1) (XType _ t2) + = do tys' <- matchT t1 t2 bs tys + return (xs, tys') -match m _ (XWitness w1) (XWitness w2) - | eqWit w1 w2 = return m +match m _ (XWitness _ w1) (XWitness _ w2) + | eqWit w1 w2 = return m match _ _ _ _ = Nothing @@ -101,10 +101,8 @@ = T.reannotate (const ()) $ case c of CastWeakenEffect eff -> CastWeakenEffect $ T.anonymizeT eff - CastWeakenClosure clo -> CastWeakenClosure $ map T.anonymizeX clo CastPurify wit -> CastPurify wit - CastForget wit -> CastForget wit - CastSuspend -> CastSuspend + CastBox -> CastBox CastRun -> CastRun @@ -134,8 +132,8 @@ -> Maybe (Subst n) matchT t1 t2 vs subst - = let t1' = unpackSumT $ crushSomeT t1 - t2' = unpackSumT $ crushSomeT 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. -- @@ -185,7 +183,7 @@ | Set.member n vs , Just t1'' <- Map.lookup n subst - , TE.equivT t1'' t2' + , T.equivT EnvT.empty t1'' t2' -> Just subst -- Both are variables but it's not a template variable, diff --git a/DDC/Core/Transform/Rewrite/Parser.hs b/DDC/Core/Transform/Rewrite/Parser.hs --- a/DDC/Core/Transform/Rewrite/Parser.hs +++ b/DDC/Core/Transform/Rewrite/Parser.hs @@ -6,91 +6,93 @@ 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 -- Rewrite Rules ---------------------------------------------------------------- {- [r1 r2 : %] (x : Int r1). - Const r1 => - addInt [:r1 r2 r1:] x (0 [r2] ()) = - x + Const r1 => + addInt [:r1 r2 r1:] x (0 [r2] ()) = + x -} -- | Parse a rewrite rule. -pRule :: Ord n - => Context -> Parser n (R.RewriteRule P.SourcePos n) +pRule :: Ord n + => Context n -> Parser n (R.RewriteRule P.SourcePos n) pRule c - = do bs <- pRuleBinders c - (cs,lhs) <- pRuleCsLhs c - hole <- pRuleHole c - pTok KEquals - rhs <- pExp c + = do bs <- pRuleBinders c + (cs,lhs) <- pRuleCsLhs c + hole <- pRuleHole c + pSym SEquals + rhs <- pExp c - return $ R.mkRewriteRule bs cs lhs hole rhs + return $ R.mkRewriteRule bs cs lhs hole rhs {- add_zero_r [r1 r2 : %] (x : Int r1). - Const r1 => - addInt [:r1 r2 r1:] x (0 [r2] ()) = - x; + Const r1 => + addInt [:r1 r2 r1:] x (0 [r2] ()) = + x; add_zero_l [r1 r2 : %] ... ; -} -- | Parse many rewrite rules. -pRuleMany +pRuleMany :: Ord n - => Context -> Parser n [(n,R.RewriteRule P.SourcePos n)] + => Context n -> Parser n [(n,R.RewriteRule P.SourcePos n)] pRuleMany c = P.many (do n <- pName r <- pRule c - pTok KSemiColon + pSym SSemiColon return (n,r)) pRuleBinders :: Ord n - => Context -> Parser n [(R.BindMode,Bind n)] + => Context n -> Parser n [(R.BindMode,Bind n)] pRuleBinders c = P.choice - [ do bs <- P.many1 (pBinders c) - pTok KDot - return $ concat bs + [ do bs <- P.many1 (pBinders c) + pSym SDot + return $ concat bs , return [] ] pRuleCsLhs :: Ord n - => Context -> Parser n ([Type n], Exp P.SourcePos n) + => Context n -> Parser n ([Type n], Exp P.SourcePos n) pRuleCsLhs c = P.choice - [ do cs <- P.many1 $ P.try (do - cc <- pTypeApp c - pTok KArrowEquals - return cc) - lhs <- pExp c - return (cs,lhs) - , do lhs <- pExp c - return ([],lhs) + [ do cs <- P.many1 $ P.try (do + cc <- pTypeApp c + pSym SArrowEquals + return cc) + lhs <- pExp c + return (cs,lhs) + , do lhs <- pExp c + return ([],lhs) ] pRuleHole :: Ord n - => Context -> Parser n (Maybe (Exp P.SourcePos n)) + => Context n -> Parser n (Maybe (Exp P.SourcePos n)) pRuleHole c = P.optionMaybe - $ do pTok KBraceBra - e <- pExp c - pTok KBraceKet - return e + $ do pSym SUnderscore + pSym SBraceBra + e <- pExp c + pSym SBraceKet + pSym SUnderscore + return e -- | Parse rewrite binders @@ -101,26 +103,26 @@ -- pBinders :: Ord n - => Context -> Parser n [(R.BindMode, Bind n)] + => 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) ] pBindersBetween :: Ord n - => Context + => 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 - = do bra + = do bra bs <- P.many1 pBinder - pTok KColon + pTok (KOp ":") t <- pType c ket return $ map (mk t) bs diff --git a/DDC/Core/Transform/Rewrite/Rule.hs b/DDC/Core/Transform/Rewrite/Rule.hs --- a/DDC/Core/Transform/Rewrite/Rule.hs +++ b/DDC/Core/Transform/Rewrite/Rule.hs @@ -17,30 +17,25 @@ import DDC.Core.Transform.Rewrite.Error import DDC.Core.Transform.Reannotate import DDC.Core.Transform.TransformUpX -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Pretty () import DDC.Core.Collect -import DDC.Core.Compounds -import DDC.Type.Pretty () -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Base.Pretty -import Control.Monad +import DDC.Core.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: -- @@ -138,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,53 +159,53 @@ -- We don't handle anonymous binders on either the left or right. -- checkRewriteRule - :: (Ord n, Show n, Pretty n) + :: (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 + (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 -- Build application from lhs and the hole so we can check its -- type against rhs - let Just a = takeAnnotOfExp lhs + let a = annotOfExp lhs let lhs_full = maybe lhs (XApp a lhs) hole -- Check the full left hand side. - (lhs_full', tLeft, effLeft, cloLeft) - <- checkExp config kenv' tenv' Lhs lhs_full + (lhs_full', tLeft, effLeft) + <- checkExp config env' Lhs lhs_full -- Check the full right hand side. - (rhs', tRight, effRight, cloRight) - <- checkExp config kenv' tenv' Rhs rhs + (rhs', tRight, effRight) + <- checkExp config env' Rhs rhs -- Check that types of both sides are equivalent. let err = ErrorTypeConflict - (tLeft, effLeft, cloLeft) - (tRight, effRight, cloRight) + (tLeft, effLeft, tBot kClosure) + (tRight, effRight, tBot kClosure) checkEquiv tLeft tRight err @@ -221,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. @@ -261,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 - :: (Ord n, Show n, Pretty n) - => C.Config n - -> KindEnv n -- ^ Kind environment of expression. - -> TypeEnv n -- ^ Type environment of expression. + :: (Show a, Ord n, Show n, Pretty n) + => 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, Closure 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 C.checkExp defs kenv tenv 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 @@ -301,14 +299,13 @@ 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.checkType config kenv tt of +checkConstraint config tt + = case C.checkSpec config tt of Left _err -> Left $ ErrorBadConstraint tt - Right k + Right (_, k) | T.isWitnessType tt -> return k | otherwise -> Left $ ErrorBadConstraint tt @@ -322,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 --------------------------------------------------------------------- @@ -333,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. @@ -343,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 @@ -365,37 +363,36 @@ -- 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 spRight = supportSpVar supportRight - Just a = takeAnnotOfExp lhs + a = annotOfExp lhs in Right $ [XVar a u | u <- Set.toList $ daLeft `Set.difference` daRight ] - ++ [XWitness (WVar a u) + ++ [XWitness a (WVar a u) | u <- Set.toList $ wiLeft `Set.difference` wiRight ] - ++ [XType (TVar u) + ++ [XType a (TVar u) | u <- Set.toList $ spLeft `Set.difference` spRight ] @@ -405,18 +402,19 @@ 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 et <- x - , Right k <- T.checkType config kenv et + | XType a et <- x + , Right (_, k) <- C.checkSpec config et , T.isEffectKind k - = XType $ T.tBot T.kEffect + = XType a $ T.tBot T.kEffect | otherwise = x @@ -425,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) () @@ -469,14 +467,15 @@ go x@(XLet _ _ _) = Left $ ErrorNotFirstOrder x go x@(XCase _ _ _) = Left $ ErrorNotFirstOrder x go (XCast _ _ x) = go x - go (XType t) = go_t t - go (XWitness _) = return () + go (XType a t) = go_t a t + go (XWitness _ _) = return () - go_t (TVar _) = return () - go_t (TCon _) = return () - go_t t@(TForall _ _) = Left $ ErrorNotFirstOrder (XType t) - go_t (TApp l r) = go_t l >> go_t r - go_t (TSum _) = return () + go_t _ (TVar _) = return () + go_t _ (TCon _) = return () + 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 () -- | Count how many times each binder is used in right-hand side. @@ -487,8 +486,8 @@ -> Either (Error a n) [(BindMode, Bind n)] countBinderUsage bs x - = let Just (U.UsedMap um) - = liftM fst $ takeAnnotOfExp $ U.usageX x + = let U.UsedMap um + = fst $ annotOfExp $ U.usageX x get (BMValue _, BName n t) = (BMValue diff --git a/DDC/Core/Transform/Snip.hs b/DDC/Core/Transform/Snip.hs --- a/DDC/Core/Transform/Snip.hs +++ b/DDC/Core/Transform/Snip.hs @@ -7,11 +7,9 @@ where import DDC.Core.Analysis.Arity import DDC.Core.Module -import DDC.Core.Exp -import DDC.Core.Compounds -import DDC.Core.Predicates -import qualified DDC.Core.Transform.LiftX as L -import qualified DDC.Type.Compounds as T +import DDC.Core.Exp.Annot +import qualified DDC.Core.Transform.BoundX as L +import qualified DDC.Type.Exp.Simple as T ------------------------------------------------------------------------------- @@ -23,6 +21,10 @@ -- | Ensure the body of a let-expression is a variable. , configSnipLetBody :: Bool + + -- | Treat lambda abstractions as atomic, + -- and don't snip them. + , configPreserveLambdas :: Bool } @@ -31,7 +33,8 @@ configZero = Config { configSnipOverApplied = False - , configSnipLetBody = False } + , configSnipLetBody = False + , configPreserveLambdas = False } ------------------------------------------------------------------------------- @@ -92,7 +95,7 @@ in case xx of -- The snipX function shouldn't have called us with an XApp. XApp{} - -> error "DDC.Core.Transform.Snip: snipX shouldn't give us an XApp" + -> error "ddc-core-simpl.Snip: snipX shouldn't give us an XApp" -- leafy constructors XVar{} -> xx @@ -123,16 +126,11 @@ x2' = snipLetBody config a $ down ars x2 in XLet a (LRec $ zip bs xs') x2' - -- letregion, just make sure we record bindings with dummy val. - XLet a (LLetRegions b bs) x2 + -- private, just make sure we record bindings with dummy val. + XLet a (LPrivate b mt bs) x2 -> let ars = zip bs (repeat 0) x2' = snipLetBody config a $ down ars x2 - in XLet a (LLetRegions b bs) x2' - - -- withregion - XLet a (LWithRegion b) x2 - -> let x2' = snipLetBody config a $ down [] x2 - in XLet a (LWithRegion b) x2' + in XLet a (LPrivate b mt bs) x2' -- case -- Split out non-atomic discriminants into their own bindings. @@ -166,8 +164,8 @@ buildNormalisedApp :: Ord n => Config -- ^ Snipper config. - -> Arities n -- ^ environment, arities of bound variables - -> Exp a n -- ^ function + -> Arities n -- ^ environment, arities of bound variables + -> Exp a n -- ^ function -> [(Exp a n,a)] -- ^ arguments being applied to current expression -> Exp a n @@ -211,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. @@ -224,7 +221,7 @@ -- Split arguments into the already atomic ones, -- and the ones we need to introduce let-expressions for. - argss = splitArgs xsArgs + argss = splitArgs config xsArgs -- Collect up the new let-bindings. xsLets = [ (x, a) @@ -286,14 +283,14 @@ -- | Sort function arguments into either the atomic ones, -- or compound ones. splitArgs - :: Ord n - => [(Exp a n, a)] + :: Config + -> [(Exp a n, a)] -> [( Exp a n -- Expression to use as the new argument. , a -- Annoation for the argument application. , Bool -- Whether this argument was already atomic. , Maybe (Exp a n))] -- New expression to let-bind. -splitArgs args +splitArgs config args = reverse $ go 0 $ reverse args where go _n [] = [] @@ -301,6 +298,10 @@ | isAtom xArg = (xArg, a, True, Nothing) : go n xsArgs + | configPreserveLambdas config + , isXLam xArg || isXLAM xArg + = (xArg, a, True, Nothing) : go n xsArgs + | otherwise = (XVar a (UIx n), a, False, Just xArg) : go (n + 1) xsArgs @@ -329,6 +330,9 @@ XCon{} -> True XType{} -> True XWitness{} -> True + + -- Keep applications of variables to their types together. +-- XApp _ x1 XType{} -> isAtom x1 -- Casts are ignored by code generator, so we can leave them in if -- their subexpression is normal diff --git a/DDC/Core/Transform/Thread.hs b/DDC/Core/Transform/Thread.hs --- a/DDC/Core/Transform/Thread.hs +++ b/DDC/Core/Transform/Thread.hs @@ -9,10 +9,9 @@ , Config (..) , injectStateType) where -import DDC.Core.Compounds import DDC.Core.Module -import DDC.Core.Exp -import DDC.Base.Pretty +import DDC.Core.Exp.Annot +import DDC.Data.Pretty import DDC.Core.Transform.Reannotate import DDC.Core.Check (AnTEC (..)) import DDC.Type.Env (KindEnv, TypeEnv) @@ -215,7 +214,7 @@ in XLam (annotTail a) b x' -- Inject a new lambda to bind the state parameter. - _ | Just a <- takeAnnotOfExp xx + _ | a <- annotOfExp xx , t == configTokenType config -> let b' = BAnon (configTokenType config) tenv' = Env.extend b' tenv @@ -339,10 +338,12 @@ XLAM{} -> error "ddc-core-simpl.Thread: unexpected XLAM" XLam{} -> error "ddc-core-simpl.Thread: unexpected XLam" XCast{} -> error "ddc-core-simpl.Thread: unexpected cast." - XType t -> XType t + + XType a t + -> XType (annotTail a) t - XWitness w - -> XWitness (reannotate annotTail w) + XWitness a w + -> XWitness (annotTail a) (reannotate annotTail w) -- Tailcalls XApp a _ _ @@ -358,7 +359,7 @@ -- Otherwise wrap the returned value with a tuple holding -- the world. | otherwise - -> let Just a = takeAnnotOfExp xx + -> let a = annotOfExp xx a' = AnTEC (configTokenType config) (tBot kEffect) (tBot kClosure) @@ -404,7 +405,7 @@ | (tsArg@(_ : _), tResult) <- takeTFunArgResult tt -> let tsArg' = tsArg ++ [configTokenType config] tResult' = injectStateType config tResult - in foldr tFunPE tResult' tsArg' + in foldr tFun tResult' tsArg' _ | tt == configTokenType config -> tt | tt == configVoidType config -> configTokenType config diff --git a/DDC/Core/Transform/TransformDownX.hs b/DDC/Core/Transform/TransformDownX.hs --- a/DDC/Core/Transform/TransformDownX.hs +++ b/DDC/Core/Transform/TransformDownX.hs @@ -6,8 +6,7 @@ , transformDownX') where import DDC.Core.Module -import DDC.Core.Exp -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import DDC.Type.Env (KindEnv, TypeEnv) import Data.Functor.Identity import Control.Monad @@ -19,7 +18,8 @@ :: forall (c :: * -> * -> *) a n . (Ord n, TransformDownMX Identity c) => (KindEnv n -> TypeEnv n -> Exp a n -> Exp a n) - -- ^ The worker function is given the current kind and type environments. + -- ^ 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. @@ -104,8 +104,8 @@ (return a) (return c) (transformDownMX f kenv tenv x) - XType _ -> return xx' - XWitness _ -> return xx' + XType{} -> return xx' + XWitness{} -> return xx' instance Monad m => TransformDownMX m Lets where @@ -121,8 +121,8 @@ xs' <- mapM (transformDownMX f kenv tenv') xs return $ LRec $ zip bs xs' - LLetRegions{} -> return xx - LWithRegion{} -> return xx + LPrivate{} + -> return xx instance Monad m => TransformDownMX m Alt where diff --git a/DDC/Core/Transform/TransformModX.hs b/DDC/Core/Transform/TransformModX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/TransformModX.hs @@ -0,0 +1,45 @@ + +-- | Helper for transforming the bindings in a module +module DDC.Core.Transform.TransformModX + ( transformModX + , transformModLet + ) +where +import DDC.Core.Module +import DDC.Core.Exp.Annot + +import Control.Arrow + + +-- | Apply transform to each expression let binding in module +transformModX :: (Exp a n -> Exp a n) + -> Module a n + -> Module a n +transformModX f mm + = transformModLet (const f) mm + + +-- | Apply transform to each expression let binding in module, with bind too +transformModLet :: (Bind n -> Exp a n -> Exp a n) + -> Module a n + -> Module a n +transformModLet f mm + = let body = moduleBody mm + + (lets,xx) = splitXLetsAnnot body + lets' = map (first go) lets + + body' = xLetsAnnot lets' xx + + in mm { moduleBody = body' } + where + go (LRec binds) + = LRec [ (b, f b x) + | (b, x) <- binds] + + go (LLet b x) + = LLet b (f b x) + + go l + = l + diff --git a/DDC/Core/Transform/TransformUpX.hs b/DDC/Core/Transform/TransformUpX.hs --- a/DDC/Core/Transform/TransformUpX.hs +++ b/DDC/Core/Transform/TransformUpX.hs @@ -1,43 +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 -import DDC.Core.Compounds -import DDC.Core.Transform.Annotate -import DDC.Core.Transform.Deannotate -import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Core.Exp.Annot import Data.Functor.Identity import Control.Monad -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Exp.Simple 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. @@ -51,7 +38,7 @@ -> c a n transformUpX' f xx - = transformUpX (\_ _ -> f) Env.empty Env.empty xx + = transformUpX (\_ -> f) EnvX.empty xx ------------------------------------------------------------------------------- @@ -59,157 +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 + 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' - LLetRegions{} -> return xx - LWithRegion{} -> return xx + 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 - = case takeAnnotOfExp xx of - Nothing -> return xx - Just a - -> do let sxx = deannotate (const Nothing) xx - msxx' <- f kenv tenv sxx - case msxx' of - Nothing -> return $ xx - Just sxx' -> return $ annotate a sxx' - - in transformUpMX f' kenv0 tenv0 xx0 - - --- | Like `transformUpX`, but the worker takes the Simple version of the AST. --- --- * To avoid repeated conversions between the different versions of the AST, --- the worker should return `Nothing` if the provided expression is unchanged. -transformSimpleUpX - :: forall (c :: * -> * -> *) a n - . (Ord n, TransformUpMX Identity c) - => (KindEnv n -> TypeEnv n -> S.Exp a n -> Maybe (S.Exp a n)) - -- ^ The worker function is given the current - -- kind and type environments. - -> KindEnv n -- ^ Initial kind environment. - -> TypeEnv n -- ^ Initial type environment. - -> c a n -- ^ Transform this thing. - -> c a n - -transformSimpleUpX f kenv tenv xx - = runIdentity - $ transformSimpleUpMX - (\kenv' tenv' x -> return (f kenv' tenv' x)) - kenv tenv xx - - --- | Like `transformUpX'`, but the worker takes the Simple version of the AST. --- --- * To avoid repeated conversions between the different versions of the AST, --- the worker should return `Nothing` if the provided expression is unchanged. -transformSimpleUpX' - :: forall (c :: * -> * -> *) a n - . (Ord n, TransformUpMX Identity c) - => (S.Exp a n -> Maybe (S.Exp a n)) - -- ^ The worker function is given the current - -- kind and type environments. - -> c a n -- ^ Transform this thing. - -> c a n - -transformSimpleUpX' f xx - = transformSimpleUpX (\_ _ -> f) Env.empty Env.empty xx - + (transformUpMX f env x) diff --git a/DDC/Core/Transform/Unshare.hs b/DDC/Core/Transform/Unshare.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Transform/Unshare.hs @@ -0,0 +1,334 @@ + +module DDC.Core.Transform.Unshare + (unshareModule) +where +import DDC.Core.Exp.Annot.AnTEC +import DDC.Core.Exp.Annot +import DDC.Core.Module +import DDC.Type.Transform.SubstituteT +import Data.Map (Map) +import qualified Data.Map.Strict as Map + + +------------------------------------------------------------------------------- +-- | Apply the unsharing transform to a module. +unshareModule + :: (Show a, Ord n, Show n) + => Module (AnTEC a n) n -> Module (AnTEC a n) n + +unshareModule !mm + = let + -- Add extra parameters to the types of imported CAFs. + importValuesNts + = [ let (iv', m) = addParamsImportValue iv + in ((n, iv'), m) + | (n, iv) <- moduleImportValues mm] + + (importValues', ntssImport') + = unzip importValuesNts + + -- Add extra parameters to the CAFs, + -- returning the names of the ones we've transformed + -- along with the transformed module body. + (ntsBody, xx) = addParamsX $ moduleBody mm + + -- Add the corresponding arguments to each use. + nts' = Map.union (Map.unions ntssImport') ntsBody + xx' = addArgsX nts' xx + + -- Update the types of exports with the transformed ones. + exportValues' + = [ (n, updateExportSource nts' ex) + | (n, ex) <- moduleExportValues mm ] + + in mm { moduleBody = xx' + , moduleExportValues = exportValues' + , moduleImportValues = importValues' } + + +------------------------------------------------------------------------------- +-- | If this import def imports a CAF then then add an extra parameter to its +-- type, assuming that the unsharing transform has also been applied to the +-- imported module. +-- +addParamsImportValue + :: ImportValue n (Type n) + -> (ImportValue n (Type n), Map n (Type n)) + +addParamsImportValue iv + = case iv of + ImportValueModule m n t (Just (nType, nValue, nBoxes)) + -> case addParamsT t of + Just t' + -> ( ImportValueModule m n t' + (Just (nType, nValue + 1, nBoxes)) + , Map.singleton n t') + + Nothing + -> ( iv, Map.empty) + + ImportValueModule{} -> (iv, Map.empty) + ImportValueSea{} -> (iv, Map.empty) + + +-- | If this is the type of a CAF then add an extra unit parameter to it. +addParamsT :: Type n -> Maybe (Type n) +addParamsT tt + = case tt of + TVar{} -> Just $ tUnit `tFun` tt + TCon{} -> Just $ tUnit `tFun` tt + + TAbs b tBody + -> do tBody' <- addParamsT 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 + + +------------------------------------------------------------------------------- +-- | Add unit parameters to the top-level CAFs in the given module body, +-- returning a map of names of transformed CAFs to their transformed +-- types. +addParamsX + :: Ord n + => Exp (AnTEC a n) n -- Module body to transform. + -> ( Map n (Type n) -- Map of transformed bindings to their + -- transformed types. + , Exp (AnTEC a n) n) -- Transformed module body. + +addParamsX xx + = case xx of + -- Transform all the top-level bindings of a module body. + XLet a (LRec bxs) xBody + -> let (ns, bxs') = addParamsBXS a bxs + in ( ns + , XLet a (LRec bxs') xBody) + + _ -> ( Map.empty + , xx) + + +-- | Add unit parameters to the bound CAFs in the given list. +addParamsBXS _a [] + = (Map.empty, []) + +addParamsBXS a ((b, x) : bxs) + = let (ns1, b', x') = addParamsBX a b x + (ns2, bxs') = addParamsBXS a bxs + in ( Map.union ns1 ns2 + , (b', x') : bxs') + + +-- | Add unit parameter to a single top-level binding, if it needs one. +addParamsBX _ b@(BName n _) x + = case addParamsBodyX x of + Nothing + -> (Map.empty, b, x) + + Just (x', t') + -> ( Map.singleton n t' + , replaceTypeOfBind t' b + , x') + +addParamsBX _ b x + = (Map.empty, b, x) + + +-- | Add unit parameters to the right of a let-binding. +addParamsBodyX xx + = case xx of + -- This binding already has an outer value abstraction, + -- so we don't need to add any more. + XLam{} + -> Nothing + + -- Decend under type abstractions. To keep the supers + -- in standard form with all the type abstractions first, + -- if we need to add a value abstraction we want to add it + -- under exising type abstractions. + XLAM a bParam xBody + -> case addParamsBodyX xBody of + Nothing + -> Nothing + + Just (xBody', tBody') + -> let t' = TForall bParam tBody' + a' = a { annotType = t' } + in Just ( XLAM a' bParam xBody', t') + + -- We've hit a plain value, so need to wrap it in a + -- value abstraction. + _ + -> let a = annotOfExp xx + t' = tFun tUnit (annotType a) + a' = a { annotType = t' } + in Just (XLam a' (BNone tUnit) xx, t') + + +------------------------------------------------------------------------------- +-- | Decend into an expression looking for applications of CAFs that +-- we've already added an extra unit parameter to. When we find them, +-- add the matching unit argument. +-- +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. + -> Exp (AnTEC a n) n -- ^ Transformed expression. + +addArgsX nts xx + = let downX = addArgsX nts + downLts = addArgsLts nts + downA = addArgsAlt nts + + in case xx of + + -- Add an extra argument for a monomorphic CAF. + XVar a (UName n) + -> case Map.lookup n nts of + Just tF + -> let xx' = XVar (a { annotType = tF }) (UName n) + in wrapAppX a tF xx' + + Nothing -> xx + + XVar{} -> xx + XCon{} -> xx + + XApp{} -> addArgsAppX nts xx [] + + -- For the rest of the constructs their types do not + -- change during the transform so we can resuse the old ones. + XLAM a b xBody -> XLAM a b (downX xBody) + XLam a b xBody -> XLam a b (downX xBody) + XLet a lts xBody -> XLet a (downLts lts) (downX xBody) + XCase a xScrut as -> XCase a (downX xScrut) (map downA as) + XCast a c x -> XCast a c (downX x) + XType{} -> xx + XWitness{} -> xx + + +addArgsAppX !nts !xx !ats + = let downX = addArgsX nts + tA = annotType $ annotOfExp xx + in case xx of + XVar a (UName n) + -> case Map.lookup n nts of + Just tF + -> let xx' = XVar (a { annotType = tF }) (UName n) + (x1, t1) = wrapAtsX xx' tF ats + x2 = wrapAppX a t1 x1 + in x2 + + Nothing + -> fst $ wrapAtsX xx tA ats + + XVar{} + -> fst $ wrapAtsX xx tA ats + + XCon{} + -> fst $ wrapAtsX xx tA ats + + XApp _a1 x1 (XType a2 t) + -> addArgsAppX nts x1 ((a2, t) : ats) + + XApp a x1 x2 + -> XApp a (addArgsAppX nts x1 ats) (downX x2) + + _ -> fst $ wrapAtsX xx tA ats + + +addArgsLts nts lts + = let downX = addArgsX nts + in case lts of + LLet b x -> LLet b (downX x) + LRec bxs -> LRec [(b, downX x) | (b, x) <- bxs] + LPrivate{} -> lts + + +addArgsAlt nts aa + = let downX = addArgsX nts + in case aa of + AAlt p x -> AAlt p (downX x) + + +-- Wrap an expression with an application of a unit value. +wrapAppX :: (Show a, Show n) + => AnTEC a n + -> Type n + -> Exp (AnTEC a n) n + -> Exp (AnTEC a n) n + +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) + + + -- 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) + +wrapAtsX !xF !tF ((aArg, tArg): ats) + = case tF of + TForall bParam tBody + -> let a = annotOfExp xF + tR = substituteT bParam tArg tBody + aR = a { annotType = tR } + aV = a { annotType = tF } + xF' = mapAnnotOfExp (const aV) xF + in wrapAtsX + (XApp aR xF' (XType aArg tArg)) + tR ats + + _ -> (xF, tF) + + +------------------------------------------------------------------------------- +-- | Update the types of exported things with the ones in +-- the give map. +updateExportSource + :: Ord n + => Map n (Type n) + -> ExportSource n (Type n) -> ExportSource n (Type n) + +updateExportSource mm ex + = case ex of + ExportSourceLocal n _t + -> case Map.lookup n mm of + Nothing -> ex + Just t' -> ExportSourceLocal n t' + + ExportSourceLocalNoType _ + -> ex + diff --git a/DDC/Type/Transform/Alpha.hs b/DDC/Type/Transform/Alpha.hs --- a/DDC/Type/Transform/Alpha.hs +++ b/DDC/Type/Transform/Alpha.hs @@ -16,8 +16,9 @@ = case tt of TVar u -> TVar (alpha f u) TCon c -> TCon (alpha f c) - TForall b t -> TForall (alpha f b) (alpha f t) + TAbs b t -> TAbs (alpha f b) (alpha f t) TApp t1 t2 -> TApp (alpha f t1) (alpha f t2) + TForall b t -> TForall (alpha f b) (alpha f t) TSum ts -> TSum (alpha f ts) @@ -49,5 +50,6 @@ TyConKind kc -> TyConKind kc TyConWitness tc -> TyConWitness tc TyConSpec tc -> TyConSpec tc - TyConBound u t -> TyConBound (alpha f u) (alpha f t) + TyConBound u k -> TyConBound (alpha f u) (alpha f k) + TyConExists i k -> TyConExists i (alpha f k) diff --git a/DDC/Type/Transform/AnonymizeT.hs b/DDC/Type/Transform/AnonymizeT.hs --- a/DDC/Type/Transform/AnonymizeT.hs +++ b/DDC/Type/Transform/AnonymizeT.hs @@ -4,8 +4,7 @@ , AnonymizeT(..) , pushAnonymizeBindT) where -import DDC.Type.Exp -import DDC.Type.Compounds +import DDC.Type.Exp.Simple import Data.List import qualified DDC.Type.Sum as T @@ -36,13 +35,17 @@ TCon{} -> tt - TForall b t + TAbs b t -> let (kstack', b') = pushAnonymizeBindT kstack b - in TForall b' (anonymizeWithT kstack' t) + in TAbs b' (anonymizeWithT kstack' t) TApp t1 t2 -> TApp (anonymizeWithT kstack t1) (anonymizeWithT kstack t2) + TForall b t + -> let (kstack', b') = pushAnonymizeBindT kstack b + in TForall b' (anonymizeWithT kstack' t) + TSum ss -> TSum (anonymizeWithT kstack ss) @@ -68,8 +71,7 @@ -- | Push a binding occurrence of a level-1 variable on the stack, -- returning the anonyized binding occurrence and the new stack. pushAnonymizeBindT - :: Ord n - => [Bind n] -- ^ Stack for Spec binders (level-1) + :: [Bind n] -- ^ Stack for Spec binders (level-1) -> Bind n -> ([Bind n], Bind n) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 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 @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/ddc-core-simpl.cabal b/ddc-core-simpl.cabal --- a/ddc-core-simpl.cabal +++ b/ddc-core-simpl.cabal @@ -1,5 +1,5 @@ Name: ddc-core-simpl -Version: 0.3.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,41 +14,49 @@ Library Build-Depends: - base == 4.6.*, - deepseq == 1.3.*, + base >= 4.6 && < 4.10, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, - array == 0.4.*, - transformers == 0.3.*, - mtl == 2.1.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.* + transformers == 0.5.*, + mtl == 2.2.1.*, + ddc-core == 0.4.3.* Exposed-modules: DDC.Core.Analysis.Arity DDC.Core.Analysis.Usage - DDC.Core.Simplifier.Recipe + DDC.Core.Simplifier.Parser + DDC.Core.Simplifier.Recipe DDC.Core.Simplifier.Result + DDC.Core.Transform.Rewrite.Disjoint DDC.Core.Transform.Rewrite.Env DDC.Core.Transform.Rewrite.Match DDC.Core.Transform.Rewrite.Parser DDC.Core.Transform.Rewrite.Rule + DDC.Core.Transform.AnonymizeX DDC.Core.Transform.Beta + DDC.Core.Transform.Boxing DDC.Core.Transform.Bubble - DDC.Core.Transform.Prune DDC.Core.Transform.Elaborate DDC.Core.Transform.Eta DDC.Core.Transform.Flatten + DDC.Core.Transform.FoldCase DDC.Core.Transform.Forward DDC.Core.Transform.Inline + DDC.Core.Transform.Lambdas DDC.Core.Transform.Namify + DDC.Core.Transform.Prune DDC.Core.Transform.Rewrite DDC.Core.Transform.Snip DDC.Core.Transform.Thread - DDC.Core.Transform.TransformUpX DDC.Core.Transform.TransformDownX + DDC.Core.Transform.TransformModX + DDC.Core.Transform.TransformUpX + DDC.Core.Transform.Unshare + DDC.Core.Simplifier DDC.Type.Transform.Alpha @@ -56,32 +64,32 @@ Other-modules: DDC.Core.Simplifier.Apply - DDC.Core.Simplifier.Lexer DDC.Core.Simplifier.Base + 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: -Wall -fno-warn-orphans -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind Extensions: - BangPatterns NoMonomorphismRestriction + ExistentialQuantification + MultiParamTypeClasses + ScopedTypeVariables + DeriveDataTypeable + FlexibleInstances + FlexibleContexts ParallelListComp ExplicitForAll KindSignatures PatternGuards - MultiParamTypeClasses - FlexibleContexts - FlexibleInstances + BangPatterns RankNTypes - ExistentialQuantification - DeriveDataTypeable - ScopedTypeVariables - -