Separate StablePtr and StableName tables (#7674)
[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" "rXMM1"
311 ,fieldOffset Both "StgRegTable" "rXMM2"
312 ,fieldOffset Both "StgRegTable" "rXMM3"
313 ,fieldOffset Both "StgRegTable" "rXMM4"
314 ,fieldOffset Both "StgRegTable" "rXMM5"
315 ,fieldOffset Both "StgRegTable" "rXMM6"
316 ,fieldOffset Both "StgRegTable" "rL1"
317 ,fieldOffset Both "StgRegTable" "rSp"
318 ,fieldOffset Both "StgRegTable" "rSpLim"
319 ,fieldOffset Both "StgRegTable" "rHp"
320 ,fieldOffset Both "StgRegTable" "rHpLim"
321 ,fieldOffset Both "StgRegTable" "rCCCS"
322 ,fieldOffset Both "StgRegTable" "rCurrentTSO"
323 ,fieldOffset Both "StgRegTable" "rCurrentNursery"
324 ,fieldOffset Both "StgRegTable" "rHpAlloc"
325 ,structField C "StgRegTable" "rRet"
326 ,structField C "StgRegTable" "rNursery"
327
328 ,defIntOffset Both "stgEagerBlackholeInfo"
329 "FUN_OFFSET(stgEagerBlackholeInfo)"
330 ,defIntOffset Both "stgGCEnter1" "FUN_OFFSET(stgGCEnter1)"
331 ,defIntOffset Both "stgGCFun" "FUN_OFFSET(stgGCFun)"
332
333 ,fieldOffset Both "Capability" "r"
334 ,fieldOffset C "Capability" "lock"
335 ,structField C "Capability" "no"
336 ,structField C "Capability" "mut_lists"
337 ,structField C "Capability" "context_switch"
338 ,structField C "Capability" "interrupt"
339 ,structField C "Capability" "sparks"
340
341 ,structField Both "bdescr" "start"
342 ,structField Both "bdescr" "free"
343 ,structField Both "bdescr" "blocks"
344 ,structField C "bdescr" "gen_no"
345 ,structField C "bdescr" "link"
346
347 ,structSize C "generation"
348 ,structField C "generation" "n_new_large_words"
349
350 ,structSize Both "CostCentreStack"
351 ,structField C "CostCentreStack" "ccsID"
352 ,structFieldH Both "CostCentreStack" "mem_alloc"
353 ,structFieldH Both "CostCentreStack" "scc_count"
354 ,structField C "CostCentreStack" "prevStack"
355
356 ,structField C "CostCentre" "ccID"
357 ,structField C "CostCentre" "link"
358
359 ,structField C "StgHeader" "info"
360 ,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
361 ,structField_ Both "StgHeader_ldvw" "StgHeader" "prof.hp.ldvw"
362
363 ,structSize Both "StgSMPThunkHeader"
364
365 ,closurePayload C "StgClosure" "payload"
366
367 ,structFieldH Both "StgEntCounter" "allocs"
368 ,structField Both "StgEntCounter" "registeredp"
369 ,structField Both "StgEntCounter" "link"
370 ,structField Both "StgEntCounter" "entry_count"
371
372 ,closureSize Both "StgUpdateFrame"
373 ,closureSize C "StgCatchFrame"
374 ,closureSize C "StgStopFrame"
375
376 ,closureSize Both "StgMutArrPtrs"
377 ,closureField Both "StgMutArrPtrs" "ptrs"
378 ,closureField Both "StgMutArrPtrs" "size"
379
380 ,closureSize Both "StgArrWords"
381 ,closureField C "StgArrWords" "bytes"
382 ,closurePayload C "StgArrWords" "payload"
383
384 ,closureField C "StgTSO" "_link"
385 ,closureField C "StgTSO" "global_link"
386 ,closureField C "StgTSO" "what_next"
387 ,closureField C "StgTSO" "why_blocked"
388 ,closureField C "StgTSO" "block_info"
389 ,closureField C "StgTSO" "blocked_exceptions"
390 ,closureField C "StgTSO" "id"
391 ,closureField C "StgTSO" "cap"
392 ,closureField C "StgTSO" "saved_errno"
393 ,closureField C "StgTSO" "trec"
394 ,closureField C "StgTSO" "flags"
395 ,closureField C "StgTSO" "dirty"
396 ,closureField C "StgTSO" "bq"
397 ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
398 ,closureField Both "StgTSO" "stackobj"
399
400 ,closureField Both "StgStack" "sp"
401 ,closureFieldOffset Both "StgStack" "stack"
402 ,closureField C "StgStack" "stack_size"
403 ,closureField C "StgStack" "dirty"
404
405 ,structSize C "StgTSOProfInfo"
406
407 ,closureField Both "StgUpdateFrame" "updatee"
408
409 ,closureField C "StgCatchFrame" "handler"
410 ,closureField C "StgCatchFrame" "exceptions_blocked"
411
412 ,closureSize C "StgPAP"
413 ,closureField C "StgPAP" "n_args"
414 ,closureFieldGcptr C "StgPAP" "fun"
415 ,closureField C "StgPAP" "arity"
416 ,closurePayload C "StgPAP" "payload"
417
418 ,thunkSize C "StgAP"
419 ,closureField C "StgAP" "n_args"
420 ,closureFieldGcptr C "StgAP" "fun"
421 ,closurePayload C "StgAP" "payload"
422
423 ,thunkSize C "StgAP_STACK"
424 ,closureField C "StgAP_STACK" "size"
425 ,closureFieldGcptr C "StgAP_STACK" "fun"
426 ,closurePayload C "StgAP_STACK" "payload"
427
428 ,thunkSize C "StgSelector"
429
430 ,closureFieldGcptr C "StgInd" "indirectee"
431
432 ,closureSize C "StgMutVar"
433 ,closureField C "StgMutVar" "var"
434
435 ,closureSize C "StgAtomicallyFrame"
436 ,closureField C "StgAtomicallyFrame" "code"
437 ,closureField C "StgAtomicallyFrame" "next_invariant_to_check"
438 ,closureField C "StgAtomicallyFrame" "result"
439
440 ,closureField C "StgInvariantCheckQueue" "invariant"
441 ,closureField C "StgInvariantCheckQueue" "my_execution"
442 ,closureField C "StgInvariantCheckQueue" "next_queue_entry"
443
444 ,closureField C "StgAtomicInvariant" "code"
445
446 ,closureField C "StgTRecHeader" "enclosing_trec"
447
448 ,closureSize C "StgCatchSTMFrame"
449 ,closureField C "StgCatchSTMFrame" "handler"
450 ,closureField C "StgCatchSTMFrame" "code"
451
452 ,closureSize C "StgCatchRetryFrame"
453 ,closureField C "StgCatchRetryFrame" "running_alt_code"
454 ,closureField C "StgCatchRetryFrame" "first_code"
455 ,closureField C "StgCatchRetryFrame" "alt_code"
456
457 ,closureField C "StgTVarWatchQueue" "closure"
458 ,closureField C "StgTVarWatchQueue" "next_queue_entry"
459 ,closureField C "StgTVarWatchQueue" "prev_queue_entry"
460
461 ,closureSize C "StgTVar"
462 ,closureField C "StgTVar" "current_value"
463 ,closureField C "StgTVar" "first_watch_queue_entry"
464 ,closureField C "StgTVar" "num_updates"
465
466 ,closureSize C "StgWeak"
467 ,closureField C "StgWeak" "link"
468 ,closureField C "StgWeak" "key"
469 ,closureField C "StgWeak" "value"
470 ,closureField C "StgWeak" "finalizer"
471 ,closureField C "StgWeak" "cfinalizer"
472
473 ,closureSize C "StgDeadWeak"
474 ,closureField C "StgDeadWeak" "link"
475
476 ,closureSize C "StgMVar"
477 ,closureField C "StgMVar" "head"
478 ,closureField C "StgMVar" "tail"
479 ,closureField C "StgMVar" "value"
480
481 ,closureSize C "StgMVarTSOQueue"
482 ,closureField C "StgMVarTSOQueue" "link"
483 ,closureField C "StgMVarTSOQueue" "tso"
484
485 ,closureSize C "StgBCO"
486 ,closureField C "StgBCO" "instrs"
487 ,closureField C "StgBCO" "literals"
488 ,closureField C "StgBCO" "ptrs"
489 ,closureField C "StgBCO" "arity"
490 ,closureField C "StgBCO" "size"
491 ,closurePayload C "StgBCO" "bitmap"
492
493 ,closureSize C "StgStableName"
494 ,closureField C "StgStableName" "sn"
495
496 ,closureSize C "StgBlockingQueue"
497 ,closureField C "StgBlockingQueue" "bh"
498 ,closureField C "StgBlockingQueue" "owner"
499 ,closureField C "StgBlockingQueue" "queue"
500 ,closureField C "StgBlockingQueue" "link"
501
502 ,closureSize C "MessageBlackHole"
503 ,closureField C "MessageBlackHole" "link"
504 ,closureField C "MessageBlackHole" "tso"
505 ,closureField C "MessageBlackHole" "bh"
506
507 ,structField_ C "RtsFlags_ProfFlags_showCCSOnException"
508 "RTS_FLAGS" "ProfFlags.showCCSOnException"
509 ,structField_ C "RtsFlags_DebugFlags_apply"
510 "RTS_FLAGS" "DebugFlags.apply"
511 ,structField_ C "RtsFlags_DebugFlags_sanity"
512 "RTS_FLAGS" "DebugFlags.sanity"
513 ,structField_ C "RtsFlags_DebugFlags_weak"
514 "RTS_FLAGS" "DebugFlags.weak"
515 ,structField_ C "RtsFlags_GcFlags_initialStkSize"
516 "RTS_FLAGS" "GcFlags.initialStkSize"
517 ,structField_ C "RtsFlags_MiscFlags_tickInterval"
518 "RTS_FLAGS" "MiscFlags.tickInterval"
519
520 ,structSize C "StgFunInfoExtraFwd"
521 ,structField C "StgFunInfoExtraFwd" "slow_apply"
522 ,structField C "StgFunInfoExtraFwd" "fun_type"
523 ,structField C "StgFunInfoExtraFwd" "arity"
524 ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
525
526 ,structSize Both "StgFunInfoExtraRev"
527 ,structField C "StgFunInfoExtraRev" "slow_apply_offset"
528 ,structField C "StgFunInfoExtraRev" "fun_type"
529 ,structField C "StgFunInfoExtraRev" "arity"
530 ,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
531
532 ,structField C "StgLargeBitmap" "size"
533 ,fieldOffset C "StgLargeBitmap" "bitmap"
534
535 ,structSize C "snEntry"
536 ,structField C "snEntry" "sn_obj"
537 ,structField C "snEntry" "addr"
538
539 ,structSize C "spEntry"
540 ,structField C "spEntry" "addr"
541
542 -- Note that this conditional part only affects the C headers.
543 -- That's important, as it means we get the same PlatformConstants
544 -- type on all platforms.
545 ,if os == "mingw32"
546 then concat [structSize C "StgAsyncIOResult"
547 ,structField C "StgAsyncIOResult" "reqID"
548 ,structField C "StgAsyncIOResult" "len"
549 ,structField C "StgAsyncIOResult" "errCode"]
550 else []
551
552 -- pre-compiled thunk types
553 ,constantWord Haskell "MAX_SPEC_SELECTEE_SIZE" "MAX_SPEC_SELECTEE_SIZE"
554 ,constantWord Haskell "MAX_SPEC_AP_SIZE" "MAX_SPEC_AP_SIZE"
555
556 -- closure sizes: these do NOT include the header (see below for
557 -- header sizes)
558 ,constantWord Haskell "MIN_PAYLOAD_SIZE" "MIN_PAYLOAD_SIZE"
559
560 ,constantInt Haskell "MIN_INTLIKE" "MIN_INTLIKE"
561 ,constantWord Haskell "MAX_INTLIKE" "MAX_INTLIKE"
562
563 ,constantWord Haskell "MIN_CHARLIKE" "MIN_CHARLIKE"
564 ,constantWord Haskell "MAX_CHARLIKE" "MAX_CHARLIKE"
565
566 ,constantWord Haskell "MUT_ARR_PTRS_CARD_BITS" "MUT_ARR_PTRS_CARD_BITS"
567
568 -- A section of code-generator-related MAGIC CONSTANTS.
569 ,constantWord Haskell "MAX_Vanilla_REG" "MAX_VANILLA_REG"
570 ,constantWord Haskell "MAX_Float_REG" "MAX_FLOAT_REG"
571 ,constantWord Haskell "MAX_Double_REG" "MAX_DOUBLE_REG"
572 ,constantWord Haskell "MAX_Long_REG" "MAX_LONG_REG"
573 ,constantWord Haskell "MAX_SSE_REG" "MAX_SSE_REG"
574 ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG"
575 ,constantWord Haskell "MAX_Real_Float_REG" "MAX_REAL_FLOAT_REG"
576 ,constantWord Haskell "MAX_Real_Double_REG" "MAX_REAL_DOUBLE_REG"
577 ,constantWord Haskell "MAX_Real_SSE_REG" "MAX_REAL_SSE_REG"
578 ,constantWord Haskell "MAX_Real_Long_REG" "MAX_REAL_LONG_REG"
579
580 -- This tells the native code generator the size of the spill
581 -- area is has available.
582 ,constantWord Haskell "RESERVED_C_STACK_BYTES" "RESERVED_C_STACK_BYTES"
583 -- The amount of (Haskell) stack to leave free for saving
584 -- registers when returning to the scheduler.
585 ,constantWord Haskell "RESERVED_STACK_WORDS" "RESERVED_STACK_WORDS"
586 -- Continuations that need more than this amount of stack
587 -- should do their own stack check (see bug #1466).
588 ,constantWord Haskell "AP_STACK_SPLIM" "AP_STACK_SPLIM"
589
590 -- Size of a word, in bytes
591 ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD"
592
593 -- Size of a double in StgWords.
594 ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE"
595
596 -- Size of a C int, in bytes. May be smaller than wORD_SIZE.
597 ,constantWord Haskell "CINT_SIZE" "SIZEOF_INT"
598 ,constantWord Haskell "CLONG_SIZE" "SIZEOF_LONG"
599 ,constantWord Haskell "CLONG_LONG_SIZE" "SIZEOF_LONG_LONG"
600
601 -- Number of bits to shift a bitfield left by in an info table.
602 ,constantWord Haskell "BITMAP_BITS_SHIFT" "BITMAP_BITS_SHIFT"
603
604 -- Amount of pointer bits used for semi-tagging constructor closures
605 ,constantWord Haskell "TAG_BITS" "TAG_BITS"
606
607 ,constantBool Haskell "WORDS_BIGENDIAN" "defined(WORDS_BIGENDIAN)"
608 ,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"
609
610 ,constantWord Haskell "LDV_SHIFT" "LDV_SHIFT"
611 ,constantNatural Haskell "ILDV_CREATE_MASK" "LDV_CREATE_MASK"
612 ,constantNatural Haskell "ILDV_STATE_CREATE" "LDV_STATE_CREATE"
613 ,constantNatural Haskell "ILDV_STATE_USE" "LDV_STATE_USE"
614 ]
615
616 getWanted :: Bool -> FilePath -> FilePath -> [String] -> FilePath -> IO Results
617 getWanted verbose tmpdir gccProgram gccFlags nmProgram
618 = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) wanteds)
619 cFile = tmpdir </> "tmp.c"
620 oFile = tmpdir </> "tmp.o"
621 writeFile cFile cStuff
622 execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
623 xs <- readProcess nmProgram [oFile] ""
624 let ls = lines xs
625 ms = map parseNmLine ls
626 m = Map.fromList $ catMaybes ms
627 rs <- mapM (lookupResult m) wanteds
628 return rs
629 where headers = ["#define IN_STG_CODE 0",
630 "",
631 "/*",
632 " * We need offsets of profiled things...",
633 " * better be careful that this doesn't",
634 " * affect the offsets of anything else.",
635 " */",
636 "",
637 "#define PROFILING",
638 "#define THREADED_RTS",
639 "",
640 "#include \"PosixSource.h\"",
641 "#include \"Rts.h\"",
642 "#include \"Stable.h\"",
643 "#include \"Capability.h\"",
644 "",
645 "#include <inttypes.h>",
646 "#include <stddef.h>",
647 "#include <stdio.h>",
648 "#include <string.h>",
649 "",
650 "#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))",
651 "#define TYPE_SIZE(type) (sizeof(type))",
652 "#define FUN_OFFSET(sym) (offsetof(Capability,f.sym) - offsetof(Capability,r))",
653 "",
654 "#pragma GCC poison sizeof"
655 ]
656
657 prefix = "derivedConstant"
658 mkFullName name = prefix ++ name
659
660 -- We add 1 to the value, as some platforms will make a symbol
661 -- of size 1 when for
662 -- char foo[0];
663 -- We then subtract 1 again when parsing.
664 doWanted (GetFieldType name (Fst (CExpr cExpr)))
665 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
666 doWanted (GetClosureSize name (Fst (CExpr cExpr)))
667 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
668 doWanted (GetWord name (Fst (CExpr cExpr)))
669 = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
670 doWanted (GetInt name (Fst (CExpr cExpr)))
671 = ["char " ++ mkFullName name ++ "Mag[1 + ((intptr_t)(" ++ cExpr ++ ") >= 0 ? (" ++ cExpr ++ ") : -(" ++ cExpr ++ "))];",
672 "char " ++ mkFullName name ++ "Sig[(intptr_t)(" ++ cExpr ++ ") >= 0 ? 3 : 1];"]
673 doWanted (GetNatural name (Fst (CExpr cExpr)))
674 = -- These casts fix "right shift count >= width of type"
675 -- warnings
676 let cExpr' = "(uint64_t)(size_t)(" ++ cExpr ++ ")"
677 in ["char " ++ mkFullName name ++ "0[1 + ((" ++ cExpr' ++ ") & 0xFFFF)];",
678 "char " ++ mkFullName name ++ "1[1 + (((" ++ cExpr' ++ ") >> 16) & 0xFFFF)];",
679 "char " ++ mkFullName name ++ "2[1 + (((" ++ cExpr' ++ ") >> 32) & 0xFFFF)];",
680 "char " ++ mkFullName name ++ "3[1 + (((" ++ cExpr' ++ ") >> 48) & 0xFFFF)];"]
681 doWanted (GetBool name (Fst (CPPExpr cppExpr)))
682 = ["#if " ++ cppExpr,
683 "char " ++ mkFullName name ++ "[1];",
684 "#else",
685 "char " ++ mkFullName name ++ "[2];",
686 "#endif"]
687 doWanted (StructFieldMacro {}) = []
688 doWanted (ClosureFieldMacro {}) = []
689 doWanted (ClosurePayloadMacro {}) = []
690 doWanted (FieldTypeGcptrMacro {}) = []
691
692 -- parseNmLine parses nm output that looks like
693 -- "0000000b C derivedConstantMAX_Vanilla_REG"
694 -- and returns ("MAX_Vanilla_REG", 11)
695 parseNmLine xs0 = case break (' ' ==) xs0 of
696 (x1, ' ' : xs1) ->
697 case break (' ' ==) xs1 of
698 (x2, ' ' : x3) ->
699 case readHex x1 of
700 [(size, "")] ->
701 case x2 of
702 "C" ->
703 let x3' = case x3 of
704 '_' : rest -> rest
705 _ -> x3
706 in case stripPrefix prefix x3' of
707 Just name ->
708 Just (name, size)
709 _ -> Nothing
710 _ -> Nothing
711 _ -> Nothing
712 _ -> Nothing
713 _ -> Nothing
714
715 -- If an Int value is larger than 2^28 or smaller
716 -- than -2^28, then fail.
717 -- This test is a bit conservative, but if any
718 -- constants are roughly maxBound or minBound then
719 -- we probably need them to be Integer rather than
720 -- Int so that -- cross-compiling between 32bit and
721 -- 64bit platforms works.
722 lookupSmall :: Map String Integer -> Name -> IO Integer
723 lookupSmall m name
724 = case Map.lookup name m of
725 Just v
726 | v > 2^(28 :: Int) ||
727 v < -(2^(28 :: Int)) ->
728 die ("Value too large for GetWord: " ++ show v)
729 | otherwise -> return v
730 Nothing -> die ("Can't find " ++ show name)
731
732 lookupResult :: Map String Integer -> (Where, What Fst)
733 -> IO (Where, What Snd)
734 lookupResult m (w, GetWord name _)
735 = do v <- lookupSmall m name
736 return (w, GetWord name (Snd (v - 1)))
737 lookupResult m (w, GetInt name _)
738 = do mag <- lookupSmall m (name ++ "Mag")
739 sig <- lookupSmall m (name ++ "Sig")
740 return (w, GetWord name (Snd ((mag - 1) * (sig - 2))))
741 lookupResult m (w, GetNatural name _)
742 = do v0 <- lookupSmall m (name ++ "0")
743 v1 <- lookupSmall m (name ++ "1")
744 v2 <- lookupSmall m (name ++ "2")
745 v3 <- lookupSmall m (name ++ "3")
746 let v = (v0 - 1)
747 + shiftL (v1 - 1) 16
748 + shiftL (v2 - 1) 32
749 + shiftL (v3 - 1) 48
750 return (w, GetWord name (Snd v))
751 lookupResult m (w, GetBool name _)
752 = do v <- lookupSmall m name
753 case v of
754 1 -> return (w, GetBool name (Snd True))
755 2 -> return (w, GetBool name (Snd False))
756 _ -> die ("Bad boolean: " ++ show v)
757 lookupResult m (w, GetFieldType name _)
758 = do v <- lookupSmall m name
759 return (w, GetFieldType name (Snd (v - 1)))
760 lookupResult m (w, GetClosureSize name _)
761 = do v <- lookupSmall m name
762 return (w, GetClosureSize name (Snd (v - 1)))
763 lookupResult _ (w, StructFieldMacro name)
764 = return (w, StructFieldMacro name)
765 lookupResult _ (w, ClosureFieldMacro name)
766 = return (w, ClosureFieldMacro name)
767 lookupResult _ (w, ClosurePayloadMacro name)
768 = return (w, ClosurePayloadMacro name)
769 lookupResult _ (w, FieldTypeGcptrMacro name)
770 = return (w, FieldTypeGcptrMacro name)
771
772 writeHaskellType :: FilePath -> [What Fst] -> IO ()
773 writeHaskellType fn ws = writeFile fn xs
774 where xs = unlines (headers ++ body ++ footers)
775 headers = ["data PlatformConstants = PlatformConstants {"
776 -- Now a kludge that allows the real entries to
777 -- all start with a comma, which makes life a
778 -- little easier
779 ," pc_platformConstants :: ()"]
780 footers = [" } deriving Read"]
781 body = concatMap doWhat ws
782 doWhat (GetClosureSize name _) = [" , pc_" ++ name ++ " :: Int"]
783 doWhat (GetFieldType name _) = [" , pc_" ++ name ++ " :: Int"]
784 doWhat (GetWord name _) = [" , pc_" ++ name ++ " :: Int"]
785 doWhat (GetInt name _) = [" , pc_" ++ name ++ " :: Int"]
786 doWhat (GetNatural name _) = [" , pc_" ++ name ++ " :: Integer"]
787 doWhat (GetBool name _) = [" , pc_" ++ name ++ " :: Bool"]
788 doWhat (StructFieldMacro {}) = []
789 doWhat (ClosureFieldMacro {}) = []
790 doWhat (ClosurePayloadMacro {}) = []
791 doWhat (FieldTypeGcptrMacro {}) = []
792
793 writeHaskellValue :: FilePath -> [What Snd] -> IO ()
794 writeHaskellValue fn rs = writeFile fn xs
795 where xs = unlines (headers ++ body ++ footers)
796 headers = ["PlatformConstants {"
797 ," pc_platformConstants = ()"]
798 footers = [" }"]
799 body = concatMap doWhat rs
800 doWhat (GetClosureSize name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
801 doWhat (GetFieldType name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
802 doWhat (GetWord name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
803 doWhat (GetInt name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
804 doWhat (GetNatural name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
805 doWhat (GetBool name (Snd v)) = [" , pc_" ++ name ++ " = " ++ show v]
806 doWhat (StructFieldMacro {}) = []
807 doWhat (ClosureFieldMacro {}) = []
808 doWhat (ClosurePayloadMacro {}) = []
809 doWhat (FieldTypeGcptrMacro {}) = []
810
811 writeHaskellWrappers :: FilePath -> [What Fst] -> IO ()
812 writeHaskellWrappers fn ws = writeFile fn xs
813 where xs = unlines body
814 body = concatMap doWhat ws
815 doWhat (GetFieldType {}) = []
816 doWhat (GetClosureSize {}) = []
817 doWhat (GetWord name _) = [haskellise name ++ " :: DynFlags -> Int",
818 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
819 doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
820 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
821 doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
822 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
823 doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
824 haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
825 doWhat (StructFieldMacro {}) = []
826 doWhat (ClosureFieldMacro {}) = []
827 doWhat (ClosurePayloadMacro {}) = []
828 doWhat (FieldTypeGcptrMacro {}) = []
829
830 writeHaskellExports :: FilePath -> [What Fst] -> IO ()
831 writeHaskellExports fn ws = writeFile fn xs
832 where xs = unlines body
833 body = concatMap doWhat ws
834 doWhat (GetFieldType {}) = []
835 doWhat (GetClosureSize {}) = []
836 doWhat (GetWord name _) = [" " ++ haskellise name ++ ","]
837 doWhat (GetInt name _) = [" " ++ haskellise name ++ ","]
838 doWhat (GetNatural name _) = [" " ++ haskellise name ++ ","]
839 doWhat (GetBool name _) = [" " ++ haskellise name ++ ","]
840 doWhat (StructFieldMacro {}) = []
841 doWhat (ClosureFieldMacro {}) = []
842 doWhat (ClosurePayloadMacro {}) = []
843 doWhat (FieldTypeGcptrMacro {}) = []
844
845 writeHeader :: FilePath -> [What Snd] -> IO ()
846 writeHeader fn rs = writeFile fn xs
847 where xs = unlines (headers ++ body)
848 headers = ["/* This file is created automatically. Do not edit by hand.*/", ""]
849 body = concatMap doWhat rs
850 doWhat (GetFieldType name (Snd v)) = ["#define " ++ name ++ " b" ++ show (v * 8)]
851 doWhat (GetClosureSize name (Snd v)) = ["#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"]
852 doWhat (GetWord name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
853 doWhat (GetInt name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
854 doWhat (GetNatural name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
855 doWhat (GetBool name (Snd v)) = ["#define " ++ name ++ " " ++ show (fromEnum v)]
856 doWhat (StructFieldMacro nameBase) =
857 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"]
858 doWhat (ClosureFieldMacro nameBase) =
859 ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"]
860 doWhat (ClosurePayloadMacro nameBase) =
861 ["#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"]
862 doWhat (FieldTypeGcptrMacro nameBase) =
863 ["#define REP_" ++ nameBase ++ " gcptr"]
864
865 die :: String -> IO a
866 die err = do hPutStrLn stderr err
867 exitFailure
868
869 execute :: Bool -> FilePath -> [String] -> IO ()
870 execute verbose prog args
871 = do when verbose $ putStrLn $ showCommandForUser prog args
872 ec <- rawSystem prog args
873 unless (ec == ExitSuccess) $
874 die ("Executing " ++ show prog ++ " failed")
875