00a9c1a4ed93ce6da47ed4e9ae10ff728cbd50eb
[ghc.git] / utils / deriveConstants / Main.hs
1 {- ------------------------------------------------------------------------
2
3 (c) The GHC Team, 1992-2012
4
5 DeriveConstants is a program that extracts information from the C
6 declarations in the header files (primarily struct field offsets)
7 and generates various files, such as a header file that can be #included
8 into non-C source containing this information.
9
10 We want to get information about code generated by the C compiler,
11 such as the sizes of types, and offsets of struct fields. We need
12 this because the layout of certain runtime objects is defined in C
13 headers (e.g. includes/rts/storage/Closures.h), but we need access to
14 the layout of these structures from a Haskell program (GHC).
15
16 One way to do this is to compile and run a C program that includes the
17 header files and prints out the sizes and offsets. However, when we
18 are cross-compiling, we can't run a C program compiled for the target
19 platform.
20
21 So, this program works as follows: we generate a C program that when
22 compiled to an object file, has the information we need encoded as
23 symbol sizes. This means that we can extract the information without
24 needing to run the program, by inspecting the object file using 'nm'.
25
26 ------------------------------------------------------------------------ -}
27
28 import Control.Monad (when, unless)
29 import Data.Bits (shiftL)
30 import Data.Char (toLower)
31 import Data.List (stripPrefix)
32 import Data.Map (Map)
33 import qualified Data.Map as Map
34 import Data.Maybe (catMaybes)
35 import Numeric (readHex)
36 import System.Environment (getArgs)
37 import System.Exit (ExitCode(ExitSuccess), exitFailure)
38 import System.FilePath ((</>))
39 import System.IO (stderr, hPutStrLn)
40 import System.Info (os)
41 import System.Process (showCommandForUser, readProcess, rawSystem)
42
43 main :: IO ()
44 main = do opts <- parseArgs
45 let getOption descr opt = case opt opts of
46 Just x -> return x
47 Nothing -> die ("No " ++ descr ++ " given")
48 mode <- getOption "mode" o_mode
49 fn <- getOption "output filename" o_outputFilename
50 case mode of
51 Gen_Haskell_Type -> writeHaskellType fn haskellWanteds
52 Gen_Haskell_Wrappers -> writeHaskellWrappers fn haskellWanteds
53 Gen_Haskell_Exports -> writeHaskellExports fn haskellWanteds
54 Gen_Computed cm ->
55 do tmpdir <- getOption "tmpdir" o_tmpdir
56 gccProg <- getOption "gcc program" o_gccProg
57 nmProg <- getOption "nm program" o_nmProg
58 let verbose = o_verbose opts
59 gccFlags = o_gccFlags opts
60 rs <- getWanted verbose tmpdir gccProg gccFlags nmProg
61 let haskellRs = [ what
62 | (wh, what) <- rs
63 , wh `elem` [Haskell, Both] ]
64 cRs = [ what
65 | (wh, what) <- rs
66 , wh `elem` [C, Both] ]
67 case cm of
68 ComputeHaskell -> writeHaskellValue fn haskellRs
69 ComputeHeader -> writeHeader fn cRs
70 where haskellWanteds = [ what | (wh, what) <- wanteds,
71 wh `elem` [Haskell, Both] ]
72
73 data Options = Options {
74 o_verbose :: Bool,
75 o_mode :: Maybe Mode,
76 o_tmpdir :: Maybe FilePath,
77 o_outputFilename :: Maybe FilePath,
78 o_gccProg :: Maybe FilePath,
79 o_gccFlags :: [String],
80 o_nmProg :: Maybe FilePath
81 }
82
83 parseArgs :: IO Options
84 parseArgs = do args <- getArgs
85 opts <- f emptyOptions args
86 return (opts {o_gccFlags = reverse (o_gccFlags opts)})
87 where emptyOptions = Options {
88 o_verbose = False,
89 o_mode = Nothing,
90 o_tmpdir = Nothing,
91 o_outputFilename = Nothing,
92 o_gccProg = Nothing,
93 o_gccFlags = [],
94 o_nmProg = Nothing
95 }
96 f opts [] = return opts
97 f opts ("-v" : args')
98 = f (opts {o_verbose = True}) args'
99 f opts ("--gen-haskell-type" : args')
100 = f (opts {o_mode = Just Gen_Haskell_Type}) args'
101 f opts ("--gen-haskell-value" : args')
102 = f (opts {o_mode = Just (Gen_Computed ComputeHaskell)}) args'
103 f opts ("--gen-haskell-wrappers" : args')
104 = f (opts {o_mode = Just Gen_Haskell_Wrappers}) args'
105 f opts ("--gen-haskell-exports" : args')
106 = f (opts {o_mode = Just Gen_Haskell_Exports}) args'
107 f opts ("--gen-header" : args')
108 = f (opts {o_mode = Just (Gen_Computed ComputeHeader)}) args'
109 f opts ("--tmpdir" : dir : args')
110 = f (opts {o_tmpdir = Just dir}) args'
111 f opts ("-o" : fn : args')
112 = f (opts {o_outputFilename = Just fn}) args'
113 f opts ("--gcc-program" : prog : args')
114 = f (opts {o_gccProg = Just prog}) args'
115 f opts ("--gcc-flag" : flag : args')
116 = f (opts {o_gccFlags = flag : o_gccFlags opts}) args'
117 f opts ("--nm-program" : prog : args')
118 = f (opts {o_nmProg = Just prog}) args'
119 f _ (flag : _) = die ("Unrecognised flag: " ++ show flag)
120
121 data Mode = Gen_Haskell_Type
122 | Gen_Haskell_Wrappers
123 | Gen_Haskell_Exports
124 | Gen_Computed ComputeMode
125
126 data ComputeMode = ComputeHaskell | ComputeHeader
127
128 type Wanteds = [(Where, What Fst)]
129 type Results = [(Where, What Snd)]
130
131 type Name = String
132 newtype CExpr = CExpr String
133 newtype CPPExpr = CPPExpr String
134 data What f = GetFieldType Name (f CExpr Integer)
135 | GetClosureSize Name (f CExpr Integer)
136 | GetWord Name (f CExpr Integer)
137 | GetInt Name (f CExpr Integer)
138 | GetNatural Name (f CExpr Integer)
139 | GetBool Name (f CPPExpr Bool)
140 | StructFieldMacro Name
141 | ClosureFieldMacro Name
142 | ClosurePayloadMacro Name
143 | FieldTypeGcptrMacro Name
144
145 data Fst a b = Fst a
146 data Snd a b = Snd b
147
148 data Where = C | Haskell | Both
149 deriving Eq
150
151 constantInt :: Where -> Name -> String -> Wanteds
152 constantInt w name expr = [(w, GetInt name (Fst (CExpr expr)))]
153
154 constantWord :: Where -> Name -> String -> Wanteds
155 constantWord w name expr = [(w, GetWord name (Fst (CExpr expr)))]
156
157 constantNatural :: Where -> Name -> String -> Wanteds
158 constantNatural w name expr = [(w, GetNatural name (Fst (CExpr expr)))]
159
160 constantBool :: Where -> Name -> String -> Wanteds
161 constantBool w name expr = [(w, GetBool name (Fst (CPPExpr expr)))]
162
163 fieldOffset :: Where -> String -> String -> Wanteds
164 fieldOffset w theType theField = fieldOffset_ w nameBase theType theField
165 where nameBase = theType ++ "_" ++ theField
166
167 fieldOffset_ :: Where -> Name -> String -> String -> Wanteds
168 fieldOffset_ w nameBase theType theField = [(w, GetWord name (Fst (CExpr expr)))]
169 where name = "OFFSET_" ++ nameBase
170 expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ")"
171
172 -- FieldType is for defining REP_x to be b32 etc
173 -- These are both the C-- types used in a load
174 -- e.g. b32[addr]
175 -- and the names of the CmmTypes in the compiler
176 -- b32 :: CmmType
177 fieldType' :: Where -> String -> String -> Wanteds
178 fieldType' w theType theField
179 = fieldType_' w nameBase theType theField
180 where nameBase = theType ++ "_" ++ theField
181
182 fieldType_' :: Where -> Name -> String -> String -> Wanteds
183 fieldType_' w nameBase theType theField
184 = [(w, GetFieldType name (Fst (CExpr expr)))]
185 where name = "REP_" ++ nameBase
186 expr = "FIELD_SIZE(" ++ theType ++ ", " ++ theField ++ ")"
187
188 structField :: Where -> String -> String -> Wanteds
189 structField = structFieldHelper C
190
191 structFieldH :: Where -> String -> String -> Wanteds
192 structFieldH w = structFieldHelper w w
193
194 structField_ :: Where -> Name -> String -> String -> Wanteds
195 structField_ w nameBase theType theField
196 = fieldOffset_ w nameBase theType theField
197 ++ fieldType_' C nameBase theType theField
198 ++ structFieldMacro nameBase
199
200 structFieldMacro :: Name -> Wanteds
201 structFieldMacro nameBase = [(C, StructFieldMacro nameBase)]
202
203 -- Outputs the byte offset and MachRep for a field
204 structFieldHelper :: Where -> Where -> String -> String -> Wanteds
205 structFieldHelper wFT w theType theField = fieldOffset w theType theField
206 ++ fieldType' wFT theType theField
207 ++ structFieldMacro nameBase
208 where nameBase = theType ++ "_" ++ theField
209
210 closureFieldMacro :: Name -> Wanteds
211 closureFieldMacro nameBase = [(C, ClosureFieldMacro nameBase)]
212
213 closurePayload :: Where -> String -> String -> Wanteds
214 closurePayload w theType theField
215 = closureFieldOffset_ w nameBase theType theField
216 ++ closurePayloadMacro nameBase
217 where nameBase = theType ++ "_" ++ theField
218
219 closurePayloadMacro :: Name -> Wanteds
220 closurePayloadMacro nameBase = [(C, ClosurePayloadMacro nameBase)]
221
222 -- Byte offset and MachRep for a closure field, minus the header
223 closureField_ :: Where -> Name -> String -> String -> Wanteds
224 closureField_ w nameBase theType theField
225 = closureFieldOffset_ w nameBase theType theField
226 ++ fieldType_' C nameBase theType theField
227 ++ closureFieldMacro nameBase
228
229 closureField :: Where -> String -> String -> Wanteds
230 closureField w theType theField = closureField_ w nameBase theType theField
231 where nameBase = theType ++ "_" ++ theField
232
233 closureFieldOffset_ :: Where -> Name -> String -> String -> Wanteds
234 closureFieldOffset_ w nameBase theType theField
235 = defOffset w nameBase (CExpr ("offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"))
236
237 -- Size of a closure type, minus the header, named SIZEOF_<type>_NoHdr
238 -- Also, we #define SIZEOF_<type> to be the size of the whole closure for .cmm.
239 closureSize :: Where -> String -> Wanteds
240 closureSize w theType = defSize w (theType ++ "_NoHdr") (CExpr expr)
241 ++ defClosureSize C theType (CExpr expr)
242 where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgHeader)"
243
244 -- Byte offset and MachRep for a closure field, minus the header
245 closureFieldGcptr :: Where -> String -> String -> Wanteds
246 closureFieldGcptr w theType theField
247 = closureFieldOffset_ w nameBase theType theField
248 ++ fieldTypeGcptr nameBase
249 ++ closureFieldMacro nameBase
250 where nameBase = theType ++ "_" ++ theField
251
252 fieldTypeGcptr :: Name -> Wanteds
253 fieldTypeGcptr nameBase = [(C, FieldTypeGcptrMacro nameBase)]
254
255 closureFieldOffset :: Where -> String -> String -> Wanteds
256 closureFieldOffset w theType theField
257 = defOffset w nameBase (CExpr expr)
258 where nameBase = theType ++ "_" ++ theField
259 expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"
260
261 thunkSize :: Where -> String -> Wanteds
262 thunkSize w theType
263 = defSize w (theType ++ "_NoThunkHdr") (CExpr expr)
264 ++ closureSize w theType
265 where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgThunkHeader)"
266
267 defIntOffset :: Where -> Name -> String -> Wanteds
268 defIntOffset w nameBase cExpr = [(w, GetInt ("OFFSET_" ++ nameBase) (Fst (CExpr cExpr)))]
269
270 defOffset :: Where -> Name -> CExpr -> Wanteds
271 defOffset w nameBase cExpr = [(w, GetWord ("OFFSET_" ++ nameBase) (Fst cExpr))]
272
273 structSize :: Where -> String -> Wanteds
274 structSize w theType = defSize w theType (CExpr ("TYPE_SIZE(" ++ theType ++ ")"))
275
276 defSize :: Where -> Name -> CExpr -> Wanteds
277 defSize w nameBase cExpr = [(w, GetWord ("SIZEOF_" ++ nameBase) (Fst cExpr))]
278
279 defClosureSize :: Where -> Name -> CExpr -> Wanteds
280 defClosureSize w nameBase cExpr = [(w, GetClosureSize ("SIZEOF_" ++ nameBase) (Fst cExpr))]
281
282 haskellise :: Name -> Name
283 haskellise (c : cs) = toLower c : cs
284 haskellise "" = ""
285
286 wanteds :: Wanteds
287 wanteds = concat
288 [-- Closure header sizes.
289 constantWord Both "STD_HDR_SIZE"
290 -- grrr.. PROFILING is on so we need to
291 -- subtract sizeofW(StgProfHeader)
292 "sizeofW(StgHeader) - sizeofW(StgProfHeader)"
293 ,constantWord Both "PROF_HDR_SIZE" "sizeofW(StgProfHeader)"
294
295 -- Size of a storage manager block (in bytes).
296 ,constantWord Both "BLOCK_SIZE" "BLOCK_SIZE"
297 ,constantWord C "MBLOCK_SIZE" "MBLOCK_SIZE"
298 -- blocks that fit in an MBlock, leaving space for the block
299 -- descriptors
300 ,constantWord Both "BLOCKS_PER_MBLOCK" "BLOCKS_PER_MBLOCK"
301 -- could be derived, but better to save doing the calculation twice
302
303 ,fieldOffset Both "StgRegTable" "rR1"
304 ,fieldOffset Both "StgRegTable" "rR2"
305 ,fieldOffset Both "StgRegTable" "rR3"
306 ,fieldOffset Both "StgRegTable" "rR4"
307 ,fieldOffset Both "StgRegTable" "rR5"
308 ,fieldOffset Both "StgRegTable" "rR6"
309 ,fieldOffset Both "StgRegTable" "rR7"
310 ,fieldOffset Both "StgRegTable" "rR8"
311 ,fieldOffset Both "StgRegTable" "rR9"
312 ,fieldOffset Both "StgRegTable" "rR10"
313 ,fieldOffset Both "StgRegTable" "rF1"
314 ,fieldOffset Both "StgRegTable" "rF2"
315 ,fieldOffset Both "StgRegTable" "rF3"
316 ,fieldOffset Both "StgRegTable" "rF4"
317 ,fieldOffset Both "StgRegTable" "rF5"
318 ,fieldOffset Both "StgRegTable" "rF6"
319 ,fieldOffset Both "StgRegTable" "rD1"
320 ,fieldOffset Both "StgRegTable" "rD2"
321 ,fieldOffset Both "StgRegTable" "rD3"
322 ,fieldOffset Both "StgRegTable" "rD4"
323 ,fieldOffset Both "StgRegTable" "rD5"
324 ,fieldOffset Both "StgRegTable" "rD6"
325 ,fieldOffset Both "StgRegTable" "rXMM1"
326 ,fieldOffset Both "StgRegTable" "rXMM2"
327 ,fieldOffset Both "StgRegTable" "rXMM3"
328 ,fieldOffset Both "StgRegTable" "rXMM4"
329 ,fieldOffset Both "StgRegTable" "rXMM5"
330 ,fieldOffset Both "StgRegTable" "rXMM6"
331 ,fieldOffset Both "StgRegTable" "rYMM1"
332 ,fieldOffset Both "StgRegTable" "rYMM2"
333 ,fieldOffset Both "StgRegTable" "rYMM3"
334 ,fieldOffset Both "StgRegTable" "rYMM4"
335 ,fieldOffset Both "StgRegTable" "rYMM5"
336 ,fieldOffset Both "StgRegTable" "rYMM6"
337 ,fieldOffset Both "StgRegTable" "rZMM1"
338 ,fieldOffset Both "StgRegTable" "rZMM2"
339 ,fieldOffset Both "StgRegTable" "rZMM3"
340 ,fieldOffset Both "StgRegTable" "rZMM4"
341 ,fieldOffset Both "StgRegTable" "rZMM5"
342 ,fieldOffset Both "StgRegTable" "rZMM6"
343 ,fieldOffset Both "StgRegTable" "rL1"
344 ,fieldOffset Both "StgRegTable" "rSp"
345 ,fieldOffset Both "StgRegTable" "rSpLim"
346 ,fieldOffset Both "StgRegTable" "rHp"
347 ,fieldOffset Both "StgRegTable" "rHpLim"
348 ,fieldOffset Both "StgRegTable" "rCCCS"
349 ,fieldOffset Both "StgRegTable" "rCurrentTSO"
350 ,fieldOffset Both "StgRegTable" "rCurrentNursery"
351 ,fieldOffset Both "StgRegTable" "rHpAlloc"
352 ,structField C "StgRegTable" "rRet"
353 ,structField C "StgRegTable" "rNursery"
354
355 ,defIntOffset Both "stgEagerBlackholeInfo"
356 "FUN_OFFSET(stgEagerBlackholeInfo)"
357 ,defIntOffset Both "stgGCEnter1" "FUN_OFFSET(stgGCEnter1)"
358 ,defIntOffset Both "stgGCFun" "FUN_OFFSET(stgGCFun)"
359
360 ,fieldOffset Both "Capability" "r"
361 ,fieldOffset C "Capability" "lock"
362 ,structField C "Capability" "no"
363 ,structField C "Capability" "mut_lists"
364 ,structField C "Capability" "context_switch"
365 ,structField C "Capability" "interrupt"
366 ,structField C "Capability" "sparks"
367 ,structField C "Capability" "total_allocated"
368 ,structField C "Capability" "weak_ptr_list_hd"
369 ,structField C "Capability" "weak_ptr_list_tl"
370
371 ,structField Both "bdescr" "start"
372 ,structField Both "bdescr" "free"
373 ,structField Both "bdescr" "blocks"
374 ,structField C "bdescr" "gen_no"
375 ,structField C "bdescr" "link"
376
377 ,structSize C "generation"
378 ,structField C "generation" "n_new_large_words"
379 ,structField C "generation" "weak_ptr_list"
380
381 ,structSize Both "CostCentreStack"
382 ,structField C "CostCentreStack" "ccsID"
383 ,structFieldH Both "CostCentreStack" "mem_alloc"
384 ,structFieldH Both "CostCentreStack" "scc_count"
385 ,structField C "CostCentreStack" "prevStack"
386
387 ,structField C "CostCentre" "ccID"
388 ,structField C "CostCentre" "link"
389
390 ,structField C "StgHeader" "info"
391 ,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
392 ,structField_ Both "StgHeader_ldvw" "StgHeader" "prof.hp.ldvw"
393
394 ,structSize Both "StgSMPThunkHeader"
395
396 ,closurePayload C "StgClosure" "payload"
397
398 ,structFieldH Both "StgEntCounter" "allocs"
399 ,structFieldH Both "StgEntCounter" "allocd"
400 ,structField Both "StgEntCounter" "registeredp"
401 ,structField Both "StgEntCounter" "link"
402 ,structField Both "StgEntCounter" "entry_count"
403
404 ,closureSize Both "StgUpdateFrame"
405 ,closureSize C "StgCatchFrame"
406 ,closureSize C "StgStopFrame"
407
408 ,closureSize Both "StgMutArrPtrs"
409 ,closureField Both "StgMutArrPtrs" "ptrs"
410 ,closureField Both "StgMutArrPtrs" "size"
411
412 ,closureSize Both "StgSmallMutArrPtrs"
413 ,closureField Both "StgSmallMutArrPtrs" "ptrs"
414
415 ,closureSize Both "StgArrBytes"
416 ,closureField Both "StgArrBytes" "bytes"
417 ,closurePayload C "StgArrBytes" "payload"
418
419 ,closureField C "StgTSO" "_link"
420 ,closureField C "StgTSO" "global_link"
421 ,closureField C "StgTSO" "what_next"
422 ,closureField C "StgTSO" "why_blocked"
423 ,closureField C "StgTSO" "block_info"
424 ,closureField C "StgTSO" "blocked_exceptions"
425 ,closureField C "StgTSO" "id"
426 ,closureField C "StgTSO" "cap"
427 ,closureField C "StgTSO" "saved_errno"
428 ,closureField C "StgTSO" "trec"
429 ,closureField C "StgTSO" "flags"
430 ,closureField C "StgTSO" "dirty"
431 ,closureField C "StgTSO" "bq"
432 ,closureField Both "StgTSO" "alloc_limit"
433 ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
434 ,closureField Both "StgTSO" "stackobj"
435
436 ,closureField Both "StgStack" "sp"
437 ,closureFieldOffset Both "StgStack" "stack"
438 ,closureField C "StgStack" "stack_size"
439 ,closureField C "StgStack" "dirty"
440
441 ,structSize C "StgTSOProfInfo"
442
443 ,closureField Both "StgUpdateFrame" "updatee"
444
445 ,closureField C "StgCatchFrame" "handler"
446 ,closureField C "StgCatchFrame" "exceptions_blocked"
447
448 ,closureSize C "StgPAP"
449 ,closureField C "StgPAP" "n_args"
450 ,closureFieldGcptr C "StgPAP" "fun"
451 ,closureField C "StgPAP" "arity"
452 ,closurePayload C "StgPAP" "payload"
453
454 ,thunkSize C "StgAP"
455 ,closureField C "StgAP" "n_args"
456 ,closureFieldGcptr C "StgAP" "fun"
457 ,closurePayload C "StgAP" "payload"
458
459 ,thunkSize C "StgAP_STACK"
460 ,closureField C "StgAP_STACK" "size"
461 ,closureFieldGcptr C "StgAP_STACK" "fun"
462 ,closurePayload C "StgAP_STACK" "payload"
463
464 ,thunkSize C "StgSelector"
465
466 ,closureFieldGcptr C "StgInd" "indirectee"
467
468 ,closureSize C "StgMutVar"
469 ,closureField C "StgMutVar" "var"
470
471 ,closureSize C "StgAtomicallyFrame"
472 ,closureField C "StgAtomicallyFrame" "code"
473 ,closureField C "StgAtomicallyFrame" "next_invariant_to_check"
474 ,closureField C "StgAtomicallyFrame" "result"
475
476 ,closureField C "StgInvariantCheckQueue" "invariant"
477 ,closureField C "StgInvariantCheckQueue" "my_execution"
478 ,closureField C "StgInvariantCheckQueue" "next_queue_entry"
479
480 ,closureField C "StgAtomicInvariant" "code"
481
482 ,closureField C "StgTRecHeader" "enclosing_trec"
483
484 ,closureSize C "StgCatchSTMFrame"
485 ,closureField C "StgCatchSTMFrame" "handler"
486 ,closureField C "StgCatchSTMFrame" "code"
487
488 ,closureSize C "StgCatchRetryFrame"
489 ,closureField C "StgCatchRetryFrame" "running_alt_code"
490 ,closureField C "StgCatchRetryFrame" "first_code"
491 ,closureField C "StgCatchRetryFrame" "alt_code"
492
493 ,closureField C "StgTVarWatchQueue" "closure"
494 ,closureField C "StgTVarWatchQueue" "next_queue_entry"
495 ,closureField C "StgTVarWatchQueue" "prev_queue_entry"
496
497 ,closureSize C "StgTVar"
498 ,closureField C "StgTVar" "current_value"
499 ,closureField C "StgTVar" "first_watch_queue_entry"
500 ,closureField C "StgTVar" "num_updates"
501
502 ,closureSize C "StgWeak"
503 ,closureField C "StgWeak" "link"
504 ,closureField C "StgWeak" "key"
505 ,closureField C "StgWeak" "value"
506 ,closureField C "StgWeak" "finalizer"
507 ,closureField C "StgWeak" "cfinalizers"
508
509 ,closureSize C "StgCFinalizerList"
510 ,closureField C "StgCFinalizerList" "link"
511 ,closureField C "StgCFinalizerList" "fptr"
512 ,closureField C "StgCFinalizerList" "ptr"
513 ,closureField C "StgCFinalizerList" "eptr"
514 ,closureField C "StgCFinalizerList" "flag"
515
516 ,closureSize C "StgMVar"
517 ,closureField C "StgMVar" "head"
518 ,closureField C "StgMVar" "tail"
519 ,closureField C "StgMVar" "value"
520
521 ,closureSize C "StgMVarTSOQueue"
522 ,closureField C "StgMVarTSOQueue" "link"
523 ,closureField C "StgMVarTSOQueue" "tso"
524
525 ,closureSize C "StgBCO"
526 ,closureField C "StgBCO" "instrs"
527 ,closureField C "StgBCO" "literals"
528 ,closureField C "StgBCO" "ptrs"
529 ,closureField C "StgBCO" "arity"
530 ,closureField C "StgBCO" "size"
531 ,closurePayload C "StgBCO" "bitmap"
532
533 ,closureSize C "StgStableName"
534 ,closureField C "StgStableName" "sn"
535
536 ,closureSize C "StgBlockingQueue"
537 ,closureField C "StgBlockingQueue" "bh"
538 ,closureField C "StgBlockingQueue" "owner"
539 ,closureField C "StgBlockingQueue" "queue"
540 ,closureField C "StgBlockingQueue" "link"
541
542 ,closureSize C "MessageBlackHole"
543 ,closureField C "MessageBlackHole" "link"
544 ,closureField C "MessageBlackHole" "tso"
545 ,closureField C "MessageBlackHole" "bh"
546
547 ,structField_ C "RtsFlags_ProfFlags_showCCSOnException"
548 "RTS_FLAGS" "ProfFlags.showCCSOnException"
549 ,structField_ C "RtsFlags_DebugFlags_apply"
550 "RTS_FLAGS" "DebugFlags.apply"
551 ,structField_ C "RtsFlags_DebugFlags_sanity"
552 "RTS_FLAGS" "DebugFlags.sanity"
553 ,structField_ C "RtsFlags_DebugFlags_weak"
554 "RTS_FLAGS" "DebugFlags.weak"
555 ,structField_ C "RtsFlags_GcFlags_initialStkSize"
556 "RTS_FLAGS" "GcFlags.initialStkSize"
557 ,structField_ C "RtsFlags_MiscFlags_tickInterval"
558 "RTS_FLAGS" "MiscFlags.tickInterval"
559
560 ,structSize C "StgFunInfoExtraFwd"
561 ,structField C "StgFunInfoExtraFwd" "slow_apply"
562 ,structField C "StgFunInfoExtraFwd" "fun_type"
563 ,structFieldH Both "StgFunInfoExtraFwd" "arity"
564 ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
565
566 ,structSize Both "StgFunInfoExtraRev"
567 ,structField C "StgFunInfoExtraRev" "slow_apply_offset"
568 ,structField C "StgFunInfoExtraRev" "fun_type"
569 ,structFieldH Both "StgFunInfoExtraRev" "arity"
570 ,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
571 ,structField_ C "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
572
573 ,structField C "StgLargeBitmap" "size"
574 ,fieldOffset C "StgLargeBitmap" "bitmap"
575
576 ,structSize C "snEntry"
577 ,structField C "snEntry" "sn_obj"
578 ,structField C "snEntry" "addr"
579
580 ,structSize C "spEntry"
581 ,structField C "spEntry" "addr"
582
583 -- Note that this conditional part only affects the C headers.
584 -- That's important, as it means we get the same PlatformConstants
585 -- type on all platforms.
586 ,if os == "mingw32"
587 then concat [structSize C "StgAsyncIOResult"
588 ,structField C "StgAsyncIOResult" "reqID"
589 ,structField C "StgAsyncIOResult" "len"
590 ,structField C "StgAsyncIOResult" "errCode"]
591 else []
592
593 -- pre-compiled thunk types
594 ,constantWord Haskell "MAX_SPEC_SELECTEE_SIZE" "MAX_SPEC_SELECTEE_SIZE"
595 ,constantWord Haskell "MAX_SPEC_AP_SIZE" "MAX_SPEC_AP_SIZE"
596
597 -- closure sizes: these do NOT include the header (see below for
598 -- header sizes)
599 ,constantWord Haskell "MIN_PAYLOAD_SIZE" "MIN_PAYLOAD_SIZE"
600
601 ,constantInt Haskell "MIN_INTLIKE" "MIN_INTLIKE"
602 ,constantWord Haskell "MAX_INTLIKE" "MAX_INTLIKE"
603
604 ,constantWord Haskell "MIN_CHARLIKE" "MIN_CHARLIKE"
605 ,constantWord Haskell "MAX_CHARLIKE" "MAX_CHARLIKE"
606
607 ,constantWord Haskell "MUT_ARR_PTRS_CARD_BITS" "MUT_ARR_PTRS_CARD_BITS"
608
609 -- A section of code-generator-related MAGIC CONSTANTS.
610 ,constantWord Haskell "MAX_Vanilla_REG" "MAX_VANILLA_REG"
611 ,constantWord Haskell "MAX_Float_REG" "MAX_FLOAT_REG"
612 ,constantWord Haskell "MAX_Double_REG" "MAX_DOUBLE_REG"
613 ,constantWord Haskell "MAX_Long_REG" "MAX_LONG_REG"
614 ,constantWord Haskell "MAX_XMM_REG" "MAX_XMM_REG"
615 ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG"
616 ,constantWord Haskell "MAX_Real_Float_REG" "MAX_REAL_FLOAT_REG"
617 ,constantWord Haskell "MAX_Real_Double_REG" "MAX_REAL_DOUBLE_REG"
618 ,constantWord Haskell "MAX_Real_XMM_REG" "MAX_REAL_XMM_REG"
619 ,constantWord Haskell "MAX_Real_Long_REG" "MAX_REAL_LONG_REG"
620
621 -- This tells the native code generator the size of the spill
622 -- area is has available.
623 ,constantWord Haskell "RESERVED_C_STACK_BYTES" "RESERVED_C_STACK_BYTES"
624 -- The amount of (Haskell) stack to leave free for saving
625 -- registers when returning to the scheduler.
626 ,constantWord Haskell "RESERVED_STACK_WORDS" "RESERVED_STACK_WORDS"
627 -- Continuations that need more than this amount of stack
628 -- should do their own stack check (see bug #1466).
629 ,constantWord Haskell "AP_STACK_SPLIM" "AP_STACK_SPLIM"
630
631 -- Size of a word, in bytes
632 ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD"
633
634 -- Size of a double in StgWords.
635 ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE"
636
637 -- Size of a C int, in bytes. May be smaller than wORD_SIZE.
638 ,constantWord Haskell "CINT_SIZE" "SIZEOF_INT"
639 ,constantWord Haskell "CLONG_SIZE" "SIZEOF_LONG"
640 ,constantWord Haskell "CLONG_LONG_SIZE" "SIZEOF_LONG_LONG"
641
642 -- Number of bits to shift a bitfield left by in an info table.
643 ,constantWord Haskell "BITMAP_BITS_SHIFT" "BITMAP_BITS_SHIFT"
644
645 -- Amount of pointer bits used for semi-tagging constructor closures
646 ,constantWord Haskell "TAG_BITS" "TAG_BITS"
647
648 ,constantBool Haskell "WORDS_BIGENDIAN" "defined(WORDS_BIGENDIAN)"
649 ,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"
650
651 ,constantWord Haskell "LDV_SHIFT" "LDV_SHIFT"
652 ,constantNatural Haskell "ILDV_CREATE_MASK" "LDV_CREATE_MASK"
653 ,constantNatural Haskell "ILDV_STATE_CREATE" "LDV_STATE_CREATE"
654 ,constantNatural Haskell "ILDV_STATE_USE" "LDV_STATE_USE"
655 ]
656
657 getWanted :: Bool -> FilePath -> FilePath -> [String] -> FilePath -> IO Results
658 getWanted verbose tmpdir gccProgram gccFlags nmProgram
659 = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) wanteds)
660 cFile = tmpdir </> "tmp.c"
661 oFile = tmpdir </> "tmp.o"
662 writeFile cFile cStuff
663 execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
664 xs <- case os of
665 "openbsd" -> readProcess "/usr/bin/objdump" ["--syms", oFile] ""
666 _ -> readProcess nmProgram ["-P", oFile] ""
667
668 let ls = lines xs
669 ms = map parseNmLine ls
670 m = Map.fromList $ catMaybes ms
671 rs <- mapM (lookupResult m) wanteds
672 return rs
673 where headers = ["#define IN_STG_CODE 0",
674 "",
675 "/*",
676 " * We need offsets of profiled things...",
677 " * better be careful that this doesn't",
678 " * affect the offsets of anything else.",
679 " */",
680 "",
681 "#define PROFILING",
682 "#define THREADED_RTS",
683 "",
684 "#include \"PosixSource.h\"",
685 "#include \"Rts.h\"",
686 "#include \"Stable.h\"",
687 "#include \"Capability.h\"",
688 "",
689 "#include <inttypes.h>",
690 "#include <stddef.h>",
691 "#include <stdio.h>",
692 "#include <string.h>",
693 "",
694 "#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))",
695 "#define TYPE_SIZE(type) (sizeof(type))",
696 "#define FUN_OFFSET(sym) (offsetof(Capability,f.sym) - offsetof(Capability,r))",
697 "",
698 "#pragma GCC poison sizeof"
699 ]
700
701 prefix = "derivedConstant"
702 mkFullName name = prefix ++ name
703
704 -- We add 1 to the value, as some platforms will make a symbol
705 -- of size 1 when for
706 -- char foo[0];
707 -- We then subtract 1 again when parsing.
708 doWanted (GetFieldType name (Fst (CExpr cExpr)))
709 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
710 doWanted (GetClosureSize name (Fst (CExpr cExpr)))
711 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
712 doWanted (GetWord name (Fst (CExpr cExpr)))
713 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
714 doWanted (GetInt name (Fst (CExpr cExpr)))
715 = ["char " ++ mkFullName name ++ "Mag[1 + ((intptr_t)(" ++ cExpr ++ ") >= 0 ? (" ++ cExpr ++ ") : -(" ++ cExpr ++ "))];",
716 "char " ++ mkFullName name ++ "Sig[(intptr_t)(" ++ cExpr ++ ") >= 0 ? 3 : 1];"]
717 doWanted (GetNatural name (Fst (CExpr cExpr)))
718 = -- These casts fix "right shift count >= width of type"
719 -- warnings
720 let cExpr' = "(uint64_t)(size_t)(" ++ cExpr ++ ")"
721 in ["char " ++ mkFullName name ++ "0[1 + ((" ++ cExpr' ++ ") & 0xFFFF)];",
722 "char " ++ mkFullName name ++ "1[1 + (((" ++ cExpr' ++ ") >> 16) & 0xFFFF)];",
723 "char " ++ mkFullName name ++ "2[1 + (((" ++ cExpr' ++ ") >> 32) & 0xFFFF)];",
724 "char " ++ mkFullName name ++ "3[1 + (((" ++ cExpr' ++ ") >> 48) & 0xFFFF)];"]
725 doWanted (GetBool name (Fst (CPPExpr cppExpr)))
726 = ["#if " ++ cppExpr,
727 "char " ++ mkFullName name ++ "[1];",
728 "#else",
729 "char " ++ mkFullName name ++ "[2];",
730 "#endif"]
731 doWanted (StructFieldMacro {}) = []
732 doWanted (ClosureFieldMacro {}) = []
733 doWanted (ClosurePayloadMacro {}) = []
734 doWanted (FieldTypeGcptrMacro {}) = []
735
736 -- parseNmLine parses "nm -P" output that looks like
737 -- "derivedConstantMAX_Vanilla_REG C 0000000b 0000000b" (GNU nm)
738 -- "_derivedConstantMAX_Vanilla_REG C b 0" (Mac OS X)
739 -- "_derivedConstantMAX_Vanilla_REG C 000000b" (MinGW)
740 -- "derivedConstantMAX_Vanilla_REG D 1 b" (Solaris)
741 -- and returns ("MAX_Vanilla_REG", 11)
742 parseNmLine line
743 = case words line of
744 ('_' : n) : "C" : s : _ -> mkP n s
745 n : "C" : s : _ -> mkP n s
746 [n, "D", _, s] -> mkP n s
747 [s, "O", "*COM*", _, n] -> mkP n s
748 _ -> Nothing
749 where mkP r s = case (stripPrefix prefix r, readHex s) of
750 (Just name, [(size, "")]) -> Just (name, size)
751 _ -> Nothing
752
753 -- If an Int value is larger than 2^28 or smaller
754 -- than -2^28, then fail.
755 -- This test is a bit conservative, but if any
756 -- constants are roughly maxBound or minBound then
757 -- we probably need them to be Integer rather than
758 -- Int so that -- cross-compiling between 32bit and
759 -- 64bit platforms works.
760 lookupSmall :: Map String Integer -> Name -> IO Integer
761 lookupSmall m name
762 = case Map.lookup name m of
763 Just v
764 | v > 2^(28 :: Int) ||
765 v < -(2^(28 :: Int)) ->
766 die ("Value too large for GetWord: " ++ show v)
767 | otherwise -> return v
768 Nothing -> die ("Can't find " ++ show name)
769
770 lookupResult :: Map String Integer -> (Where, What Fst)
771 -> IO (Where, What Snd)
772 lookupResult m (w, GetWord name _)
773 = do v <- lookupSmall m name
774 return (w, GetWord name (Snd (v - 1)))
775 lookupResult m (w, GetInt name _)
776 = do mag <- lookupSmall m (name ++ "Mag")
777 sig <- lookupSmall m (name ++ "Sig")
778 return (w, GetWord name (Snd ((mag - 1) * (sig - 2))))
779 lookupResult m (w, GetNatural name _)
780 = do v0 <- lookupSmall m (name ++ "0")
781 v1 <- lookupSmall m (name ++ "1")
782 v2 <- lookupSmall m (name ++ "2")
783 v3 <- lookupSmall m (name ++ "3")
784 let v = (v0 - 1)
785 + shiftL (v1 - 1) 16
786 + shiftL (v2 - 1) 32
787 + shiftL (v3 - 1) 48
788 return (w, GetWord name (Snd v))
789 lookupResult m (w, GetBool name _)
790 = do v <- lookupSmall m name
791 case v of
792 1 -> return (w, GetBool name (Snd True))
793 2 -> return (w, GetBool name (Snd False))
794 _ -> die ("Bad boolean: " ++ show v)
795 lookupResult m (w, GetFieldType name _)
796 = do v <- lookupSmall m name
797 return (w, GetFieldType name (Snd (v - 1)))
798 lookupResult m (w, GetClosureSize name _)
799 = do v <- lookupSmall m name
800 return (w, GetClosureSize name (Snd (v - 1)))
801 lookupResult _ (w, StructFieldMacro name)
802 = return (w, StructFieldMacro name)
803 lookupResult _ (w, ClosureFieldMacro name)
804 = return (w, ClosureFieldMacro name)
805 lookupResult _ (w, ClosurePayloadMacro name)
806 = return (w, ClosurePayloadMacro name)
807 lookupResult _ (w, FieldTypeGcptrMacro name)
808 = return (w, FieldTypeGcptrMacro name)
809
810 writeHaskellType :: FilePath -> [What Fst] -> IO ()
811 writeHaskellType fn ws = writeFile fn xs
812 where xs = unlines (headers ++ body ++ footers)
813 headers = ["data PlatformConstants = PlatformConstants {"
814 -- Now a kludge that allows the real entries to
815 -- all start with a comma, which makes life a
816 -- little easier
817 ," pc_platformConstants :: ()"]
818 footers = [" } deriving Read"]
819 body = concatMap doWhat ws
820 doWhat (GetClosureSize name _) = [" , pc_" ++ name ++ " :: Int"]
821 doWhat (GetFieldType name _) = [" , pc_" ++ name ++ " :: Int"]
822 doWhat (GetWord name _) = [" , pc_" ++ name ++ " :: Int"]
823 doWhat (GetInt name _) = [" , pc_" ++ name ++ " :: Int"]
824 doWhat (GetNatural name _) = [" , pc_" ++ name ++ " :: Integer"]
825 doWhat (GetBool name _) = [" , pc_" ++ name ++ " :: Bool"]
826 doWhat (StructFieldMacro {}) = []
827 doWhat (ClosureFieldMacro {}) = []
828 doWhat (ClosurePayloadMacro {}) = []
829 doWhat (FieldTypeGcptrMacro {}) = []
830
831 writeHaskellValue :: FilePath -> [What Snd] -> IO ()
832 writeHaskellValue fn rs = writeFile fn xs
833 where xs = unlines (headers ++ body ++ footers)
834 headers = ["PlatformConstants {"
835 ," pc_platformConstants = ()"]
836 footers = [" }"]
837 body = concatMap doWhat rs
838 doWhat (GetClosureSize name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
839 doWhat (GetFieldType name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
840 doWhat (GetWord name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
841 doWhat (GetInt name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
842 doWhat (GetNatural name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
843 doWhat (GetBool name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
844 doWhat (StructFieldMacro {}) = []
845 doWhat (ClosureFieldMacro {}) = []
846 doWhat (ClosurePayloadMacro {}) = []
847 doWhat (FieldTypeGcptrMacro {}) = []
848
849 writeHaskellWrappers :: FilePath -> [What Fst] -> IO ()
850 writeHaskellWrappers fn ws = writeFile fn xs
851 where xs = unlines body
852 body = concatMap doWhat ws
853 doWhat (GetFieldType {}) = []
854 doWhat (GetClosureSize {}) = []
855 doWhat (GetWord name _) = [haskellise name ++ " :: DynFlags -> Int",
856 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
857 doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
858 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
859 doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
860 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
861 doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
862 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
863 doWhat (StructFieldMacro {}) = []
864 doWhat (ClosureFieldMacro {}) = []
865 doWhat (ClosurePayloadMacro {}) = []
866 doWhat (FieldTypeGcptrMacro {}) = []
867
868 writeHaskellExports :: FilePath -> [What Fst] -> IO ()
869 writeHaskellExports fn ws = writeFile fn xs
870 where xs = unlines body
871 body = concatMap doWhat ws
872 doWhat (GetFieldType {}) = []
873 doWhat (GetClosureSize {}) = []
874 doWhat (GetWord name _) = [" " ++ haskellise name ++ ","]
875 doWhat (GetInt name _) = [" " ++ haskellise name ++ ","]
876 doWhat (GetNatural name _) = [" " ++ haskellise name ++ ","]
877 doWhat (GetBool name _) = [" " ++ haskellise name ++ ","]
878 doWhat (StructFieldMacro {}) = []
879 doWhat (ClosureFieldMacro {}) = []
880 doWhat (ClosurePayloadMacro {}) = []
881 doWhat (FieldTypeGcptrMacro {}) = []
882
883 writeHeader :: FilePath -> [What Snd] -> IO ()
884 writeHeader fn rs = writeFile fn xs
885 where xs = unlines (headers ++ body)
886 headers = ["/* This file is created automatically. Do not edit by hand.*/", ""]
887 body = concatMap doWhat rs
888 doWhat (GetFieldType name (Snd v)) = ["#define " ++ name ++ " b" ++ show (v * 8)]
889 doWhat (GetClosureSize name (Snd v)) = ["#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"]
890 doWhat (GetWord name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
891 doWhat (GetInt name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
892 doWhat (GetNatural name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
893 doWhat (GetBool name (Snd v)) = ["#define " ++ name ++ " " ++ show (fromEnum v)]
894 doWhat (StructFieldMacro nameBase) =
895 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"]
896 doWhat (ClosureFieldMacro nameBase) =
897 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"]
898 doWhat (ClosurePayloadMacro nameBase) =
899 ["#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"]
900 doWhat (FieldTypeGcptrMacro nameBase) =
901 ["#define REP_" ++ nameBase ++ " gcptr"]
902
903 die :: String -> IO a
904 die err = do hPutStrLn stderr err
905 exitFailure
906
907 execute :: Bool -> FilePath -> [String] -> IO ()
908 execute verbose prog args
909 = do when verbose $ putStrLn $ showCommandForUser prog args
910 ec <- rawSystem prog args
911 unless (ec == ExitSuccess) $
912 die ("Executing " ++ show prog ++ " failed")
913