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