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