ddc-core-simpl 0.4.1.3 → 0.4.2.1

raw patch · 33 files changed

+1670/−833 lines, 33 filesdep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, ddc-base, ddc-core, deepseq, mtl

API changes (from Hackage documentation)

Files

• DDC/Core/Analysis/Arity.hs +4/−6
• DDC/Core/Analysis/Usage.hs +24/−24
• DDC/Core/Simplifier/Apply.hs +36/−38
• DDC/Core/Simplifier/Base.hs +34/−24
• DDC/Core/Simplifier/Parser.hs +14/−14
• DDC/Core/Simplifier/Recipe.hs +36/−28
• DDC/Core/Transform/AnonymizeX.hs +0/−6
• DDC/Core/Transform/Beta.hs +13/−48
• DDC/Core/Transform/Boxing.hs +281/−350
• DDC/Core/Transform/Bubble.hs +6/−67
• DDC/Core/Transform/Elaborate.hs +2/−6
• DDC/Core/Transform/Eta.hs +12/−10
• DDC/Core/Transform/Flatten.hs +24/−46
• DDC/Core/Transform/FoldCase.hs +83/−0
• DDC/Core/Transform/Forward.hs +54/−26
• DDC/Core/Transform/Inline.hs +0/−1
• DDC/Core/Transform/Inline/Templates.hs +3/−3
• DDC/Core/Transform/Lambdas.hs +600/−0
• DDC/Core/Transform/Namify.hs +6/−15
• DDC/Core/Transform/Prune.hs +11/−23
• DDC/Core/Transform/Rewrite.hs +4/−21
• DDC/Core/Transform/Rewrite/Disjoint.hs +4/−3
• DDC/Core/Transform/Rewrite/Env.hs +2/−4
• DDC/Core/Transform/Rewrite/Match.hs +3/−5
• DDC/Core/Transform/Rewrite/Parser.hs +8/−8
• DDC/Core/Transform/Rewrite/Rule.hs +11/−12
• DDC/Core/Transform/Snip.hs +7/−11
• DDC/Core/Transform/Thread.hs +2/−3
• DDC/Core/Transform/TransformDownX.hs +5/−5
• DDC/Core/Transform/TransformModX.hs +45/−0
• DDC/Core/Transform/TransformUpX.hs +3/−5
• DDC/Core/Transform/Unshare.hs +311/−0
• ddc-core-simpl.cabal +22/−21

@@ -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@@ -78,10 +76,10 @@          aritiesImports            = catMaybes-         $ [ case arityFromType (typeOfImportSource isrc) of-                Just a  -> Just (BName n (typeOfImportSource isrc), a)+         $ [ case arityFromType (typeOfImportValue isrc) of+                Just a  -> Just (BName n (typeOfImportValue isrc), a)                 Nothing -> Nothing-           | (n, isrc) <- moduleImportTypes mm ]+           | (n, isrc) <- moduleImportValues mm ]      in  emptyArities         `extendsArities` aritiesImports

@@ -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 -----------------------------------------------------------------------@@ -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.@@ -81,19 +90,25 @@ usageModule         (ModuleCore                 { moduleName            = name+                , moduleIsHeader        = isHeader                 , moduleExportTypes     = exportTypes                 , moduleExportValues    = exportValues                 , moduleImportTypes     = importTypes+                , moduleImportCaps      = importCaps                 , moduleImportValues    = importValues+                , moduleImportDataDefs  = importDataDefs                 , moduleDataDefsLocal   = dataDefsLocal                 , moduleBody            = body })   =       ModuleCore                 { moduleName            = name+                , moduleIsHeader        = isHeader                 , moduleExportTypes     = exportTypes                 , moduleExportValues    = exportValues                 , moduleImportTypes     = importTypes+                , moduleImportCaps      = importCaps                 , moduleImportValues    = importValues+                , moduleImportDataDefs  = importDataDefs                 , moduleDataDefsLocal   = dataDefsLocal                 , moduleBody            = usageX body } @@ -128,7 +143,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@@ -137,7 +153,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@@ -160,7 +177,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@@ -212,12 +231,9 @@         LPrivate b mt bs           -> (empty, LPrivate b mt bs) -        LWithRegion b-         -> (empty, LWithRegion b) - -- | Annotate binding occurrences of named value variables with ---  usage information.+--   usage information. usageCast           :: Ord n         => Cast a n@@ -227,20 +243,10 @@         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')-         CastBox         -> (empty, CastBox)         CastRun         -> (empty, CastRun) @@ -277,12 +283,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)

@@ -12,22 +12,26 @@ 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.Bubble+import DDC.Core.Transform.Elaborate import DDC.Core.Transform.Eta           as Eta-import DDC.Core.Transform.Prune+import DDC.Core.Transform.Flatten import DDC.Core.Transform.Forward       as Forward-import DDC.Core.Transform.Bubble import DDC.Core.Transform.Inline+import DDC.Core.Transform.Lambdas import DDC.Core.Transform.Namify+import DDC.Core.Transform.Prune import DDC.Core.Transform.Rewrite-import DDC.Core.Transform.Elaborate+import DDC.Core.Transform.Snip          as Snip+import DDC.Core.Transform.FoldCase      as FoldCase import DDC.Type.Env                     (KindEnv, TypeEnv) import Data.Typeable                    (Typeable) import Control.Monad.State.Strict+import DDC.Base.Name import qualified DDC.Base.Pretty        as P import qualified Data.Set               as Set+import Prelude                          hiding ((<$>))   -- Modules --------------------------------------------------------------------@@ -36,7 +40,7 @@ --   The state monad can be used by `Namifier` functions to generate fresh names. -- applySimplifier -        :: (Show a, Ord n, Show n, Pretty n) +        :: (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@@ -82,7 +86,7 @@  -- | Apply a transform until it stops progressing, or a maximum number of times applyFixpoint-        :: (Show a, Ord n, Show n, Pretty n)+        :: (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@@ -122,7 +126,7 @@  -- | Apply a transform to a module. applyTransform-        :: (Show a, Ord n, Show n, Pretty n)+        :: (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@@ -134,26 +138,24 @@  = let  res x = return $ resultDone (show $ ppr spec) x    in case spec of         Id               -> res mm-        Anonymize        -> res $ anonymizeX mm-        Snip config      -> res $ snip config mm-        Flatten          -> res $ flatten mm--        Beta config      -         -> return $ betaReduce    profile config mm--        Eta  config      -         -> return $ Eta.etaModule profile config 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 $ forwardModule profile config mm -        Bubble           -> res $ bubbleModule mm+        FoldCase config  -> res    $ foldCase config mm+        Inline getDef    -> res    $ inline getDef Set.empty mm+        Lambdas          -> res    $ lambdasModule profile mm         Namify namK namT -> namifyUnique namK namT mm >>= res-        Inline getDef    -> res $ inline getDef Set.empty mm-        Rewrite rules    -> res $ rewriteModule rules mm-        Prune            -> res $ pruneModule profile mm-        Elaborate        -> res $ elaborateModule mm+        Prune            -> res    $ pruneModule profile mm+        Rewrite rules    -> res    $ rewriteModule rules mm+        Snip config      -> res    $ snip config mm   -- Expressions ----------------------------------------------------------------@@ -162,7 +164,7 @@ --   The state monad can be used by `Namifier` functions to generate fresh names. -- applySimplifierX -        :: (Show a, Show n, Ord n, Pretty n)+        :: (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@@ -208,7 +210,7 @@  -- | Apply a simplifier until it stops progressing, or a maximum number of times applyFixpointX-        :: (Show a, Show n, Ord n, Pretty n)+        :: (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@@ -288,25 +290,21 @@    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 kenv tenv xx         Flatten           -> res    $ flatten xx-        Inline  getDef    -> res    $ inline getDef Set.empty xx -        Beta config       -         -> return $ betaReduce profile config xx--        Eta  config       -         -> return $ Eta.etaX   profile config 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 config xx+        Lambdas           -> res    $ xx         Namify  namK namT -> namifyUnique namK namT xx >>= res+        Prune             -> return $ pruneX     profile kenv tenv xx         Rewrite rules     -> return $ rewriteX rules xx-        Elaborate{}       -> res    $ elaborateX xx-    +        Snip config       -> res    $ snip config xx+

@@ -23,7 +23,7 @@ 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 -----------------------------------------------------------------@@ -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,19 @@                   --   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 +137,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"+         

@@ -16,12 +16,13 @@ import qualified DDC.Core.Transform.Snip        as Snip import qualified DDC.Core.Transform.Beta        as Beta import qualified DDC.Core.Transform.Eta         as Eta+import qualified DDC.Core.Transform.FoldCase    as FoldCase import qualified DDC.Base.Parser                as P import qualified 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 +41,7 @@         , simplifierTemplates           :: [Module a n] }  --------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------- -- | A parser of simplifier specifications. type Parser n a         = P.Parser (Tok n) a@@ -192,21 +193,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 +233,4 @@ pModuleName = P.pTokMaybe f  where  f (KCon n) = Just $ ModuleName [n]         f _        = Nothing- 

@@ -4,15 +4,16 @@         ( -- * Atomic recipies           idsimp         , anonymize-        , snip-        , snipOver-        , flatten         , beta         , betaLets-        , prune-        , forward         , bubble         , elaborate+        , flatten+        , forward+        , lambdas+        , snip+        , snipOver+        , prune            -- * Compound recipies         , anormalize@@ -39,50 +40,57 @@ anonymize = Trans Anonymize  --- | Introduce let-bindings for nested applications.-snip      :: Simplifier s a n-snip      = Trans (Snip Snip.configZero)+-- | Perform beta reduction+beta    :: Simplifier s a n+beta    = Trans (Beta Beta.configZero)  --- | Introduce let-bindings for nested applications.-snipOver  :: Simplifier s a n-snipOver  = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True })+-- | Perform beta reduction, introducing let-expressions for compound arguments.+betaLets :: Simplifier s a n+betaLets = Trans (Beta Beta.configZero { Beta.configBindRedexes = True })  +-- | Float casts outwards.+bubble   :: Simplifier s a n+bubble   = Trans Bubble+++-- | Elaborate possible Const and Distinct witnesses that aren't+--   otherwise in the program.+elaborate :: Simplifier s a n+elaborate = Trans Elaborate++ -- | 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)+-- | Float single-use bindings forward into their use sites.+forward  :: Simplifier s a n+forward  = Trans Forward  --- | Perform beta reduction, introducing let-expressions for compound arguments.-betaLets :: Simplifier s a n-betaLets = Trans (Beta Beta.configZero { Beta.configBindRedexes = True })+-- | 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+prune    = Trans Prune  --- | Float single-use bindings forward into their use sites.-forward  :: Simplifier s a n-forward  = Trans Forward+-- | Introduce let-bindings for nested applications.+snip      :: Simplifier s a n+snip      = Trans (Snip Snip.configZero)  --- | Float casts outwards.-bubble   :: Simplifier s a n-bubble   = Trans Bubble+-- | Introduce let-bindings for nested applications.+snipOver  :: Simplifier s a n+snipOver  = Trans (Snip Snip.configZero { Snip.configSnipOverApplied = True })  --- | Elaborate possible Const and Distinct witnesses that aren't---   otherwise in the program.-elaborate :: Simplifier s a n-elaborate = Trans Elaborate   -- Compound -------------------------------------------------------------------

@@ -89,9 +89,7 @@   = 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)         CastBox                 -> CastBox         CastRun                 -> CastRun @@ -120,7 +118,6 @@         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)  @@ -201,7 +198,4 @@          -> let (kstack', b')   = mapAccumL pushAnonymizeBindT kstack b                 (tstack', bs')  = pushAnonymizeBindXs keep kstack' tstack bs             in  (kstack', tstack', LPrivate b' mt bs')--        LWithRegion{}-         -> (kstack, tstack, lts) 

@@ -8,22 +8,18 @@         , betaReduce) where import DDC.Base.Pretty-import DDC.Core.Collect-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Core.Fragment-import DDC.Core.Predicates 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                     (KindEnv, TypeEnv)-import DDC.Type.Compounds import qualified DDC.Type.Env           as Env-import qualified Data.Set               as Set+import Prelude                          hiding ((<$>))   -------------------------------------------------------------------------------@@ -133,67 +129,36 @@         -> Exp a n      -- ^ Expression to transform.         -> Writer Info (Exp a n) -betaReduce1 profile config _kenv tenv xx+betaReduce1 _profile config _kenv _tenv xx  = let  ret info x = tell info >> return x -        -- If we're using closure types then when we perform a beta-reduction:-        --  (\v. X1) X2 => X1[X2/v] then we need to weaken the closure if the -        -- body expression X1 does not reference 'v'.-        weakenClosure a usesBind fvs2 xWeak x-         | featuresTrackedClosures $ profileFeatures profile -         , not (usesBind || Set.null fvs2)-         = XCast a (CastWeakenClosure [xWeak]) x--         | otherwise-         = 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 a2 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}-                 $ weakenClosure a usesBind fvs2 (XType a2 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 a2 w2)-         -> let usesBind        = any (flip boundMatchesBind b11)-                                $ Set.toList $ freeX tenv x12-                fvs2            = freeX Env.empty w2-            in  ret mempty { infoWits = 1 }-                 $ weakenClosure a usesBind fvs2 (XWitness a2 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 }-                 $ weakenClosure a usesBind fvs2 x2-                 $ substituteXX b11 x2 x12+         -> ret mempty { infoValues = 1 }+              $ substituteXX b11 x2 x12           | configBindRedexes config          -> ret mempty { infoValuesLetted  = 1 }

@@ -1,49 +1,5 @@ -- | Manage representation of numeric values in a module. -----   We use three seprate versions of each numeric type.---      Nat#            Numeric index type.---      B# Nat#         Boxed representation type.---      U# Nat#         Unboxed representation type.------   A numeric index type is the type of pure values like 23#, where "pure value"---   means the mathematical value, free from any considerations about how that ---   might be represented at runtime in the physical machine.------   The Boxed and Unboxed representation types commit to a specific runtime---   representation, and have implications for runtime performance and space ---   usage of the compiled program.------   The boxing transform takes an input program using just pure values and---   numeric index types, and refines it to a program that commits to particular---   representations of those values. In particular, we commit to a particular---   representation for function arguments and results, which makes the program---   adhere to a function calling convention that follow-on transformations---   to lower level languages (like Core Salt) can deal with.------   This Boxing transform should do  just enough to make the code well-formed---   with respect to runtime representation. Demand-driven optimisations like---   local unboxing should be done in follow-on transformations.------   We make the following representation commitments, so that the default---   representation is boxed.------   Literal values are wrapped into their boxed representation:---        23# ---     => convert# [B# Nat#] [Nat#] 23#------   Use unboxed versions of primitive operators:---        add# [Nat#] x y ---     => convert# [B# Nat#] [U# Nat#] ---                 (add# [U# Nat#] (convert# [U# Nat#] [B# Nat#] x)---                                 (convert# [U# Nat#] [B# Nat#] y))------   Case scrutinees are unwrapped when matching against literal patterns:---        case x of { 0# -> ... }---     => case convert [B# Nat#] [Nat#] x of { 0# -> ... }------   After performing this transformation the program is said---   to "use representational types", or be in "representational form".--- --  [Note: Boxing and Partial Application] --  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --  Unlike in Haskell, we do not allow explictly unboxed types in the source@@ -60,58 +16,40 @@ module DDC.Core.Transform.Boxing         ( Rep           (..)         , Config        (..)-        , Boxing        (..))+        , boxingModule) where-import DDC.Core.Compounds import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot+import DDC.Core.Pretty import DDC.Type.Transform.Instantiate-import DDC.Type.DataDef-import Control.Monad+import Data.Maybe   --------------------------------------------------------------------------------------------------- -- | Representation of the values of some type. data Rep-        -- | Values of this type cannot be directly represented in the target-        --   language. We need to use a boxed or unboxed representation instead.+        -- | These types don't contain any values.         = RepNone -        -- | Type is represented in boxed form,-        --   and thus can instantiate polymorphic types.-        | RepBoxed     +        -- | Values of this type are uncomitted to a particular representation,+        --   they just describe a set of logical values.+        | RepBoxed -        -- | Type is represented in unboxed form,-        --   and thus cannot instantiate polymorphic types.+        -- | Values of this type are represented in unboxed form.         | RepUnboxed         deriving (Eq, Ord, Show)   data Config a n         = Config-        { -- | Values of this type needs boxing to make the program-          --   representational. This will only be passed types of kind Data.-          configIsValueIndexType        :: Type n -> Bool--          -- | Check if this is a boxed representation type.-        , configIsBoxedType             :: Type n -> Bool--          -- | Check if this is an unboxed representation type.-        , configIsUnboxedType           :: Type n -> Bool--          -- | Get the boxed version of some data type, if any.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configBoxedOfIndexType        :: Type n -> Maybe (Type n) --          -- | Get the unboxed version of some data type, if any.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configUnboxedOfIndexType      :: Type n -> Maybe (Type n) +        { -- | Get the representation of this type.+          configRepOfType               :: Type n -> Maybe Rep -          -- | Take the index type from a boxed type, if it is one.-        , configIndexTypeOfBoxed        :: Type n -> Maybe (Type n)+          -- | Get the type for a different representation of the given one.+        , configConvertRepType          :: Rep -> Type n -> Maybe (Type n) -          -- | Take the index type from an unboxed type, if it is one.-        , configIndexTypeOfUnboxed      :: 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)@@ -124,336 +62,329 @@           --   The function can be polymorphic, but must have a prenex rank-1 type.         , configValueTypeOfForeignName  :: n -> Maybe (Type n) -          -- | Check if the primop with this name works on unboxed values-          --   directly. Operators where this function returns False are assumed-          --   to take boxed values for every argument.-        , configNameIsUnboxedOp         :: n -> Bool --          -- | Wrap a value of the given index type.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configBoxedOfValue    :: a -> Exp a n -> Type n -> Maybe (Exp a n) --          -- | Unwrap a boxed value of the given index type.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configValueOfBoxed    :: a -> Exp a n -> Type n -> Maybe (Exp a n)--          -- | Box an unboxed value of the given index type.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configBoxedOfUnboxed  :: a -> Exp a n -> Type n -> Maybe (Exp a n)--          -- | Unbox a boxed value of the given index type.-          --   This will only be passed types where typeNeedsBoxing returns True.-        , configUnboxedOfBoxed  :: a -> Exp a n -> Type n -> Maybe (Exp a n) }-+          -- | Convert a literal name to its unboxed version.+        , configUnboxLitName            :: n -> Maybe n -----------------------------------------------------------------------------------------------------class Boxing (c :: * -> * -> *) where- -- | Rewrite a module to use explitit boxed and unboxed types.- boxing :: (Show n, Show a, Ord n)-        => Config a n-        -> c a n-        -> c a n+          -- | Covnert a primop name to its unboxed version.+        , configUnboxPrimOpName         :: n -> Maybe n+        }   -- Module ------------------------------------------------------------------------------------------instance Boxing Module where- boxing config mm-  = let -        -- Handle boxing in the types of exported values.-        exportValues'-         = map (boxingExportValue config) $ moduleExportValues mm-         -        -- Handle boxing in the types of imported values.-        importValues'-         = map (boxingImportValue config) $ moduleImportValues mm+-- | Manage boxing in a module.+boxingModule +        :: (Show a, Show n, Pretty n, Ord n) +        => Config a n -> Module a n -> Module a n -        -- Add locally imported foreign functions to the foreign function detector.-        --  We want the original type here, before it has been passed through-        --  the boxing transform.-        typeOfForeignName n-         -- The provided config already says this is foreign.-         | Just t       <- configValueTypeOfForeignName config n  -         = Just t+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 -         -- This is a locally imported C function.-         | Just (ImportSourceSea _ t)-                        <- lookup n (moduleImportValues mm)  -         = Just t+        -- 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 -         | otherwise-         = Nothing+   in   mm { moduleBody         +              = boxingX config (moduleBody mm) -        -- Use our new foreign function detector in the config.-        config'-         = config-         { configValueTypeOfForeignName  = typeOfForeignName }+           , moduleExportValues +              = [(n, boxingExport expt) | (n, expt) <- moduleExportValues mm ] -        -- Do the boxing transform.-    in  mm  { moduleBody            = boxing config' (moduleBody mm) -            , moduleExportValues    = exportValues'-            , moduleImportValues    = importValues'-            , moduleDataDefsLocal   = map (boxingDataDef config') (moduleDataDefsLocal mm) }+           , moduleImportValues +              = [(n, boxingImport impt) | (n, impt) <- moduleImportValues mm ] }  --- | Manage boxing in the type of an exported value.-boxingExportValue-        :: Config a n-        -> (n, ExportSource n)-        -> (n, ExportSource n)+boxingX config xx+ = case xx of -boxingExportValue config (n, esrc)- = case esrc of-        ExportSourceLocal n' t-         -> (n, ExportSourceLocal n' (boxingT config t))+        -- Convert literals to their unboxed form, followed by a boxing conversion.+        XCon a (DaConPrim n tLit)+         | Just RepBoxed        <- configRepOfType config tLit+         -> let Just tLitU      = configConvertRepType config RepUnboxed tLit+                Just nU         = configUnboxLitName   config n -        ExportSourceLocalNoType{}-         -> (n, esrc)+                Just xLit       = configConvertRepExp  config RepBoxed a tLitU +                                $ XCon a (DaConPrim nU tLitU)+           in   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' --- | Manage boxing in the type of an imported value.-boxingImportValue -        :: Config a n-        -> (n, ImportSource n)-        -> (n, ImportSource n)+        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' -boxingImportValue config (n, isrc)- = case isrc of-        -- This shouldn't happen for values, but just pass it through.-        ImportSourceAbstract _-         -> (n, isrc)+        -- 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' -        -- Function imported from a DDC compiled module.-        ImportSourceModule mn n' t-         -> (n, ImportSourceModule mn n' (boxingT config t)) -        -- Value imported using the standard C calling convention.-        ImportSourceSea str t-         -> (n, ImportSourceSea str (boxingSeaT config t))+        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 --- Exp ---------------------------------------------------------------------------------------------instance Boxing Exp where- boxing config xx-  = let down = boxing config-    in case xx of+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 -        -- Convert literals to their boxed representations.-        XCon a dc-         |  Just dcn    <- takeNameOfDaCon dc-         ,  Just tLit   <- configValueTypeOfLitName config dcn-         ,  configIsValueIndexType config tLit-         ,  Just xx'    <- configBoxedOfValue  config a xx tLit-         -> xx'+boxingAlt config alt+ = case alt of+        AAlt p x        -> AAlt p (boxingX config x) -        -- When applying a primop that works on unboxed values, -        -- unbox its arguments and then rebox the result.-        XApp a x1 x2-         -- Split the application of a primop into its name and arguments.-         -- The arguments here include type arguments as well.-         | Just (xFn, tPrim, xsArgsAll) -                <- splitUnboxedOpApp config xx-         -> let -                -- Split off the type arguments.-                (asArgs, tsArgs) = unzip $ [(a', t) | XType a' t <- xsArgsAll]-                -                -- For each type argument, if we know how to create the unboxed version-                -- then do so. If this is wrong then the type checker will catch it later.-                getTypeUnboxed t-                 | Just t'      <- configUnboxedOfIndexType config t  -                                = t'                -                 | otherwise    = t  -                tsArgsUnboxed   = map getTypeUnboxed tsArgs-                -                -- Instantiate the type to work out which arguments need to be unboxed,-                -- and which we can leave as-is. -                Just tPrimInstUnboxed   = instantiateTs tPrim tsArgsUnboxed-                (tsArgsInstUnboxed, tResultInstUnboxed)-                                        = takeTFunArgResult tPrimInstUnboxed+---------------------------------------------------------------------------------------------------+-- | 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, Pretty n, Show a, Show 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 -                -- Unboxing arguments to the function.-                xsArgs  = drop (length tsArgs) xsArgsAll+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 -            in if -- 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.-                  not (length xsArgs == length tsArgsInstUnboxed)-                   then XApp a (down x1) (down x2)+        -- Get the boxed version of the types of parameters and return value.+        tPrimBoxedInst   <- instantiateTs tPrimBoxed tsArgs+        let (tsParamBoxed, _tResultBoxed) +                        = takeTFunArgResult tPrimBoxedInst -                   -- We got a type for each argument, so the primop is fully applied-                   -- and we can do the boxing/unboxing transform.-                   else let xsArgs' -                             = [ unboxExp config a tArgInst (down xArg)-                                  | xArg      <- xsArgs-                                  | tArgInst  <- tsArgsInstUnboxed ]-                        in  boxExp config a tResultInstUnboxed-                                $ xApps a xFn  (  [XType a' t  | t  <- tsArgsUnboxed-                                                        | a' <- asArgs]-                                                ++ xsArgs')+        -- Get the unboxed version of the types of parameters and return value.+        tPrimUnboxedInst <- instantiateTs tPrimUnboxed tsArgs+        let (tsParamUnboxed, tResultUnboxed)+                        = takeTFunArgResult tPrimUnboxedInst -        -- Unrap scrutinees when matching against literal patterns.-        XCase a xScrut alts-         | p : _        <- [ p  | AAlt (PData p@DaConPrim{} []) _ <- alts]-         , Just tLit    <- configValueTypeOfLitName config (daConName p)-         , configIsValueIndexType config tLit-         , Just xScrut' <- configValueOfBoxed  config a (down xScrut) tLit-         -> XCase a xScrut' (map down alts)+        -- 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 -        -- Boilerplate-        XVar{}          -> xx-        XCon{}          -> xx-        XLAM a b x      -> XLAM  a b (down x)-        XLam a b x      -> XLam  a (boxingB config b) (down x)-        XApp a x1 x2    -> XApp  a (down x1)  (down x2)-        XLet a lts x    -> XLet  a (down lts) (down x)-        XCase a x alts  -> XCase a (down x)   (map down alts)-        XCast a c x     -> XCast a c (down x)-        XType a t       -> XType a (boxingT config t)-        XWitness{}      -> xx+        -- 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 ] --- | Box an expression that produces a value.-boxExp :: Config a n -> a -> Type n -> Exp a n -> Exp a n-boxExp config a t xx-        | configIsValueIndexType config t-        , Just x'      <- configBoxedOfUnboxed config a xx t-        = x'+        -- 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 -        | configIsUnboxedType config t-        , Just tIdx    <- configIndexTypeOfUnboxed config t-        , Just x'      <- configBoxedOfUnboxed config a xx tIdx-        = x'+        let xResultV =  fromMaybe xResultRunU+                     $  configConvertRepExp config RepBoxed a tResultUnboxed' xResultRunU -        | otherwise-        = xx+        return xResultV  --- | Unbox an expression that produces a boxed value.-unboxExp :: Config a n -> a -> Type n -> Exp a n -> Exp a n-unboxExp config a t xx-        | configIsValueIndexType config t-        , Just x'      <- configUnboxedOfBoxed     config a xx t-        = x'+---------------------------------------------------------------------------------------------------+-- Marshall arguments and return values of foreign imported functions.+-- +-- * Assumes that the type of the imported thing is in prenex form.+--+boxingForeignSea+        :: (Ord n, Pretty 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 -        | configIsUnboxedType config t-        , Just tIdx    <- configIndexTypeOfUnboxed config t-        , Just x'      <- configUnboxedOfBoxed     config a xx tIdx-        = x'+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 -        | otherwise-        = xx+        -- 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 ()) --- | If this is an application of some primitive operator or foreign function that ---   works on unboxed values then split it into the function and arguments.------   The arguments returned include type arguments as well.-splitUnboxedOpApp-        :: Config a n-        -> Exp a n -        -> Maybe (Exp a n, Type n, [Exp a n])+        -- For each argument, if it has an unboxed representation then unbox it.+        let unboxArg xArg tArg +             = fromMaybe xArg+             $ configConvertRepExp config RepUnboxed a tArg xArg -splitUnboxedOpApp config xx- = case xx of-        XApp{}-         | Just (n, xsArgsAll)  <- takeXPrimApps xx-         , Just (xFn, _)        <- takeXApps     xx-         , configNameIsUnboxedOp config n-         , Just tPrim           <- configValueTypeOfPrimOpName config n-         -> Just (xFn, tPrim, xsArgsAll)+        let xsArgValU = zipWith unboxArg xsArgVal tsArgVal+        let xExpU     = xApps a xFn ([XType a t | t <- tsArgType] ++ xsArgValU) -        XApp{}-         | Just (xFn@(XVar _ (UName n)), xsArgsAll)-                                <- takeXApps xx-         , Just tForeign        <- configValueTypeOfForeignName config n-         -> Just (xFn, tForeign, xsArgsAll)+        -- 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 -        _ -> Nothing+        return $ boxResult tResult xExpU  --- Lets --------------------------------------------------------------------------------------------instance Boxing Lets where- boxing config lts-  = let down    = boxing config-    in case lts of-        LLet b x-         -> let b'      = boxingB config b-                x'      = down x-            in  LLet b' x'+-- | Marshall arguments and return values for function imported from Sea land.+boxingForeignSeaType+        :: Config a n -> Type n -> Type n -        LRec bxs-         -> let bxs'    = [(boxingB config b, down x) -                                | (b, x) <- bxs]-            in  LRec bxs'+boxingForeignSeaType config tForeign+ = let  +        -- Split the type into quantifiers, parameter and result types.+        (bsForall, tBody) +                 = fromMaybe ([], tForeign)+                 $ takeTForalls tForeign -        LPrivate{}      -> lts-        LWithRegion{}   -> lts+        (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 --- Alt ---------------------------------------------------------------------------------------------instance Boxing Alt where- boxing config alt-  = case alt of-        AAlt PDefault x -         -> AAlt PDefault (boxing config x)+        tsParamU    = map unboxType tsParam+        tResultU    = unboxType tResult -        AAlt (PData dc bs) x-         -> AAlt (PData dc (map (boxingB config) bs)) (boxing config x)+        -- Build the converted type back out of its parts.+        Just tBodyU = tFunOfList (tsParamU ++ [tResultU])+        tForeignU   = foldr TForall tBodyU bsForall +   in   tForeignU + ------------------------------------------------------------------------------------------------------ | Manage boxing in a Bind.-boxingB :: Config a n -> Bind n -> Bind n-boxingB config bb- = case bb of-        BAnon t         -> BAnon   (boxingT config t)-        BName n t       -> BName n (boxingT config t)-        BNone t         -> BNone   (boxingT config t)+-- 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) --- | Manage boxing in a Type.-boxingT :: Config a n -> Type n -> Type n-boxingT config tt-  | configIsValueIndexType config tt-  , Just tResult        <- configBoxedOfIndexType config tt-  = tResult+        unboxAlt alt@(AAlt PDefault _) = Just alt+        unboxAlt _                     = Nothing -  | otherwise-  = let down = boxingT config-    in case tt of-        TVar{}          -> tt-        TCon{}          -> tt-        TForall b t     -> TForall b (down t)-        TApp t1 t2      -> TApp (down t1) (down t2)-        TSum{}          -> tt+        Just alts_unboxed+         = sequence $ map unboxAlt alts +        Just xScrut'    = configConvertRepExp config RepUnboxed a tLit1 xScrut+        alts_default    = ensureDefault alts_unboxed --- | Manage boxing in the type of a C value.-boxingSeaT :: Config a n -> Type n -> Type n-boxingSeaT config tt-  | configIsValueIndexType config tt-  , Just tResult        <- configUnboxedOfIndexType config tt-  = tResult+  in    XCase a xScrut' $ alts_default -  | otherwise-  = let down = boxingSeaT config-    in case tt of-        TVar{}          -> tt-        TCon{}          -> tt-        TForall b t     -> TForall b (down t)-        TApp t1 t2      -> TApp (down t1) (down t2)-        TSum{}          -> tt --- | Manage boxing in a data type definition.-boxingDataDef :: Config a n -> DataDef n -> DataDef n-boxingDataDef config def@DataDef{}-        = def { dataDefCtors = liftM (map (boxingDataCtor config)) (dataDefCtors def) }+-- | 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] --- | Manage boxing in a data constructor definition.-boxingDataCtor :: Config a n -> DataCtor n -> DataCtor n    -boxingDataCtor config ctor@DataCtor{}-        = ctor -        { dataCtorFieldTypes   = map (boxingT config) (dataCtorFieldTypes ctor)-        , dataCtorResultType   = boxingT config (dataCtorResultType ctor) }+        | otherwise+        = alts+

@@ -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@@ -142,8 +140,8 @@              in  ([], LRec bxs') -        LPrivate{}              -> ([], lts)-        LWithRegion{}           -> ([], lts)+        LPrivate{}+         -> ([], lts)   instance Bubble Alt where@@ -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 a (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 -------------------------------------------------------------------

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

@@ -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 qualified DDC.Type.Env   as Env+import Prelude                  hiding ((<$>))   -------------------------------------------------------------------------------@@ -134,7 +134,7 @@  ------------------------------------------------------------------------------- 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.@@ -219,8 +219,8 @@                           $  map snd bxs                 return    $ LRec (zip bs xs') -        LPrivate{}      -> return lts-        LWithRegion{}   -> return lts+        LPrivate{}+         -> return lts   instance Eta Alt where@@ -243,7 +243,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' 

@@ -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 (LPrivate b2 mt 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 (LPrivate b2 mt bs2) -      $ flatten1-      $ XLet a1 (LLet (zapX b1) x2) -             x1'-- -- Flatten single-alt case expressions. -- @ --     let b1 = case x1 of @@ -144,13 +132,3 @@    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

@@ -0,0 +1,83 @@++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, [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

@@ -9,21 +9,20 @@ where import DDC.Base.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 Data.Typeable import qualified Data.Map                               as Map 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@@ -131,20 +131,26 @@  forwardWith profile config bindings          (ModuleCore                 { moduleName            = name+                , moduleIsHeader        = isHeader                 , moduleExportTypes     = exportTypes                 , moduleExportValues    = exportValues                 , moduleImportTypes     = importTypes+                , moduleImportCaps      = importCaps                 , moduleImportValues    = importValues+                , moduleImportDataDefs  = importDataDefs                 , moduleDataDefsLocal   = dataDefsLocal                 , 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                 , moduleDataDefsLocal   = dataDefsLocal                 , moduleBody            = body' } @@ -175,18 +181,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@@ -205,20 +222,34 @@                         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) @@ -235,13 +266,10 @@   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)         CastBox                 -> return $ CastBox         CastRun                 -> return $ CastRun @@ -260,8 +288,8 @@                           return (b, x'))              bxs -        LPrivate b mt bs -> return $ LPrivate b mt bs-        LWithRegion b    -> return $ LWithRegion b+        LPrivate b mt bs+         -> return $ LPrivate b mt bs   instance Forward Alt where

@@ -65,7 +65,6 @@         LLet b x        -> LLet b (enter b x)         LRec bxs        -> LRec [(b, enter b x) | (b, x) <- bxs]         LPrivate{}      -> lts-        LWithRegion{}   -> lts   instance Inline Alt where

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

@@ -0,0 +1,600 @@++module DDC.Core.Transform.Lambdas+        (lambdasModule)+where+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.Collect+import DDC.Base.Pretty+import DDC.Base.Name+import Data.Function+import Data.List+import Data.Set                         (Set)+import Data.Map                         (Map)+import qualified DDC.Core.Check         as Check+import qualified DDC.Type.Env           as Env+import qualified Data.Set               as Set+import qualified Data.Map               as Map+import 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 -> Module a n++lambdasModule profile mm+ = let  +        -- Take the top-level environment of the module.+        defs    = moduleDataDefs mm+        kenv    = moduleKindEnv  mm+        tenv    = moduleTypeEnv  mm+        c       = Context +                        kenv tenv +                        (Env.fromList +                                [BName n t | (n, ImportCapAbstract t) <- moduleImportCaps mm])+                        (CtxTop defs kenv tenv)++        x'      = lambdasLoopX profile c $ moduleBody mm++   in   beautifyModule+         $ mm { moduleBody = x' }+++---------------------------------------------------------------------------------------------------+-- | Result of lambda lifter recursion.+data Result a n+        = Result +           Bool                 -- Whether we've made progress in this pass.+           [(Bind n, Exp a n)]  -- Lifted bindings++instance Ord n => Monoid (Result a n) where+ mempty+  = Result False []+ + mappend (Result p1 lts1) (Result p2 lts2)+  = Result (p1 || p2) (lts1 ++ lts2)+++-- Exp --------------------------------------------------------------------------------------------+lambdasLoopX+         :: (Show n, Show a, Pretty n, Pretty a, CompoundName n, Ord n)+         => Profile n           -- ^ Language profile.+         -> Context a n         -- ^ Enclosing context.+         -> Exp a n             -- ^ Expression to perform lambda lifting on.+         -> Exp a n             --   Replacement expression.+        +lambdasLoopX p c xx+ = let  (xx1, Result progress _)   = lambdasX p c xx+   in   if progress then lambdasLoopX p c xx1+                    else xx1+++-- | Perform a single pass of lambda lifting in an expression.+lambdasX :: (Show n, Show a, Pretty n, Pretty a, CompoundName n, Ord n)+         => Profile n           -- ^ Language profile.+         -> Context a n         -- ^ Enclosing context.+         -> Exp a n             -- ^ Expression to perform lambda lifting on.+         -> ( Exp a n           --   Replacement expression+            , Result a n)       --   Lifter result.+         +lambdasX p c xx+ = case xx of+        XVar{}  -> (xx, mempty)+        XCon{}  -> (xx, mempty)+         +        -- Lift type lambdas to top-level.+        XLAM a b x0+         -> enterLAM c a b x0 $ \c' x+         -> let (x', r)      = lambdasX p c' x+                xx'          = XLAM a b x'+                Result _ bxs = r+                +                -- Decide whether to lift this lambda to top-level.+                -- If there are multiple nested lambdas then we want to lift+                -- the whole group at once, rather than lifting each one +                -- individually.+                liftMe       =  isLiftyContext (contextCtx c)   && null bxs+                +            in if liftMe+                then  let us'   = supportEnvFlags+                                $ support Env.empty Env.empty xx'+                          +                          (xCall, bLifted, xLifted)+                                = liftLambda p c us' a [(True, b)] x'++                      in  ( xCall+                          , Result True (bxs ++ [(bLifted, xLifted)]))++                else (xx', r)+++        -- Lift value lambdas to top-level.+        XLam a b x0+         -> enterLam c a b x0 $ \c' x+         -> let (x', r)      = lambdasX p c' x+                xx'          = XLam a b x'+                Result _ bxs = r+                +                -- Decide whether to lift this lambda to top-level.+                liftMe       =  isLiftyContext (contextCtx c)  && null bxs++            in if liftMe+                then  let us'   = supportEnvFlags+                                $ support Env.empty Env.empty xx'++                          (xCall, bLifted, xLifted)+                                = liftLambda p c us' a [(False, b)] x'+                      +                      in  ( xCall+                          , Result True (bxs ++ [(bLifted, xLifted)]))+                else (xx', r)+++        -- Lift suspensions to top-level.+        --   These behave like zero-arity lambda expressions,+        --   they suspspend evaluation but do not abstract over a value.+        XCast a cc@CastBox x0+         -> enterCastBody c a cc x0 $ \c' x+         -> let (x', r)      = lambdasX p c' x+                xx'          = XCast a CastBox x'+                Result _ bxs = r++                -- Decide whether to lift this box to top-level.+                liftMe       =  isLiftyContext (contextCtx c)  && null bxs++            in if liftMe +                then let us' = supportEnvFlags+                             $ support Env.empty Env.empty xx'++                         (xCall, bLifted, xLifted)+                             = liftLambda p c us' a [] (XCast a CastBox x')++                     in  ( xCall+                         , Result True (bxs ++ [(bLifted, xLifted)]))++                else (xx', r)+++        -- Boilerplate.+        XApp a x1 x2+         -> let (x1', r1)       = enterAppLeft  c a x1 x2 (lambdasX p)+                (x2', r2)       = enterAppRight c a x1 x2 (lambdasX p)+            in  ( XApp a x1' x2'+                , mappend r1 r2)+                +        XLet a lts x+         -> let (lts', r1)      = lambdasLets  p c a x lts +                (x',   r2)      = enterLetBody c a lts x  (lambdasX p)+            in  ( foldr (XLet a) x' lts'+                , mappend r1 r2)+                +        XCase a x alts+         -> let (x',    r1)     = enterCaseScrut c a x alts (lambdasX p)+                (alts', r2)     = lambdasAlts  p c a x [] alts+            in  ( XCase a x' alts'+                , mappend r1 r2)++        XCast a cc x+         ->     lambdasCast p c a cc x+                +        XType{}         -> (xx, mempty)+        XWitness{}      -> (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+        -> ([Lets a n], Result a n)+           +lambdasLets p c a xBody lts+ = case lts of+ +        LLet b x+         -> let (x', r)   = enterLetLLet c a b x xBody (lambdasX p)+            in  ([LLet b x'], r)++        LRec bxs+         | isLiftyContext (contextCtx c)+         -- Some fragments only allow letrecs to bind lambdas.+         -- If all the bindings are lambdas, we can safely convert it to a+         -- sequence of nonrecursive lets, as the recursion will be lifted to the+         -- top level.+         , Just _ <- sequence $ map (takeXLamFlags . snd) bxs+         -> let (bxs', r) = lambdasLetRecLiftAll p c a bxs+            in  (map (uncurry LLet) bxs', r)++         -- If any bindings aren't lambdas, we know the fragment must+         -- allow general recursion in letrecs anyway, and can leave it as a letrec.+         | otherwise+         -> let (bxs', r) = lambdasLetRec p c a [] bxs xBody+            in  ([LRec bxs'], r)+                +        LPrivate{}+         -> ([lts], mempty)+++-- 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+        -> ([(Bind n, Exp a n)], Result a n)++lambdasLetRec _ _ _ _ [] _+        = ([], mempty)++lambdasLetRec p c a bxsAcc ((b, x) : bxsMore) xBody+ = let  (x',   r1) = enterLetLRec  c a bxsAcc b x bxsMore xBody (lambdasX p)++   in   case contextCtx c of++         -- If we're at top-level then drop lifted bindings here.+         CtxTop{}+          -> let  (bxs', Result p2 bxs2) +                        = lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody+                  Result p1 bxsLifted = r1+             in   ( bxsLifted ++ ((b, x') : bxs')+                  , Result (p1 || p2) bxs2 )++         _+          -> let  (bxs', r2) = lambdasLetRec p c a ((b, x') : bxsAcc) bxsMore xBody+             in   ( (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)]+        -> ([(Bind n, Exp a n)], Result a n)++lambdasLetRecLiftAll p c a bxs+ = let +       -- The union of free variables of all the mutually recursive bindings must be used,+       -- as any lifted function may call the other lifted functions.+       us   = Set.unions+            $ map (supportEnvFlags . support Env.empty Env.empty)+            $ map snd bxs++       -- However, the functions we are lifting should not be treated as free variables+       us'  = Set.filter (\(_,bo) -> not $ any (boundMatchesBind bo . fst) bxs)+            $ us++       -- Lift each function with a different context+       lift _before [] = []++       lift before ((b, x) : after)+            = let Just (lams, xx) = takeXLamFlags x+                  c'       = ctx before b x after+                  l'       = liftLambda p c' us' a lams xx+              in (b, l') : lift (before ++ [(b,x)]) after++       ls   = lift [] bxs++       -- The call to each lifted function+       calls = map (\(b,(xC,_,_)) -> (b,xC)) ls++       -- Substitute the original name of the recursive function with a call to its new name,+       -- including passing along any free variables.+       -- Here, we need to unwrap the newly-created lambdas for the free variables,+       -- as capture-avoiding substitution would rename them - the opposite of what we want.+       sub x = case takeXLamFlags x of+                Just (lams, xx) -> makeXLamFlags a lams (substituteXXs calls xx)+                Nothing         ->                       substituteXXs calls x++       -- The result bindings to add at the top-level, with all the new names substituted in+       res  = map (\(_, (_, bL, xL)) -> (bL, sub xL)) ls+   in  (calls, Result True res)++ where+  -- Wrap the context in the letrec+  ctx before b x after+   = enterLetLRec c a before b x after x (\c' _ -> c')+++-- Alts -------------------------------------------------------------------------------------------+-- | Perform lambda lifting in the right of a single alternative.+lambdasAlts +        :: (Show a, Show n, Ord n, Pretty n, Pretty a, CompoundName n)+        => Profile n -> Context a n+        -> a -> Exp a n -> [Alt a n] -> [Alt a n]+        -> ([Alt a n], Result a n)+           +lambdasAlts _ _ _ _ _ []+        = ([], mempty)++lambdasAlts p c a xScrut altsAcc (AAlt w x : altsMore)+ = let  (x', r1)    = enterCaseAlt   c a xScrut altsAcc w x altsMore (lambdasX p)+        (alts', r2) = lambdasAlts  p c a xScrut (AAlt w x' : altsAcc) altsMore+   in   ( AAlt w x' : alts'+        , mappend r1 r2)+++-- 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+        -> (Exp a n, Result a n)++lambdasCast p c a cc x+  = case cc of+        CastWeakenEffect{}    +         -> let (x', r) = enterCastBody c a cc x  (lambdasX p)+            in  ( XCast a cc x', r)++        CastPurify{}+         -> let (x', r) = enterCastBody c a cc x  (lambdasX p)+            in  (XCast a cc x',  r)++        CastBox +         -> let (x', r) = enterCastBody  c a cc x (lambdasX p)+            in  (XCast a cc x',  r)+       +        CastRun +         -> let (x', r)  = enterCastBody c a cc x (lambdasX p)+            in  (XCast a cc x',  r)+++---------------------------------------------------------------------------------------------------+-- | Check if this is a context that we should lift lambda abstractions out of.+isLiftyContext :: Ctx a n -> Bool+isLiftyContext ctx+ = case ctx of+        -- Don't lift out of the top-level context.+        -- There's nowhere else to lift to.+        CtxTop{}        -> False+        CtxLetLLet{}    -> not $ isTopLetCtx ctx+        CtxLetLRec{}    -> not $ isTopLetCtx ctx++        -- Don't lift if we're inside more lambdas.+        --  We want to lift the whole binding group together.+        CtxLAM{}        -> False+        CtxLam{}        -> False+   +        -- We can't do code generation for abstractions in these contexts,+        -- so they need to be lifted.+        CtxAppLeft{}    -> True+        CtxAppRight{}   -> True+        CtxLetBody{}    -> True+        CtxCaseScrut{}  -> True+        CtxCaseAlt{}    -> True+        CtxCastBody{}   -> True+++---------------------------------------------------------------------------------------------------+-- | Construct the call site, and new lifted binding for a lambda lifted+--   abstraction.+liftLambda +        :: (Show a, Show n, Pretty n, Ord n, CompoundName n, Pretty a)+        => Profile n            -- ^ Language profile.+        -> Context a n          -- ^ Context of the original abstraction.+        -> Set (Bool, Bound n)  -- ^ Free variables in the body of the abstraction.+        -> a+        -> [(Bool, Bind n)]     -- ^ The lambdas, and whether they are type or value+        -> Exp a n+        -> (  Exp a n+            , Bind n, Exp a n)++liftLambda p c fusFree a lams xBody+ = let  ctx     = contextCtx c+        kenv    = contextKindEnv c+        tenv    = contextTypeEnv c++        -- The complete abstraction that we're lifting out.+        xLambda         = makeXLamFlags a lams xBody++        -- Name of the enclosing top-level binding.+        Just nTop       = takeTopNameOfCtx ctx++        -- Names of other supers bound at top-level.+        nsSuper         = takeTopLetEnvNamesOfCtx ctx++        -- Name of the new lifted binding.+        nLifted         = extendName nTop ("Lift_" ++ encodeCtx ctx)+        uLifted         = UName nLifted+++        -- Build the type checker configuration for this context.+        (defs, _, _)    = topOfCtx (contextCtx c)        +        config          = Check.configOfProfile p++        config'         = config +                        { Check.configDataDefs+                                = mappend defs (Check.configDataDefs config) ++                        , Check.configGlobalCaps+                                = contextGlobalCaps c }++        -- Function to get the type of an expression in this context.+        -- If there are type errors in the input program then some +        -- either the lambda lifter is broken or some other transform+        -- has messed up.+        typeOfExp x+         = case Check.typeOfExp +                        config' (contextKindEnv c) (contextTypeEnv c)+                        x+            of  Left err+                 -> error $ renderIndent $ vcat+                          [ text "ddc-core-simpl.liftLambda: type error in lifted expression"+                          , ppr err]+                Right t -> t+++        -- Decide whether we want to bind the given variable as a new parameter+        -- on the lifted super. We don't need to bind primitives, other supers,+        -- or any variable bound by the abstraction itself.+        keepVar fu@(_, u)+         | (False, UName n) <- fu      = not $ Set.member n nsSuper+         | (_,     UPrim{}) <- fu      = False+         | any (boundMatchesBind u . snd) lams+                                       = False+         | otherwise                   = True++        fusFree_filtered+                = filter keepVar+                $ Set.toList fusFree+++        -- Join in the types of the free variables.+        joinType (f, u)+         = case f of+            True    | Just t <- Env.lookup u kenv+                    -> ((f, u), t)++            False   | Just t <- Env.lookup u tenv+                    -> ((f, u), t)+                +            _       -> error $ unlines+                        [ "ddc-core-simpl.joinType: cannot find type of free var."+                        , show (f, u) ]++        futsFree_types+                = map joinType fusFree_filtered+++        -- Add in type variables that are free in the types of free value variables.+        -- We need to bind these as well in the new super.+        expandFree ((f, u), t)+         | False <- f   =  [(f, u)]+                        ++ [(True, ut) | ut  <- Set.toList+                                             $  freeVarsT Env.empty t]+         | otherwise    =  [(f, u)]+    +        fusFree_body    =  [(True, ut) | ut  <- Set.toList +                                             $  freeVarsT Env.empty $ typeOfExp xLambda]++        futsFree_expandFree+                =  map joinType+                $  Set.toList $ Set.fromList+                $  (concatMap expandFree $ futsFree_types)+                ++ fusFree_body++        -- Sort free vars so the type variables come out the front.+        futsFree+                = sortBy (compare `on` (not . fst . fst))+                $ futsFree_expandFree+++        -- At the call site, apply all the free variables of the lifted+        -- function as new arguments.    +        makeArg  (True,  u) = XType a (TVar u)+        makeArg  (False, u) = XVar a u+        +        xCall   = xApps a (XVar a uLifted)+                $ map makeArg $ map fst futsFree+++        -- ISSUE #330: Lambda lifter doesn't work with anonymous binders.+        -- For the lifted abstraction, wrap it in new lambdas to bind all of+        -- its free variables. +        makeBind ((True,  (UName n)), t) = (True,  BName n t)+        makeBind ((False, (UName n)), t) = (False, BName n t)+        makeBind fut+                = error $ "ddc-core-simpl.liftLamba: unhandled binder " ++ show fut+        +        -- Make the new super.+        bsParam = map makeBind futsFree++        xLifted = makeXLamFlags a bsParam xLambda+++        -- Get the type of the bound expression, which we need when building+        -- the type of the new super.+        tLifted = typeOfExp xLifted+        bLifted = BName nLifted tLifted+        +    in  ( xCall+        , bLifted, xLifted)+++---------------------------------------------------------------------------------------------------+-- | Beautify the names of lifted lamdba abstractions.+--   The lifter itself names new abstractions after the context they come from.+--   This is an easy way of generating unique names, but the names are too+--   verbose to want to show to users, or put in the symbol table of the+--   resulting binary.+--   +--   The beautifier renames the bindings of lifted abstractions to+--    fun$L0, fun$L1 etc, where 'fun' is the name of the top-level binding+--   it was lifted out of.+--+beautifyModule +        :: forall a n. (Ord n, Show n, CompoundName n)+        => Module a n -> Module a n++beautifyModule mm+ = mm { moduleBody = beautifyX $ moduleBody mm }++ where+  -- If the given binder is for an abstraction that we have lifted, +  -- then produce a new nice name for it.+  makeRenamer +        :: Map n Int -> Bind n +        -> (Map n Int, Maybe (n, (n, Type n)))+  makeRenamer acc b+        | BName n t         <- b+        , Just (nBase, str) <- splitName n+        , isPrefixOf "Lift_" str+        = case Map.lookup nBase acc of+           Nothing  -> ( Map.insert nBase 0 acc+                       , Just (  extendName nBase str+                              , (extendName nBase ("L" ++ show (0 :: Int)), t)))++           Just n'  -> ( Map.insert nBase (n' + 1) acc+                       , Just (  extendName nBase str+                              , (extendName nBase ("L" ++ show (n' + 1)),   t)))++        | otherwise = (acc, Nothing)++  -- Beautify bindings.+  beautifyBXs a bxs+   = let bsRenames   :: [(n, (n, Type n))]+         bsRenames   = catMaybes $ snd+                     $ mapAccumL makeRenamer (Map.empty :: Map n Int)+                     $ map fst bxs++         bxsSubsts   :: [(Bind n, Exp a n)]+         bxsSubsts   =  [ (BName n t, XVar a (UName n'))+                                | (n, (n', t))  <- bsRenames]   ++         renameBind (b, x)+                | BName n t     <- b+                , Just  (n', _) <- lookup n bsRenames+                = (BName n' t, x)+                +                | otherwise = (b, x)+            +     in  map (\(b, x) -> (b, substituteXXs bxsSubsts x))+          $ map renameBind bxs++  -- Beautify bindings in top-level let-expressions.+  beautifyX xx+   = case xx of+        XLet a (LRec bxs) xBody+         -> let bxs'    = beautifyBXs a bxs+            in  XLet a (LRec bxs')  (beautifyX xBody)++        XLet a (LLet b x) xBody+         -> let [(b', x')] = beautifyBXs a [(b, x)]+            in  XLet a (LLet b' x') (beautifyX xBody)++        _ -> xx+

@@ -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,7 +76,8 @@  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@@ -86,7 +87,9 @@                 t'              <- namify tnam' xnam t                 return  $ TForall b' t' -        TApp t1 t2      -> liftM2 TApp (down t1) (down t2)+        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 +108,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)  @@ -149,11 +151,6 @@                 x2'             <- namify tnam' xnam' x2                 return $ XLet a (LPrivate b' mt bs') x2' -        XLet a (LWithRegion u) x2-         -> do  u'              <- rewriteX tnam xnam u-                x2'             <- down x2-                return  $ XLet a (LWithRegion u') x2'-         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)@@ -175,13 +172,7 @@   = 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)         CastBox                 -> return CastBox         CastRun                 -> return CastRun 

@@ -22,16 +22,13 @@ import DDC.Base.Pretty import Data.Typeable import Control.Monad.Writer                     (Writer, runWriter, tell)-import Data.Monoid                              (Monoid, mempty, mappend) 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.Equiv                         as T 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.Type.Env                           as Env+import Prelude                                          hiding ((<$>))   -------------------------------------------------------------------------------@@ -114,8 +111,10 @@ -- deadCodeTrans to actually erase dead bindings. -- transformTypeUsage profile kenv tenv trans xx- = case fst $ checkExp (configOfProfile profile) kenv tenv xx Recon of-        Right (xx1, _, _,_) + = let  config  = configOfProfile profile+        rr      = checkExp config kenv tenv 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'@@ -123,7 +122,7 @@          Left _          -> error $  renderIndent-         $  vcat [ text "ddc-coe-simpl.Prune: core type error" ]+         $  vcat [ text "ddc-core-simpl.Prune: core type error" ]   -------------------------------------------------------------------------------@@ -148,14 +147,13 @@          , 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@@ -163,20 +161,10 @@  where         weakEff antec          = CastWeakenEffect-         $ T.crushEffect+         $ T.crushEffect Env.empty          $ annotEffect antec -        weakClo a x1 -         = CastWeakenClosure-         $ Trim.trimClosures a-                (  (map ((XType a) . 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.@@ -206,7 +194,7 @@  = all contained         $ map T.takeTApps          $ sumList -        $ T.crushEffect eff+        $ T.crushEffect Env.empty eff  where         contained (c : _args)          = case c of

@@ -6,11 +6,10 @@         , rewriteX) where import DDC.Base.Pretty-import DDC.Core.Exp+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,8 +17,7 @@ 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.Core.Transform.BoundX              as L import qualified DDC.Type.Compounds                     as T import qualified Data.Map                               as Map import qualified Data.Set                               as Set@@ -28,6 +26,7 @@ import Control.Monad.Writer (tell, runWriter) import Data.List import Data.Typeable+import Prelude                                          hiding ((<$>))   -- Log ------------------------------------------------------------------------@@ -316,7 +315,7 @@              , ruleConstraints   = constrs              , ruleRight         = rhs              , ruleWeakEff       = eff-             , ruleWeakClo       = clo } +             , ruleWeakClo       = _clo }               = rule             -- Try to find a substitution for the left of the rule.@@ -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@@ -370,17 +364,6 @@  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

@@ -7,8 +7,9 @@ import DDC.Type.Predicates import DDC.Type.Compounds import qualified DDC.Core.Transform.Rewrite.Env as RE+import qualified DDC.Type.Env                   as Env import qualified DDC.Type.Sum                   as Sum-import qualified DDC.Type.Transform.Crush       as TC+import qualified DDC.Type.Equiv                 as TC   -- | Check whether a disjointness property is true in the given@@ -68,8 +69,8 @@         -- The type must have the form "Disjoint e1 e2"         | [TCon (TyConWitness TwConDisjoint), fs, gs] <- takeTApps c         = and [ areDisjoint env g f -                | f <- sumList $ TC.crushEffect fs-                , g <- sumList $ TC.crushEffect gs ]+                | f <- sumList $ TC.crushEffect Env.empty fs+                , g <- sumList $ TC.crushEffect Env.empty gs ]          | otherwise         = False

@@ -16,8 +16,8 @@ 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.Transform.BoundT      as L+import qualified DDC.Core.Transform.BoundX      as L import Data.Maybe (fromMaybe, listToMaybe, isJust)  @@ -103,8 +103,6 @@  = foldl lift' env (map fst bs)  where  lift' e b = insertDef b Nothing (liftValue b e) --extendLets _ env  = env   -- Witnesses ------------------------------------------------------------------

@@ -8,9 +8,9 @@         , match) where import DDC.Core.Exp-import DDC.Type.Transform.Crush import Data.Set                                 (Set) import Data.Map                                 (Map)+import qualified DDC.Type.Env                   as Env import qualified DDC.Type.Sum                   as Sum import qualified DDC.Type.Transform.AnonymizeT  as T import qualified DDC.Core.Transform.AnonymizeX  as T@@ -101,9 +101,7 @@          = 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                 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 $ TE.crushSomeT Env.empty t1+        t2'     = unpackSumT $ TE.crushSomeT Env.empty t2    in case (t1', t2') of         -- Constructor names must be equal.         --

@@ -20,12 +20,12 @@ -} -- | Parse a rewrite rule. pRule   :: Ord n -        => Context -> Parser n (R.RewriteRule P.SourcePos n)+        => Context n -> Parser n (R.RewriteRule P.SourcePos n) pRule c  = do   bs       <- pRuleBinders c         (cs,lhs) <- pRuleCsLhs c         hole     <- pRuleHole c-        pTok (KOp "=")+        pTok KEquals         rhs      <- pExp c          return $ R.mkRewriteRule bs cs lhs hole rhs@@ -44,7 +44,7 @@ -- | Parse many rewrite rules. 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@@ -55,7 +55,7 @@  pRuleBinders          :: Ord n -        => Context -> Parser n [(R.BindMode,Bind n)]+        => Context n -> Parser n [(R.BindMode,Bind n)]  pRuleBinders c  = P.choice@@ -68,7 +68,7 @@  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@@ -84,7 +84,7 @@  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 KUnderscore@@ -103,7 +103,7 @@ -- 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)@@ -113,7 +113,7 @@  pBindersBetween          :: Ord n -        => Context+        => Context n         -> R.BindMode          -> Parser n ()          -> Parser n () 

@@ -17,10 +17,9 @@ 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.Core.Pretty                          () import DDC.Type.Env                             (KindEnv, TypeEnv) import DDC.Base.Pretty@@ -164,7 +163,7 @@ --   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.@@ -183,13 +182,13 @@         mapM_ (checkConstraint config kenv') csSpread          -- Typecheck, spread and annotate with type information-        (lhs', _, _, _)+        (lhs', _, _)                 <- checkExp config kenv' tenv' 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 kenv' tenv' Lhs h                            return $ Just h'                    Nothing -> return Nothing@@ -200,17 +199,17 @@         let lhs_full    = maybe lhs (XApp a lhs) hole          -- Check the full left hand side.-        (lhs_full', tLeft, effLeft, cloLeft)+        (lhs_full', tLeft, effLeft)                 <- checkExp config kenv' tenv' Lhs lhs_full          -- Check the full right hand side.-        (rhs', tRight, effRight, cloRight)+        (rhs', tRight, effRight)                 <- checkExp config kenv' tenv' 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 @@ -280,18 +279,18 @@  -- | Type check the expression on one side of the rule. checkExp -        :: (Ord n, Show n, Pretty n)+        :: (Show a, Ord n, Show n, Pretty n)         => C.Config n          -> KindEnv n    -- ^ Kind environment of expression.         -> TypeEnv n    -- ^ Type environment of expression.         -> 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 fst $ C.checkExp defs kenv tenv xx' C.Recon of+   in  case fst $ C.checkExp defs kenv tenv C.Recon C.DemandNone xx'  of         Left err  -> Left $ ErrorTypeCheck side xx' err         Right rhs -> return rhs 

@@ -7,10 +7,8 @@ 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 DDC.Core.Exp.Annot+import qualified DDC.Core.Transform.BoundX      as L import qualified DDC.Type.Compounds             as T  @@ -134,11 +132,6 @@                 x2'     = snipLetBody config a $ down ars x2             in  XLet a (LPrivate b mt bs) x2' -        -- withregion-        XLet a (LWithRegion b) x2-         -> let x2'     = snipLetBody config a $ down [] x2-            in  XLet a (LWithRegion b) x2'-         -- case         -- Split out non-atomic discriminants into their own bindings.         XCase a e alts@@ -171,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 @@ -339,6 +332,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

@@ -9,9 +9,8 @@         , Config (..)         , injectStateType) where-import DDC.Core.Compounds import DDC.Core.Module-import DDC.Core.Exp+import DDC.Core.Exp.Annot import DDC.Base.Pretty import DDC.Core.Transform.Reannotate import DDC.Core.Check           (AnTEC (..))@@ -406,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

@@ -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.@@ -121,8 +121,8 @@                 xs'          <- mapM (transformDownMX f kenv tenv') xs                 return       $ LRec $ zip bs xs' -        LPrivate{}      -> return xx-        LWithRegion{}   -> return xx+        LPrivate{}+         -> return xx   instance Monad m => TransformDownMX m Alt where

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

@@ -11,15 +11,14 @@         , transformSimpleUpX') where import DDC.Core.Module-import DDC.Core.Exp-import DDC.Core.Compounds+import DDC.Core.Exp.Annot import DDC.Core.Transform.Annotate import DDC.Core.Transform.Deannotate import DDC.Type.Env             (KindEnv, TypeEnv) import Data.Functor.Identity import Control.Monad-import qualified DDC.Type.Env           as Env-import qualified DDC.Core.Exp.Simple    as S+import qualified DDC.Type.Env                   as Env+import qualified DDC.Core.Exp.Simple.Exp        as S   -- | Bottom up rewrite of all core expressions in a thing.@@ -129,7 +128,6 @@                 return       $ LRec $ zip bs xs'          LPrivate{}      -> return xx-        LWithRegion{}   -> return xx   instance Monad m => TransformUpMX m Alt where

@@ -0,0 +1,311 @@++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 +        :: (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 -> (ImportValue 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++        TForall b tBody+         -> do  tBody'   <- addParamsT tBody+                return   $  TForall b tBody'++        TApp{}+         -> case takeTFun tt of+                Nothing -> Just $ tUnit `tFun` tt+                Just _  -> Nothing++        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)+         =>  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   -> fst $ wrapAppX xx tF+                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 (x1, t1) = wrapAtsX xx tF ats+                        (x2, _)  = wrapAppX x1 t1 +                    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 :: Exp (AnTEC a n) n +         -> Type n+         -> (Exp (AnTEC a n) n,   Type n)++wrapAppX xF tF+ = case takeTFun tF of+    Just (_, tResult)+     -> let a   = annotOfExp xF+            aR  = a { annotType = tResult }+            aV  = a { annotType = tF      }+            aU  = a { annotType = tUnit   }+            xF' = mapAnnotOfExp (const aV) xF+        in  ( XApp aR xF' (xUnit aU)+            , tResult)++    Nothing +     -> (xF, tF)+++-- 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 -> ExportSource 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+

@@ -1,5 +1,5 @@ Name:           ddc-core-simpl-Version:        0.4.1.3+Version:        0.4.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -14,21 +14,21 @@  Library   Build-Depends: -        base            >= 4.6 && < 4.8,+        base            >= 4.6 && < 4.9,         array           >= 0.4 && < 0.6,-        deepseq         == 1.3.*,+        deepseq         >= 1.3 && < 1.5,         containers      == 0.5.*,         transformers    == 0.4.*,-        mtl             == 2.2.*,-        ddc-base        == 0.4.1.*,-        ddc-core        == 0.4.1.*+        mtl             == 2.2.1.*,+        ddc-base        == 0.4.2.*,+        ddc-core        == 0.4.2.*    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@@ -36,23 +36,27 @@         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@@ -60,13 +64,12 @@    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.Rewrite.Error -   GHC-options:         -Wall         -fno-warn-orphans@@ -75,18 +78,16 @@         -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--