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