never executed always true always false
1 {-# LANGUAGE ViewPatterns #-}
2
3 -- | Code generation for the Static Pointer Table
4 --
5 -- (c) 2014 I/O Tweag
6 --
7 -- Each module that uses 'static' keyword declares an initialization function of
8 -- the form hs_spt_init_\<module>() which is emitted into the _stub.c file and
9 -- annotated with __attribute__((constructor)) so that it gets executed at
10 -- startup time.
11 --
12 -- The function's purpose is to call hs_spt_insert to insert the static
13 -- pointers of this module in the hashtable of the RTS, and it looks something
14 -- like this:
15 --
16 -- > static void hs_hpc_init_Main(void) __attribute__((constructor));
17 -- > static void hs_hpc_init_Main(void) {
18 -- >
19 -- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
20 -- > extern StgPtr Main_r2wb_closure;
21 -- > hs_spt_insert(k0, &Main_r2wb_closure);
22 -- >
23 -- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
24 -- > extern StgPtr Main_r2wc_closure;
25 -- > hs_spt_insert(k1, &Main_r2wc_closure);
26 -- >
27 -- > }
28 --
29 -- where the constants are fingerprints produced from the static forms.
30 --
31 -- The linker must find the definitions matching the @extern StgPtr <name>@
32 -- declarations. For this to work, the identifiers of static pointers need to be
33 -- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'.
34 --
35 -- There is also a finalization function for the time when the module is
36 -- unloaded.
37 --
38 -- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
39 -- > static void hs_hpc_fini_Main(void) {
40 -- >
41 -- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
42 -- > hs_spt_remove(k0);
43 -- >
44 -- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
45 -- > hs_spt_remove(k1);
46 -- >
47 -- > }
48 --
49
50 module GHC.Iface.Tidy.StaticPtrTable
51 ( sptCreateStaticBinds
52 , sptModuleInitCode
53 ) where
54
55 {- Note [Grand plan for static forms]
56 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
57 Static forms go through the compilation phases as follows.
58 Here is a running example:
59
60 f x = let k = map toUpper
61 in ...(static k)...
62
63 * The renamer looks for out-of-scope names in the body of the static
64 form, as always. If all names are in scope, the free variables of the
65 body are stored in AST at the location of the static form.
66
67 * The typechecker verifies that all free variables occurring in the
68 static form are floatable to top level (see Note [Meaning of
69 IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable.
70 Even though it is bound in a nested let, we are fine.
71
72 * The desugarer replaces the static form with an application of the
73 function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
74 base). So we get
75
76 f x = let k = map toUpper
77 in ...fromStaticPtr (makeStatic location k)...
78
79 * The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
80 to the top level. Thus the FloatOut pass is always executed, even when
81 optimizations are disabled. So we get
82
83 k = map toUpper
84 static_ptr = makeStatic location k
85 f x = ...fromStaticPtr static_ptr...
86
87 The FloatOut pass is careful to produce an /exported/ Id for a floated
88 'makeStatic' call, so the binding is not removed or inlined by the
89 simplifier.
90 E.g. the code for `f` above might look like
91
92 static_ptr = makeStatic location k
93 f x = ...(case static_ptr of ...)...
94
95 which might be simplified to
96
97 f x = ...(case makeStatic location k of ...)...
98
99 BUT the top-level binding for static_ptr must remain, so that it can be
100 collected to populate the Static Pointer Table.
101
102 Making the binding exported also has a necessary effect during the
103 CoreTidy pass.
104
105 * The CoreTidy pass replaces all bindings of the form
106
107 b = /\ ... -> makeStatic location value
108
109 with
110
111 b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
112
113 where a distinct key is generated for each binding.
114
115 * If we are compiling to object code we insert a C stub (generated by
116 sptModuleInitCode) into the final object which runs when the module is loaded,
117 inserting the static forms defined by the module into the RTS's static pointer
118 table.
119
120 * If we are compiling for the byte-code interpreter, we instead explicitly add
121 the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
122 process' SPT table using the addSptEntry interpreter message. This happens
123 in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep').
124 -}
125
126 import GHC.Prelude
127 import GHC.Platform
128
129 import GHC.Driver.Session
130 import GHC.Driver.Env
131
132 import GHC.Core
133 import GHC.Core.Utils (collectMakeStaticArgs)
134 import GHC.Core.DataCon
135 import GHC.Core.Make (mkStringExprFSWith)
136 import GHC.Core.Type
137
138 import GHC.Cmm.CLabel
139
140 import GHC.Unit.Module
141 import GHC.Utils.Outputable as Outputable
142 import GHC.Utils.Panic
143 import GHC.Builtin.Names
144 import GHC.Tc.Utils.Env (lookupGlobal)
145
146 import GHC.Linker.Types
147
148 import GHC.Types.Name
149 import GHC.Types.Id
150 import GHC.Types.TyThing
151 import GHC.Types.ForeignStubs
152
153 import Control.Monad.Trans.Class (lift)
154 import Control.Monad.Trans.State.Strict
155 import Data.List (intercalate)
156 import Data.Maybe
157 import GHC.Fingerprint
158 import qualified GHC.LanguageExtensions as LangExt
159
160 -- | Replaces all bindings of the form
161 --
162 -- > b = /\ ... -> makeStatic location value
163 --
164 -- with
165 --
166 -- > b = /\ ... ->
167 -- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
168 --
169 -- where a distinct key is generated for each binding.
170 --
171 -- It also yields the C stub that inserts these bindings into the static
172 -- pointer table.
173 sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
174 -> IO ([SptEntry], CoreProgram)
175 sptCreateStaticBinds hsc_env this_mod binds
176 | not (xopt LangExt.StaticPointers dflags) =
177 return ([], binds)
178 | otherwise = do
179 -- Make sure the required interface files are loaded.
180 _ <- lookupGlobal hsc_env unpackCStringName
181 (fps, binds') <- evalStateT (go [] [] binds) 0
182 return (fps, binds')
183 where
184 go fps bs xs = case xs of
185 [] -> return (reverse fps, reverse bs)
186 bnd : xs' -> do
187 (fps', bnd') <- replaceStaticBind bnd
188 go (reverse fps' ++ fps) (bnd' : bs) xs'
189
190 dflags = hsc_dflags hsc_env
191 platform = targetPlatform dflags
192
193 -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
194 --
195 -- The 'Int' state is used to produce a different key for each binding.
196 replaceStaticBind :: CoreBind
197 -> StateT Int IO ([SptEntry], CoreBind)
198 replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
199 return (maybeToList mfp, NonRec b' e')
200 replaceStaticBind (Rec rbs) = do
201 (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
202 return (catMaybes mfps, Rec rbs')
203
204 replaceStatic :: Id -> CoreExpr
205 -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
206 replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
207 case collectMakeStaticArgs e0 of
208 Nothing -> return (Nothing, (b, e))
209 Just (_, t, info, arg) -> do
210 (fp, e') <- mkStaticBind t info arg
211 return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
212
213 mkStaticBind :: Type -> CoreExpr -> CoreExpr
214 -> StateT Int IO (Fingerprint, CoreExpr)
215 mkStaticBind t srcLoc e = do
216 i <- get
217 put (i + 1)
218 staticPtrInfoDataCon <-
219 lift $ lookupDataConHscEnv staticPtrInfoDataConName
220 let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
221 info <- mkConApp staticPtrInfoDataCon <$>
222 (++[srcLoc]) <$>
223 mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
224 [ unitFS $ moduleUnit this_mod
225 , moduleNameFS $ moduleName this_mod
226 ]
227
228 -- The module interface of GHC.StaticPtr should be loaded at least
229 -- when looking up 'fromStatic' during type-checking.
230 staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
231 return (fp, mkConApp staticPtrDataCon
232 [ Type t
233 , mkWord64LitWordRep platform w0
234 , mkWord64LitWordRep platform w1
235 , info
236 , e ])
237
238 mkStaticPtrFingerprint :: Int -> Fingerprint
239 mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
240 [ unitString $ moduleUnit this_mod
241 , moduleNameString $ moduleName this_mod
242 , show n
243 ]
244
245 -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
246 -- 'Fingerprint' data constructor.
247 mkWord64LitWordRep platform =
248 case platformWordSize platform of
249 PW4 -> mkWord64LitWord64
250 PW8 -> mkWordLit platform . toInteger
251
252 lookupIdHscEnv :: Name -> IO Id
253 lookupIdHscEnv n = lookupType hsc_env n >>=
254 maybe (getError n) (return . tyThingId)
255
256 lookupDataConHscEnv :: Name -> IO DataCon
257 lookupDataConHscEnv n = lookupType hsc_env n >>=
258 maybe (getError n) (return . tyThingDataCon)
259
260 getError n = pprPanic "sptCreateStaticBinds.get: not found" $
261 text "Couldn't find" <+> ppr n
262
263 -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
264 -- of @module@ into the static pointer table.
265 --
266 -- @fps@ is a list associating each binding corresponding to a static entry with
267 -- its fingerprint.
268 sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
269 sptModuleInitCode _ _ [] = mempty
270 sptModuleInitCode platform this_mod entries = CStub $ vcat
271 [ text "static void hs_spt_init_" <> ppr this_mod
272 <> text "(void) __attribute__((constructor));"
273 , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
274 , braces $ vcat $
275 [ text "static StgWord64 k" <> int i <> text "[2] = "
276 <> pprFingerprint fp <> semi
277 $$ text "extern StgPtr "
278 <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
279 $$ text "hs_spt_insert" <> parens
280 (hcat $ punctuate comma
281 [ char 'k' <> int i
282 , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n))
283 ]
284 )
285 <> semi
286 | (i, SptEntry n fp) <- zip [0..] entries
287 ]
288 , text "static void hs_spt_fini_" <> ppr this_mod
289 <> text "(void) __attribute__((destructor));"
290 , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
291 , braces $ vcat $
292 [ text "StgWord64 k" <> int i <> text "[2] = "
293 <> pprFingerprint fp <> semi
294 $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
295 | (i, (SptEntry _ fp)) <- zip [0..] entries
296 ]
297 ]
298 where
299 pprFingerprint :: Fingerprint -> SDoc
300 pprFingerprint (Fingerprint w1 w2) =
301 braces $ hcat $ punctuate comma
302 [ integer (fromIntegral w1) <> text "ULL"
303 , integer (fromIntegral w2) <> text "ULL"
304 ]