summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToJS/CodeGen.hs
blob: 7703398aea99200a17f714030cfbd48390417781 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
{-# 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)))