ddc-core-simpl 0.3.2.1 → 0.4.3.1
raw patch · 41 files changed
Files
- DDC/Core/Analysis/Arity.hs +8/−9
- DDC/Core/Analysis/Usage.hs +45/−38
- DDC/Core/Simplifier/Apply.hs +165/−90
- DDC/Core/Simplifier/Base.hs +38/−29
- DDC/Core/Simplifier/Lexer.hs +2/−3
- DDC/Core/Simplifier/Parser.hs +18/−19
- DDC/Core/Simplifier/Recipe.hs +38/−32
- DDC/Core/Simplifier/Result.hs +2/−2
- DDC/Core/Transform/AnonymizeX.hs +36/−42
- DDC/Core/Transform/Beta.hs +36/−63
- DDC/Core/Transform/Boxing.hs +390/−0
- DDC/Core/Transform/Bubble.hs +11/−72
- DDC/Core/Transform/Elaborate.hs +5/−9
- DDC/Core/Transform/Eta.hs +59/−54
- DDC/Core/Transform/Flatten.hs +25/−47
- DDC/Core/Transform/FoldCase.hs +84/−0
- DDC/Core/Transform/Forward.hs +86/−52
- DDC/Core/Transform/Inline.hs +1/−2
- DDC/Core/Transform/Inline/Templates.hs +6/−6
- DDC/Core/Transform/Lambdas.hs +481/−0
- DDC/Core/Transform/Lambdas/Base.hs +103/−0
- DDC/Core/Transform/Lambdas/Lift.hs +184/−0
- DDC/Core/Transform/Namify.hs +21/−26
- DDC/Core/Transform/Prune.hs +49/−61
- DDC/Core/Transform/Rewrite.hs +20/−36
- DDC/Core/Transform/Rewrite/Disjoint.hs +16/−17
- DDC/Core/Transform/Rewrite/Env.hs +13/−17
- DDC/Core/Transform/Rewrite/Error.hs +3/−2
- DDC/Core/Transform/Rewrite/Match.hs +25/−27
- DDC/Core/Transform/Rewrite/Parser.hs +47/−45
- DDC/Core/Transform/Rewrite/Rule.hs +88/−89
- DDC/Core/Transform/Snip.hs +27/−23
- DDC/Core/Transform/Thread.hs +10/−9
- DDC/Core/Transform/TransformDownX.hs +7/−7
- DDC/Core/Transform/TransformModX.hs +45/−0
- DDC/Core/Transform/TransformUpX.hs +40/−122
- DDC/Core/Transform/Unshare.hs +334/−0
- DDC/Type/Transform/Alpha.hs +4/−2
- DDC/Type/Transform/AnonymizeT.hs +8/−6
- LICENSE +1/−15
- ddc-core-simpl.cabal +30/−22
DDC/Core/Analysis/Arity.hs view
@@ -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
DDC/Core/Analysis/Usage.hs view
@@ -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)
DDC/Core/Simplifier/Apply.hs view
@@ -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++
DDC/Core/Simplifier/Base.hs view
@@ -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"+
DDC/Core/Simplifier/Lexer.hs view
@@ -3,7 +3,6 @@ ( Tok(..) , lexSimplifier) where-import DDC.Data.Token import DDC.Data.SourcePos import Data.Char @@ -11,10 +10,10 @@ lexSimplifier :: (String -> Maybe n) -- ^ Function to read a name. -> String -- ^ String to parse.- -> [Token (Tok n)]+ -> [Located (Tok n)] lexSimplifier readName str- = map (\t -> Token t (SourcePos "<simplifier spec>" 0 0)) + = map (\t -> Located (SourcePos "<simplifier spec>" 0 0) t) $ lexer readName str
DDC/Core/Simplifier/Parser.hs view
@@ -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 "<simplifier spec>" 0 0)+ = let kend = Located (SourcePos "<simplifier spec>" 0 0) KEnd toks = lexSimplifier readName str ++ [kend] in P.runTokenParser show "<simplifier spec>" (pSimplifier details)@@ -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-
DDC/Core/Simplifier/Recipe.hs view
@@ -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
DDC/Core/Simplifier/Result.hs view
@@ -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 ------------------------------------------------------------
DDC/Core/Transform/AnonymizeX.hs view
@@ -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')
DDC/Core/Transform/Beta.hs view
@@ -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
+ DDC/Core/Transform/Boxing.hs view
@@ -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+
DDC/Core/Transform/Bubble.hs view
@@ -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 -------------------------------------------------------------------
DDC/Core/Transform/Elaborate.hs view
@@ -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)
DDC/Core/Transform/Eta.hs view
@@ -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
DDC/Core/Transform/Flatten.hs view
@@ -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
+ DDC/Core/Transform/FoldCase.hs view
@@ -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
DDC/Core/Transform/Forward.hs view
@@ -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
DDC/Core/Transform/Inline.hs view
@@ -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
DDC/Core/Transform/Inline/Templates.hs view
@@ -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
+ DDC/Core/Transform/Lambdas.hs view
@@ -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+
+ DDC/Core/Transform/Lambdas/Base.hs view
@@ -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+
+ DDC/Core/Transform/Lambdas/Lift.hs view
@@ -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+
DDC/Core/Transform/Namify.hs view
@@ -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)
DDC/Core/Transform/Prune.hs view
@@ -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
DDC/Core/Transform/Rewrite.hs view
@@ -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
DDC/Core/Transform/Rewrite/Disjoint.hs view
@@ -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
DDC/Core/Transform/Rewrite/Env.hs view
@@ -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
DDC/Core/Transform/Rewrite/Error.hs view
@@ -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
DDC/Core/Transform/Rewrite/Match.hs view
@@ -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,
DDC/Core/Transform/Rewrite/Parser.hs view
@@ -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
DDC/Core/Transform/Rewrite/Rule.hs view
@@ -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
DDC/Core/Transform/Snip.hs view
@@ -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
DDC/Core/Transform/Thread.hs view
@@ -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
DDC/Core/Transform/TransformDownX.hs view
@@ -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
+ DDC/Core/Transform/TransformModX.hs view
@@ -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+
DDC/Core/Transform/TransformUpX.hs view
@@ -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)
@@ -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+
DDC/Type/Transform/Alpha.hs view
@@ -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)
DDC/Type/Transform/AnonymizeT.hs view
@@ -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)
LICENSE view
@@ -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-
ddc-core-simpl.cabal view
@@ -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--