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

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

-- | JavaScript code generator
module GHC.StgToJS.CodeGen 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.UnitUtils

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.Types.TyThing

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

import qualified Data.Set as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Monoid
import Control.Monad
import Control.Monad.Trans.Class
import Data.Bifunctor

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

  obj <- runG config this_mod unfloated_binds $ do
        ifProfilingM $ initCostCentres cccs
        (sym_table, lus) <- genUnits this_mod stg_binds spt_entries foreign_stubs

        -- (exported symbol names, javascript statements) for each linkable unit
        p <- forM lus \u -> do
           ts <- mapM (fmap (\(TxtI i) -> i) . jsIdI) (luIdExports u)
           return (ts ++ luOtherExports u, luStat u)

        deps <- genDependencyData this_mod lus
        lift $ Object.object' (moduleName this_mod) sym_table deps (map (second BL.fromStrict) p)

  -- Doc to dump when -ddump-js is enabled
  let mod_name = renderWithContext defaultSDocContext (ppr this_mod)
  o <- Object.readObject mod_name obj
  putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
    $ vcat (fmap (docToSDoc . jsToDoc . Object.oiStat) o)

  BL.writeFile output_fn obj



-- | Generate the ingredients for the linkable units for this module
genUnits :: HasDebugCallStack
         => Module
         -> [CgStgTopBinding]
         -> [SptEntry]
         -> ForeignStubs
         -> G (Object.SymbolTable, [LinkableUnit]) -- ^ the final symbol table and the linkable units
genUnits m ss spt_entries foreign_stubs
                                 = generateGlobalBlock =<<
                                   generateExportsBlock =<<
                                   go 2 Object.emptySymbolTable ss
    where
      go :: HasDebugCallStack
         => Int                 -- the block we're generating (block 0 is the global unit for the module)
         -> Object.SymbolTable  -- the shared symbol table
         -> [CgStgTopBinding]
         -> 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 <- State.gets gsGlobal
        staticInit <-
          initStaticPtrs spt_entries
        (st', _, bs) <- serializeLinkableUnit m st [] [] []
                         ( -- FIXME (Sylvain, 2022/02): optimizer disabled: O.optimize .
                           jsSaturate (Just $ modulePrefix m 1)
                         $ mconcat (reverse glbl) <> staticInit) "" [] []
        return ( st'
               , LinkableUnit bs
                              []
                              [moduleGlobalSymbol m]
                              []
                              []
                              []
                              False
                              []
                 : lus
               )

      generateExportsBlock :: HasDebugCallStack
                          => (Object.SymbolTable, [LinkableUnit])
                          -> G (Object.SymbolTable, [LinkableUnit])
      generateExportsBlock (st, lus) = 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"

        (st', _, bs) <- serializeLinkableUnit m
                                              st
                                              []
                                              []
                                              []
                                              mempty
                                              (ST.pack $ renderWithContext defaultSDocContext f_c)
                                              []
                                              []
        return ( st'
               , LinkableUnit bs
                              []
                              [moduleExportsSymbol m]
                              [] -- id deps
                              unique_deps -- pseudo id deps
                              []
                              True
                              []
                 : lus
               )

      --   Generate the linkable unit for one binding or group of
      --   mutually recursive bindings
      generateBlock :: HasDebugCallStack
                    => Object.SymbolTable
                    -> CgStgTopBinding
                    -> Int
                    -> G (Object.SymbolTable, Maybe LinkableUnit)
      generateBlock st (StgTopStringLit bnd str) n = do
        bids <- genIdsI 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 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 = 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     = -- FIXME (Sylvain 2022/02): optimizer disabled:
                       -- {-decl -} Opt.optimize .
                       jsSaturate (Just $ modulePrefix m n)
                     $ mconcat (reverse extraTl) <> tl
        (st', _ss, bs) <- serializeLinkableUnit m st topDeps ci si stat mempty [] fRefs
        return $! seqList topDeps `seq` seqList allDeps `seq` st' `seq`
          (st', Just $ LinkableUnit bs topDeps [] allDeps [] (S.toList extraDeps) required fRefs)

-- | 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
                      -> ShortText
                      -> [Object.ExpFun]
                      -> [ForeignJSRef]
                      -> G (Object.SymbolTable, [ShortText], BS.ByteString)
serializeLinkableUnit _m st i ci si stat rawStat fe fi = do
  !i' <- mapM idStr i
  !(!st', !o) <- lift $ Object.serializeStat st ci si stat rawStat fe fi
  return (st', i', o) -- deepseq results?
    where
      idStr i = itxt <$> jsIdI i

-- | variable prefix for the nth block in module
modulePrefix :: Module -> Int -> ShortText
modulePrefix m n =
  let encMod = zEncodeString . moduleNameString . moduleName $ m
  in  ST.pack $ "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
    | i `elem` [ i' | AnId i' <- dataConImplicitTyThings con ]
    -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT
  StgRhsClosure _ _cc _upd_flag _args body
    | StgConApp dc _n _cargs _tys <- removeTick body
    , i `elem` [ i' | AnId i' <- dataConImplicitTyThings dc ]
    -> genSetConInfo i dc (stgRhsLive rhs) -- srt
  _ -> pure mempty

genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo i d l {- srt -} = do
  ei@(TxtI eii) <- jsDcEntryIdI i
  sr <- genStaticRefs l
  emitClosureInfo $ ClosureInfo eii
                                (CIRegs 0 [PtrV])
                                (ST.pack $ 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 <- jsIdI i
    allocConStatic ii cc con args
    return mempty
  StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do
    eid@(TxtI eidt) <- jsEnIdI i
    (TxtI idt)   <- jsIdI i
    body <- genBody (initExprCtx i) i R2 args body
    (lidents, lids) <- unzip <$> liftToGlobal (jsSaturate (Just "ghcjs_tmp_sat_") body)
    let lidents' = map (\(TxtI t) -> t) 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 eidt
                                 regs
                                 idt
                                 (fixedLayout $ map (uTypeVt . idType) lids)
                                 et
                                 sr)
    ccId <- costCentreStackLbl cc
    emitStatic idt static ccId
    return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body)))