Use ByteString to represent Cmm string literals (#16198)
[ghc.git] / compiler / codeGen / StgCmm.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DataKinds #-}
3
4 -----------------------------------------------------------------------------
5 --
6 -- Stg to C-- code generation
7 --
8 -- (c) The University of Glasgow 2004-2006
9 --
10 -----------------------------------------------------------------------------
11
12 module StgCmm ( codeGen ) where
13
14 #include "HsVersions.h"
15
16 import GhcPrelude as Prelude
17
18 import StgCmmProf (initCostCentres, ldvEnter)
19 import StgCmmMonad
20 import StgCmmEnv
21 import StgCmmBind
22 import StgCmmCon
23 import StgCmmLayout
24 import StgCmmUtils
25 import StgCmmClosure
26 import StgCmmHpc
27 import StgCmmTicky
28
29 import Cmm
30 import CmmUtils
31 import CLabel
32
33 import StgSyn
34 import DynFlags
35
36 import HscTypes
37 import CostCentre
38 import Id
39 import IdInfo
40 import RepType
41 import DataCon
42 import Name
43 import TyCon
44 import Module
45 import Outputable
46 import Stream
47 import BasicTypes
48 import VarSet ( isEmptyDVarSet )
49
50 import OrdList
51 import MkGraph
52
53 import Data.IORef
54 import Control.Monad (when,void)
55 import Util
56
57 codeGen :: DynFlags
58 -> Module
59 -> [TyCon]
60 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
61 -> [CgStgTopBinding] -- Bindings to convert
62 -> HpcInfo
63 -> Stream IO CmmGroup () -- Output as a stream, so codegen can
64 -- be interleaved with output
65
66 codeGen dflags this_mod data_tycons
67 cost_centre_info stg_binds hpc_info
68 = do { -- cg: run the code generator, and yield the resulting CmmGroup
69 -- Using an IORef to store the state is a bit crude, but otherwise
70 -- we would need to add a state monad layer.
71 ; cgref <- liftIO $ newIORef =<< initC
72 ; let cg :: FCode () -> Stream IO CmmGroup ()
73 cg fcode = do
74 cmm <- liftIO $ do
75 st <- readIORef cgref
76 let (a,st') = runC dflags this_mod st (getCmm fcode)
77
78 -- NB. stub-out cgs_tops and cgs_stmts. This fixes
79 -- a big space leak. DO NOT REMOVE!
80 writeIORef cgref $! st'{ cgs_tops = nilOL,
81 cgs_stmts = mkNop }
82 return a
83 yield cmm
84
85 -- Note [codegen-split-init] the cmm_init block must come
86 -- FIRST. This is because when -split-objs is on we need to
87 -- combine this block with its initialisation routines; see
88 -- Note [pipeline-split-init].
89 ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
90
91 ; mapM_ (cg . cgTopBinding dflags) stg_binds
92
93 -- Put datatype_stuff after code_stuff, because the
94 -- datatype closure table (for enumeration types) to
95 -- (say) PrelBase_True_closure, which is defined in
96 -- code_stuff
97 ; let do_tycon tycon = do
98 -- Generate a table of static closures for an
99 -- enumeration type Note that the closure pointers are
100 -- tagged.
101 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
102 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
103
104 ; mapM_ do_tycon data_tycons
105 }
106
107 ---------------------------------------------------------------
108 -- Top-level bindings
109 ---------------------------------------------------------------
110
111 {- 'cgTopBinding' is only used for top-level bindings, since they need
112 to be allocated statically (not in the heap) and need to be labelled.
113 No unboxed bindings can happen at top level.
114
115 In the code below, the static bindings are accumulated in the
116 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
117 This is so that we can write the top level processing in a compositional
118 style, with the increasing static environment being plumbed as a state
119 variable. -}
120
121 cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
122 cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
123 = do { id' <- maybeExternaliseId dflags id
124 ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
125 ; fcode
126 ; addBindC info -- Add the *un-externalised* Id to the envt,
127 -- so we find it when we look up occurrences
128 }
129
130 cgTopBinding dflags (StgTopLifted (StgRec pairs))
131 = do { let (bndrs, rhss) = unzip pairs
132 ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
133 ; let pairs' = zip bndrs' rhss
134 r = unzipWith (cgTopRhs dflags Recursive) pairs'
135 (infos, fcodes) = unzip r
136 ; addBindsC infos
137 ; sequence_ fcodes
138 }
139
140 cgTopBinding dflags (StgTopStringLit id str)
141 = do { id' <- maybeExternaliseId dflags id
142 ; let label = mkBytesLabel (idName id')
143 ; let (lit, decl) = mkByteStringCLit label str
144 ; emitDecl decl
145 ; addBindC (litIdInfo dflags id' mkLFStringLit lit)
146 }
147
148 cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
149 -- The Id is passed along for setting up a binding...
150 -- It's already been externalised if necessary
151
152 cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
153 = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
154 -- con args are always non-void,
155 -- see Note [Post-unarisation invariants] in UnariseStg
156
157 cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
158 = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables
159 cgTopRhsClosure dflags rec bndr cc upd_flag args body
160
161
162 ---------------------------------------------------------------
163 -- Module initialisation code
164 ---------------------------------------------------------------
165
166 mkModuleInit
167 :: CollectedCCs -- cost centre info
168 -> Module
169 -> HpcInfo
170 -> FCode ()
171
172 mkModuleInit cost_centre_info this_mod hpc_info
173 = do { initHpc this_mod hpc_info
174 ; initCostCentres cost_centre_info
175 }
176
177
178 ---------------------------------------------------------------
179 -- Generating static stuff for algebraic data types
180 ---------------------------------------------------------------
181
182
183 cgEnumerationTyCon :: TyCon -> FCode ()
184 cgEnumerationTyCon tycon
185 = do dflags <- getDynFlags
186 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
187 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
188 (tagForCon dflags con)
189 | con <- tyConDataCons tycon]
190
191
192 cgDataCon :: DataCon -> FCode ()
193 -- Generate the entry code, info tables, and (for niladic constructor)
194 -- the static closure, for a constructor.
195 cgDataCon data_con
196 = do { dflags <- getDynFlags
197 ; let
198 (tot_wds, -- #ptr_wds + #nonptr_wds
199 ptr_wds) -- #ptr_wds
200 = mkVirtConstrSizes dflags arg_reps
201
202 nonptr_wds = tot_wds - ptr_wds
203
204 dyn_info_tbl =
205 mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
206
207 -- We're generating info tables, so we don't know and care about
208 -- what the actual arguments are. Using () here as the place holder.
209 arg_reps :: [NonVoid PrimRep]
210 arg_reps = [ NonVoid rep_ty
211 | ty <- dataConRepArgTys data_con
212 , rep_ty <- typePrimRep ty
213 , not (isVoidRep rep_ty) ]
214
215 ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
216 -- NB: the closure pointer is assumed *untagged* on
217 -- entry to a constructor. If the pointer is tagged,
218 -- then we should not be entering it. This assumption
219 -- is used in ldvEnter and when tagging the pointer to
220 -- return it.
221 -- NB 2: We don't set CC when entering data (WDP 94/06)
222 do { tickyEnterDynCon
223 ; ldvEnter (CmmReg nodeReg)
224 ; tickyReturnOldCon (length arg_reps)
225 ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
226 }
227 -- The case continuation code expects a tagged pointer
228 }
229
230 ---------------------------------------------------------------
231 -- Stuff to support splitting
232 ---------------------------------------------------------------
233
234 maybeExternaliseId :: DynFlags -> Id -> FCode Id
235 maybeExternaliseId dflags id
236 | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting]
237 -- in StgCmmMonad
238 isInternalName name = do { mod <- getModuleName
239 ; return (setIdName id (externalise mod)) }
240 | otherwise = return id
241 where
242 externalise mod = mkExternalName uniq mod new_occ loc
243 name = idName id
244 uniq = nameUnique name
245 new_occ = mkLocalOcc uniq (nameOccName name)
246 loc = nameSrcSpan name
247 -- We want to conjure up a name that can't clash with any
248 -- existing name. So we generate
249 -- Mod_$L243foo
250 -- where 243 is the unique.