Make default output less verbose (source/object paths)
[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
572 ,structSize C "StgCompactNFDataBlock"
573 ,structField C "StgCompactNFDataBlock" "self"
574 ,structField C "StgCompactNFDataBlock" "owner"
575 ,structField C "StgCompactNFDataBlock" "next"
576
577 ,structField_ C "RtsFlags_ProfFlags_showCCSOnException"
578 "RTS_FLAGS" "ProfFlags.showCCSOnException"
579 ,structField_ C "RtsFlags_DebugFlags_apply"
580 "RTS_FLAGS" "DebugFlags.apply"
581 ,structField_ C "RtsFlags_DebugFlags_sanity"
582 "RTS_FLAGS" "DebugFlags.sanity"
583 ,structField_ C "RtsFlags_DebugFlags_weak"
584 "RTS_FLAGS" "DebugFlags.weak"
585 ,structField_ C "RtsFlags_GcFlags_initialStkSize"
586 "RTS_FLAGS" "GcFlags.initialStkSize"
587 ,structField_ C "RtsFlags_MiscFlags_tickInterval"
588 "RTS_FLAGS" "MiscFlags.tickInterval"
589
590 ,structSize C "StgFunInfoExtraFwd"
591 ,structField C "StgFunInfoExtraFwd" "slow_apply"
592 ,structField C "StgFunInfoExtraFwd" "fun_type"
593 ,structFieldH Both "StgFunInfoExtraFwd" "arity"
594 ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
595
596 ,structSize Both "StgFunInfoExtraRev"
597 ,structField C "StgFunInfoExtraRev" "slow_apply_offset"
598 ,structField C "StgFunInfoExtraRev" "fun_type"
599 ,structFieldH Both "StgFunInfoExtraRev" "arity"
600 ,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
601 ,structField_ C "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
602
603 ,structField C "StgLargeBitmap" "size"
604 ,fieldOffset C "StgLargeBitmap" "bitmap"
605
606 ,structSize C "snEntry"
607 ,structField C "snEntry" "sn_obj"
608 ,structField C "snEntry" "addr"
609
610 ,structSize C "spEntry"
611 ,structField C "spEntry" "addr"
612
613 -- Note that this conditional part only affects the C headers.
614 -- That's important, as it means we get the same PlatformConstants
615 -- type on all platforms.
616 ,if os == "mingw32"
617 then concat [structSize C "StgAsyncIOResult"
618 ,structField C "StgAsyncIOResult" "reqID"
619 ,structField C "StgAsyncIOResult" "len"
620 ,structField C "StgAsyncIOResult" "errCode"]
621 else []
622
623 -- pre-compiled thunk types
624 ,constantWord Haskell "MAX_SPEC_SELECTEE_SIZE" "MAX_SPEC_SELECTEE_SIZE"
625 ,constantWord Haskell "MAX_SPEC_AP_SIZE" "MAX_SPEC_AP_SIZE"
626
627 -- closure sizes: these do NOT include the header (see below for
628 -- header sizes)
629 ,constantWord Haskell "MIN_PAYLOAD_SIZE" "MIN_PAYLOAD_SIZE"
630
631 ,constantInt Haskell "MIN_INTLIKE" "MIN_INTLIKE"
632 ,constantWord Haskell "MAX_INTLIKE" "MAX_INTLIKE"
633
634 ,constantWord Haskell "MIN_CHARLIKE" "MIN_CHARLIKE"
635 ,constantWord Haskell "MAX_CHARLIKE" "MAX_CHARLIKE"
636
637 ,constantWord Haskell "MUT_ARR_PTRS_CARD_BITS" "MUT_ARR_PTRS_CARD_BITS"
638
639 -- A section of code-generator-related MAGIC CONSTANTS.
640 ,constantWord Haskell "MAX_Vanilla_REG" "MAX_VANILLA_REG"
641 ,constantWord Haskell "MAX_Float_REG" "MAX_FLOAT_REG"
642 ,constantWord Haskell "MAX_Double_REG" "MAX_DOUBLE_REG"
643 ,constantWord Haskell "MAX_Long_REG" "MAX_LONG_REG"
644 ,constantWord Haskell "MAX_XMM_REG" "MAX_XMM_REG"
645 ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG"
646 ,constantWord Haskell "MAX_Real_Float_REG" "MAX_REAL_FLOAT_REG"
647 ,constantWord Haskell "MAX_Real_Double_REG" "MAX_REAL_DOUBLE_REG"
648 ,constantWord Haskell "MAX_Real_XMM_REG" "MAX_REAL_XMM_REG"
649 ,constantWord Haskell "MAX_Real_Long_REG" "MAX_REAL_LONG_REG"
650
651 -- This tells the native code generator the size of the spill
652 -- area is has available.
653 ,constantWord Haskell "RESERVED_C_STACK_BYTES" "RESERVED_C_STACK_BYTES"
654 -- The amount of (Haskell) stack to leave free for saving
655 -- registers when returning to the scheduler.
656 ,constantWord Haskell "RESERVED_STACK_WORDS" "RESERVED_STACK_WORDS"
657 -- Continuations that need more than this amount of stack
658 -- should do their own stack check (see bug #1466).
659 ,constantWord Haskell "AP_STACK_SPLIM" "AP_STACK_SPLIM"
660
661 -- Size of a word, in bytes
662 ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD"
663
664 -- Size of a double in StgWords.
665 ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE"
666
667 -- Size of a C int, in bytes. May be smaller than wORD_SIZE.
668 ,constantWord Haskell "CINT_SIZE" "SIZEOF_INT"
669 ,constantWord Haskell "CLONG_SIZE" "SIZEOF_LONG"
670 ,constantWord Haskell "CLONG_LONG_SIZE" "SIZEOF_LONG_LONG"
671
672 -- Number of bits to shift a bitfield left by in an info table.
673 ,constantWord Haskell "BITMAP_BITS_SHIFT" "BITMAP_BITS_SHIFT"
674
675 -- Amount of pointer bits used for semi-tagging constructor closures
676 ,constantWord Haskell "TAG_BITS" "TAG_BITS"
677
678 ,constantBool Haskell "WORDS_BIGENDIAN" "defined(WORDS_BIGENDIAN)"
679 ,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"
680
681 ,constantWord Haskell "LDV_SHIFT" "LDV_SHIFT"
682 ,constantNatural Haskell "ILDV_CREATE_MASK" "LDV_CREATE_MASK"
683 ,constantNatural Haskell "ILDV_STATE_CREATE" "LDV_STATE_CREATE"
684 ,constantNatural Haskell "ILDV_STATE_USE" "LDV_STATE_USE"
685 ]
686
687 getWanted :: Bool -> String -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath
688 -> IO Results
689 getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
690 = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds os))
691 cFile = tmpdir </> "tmp.c"
692 oFile = tmpdir </> "tmp.o"
693 writeFile cFile cStuff
694 execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
695 xs <- case os of
696 "openbsd" -> readProcess objdumpProgam ["--syms", oFile] ""
697 "aix" -> readProcess objdumpProgam ["--syms", oFile] ""
698 _ -> readProcess nmProgram ["-P", oFile] ""
699
700 let ls = lines xs
701 m = Map.fromList $ case os of
702 "aix" -> parseAixObjdump ls
703 _ -> catMaybes $ map parseNmLine ls
704
705 case Map.lookup "CONTROL_GROUP_CONST_291" m of
706 Just 292 -> return () -- OK
707 Nothing -> die "CONTROL_GROUP_CONST_291 missing!"
708 Just 0x292 -> die $ "broken 'nm' detected, see https://ghc.haskell.org/ticket/11744.\n"
709 ++ "\n"
710 ++ "Workaround: You may want to pass\n"
711 ++ " --with-nm=$(xcrun --find nm-classic)\n"
712 ++ "to 'configure'.\n"
713 Just x -> die ("unexpected value round-tripped for CONTROL_GROUP_CONST_291: " ++ show x)
714
715 rs <- mapM (lookupResult m) (wanteds os)
716 return rs
717 where headers = ["#define IN_STG_CODE 0",
718 "",
719 "/*",
720 " * We need offsets of profiled things...",
721 " * better be careful that this doesn't",
722 " * affect the offsets of anything else.",
723 " */",
724 "",
725 "#define PROFILING",
726 "#define THREADED_RTS",
727 "",
728 "#include \"PosixSource.h\"",
729 "#include \"Rts.h\"",
730 "#include \"Stable.h\"",
731 "#include \"Capability.h\"",
732 "",
733 "#include <inttypes.h>",
734 "#include <stddef.h>",
735 "#include <stdio.h>",
736 "#include <string.h>",
737 "",
738 "#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))",
739 "#define TYPE_SIZE(type) (sizeof(type))",
740 "#define FUN_OFFSET(sym) (offsetof(Capability,f.sym) - offsetof(Capability,r))",
741 "",
742 "#pragma GCC poison sizeof"
743 ]
744
745 objdumpProgam = maybe (error "no objdump program given") id mobjdumpProgram
746
747 prefix = "derivedConstant"
748 mkFullName name = prefix ++ name
749
750 -- We add 1 to the value, as some platforms will make a symbol
751 -- of size 1 when for
752 -- char foo[0];
753 -- We then subtract 1 again when parsing.
754 doWanted (GetFieldType name (Fst (CExpr cExpr)))
755 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
756 doWanted (GetClosureSize name (Fst (CExpr cExpr)))
757 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
758 doWanted (GetWord name (Fst (CExpr cExpr)))
759 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
760 doWanted (GetInt name (Fst (CExpr cExpr)))
761 = ["char " ++ mkFullName name ++ "Mag[1 + ((intptr_t)(" ++ cExpr ++ ") >= 0 ? (" ++ cExpr ++ ") : -(" ++ cExpr ++ "))];",
762 "char " ++ mkFullName name ++ "Sig[(intptr_t)(" ++ cExpr ++ ") >= 0 ? 3 : 1];"]
763 doWanted (GetNatural name (Fst (CExpr cExpr)))
764 = -- These casts fix "right shift count >= width of type"
765 -- warnings
766 let cExpr' = "(uint64_t)(size_t)(" ++ cExpr ++ ")"
767 in ["char " ++ mkFullName name ++ "0[1 + ((" ++ cExpr' ++ ") & 0xFFFF)];",
768 "char " ++ mkFullName name ++ "1[1 + (((" ++ cExpr' ++ ") >> 16) & 0xFFFF)];",
769 "char " ++ mkFullName name ++ "2[1 + (((" ++ cExpr' ++ ") >> 32) & 0xFFFF)];",
770 "char " ++ mkFullName name ++ "3[1 + (((" ++ cExpr' ++ ") >> 48) & 0xFFFF)];"]
771 doWanted (GetBool name (Fst (CPPExpr cppExpr)))
772 = ["#if " ++ cppExpr,
773 "char " ++ mkFullName name ++ "[1];",
774 "#else",
775 "char " ++ mkFullName name ++ "[2];",
776 "#endif"]
777 doWanted (StructFieldMacro {}) = []
778 doWanted (ClosureFieldMacro {}) = []
779 doWanted (ClosurePayloadMacro {}) = []
780 doWanted (FieldTypeGcptrMacro {}) = []
781
782 -- parseNmLine parses "nm -P" output that looks like
783 -- "derivedConstantMAX_Vanilla_REG C 0000000b 0000000b" (GNU nm)
784 -- "_derivedConstantMAX_Vanilla_REG C b 0" (Mac OS X)
785 -- "_derivedConstantMAX_Vanilla_REG C 000000b" (MinGW)
786 -- "derivedConstantMAX_Vanilla_REG D 1 b" (Solaris)
787 -- and returns ("MAX_Vanilla_REG", 11)
788 parseNmLine line
789 = case words line of
790 ('_' : n) : "C" : s : _ -> mkP n s
791 n : "C" : s : _ -> mkP n s
792 [n, "D", _, s] -> mkP n s
793 [s, "O", "*COM*", _, n] -> mkP n s
794 _ -> Nothing
795 where mkP r s = case (stripPrefix prefix r, readHex s) of
796 (Just name, [(size, "")]) -> Just (name, size)
797 _ -> Nothing
798
799 -- On AIX, `nm` isn't able to tell us the symbol size, so we
800 -- need to use `objdump --syms`. However, unlike on OpenBSD,
801 -- `objdump --syms` outputs entries spanning two lines, e.g.
802 --
803 -- [ 50](sec 3)(fl 0x00)(ty 0)(scl 2) (nx 1) 0x00000318 derivedConstantBLOCK_SIZE
804 -- AUX val 4097 prmhsh 0 snhsh 0 typ 3 algn 3 clss 5 stb 0 snstb 0
805 --
806 parseAixObjdump :: [String] -> [(String,Integer)]
807 parseAixObjdump = catMaybes . goAix
808 where
809 goAix (l1@('[':_):l2@('A':'U':'X':_):ls')
810 = parseObjDumpEntry l1 l2 : goAix ls'
811 goAix (_:ls') = goAix ls'
812 goAix [] = []
813
814 parseObjDumpEntry l1 l2
815 | ["val",n] <- take 2 (tail $ words l2)
816 , Just sym <- stripPrefix prefix sym0 = Just (sym, read n)
817 | otherwise = Nothing
818 where
819 [sym0, _] = take 2 (reverse $ words l1)
820
821 -- If an Int value is larger than 2^28 or smaller
822 -- than -2^28, then fail.
823 -- This test is a bit conservative, but if any
824 -- constants are roughly maxBound or minBound then
825 -- we probably need them to be Integer rather than
826 -- Int so that -- cross-compiling between 32bit and
827 -- 64bit platforms works.
828 lookupSmall :: Map String Integer -> Name -> IO Integer
829 lookupSmall m name
830 = case Map.lookup name m of
831 Just v
832 | v > 2^(28 :: Int) ||
833 v < -(2^(28 :: Int)) ->
834 die ("Value too large for GetWord: " ++ show v)
835 | otherwise -> return v
836 Nothing -> die ("Can't find " ++ show name)
837
838 lookupResult :: Map String Integer -> (Where, What Fst)
839 -> IO (Where, What Snd)
840 lookupResult m (w, GetWord name _)
841 = do v <- lookupSmall m name
842 return (w, GetWord name (Snd (v - 1)))
843 lookupResult m (w, GetInt name _)
844 = do mag <- lookupSmall m (name ++ "Mag")
845 sig <- lookupSmall m (name ++ "Sig")
846 return (w, GetWord name (Snd ((mag - 1) * (sig - 2))))
847 lookupResult m (w, GetNatural name _)
848 = do v0 <- lookupSmall m (name ++ "0")
849 v1 <- lookupSmall m (name ++ "1")
850 v2 <- lookupSmall m (name ++ "2")
851 v3 <- lookupSmall m (name ++ "3")
852 let v = (v0 - 1)
853 + shiftL (v1 - 1) 16
854 + shiftL (v2 - 1) 32
855 + shiftL (v3 - 1) 48
856 return (w, GetWord name (Snd v))
857 lookupResult m (w, GetBool name _)
858 = do v <- lookupSmall m name
859 case v of
860 1 -> return (w, GetBool name (Snd True))
861 2 -> return (w, GetBool name (Snd False))
862 _ -> die ("Bad boolean: " ++ show v)
863 lookupResult m (w, GetFieldType name _)
864 = do v <- lookupSmall m name
865 return (w, GetFieldType name (Snd (v - 1)))
866 lookupResult m (w, GetClosureSize name _)
867 = do v <- lookupSmall m name
868 return (w, GetClosureSize name (Snd (v - 1)))
869 lookupResult _ (w, StructFieldMacro name)
870 = return (w, StructFieldMacro name)
871 lookupResult _ (w, ClosureFieldMacro name)
872 = return (w, ClosureFieldMacro name)
873 lookupResult _ (w, ClosurePayloadMacro name)
874 = return (w, ClosurePayloadMacro name)
875 lookupResult _ (w, FieldTypeGcptrMacro name)
876 = return (w, FieldTypeGcptrMacro name)
877
878 writeHaskellType :: FilePath -> [What Fst] -> IO ()
879 writeHaskellType fn ws = writeFile fn xs
880 where xs = unlines (headers ++ body ++ footers)
881 headers = ["data PlatformConstants = PlatformConstants {"
882 -- Now a kludge that allows the real entries to
883 -- all start with a comma, which makes life a
884 -- little easier
885 ," pc_platformConstants :: ()"]
886 footers = [" } deriving Read"]
887 body = concatMap doWhat ws
888 doWhat (GetClosureSize name _) = [" , pc_" ++ name ++ " :: Int"]
889 doWhat (GetFieldType name _) = [" , pc_" ++ name ++ " :: Int"]
890 doWhat (GetWord name _) = [" , pc_" ++ name ++ " :: Int"]
891 doWhat (GetInt name _) = [" , pc_" ++ name ++ " :: Int"]
892 doWhat (GetNatural name _) = [" , pc_" ++ name ++ " :: Integer"]
893 doWhat (GetBool name _) = [" , pc_" ++ name ++ " :: Bool"]
894 doWhat (StructFieldMacro {}) = []
895 doWhat (ClosureFieldMacro {}) = []
896 doWhat (ClosurePayloadMacro {}) = []
897 doWhat (FieldTypeGcptrMacro {}) = []
898
899 writeHaskellValue :: FilePath -> [What Snd] -> IO ()
900 writeHaskellValue fn rs = writeFile fn xs
901 where xs = unlines (headers ++ body ++ footers)
902 headers = ["PlatformConstants {"
903 ," pc_platformConstants = ()"]
904 footers = [" }"]
905 body = concatMap doWhat rs
906 doWhat (GetClosureSize name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
907 doWhat (GetFieldType name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
908 doWhat (GetWord name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
909 doWhat (GetInt name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
910 doWhat (GetNatural name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
911 doWhat (GetBool name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
912 doWhat (StructFieldMacro {}) = []
913 doWhat (ClosureFieldMacro {}) = []
914 doWhat (ClosurePayloadMacro {}) = []
915 doWhat (FieldTypeGcptrMacro {}) = []
916
917 writeHaskellWrappers :: FilePath -> [What Fst] -> IO ()
918 writeHaskellWrappers fn ws = writeFile fn xs
919 where xs = unlines body
920 body = concatMap doWhat ws
921 doWhat (GetFieldType {}) = []
922 doWhat (GetClosureSize {}) = []
923 doWhat (GetWord name _) = [haskellise name ++ " :: DynFlags -> Int",
924 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
925 doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
926 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
927 doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
928 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
929 doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
930 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
931 doWhat (StructFieldMacro {}) = []
932 doWhat (ClosureFieldMacro {}) = []
933 doWhat (ClosurePayloadMacro {}) = []
934 doWhat (FieldTypeGcptrMacro {}) = []
935
936 writeHaskellExports :: FilePath -> [What Fst] -> IO ()
937 writeHaskellExports fn ws = writeFile fn xs
938 where xs = unlines body
939 body = concatMap doWhat ws
940 doWhat (GetFieldType {}) = []
941 doWhat (GetClosureSize {}) = []
942 doWhat (GetWord name _) = [" " ++ haskellise name ++ ","]
943 doWhat (GetInt name _) = [" " ++ haskellise name ++ ","]
944 doWhat (GetNatural name _) = [" " ++ haskellise name ++ ","]
945 doWhat (GetBool name _) = [" " ++ haskellise name ++ ","]
946 doWhat (StructFieldMacro {}) = []
947 doWhat (ClosureFieldMacro {}) = []
948 doWhat (ClosurePayloadMacro {}) = []
949 doWhat (FieldTypeGcptrMacro {}) = []
950
951 writeHeader :: FilePath -> [What Snd] -> IO ()
952 writeHeader fn rs = writeFile fn xs
953 where xs = unlines (headers ++ body)
954 headers = ["/* This file is created automatically. Do not edit by hand.*/", ""]
955 body = concatMap doWhat rs
956 doWhat (GetFieldType name (Snd v)) = ["#define " ++ name ++ " b" ++ show (v * 8)]
957 doWhat (GetClosureSize name (Snd v)) = ["#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"]
958 doWhat (GetWord name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
959 doWhat (GetInt name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
960 doWhat (GetNatural name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
961 doWhat (GetBool name (Snd v)) = ["#define " ++ name ++ " " ++ show (fromEnum v)]
962 doWhat (StructFieldMacro nameBase) =
963 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"]
964 doWhat (ClosureFieldMacro nameBase) =
965 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"]
966 doWhat (ClosurePayloadMacro nameBase) =
967 ["#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"]
968 doWhat (FieldTypeGcptrMacro nameBase) =
969 ["#define REP_" ++ nameBase ++ " gcptr"]
970
971 die :: String -> IO a
972 die err = do hPutStrLn stderr err
973 exitFailure
974
975 execute :: Bool -> FilePath -> [String] -> IO ()
976 execute verbose prog args
977 = do when verbose $ putStrLn $ showCommandForUser prog args
978 ec <- rawSystem prog args
979 unless (ec == ExitSuccess) $
980 die ("Executing " ++ show prog ++ " failed")
981