/src/Gen2/Generator.hs

{-# 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 :: Type -> [(PrimRep, Int)]
typeTarget = map (\t -> (t, varSize (primRepVt t))) . typePrimRep . unwrapType

assignAll :: (ToJExpr a, ToJExpr b) => [a] -> [b] -> JStat
assignAll xs ys = mconcat (zipWith assignj xs ys)

-- assign ys to xs, checking if the lengths are compatible
assignAllCh :: (ToJExpr a, ToJExpr b) => String -> [a] -> [b] -> JStat
assignAllCh msg xs ys
  | length xs == length ys = mconcat (zipWith assignj xs ys)
  | otherwise =
     panic $ "assignAllCh: lengths do not match: " ++
             show (length xs, length ys) ++
             "\n    " ++
             msg

assignAllCh1 :: String
             -> [(PrimRep, [JExpr])]
             -> [(PrimRep, [JExpr])]
             -> JStat
assignAllCh1 msg ((rx,ex):xs) ((ry,ey):ys) =
  assignPrimReps rx ry ex ey
assignAllCh1 _   [] [] = mempty
assignAllCh1 _   _  _  =
  panic $ "assignAllCh1: lengths do not match"

-- assign p2 to p1
assignPrimReps :: PrimRep -> PrimRep -> [JExpr] -> [JExpr] -> JStat
assignPrimReps p1 p2 e1 e2
-- Allow same size assignment, even if rep is not the same
--  | p1 /= p2 && Debug.Trace.trace ("implicit conversion: " ++ show p2 ++ " -> " ++ show p1) False = undefined
  | length e1 == length e2 = mconcat (zipWith assignj e1 e2)
-- Coercion between StablePtr# and Addr#
assignPrimReps AddrRep UnliftedRep [a_val, a_off] [sptr] =
  [j| `a_val` = h$stablePtrBuf; `a_off` = `sptr`; |]
assignPrimReps UnliftedRep AddrRep [sptr] [a_val, a_off] =
  [j| `sptr` = `a_off`; |]
assignPrimReps p1 p2 e1 e2 =
  let sr r s = show r ++ " (size " ++ show (length s) ++ ")"
  in  panic $ "cannot assign " ++ sr p2 e2 ++ " to " ++ sr p1 e1

genRet :: HasDebugCallStack
       => ExprCtx
       -> Id
       -> AltType
       -> [StgAlt]
       -> LiveVars
       -> C
genRet ctx e at as l = -- withNewIdent f
  trace' ("genRet" ++ unlines (map showIndent as))
         (genRet0 ctx e at as l)

genRet0 :: HasDebugCallStack
       => ExprCtx
       -> Id
       -> AltType
       -> [StgAlt]
       -> LiveVars
       -> C
genRet0 ctx e at as l = withNewIdent f
  where
    allRefs :: [Id]
    allRefs =  S.toList . S.unions $ as ^.. traverse . _3 . to (exprRefs emptyUFM)
    lneLive :: Int
    lneLive    = maximum $ 0 : map (fromMaybe 0 . lookupUFM (ctx ^. ctxLneFrameBs)) allRefs
    ctx'       = adjustCtxStack lneLive ctx
    lneVars    = map fst $ take lneLive (ctx ^. ctxLneFrame)
    isLne i    = i `elem` lneVars || i `elementOfUniqSet` (ctx ^. ctxLne)
    nonLne     = filter (not . isLne) (dVarSetElems l)

    f :: Ident -> C
    f r    =  do
      pushLne  <- pushLneFrame lneLive ctx
      saveCCS  <- ifProfilingM $ push [jCurrentCCS]
      free     <- trace' ("nonLne: " ++ show nonLne) (optimizeFree 0 nonLne)
      pushRet  <- pushRetArgs free (iex r)
      fun'     <- fun free
      sr       <- genStaticRefs l -- srt
      prof     <- profiling
      emitClosureInfo $
        ClosureInfo (itxt r)
                    (CIRegs 0 altRegs)
                    (itxt r)
                    (fixedLayout . reverse $
                       map (stackSlotType . fst3) free
                       ++ if prof then [ObjV] else []
                       ++ map stackSlotType lneVars)
                    CIStackFrame
                    sr
      emitToplevel $ r ||= JFunc [] fun'
      return (pushLne <> saveCCS <> pushRet)
    fst3 ~(x,_,_)  = x

    altRegs :: HasDebugCallStack => [VarType]
    altRegs = case at of
      PrimAlt ptc    -> [primRepVt ptc]
      MultiValAlt _n -> idVt e
      _              -> [PtrV]

    fun free = resetSlots $ do
      decs          <- declIds e
      load          <- flip assignAll [R1 ..] <$> genIdsI e
      loadv         <- verifyRuntimeReps [e]
      ras           <- loadRetArgs free
      rasv          <- verifyRuntimeReps (map (\(x,_,_)->x) free)
      restoreCCS    <- ifProfilingM $ popUnknown [jCurrentCCS]
      rlne          <- popLneFrame False lneLive ctx'
      rlnev         <- verifyRuntimeReps (map fst $ take lneLive (ctx' ^. ctxLneFrame))
      (alts, _altr) <- genAlts ctx' e at Nothing as
      return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <>
               returnStack


-- 2-var values might have been moved around separately, use DoubleV as substitute
-- ObjV is 1 var, so this is no problem for implicit metadata
stackSlotType :: Id -> VarType
stackSlotType i
  | varSize otype == 1 = otype
  | otherwise          = DoubleV
  where otype = uTypeVt (idType i)

popLneFrame :: Bool -> Int -> ExprCtx -> C
popLneFrame inEntry size ctx
  | l < size  = panic $ "popLneFrame: let-no-escape frame too short: " ++
                        show l ++ " < " ++ show size
  | otherwise = popSkipI skip
                  =<< mapM (\(i,n) -> (,SlotId i n) <$> genIdsIN i n)
                           (take size $ ctx ^. ctxLneFrame)
  where
    skip = if inEntry then 1 else 0 -- pop the frame header
    l    = ctx ^. ctxLneFrame . to length

pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> C
pushLneFrame size ctx
  | l < size  = panic $ "pushLneFrame: let-no-escape frame too short " ++
                        show l ++ " < " ++ show size
  | otherwise = pushOptimized' (take size $ ctx ^. ctxLneFrame)
  where
    l = ctx ^. ctxLneFrame . to length

-- reorder the things we need to push to reuse existing stack values as much as possible
-- True if already on the stack at that location
optimizeFree :: HasDebugCallStack => Int -> [Id] -> G [(Id,Int,Bool)]
optimizeFree offset ids = do
  -- this line goes wrong                               vvvvvvv
  let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids
      idSize :: Id -> Int
      idSize i = let s = idSize0 i in trace' ("idSize: " ++ show i ++ " -> " ++ show s) s
      idSize0 :: Id -> Int
      idSize0 i = sum $ map varSize (typeVt . idType $ i)
      ids' = concat $ map (\i -> map (i,) [1..idSize i]) ids
      -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids)
      l    = length ids'
  slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots
  let slm                = M.fromList (zip slots [0..])
      (remaining, fixed) = partitionEithers $
         map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True))
            (M.lookup (SlotId i n) slm)) ids'
      takenSlots         = S.fromList (fixed ^.. traverse . _3)
      freeSlots          = filter (`S.notMember` takenSlots) [0..l-1]
      remaining'         = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots
      allSlots           = sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining')
  return $ map (\(i,n,_,b) -> (i,n,b)) allSlots

(!!!) :: HasDebugCallStack => [a] -> Int -> a
xs !!! n = case (drop n xs) of
            x:_ -> x
            _   -> error "list too short"

pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> C
pushRetArgs free fun = do
  p <- pushOptimized . (++[(fun,False)]) =<< mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free
  return p

loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> C
loadRetArgs free = popSkipI 1 =<< ids
    where
       ids = mapM (\(i,n,_b) -> (!!!(n-1)) <$> genIdStackArgI i) free

genAlts :: HasDebugCallStack
        => ExprCtx        -- ^ lhs to assign expression result to
        -> Id             -- ^ id being matched
        -> AltType        -- ^ type
        -> Maybe [JExpr]  -- ^ if known, fields in datacon from earlier expression
        -> [StgAlt]       -- ^ the alternatives
        -> G (JStat, ExprResult)
genAlts top e at me as =
  trace''
  ("genAlts0\n" ++ unlines ([{- show top, -} show e, show at] ++ map show as)) $ do
    ver <- verifyMatchRep e at
    (st, er) <- genAlts0 top e at me as
    pure (ver <> st, er)
  --(\(_,s,r) -> (s,r)) <$> mkAlgBranch top e alt


genAlts0 :: HasDebugCallStack
         => ExprCtx        -- ^ lhs to assign expression result to
         -> Id             -- ^ id being matched
         -> AltType        -- ^ type
         -> Maybe [JExpr]  -- ^ if known, fields in datacon from earlier expression
         -> [StgAlt]       -- ^ the alternatives
         -> G (JStat, ExprResult)
genAlts0 top e PolyAlt _ [alt] = (\(_,s,r) -> (s,r)) <$> mkAlgBranch top e alt
genAlts0 _   _ PolyAlt _ _ = panic "genAlts: multiple polyalt"
genAlts0 top e (PrimAlt _tc) _ [(_, bs, expr)] = do
  ie       <- genIds e
  dids     <- mconcat (map declIds bs)
  bss      <- concatMapM genIds bs
  (ej, er) <- genExpr top expr
  return (dids <> assignAll bss ie <> ej, er)
genAlts0 top e (PrimAlt tc) _ alts = do
  ie <- genIds e
  (r, bss) <- normalizeBranches top <$>
     mapM (isolateSlots . mkPrimIfBranch top [primRepVt tc]) alts
  setSlots []
  return (mkSw ie bss, r)
genAlts0 top e (MultiValAlt n) _ [(_, bs, expr)] = do
  eids     <- genIds e
  l        <- loadUbxTup eids bs n
  (ej, er) <- genExpr top expr
  return (l <> ej, er)
genAlts0 _   _ (AlgAlt tc) _ [_alt] | isUnboxedTupleTyCon tc =
  panic "genAlts: unexpected unboxed tuple"
genAlts0 top _ (AlgAlt _tc) (Just es) [(DataAlt dc, bs, expr)]
  | not (isUnboxableCon dc) = do
      bsi <- mapM genIdsI bs
      let args = zipWith (\i de -> i ||= de) (concat bsi) es
      (ej, er) <- genExpr top expr
      return (mconcat args <> ej, er)
genAlts0 top e (AlgAlt _tc) _ [alt] = do
  (_,s,r) <- mkAlgBranch top e alt
  return (s, r)
genAlts0 top e (AlgAlt _tc) _ alts@[(DataAlt dc,_,_),_]
  | isBoolTy (dataConType dc) = do
      i <- jsId e
      nbs <- normalizeBranches top <$>
          mapM (isolateSlots . mkAlgBranch top e) alts
      case nbs of
        (r, [(_,s1,_), (_,s2,_)]) -> do
          let s = if   dataConTag dc == 2
                  then [j| if(`i`) { `s1` } else { `s2` } |]
                  else [j| if(`i`) { `s2` } else { `s1` } |]
          setSlots []
          return (s, r)
        _ -> error "genAlts: invalid branches for Bool"
-- fixme, add all alts
genAlts0 top e (AlgAlt _tc) _ alts = do
      ei <- jsId e
      (r, brs) <- normalizeBranches top <$>
          mapM (isolateSlots . mkAlgBranch top e) alts
      setSlots []
      return (mkSwitch [je| `ei`.f.a |] brs, r)
genAlts0 _  _ a _ l = do
  ap <- showPpr' a
  panic $ "genAlts: unhandled case variant: " ++
          ap ++
          " (" ++
          show (length l) ++
          ")"

-- if one branch ends in a continuation but another is inline,
-- we need to adjust the inline branch to use the continuation convention
normalizeBranches :: ExprCtx
                  -> [(a, JStat, ExprResult)]
                  -> (ExprResult, [(a, JStat, ExprResult)])
normalizeBranches e brs
    | all (==ExprCont) (brs ^.. traverse . _3) =
        (ExprCont, brs)
    | branchResult (brs ^.. traverse  ._3) == ExprCont =
        (ExprCont, map mkCont brs)
    | otherwise =
        (ExprInline Nothing, brs)
  where
    mkCont (me, s, ExprInline{}) = ( me
                                   , s <> assignAll (enumFrom R1)
                                                    (concatMap snd $ e ^. ctxTarget)
                                   , ExprCont)
    mkCont x                     = x

loadUbxTup :: [JExpr] -> [Id] -> Int -> C
loadUbxTup es bs _n = do
  bs' <- concatMapM genIdsI bs
  return $ mconcat $ zipWith (||=) bs' es

mkSw :: [JExpr] -> [(Maybe [JExpr], JStat, ExprResult)] -> JStat
mkSw [e] cases = mkSwitch e (over (mapped._1.mapped) head cases)
mkSw es cases  = mkIfElse es cases

-- switch for pattern matching on constructors or prims
mkSwitch :: JExpr -> [(Maybe JExpr, JStat, ExprResult)] -> JStat
mkSwitch e cases
    | [(Just c1,s1,_)] <- n, [(_,s2,_)] <- d =
        IfStat [je| `e` === `c1` |] s1 s2
    | [(Just c1,s1,_),(_,s2,_)] <- n, null d =
        IfStat [je| `e` === `c1` |] s1 s2
    | null d =
        SwitchStat e (map addBreak (init n)) (last n ^. _2)
    | [(_,d0,_)] <- d =
        SwitchStat e (map addBreak n) d0
    | otherwise = panic "mkSwitch: multiple default cases"
    where
      addBreak (Just c, s, _) = (c, s <> [j| break; |])
      addBreak _              = panic "mkSwitch: addBreak"
      (n,d) = partition (isJust . (^. _1)) cases

-- if/else for pattern matching on things that js cannot switch on
mkIfElse :: [JExpr] -> [(Maybe [JExpr], JStat, ExprResult)] -> JStat
mkIfElse e s = go (reverse $ sort s)
    where
      go [] = panic "mkIfElse: empty expression list"
      go [(_, s, _)] = s -- only one 'nothing' allowed
      go ((Just e0, s, _):xs) =
          [j| if( `mkEq e e0` ) { `s` } else { `go xs` } |]
      go _ = panic "mkIfElse: multiple DEFAULT cases"

mkEq :: [JExpr] -> [JExpr] -> JExpr
mkEq es1 es2
  | length es1 == length es2 = foldl1 and (zipWith eq es1 es2)
  | otherwise                = panic "mkEq: incompatible expressions"
    where
      and e1 e2 = [je| `e1` && `e2`  |]
      eq  e1 e2 = [je| `e1` === `e2` |]


mkAlgBranch :: ExprCtx  -- ^ toplevel id for the result
            -> Id      -- ^ datacon to match
            -> StgAlt  -- ^ match alternative with binders
            -> G (Maybe JExpr, JStat, ExprResult)
mkAlgBranch top d (DataAlt dc,[b],expr)
  | isUnboxableCon dc = do
      idd      <- jsId d
      fldx <- genIdsI b
      case fldx of
        [fld] -> do
          (ej, er) <- genExpr top expr
          return (Nothing, decl fld <> [j| `fld` = `idd` |] <> ej, er)
        _ -> panic "mkAlgBranch: invalid size"
mkAlgBranch top d (a, bs, expr) = do
  cc       <- caseCond a
  idd      <- jsId d
  b        <- loadParams idd bs
  (ej, er) <- genExpr top expr
  return (cc, b <> ej, er)

mkPrimIfBranch :: ExprCtx
               -> [VarType]
               -> StgAlt
               -> G (Maybe [JExpr], JStat, ExprResult)
mkPrimIfBranch top _vt (cond, _, e) =
  (\ic (ej,er) -> (ic,ej,er)) <$> ifCond cond <*> genExpr top e

-- fixme are bool things always checked correctly here?
ifCond :: AltCon -> G (Maybe [JExpr])
ifCond (DataAlt da) = return $ Just [[je| `dataConTag da` |]]
ifCond (LitAlt l)   = Just <$> genLit l
ifCond DEFAULT      = return Nothing

caseCond :: AltCon -> G (Maybe JExpr)
caseCond (DataAlt da) = return $ Just [je| `dataConTag da` |]
caseCond (LitAlt l)   = Just <$> genSingleLit l
caseCond DEFAULT      = return Nothing

-- load parameters from constructor
-- fixme use single tmp var for all branches
loadParams :: JExpr -> [Id] -> C
loadParams from args = do
  as <- concat <$> sequence (zipWith (\a u -> map (,u) <$> genIdsI a) args use)
  return $ case as of
    []                 -> mempty
    [(x,u)]            -> loadIfUsed [je| `from`.d1 |] x  u
    [(x1,u1),(x2,u2)]  -> loadIfUsed [je| `from`.d1 |] x1 u1 <>
                          loadIfUsed [je| `from`.d2 |] x2 u2
    ((x,u):xs)         -> loadIfUsed [je| `from`.d1 |] x  u  <>
                          [j| var d = `from`.d2;
                              `loadConVarsIfUsed d xs`;
                            |]
  where
    use = repeat True -- fixme clean up
    loadIfUsed fr tgt True = decl' tgt fr
    loadIfUsed  _ _ _  = mempty

    loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..]
      where f (x,u) n = loadIfUsed (SelExpr fr (dataFields ! n)) x u


genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp top op args t = do

  as <- concatMapM genArg args
  df <- use gsDynFlags
  -- fixme: should we preserve/check the primreps?
  return $ case genPrim df t op (map toJExpr . concatMap snd $ top ^. ctxTarget) as of
             PrimInline s -> (s, ExprInline Nothing)
             PRPrimCall s -> (s, ExprCont)

genArg :: HasDebugCallStack => StgArg -> G [JExpr]
genArg (StgLitArg l) = genLit l
genArg a@(StgVarArg i) = do
  unFloat <- use gsUnfloated
  case lookupUFM unFloat i of
    Nothing -> reg
    Just expr -> unfloated expr
   where
     -- if our argument is a joinid, it can be an unboxed tuple
     r :: HasDebugCallStack => VarType
     r = trace' ("r: " ++ showIndent a) r0
     r0 :: HasDebugCallStack => VarType
     r0 = uTypeVt . stgArgType $ a
     reg
       | isVoid r     = return []
       | i == trueDataConId  = return [ [je| true  |] ]
       | i == falseDataConId = return [ [je| false |] ]
       | isMultiVar r = mapM (jsIdN i) [1..varSize r]
       | otherwise    = (:[]) <$> jsId i

     unfloated :: HasDebugCallStack => StgExpr -> G [JExpr]
     unfloated (StgLit l) = genLit l
     unfloated (StgConApp dc args _)
       | isBoolTy (dataConType dc) || isUnboxableCon dc =
           (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args
       | null args = (:[]) <$> jsId (dataConWorkId dc)
       | otherwise = do
           as <- concat <$> mapM genArg args
           e  <- enterDataCon dc
           cs <- use gsSettings
           return [allocDynamicE cs e as Nothing] -- FIXME: ccs
     unfloated x = panic $ "genArg: unexpected unfloated expression: " ++
                           show x

genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg (StgLitArg l) = map StaticLitArg <$> genStaticLit l
genStaticArg a@(StgVarArg i) = do
  unFloat <- use gsUnfloated
  case lookupUFM unFloat i of
    Nothing -> reg
    Just expr -> unfloated expr
   where
     r = uTypeVt . stgArgType $ a
     reg
       | isVoid r            =
           return []
       | i == trueDataConId  =
           return [StaticLitArg (BoolLit True)]
       | i == falseDataConId =
           return [StaticLitArg (BoolLit False)]
       | isMultiVar r        =
           map (\(TxtI t) -> StaticObjArg t) <$> mapM (jsIdIN i) [1..varSize r] -- this seems wrong, not an obj?
       | otherwise           = (\(TxtI it) -> [StaticObjArg it]) <$> jsIdI i

     unfloated :: StgExpr -> G [StaticArg]
     unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l
     unfloated (StgConApp dc args _)
       | isBoolTy (dataConType dc) || isUnboxableCon dc =
           (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon?
       | null args = (\(TxtI t) -> [StaticObjArg t]) <$> jsIdI (dataConWorkId dc)
       | otherwise = do
           as       <- concat <$> mapM genStaticArg args
           (TxtI e) <- enterDataConI dc
           return [StaticConArg e as]
     unfloated x = panic ("genArg: unexpected unfloated expression: " ++ show x)

allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList xs a@(StgVarArg i)
  | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing
  | otherwise = do
      unFloat <- use gsUnfloated
      case lookupUFM unFloat i of
        Just (StgConApp dc [h,t] _)
          | dc == consDataCon -> allocateStaticList (h:xs) t
        _ -> listAlloc xs (Just a)
  where
    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
    listAlloc xs Nothing  = do
      as <- concat . reverse <$> mapM genStaticArg xs
      return (StaticList as Nothing)
    listAlloc xs (Just r) = do
      as <- concat . reverse <$> mapM genStaticArg xs
      r' <- genStaticArg r
      case r' of
        [StaticObjArg ri] -> return (StaticList as (Just ri))
        _                 ->
          panic $ "allocateStaticList: invalid argument (tail): " ++
                  show xs ++
                  " " ++
                  show r
allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list"

-- generate arg to be passed to FFI call, with marshalling JStat to be run
-- before the call
genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l
genFFIArg isJavaScriptCc a@(StgVarArg i)
    | not isJavaScriptCc &&
      (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) = do
        (\x -> (mempty,[x,jint 0])) <$> jsId i
    | isVoid r                  = return (mempty, [])
--    | Just x <- marshalFFIArg a = x
    | isMultiVar r              = (mempty,) <$> mapM (jsIdN i) [1..varSize r]
    | otherwise                 = (\x -> (mempty,[x])) <$> jsId i
   where
     tycon  = tyConAppTyCon (unwrapType arg_ty)
     arg_ty = stgArgType a
     r      = uTypeVt arg_ty

genIdArg :: HasDebugCallStack => Id -> G [JExpr]
genIdArg i = genArg (StgVarArg i)

genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI i = trace' ("genIdArgI: " ++ show i) (genIdArgI0 i)

genIdArgI0 :: HasDebugCallStack => Id -> G [Ident]
genIdArgI0 i
    | isVoid r     = return []
    | isMultiVar r = mapM (jsIdIN i) [1..varSize r]
    | otherwise    = (:[]) <$> jsIdI i
    where
      r = uTypeVt . idType $ i


genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
genIdStackArgI i = zipWith f [1..] <$> genIdArgI i
  where
    f :: Int -> Ident -> (Ident,StackSlot)
    f n ident = (ident, SlotId i n)

r2d :: Rational -> Double
r2d = realToFrac

r2f :: Rational -> Double
r2f = float2Double . realToFrac

genStrThunk :: HasDebugCallStack
            => Id
            -> Bool
            -> B.ByteString
            -> CostCentreStack
            -> C
genStrThunk i nonAscii str cc = do
  ii@(TxtI iit) <- jsIdI i
  let d = decl ii
  ccs <- costCentreStackLbl cc
  let ccsArg = map toJExpr $ maybeToList ccs
  emitStatic iit (StaticThunk Nothing) Nothing
  return $ case decodeModifiedUTF8 str of
    Just t -> d <>
      if nonAscii
      then [j| `ii` =  `ApplExpr (jvar "h$strt") $
               [toJExpr $ T.unpack t] ++ ccsArg`; |]
      else [j| `ii` =  `ApplExpr (jvar "h$strta") $
               [toJExpr $ T.unpack t] ++ ccsArg`; |]
    Nothing -> d <>
      if nonAscii
      then [j| `ii` = `ApplExpr (jvar "h$strtb") $
               [toJExpr $ map toInteger (B.unpack str)] ++ ccsArg`; |]
      else [j| `ii` = `ApplExpr (jvar "h$strta") $
               [toJExpr $ map (chr.fromIntegral) (B.unpack str)] ++ ccsArg`; |]

genLit :: HasDebugCallStack => Literal -> G [JExpr]
genLit (MachChar c)      = return [ [je| `ord c` |] ]
genLit (MachStr  str)    =
  withNewIdent $ \strLit@(TxtI strLitT) ->
    withNewIdent $ \strOff@(TxtI strOffT) -> do
      emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing
      emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
      return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ]
genLit MachNullAddr      = return [ [je| null |], [je| 0 |] ]
genLit (LitNumber LitNumInt i _)       = return [ [je| `intLit i` |] ]
genLit (LitNumber LitNumInt64 i _)     = return [ [je| `intLit (shiftR i 32)` |]
                                  , [je| `toSigned i` |]
                                  ]
genLit (LitNumber LitNumWord w _)      = return [ [je| `toSigned w` |] ]
genLit (LitNumber LitNumWord64 w _)    = return [ [je| `toSigned (shiftR w 32)` |]
                                  , [je| `toSigned w` |]
                                  ]
genLit (MachFloat r)     = return [ [je| `r2f r` |] ]
genLit (MachDouble r)    = return [ [je| `r2d r` |] ]
genLit (MachLabel name _size fod)
  | fod == IsFunction = return [ [je| h$mkFunctionPtr(`TxtI . T.pack $ "h$" ++ unpackFS name`) |], [je| 0 |] ]
  | otherwise         = return [ iex (TxtI . T.pack $ "h$" ++ unpackFS name), [je| 0 |] ]
genLit l = panic $ "genLit: " ++ show l -- unhandled numeric literal" -- removed by CorePrep

-- | generate a literal for the static init tables
genStaticLit :: Literal -> G [StaticLit]
genStaticLit (MachChar c)         = return [ IntLit (fromIntegral $ ord c) ]
genStaticLit (MachStr  str)       =
  case T.decodeUtf8' str of
                         Right t -> return [ StringLit t, IntLit 0 ]
                         Left _  -> return [ BinLit str, IntLit 0]
genStaticLit MachNullAddr         = return [ NullLit, IntLit 0 ]
genStaticLit (LitNumber LitNumInt i _)          = return [ IntLit (fromIntegral i) ]
genStaticLit (LitNumber LitNumInt64 i _)        = return [ IntLit (i `shiftR` 32)
                                           , IntLit (toSigned i)
                                           ]
genStaticLit (LitNumber LitNumWord w _)         = return [ IntLit (toSigned w) ]
genStaticLit (LitNumber LitNumWord64 w _)       = return [ IntLit (toSigned (w `shiftR` 32))
                                           , IntLit (toSigned w)
                                           ]
genStaticLit (MachFloat r)        = return [ DoubleLit . SaneDouble . r2f $ r ]
genStaticLit (MachDouble r)       = return [ DoubleLit . SaneDouble . r2d $ r ]
genStaticLit (MachLabel name _size fod) =
  return [ LabelLit (fod == IsFunction) (T.pack $ "h$" ++ unpackFS name)
         , IntLit 0
         ]
genStaticLit l = panic $ "genStaticLit: " ++
                         show l

-- make a signed 32 bit int from this unsigned one, lower 32 bits
toSigned :: Integer -> Integer
toSigned i | testBit i 31 = complement (0x7FFFFFFF `xor` (i.&.0x7FFFFFFF))
           | otherwise    = i.&.0xFFFFFFFF

-- truncate literal to fit in 32 bit int
intLit :: Integer -> Integer
intLit i = fromIntegral (fromIntegral i :: Int32)

genSingleLit :: Literal -> G JExpr
genSingleLit l = do
  es <- genLit l
  case es of
    [e] -> return e
    _   -> panic "genSingleLit: expected single-variable literal"

genCon :: ExprCtx -> DataCon -> [JExpr] -> C
genCon tgt con args
  -- fixme should we check the primreps here?
  | isUnboxedTupleCon con && length (concatMap snd $ tgt^.ctxTarget) == length args =
      return $ assignAll (concatMap snd $ tgt ^. ctxTarget) args
genCon tgt con args | isUnboxedTupleCon con =
  panic ("genCon: unhandled DataCon:\n" ++
         show con ++ "\n" ++
         show (tgt ^. ctxTop) ++ "\n" ++
         show (tgt ^. ctxTarget) ++ "\n" ++
         show args)
genCon tgt con args | [ValExpr (JVar tgti)] <- concatMap snd (tgt ^. ctxTarget) =
  allocCon tgti con currentCCS args
genCon tgt con args =
  return mempty -- fixme, do we get missing VecRep things because of this?
  -- panic ("genCon: unhandled DataCon: " ++ show con ++ " " ++ show (tgt ^. ctxTop, length args))

allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> C
allocCon to con cc xs
  | isBoolTy (dataConType con) || isUnboxableCon con = do
      return [j| `to` = `allocUnboxedCon con xs`; |]
{-  | null xs = do
      i <- jsId (dataConWorkId con)
      return (assignj to i) -}
  | otherwise = do
      e <- enterDataCon con
      cs <- use gsSettings
      prof <- profiling
      ccsJ <- if prof then ccsVarJ cc else return Nothing
      return $ allocDynamic cs False to e xs ccsJ

allocUnboxedCon :: DataCon -> [JExpr] -> JExpr
allocUnboxedCon con []
  | isBoolTy (dataConType con) && dataConTag con == 1 = [je| false |]
  | isBoolTy (dataConType con) && dataConTag con == 2 = [je| true  |]
allocUnboxedCon con [x]
  | isUnboxableCon con = x
allocUnboxedCon con xs = panic ("allocUnboxedCon: not an unboxed constructor: " ++ show con ++ " " ++ show xs)

allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic con []
  | isBoolTy (dataConType con) && dataConTag con == 1 =
      StaticLitArg (BoolLit False)
  | isBoolTy (dataConType con) && dataConTag con == 2 =
      StaticLitArg (BoolLit True)
allocUnboxedConStatic _   [a@(StaticLitArg (IntLit _i))]    = a
allocUnboxedConStatic _   [a@(StaticLitArg (DoubleLit _d))] = a
allocUnboxedConStatic con _                                =
  panic ("allocUnboxedConStatic: not an unboxed constructor: " ++ show con)

allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [GenStgArg Id] {- -> Bool -} -> G ()
allocConStatic (TxtI to) cc con args -- isRecursive
{-  | trace' ("allocConStatic: " ++ show to ++ " " ++ show con ++ " " ++ show args) True -} = do
  as <- mapM genStaticArg args
  cc' <- costCentreStackLbl cc
  allocConStatic' cc' (concat as)
  where
    allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
    allocConStatic' cc' []
      | isBoolTy (dataConType con) && dataConTag con == 1 =
           emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc'
      | isBoolTy (dataConType con) && dataConTag con == 2 =
           emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
      | otherwise = do
           (TxtI e) <- enterDataConI con
           emitStatic to (StaticData e []) cc'
    allocConStatic' cc' [x]
      | isUnboxableCon con =
        case x of
          StaticLitArg (IntLit i)    ->
            emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc'
          StaticLitArg (BoolLit b)   ->
            emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc'
          StaticLitArg (DoubleLit d) ->
            emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc'
          _                          ->
            panic $ "allocConStatic: invalid unboxed literal: " ++ show x
    allocConStatic' cc' xs =
           if con == consDataCon
              then flip (emitStatic to) cc' =<< allocateStaticList [args !!! 0] (args !!! 1)
              else do
                (TxtI e) <- enterDataConI con
                emitStatic to (StaticData e xs) cc'

-- avoid one indirection for global ids
-- fixme in many cases we can also jump directly to the entry for local?
jumpToII :: Id -> [JExpr] -> JStat -> C
jumpToII i args afterLoad
  | isLocalId i = do
     ii <- jsId i
     return (ra <> afterLoad <> [j| return `ii`.f; |])
  | otherwise   = do
     ei <- jsEntryId i
     return (ra <> afterLoad <> [j| return `ei`; |])
  where
    ra = mconcat . reverse $ zipWith (\r a -> [j| `r` = `a`; |]) (enumFrom R2) args

jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> C
jumpToFast as afterLoad = do
  regs <- concatMapM genArg as
  (fun, spec) <- selectApply True (as,regs)
  if spec
    then return $ mconcat (ra regs) <> afterLoad <> [j| return `fun`(); |]
    else return $ mconcat (ra regs) <> afterLoad <> [j| return `fun`(`mkTag regs as`); |]
    where
      ra regs   = reverse $ zipWith (\r e -> [j| `r` = `e` |]) (enumFrom R2) regs
      mkTag rs as = (length rs `shiftL` 8) .|. length as


-- find a specialized application path if there is one
selectApply :: Bool           -- ^ true for fast apply, false for stack apply
            -> ([StgArg], [JExpr])       -- ^ arguments
            -> G (JExpr,Bool) -- ^ the function to call, true if specialized path
selectApply fast (args, as) = do
  case specApply fast (length args) (length as) of
    Just e  -> return (e, True)
    Nothing -> return (jsv $ "h$ap_gen" <> fastSuff, False)
  where
    fastSuff | fast      = "_fast"
             | otherwise = ""

-- fixme: what if the call returns a thunk?
genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimCall top (PrimCall lbl _) args t = do
  j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (map toJExpr . concatMap snd $ top ^. ctxTarget) args
  return (j, ExprInline Nothing)

getObjectKeyValuePairs :: [StgArg] -> Maybe [(Text, StgArg)]
getObjectKeyValuePairs [] = Just []
getObjectKeyValuePairs (k:v:xs)
  | Just t <- argJSStringLitUnfolding k =
      fmap ((t,v):) (getObjectKeyValuePairs xs)
getObjectKeyValuePairs _ = Nothing

argJSStringLitUnfolding :: StgArg -> Maybe Text
argJSStringLitUnfolding (StgVarArg v)
  | False = Just "abc" -- fixme
argJSStringLitUnfolding _ = Nothing

genForeignCall :: HasDebugCallStack
               => ExprCtx
               -> ForeignCall
               -> Type
               -> [JExpr]
               -> [StgArg]
               -> G (JStat, ExprResult)
genForeignCall top
               (CCall (CCallSpec (StaticTarget _ tgt Nothing True)
                                 JavaScriptCallConv
                                 PlayRisky))
               t
               [obj]
               args
  | tgt == fsLit "h$buildObject"
  , Just pairs <- getObjectKeyValuePairs args = do
      pairs' <- mapM (\(k,v) -> genArg v >>= \([v']) -> return (k,v')) pairs
      return ( assignj obj (ValExpr (JHash $ M.fromList pairs'))
             , ExprInline Nothing
             )
genForeignCall top (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
  emitForeign (top ^. ctxSrcSpan) (T.pack lbl) safety cconv (map showArgType args) (showType t)
  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args
  where
    isJsCc = cconv == JavaScriptCallConv

    lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget
            = let clbl' = unpackFS clbl
              in  if | isJsCc -> clbl'
                     | wrapperPrefix `L.isPrefixOf` clbl' ->
                         ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))
                     | otherwise -> "h$" ++ clbl'
        | otherwise = "h$callDynamic"

    exprResult | async     = ExprCont
               | otherwise = ExprInline Nothing

    catchExcep = (cconv == JavaScriptCallConv) &&
                 playSafe safety || playInterruptible safety

    async | isJsCc    = playInterruptible safety
          | otherwise = playInterruptible safety || playSafe safety

    tgt'  | async     = take (length tgt) (map toJExpr $ enumFrom R1)
          | otherwise = tgt

    wrapperPrefix = "ghczuwrapperZC"

-- | generate the actual call
{-
  parse FFI patterns:
   "&value         -> value
  1. "function"      -> ret = function(...)
  2. "$r = $1.f($2)  -> r1 = a1.f(a2)

  arguments, $1, $2, $3 unary arguments
     $1_1, $1_2, for a binary argument

  return type examples
  1. $r                      unary return
  2. $r1, $r2                binary return
  3. $r1, $r2, $r3_1, $r3_2  unboxed tuple return
 -}
parseFFIPattern :: Bool  -- ^ catch exception and convert them to haskell exceptions
                -> Bool  -- ^ async (only valid with javascript calling conv)
                -> Bool  -- ^ using javascript calling convention
                -> String
                -> Type
                -> [JExpr]
                -> [StgArg]
                -> C
parseFFIPattern catchExcep async jscc pat t es as
  | catchExcep = do
      c <- parseFFIPatternA async jscc pat t es as
      return [j| try {
                   `c`;
                 } catch(e) {
                   return h$throwJSException(e);
                 }
               |]
  | otherwise  = parseFFIPatternA async jscc pat t es as

parseFFIPatternA :: Bool  -- ^ async
                 -> Bool  -- ^ using JavaScript calling conv
                 -> String
                 -> Type
                 -> [JExpr]
                 -> [StgArg]
                 -> C
-- async calls get an extra callback argument
-- call it with the result
parseFFIPatternA True True pat t es as  = do
  cb <- makeIdent
  stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as
  return [j| `decl cb`;
             var x = { mv: null };
             `cb` = h$mkForeignCallback(x);
             `stat`;
             if(x.mv === null) {
               x.mv = new h$MVar();
               `Sp` = `Sp` + 1;
               `Stack`[`Sp`] = h$unboxFFIResult;
               return h$takeMVar(x.mv);
             } else {
               var d = x.mv;
               `copyResult d`;
             }
           |]
     where nrst = typeSize t
           copyResult d = assignAll es (map (\i -> [je| `d`[`i`] |]) [0..nrst-1])
parseFFIPatternA _async javascriptCc pat t es as =
  parseFFIPattern' Nothing javascriptCc pat t es as

-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous"

parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async
                 -> Bool        -- ^ javascript calling convention used
                 -> String      -- ^ pattern called
                 -> Type        -- ^ return type
                 -> [JExpr]     -- ^ expressions to return in (may be more than necessary)
                 -> [StgArg]    -- ^ arguments
                 -> C
parseFFIPattern' callback javascriptCc pat t ret args
  | not javascriptCc = mkApply pat
  | otherwise = do
      u <- freshUnique
      case parseFfiJME pat u of
        Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat
        Right expr | not async && length tgt < 2 -> do
          (statPre, ap) <- argPlaceholders javascriptCc args
          let rp  = resultPlaceholders async t ret
              env = M.fromList (rp ++ ap)
          if length tgt == 1
            then return $ statPre <> (everywhere (mkT $ replaceIdent env) [j| $r = `expr`; |])
            else return $ statPre <> (everywhere (mkT $ replaceIdent env) (toStat expr))
        Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++
                       " imports with result size 0 or 1.\n" ++ pat
        Left _ -> case parseFfiJM pat u of
          Left err -> p (show err)
          Right stat -> do
            let rp = resultPlaceholders async t ret
            let cp = callbackPlaceholders callback
            (statPre, ap) <- argPlaceholders javascriptCc args
            let env = M.fromList (rp ++ ap ++ cp)
            return $ statPre <> (everywhere (mkT $ replaceIdent env) stat) -- fixme trace?
  where
    async = isJust callback
    tgt = take (typeSize t) ret
    -- automatic apply, build call and result copy
    mkApply f
      | Just cb <- callback = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         cs <- use gsSettings
         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb])
      | (ts@(_:_)) <- tgt = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         case ts of
           (t:ts') -> do
             cs <- use gsSettings
             return $ traceCall cs as
                    <> mconcat stats
                    <> [j| `t` = `ApplExpr f' (concat as)`; |]
                    <> copyResult ts'
                    <> mempty
           _ -> error "mkApply: empty list"
      | otherwise = do
         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
         cs <- use gsSettings
         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as)
        where f' = toJExpr (TxtI $ T.pack f)
    copyResult rs = mconcat $ zipWith (\t r -> [j| `r`=`t`;|]) (enumFrom Ret1) rs
    p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e)
    replaceIdent :: Map Ident JExpr -> JExpr -> JExpr
    replaceIdent env e@(ValExpr (JVar i))
      | isFFIPlaceholder i = fromMaybe err (M.lookup i env)
      | otherwise = e
        where
          (TxtI i') = i
          err = error (pat ++ ": invalid placeholder, check function type: " ++ show (i', args, t))
    replaceIdent _ e = e
    traceCall cs as
        | csTraceForeign cs = [j| h$traceForeign(`pat`, `as`); |]
        | otherwise         = mempty

showArgType :: StgArg -> Text
showArgType a = showType (stgArgType a)

showType :: Type -> Text
showType t
  | Just tc <- tyConAppTyCon_maybe (unwrapType t) =
      T.pack (show tc)
  | otherwise = "<unknown>"

-- parse and saturate ffi splice
parseFfiJME :: String -> Int -> Either P.ParseError JExpr
parseFfiJME xs u = fmap (saturateFFI u) . parseJME $ xs

-- parse and saturate ffi splice, check for unhygienic declarations
parseFfiJM :: String -> Int -> Either P.ParseError JStat
parseFfiJM xs u = fmap (makeHygienic . saturateFFI u) . parseJM $ xs
  where
    makeHygienic :: JStat -> JStat
    makeHygienic s = snd $ O.renameLocalsFun (map addFFIToken newLocals) ([], s)

--    addFFIToken (StrI xs) = TxtI (T.pack $ "ghcjs_ffi_" ++ show u ++ "_" ++ xs)
    addFFIToken (TxtI xs) = TxtI (T.pack ("ghcjs_ffi_" ++ show u ++ "_") <> xs)

saturateFFI :: JMacro a => Int -> a -> a
saturateFFI u = jsSaturate (Just . T.pack $ "ghcjs_ffi_sat_" ++ show u)

-- $r for single, $r1,$r2 for dual
-- $r1, $r2, etc for ubx tup, void args not counted
resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement
resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback
resultPlaceholders False t rs =
  case typeVt (unwrapType t) of
    [t'] -> mkUnary (varSize t')
    uts ->
      let sizes = filter (>0) (map varSize uts)
          f _ 0 = []
          f n 1 = [["$r" ++ show n]]
          f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k]
            where sn = show n
          phs   = zipWith (\size n -> f n size) sizes [(1::Int)..]
      in case sizes of
           [n] -> mkUnary n
           _   -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (T.pack i), r)) phs') (concat phs) rs
  where
    mkUnary 0 = []
    mkUnary 1 = [(TxtI "$r",head rs)] -- single
    mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++
       zipWith (\n r -> (TxtI . T.pack $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs)

-- $1, $2, $3 for single, $1_1, $1_2 etc for dual
-- void args not counted
argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)])
argPlaceholders isJavaScriptCc args = do
  (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args
  let idents = filter (not . null) idents0
  return $ (mconcat stats, concat
    (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..]))

callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)]
callbackPlaceholders Nothing  = []
callbackPlaceholders (Just e) = [((TxtI "$c"), e)]

mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)]
mkPlaceholder undersc prefix aids =
      case aids of
             []       -> []
             [x]      -> [(TxtI . T.pack $ prefix, x)]
             xs@(x:_) -> (TxtI . T.pack $ prefix, x) :
                zipWith (\x m -> (TxtI . T.pack $ prefix ++ u ++ show m,x)) xs [(1::Int)..]
   where u = if undersc then "_" else ""

-- ident is $N, $N_R, $rN, $rN_R or $r or $c
isFFIPlaceholder :: Ident -> Bool
isFFIPlaceholder (TxtI x) =
  either (const False) (const True) (P.parse parser "" x)
    where
      parser = void (P.try $ P.string "$r") <|>
               void (P.try $ P.string "$c") <|> do
        P.char '$'
        P.optional (P.char 'r')
        P.many1 P.digit
        P.optional (P.char '_' >> P.many1 P.digit)

withNewIdent :: (Ident -> G a) -> G a
withNewIdent m = makeIdent >>= m

makeIdent :: G Ident
makeIdent = do
  gsId += 1
  i <- use gsId
  mod <- use gsModule
  return (TxtI . T.pack $ "h$$" ++
                          zEncodeString (show mod) ++
                          "_" ++
                          encodeUnique i
         )

freshUnique :: G Int
freshUnique = gsId += 1 >> use gsId

-- returns True if the expression is definitely inline
isInlineExpr :: UniqSet Id -> StgExpr -> (UniqSet Id, Bool)
isInlineExpr v (StgApp i args) =
  (emptyUniqSet, isInlineApp v i args)
isInlineExpr _ (StgLit{}) =
  (emptyUniqSet, True)
isInlineExpr _ (StgConApp{}) =
  (emptyUniqSet, True)
isInlineExpr _ (StgOpApp (StgFCallOp f _) _ _) =
  (emptyUniqSet, isInlineForeignCall f)
isInlineExpr v (StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t) =
  (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t)
isInlineExpr _ (StgOpApp (StgPrimOp op) _ _) =
  (emptyUniqSet, isInlinePrimOp op)
isInlineExpr _ (StgOpApp (StgPrimCallOp _c) _ _) =
  (emptyUniqSet, True)
isInlineExpr _ (StgLam{}) =
  (emptyUniqSet, True)
isInlineExpr v (StgCase e b _ alts) =
  let (_ve, ie)   = isInlineExpr v e
      v'          = addOneToUniqSet v b
      (vas, ias)  = unzip $ map (isInlineExpr v') (alts ^.. traverse . _3)
      vr          = foldl1' intersectUniqSets vas
  in (vr, (ie || b `elementOfUniqSet` v) && and ias)
isInlineExpr v (StgLet b e) =
  isInlineExpr (inspectInlineBinding v b) e
isInlineExpr v (StgLetNoEscape b e) =
  isInlineExpr v e
isInlineExpr v (StgTick  _ e) =
  isInlineExpr v e

inspectInlineBinding :: UniqSet Id -> StgBinding -> UniqSet Id
inspectInlineBinding v (StgNonRec i r) = inspectInlineRhs v i r
inspectInlineBinding v (StgRec bs)       =
  foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs

inspectInlineRhs :: UniqSet Id -> Id -> StgRhs -> UniqSet Id
inspectInlineRhs v i (StgRhsCon{})                       = addOneToUniqSet v i
inspectInlineRhs v i (StgRhsClosure _ _ _ ReEntrant _ _) = addOneToUniqSet v i
inspectInlineRhs v _ _                                   = v

isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall (CCall (CCallSpec _ cconv safety)) =
  not (playInterruptible safety) &&
  not (cconv /= JavaScriptCallConv && playSafe safety)

isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp _ i _
  | isJoinId i = False
isInlineApp v i [] = isUnboxedTupleType (idType i) ||
                     isStrictType (idType i) ||
                     i `elementOfUniqSet` v ||
                     isStrictId i
isInlineApp v i [StgVarArg a]
  | DataConWrapId dc <- idDetails i
  , isNewTyCon (dataConTyCon dc)
  , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a = True
isInlineApp _ _ _ = False

verifyMatchRep :: HasDebugCallStack => Id -> AltType -> C
#ifndef RUNTIME_ASSERTIONS
verifyMatchRep _ _ = pure mempty
#else
verifyMatchRep x (AlgAlt tc) = do
  ix <- genIds x
  pure $ ApplStat (ValExpr (JVar (TxtI "h$verify_match_alg")))
                  (ValExpr(JStr(T.pack (show tc))):ix)
verifyMatchRep _ _ = pure mempty
#endif

verifyRuntimeReps :: HasDebugCallStack => [Id] -> C
#ifndef RUNTIME_ASSERTIONS
verifyRuntimeReps _  = pure mempty
#else
verifyRuntimeReps xs = mconcat <$> mapM verifyRuntimeRep xs
  where
    verifyRuntimeRep i = do
      i' <- genIds i
      pure $ go i' (idVt i)
    go js         (VoidV:vs) = go js vs
    go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs
    go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs
    go (j:js)     (v:vs)     = ver j v                       <> go js vs
    go []         []         = mempty
    go _          _          = panic
      ("verifyRuntimeReps: inconsistent sizes: " ++ show xs)
    ver j PtrV    = v "h$verify_rep_heapobj" [j]
    ver j IntV    = v "h$verify_rep_int"     [j]
    ver j RtsObjV = v "h$verify_rep_rtsobj"  [j]
    ver j DoubleV = v "h$verify_rep_double"  [j]
    ver j ArrV    = v "h$verify_rep_arr"     [j]
    ver _ _       = mempty
    v f as = ApplStat (ValExpr (JVar (TxtI f))) as
#endif