/src/Gen2/Generator.hs

Large files files are truncated, but you can click here to view the full file

{-# LANGUAGE CPP,
             QuasiQuotes,
             TupleSections,
             OverloadedStrings,
             LambdaCase,
             MultiWayIf,
             TemplateHaskell,
             ViewPatterns,
             BangPatterns
  #-}

{-
  Main generator module
-}

module Gen2.Generator (generate) where

import           Fingerprint
import           ForeignCall
import           CostCentre
import           FastString
import           TysWiredIn
import           BasicTypes
import           ListSetOps
import           PrelNames
import           DynFlags
import           Encoding
import           UniqSet
import           Literal
import           DataCon
import           CoreSyn
import           IdInfo
import           TcType
import           UniqFM
import           Unique
import           StgSyn
import           PrimOp
import           Module
import           VarSet
import           Panic
import           TyCon
import           Util
import           Type hiding (typeSize)
import           RepType
import           TysPrim
import           Name
import           GHC
import           Id
import           HscTypes

import           Control.Applicative
import           Control.DeepSeq
import           Control.Lens hiding ((||=))
import           Control.Monad.State.Strict

import           Data.Array
import           Data.Bits
  ((.|.), shiftL, shiftR, (.&.), testBit, xor, complement)
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import           Data.Char (ord, chr, isDigit)
import           Data.Either (partitionEithers)
import           Data.Function (on)
import           Data.Generics.Aliases (mkT)
import           Data.Generics.Schemes (everywhere)
import           Data.Int
import           Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet        as IS
import           Data.Maybe
  (isJust, isNothing, catMaybes, fromMaybe, maybeToList, listToMaybe)
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.List
  (partition, intercalate, sort, sortBy, foldl', scanl')
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Text (Text)

import           Compiler.JMacro
import qualified Text.Parsec as P

import           Compiler.Compat
import           Compiler.Settings

import           Gen2.Base
import           Gen2.Deps
import           Gen2.Utils
import           Gen2.Prim
import           Gen2.Rts
import           Gen2.RtsTypes
import           Gen2.StgAst
import           Gen2.RtsAlloc
import           Gen2.RtsApply
import qualified Gen2.Linker    as Linker
import           Gen2.ClosureInfo
import qualified Gen2.Optimizer as O
import qualified Gen2.Object    as Object
import           Gen2.Sinker
import           Gen2.Profiling
import qualified Gen2.Compactor as Compactor

import           GHC.Float

-- debug
import           Gen2.Printer             (pretty)

import qualified Data.Text.Lazy           as TL
import           Text.PrettyPrint.Leijen.Text (displayT, renderPretty)

import qualified Debug.Trace

data DependencyDataCache = DDC
         { _ddcModule   :: !(IntMap        Object.Package)  -- ^ Unique Module -> Object.Package
         , _ddcId       :: !(IntMap        Object.Fun)      -- ^ Unique Id     -> Object.Fun (only to other modules)
         , _ddcOther    :: !(Map OtherSymb Object.Fun)
         }

makeLenses ''DependencyDataCache

type StgPgm     = [StgBinding]

data ExprCtx = ExprCtx
       { _ctxTop        :: Id
       , _ctxTarget     :: [(PrimRep,[JExpr])]
       , _ctxEval       :: UniqSet Id
       , _ctxLne        :: UniqSet Id -- ^ all lne-bound things
       , _ctxLneFrameBs :: UniqFM Int -- ^ binds in current lne frame (defined at size)
       , _ctxLneFrame   :: [(Id,Int)] -- ^ contents of current lne frame
       , _ctxSrcSpan    :: Maybe RealSrcSpan
       }

makeLenses ''ExprCtx

instance Show ExprCtx where
  show (ExprCtx top tgt eval lne _lnefbs lnef _mbSpan) =
    "ExprCtx\n" ++ unlines [show top, show tgt, sus eval, sus lne, show lnef]
    where
      sus = show . nonDetEltsUniqSet

clearCtxStack :: ExprCtx -> ExprCtx
clearCtxStack ctx = ctx & ctxLneFrameBs .~ emptyUFM
                        & ctxLneFrame   .~ []

adjustCtxStack :: Int -> ExprCtx -> ExprCtx
adjustCtxStack n ctx
  | l < n     = panic $ "adjustCtxStack: let-no-escape stack too short: " ++
                        show l ++ " < " ++ show n
  | otherwise = ctx & ctxLneFrame %~ take n
  where
    l = ctx ^. ctxLneFrame . to length

addEval :: Id -> ExprCtx -> ExprCtx
addEval i = over ctxEval (flip addOneToUniqSet i)

generate :: GhcjsSettings
         -> DynFlags
         -> Module
         -> [StgTopBinding] -- StgPgm
         -> [SptEntry]
         -> CollectedCCs
         -> ByteString -- ^ binary data for the .js_o object file
generate settings df m s spt_entries cccs =
  let (uf, s') = sinkPgm m s
  in trace' ("generate\n" ++ intercalate "\n\n" (map showIndent s)) $

     flip evalState (initState df m uf) $ do
        ifProfiling' $ initCostCentres cccs
        (st, lus) <- genUnits df m s' spt_entries
        -- (exported symbol names, javascript statements) for each linkable unit
        p <- forM lus $ \u ->
           mapM (fmap (\(TxtI i) -> i) . jsIdI) (luIdExports u) >>=
            \ts -> return (ts ++ luOtherExports u, luStat u)
        let (st', dbg) = dumpAst st settings df s'
        deps <- genDependencyData df m lus
        -- p first, so numbering of linkable units lines up
        pure . BL.toStrict $
          Object.object' st' deps (p ++ dbg)
{- |
  Generate an extra linkable unit for the object file if -debug is active.
  this unit is never actually linked, but it contains the optimized STG AST
  so it can be easily reviewed using ghcjs --print-obj to aid in solving
  code generator problems.
 -}
dumpAst :: Object.SymbolTable
        -> GhcjsSettings
        -> DynFlags
        -> [StgTopBinding]
        -> (Object.SymbolTable, [([Text], BL.ByteString)])
dumpAst st _settings dflags s
  | buildingDebug dflags = (st', [(["h$debug", "h$dumpAst"], bs)])
  | otherwise            = (st, [])
      where
        (st', bs) = Object.serializeStat st [] [] [j| h$dumpAst = `x` |] [] []
        x = T.intercalate "\n\n" (map (T.pack . showIndent) s)

-- | variable prefix for the nth block in module
modulePrefix :: Module -> Int -> Text
modulePrefix m n =
  let encMod = zEncodeString . moduleNameString . moduleName $ m
  in  T.pack $ "h$" ++ encMod ++ "_id_" ++ show n

-- | data used to generate one ObjUnit in our object file
data LinkableUnit = LinkableUnit
  { luStat         :: BL.ByteString -- ^ serialized JS AST
  , luIdExports    :: [Id]          -- ^ exported names from haskell identifiers
  , luOtherExports :: [Text]        -- ^ other exports
  , luIdDeps       :: [Id]          -- ^ identifiers this unit depends on
  , luOtherDeps    :: [OtherSymb]   -- ^ symbols not from a haskell id that this unit depends on
  , luRequired     :: Bool          -- ^ always link this unit
  , luForeignRefs  :: [ForeignRef]
  } deriving (Eq, Ord, Show)

-- | Generate the ingredients for the linkable units for this module
genUnits :: HasDebugCallStack
         => DynFlags
         -> Module
         -> [StgTopBinding] -- StgPgm
         -> [SptEntry]
         -> G (Object.SymbolTable, [LinkableUnit]) -- ^ the final symbol table and the linkable units
genUnits dflags m ss spt_entries = generateGlobalBlock =<< go 2 Object.emptySymbolTable ss
    where
      -- ss' = [l | StgTopLifted l <- ss]

      go :: HasDebugCallStack
         => Int                 -- ^ the block we're generating (block 0 is the global unit for the module)
         -> Object.SymbolTable  -- ^ the shared symbol table
         -> [StgTopBinding]
         -> G (Object.SymbolTable, [LinkableUnit])
      go n st (x:xs) = do
        (st', mlu) <- generateBlock st x n
        (st'', lus)  <- go (n+1) st' xs
        return (st'', maybe lus (:lus) mlu)
      go _ st []     = return (st, [])

      -- | Generate the global unit that all other blocks in the module depend on
      --   used for cost centres and static initializers
      --   the global unit has no dependencies, exports the moduleGlobalSymbol
      generateGlobalBlock :: HasDebugCallStack
                          => (Object.SymbolTable, [LinkableUnit])
                          -> G (Object.SymbolTable, [LinkableUnit])
      generateGlobalBlock (st, lus) = do
        glbl <- use gsGlobal
        staticInit <-
          initStaticPtrs spt_entries
        (st', _, bs) <- serializeLinkableUnit m st [] [] []
                         ( O.optimize
                         . jsSaturate (Just $ modulePrefix m 1)
                         $ mconcat (reverse glbl) <> staticInit) [] []
        return ( st'
               , LinkableUnit bs
                              []
                              [moduleGlobalSymbol dflags m]
                              []
                              []
                              False
                              []
                 : lus
               )

      -- | Generate the linkable unit for one binding or group of
      --   mutually recursive bindings
      generateBlock :: HasDebugCallStack
                    => Object.SymbolTable
                    -> StgTopBinding
                    -> Int
                    -> G (Object.SymbolTable, Maybe LinkableUnit)
      generateBlock st (StgTopStringLit bnd str) n = do
        bids <- genIdsI bnd
        case bids of
          [b1@(TxtI b1t),b2@(TxtI b2t)] -> do
            -- [e1,e2] <- genLit (MachStr str)
            emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing
            emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
            extraTl   <- use (gsGroup . ggsToplevelStats)
            si        <- use (gsGroup . ggsStatic)
            let stat = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
            (st', _ss, bs) <- serializeLinkableUnit m st [bnd] [] si
                              (jsSaturate (Just $ modulePrefix m n) stat) [] []
            pure (st', Just $ LinkableUnit bs [bnd] [] [] [] False [])
          _ -> panic "generateBlock: invalid size"
      generateBlock st (StgTopLifted decl) n =
        trace' ("generateBlock:\n" ++ showIndent decl) $
       do
        tl        <- genToplevel decl
        extraTl   <- use (gsGroup . ggsToplevelStats)
        ci        <- use (gsGroup . ggsClosureInfo)
        si        <- use (gsGroup . ggsStatic)
        unf       <- use gsUnfloated
        extraDeps <- use (gsGroup . ggsExtraDeps)
        fRefs     <- use (gsGroup . ggsForeignRefs)
        resetGroup
        let allDeps  = collectIds unf decl
            topDeps  = collectTopIds decl
            required = hasExport decl
            stat     = O.optimize
                     . jsSaturate (Just $ modulePrefix m n)
                     $ mconcat (reverse extraTl) <> tl
        (st', _ss, bs) <- serializeLinkableUnit m st topDeps ci si stat [] fRefs
        return $! seqList topDeps `seq` seqList allDeps `seq` st' `seq`
          (st', Just $ LinkableUnit bs topDeps [] allDeps (S.toList extraDeps) required fRefs)

initStaticPtrs :: [SptEntry] -> C
initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs
  where
    initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do
      i <- jsId sp_id
      fpa <- concat <$> mapM (genLit . mkMachWord64 . fromIntegral) [w1,w2]
      let sptInsert = ApplExpr (ValExpr (JVar (TxtI "h$hs_spt_insert")))
                               (fpa ++ [i])
      return [j| h$initStatic.push(function() {
                   `sptInsert`;
                 })
               |]

hasExport :: StgBinding -> Bool
hasExport bnd =
  case bnd of
    StgNonRec b e -> isExportedBind b e
    StgRec bs     -> any (uncurry isExportedBind) bs
  where
    isExportedBind _i (StgRhsCon _cc con _) =
      getUnique con == staticPtrDataConKey
    isExportedBind _ _ = False

{- |
   serialize the payload of a linkable unit in the object file, adding
   strings to the SymbolTable where necessary
-}
serializeLinkableUnit :: HasDebugCallStack
                      => Module
                      -> Object.SymbolTable  -- symbol table to start with
                      -> [Id]                -- id's exported by unit
                      -> [ClosureInfo]
                      -> [StaticInfo]
                      -> JStat               -- generated code for the unit
                      -> [Object.ExpFun]
                      -> [Object.ForeignRef]
                      -> G (Object.SymbolTable, [Text], BL.ByteString)
serializeLinkableUnit _m st i ci si stat fe fi = do
  i' <- mapM idStr i
  let (st', o) = Object.serializeStat st ci si stat fe fi
  rnf i' `seq` rnf o `seq` return (st', i', o)
    where
      idStr i = itxt <$> jsIdI i

collectTopIds :: StgBinding -> [Id]
collectTopIds (StgNonRec b _) = [b]
collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs
                            in  seqList xs `seq` xs

collectIds :: UniqFM StgExpr -> StgBinding -> [Id]
collectIds unfloated b =
  let xs = map zapFragileIdInfo .
           filter acceptId $ S.toList (bindingRefs unfloated b)
  in  seqList xs `seq` xs
  where
    acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden]
    -- the GHC.Prim module has no js source file
    isForbidden i
      | Just m <- nameModule_maybe (getName i) =
                    moduleNameText m   == T.pack "GHC.Prim" &&
                    modulePackageKey m == primPackageKey
      | otherwise = False

{- |
     generate the object's dependy data, taking care that package and module names
     are only stored once
 -}
genDependencyData :: HasDebugCallStack
                  => DynFlags
                  -> Module
                  -> [LinkableUnit]
                  -> G Object.Deps
genDependencyData dflags mod units = do
    -- [(blockindex, blockdeps, required, exported)]
    ds <- evalStateT (sequence (map (uncurry oneDep) blocks))
                     (DDC IM.empty IM.empty M.empty)
    return $ Object.Deps (Linker.mkPackage $
                           toInstalledUnitId (moduleUnitId mod))
                         (moduleNameText mod)
                         (IS.fromList [ n | (n, _, True, _) <- ds ])
                         (M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds)
                         (listArray (0, length blocks-1) (ds ^.. traverse . _2))
  where
      -- Id -> Block
      unitIdExports :: UniqFM Int
      unitIdExports = listToUFM $
                      concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks

      -- OtherSymb -> Block
      unitOtherExports :: Map OtherSymb Int
      unitOtherExports = M.fromList $
                         concatMap (\(u,n) -> map (,n)
                                                  (map (OtherSymb mod)
                                                       (luOtherExports u)))
                                   blocks

      blocks :: [(LinkableUnit, Int)]
      blocks = zip units [0..]

      -- generate the list of exports and set of dependencies for one unit
      oneDep :: LinkableUnit
             -> Int
             -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.Fun])
      oneDep (LinkableUnit _ idExports otherExports idDeps otherDeps req frefs) n = do
        (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
        (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
        expi <- mapM lookupExportedId (filter isExportedId idExports)
        expo <- mapM lookupExportedOther otherExports
        -- fixme thin deps, remove all transitive dependencies!
        let bdeps = Object.BlockDeps
                      (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo)
                      (S.toList . S.fromList $ edi++edo)
                      -- [] -- fixme support foreign exported
                      -- frefs
        return (n, bdeps, req, expi++expo)

      idModule :: Id -> Maybe Module
      idModule i = nameModule_maybe (getName i) >>= \m ->
                   guard (m /= mod) >> return m

      -- get the function for an Id from the cache, add it if necessary
      -- result: Left Object.Fun   if function refers to another module
      --         Right blockNumber if function refers to current module
      --
      --         assumes function is internal to the current block if it's
      --         from teh current module and not in the unitIdExports map.
      lookupIdFun :: Int -> Id
                  -> StateT DependencyDataCache G (Either Object.Fun Int)
      lookupIdFun n i = case lookupUFM unitIdExports i of
        Just k  -> return (Right k)
        Nothing -> case idModule i of
          Nothing -> return (Right n)
          Just m ->
            let k = getKey . getUnique $ i
                addEntry :: StateT DependencyDataCache G Object.Fun
                addEntry = do
                  (TxtI idTxt) <- lift (jsIdI i)
                  lookupExternalFun (Just k) (OtherSymb m idTxt)
            in  if m == mod
                   then panic ("local id not found: " ++ show m)
                    else Left <$> (maybe addEntry return =<<
                                   use (ddcId . to (IM.lookup k)))

      -- get the function for an OtherSymb from the cache, add it if necessary
      lookupOtherFun :: OtherSymb
                     -> StateT DependencyDataCache G (Either Object.Fun Int)
      lookupOtherFun od@(OtherSymb m idTxt) =
        case M.lookup od unitOtherExports of
          Just n  -> return (Right n)
          Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ T.unpack idTxt)
          Nothing ->  Left <$> (maybe (lookupExternalFun Nothing od) return =<<
                        use (ddcOther . to (M.lookup od)))

      lookupExportedId :: Id -> StateT DependencyDataCache G Object.Fun
      lookupExportedId i = do
        (TxtI idTxt) <- lift (jsIdI i)
        lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt)

      lookupExportedOther :: Text -> StateT DependencyDataCache G Object.Fun
      lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod

      -- lookup a dependency to another module, add to the id cache if there's
      -- an id key, otherwise add to other cache
      lookupExternalFun :: Maybe Int
                        -> OtherSymb -> StateT DependencyDataCache G Object.Fun
      lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do
        let mk        = getKey . getUnique $ m
            mpk       = Linker.mkPackage (toInstalledUnitId (moduleUnitId m))
            inCache p = Object.Fun p (moduleNameText m) idTxt
            addCache  = do
              let cache' = IM.insert mk mpk
              ddcModule %= cache'
              cache' `seq` return (Object.Fun mpk (moduleNameText m) idTxt)
        f <- maybe addCache (return . inCache) =<<
                   use (ddcModule . to (IM.lookup mk))
        maybe (ddcOther %= M.insert od f) (\k -> ddcId %= IM.insert k f) mbIdKey
        return f

moduleNameText :: Module -> Text
moduleNameText m
  | xs == ":Main" = T.pack "Main"
  | otherwise     = T.pack xs
    where xs      = moduleNameString . moduleName $ m

genToplevel :: StgBinding -> C
genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs
genToplevel (StgRec bs)          =
  mconcat $ map (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs

-- entry function of the worker
enterDataCon :: DataCon -> G JExpr
enterDataCon d = jsDcEntryId (dataConWorkId d)

enterDataConI :: DataCon -> G Ident
enterDataConI d = jsDcEntryIdI (dataConWorkId d)

genToplevelDecl :: Id -> StgRhs -> C
genToplevelDecl i rhs = do
  s1 <- resetSlots (genToplevelConEntry i rhs)
  s2 <- resetSlots (genToplevelRhs i rhs)
  return (s1 <> s2)

genToplevelConEntry :: Id -> StgRhs -> C
genToplevelConEntry i rhs@(StgRhsCon _cc con _args)
    | i `elem` [ i' | AnId i' <- dataConImplicitTyThings con ]
    = genSetConInfo i con (stgRhsLive rhs) -- NoSRT
genToplevelConEntry i rhs@(StgRhsClosure _cc _bi [] _upd_flag
                    _args (removeTick -> StgConApp dc _cargs _))
    | i `elem` [ i' | AnId i' <- dataConImplicitTyThings dc ]
    = genSetConInfo i dc (stgRhsLive rhs) -- srt
genToplevelConEntry _ _ = mempty

removeTick :: StgExpr -> StgExpr
removeTick (StgTick _ e) = e
removeTick e             = e

genStaticRefsRhs :: StgRhs -> G CIStatic
genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv)

-- fixme, update to new way to compute static refs dynamically
genStaticRefs :: LiveVars -> G CIStatic
genStaticRefs lv
  | isEmptyDVarSet sv = return noStatic
  | otherwise         = do
      unfloated <- use gsUnfloated
      let xs = filter (\x -> not (elemUFM x unfloated ||
                                  isLiftedType_maybe (idType x) == Just False))
                      (dVarSetElems sv)
      CIStaticRefs . catMaybes <$> mapM getStaticRef xs
  where
    sv = liveStatic lv

getStaticRef :: Id -> G (Maybe Text)
getStaticRef = fmap (fmap itxt . listToMaybe) . genIdsI

genToplevelRhs :: Id
               -> StgRhs
               -> C
genToplevelRhs i rhs@(StgRhsClosure cc _bi _ upd args body)
  -- foreign exports
  | (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget _ t _ _) _ _)) _)
     [StgLitArg _ {- (MachInt _is_js_conv) -}, StgLitArg (MachStr _js_name), StgVarArg _tgt] _) <- body,
     t == fsLit "__mkExport" = return mempty -- fixme error "export not implemented"
-- general cases:
genToplevelRhs i (StgRhsCon cc con args) = do
  ii <- jsIdI i
  allocConStatic ii cc con args
  return mempty
genToplevelRhs i rhs@(StgRhsClosure cc _bi [] _upd_flag {- srt -} args body) = do
  eid@(TxtI eidt) <- jsEnIdI i
  (TxtI idt)   <- jsIdI i
--  pushGlobalRefs
  body <- genBody (ExprCtx i [] emptyUniqSet emptyUniqSet emptyUFM [] Nothing) i R2 args body
  (lidents, lids) <- unzip <$> liftToGlobal (jsSaturate (Just . T.pack $ "ghcjs_tmp_sat_") body)
  let lidents' = map (\(TxtI t) -> t) lidents
--  li
--  refs <- popGlobalRefs
  CIStaticRefs sr0 <- genStaticRefsRhs rhs
  let sri = filter (`notElem` lidents') sr0
      sr   = CIStaticRefs sri

--  emitToplevel $ AssignStat (ValExpr (JVar $ TxtI ("h$globalRefs_" <> idt)))
--                            (ValExpr (JList $ map (ValExpr . JVar) lidents ++ [jnull] ++ map (ValExpr . JVar . TxtI) sri))

  et <- genEntryType args
  ll <- loadLiveFun lids
  (static, regs, upd) <-
        if et == CIThunk
          then (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],) <$> updateThunk
          else return (StaticFun eidt (map StaticObjArg lidents'),
                      (if null lidents then CIRegs 1 (concatMap idVt args)
                                       else CIRegs 0 (PtrV : concatMap idVt args))
                        , mempty)
  setcc <- ifProfiling $
             if et == CIThunk
               then enterCostCentreThunk
               else enterCostCentreFun cc
  emitClosureInfo (ClosureInfo eidt
                               regs
                               idt
                               (fixedLayout $ map (uTypeVt . idType) lids) -- (CILayoutFixed 0 [])
                               et
                               sr)
  ccId <- costCentreStackLbl cc
  emitStatic idt static ccId
  return $ eid ||= JFunc [] (ll <> upd <> setcc <> body)
genToplevelRhs _ _ = panic "genToplevelRhs: top-level values cannot have live variables"

dumpGlobalIdCache :: Text -> G ()
dumpGlobalIdCache itxt = do
  GlobalIdCache gidc <- use globalIdCache
  let i  = TxtI ("h$globalIdCache_" <> itxt)
      vs = M.keys
  emitToplevel [j| `i` = `M.keys gidc`; |]
{-  emitToplevel $ [j|

                   AssignStat (ValExpr (JVar . TxtI $ "h$globalIdCache_" <> idt))
                            (ValExpr (JList
-}

liftToGlobal :: JStat -> G [(Ident, Id)]
liftToGlobal jst = do
  GlobalIdCache gidc <- use globalIdCache
  let sids  = filter (`M.member` gidc) (jst ^.. Compactor.identsS)
      cnt   = M.fromListWith (+) (map (,1) sids)
      sids' = sortBy (compare `on` (cnt M.!)) (nub' sids)
  pure $ map (\s -> (s, snd $ gidc M.! s)) sids'

nub' :: (Ord a, Eq a) => [a] -> [a]
nub' xs = go S.empty xs
  where
    go _ []     = []
    go s xxs@(x:xs) | S.member x s = go s xs
                    | otherwise    = x : go (S.insert x s) xs
--       ids  = filter M.member gidc
{-
  algorithm:
   - collect all Id refs that are in the cache, count usage
   - order by increasing use
   - prepend loading lives var to body: body can stay the same
-}

{-
   todo for stack frames:
    - change calling convention?
    - return stack[sp] -> return stack[sp].f ?
       -> no we miss the continuation object then
       -> set h$rS
       -> return h$rs(); instead
 -}

loadLiveFun :: [Id] -> C
loadLiveFun l = do
   l' <- concat <$> mapM genIdsI l
   case l' of
     []  -> return mempty
     [v] -> return (decl' v [je| `R1`.d1 |])
     [v1,v2] -> return (decl' v1 [je| `R1`.d1 |] <> decl' v2 [je| `R1`.d2 |])
     (v:vs)  -> do
       d <- makeIdent
       let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs
       return (decl' v [je| `R1`.d1 |] <> [j| `decl d`; `d` = `R1`.d2 |] <> l'')
  where
        loadLiveVar d n v = let ident = dataFields ! n
                            in  decl' v (SelExpr d ident)

dataFields :: Array Int Ident
dataFields = listArray (1,16384) (map (TxtI . T.pack . ('d':) . show) [(1::Int)..16384])

genBody :: HasDebugCallStack => ExprCtx -> Id -> StgReg -> [Id] -> StgExpr -> C
genBody ctx i startReg args e =
  -- trace' ("genBody: " ++ show args)
  (genBody0 ctx i startReg args e)

genBody0 :: HasDebugCallStack
         => ExprCtx
         -> Id
         -> StgReg
         -> [Id]
         -> StgExpr
         -> C
genBody0 ctx i startReg args e = do
  la <- loadArgs startReg args
  lav <- verifyRuntimeReps args
  let ids :: [(PrimRep, [JExpr])]
      ids = -- take (resultSize args $ idType i) (map toJExpr $ enumFrom R1)
            reverse . fst $
            foldl' (\(rs, vs) (rep, size) ->
                       let (vs0, vs1) = splitAt size vs
                       in  ((rep, vs0):rs,vs1))
                   ([], map toJExpr $ enumFrom R1)
                   (resultSize args $ idType i)
  (e, _r) <-  trace' ("genBody0 ids:\n" ++ show ids) (genExpr (ctx & ctxTarget .~ ids) e)
  return $ la <> lav <> e <> returnStack -- [j| return `Stack`[`Sp`]; |]

-- find the result type after applying the function to the arguments
resultSize :: HasDebugCallStack => [Id] -> Type -> [(PrimRep, Int)]
resultSize xs t = trace' ("resultSize\n" ++ show xs ++ "\n" ++ show t)
                    (let r = resultSize0 xs t
                     in trace' ("resultSize -> " ++ show r) r
                    )

resultSize0 :: HasDebugCallStack
            => [Id]
            -> Type
            -> [(PrimRep, Int)] -- Int
resultSize0 xxs@(x:xs) t
  -- - | isUnboxedTupleType
  -- - | t' <- piResultTys t (map idType xxs) = resultSize0 [] t'
  -- - | MultiRep _ <- {- trace' "resultSize0 ubx" -} (repType (idType x)) = panic "genBody: unboxed tuple argument"
  -- - | otherwise = {- trace' "resultSize0 not" $ -}
  | t' <- unwrapType t
  , Just (fa, fr) <- splitFunTy_maybe t' -- isFunTy t' =
  , Just (tc, ys) <- splitTyConApp_maybe fa
  , isUnboxedTupleTyCon tc =
      resultSize0 xxs (mkFunTys (dropRuntimeRepArgs ys) fr)
  | t' <- unwrapType t
  , Just (fa, fr) <- splitFunTy_maybe t' = -- isFunTy t' =
      resultSize0 xs fr
        -- let (fa, fr) = splitFunTy t'
        -- let    t''     = mkFunTys (map primRepToType . typePrimRep $ unwrapType fa) fr
        -- in  resultSize0 xs (maybe fr snd . splitFunTy_maybe $ t'')
  | otherwise = [(LiftedRep, 1)] -- possibly newtype family, must be boxed
--      case typePrimRep (unwrapType t) of -- repType t of
       -- (UnaryRep t' | isFunTy t' ->
      --                   let (fa,fr) = splitFunTy t'
        --                     t''     = mkFunTys (map slotTyToType . repTypeSlots $ repType fa) fr
--                         in  {- trace' ("resultSize0 fun: " ++ show (fa, fr)) $ -}
  --                           resultSize0 xs (snd . splitFunTy $ t'')
--       _                          -> 1 -- possibly newtype family, must be boxed
resultSize0 [] t
  | isRuntimeRepKindedTy t' = []
  | isRuntimeRepTy t' = []
  | Nothing <- isLiftedType_maybe t' = [(LiftedRep, 1)]
  | otherwise = typeTarget t
  where
    t' = unwrapType t
       -- map (\t -> (t, varSize (primRepVt t))) $ typePrimRep (unwrapType t)
    {- trace' "resultSize0 eol" $ -}
  -- case repType t of
    -- UnaryRep t'     -> {- trace' ("resultSize0 eol2: " ++ show t') $ -} typeSize t'
    -- MultiRep tys -> {- trace' ("resultSize0 eol3: " ++ show tys) $ -} sum (map (typeSize . slotTyToType) tys)

loadArgs :: HasDebugCallStack => StgReg -> [Id] -> C
loadArgs start args = do
  args' <- concatMapM genIdArgI args
  return (mconcat $ zipWith (||=) args' [start..])

data ExprResult = ExprCont
                | ExprInline (Maybe [JExpr])
  deriving (Eq, Ord, Show)

data ExprValData = ExprValData [JExpr]
  deriving (Eq, Ord, Show)

-- not a Monoid
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult []           = panic "branchResult: empty list"
branchResult [e]          = e
branchResult (ExprCont:_) = ExprCont
branchResult (_:es)
  | any (==ExprCont) es   = ExprCont
  | otherwise             = ExprInline Nothing

genExpr :: HasDebugCallStack => ExprCtx -> StgExpr -> G (JStat, ExprResult)
genExpr top e = trace' ("genExpr\n" ++ showIndent e)
                       (genExpr0 top e)

genExpr0 :: HasDebugCallStack
         => ExprCtx
         -> StgExpr
         -> G (JStat, ExprResult)
genExpr0 top (StgApp f args) = genApp top f args
genExpr0 top (StgLit l) =
  -- fixme check primRep here?
  (,ExprInline Nothing) .
  assignAllCh ("genExpr StgLit " ++ show (top ^. ctxTarget))
                                         (concatMap snd $ top ^. ctxTarget)
                         <$> genLit l
genExpr0 top (StgConApp con args _) = do
  as <- concatMapM genArg args
  c <- genCon top con as
  return (c, ExprInline (Just as))
genExpr0 top (StgOpApp (StgFCallOp f _) args t) =
   genForeignCall top f t (concatMap snd $ top ^. ctxTarget) args
genExpr0 top (StgOpApp (StgPrimOp op) args t)    = genPrimOp top op args t
genExpr0 top (StgOpApp (StgPrimCallOp c) args t) = genPrimCall top c args t
genExpr0 _   (StgLam{}) = panic "genExpr: StgLam"
genExpr0 top stg@(StgCase e b at alts) =
  genCase top b e at alts (liveVars $ stgExprLive False stg)
genExpr0 top (StgLet b e) = do
  (b',top') <- genBind top b
  (s,r)     <- genExpr top' e
  return (b' <> s, r)
genExpr0 top (StgLetNoEscape b e) = do
  (b', top') <- genBindLne top b
  (s, r)     <- genExpr top' e
  return (b' <> s, r)
genExpr0 top (StgTick (ProfNote cc count scope) e) = do
  setSCCstats <- ifProfilingM $ setCC cc count scope
  (stats, result) <- genExpr top e
  return (setSCCstats <> stats, result)
genExpr0 top (StgTick (SourceNote span _sname) e) =
  genExpr (top & ctxSrcSpan .~ Just span) e
genExpr0 top (StgTick _m e) = genExpr top e

might_be_a_function :: HasDebugCallStack => Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
  | [LiftedRep] <- typePrimRep ty
  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
  , isDataTyCon tc
  = False
  | otherwise
  = True

matchVarName :: String -> FastString -> FastString -> Id -> Bool
matchVarName pkg modu occ (idName -> n)
  | Just m <- nameModule_maybe n =
    occ  == occNameFS (nameOccName n) &&
    modu == moduleNameFS (moduleName m) &&
    pkg `L.isPrefixOf` (unitIdString (moduleUnitId m))
  | otherwise = False

genApp :: HasDebugCallStack
       => ExprCtx
       -> Id
       -> [StgArg]
       -> G (JStat, ExprResult)
-- special cases for JSString literals
 -- we could handle unpackNBytes# here, but that's probably not common
 -- enough to warrant a special case
genApp ctx i [StgVarArg v]
   | [top] <- concatMap snd (ctx ^. ctxTarget)
   -- , Just (Lit (MachStr bs)) <- expandUnfolding_maybe (idUnfolding v)
   -- , Just t <- decodeModifiedUTF8 bs -- unpackFS fs -- Just t <- decodeModifiedUTF8 bs
   , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i =
      (,ExprInline Nothing) . assignj top . ApplExpr (ValExpr (JVar (TxtI "h$decodeUtf8z")))
        <$> genIds v
genApp ctx i [StgLitArg (MachStr bs), x]
    | [top] <- concatMap snd (ctx ^. ctxTarget), getUnique i == unpackCStringAppendIdKey, Just d <- decodeModifiedUTF8 bs = do
        -- fixme breaks assumption in codegen if bs doesn't decode
        prof <- csProf <$> use gsSettings
        let profArg = if prof then [jCafCCS] else []
        a <- genArg x
        return ([j| `top` = `ApplExpr (jsv "h$appendToHsStringA") $ [toJExpr d, toJExpr a] ++ profArg`; |]
               ,ExprInline Nothing)
genApp top i a
    | Just n <- top ^. ctxLneFrameBs . to (flip lookupUFM i) = do -- let-no-escape
        as'      <- concatMapM genArg a
        ei       <- jsEntryId i
        let ra = mconcat . reverse $
                   zipWith (\r a -> [j| `r` = `a`; |]) [R1 ..] as'
        p <- pushLneFrame n top
        a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)
        return (ra <> p <> a <> [j| return `ei`; |], ExprCont)
    | n == 0 && (isUnboxedTupleType (idType i) || isStrictType (idType i)) = do
                a <- assignAllCh1 "genApp" (top ^. ctxTarget) .
                                          (alignTarget (idTarget i)) <$> genIds i
                return (a, ExprInline Nothing)
    | [vt] <- idVt i, isUnboxable vt && n == 0 && i `elementOfUniqSet` (top ^. ctxEval) = do
                let [c] =  concatMap snd $ top ^. ctxTarget
                is <- genIds i
                case is of
                  [i'] ->
                    return ([j| `c` = (typeof `i'` === 'object') ? `i'`.d1 : `i'`; |]
                           ,ExprInline Nothing)
                  _ -> panic "genApp: invalid size"
    | n == 0 && (i `elementOfUniqSet` (top ^. ctxEval) || isStrictId i) = do
                a <- assignAllCh1 ("genApp:" ++ show i ++ " " ++ show (idFunRepArity i, idVt i))
                                 (top ^. ctxTarget) .
                                 (alignTarget (idTarget i))
                                 <$> genIds i
                settings <- use gsSettings
                let ww = case concatMap snd (top ^. ctxTarget) of
                           [t] | csAssertRts settings ->
                                   [j| if(typeof `t` === 'object' && `isThunk t`)
                                         throw "unexpected thunk";
                                     |]
                           _   -> mempty
                return (a <> ww, ExprInline Nothing)
    | DataConWrapId dc <- idDetails i, isNewTyCon (dataConTyCon dc) = do
                as <- concatMapM genArg a
                case as of
                  [ai] -> do
                    let [t] = concatMap snd (top ^. ctxTarget)
                        [StgVarArg a'] = a
                    if isStrictId a' || a' `elementOfUniqSet` (top ^. ctxEval)
                      then return ([j| `t` = `ai`; |], ExprInline Nothing)
                      else return ([j| return h$e(`ai`); |], ExprCont)
                  _ -> panic "genApp: invalid size"
    | idFunRepArity i == 0 && n == 0 && not (might_be_a_function (idType i)) = do
             ii <- enterId
             return ([j| return h$e(`ii`) |], ExprCont)
    | idFunRepArity i == n && not (isLocalId i) && isStrictId i && n /= 0 = do
        as' <- concatMapM genArg a
        jmp <- jumpToII i as' =<< r1
        return (jmp, ExprCont)
    | idFunRepArity i < n && isStrictId i && idFunRepArity i > 0 =
         let (reg,over) = splitAt (idFunRepArity i) a
         in  do
           reg' <- concatMapM genArg reg
           pc   <- pushCont over
           jmp  <- jumpToII i reg' =<< r1
           return (pc <> jmp, ExprCont)
    | otherwise = do
           jmp <- jumpToFast a =<< r1
           return (jmp, ExprCont)
  where
    enterId :: G JExpr
    enterId = genArg (StgVarArg i) >>=
                \case
                   [x] -> return x
                   xs  -> panic $ "genApp: unexpected multi-var argument (" ++ show (length xs) ++ ")\n" ++ showIndent i

    r1 :: C
    r1 = do
      ids <- genIds i
      return $ mconcat $ zipWith (\r u -> [j| `r`=`u`; |]) (enumFrom R1) ids
    n = length a

pushCont :: HasDebugCallStack
         => [StgArg]
         -> C
pushCont as = do
  as' <- concatMapM genArg as
  (app, spec) <- selectApply False (as,as')
  if spec
    then push $ reverse $ app : as'
    else push $ reverse $ app : mkTag as' as : as'
  where
    mkTag rs ns = toJExpr ((length rs `shiftL` 8) .|. length ns)

-- regular let binding: allocate heap object
genBind :: HasDebugCallStack
        => ExprCtx
        -> StgBinding
        -> G (JStat, ExprCtx)
genBind ctx bndr =
  case bndr of
    StgNonRec b r -> do
       j <- assign b r >>= \case
         Just ja -> return ja
         Nothing -> allocCls Nothing [(b,r)]
       return (j, addEvalRhs ctx [(b,r)])
    StgRec bs     -> do
       jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls
       let m = if null jas then Nothing else Just (mconcat $ catMaybes jas)
       j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs
       return (j, addEvalRhs ctx bs)
   where
     ctx' = clearCtxStack ctx

     assign :: Id -> StgRhs -> G (Maybe JStat)
     assign b (StgRhsClosure _ccs _bi [the_fv] _upd [] expr)
       | let strip = snd . stripStgTicksTop (not . tickishIsCode)
       , StgCase (StgApp scrutinee []) _ (AlgAlt _) [(DataAlt _, params, sel_expr)] <- strip expr
       , StgApp selectee [] <- strip sel_expr
       , let params_w_offsets = zip params (scanl' (+) 1 $ map (typeSize . idType) params)
       , let total_size = sum (map (typeSize . idType) params)
       , the_fv == scrutinee
       , Just the_offset <- assocMaybe params_w_offsets selectee
       , the_offset <= 16 -- fixme make this some configurable constant
       = do
           let sel_tag | the_offset == 2 = if total_size == 2 then "2a"
                                                              else "2b"
                       | otherwise       = show the_offset
           tgts <- genIdsI b
           the_fvjs <- genIds the_fv
           case (tgts, the_fvjs) of
             ([tgt], [the_fvj]) -> return $ Just
               (tgt ||= ApplExpr (ValExpr (JVar (TxtI ("h$c_sel_" <> T.pack sel_tag))))
                              [the_fvj])
             _ -> panic "genBind.assign: invalid size"
     assign b (StgRhsClosure _ccs _bi _free _upd [] expr)
       | snd (isInlineExpr (ctx ^. ctxEval) expr) = do
           d   <- declIds b
           tgt <- genIds b
           (j, _) <- genExpr (ctx & ctxTarget .~ alignTarget (idTarget b) tgt) expr
           return (Just (d <> j))
     assign b (StgRhsCon{}) = return Nothing
     assign b r             = genEntry ctx' b r >> return Nothing

     addEvalRhs c [] = c
     addEvalRhs c ((b,r):xs)
       | (StgRhsCon{}) <- r                       = addEvalRhs (addEval b c) xs
       | (StgRhsClosure _ _ _ ReEntrant _ _) <- r = addEvalRhs (addEval b c) xs
       | otherwise                                = addEvalRhs c xs

genBindLne :: HasDebugCallStack
           => ExprCtx
           -> StgBinding
           -> G (JStat, ExprCtx)
genBindLne ctx bndr =
  trace' ("genBindLne\n" ++ showIndent bndr)
         (genBindLne0 ctx bndr)

genBindLne0 :: HasDebugCallStack
            => ExprCtx
            -> StgBinding
            -> G (JStat, ExprCtx)
genBindLne0 ctx bndr = do
  vis  <- map (\(x,y,_) -> (x,y)) <$>
            optimizeFree oldFrameSize (newLvs++map fst updBinds)
  declUpds <- mconcat <$> mapM (fmap (||= jnull) . jsIdI . fst) updBinds
  let newFrameSize = oldFrameSize + length vis
      ctx' = ctx & ctxLne        %~ flip addListToUniqSet bound
                 & ctxLneFrameBs %~ flip addListToUFM (map (,newFrameSize) bound)
                 & ctxLneFrame   %~ (++vis)
  mapM_ (uncurry $ genEntryLne ctx') binds
  return (declUpds, ctx')
  where
    oldFrame     = ctx ^. ctxLneFrame
    oldFrameSize = length oldFrame
    isOldLv i    = i `elementOfUniqSet` (ctx ^. ctxLne) ||
                   i `elem` (map fst oldFrame)
    live         = liveVars $ mkDVarSet $ stgLneLive' bndr
    newLvs       = filter (not . isOldLv) (dVarSetElems live)
    binds = case bndr of
              StgNonRec b e -> [(b,e)]
              StgRec    bs  -> bs
    bound = map fst binds
    (updBinds, _nonUpdBinds) = partition (isUpdatableRhs . snd) binds

stgLneLive' :: StgBinding -> [Id]
stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b)

stgLneLive :: StgBinding -> [Id]
stgLneLive (StgNonRec _b e) = stgLneLiveExpr e
stgLneLive (StgRec bs)      = L.nub $ concatMap (stgLneLiveExpr . snd) bs

stgLneLiveExpr :: StgRhs -> [Id]
stgLneLiveExpr (StgRhsClosure _ _ l _ _ _) = l
stgLneLiveExpr (StgRhsCon {})                = []

isUpdatableRhs :: StgRhs -> Bool
isUpdatableRhs (StgRhsClosure _ _ _ u _ _) = isUpdatable u
isUpdatableRhs _                           = False

{-
  Let-no-escape entries live on the stack. There is no heap object associated with them.

  A let-no-escape entry is called like a normal stack frame, although as an optimization,
  `Stack`[`Sp`] is not set when making the call. This done later if the thread needs to
  be suspended.

  Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot
  is initially set to null, changed to h$blackhole when the thunk is being evaluated.
 -}

genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> StgRhs -> G ()
genEntryLne ctx i rhs@(StgRhsClosure _cc _bi _live2 update args body) =
  resetSlots $ do
  let payloadSize = length frame
      frame       = ctx ^. ctxLneFrame
      myOffset    =
        maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame")
              ((payloadSize-) . fst)
              (listToMaybe $ filter ((==i).fst.snd) (zip [0..] frame))
      bh | isUpdatable update =
             [j| var x = h$bh_lne(`Sp`-`myOffset`, `payloadSize+1`);
                 if(x) return(x);
               |]
         | otherwise = mempty
  lvs  <- popLneFrame True payloadSize ctx
  body <- genBody ctx i R1 args body
  ei   <- jsEntryIdI i
  sr   <- genStaticRefsRhs rhs
  let f = JFunc [] (bh <> lvs <> body)
  emitClosureInfo $
    ClosureInfo (itxt ei)
                (CIRegs 0 $ concatMap idVt args)
                (itxt ei <> ", " <> T.pack (show i))
                (fixedLayout . reverse $
                    map (stackSlotType . fst) (ctx ^. ctxLneFrame))
                CIStackFrame
                sr
  emitToplevel (ei ||= f)
genEntryLne ctx i (StgRhsCon cc con args) = resetSlots $ do
  let payloadSize = length (ctx ^. ctxLneFrame)
  ei <- jsEntryIdI i
  di <- enterDataCon con
  ii <- makeIdent
  p  <- popLneFrame True payloadSize ctx
  args' <- concatMapM genArg args
  ac    <- allocCon ii con cc args'
  emitToplevel $ ei ||= JFunc []
    (decl ii <> p <> ac <> [j| `R1` = `ii`; |] <> returnStack)

-- generate the entry function for a local closure
genEntry :: HasDebugCallStack => ExprCtx -> Id -> StgRhs -> G ()
genEntry _ _i (StgRhsCon _cc _con _args) = return () -- mempty -- error "local data entry"

genEntry ctx i rhs@(StgRhsClosure cc _bi live upd_flag args body) = resetSlots $ do
  ll    <- loadLiveFun live
  llv   <- verifyRuntimeReps live
  upd   <- genUpdFrame upd_flag i
  body  <- genBody entryCtx i R2 args body
  ei    <- jsEntryIdI i
  et    <- genEntryType args
  setcc <- ifProfiling $
             if et == CIThunk
               then enterCostCentreThunk
               else enterCostCentreFun cc
  sr <- genStaticRefsRhs rhs
  emitClosureInfo $ ClosureInfo (itxt ei)
                                (CIRegs 0 $ PtrV : concatMap idVt args)
                                (itxt ei <> ", " <> T.pack (show i))
                                (fixedLayout $ map (uTypeVt . idType) live)
                                et
                                sr
  emitToplevel (ei ||= JFunc [] (ll <> llv <> upd <> setcc <> body))
  where
    entryCtx = ExprCtx i [] (ctx ^. ctxEval) (ctx ^. ctxLne) emptyUFM [] (ctx ^. ctxSrcSpan)

genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType []   = return CIThunk
genEntryType args0 = {- trace' "genEntryType" $ -} do
  args' <- mapM genIdArg args
  return $ CIFun (length args) (length $ concat args')
  where
    args = filter (not . isRuntimeRepKindedTy . idType) args0

genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> C
genSetConInfo i d l {- srt -} = do
  ei <- jsDcEntryIdI i
  sr <- genStaticRefs l
  emitClosureInfo $ ClosureInfo (itxt ei)
                                (CIRegs 0 [PtrV])
                                (T.pack $ show d)
                                (fixedLayout $ map uTypeVt fields)
                                (CICon $ dataConTag d)
                                sr
  return (ei ||= mkDataEntry)
    where
      -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
      fields = concatMap (map primRepToType . typePrimRep . unwrapType)
                         (dataConRepArgTys d)
        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)

mkDataEntry :: JExpr
mkDataEntry = ValExpr $ JFunc [] returnStack

genUpdFrame :: UpdateFlag -> Id -> C
genUpdFrame u i
  | isReEntrant u   = mempty
  | isOneShotBndr i = maybeBh
  | isUpdatable u   = updateThunk
  | otherwise       = maybeBh
  where
    isReEntrant ReEntrant = True
    isReEntrant _         = False
    maybeBh = do
      settings <- use gsSettings
      assertRtsStat (return $ bhSingleEntry settings)

-- allocate local closures
allocCls :: Maybe JStat -> [(Id, StgRhs)] -> C
allocCls dynMiddle xs = do
   (stat, dyn) <- partitionEithers <$> mapM toCl xs
   cs <- use gsSettings
   return (mconcat stat) <> allocDynAll cs True dynMiddle dyn
  where
    -- left = static, right = dynamic
    toCl :: (Id, StgRhs)
         -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack))
    -- statics
    {- making zero-arg constructors static is problematic, see #646
       proper candidates for this optimization should have been floated
       already
      toCl (i, StgRhsCon cc con []) = do
      ii <- jsIdI i
      Left <$> (return (decl ii) <> allocCon ii con cc []) -}
    toCl (i, StgRhsCon cc con [a]) | isUnboxableCon con = do
      ii <- jsIdI i
      Left <$> (return (decl ii) <> (allocCon ii con cc =<< genArg a))

    -- dynamics
    toCl (i, StgRhsCon cc con ar) =
      -- fixme do we need to handle unboxed?
      Right <$> ((,,,) <$> jsIdI i
                       <*> enterDataCon con
                       <*> concatMapM genArg ar
                       <*> pure cc)
    toCl (i, StgRhsClosure cc _bi live _upd_flag _args _body) =
      Right <$> ((,,,) <$> jsIdI i
                       <*> jsEntryId i
                       <*> concatMapM genIds live
                       <*> pure cc)


genCase :: HasDebugCallStack
        => ExprCtx
        -> Id
        -> StgExpr
        -> AltType
        -> [StgAlt]
        -> LiveVars
        -> G (JStat, ExprResult)
genCase top bnd e at alts l =
  trace' ("genCase\n" ++ showIndent e ++ "\n" ++ unlines (map showIndent alts))
 (genCase0 top bnd e at alts l)
-- fixme CgCase has a reps_compatible check here
genCase0 :: HasDebugCallStack
        => ExprCtx
        -> Id
        -> StgExpr
        -> AltType
        -> [StgAlt]
        -> LiveVars
        -> G (JStat, ExprResult)
genCase0 top bnd e at alts l
  | snd (isInlineExpr (top ^. ctxEval) e) = withNewIdent $ \ccsVar -> do
      bndi <- genIdsI bnd
      (ej, r) <- genExpr (top & ctxTop .~ bnd
                              & ctxTarget .~ alignTarget (idTarget bnd)
                                                         (map toJExpr bndi)) e
      -- ExprCtx bnd (map toJExpr bndi) (top ^. ctxEval) (top ^. ctxLneV) (top ^. ctxLneB) (top ^. ctxLne)) e
      let d = case r of
                ExprInline d0 -> d0
                ExprCont -> panic $ "genCase: expression was not inline:\n" ++
                                    showIndent e ++ "\n" ++
                                    (TL.unpack . (<>"\n") . displayT . renderPretty 0.8 150 . pretty . jsSaturate (Just "debug") $ ej)

          ww = mempty -- if snd (isInlineExpr emptyUniqSet e) then mempty else [j| h$log('danger will robinson'); |]
      (aj, ar) <- genAlts (addEval bnd top) bnd at d alts
      saveCCS <- ifProfiling $ ccsVar |= jCurrentCCS
      restoreCCS <- ifProfiling $ [j| `jCurrentCCS` = `ccsVar`; |]
      return ( decl ccsVar <>
               mconcat (map decl bndi) <>
               saveCCS <>
               ww <>
               ej <>
               restoreCCS <>
               aj
             , ar
             )
  | otherwise = do
      rj       <- genRet (addEval bnd top) bnd at alts l
      (ej, _r) <- genExpr (top & ctxTop .~ bnd
                               & ctxTarget .~ alignTarget (idTarget bnd)
                                                          (map toJExpr [R1 ..])) e
      return (rj <> ej, ExprCont)

alignTarget :: [(PrimRep, Int)] -> [a] -> [(PrimRep, [a])]
alignTarget []     _  = []
alignTarget ((rep, size):xs) vs
  | length vs0 == size = (rep, vs0) : alignTarget xs vs1
  | otherwise          = panic "alignTarget: target size insufficient"
  where (vs0, vs1) = splitAt size vs

idTarget :: Id -> [(PrimRep, Int)]
idTarget = typeTarget . idType

typeTarget :…