path: root/compiler/GHC/StgToJS/CodeGen.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

-- | JavaScript code generator
module GHC.StgToJS.CodeGen
  ( stgToJS
  )
where

import GHC.Prelude

import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js))

import GHC.JS.Ppr
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.JS.Transform

import GHC.StgToJS.Arg
import GHC.StgToJS.Sinker
import GHC.StgToJS.Types
import qualified GHC.StgToJS.Object as Object
import GHC.StgToJS.StgUtils
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Deps
import GHC.StgToJS.Expr
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.StaticPtr
import GHC.StgToJS.Symbols
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids

import GHC.Stg.Syntax
import GHC.Core.DataCon
import GHC.Core.TyCo.Rep (scaledThing)

import GHC.Unit.Module
import GHC.Linker.Types (SptEntry (..))

import GHC.Types.CostCentre
import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub)
import GHC.Types.RepType
import GHC.Types.Id
import GHC.Types.Unique

import GHC.Data.FastString
import GHC.Utils.Encoding
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Binary
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Utils.Outputable hiding ((<>))

import qualified Data.Set as S
import Data.Monoid
import Control.Monad
import System.Directory
import System.FilePath

-- | Code generator for JavaScript
stgToJS
  :: Logger
  -> StgToJSConfig
  -> [CgStgTopBinding]
  -> Module
  -> [SptEntry]
  -> ForeignStubs
  -> CollectedCCs
  -> FilePath -- ^ Output file name
  -> IO ()
stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do

  let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0
    -- TODO: avoid top level lifting in core-2-core when the JS backend is
    -- enabled instead of undoing it here

    -- TODO: add dump pass for optimized STG ast for JS

  (deps,lus) <- runG config this_mod unfloated_binds $ do
    ifProfilingM $ initCostCentres cccs
    lus  <- genUnits this_mod stg_binds spt_entries foreign_stubs
    deps <- genDependencyData this_mod lus
    pure (deps,lus)

  -- Doc to dump when -ddump-js is enabled
  when (logHasDumpFlag logger Opt_D_dump_js) $ do
    putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
      $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus)

  -- Write the object file
  bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
  Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus)

  createDirectoryIfMissing True (takeDirectory output_fn)
  writeBinMem bh output_fn



-- | Generate the ingredients for the linkable units for this module
genUnits :: HasDebugCallStack
         => Module
         -> [CgStgTopBinding]
         -> [SptEntry]
         -> ForeignStubs
         -> G [LinkableUnit] -- ^ the linkable units
genUnits m ss spt_entries foreign_stubs = do
    gbl     <- generateGlobalBlock
    exports <- generateExportsBlock
    others  <- go 2 ss
    pure (gbl:exports:others)
    where
      go :: HasDebugCallStack
         => Int                 -- the block we're generating (block 0 is the global unit for the module)
         -> [CgStgTopBinding]
         -> G [LinkableUnit]
      go !n = \case
        []     -> pure []
        (x:xs) -> do
          mlu <- generateBlock x n
          lus <- go (n+1) xs
          return (maybe lus (:lus) mlu)

      --   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 => G LinkableUnit
      generateGlobalBlock = do
        glbl <- State.gets gsGlobal
        staticInit <-
          initStaticPtrs spt_entries
        let stat = ( -- O.optimize .
                     jsSaturate (Just $ modulePrefix m 1)
                   $ mconcat (reverse glbl) <> staticInit)
        let syms = [moduleGlobalSymbol m]
        let oi = ObjUnit
                  { oiSymbols  = syms
                  , oiClInfo   = []
                  , oiStatic   = []
                  , oiStat     = stat
                  , oiRaw      = mempty
                  , oiFExports = []
                  , oiFImports = []
                  }
        let lu = LinkableUnit
                  { luObjUnit      = oi
                  , luIdExports    = []
                  , luOtherExports = syms
                  , luIdDeps       = []
                  , luPseudoIdDeps = []
                  , luOtherDeps    = []
                  , luRequired     = False
                  , luForeignRefs  = []
                  }
        pure lu

      generateExportsBlock :: HasDebugCallStack => G LinkableUnit
      generateExportsBlock = do
        let (f_hdr, f_c) = case foreign_stubs of
                                  NoStubs            -> (empty, empty)
                                  ForeignStubs hdr c -> (getCHeader hdr, getCStub c)
            unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr)
            mkUniqueDep (tag:xs) = mkUnique tag (read xs)
            mkUniqueDep []       = panic "mkUniqueDep"

        let syms = [moduleExportsSymbol m]
        let raw  = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c
        let oi = ObjUnit
                  { oiSymbols  = syms
                  , oiClInfo   = []
                  , oiStatic   = []
                  , oiStat     = mempty
                  , oiRaw      = raw
                  , oiFExports = []
                  , oiFImports = []
                  }
        let lu = LinkableUnit
                  { luObjUnit      = oi
                  , luIdExports    = []
                  , luOtherExports = syms
                  , luIdDeps       = []
                  , luPseudoIdDeps = unique_deps
                  , luOtherDeps    = []
                  , luRequired     = True
                  , luForeignRefs  = []
                  }
        pure lu

      --   Generate the linkable unit for one binding or group of
      --   mutually recursive bindings
      generateBlock :: HasDebugCallStack
                    => CgStgTopBinding
                    -> Int
                    -> G (Maybe LinkableUnit)
      generateBlock top_bind n = case top_bind of
        StgTopStringLit bnd str -> do
          bids <- identsForId bnd
          case bids of
            [(TxtI b1t),(TxtI b2t)] -> do
              -- [e1,e2] <- genLit (MachStr str)
              emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing
              emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
              _extraTl   <- State.gets (ggsToplevelStats . gsGroup)
              si        <- State.gets (ggsStatic . gsGroup)
              let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
              let stat = jsSaturate (Just $ modulePrefix m n) body
              let ids = [bnd]
              syms <- (\(TxtI i) -> [i]) <$> identForId bnd
              let oi = ObjUnit
                        { oiSymbols  = syms
                        , oiClInfo   = []
                        , oiStatic   = si
                        , oiStat     = stat
                        , oiRaw      = ""
                        , oiFExports = []
                        , oiFImports = []
                        }
              let lu = LinkableUnit
                        { luObjUnit      = oi
                        , luIdExports    = ids
                        , luOtherExports = []
                        , luIdDeps       = []
                        , luPseudoIdDeps = []
                        , luOtherDeps    = []
                        , luRequired     = False
                        , luForeignRefs  = []
                        }
              pure (Just lu)
            _ -> panic "generateBlock: invalid size"

        StgTopLifted decl -> do
          tl        <- genToplevel decl
          extraTl   <- State.gets (ggsToplevelStats . gsGroup)
          ci        <- State.gets (ggsClosureInfo . gsGroup)
          si        <- State.gets (ggsStatic . gsGroup)
          unf       <- State.gets gsUnfloated
          extraDeps <- State.gets (ggsExtraDeps . gsGroup)
          fRefs     <- State.gets (ggsForeignRefs . gsGroup)
          resetGroup
          let allDeps  = collectIds unf decl
              topDeps  = collectTopIds decl
              required = hasExport decl
              stat     = -- Opt.optimize .
                         jsSaturate (Just $ modulePrefix m n)
                       $ mconcat (reverse extraTl) <> tl
          syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps
          let oi = ObjUnit
                    { oiSymbols  = syms
                    , oiClInfo   = ci
                    , oiStatic   = si
                    , oiStat     = stat
                    , oiRaw      = ""
                    , oiFExports = []
                    , oiFImports = fRefs
                    }
          let lu = LinkableUnit
                    { luObjUnit      = oi
                    , luIdExports    = topDeps
                    , luOtherExports = []
                    , luIdDeps       = allDeps
                    , luPseudoIdDeps = []
                    , luOtherDeps    = S.toList extraDeps
                    , luRequired     = required
                    , luForeignRefs  = fRefs
                    }
          pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu

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

genToplevel :: CgStgBinding -> G JStat
genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs
genToplevel (StgRec bs)          =
  mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs

genToplevelDecl :: Id -> CgStgRhs -> G JStat
genToplevelDecl i rhs = do
  s1 <- resetSlots (genToplevelConEntry i rhs)
  s2 <- resetSlots (genToplevelRhs i rhs)
  return (s1 <> s2)

genToplevelConEntry :: Id -> CgStgRhs -> G JStat
genToplevelConEntry i rhs = case rhs of
   StgRhsCon _cc con _mu _ts _args
     | isDataConWorkId i
       -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT
   StgRhsClosure _ _cc _upd_flag _args _body
     | Just dc <- isDataConWorkId_maybe i
       -> genSetConInfo i dc (stgRhsLive rhs) -- srt
   _ -> pure mempty

genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo i d l {- srt -} = do
  ei <- identForDataConEntryId i
  sr <- genStaticRefs l
  emitClosureInfo $ ClosureInfo ei
                                (CIRegs 0 [PtrV])
                                (mkFastString $ renderWithContext defaultSDocContext (ppr 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 . scaledThing)
                         (dataConRepArgTys d)
        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)

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

genToplevelRhs :: Id -> CgStgRhs -> G JStat
-- general cases:
genToplevelRhs i rhs = case rhs of
  StgRhsCon cc con _mu _tys args -> do
    ii <- identForId i
    allocConStatic ii cc con args
    return mempty
  StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do
    {-
      algorithm:
       - collect all Id refs that are in the global id cache
       - count usage in body for each ref
       - order by increasing use
       - prepend loading lives var to body: body can stay the same
    -}
    eid@(TxtI eidt) <- identForEntryId i
    (TxtI idt)   <- identForId i
    body <- genBody (initExprCtx i) i R2 args body
    global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body)
    let lidents = map global_ident global_occs
    let lids    = map global_id    global_occs
    let lidents' = map identFS lidents
    CIStaticRefs sr0 <- genStaticRefsRhs rhs
    let sri = filter (`notElem` lidents') sr0
        sr   = CIStaticRefs sri
    et <- genEntryType args
    ll <- loadLiveFun lids
    (static, regs, upd) <-
      if et == CIThunk
        then do
          r <- updateThunk
          pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
        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 eid
                                 regs
                                 idt
                                 (fixedLayout $ map (uTypeVt . idType) lids)
                                 et
                                 sr)
    ccId <- costCentreStackLbl cc
    emitStatic idt static ccId
    return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body)))