never executed always true always false
1
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE BangPatterns #-}
4 {-# LANGUAGE LambdaCase #-}
5
6 -----------------------------------------------------------------------------
7 --
8 -- Stg to C-- code generation
9 --
10 -- (c) The University of Glasgow 2004-2006
11 --
12 -----------------------------------------------------------------------------
13
14 module GHC.StgToCmm ( codeGen ) where
15
16 import GHC.Prelude as Prelude
17
18 import GHC.Driver.Backend
19 import GHC.Driver.Session
20
21 import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
22 import GHC.StgToCmm.Monad
23 import GHC.StgToCmm.Env
24 import GHC.StgToCmm.Bind
25 import GHC.StgToCmm.DataCon
26 import GHC.StgToCmm.Layout
27 import GHC.StgToCmm.Utils
28 import GHC.StgToCmm.Closure
29 import GHC.StgToCmm.Hpc
30 import GHC.StgToCmm.Ticky
31 import GHC.StgToCmm.Types (ModuleLFInfos)
32
33 import GHC.Cmm
34 import GHC.Cmm.Utils
35 import GHC.Cmm.CLabel
36 import GHC.Cmm.Graph
37
38 import GHC.Stg.Syntax
39
40 import GHC.Types.CostCentre
41 import GHC.Types.IPE
42 import GHC.Types.HpcInfo
43 import GHC.Types.Id
44 import GHC.Types.Id.Info
45 import GHC.Types.RepType
46 import GHC.Types.Basic
47 import GHC.Types.Var.Set ( isEmptyDVarSet )
48 import GHC.Types.Unique.FM
49 import GHC.Types.Name.Env
50
51 import GHC.Core.DataCon
52 import GHC.Core.TyCon
53 import GHC.Core.Multiplicity
54
55 import GHC.Unit.Module
56
57 import GHC.Utils.Error
58 import GHC.Utils.Outputable
59 import GHC.Utils.Panic.Plain
60 import GHC.Utils.Logger
61
62 import GHC.Utils.TmpFs
63
64 import GHC.Data.Stream
65 import GHC.Data.OrdList
66 import GHC.Types.Unique.Map
67
68 import Control.Monad (when,void, forM_)
69 import GHC.Utils.Misc
70 import System.IO.Unsafe
71 import qualified Data.ByteString as BS
72 import Data.IORef
73
74 codeGen :: Logger
75 -> TmpFs
76 -> DynFlags
77 -> Module
78 -> InfoTableProvMap
79 -> [TyCon]
80 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
81 -> [CgStgTopBinding] -- Bindings to convert
82 -> HpcInfo
83 -> Stream IO CmmGroup ModuleLFInfos -- Output as a stream, so codegen can
84 -- be interleaved with output
85
86 codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons
87 cost_centre_info stg_binds hpc_info
88 = do { -- cg: run the code generator, and yield the resulting CmmGroup
89 -- Using an IORef to store the state is a bit crude, but otherwise
90 -- we would need to add a state monad layer which regresses
91 -- allocations by 0.5-2%.
92 ; cgref <- liftIO $ initC >>= \s -> newIORef s
93 ; let cg :: FCode a -> Stream IO CmmGroup a
94 cg fcode = do
95 (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
96 st <- readIORef cgref
97 let (a,st') = runC dflags this_mod st (getCmm fcode)
98
99 -- NB. stub-out cgs_tops and cgs_stmts. This fixes
100 -- a big space leak. DO NOT REMOVE!
101 -- This is observed by the #3294 test
102 writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
103 return a
104 yield cmm
105 return a
106
107 -- Note [codegen-split-init] the cmm_init block must come
108 -- FIRST. This is because when -split-objs is on we need to
109 -- combine this block with its initialisation routines; see
110 -- Note [pipeline-split-init].
111 ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
112
113 ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds
114 -- Put datatype_stuff after code_stuff, because the
115 -- datatype closure table (for enumeration types) to
116 -- (say) PrelBase_True_closure, which is defined in
117 -- code_stuff
118 ; let do_tycon tycon = do
119 -- Generate a table of static closures for an
120 -- enumeration type Note that the closure pointers are
121 -- tagged.
122 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
123 -- Emit normal info_tables, for data constructors defined in this module.
124 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
125
126 ; mapM_ do_tycon data_tycons
127
128 -- Emit special info tables for everything used in this module
129 -- This will only do something if `-fdistinct-info-tables` is turned on.
130 ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)
131
132 ; final_state <- liftIO (readIORef cgref)
133 ; let cg_id_infos = cgs_binds final_state
134
135 -- See Note [Conveying CAF-info and LFInfo between modules] in
136 -- GHC.StgToCmm.Types
137 ; let extractInfo info = (name, lf)
138 where
139 !name = idName (cg_id info)
140 !lf = cg_lf info
141
142 !generatedInfo
143 | gopt Opt_OmitInterfacePragmas dflags
144 = emptyNameEnv
145 | otherwise
146 = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
147
148 ; return generatedInfo
149 }
150
151 ---------------------------------------------------------------
152 -- Top-level bindings
153 ---------------------------------------------------------------
154
155 {- 'cgTopBinding' is only used for top-level bindings, since they need
156 to be allocated statically (not in the heap) and need to be labelled.
157 No unboxed bindings can happen at top level.
158
159 In the code below, the static bindings are accumulated in the
160 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
161 This is so that we can write the top level processing in a compositional
162 style, with the increasing static environment being plumbed as a state
163 variable. -}
164
165 cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()
166 cgTopBinding logger tmpfs dflags = \case
167 StgTopLifted (StgNonRec id rhs) -> do
168 let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
169 fcode
170 addBindC info
171
172 StgTopLifted (StgRec pairs) -> do
173 let (bndrs, rhss) = unzip pairs
174 let pairs' = zip bndrs rhss
175 r = unzipWith (cgTopRhs dflags Recursive) pairs'
176 (infos, fcodes) = unzip r
177 addBindsC infos
178 sequence_ fcodes
179
180 StgTopStringLit id str -> do
181 let label = mkBytesLabel (idName id)
182 -- emit either a CmmString literal or dump the string in a file and emit a
183 -- CmmFileEmbed literal.
184 -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
185 let isNCG = backend dflags == NCG
186 isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags
187 asString = binBlobThreshold dflags == 0 || isSmall
188
189 (lit,decl) = if not isNCG || asString
190 then mkByteStringCLit label str
191 else mkFileEmbedLit label $ unsafePerformIO $ do
192 bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat"
193 BS.writeFile bFile str
194 return bFile
195 emitDecl decl
196 addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)
197
198
199 cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
200 -- The Id is passed along for setting up a binding...
201
202 cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
203 = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
204 -- con args are always non-void,
205 -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
206
207 cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
208 = assert (isEmptyDVarSet fvs) -- There should be no free variables
209 cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body
210
211
212 ---------------------------------------------------------------
213 -- Module initialisation code
214 ---------------------------------------------------------------
215
216 mkModuleInit
217 :: CollectedCCs -- cost centre info
218 -> Module
219 -> HpcInfo
220 -> FCode ()
221
222 mkModuleInit cost_centre_info this_mod hpc_info
223 = do { initHpc this_mod hpc_info
224 ; initCostCentres cost_centre_info
225 }
226
227
228 ---------------------------------------------------------------
229 -- Generating static stuff for algebraic data types
230 ---------------------------------------------------------------
231
232
233 cgEnumerationTyCon :: TyCon -> FCode ()
234 cgEnumerationTyCon tycon
235 = do platform <- getPlatform
236 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
237 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
238 (tagForCon platform con)
239 | con <- tyConDataCons tycon]
240
241
242 cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
243 -- Generate the entry code, info tables, and (for niladic constructor)
244 -- the static closure, for a constructor.
245 cgDataCon mn data_con
246 = do { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))
247 ; profile <- getProfile
248 ; platform <- getPlatform
249 ; let
250 (tot_wds, -- #ptr_wds + #nonptr_wds
251 ptr_wds) -- #ptr_wds
252 = mkVirtConstrSizes profile arg_reps
253
254 nonptr_wds = tot_wds - ptr_wds
255
256 dyn_info_tbl =
257 mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds
258
259 -- We're generating info tables, so we don't know and care about
260 -- what the actual arguments are. Using () here as the place holder.
261 arg_reps :: [NonVoid PrimRep]
262 arg_reps = [ NonVoid rep_ty
263 | ty <- dataConRepArgTys data_con
264 , rep_ty <- typePrimRep (scaledThing ty)
265 , not (isVoidRep rep_ty) ]
266
267 ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
268 -- NB: the closure pointer is assumed *untagged* on
269 -- entry to a constructor. If the pointer is tagged,
270 -- then we should not be entering it. This assumption
271 -- is used in ldvEnter and when tagging the pointer to
272 -- return it.
273 -- NB 2: We don't set CC when entering data (WDP 94/06)
274 do { tickyEnterDynCon
275 ; ldvEnter (CmmReg nodeReg)
276 ; tickyReturnOldCon (length arg_reps)
277 ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]
278 }
279 -- The case continuation code expects a tagged pointer
280 }