Generating code now. Buggy code, but first class environments at least produce executables

9 files changed, 295 insertions, 76 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index e57a0fd801..b5b5381445 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -72,6 +72,7 @@ data DumpFlag
    | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output)
    | Opt_D_dump_stg_unarised  -- ^ STG after unarise
    | Opt_D_dump_stg_final     -- ^ Final STG (after stg2stg)
+   | Opt_D_dump_stg_clos_env_share
    | Opt_D_dump_call_arity
    | Opt_D_dump_exitify
    | Opt_D_dump_stranal
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 8f2f60ba17..7e704654a4 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2408,6 +2408,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_stg_unarised)
   , make_ord_flag defGhcFlag "ddump-stg-final"
         (setDumpFlag Opt_D_dump_stg_final)
+  , make_ord_flag defGhcFlag "ddump-stg-clos-env-share"
+        (setDumpFlag Opt_D_dump_stg_clos_env_share)
   , make_dep_flag defGhcFlag "ddump-stg"
         (setDumpFlag Opt_D_dump_stg_from_core)
         "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"
diff --git a/compiler/GHC/Stg/ClosEnvShare.hs b/compiler/GHC/Stg/ClosEnvShare.hs
index 754bafe188..fb73ff6543 100644
--- a/compiler/GHC/Stg/ClosEnvShare.hs
+++ b/compiler/GHC/Stg/ClosEnvShare.hs
@@ -1,20 +1,32 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module GHC.Stg.ClosEnvShare ( stgClosEnvShare ) where
+module GHC.Stg.ClosEnvShare ( stgClosEnvShare, CesLog ) where
 
+import Control.Arrow hiding ((<+>))
+import Data.Semigroup
 import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer.CPS
 
 import GHC.Prelude
+
+import GHC.Core.Multiplicity
+import GHC.Core.Type
 import GHC.Data.FastString
+import GHC.Types.Basic
 import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Unique.Supply
 import GHC.Stg.FVs
 import GHC.Stg.Syntax
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Monad
 
 {-
 *************************************************************************
@@ -24,52 +36,68 @@ Transformation
 *************************************************************************
 -}
 
-type CesAble pass = (XRhsClosure pass ~ DIdSet, BinderP pass ~ Id)
-
 -- | We are sneaky (and inefficient) by annotating with free variables,
 -- performing our transformation and then forgetting annotations here. This
 -- means that we *must* completely traverse every expression to rebuild it
 -- without the *Cg* part.
-stgClosEnvShare :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
+stgClosEnvShare :: UniqSupply -> [StgTopBinding] -> ([StgTopBinding],CesLog)
 stgClosEnvShare us binds = stgClosEnvShare' us (annTopBindingsFreeVars binds)
 
 stgClosEnvShare' :: CesAble pass
-                 => UniqSupply -> [GenStgTopBinding pass] -> [StgTopBinding]
-stgClosEnvShare' us binds = initUs_ us $ mapM stgCesTopBinding binds
+                 => UniqSupply
+                 -> [GenStgTopBinding pass]
+                 -> ([StgTopBinding],CesLog)
+stgClosEnvShare' us binds = runCesM us $ mapM stgCesTopBinding binds
 
 stgCesTopBinding :: CesAble pass
-                 => GenStgTopBinding pass -> UniqSM StgTopBinding
+                 => GenStgTopBinding pass -> CesM StgTopBinding
 stgCesTopBinding (StgTopLifted bind) = StgTopLifted <$> stgTopCesBinding' bind
 stgCesTopBinding (StgTopStringLit i bs) = return (StgTopStringLit i bs)
 
 -- | For now, do not mess with top level binders
-stgTopCesBinding' :: CesAble pass => GenStgBinding pass -> UniqSM StgBinding
+stgTopCesBinding' :: CesAble pass => GenStgBinding pass -> CesM StgBinding
 stgTopCesBinding' (StgNonRec x rhs) = StgNonRec x <$> stgCesRhs rhs
 stgTopCesBinding' (StgRec bs)
   = StgRec <$> mapM (\(x,rhs) -> stgCesRhs rhs >>= \rhs' -> return (x,rhs')) bs
 
--- | Genereate shared environments at binding sites
-stgCesBinding :: CesAble pass
-              => GenStgBinding pass -> UniqSM (StgBinding, [SharedEnvData])
-stgCesBinding (StgNonRec x rhs) =
-  do rhs' <- stgCesRhs rhs
-     return (StgNonRec x rhs', [])
+stgCesBinding :: CesAble pass => GenStgBinding pass -> CesM StgBinding
+stgCesBinding (StgNonRec x rhs) = StgNonRec x <$> stgCesRhs rhs
 stgCesBinding (StgRec bs) =
-  let sharedEnvsData = findSharedEnvs bs in
-    do bs' <- forM bs $ \(x,rhs) ->
-                do rhs' <- stgCesRhs rhs
-                   let rhs'' = unpackSharedEnvs x rhs' sharedEnvsData
-                   return (x,rhs'')
-       return (StgRec bs', sharedEnvsData)
+  StgRec <$> mapM (\(x,rhs) -> (,) x <$> stgCesRhs rhs) bs
+-- stgCesBinding (StgRec bs) =
+--   do sharedEnvsData <- createSEDHorizontal bs
+--      bs' <- forM bs $ \(x,rhs) ->
+--               do rhs' <- stgCesRhs rhs
+--                  let rhs'' = unpackSharedEnvs x rhs' sharedEnvsData
+--                  return (x,rhs'')
+--      return (StgRec bs', sharedEnvsData)
 
-
-stgCesRhs :: CesAble pass => GenStgRhs pass -> UniqSM StgRhs
+stgCesRhs :: CesAble pass => GenStgRhs pass -> CesM StgRhs
 stgCesRhs (StgRhsClosure _ ccs u args body)
   = StgRhsClosure noExtFieldSilent ccs u args <$> stgCesExpr body
 stgCesRhs (StgRhsCon ccs dc args) = return (StgRhsCon ccs dc args)
 stgCesRhs (StgRhsEnv fvs) = return (StgRhsEnv fvs)
 
-stgCesExpr :: CesAble pass => GenStgExpr pass -> UniqSM StgExpr
+-- stgCesExpr :: CesAble pass => GenStgExpr pass -> CesM StgExpr
+-- stgCesExpr expr =
+--   case collectBinderChain expr of
+--     [] -> stgCesExpr' expr
+--     bs -> do sharedEnvsData <- createSEDShallow (collectBinderChain expr)
+--              bindSharedEnvs sharedEnvsData <$> stgCesExpr' expr
+--   where collectBinderChain e =
+--           case e of
+--             (StgLet _ (StgNonRec x rhs) e) -> (x,rhs):collectBinderChain e
+--             (StgLet _ (StgRec bs) e)       -> bs ++ collectBinderChain e
+--             _                              -> []
+
+{-
+TODO: I think that it is better that shared environments are introduced here at
+the beginning of the expression; so an expression can be converted into one that
+introduces a binding. This is different than the way I have it now wherein
+shared environments are pulled out of let-expressions.
+-}
+
+stgCesExpr :: CesAble pass => GenStgExpr pass -> CesM StgExpr
 stgCesExpr (StgApp i args)          = return (StgApp i args)
 stgCesExpr (StgLit l)               = return (StgLit l)
 stgCesExpr (StgConApp dc args tys)  = return (StgConApp dc args tys)
@@ -78,28 +106,91 @@ stgCesExpr (StgCase e id alt_ty alts) =
   do e' <- stgCesExpr e
      alts' <- mapM stgCesAlt alts
      return (StgCase e' id alt_ty alts')
+stgCesExpr (StgLet _ (StgNonRec x (StgRhsClosure fvs ccs u args body)) e) =
+  do body' <- stgCesExpr body
+     e' <- stgCesExpr e
+     env_id <- mkEnvId
+     let sed = SharedEnvData fvs env_id [x]
+     let clos' = StgRhsClosure noExtFieldSilent ccs u args
+                               (unpackSharedEnv sed body')
+     return (bindSharedEnv sed (StgLet noExtFieldSilent (StgNonRec x clos') e'))
 stgCesExpr (StgLet _ b e) =
-  do (b',sharedEnvsData) <- stgCesBinding b
+  do b' <- stgCesBinding b
      e' <- stgCesExpr e
-     bindSharedEnvs sharedEnvsData (StgLet noExtFieldSilent b' e')
+     return (StgLet noExtFieldSilent b' e')
 stgCesExpr (StgLetNoEscape _ b e) =
-  do (b',sharedEnvsData) <- stgCesBinding b
+  do b' <- stgCesBinding b
      e' <- stgCesExpr e
-     bindSharedEnvs sharedEnvsData (StgLetNoEscape noExtFieldSilent b' e')
+     return (StgLetNoEscape noExtFieldSilent b' e')
 stgCesExpr (StgTick t e) = StgTick t <$> stgCesExpr e
 stgCesExpr (StgCaseEnv x args e) = StgCaseEnv x args <$> stgCesExpr e
 
-stgCesAlt :: CesAble pass => GenStgAlt pass -> UniqSM StgAlt
+
+-- collectBinderChain :: CesAble pass
+--                    => GenStgExpr pass -> [(BinderP pass, GenStgRhs pass)]
+-- collectBinderChain e =
+--   case e of
+--     (StgLet _ (StgNonRec x rhs) e) -> (x,rhs):collectBinderChain e
+--     (StgLet _ (StgRec bs) e)       -> bs ++ collectBinderChain e
+--     _                              -> []
+
+stgCesAlt :: CesAble pass => GenStgAlt pass -> CesM StgAlt
 stgCesAlt (acon,args,e) = stgCesExpr e >>= \e' -> return (acon,args,e')
 
 {-
 *************************************************************************
 *                                                                      *
-Data for transformation and analysis
+Data and Monad for transformation and analysis
 *                                                                      *
 *************************************************************************
 -}
 
+type CesAble pass = (XRhsClosure pass ~ DIdSet, BinderP pass ~ Id)
+
+data CesLog
+  = CesLog
+  { num_candidates :: Int
+  , num_shared_env_created :: Int
+  , num_env_too_small_to_share :: Int
+  }
+
+instance Outputable CesLog where
+  ppr log = vcat
+    [ text "Number of sharing candidates (i.e. rhs-closures):"
+      <+> ppr (num_candidates log)
+    , text "Number of shared environments created:"
+      <+> ppr (num_shared_env_created log)
+    , text "Number of environments too small to share:"
+      <+> ppr (num_env_too_small_to_share log)
+    ]
+
+log_num_candidates :: Int -> CesM ()
+log_num_candidates n = CesM . tell $ mempty { num_candidates = n }
+
+log_shared_env_created :: CesM ()
+log_shared_env_created = CesM . tell $ mempty { num_shared_env_created = 1 }
+
+log_env_too_small :: CesM ()
+log_env_too_small = CesM . tell $ mempty { num_env_too_small_to_share = 1 }
+
+instance Semigroup CesLog where
+  (CesLog x0 x1 x2) <> (CesLog y0 y1 y2) = CesLog (x0+y0) (x1+y1) (x2+y2)
+
+instance Monoid CesLog where
+  mempty = CesLog 0 0 0
+
+newtype CesM a
+  = CesM { unwrapCesM :: WriterT CesLog UniqSM a }
+  deriving (Functor, Applicative, Monad)
+
+instance MonadUnique CesM where
+  getUniqueSupplyM = CesM (lift getUniqueSupplyM)
+  getUniqueM = CesM (lift getUniqueM)
+  getUniquesM = CesM (lift getUniquesM)
+
+runCesM :: UniqSupply -> CesM a -> (a,CesLog)
+runCesM us = initUs_ us . runWriterT . unwrapCesM
+
 data SharedEnvData
   = SharedEnvData
   { sed_se  :: DIdSet
@@ -111,44 +202,25 @@ data SharedEnvData
     -- environment
   }
 
-bindSharedEnv :: SharedEnvData -> StgExpr -> UniqSM StgExpr
+bindSharedEnv :: SharedEnvData -> StgExpr -> StgExpr
 bindSharedEnv sed e =
-  mkEnvId >>= \x ->
-    return $ StgLet noExtFieldSilent (StgNonRec x (StgRhsEnv (sed_se sed))) e
-
-bindSharedEnvs :: [SharedEnvData] -> StgExpr -> UniqSM StgExpr
-bindSharedEnvs envs e = foldM (flip bindSharedEnv) e envs
-
-mkEnvId :: UniqSM Id
-mkEnvId = mkIdWithU <$> getUniqueM
-  where mkIdWithU u =
-          mkSysLocal (mkFastString "env")
-                     u
-                     (pprPanic "mkEnvId" $ text s)
-                     (pprPanic "mkEnvId" $ text s)
-        s = "First class environments are untyped; this information should not be needed"
-
-unpackSharedEnv :: Id -> StgRhs -> SharedEnvData -> StgRhs
-unpackSharedEnv id (StgRhsCon _ _ _) sed
-  | elem id (sed_rhs_ids sed)
-  = pprPanic "unpackSharedEnv"
-  $ text "Created a shared environment for a constructor application"
-unpackSharedEnv id (StgRhsEnv _) sed
-  | elem id (sed_rhs_ids sed)
-  = pprPanic "unpackSharedEnv"
-  $ text "Created a shared environment for a shared environment"
-unpackSharedEnv id (StgRhsClosure _ ccs u args e) sed
-  | elem id (sed_rhs_ids sed)
-  = StgRhsClosure noExtFieldSilent ccs u args (StgCaseEnv (sed_binder sed) (sed_se sed) e)
-unpackSharedEnv _ rhs _ = rhs
-
-unpackSharedEnvs :: Id -> StgRhs -> [SharedEnvData] -> StgRhs
-unpackSharedEnvs id rhs seds = foldr (flip (unpackSharedEnv id)) rhs seds
+  StgLet noExtFieldSilent (StgNonRec (sed_binder sed) (StgRhsEnv (sed_se sed))) e
+
+bindSharedEnvs :: [SharedEnvData] -> StgExpr -> StgExpr
+bindSharedEnvs envs e = foldr bindSharedEnv e envs
+
+mkEnvId :: CesM Id
+mkEnvId = mkSysLocalM (mkFastString "env") Many (mkVisFunTyMany (mkNumLitTy 0) (mkNumLitTy 0))
+  -- where s = "First class environments are untyped; this information should not be needed"
+  --       m = pprPanic "mkEnvId" $ text s
+
+unpackSharedEnv :: SharedEnvData -> StgExpr -> StgExpr
+unpackSharedEnv sed = StgCaseEnv (sed_binder sed) (sed_se sed)
 
 {-
 *************************************************************************
 *                                                                      *
-Analysis
+Analyses
 *                                                                      *
 *************************************************************************
 -}
@@ -178,6 +250,92 @@ Analysis
 --   ...
 -- @
 
-findSharedEnvs :: CesAble pass
-               => [(BinderP pass,GenStgRhs pass)] -> [SharedEnvData]
-findSharedEnvs _ = []
+type SharingCandidate = (Id, DIdSet)
+
+-- | Shallow refers to creating shared environments of a block of bindings;
+-- this is in contrast with a depth analysis which looks to shared environments
+-- of closures to be bound within closures
+createSEDShallow :: CesAble pass
+                    => [(BinderP pass,GenStgRhs pass)] -> CesM [SharedEnvData]
+createSEDShallow bs =
+  log_num_candidates (length sharingCandidates) >>
+     -- shareMinimalFVSetCover sharingCandidates
+     needlesslyShared sharingCandidates
+  where sharingCandidates = filter (isEmptyDVarSet . snd)
+                            . map (second getRhsEnv)
+                            $ bs
+
+getRhsEnv :: CesAble pass => GenStgRhs pass -> DIdSet
+getRhsEnv (StgRhsClosure fvs _ _ _ _) = fvs
+getRhsEnv (StgRhsCon _ _ _) = emptyDVarSet
+getRhsEnv (StgRhsEnv _) = emptyDVarSet
+
+-- | shareMinimalFVSetCover finds the minimal amount of shared environments that
+-- cover all of the variables needed. Note that this produces a space
+-- leak. Suppose we have the closures with the following free variable sets:
+--
+--   x1 = { a, b, c, d }
+--   x2 = { a, b }
+--   x3 = { d, e, f }
+--   x4 = { z, a }
+--
+--  We will have the following closure structure generated:
+--
+--   e1 = { a, b, c, d }
+--   e2 = { d, e, f }
+--   e3 = { z, a }
+--
+--   x1 = { e1 }
+--   x2 = { e1 }
+--   x3 = { e2 }
+--   x4 = { e3 }
+--
+-- Since x2 now depends on the variables c and d, there is a space
+-- leak. Additionally, every envrionment is behind an extra indirection. This
+-- latter problem can be solved by removing any shared environment which isn't
+-- pointed to by more than one closure. Thus, the final output will be the
+-- following (still containing the space leak):
+--
+--   e1 = { a, b, c, d }
+--
+--   x1 = { e1 }
+--   x2 = { e1 }
+--   x3 = { d, e, f }
+--   x4 = { z, a }
+shareMinimalFVSetCover :: [SharingCandidate] -> CesM [SharedEnvData]
+shareMinimalFVSetCover cds | length cds < 2 = log_env_too_small >> return []
+shareMinimalFVSetCover cds | otherwise      = concatMapM maybeMkSharedData covering
+  where fvSets   = map snd cds
+        totalFVs = unionDVarSets fvSets
+        covering = greedyCover totalFVs []
+        maybeMkSharedData fvSet =
+          let sharers = filter (\cd -> subDVarSet (snd cd) fvSet) cds in
+            if length sharers > 1
+            then mkEnvId >>= \env_id ->
+                   log_shared_env_created >>
+                   return [SharedEnvData fvSet env_id (map fst sharers)]
+            else return []
+
+        greedyCover left_to_cover_set out_sets
+          | isEmptyDVarSet left_to_cover_set
+          = out_sets
+        greedyCover left_to_cover_set out_sets
+          | otherwise
+          = let s = foldr
+                      (\a b -> if ((sizeDVarSet (a `intersectDVarSet` left_to_cover_set))
+                                  >
+                                  (sizeDVarSet (b `intersectDVarSet` left_to_cover_set)))
+                               then a
+                               else b)
+                      emptyDVarSet
+                      fvSets
+            in greedyCover (left_to_cover_set `minusDVarSet` s) (s:out_sets)
+
+-- | This isn't really shared closure analysis, rather it always creates a first
+-- class environment. It is here to test the code generator
+needlesslyShared :: [SharingCandidate] -> CesM [SharedEnvData]
+needlesslyShared cds = mapM mkSed cds
+  where mkSed (id,fvs) =
+          mkEnvId >>= \env_id ->
+            log_shared_env_created >>
+            return (SharedEnvData fvs env_id [id])
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 198430f4a0..76864b3e01 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -109,8 +109,12 @@ stg2stg logger dflags this_mod binds
 
           StgClosEnvShare -> do
             us <- getUniqueSupplyM
-            let _ =  {-# SCC "StgLiftLams" #-} stgClosEnvShare us binds
-            end_pass "StgClosEnvShare" binds
+            let (binds',ces_log) = {-# SCC "StgClosEnvShare" #-} stgClosEnvShare us binds
+            liftIO (dumpIfSet logger dflags
+                      (dopt Opt_D_dump_stg_clos_env_share dflags)
+                      "Closure environment sharing information:"
+                      (ppr ces_log))
+            end_pass "StgClosEnvShare" binds'
 
     opts = initStgPprOpts dflags
     dump_when flag header binds
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 9acf807257..8f51e5d2fe 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -815,7 +815,7 @@ pprStgExpr opts e = case e of
 
    StgCaseEnv env_var vars expr
      -> sep [ sep [ text "case-env", ppr env_var, text "of", char '{' ]
-            , sep [ ppr vars, text "->", pprStgExpr opts expr ]
+            , nest 2 (sep [ ppr vars, text "->", pprStgExpr opts expr ])
             , char '}'
             ]
 
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 2dc5ffbc00..fa06c5887e 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -22,7 +22,6 @@ import GHC.StgToCmm.Expr
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Env
 import GHC.StgToCmm.DataCon
-import GHC.StgToCmm.FirstClassEnv
 import GHC.StgToCmm.Heap
 import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
                    initUpdFrameProf)
@@ -212,8 +211,8 @@ cgRhs id (StgRhsCon cc con args)
       -- con args are always non-void,
       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
 
-cgRhs id (StgRhsEnv vs)
-  = buildFirstClassEnv id (dVarSetElems vs)
+cgRhs id (StgRhsEnv fvs)
+  = buildEnv id (nonVoidIds (dVarSetElems fvs))
 
 {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
 cgRhs id (StgRhsClosure fvs cc upd_flag args body)
@@ -221,7 +220,40 @@ cgRhs id (StgRhsClosure fvs cc upd_flag args body)
        mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
 
 ------------------------------------------------------------------------
---              Non-constructor right hand sides
+--              Environment right hand sides
+------------------------------------------------------------------------
+
+buildEnv :: Id -> [NonVoid Id] -> FCode (CgIdInfo, FCode CmmAGraph)
+buildEnv binder args =
+  do { (id_info, reg) <- rhsIdInfo binder lf_info
+     ; return (id_info, gen_code reg) }
+  where
+    lf_info = mkEnvLFInfo
+    gen_code reg
+      = do { profile <- getProfile
+           ; let platform = profilePlatform profile
+                 (tot_wds, ptr_wds, args_w_offsets)
+                   = mkVirtHeapOffsets profile StdHeader (addIdReps args)
+                 non_ptr_wds = tot_wds - ptr_wds
+                 info_tbl = mkEnvInfoTable profile ptr_wds non_ptr_wds
+                 use_cc = cccsExpr
+                 blame_cc = cccsExpr
+           ; emit (mkComment $ mkFastString "calling allocDynClosure")
+           ; hp_plus_n <- allocDynClosure (Just binder) info_tbl lf_info use_cc
+                            blame_cc (map toVarArg args_w_offsets)
+           ; return (mkRhsInit platform reg lf_info hp_plus_n) }
+    mkEnvInfoTable profile ptr_wds non_ptr_wds =
+      CmmInfoTable
+      { cit_lbl  = mkBytesLabel (idName binder)
+      , cit_rep  = mkHeapRep profile False ptr_wds non_ptr_wds IndStatic
+      , cit_prof = NoProfilingInfo
+      , cit_srt  = Nothing
+      , cit_clo  = Nothing }
+
+    toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+
+------------------------------------------------------------------------
+--              Closure right hand sides
 ------------------------------------------------------------------------
 
 mkRhsClosure :: Profile -> Id -> CostCentreStack
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index ddd8a8a988..2328933ab7 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -28,7 +28,7 @@ module GHC.StgToCmm.Closure (
         -- * LambdaFormInfo
         LambdaFormInfo,         -- Abstract
         StandardFormInfo,        -- ...ditto...
-        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkEnvLFInfo, mkSelectorLFInfo,
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
         mkLFStringLit,
         lfDynTag,
@@ -256,6 +256,10 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con = LFCon con
 
 -------------
+mkEnvLFInfo :: LambdaFormInfo
+mkEnvLFInfo = LFUnlifted
+
+-------------
 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 1acf880285..0372cf6797 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -16,6 +16,9 @@ module GHC.StgToCmm.Expr ( cgExpr ) where
 
 import GHC.Prelude hiding ((<*>))
 
+import GHC.Platform
+import GHC.Platform.Profile
+
 import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )
 
 import GHC.StgToCmm.Monad
@@ -46,13 +49,14 @@ import GHC.Core.TyCon
 import GHC.Core.Type        ( isUnliftedType )
 import GHC.Types.RepType    ( isVoidTy, countConRepArgs )
 import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
+import GHC.Types.Var.Set
 import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Data.FastString
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
-import Control.Monad ( unless, void )
+import Control.Monad ( unless, void, forM )
 import Control.Arrow ( first )
 import Data.List     ( partition )
 
@@ -129,8 +133,18 @@ cgExpr (StgLetNoEscape _ binds expr) =
 cgExpr (StgCase expr bndr alt_type alts) =
   cgCase expr bndr alt_type alts
 
-cgExpr (StgCaseEnv _ _ e) =
-  do { cgExpr e }
+cgExpr (StgCaseEnv env_id fvs e) =
+  do { base_reg <- rebindToReg (NonVoid env_id)
+     ; profile <- getProfile
+     ; let platform = profilePlatform profile
+           (_, _, fvs_w_offsets)
+             = mkVirtHeapOffsets profile StdHeader . addIdReps . nonVoidIds . dVarSetElems $ fvs
+           tag = lfDynTag platform mkEnvLFInfo
+     ; forM fvs_w_offsets $ \(fv_id, off) ->
+         do { fv_reg <- rebindToReg fv_id
+            ; emit $ mkTaggedObjectLoad platform fv_reg base_reg off tag }
+     ; cgExpr e }
+
 
 ------------------------------------------------------------------------
 --              Let no escape
diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs
index e59792cb57..63b1fe76dd 100644
--- a/compiler/GHC/StgToCmm/Types.hs
+++ b/compiler/GHC/StgToCmm/Types.hs
@@ -130,6 +130,8 @@ data LambdaFormInfo
   | LFUnlifted          -- A value of unboxed type;
                         -- always a value, needs evaluation
 
+  | LFFirstClassEnv     -- Is unlifted like @LFUnlifted@, but is also boxed
+
   | LFLetNoEscape       -- See LetNoEscape module for precise description
 
 instance Outputable LambdaFormInfo where
@@ -146,6 +148,8 @@ instance Outputable LambdaFormInfo where
       text "LFUnknown" <> brackets (pprFuncFlag m_func)
     ppr LFUnlifted =
       text "LFUnlifted"
+    ppr LFFirstClassEnv =
+      text "LFFirstClassEnv"
     ppr LFLetNoEscape =
       text "LFLetNoEscape"