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