StgToCmm.hs 11.2 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
{-# LANGUAGE DataKinds #-}
3
{-# LANGUAGE BangPatterns #-}
4
{-# LANGUAGE LambdaCase #-}
5

6 7 8 9 10 11 12 13
-----------------------------------------------------------------------------
--
-- Stg to C-- code generation
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

14
module GHC.StgToCmm ( codeGen ) where
15 16 17

#include "HsVersions.h"

18
import GHC.Prelude as Prelude
19

Sylvain Henry's avatar
Sylvain Henry committed
20 21 22
import GHC.Driver.Backend
import GHC.Driver.Session

23
import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)
24 25 26
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Bind
27
import GHC.StgToCmm.DataCon
28 29 30 31 32
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
33
import GHC.StgToCmm.Types (ModuleLFInfos)
34

35
import GHC.Cmm
Sylvain Henry's avatar
Sylvain Henry committed
36
import GHC.Cmm.Utils
37
import GHC.Cmm.CLabel
Sylvain Henry's avatar
Sylvain Henry committed
38
import GHC.Cmm.Graph
39

Sylvain Henry's avatar
Sylvain Henry committed
40
import GHC.Stg.Syntax
41

Sylvain Henry's avatar
Sylvain Henry committed
42
import GHC.Types.CostCentre
43
import GHC.Types.IPE
Sylvain Henry's avatar
Sylvain Henry committed
44
import GHC.Types.HpcInfo
Sylvain Henry's avatar
Sylvain Henry committed
45 46
import GHC.Types.Id
import GHC.Types.Id.Info
Sylvain Henry's avatar
Sylvain Henry committed
47
import GHC.Types.RepType
Sylvain Henry's avatar
Sylvain Henry committed
48 49 50 51
import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
import GHC.Types.Unique.FM
import GHC.Types.Name.Env
52
import GHC.Types.ForeignStubs
Sylvain Henry's avatar
Sylvain Henry committed
53

Sylvain Henry's avatar
Sylvain Henry committed
54 55
import GHC.Core.DataCon
import GHC.Core.TyCon
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
56
import GHC.Core.Multiplicity
Sylvain Henry's avatar
Sylvain Henry committed
57

Sylvain Henry's avatar
Sylvain Henry committed
58
import GHC.Unit.Module
Sylvain Henry's avatar
Sylvain Henry committed
59 60

import GHC.Utils.Error
61
import GHC.Utils.Outputable
62
import GHC.Utils.Panic
Sylvain Henry's avatar
Sylvain Henry committed
63
import GHC.Utils.Logger
Sylvain Henry's avatar
Sylvain Henry committed
64

65
import GHC.Utils.TmpFs
66

Sylvain Henry's avatar
Sylvain Henry committed
67
import GHC.Data.Stream
68
import GHC.Data.OrdList
69
import GHC.Types.Unique.Map
70

71
import Control.Monad (when,void, forM_)
72
import GHC.Utils.Misc
73 74
import System.IO.Unsafe
import qualified Data.ByteString as BS
75 76 77 78 79 80
import Data.Maybe
import Data.IORef

data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)
                                 , codegen_state :: !CgState }

81

Sylvain Henry's avatar
Sylvain Henry committed
82
codeGen :: Logger
83
        -> TmpFs
Sylvain Henry's avatar
Sylvain Henry committed
84
        -> DynFlags
85
        -> Module
86
        -> InfoTableProvMap
87 88
        -> [TyCon]
        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
89
        -> [CgStgTopBinding]           -- Bindings to convert
90
        -> HpcInfo
91
        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can
92
                                       -- be interleaved with output
93

94
codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons
95
        cost_centre_info stg_binds hpc_info
96
  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
97
              -- Using an IORef to store the state is a bit crude, but otherwise
98 99 100 101
              -- we would need to add a state monad layer which regresses
              -- allocations by 0.5-2%.
        ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)
        ; let cg :: FCode a -> Stream IO CmmGroup a
102
              cg fcode = do
103 104
                (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do
                         CodeGenState ts st <- readIORef cgref
105 106 107 108
                         let (a,st') = runC dflags this_mod st (getCmm fcode)

                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
                         -- a big space leak.  DO NOT REMOVE!
109 110 111 112 113 114 115 116 117 118
                         -- This is observed by the #3294 test
                         let !used_info
                                | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts
                                | otherwise = mempty
                         writeIORef cgref $!
                                    CodeGenState used_info
                                      (st'{ cgs_tops = nilOL,
                                            cgs_stmts = mkNop
                                          })

119 120
                         return a
                yield cmm
121
                return a
122 123 124 125 126 127 128

               -- Note [codegen-split-init] the cmm_init block must come
               -- FIRST.  This is because when -split-objs is on we need to
               -- combine this block with its initialisation routines; see
               -- Note [pipeline-split-init].
        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)

129
        ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds
130 131 132 133
                -- Put datatype_stuff after code_stuff, because the
                -- datatype closure table (for enumeration types) to
                -- (say) PrelBase_True_closure, which is defined in
                -- code_stuff
134 135 136 137 138
        ; let do_tycon tycon = do
                -- Generate a table of static closures for an
                -- enumeration type Note that the closure pointers are
                -- tagged.
                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
139 140
                 -- Emit normal info_tables, for data constructors defined in this module.
                 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
141 142

        ; mapM_ do_tycon data_tycons
143

144 145 146 147
        -- Emit special info tables for everything used in this module
        -- This will only do something if  `-fdistinct-info-tables` is turned on.
        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)

148 149 150 151 152
        ; final_state <- liftIO (readIORef cgref)
        ; let cg_id_infos = cgs_binds . codegen_state $ final_state
              used_info = fromOL . codegen_used_info $ final_state

        ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)
153 154 155 156 157 158 159 160 161 162 163 164 165 166

          -- See Note [Conveying CAF-info and LFInfo between modules] in
          -- GHC.StgToCmm.Types
        ; let extractInfo info = (name, lf)
                where
                  !name = idName (cg_id info)
                  !lf = cg_lf info

              !generatedInfo
                | gopt Opt_OmitInterfacePragmas dflags
                = emptyNameEnv
                | otherwise
                = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))

167
        ; return (foreign_stub, generatedInfo)
168
        }
169 170

---------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
171
--      Top-level bindings
172 173 174 175 176 177 178 179 180 181 182 183
---------------------------------------------------------------

{- 'cgTopBinding' is only used for top-level bindings, since they need
to be allocated statically (not in the heap) and need to be labelled.
No unboxed bindings can happen at top level.

In the code below, the static bindings are accumulated in the
@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable. -}

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
cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding logger tmpfs dflags = \case
    StgTopLifted (StgNonRec id rhs) -> do
        let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
        fcode
        addBindC info

    StgTopLifted (StgRec pairs) -> do
        let (bndrs, rhss) = unzip pairs
        let pairs' = zip bndrs rhss
            r = unzipWith (cgTopRhs dflags Recursive) pairs'
            (infos, fcodes) = unzip r
        addBindsC infos
        sequence_ fcodes

    StgTopStringLit id str -> do
        let label = mkBytesLabel (idName id)
        -- emit either a CmmString literal or dump the string in a file and emit a
        -- CmmFileEmbed literal.
        -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
        let isNCG    = backend dflags == NCG
            isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags
            asString = binBlobThreshold dflags == 0 || isSmall

            (lit,decl) = if not isNCG || asString
              then mkByteStringCLit label str
              else mkFileEmbedLit label $ unsafePerformIO $ do
                     bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat"
                     BS.writeFile bFile str
                     return bFile
        emitDecl decl
        addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)
216

217

218
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
Simon Marlow's avatar
Simon Marlow committed
219
        -- The Id is passed along for setting up a binding...
220

221 222
cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
  = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
223
      -- con args are always non-void,
Sylvain Henry's avatar
Sylvain Henry committed
224
      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
225

226
cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
Sebastian Graf's avatar
Sebastian Graf committed
227
  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
228
    cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body
229 230 231


---------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
232
--      Module initialisation code
233 234
---------------------------------------------------------------

235
mkModuleInit
236
        :: CollectedCCs         -- cost centre info
Simon Marlow's avatar
Simon Marlow committed
237
        -> Module
238
        -> HpcInfo
Simon Marlow's avatar
Simon Marlow committed
239
        -> FCode ()
240 241 242 243 244

mkModuleInit cost_centre_info this_mod hpc_info
  = do  { initHpc this_mod hpc_info
        ; initCostCentres cost_centre_info
        }
245

246

247
---------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
248
--      Generating static stuff for algebraic data types
249 250 251
---------------------------------------------------------------


252
cgEnumerationTyCon :: TyCon -> FCode ()
253
cgEnumerationTyCon tycon
254
  = do platform <- getPlatform
Sylvain Henry's avatar
Sylvain Henry committed
255
       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
256
             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
257
                           (tagForCon platform con)
258 259
             | con <- tyConDataCons tycon]

260

261 262
cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
263
-- the static closure, for a constructor.
264 265 266
cgDataCon mn data_con
  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )
        ; profile <- getProfile
267
        ; platform <- getPlatform
268
        ; let
269
            (tot_wds, --  #ptr_wds + #nonptr_wds
270
             ptr_wds) --  #ptr_wds
271
              = mkVirtConstrSizes profile arg_reps
272

273 274
            nonptr_wds   = tot_wds - ptr_wds

Simon Marlow's avatar
Simon Marlow committed
275
            dyn_info_tbl =
276
              mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds
277

278 279 280
            -- We're generating info tables, so we don't know and care about
            -- what the actual arguments are. Using () here as the place holder.
            arg_reps :: [NonVoid PrimRep]
Richard Eisenberg's avatar
Richard Eisenberg committed
281
            arg_reps = [ NonVoid rep_ty
Simon Marlow's avatar
Simon Marlow committed
282
                       | ty <- dataConRepArgTys data_con
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
283
                       , rep_ty <- typePrimRep (scaledThing ty)
Richard Eisenberg's avatar
Richard Eisenberg committed
284
                       , not (isVoidRep rep_ty) ]
Simon Marlow's avatar
Simon Marlow committed
285

286
        ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
Simon Marlow's avatar
Simon Marlow committed
287 288 289 290 291 292 293 294 295
            -- NB: the closure pointer is assumed *untagged* on
            -- entry to a constructor.  If the pointer is tagged,
            -- then we should not be entering it.  This assumption
            -- is used in ldvEnter and when tagging the pointer to
            -- return it.
            -- NB 2: We don't set CC when entering data (WDP 94/06)
            do { tickyEnterDynCon
               ; ldvEnter (CmmReg nodeReg)
               ; tickyReturnOldCon (length arg_reps)
296
               ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]
Simon Marlow's avatar
Simon Marlow committed
297 298 299
               }
                    -- The case continuation code expects a tagged pointer
        }