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