Main.hs 44.4 KB
Newer Older
1 2 3 4 5 6 7 8 9
{- ------------------------------------------------------------------------

(c) The GHC Team, 1992-2012

DeriveConstants is a program that extracts information from the C
declarations in the header files (primarily struct field offsets)
and generates various files, such as a header file that can be #included
into non-C source containing this information.

10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
We want to get information about code generated by the C compiler,
such as the sizes of types, and offsets of struct fields.  We need
this because the layout of certain runtime objects is defined in C
headers (e.g. includes/rts/storage/Closures.h), but we need access to
the layout of these structures from a Haskell program (GHC).

One way to do this is to compile and run a C program that includes the
header files and prints out the sizes and offsets. However, when we
are cross-compiling, we can't run a C program compiled for the target
platform.

So, this program works as follows: we generate a C program that when
compiled to an object file, has the information we need encoded as
symbol sizes.  This means that we can extract the information without
needing to run the program, by inspecting the object file using 'nm'.

26 27
------------------------------------------------------------------------ -}

28 29 30
import Control.Monad (when, unless)
import Data.Bits (shiftL)
import Data.Char (toLower)
31
import Data.List (stripPrefix, intercalate)
32 33
import Data.Map (Map)
import qualified Data.Map as Map
34
import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
35 36 37 38 39 40
import Numeric (readHex)
import System.Environment (getArgs)
import System.Exit (ExitCode(ExitSuccess), exitFailure)
import System.FilePath ((</>))
import System.IO (stderr, hPutStrLn)
import System.Process (showCommandForUser, readProcess, rawSystem)
41 42 43 44 45 46 47 48

main :: IO ()
main = do opts <- parseArgs
          let getOption descr opt = case opt opts of
                                    Just x -> return x
                                    Nothing -> die ("No " ++ descr ++ " given")
          mode <- getOption "mode" o_mode
          fn <- getOption "output filename" o_outputFilename
49 50 51 52 53
          os <- getOption "target os"   o_targetOS

          let haskellWanteds = [ what | (wh, what) <- wanteds os
                                      , wh `elem` [Haskell, Both] ]

54 55 56 57 58 59 60 61
          case mode of
              Gen_Haskell_Type     -> writeHaskellType     fn haskellWanteds
              Gen_Haskell_Wrappers -> writeHaskellWrappers fn haskellWanteds
              Gen_Haskell_Exports  -> writeHaskellExports  fn haskellWanteds
              Gen_Computed cm ->
                  do tmpdir  <- getOption "tmpdir"      o_tmpdir
                     gccProg <- getOption "gcc program" o_gccProg
                     nmProg  <- getOption "nm program"  o_nmProg
62 63
                     let verbose = o_verbose opts
                         gccFlags = o_gccFlags opts
64 65
                     rs <- getWanted verbose os tmpdir gccProg gccFlags nmProg
                                     (o_objdumpProg opts)
66 67 68 69 70 71 72 73 74 75 76
                     let haskellRs = [ what
                                     | (wh, what) <- rs
                                     , wh `elem` [Haskell, Both] ]
                         cRs = [ what
                               | (wh, what) <- rs
                               , wh `elem` [C, Both] ]
                     case cm of
                         ComputeHaskell -> writeHaskellValue fn haskellRs
                         ComputeHeader  -> writeHeader       fn cRs

data Options = Options {
77
                   o_verbose :: Bool,
78 79 80 81 82
                   o_mode :: Maybe Mode,
                   o_tmpdir :: Maybe FilePath,
                   o_outputFilename :: Maybe FilePath,
                   o_gccProg :: Maybe FilePath,
                   o_gccFlags :: [String],
83 84 85
                   o_nmProg :: Maybe FilePath,
                   o_objdumpProg :: Maybe FilePath,
                   o_targetOS :: Maybe String
86 87 88 89 90 91 92
               }

parseArgs :: IO Options
parseArgs = do args <- getArgs
               opts <- f emptyOptions args
               return (opts {o_gccFlags = reverse (o_gccFlags opts)})
    where emptyOptions = Options {
93
                             o_verbose = False,
94 95 96 97 98
                             o_mode = Nothing,
                             o_tmpdir = Nothing,
                             o_outputFilename = Nothing,
                             o_gccProg = Nothing,
                             o_gccFlags = [],
99 100 101
                             o_nmProg = Nothing,
                             o_objdumpProg = Nothing,
                             o_targetOS = Nothing
102 103
                         }
          f opts [] = return opts
104 105
          f opts ("-v" : args')
              = f (opts {o_verbose = True}) args'
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
          f opts ("--gen-haskell-type" : args')
              = f (opts {o_mode = Just Gen_Haskell_Type}) args'
          f opts ("--gen-haskell-value" : args')
              = f (opts {o_mode = Just (Gen_Computed ComputeHaskell)}) args'
          f opts ("--gen-haskell-wrappers" : args')
              = f (opts {o_mode = Just Gen_Haskell_Wrappers}) args'
          f opts ("--gen-haskell-exports" : args')
              = f (opts {o_mode = Just Gen_Haskell_Exports}) args'
          f opts ("--gen-header" : args')
              = f (opts {o_mode = Just (Gen_Computed ComputeHeader)}) args'
          f opts ("--tmpdir" : dir : args')
              = f (opts {o_tmpdir = Just dir}) args'
          f opts ("-o" : fn : args')
              = f (opts {o_outputFilename = Just fn}) args'
          f opts ("--gcc-program" : prog : args')
              = f (opts {o_gccProg = Just prog}) args'
          f opts ("--gcc-flag" : flag : args')
              = f (opts {o_gccFlags = flag : o_gccFlags opts}) args'
          f opts ("--nm-program" : prog : args')
              = f (opts {o_nmProg = Just prog}) args'
126 127 128 129
          f opts ("--objdump-program" : prog : args')
              = f (opts {o_objdumpProg = Just prog}) args'
          f opts ("--target-os" : os : args')
              = f (opts {o_targetOS = Just os}) args'
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
          f _ (flag : _) = die ("Unrecognised flag: " ++ show flag)

data Mode = Gen_Haskell_Type
          | Gen_Haskell_Wrappers
          | Gen_Haskell_Exports
          | Gen_Computed ComputeMode

data ComputeMode = ComputeHaskell | ComputeHeader

type Wanteds = [(Where, What Fst)]
type Results = [(Where, What Snd)]

type Name = String
newtype CExpr = CExpr String
newtype CPPExpr = CPPExpr String
data What f = GetFieldType   Name (f CExpr   Integer)
            | GetClosureSize Name (f CExpr   Integer)
            | GetWord        Name (f CExpr   Integer)
            | GetInt         Name (f CExpr   Integer)
            | GetNatural     Name (f CExpr   Integer)
            | GetBool        Name (f CPPExpr Bool)
            | StructFieldMacro    Name
            | ClosureFieldMacro   Name
            | ClosurePayloadMacro Name
            | FieldTypeGcptrMacro Name

data Fst a b = Fst a
data Snd a b = Snd b

data Where = C | Haskell | Both
    deriving Eq

constantInt :: Where -> Name -> String -> Wanteds
constantInt w name expr = [(w, GetInt name (Fst (CExpr expr)))]

constantWord :: Where -> Name -> String -> Wanteds
constantWord w name expr = [(w, GetWord name (Fst (CExpr expr)))]

constantNatural :: Where -> Name -> String -> Wanteds
constantNatural w name expr = [(w, GetNatural name (Fst (CExpr expr)))]

constantBool :: Where -> Name -> String -> Wanteds
constantBool w name expr = [(w, GetBool name (Fst (CPPExpr expr)))]

fieldOffset :: Where -> String -> String -> Wanteds
fieldOffset w theType theField = fieldOffset_ w nameBase theType theField
    where nameBase = theType ++ "_" ++ theField

fieldOffset_ :: Where -> Name -> String -> String -> Wanteds
fieldOffset_ w nameBase theType theField = [(w, GetWord name (Fst (CExpr expr)))]
    where name = "OFFSET_" ++ nameBase
181
          expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ")"
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245

-- FieldType is for defining REP_x to be b32 etc
-- These are both the C-- types used in a load
--    e.g.  b32[addr]
-- and the names of the CmmTypes in the compiler
--    b32 :: CmmType
fieldType' :: Where -> String -> String -> Wanteds
fieldType' w theType theField
    = fieldType_' w nameBase theType theField
    where nameBase = theType ++ "_" ++ theField

fieldType_' :: Where -> Name -> String -> String -> Wanteds
fieldType_' w nameBase theType theField
    = [(w, GetFieldType name (Fst (CExpr expr)))]
    where name = "REP_" ++ nameBase
          expr = "FIELD_SIZE(" ++ theType ++ ", " ++ theField ++ ")"

structField :: Where -> String -> String -> Wanteds
structField = structFieldHelper C

structFieldH :: Where -> String -> String -> Wanteds
structFieldH w = structFieldHelper w w

structField_ :: Where -> Name -> String -> String -> Wanteds
structField_ w nameBase theType theField
    = fieldOffset_ w nameBase theType theField
   ++ fieldType_' C nameBase theType theField
   ++ structFieldMacro nameBase

structFieldMacro :: Name -> Wanteds
structFieldMacro nameBase = [(C, StructFieldMacro nameBase)]

-- Outputs the byte offset and MachRep for a field
structFieldHelper :: Where -> Where -> String -> String -> Wanteds
structFieldHelper wFT w theType theField = fieldOffset w theType theField
                                        ++ fieldType' wFT theType theField
                                        ++ structFieldMacro nameBase
    where nameBase = theType ++ "_" ++ theField

closureFieldMacro :: Name -> Wanteds
closureFieldMacro nameBase = [(C, ClosureFieldMacro nameBase)]

closurePayload :: Where -> String -> String -> Wanteds
closurePayload w theType theField
    = closureFieldOffset_ w nameBase theType theField
   ++ closurePayloadMacro nameBase
    where nameBase = theType ++ "_" ++ theField

closurePayloadMacro :: Name -> Wanteds
closurePayloadMacro nameBase = [(C, ClosurePayloadMacro nameBase)]

-- Byte offset and MachRep for a closure field, minus the header
closureField_ :: Where -> Name -> String -> String -> Wanteds
closureField_ w nameBase theType theField
    = closureFieldOffset_ w nameBase theType theField
   ++ fieldType_' C nameBase theType theField
   ++ closureFieldMacro nameBase

closureField :: Where -> String -> String -> Wanteds
closureField w theType theField = closureField_ w nameBase theType theField
    where nameBase = theType ++ "_" ++ theField

closureFieldOffset_ :: Where -> Name -> String -> String -> Wanteds
closureFieldOffset_ w nameBase theType theField
246
    = defOffset w nameBase (CExpr ("offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"))
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269

-- Size of a closure type, minus the header, named SIZEOF_<type>_NoHdr
-- Also, we #define SIZEOF_<type> to be the size of the whole closure for .cmm.
closureSize :: Where -> String -> Wanteds
closureSize w theType = defSize        w (theType ++ "_NoHdr") (CExpr expr)
                     ++ defClosureSize C theType               (CExpr expr)
    where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgHeader)"

-- Byte offset and MachRep for a closure field, minus the header
closureFieldGcptr :: Where -> String -> String -> Wanteds
closureFieldGcptr w theType theField
    = closureFieldOffset_ w nameBase theType theField
   ++ fieldTypeGcptr nameBase
   ++ closureFieldMacro nameBase
    where nameBase = theType ++ "_" ++ theField

fieldTypeGcptr :: Name -> Wanteds
fieldTypeGcptr nameBase = [(C, FieldTypeGcptrMacro nameBase)]

closureFieldOffset :: Where -> String -> String -> Wanteds
closureFieldOffset w theType theField
    = defOffset w nameBase (CExpr expr)
    where nameBase = theType ++ "_" ++ theField
270
          expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296

thunkSize :: Where -> String -> Wanteds
thunkSize w theType
    = defSize w (theType ++ "_NoThunkHdr") (CExpr expr)
  ++ closureSize w theType
    where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgThunkHeader)"

defIntOffset :: Where -> Name -> String -> Wanteds
defIntOffset w nameBase cExpr = [(w, GetInt ("OFFSET_" ++ nameBase) (Fst (CExpr cExpr)))]

defOffset :: Where -> Name -> CExpr -> Wanteds
defOffset w nameBase cExpr = [(w, GetWord ("OFFSET_" ++ nameBase) (Fst cExpr))]

structSize :: Where -> String -> Wanteds
structSize w theType = defSize w theType (CExpr ("TYPE_SIZE(" ++ theType ++ ")"))

defSize :: Where -> Name -> CExpr -> Wanteds
defSize w nameBase cExpr = [(w, GetWord ("SIZEOF_" ++ nameBase) (Fst cExpr))]

defClosureSize :: Where -> Name -> CExpr -> Wanteds
defClosureSize w nameBase cExpr = [(w, GetClosureSize ("SIZEOF_" ++ nameBase) (Fst cExpr))]

haskellise :: Name -> Name
haskellise (c : cs) = toLower c : cs
haskellise "" = ""

297 298
wanteds :: String -> Wanteds
wanteds os = concat
299 300 301 302 303 304
          [-- Control group constant for integrity check; this
           -- round-tripped constant is used for testing that
           -- derivedConstant works as expected
           constantWord Both "CONTROL_GROUP_CONST_291" "0x123"
           -- Closure header sizes.
          ,constantWord Both "STD_HDR_SIZE"
305 306 307 308 309
                             -- grrr.. PROFILING is on so we need to
                             -- subtract sizeofW(StgProfHeader)
                             "sizeofW(StgHeader) - sizeofW(StgProfHeader)"
          ,constantWord Both "PROF_HDR_SIZE" "sizeofW(StgProfHeader)"

310 311 312
           -- Stack flags for C--
          ,constantWord C "STACK_DIRTY" "STACK_DIRTY"

313 314 315 316 317 318 319 320
           -- Size of a storage manager block (in bytes).
          ,constantWord Both "BLOCK_SIZE"  "BLOCK_SIZE"
          ,constantWord C    "MBLOCK_SIZE" "MBLOCK_SIZE"
           -- blocks that fit in an MBlock, leaving space for the block
           -- descriptors
          ,constantWord Both "BLOCKS_PER_MBLOCK" "BLOCKS_PER_MBLOCK"
           -- could be derived, but better to save doing the calculation twice

mlen's avatar
mlen committed
321 322 323
          ,constantWord Both "TICKY_BIN_COUNT" "TICKY_BIN_COUNT"
           -- number of bins for histograms used in ticky code

324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345
          ,fieldOffset Both "StgRegTable" "rR1"
          ,fieldOffset Both "StgRegTable" "rR2"
          ,fieldOffset Both "StgRegTable" "rR3"
          ,fieldOffset Both "StgRegTable" "rR4"
          ,fieldOffset Both "StgRegTable" "rR5"
          ,fieldOffset Both "StgRegTable" "rR6"
          ,fieldOffset Both "StgRegTable" "rR7"
          ,fieldOffset Both "StgRegTable" "rR8"
          ,fieldOffset Both "StgRegTable" "rR9"
          ,fieldOffset Both "StgRegTable" "rR10"
          ,fieldOffset Both "StgRegTable" "rF1"
          ,fieldOffset Both "StgRegTable" "rF2"
          ,fieldOffset Both "StgRegTable" "rF3"
          ,fieldOffset Both "StgRegTable" "rF4"
          ,fieldOffset Both "StgRegTable" "rF5"
          ,fieldOffset Both "StgRegTable" "rF6"
          ,fieldOffset Both "StgRegTable" "rD1"
          ,fieldOffset Both "StgRegTable" "rD2"
          ,fieldOffset Both "StgRegTable" "rD3"
          ,fieldOffset Both "StgRegTable" "rD4"
          ,fieldOffset Both "StgRegTable" "rD5"
          ,fieldOffset Both "StgRegTable" "rD6"
346 347 348 349 350 351
          ,fieldOffset Both "StgRegTable" "rXMM1"
          ,fieldOffset Both "StgRegTable" "rXMM2"
          ,fieldOffset Both "StgRegTable" "rXMM3"
          ,fieldOffset Both "StgRegTable" "rXMM4"
          ,fieldOffset Both "StgRegTable" "rXMM5"
          ,fieldOffset Both "StgRegTable" "rXMM6"
352 353 354 355 356 357
          ,fieldOffset Both "StgRegTable" "rYMM1"
          ,fieldOffset Both "StgRegTable" "rYMM2"
          ,fieldOffset Both "StgRegTable" "rYMM3"
          ,fieldOffset Both "StgRegTable" "rYMM4"
          ,fieldOffset Both "StgRegTable" "rYMM5"
          ,fieldOffset Both "StgRegTable" "rYMM6"
358 359 360 361 362 363
          ,fieldOffset Both "StgRegTable" "rZMM1"
          ,fieldOffset Both "StgRegTable" "rZMM2"
          ,fieldOffset Both "StgRegTable" "rZMM3"
          ,fieldOffset Both "StgRegTable" "rZMM4"
          ,fieldOffset Both "StgRegTable" "rZMM5"
          ,fieldOffset Both "StgRegTable" "rZMM6"
364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387
          ,fieldOffset Both "StgRegTable" "rL1"
          ,fieldOffset Both "StgRegTable" "rSp"
          ,fieldOffset Both "StgRegTable" "rSpLim"
          ,fieldOffset Both "StgRegTable" "rHp"
          ,fieldOffset Both "StgRegTable" "rHpLim"
          ,fieldOffset Both "StgRegTable" "rCCCS"
          ,fieldOffset Both "StgRegTable" "rCurrentTSO"
          ,fieldOffset Both "StgRegTable" "rCurrentNursery"
          ,fieldOffset Both "StgRegTable" "rHpAlloc"
          ,structField C    "StgRegTable" "rRet"
          ,structField C    "StgRegTable" "rNursery"

          ,defIntOffset Both "stgEagerBlackholeInfo"
                             "FUN_OFFSET(stgEagerBlackholeInfo)"
          ,defIntOffset Both "stgGCEnter1" "FUN_OFFSET(stgGCEnter1)"
          ,defIntOffset Both "stgGCFun"    "FUN_OFFSET(stgGCFun)"

          ,fieldOffset Both "Capability" "r"
          ,fieldOffset C    "Capability" "lock"
          ,structField C    "Capability" "no"
          ,structField C    "Capability" "mut_lists"
          ,structField C    "Capability" "context_switch"
          ,structField C    "Capability" "interrupt"
          ,structField C    "Capability" "sparks"
Simon Marlow's avatar
Simon Marlow committed
388
          ,structField C    "Capability" "total_allocated"
389 390
          ,structField C    "Capability" "weak_ptr_list_hd"
          ,structField C    "Capability" "weak_ptr_list_tl"
391 392 393 394 395 396

          ,structField Both "bdescr" "start"
          ,structField Both "bdescr" "free"
          ,structField Both "bdescr" "blocks"
          ,structField C    "bdescr" "gen_no"
          ,structField C    "bdescr" "link"
gcampax's avatar
gcampax committed
397
          ,structField Both "bdescr" "flags"
398 399 400

          ,structSize C  "generation"
          ,structField C "generation" "n_new_large_words"
401
          ,structField C "generation" "weak_ptr_list"
402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420

          ,structSize Both   "CostCentreStack"
          ,structField C     "CostCentreStack" "ccsID"
          ,structFieldH Both "CostCentreStack" "mem_alloc"
          ,structFieldH Both "CostCentreStack" "scc_count"
          ,structField C     "CostCentreStack" "prevStack"

          ,structField C "CostCentre" "ccID"
          ,structField C "CostCentre" "link"

          ,structField C     "StgHeader" "info"
          ,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
          ,structField_ Both "StgHeader_ldvw" "StgHeader" "prof.hp.ldvw"

          ,structSize Both "StgSMPThunkHeader"

          ,closurePayload C "StgClosure" "payload"

          ,structFieldH Both "StgEntCounter" "allocs"
nfrisby's avatar
nfrisby committed
421
          ,structFieldH Both "StgEntCounter" "allocd"
422 423 424 425 426 427 428 429 430 431 432 433
          ,structField  Both "StgEntCounter" "registeredp"
          ,structField  Both "StgEntCounter" "link"
          ,structField  Both "StgEntCounter" "entry_count"

          ,closureSize Both "StgUpdateFrame"
          ,closureSize C    "StgCatchFrame"
          ,closureSize C    "StgStopFrame"

          ,closureSize  Both "StgMutArrPtrs"
          ,closureField Both "StgMutArrPtrs" "ptrs"
          ,closureField Both "StgMutArrPtrs" "size"

434 435 436
          ,closureSize  Both "StgSmallMutArrPtrs"
          ,closureField Both "StgSmallMutArrPtrs" "ptrs"

437 438 439
          ,closureSize    Both "StgArrBytes"
          ,closureField   Both "StgArrBytes" "bytes"
          ,closurePayload C    "StgArrBytes" "payload"
440 441 442 443 444 445 446 447 448 449 450 451 452 453

          ,closureField  C    "StgTSO"      "_link"
          ,closureField  C    "StgTSO"      "global_link"
          ,closureField  C    "StgTSO"      "what_next"
          ,closureField  C    "StgTSO"      "why_blocked"
          ,closureField  C    "StgTSO"      "block_info"
          ,closureField  C    "StgTSO"      "blocked_exceptions"
          ,closureField  C    "StgTSO"      "id"
          ,closureField  C    "StgTSO"      "cap"
          ,closureField  C    "StgTSO"      "saved_errno"
          ,closureField  C    "StgTSO"      "trec"
          ,closureField  C    "StgTSO"      "flags"
          ,closureField  C    "StgTSO"      "dirty"
          ,closureField  C    "StgTSO"      "bq"
454
          ,closureField  Both "StgTSO"      "alloc_limit"
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
          ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
          ,closureField  Both "StgTSO"      "stackobj"

          ,closureField       Both "StgStack" "sp"
          ,closureFieldOffset Both "StgStack" "stack"
          ,closureField       C    "StgStack" "stack_size"
          ,closureField       C    "StgStack" "dirty"

          ,structSize C "StgTSOProfInfo"

          ,closureField Both "StgUpdateFrame" "updatee"

          ,closureField C "StgCatchFrame" "handler"
          ,closureField C "StgCatchFrame" "exceptions_blocked"

          ,closureSize       C "StgPAP"
          ,closureField      C "StgPAP" "n_args"
          ,closureFieldGcptr C "StgPAP" "fun"
          ,closureField      C "StgPAP" "arity"
          ,closurePayload    C "StgPAP" "payload"

          ,thunkSize         C "StgAP"
          ,closureField      C "StgAP" "n_args"
          ,closureFieldGcptr C "StgAP" "fun"
          ,closurePayload    C "StgAP" "payload"

          ,thunkSize         C "StgAP_STACK"
          ,closureField      C "StgAP_STACK" "size"
          ,closureFieldGcptr C "StgAP_STACK" "fun"
          ,closurePayload    C "StgAP_STACK" "payload"

          ,thunkSize C "StgSelector"

          ,closureFieldGcptr C "StgInd" "indirectee"

          ,closureSize  C "StgMutVar"
          ,closureField C "StgMutVar" "var"

          ,closureSize  C "StgAtomicallyFrame"
          ,closureField C "StgAtomicallyFrame" "code"
          ,closureField C "StgAtomicallyFrame" "result"

          ,closureField C "StgTRecHeader" "enclosing_trec"

          ,closureSize  C "StgCatchSTMFrame"
          ,closureField C "StgCatchSTMFrame" "handler"
          ,closureField C "StgCatchSTMFrame" "code"

          ,closureSize  C "StgCatchRetryFrame"
          ,closureField C "StgCatchRetryFrame" "running_alt_code"
          ,closureField C "StgCatchRetryFrame" "first_code"
          ,closureField C "StgCatchRetryFrame" "alt_code"

          ,closureField C "StgTVarWatchQueue" "closure"
          ,closureField C "StgTVarWatchQueue" "next_queue_entry"
          ,closureField C "StgTVarWatchQueue" "prev_queue_entry"

          ,closureSize  C "StgTVar"
          ,closureField C "StgTVar" "current_value"
          ,closureField C "StgTVar" "first_watch_queue_entry"
          ,closureField C "StgTVar" "num_updates"

          ,closureSize  C "StgWeak"
          ,closureField C "StgWeak" "link"
          ,closureField C "StgWeak" "key"
          ,closureField C "StgWeak" "value"
          ,closureField C "StgWeak" "finalizer"
522 523 524 525 526 527 528 529
          ,closureField C "StgWeak" "cfinalizers"

          ,closureSize  C "StgCFinalizerList"
          ,closureField C "StgCFinalizerList" "link"
          ,closureField C "StgCFinalizerList" "fptr"
          ,closureField C "StgCFinalizerList" "ptr"
          ,closureField C "StgCFinalizerList" "eptr"
          ,closureField C "StgCFinalizerList" "flag"
530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561

          ,closureSize  C "StgMVar"
          ,closureField C "StgMVar" "head"
          ,closureField C "StgMVar" "tail"
          ,closureField C "StgMVar" "value"

          ,closureSize  C "StgMVarTSOQueue"
          ,closureField C "StgMVarTSOQueue" "link"
          ,closureField C "StgMVarTSOQueue" "tso"

          ,closureSize    C "StgBCO"
          ,closureField   C "StgBCO" "instrs"
          ,closureField   C "StgBCO" "literals"
          ,closureField   C "StgBCO" "ptrs"
          ,closureField   C "StgBCO" "arity"
          ,closureField   C "StgBCO" "size"
          ,closurePayload C "StgBCO" "bitmap"

          ,closureSize  C "StgStableName"
          ,closureField C "StgStableName" "sn"

          ,closureSize  C "StgBlockingQueue"
          ,closureField C "StgBlockingQueue" "bh"
          ,closureField C "StgBlockingQueue" "owner"
          ,closureField C "StgBlockingQueue" "queue"
          ,closureField C "StgBlockingQueue" "link"

          ,closureSize  C "MessageBlackHole"
          ,closureField C "MessageBlackHole" "link"
          ,closureField C "MessageBlackHole" "tso"
          ,closureField C "MessageBlackHole" "bh"

gcampax's avatar
gcampax committed
562 563 564 565 566
          ,closureSize  C "StgCompactNFData"
          ,closureField C "StgCompactNFData" "totalW"
          ,closureField C "StgCompactNFData" "autoBlockW"
          ,closureField C "StgCompactNFData" "nursery"
          ,closureField C "StgCompactNFData" "last"
567 568 569 570
          ,closureField C "StgCompactNFData" "hp"
          ,closureField C "StgCompactNFData" "hpLim"
          ,closureField C "StgCompactNFData" "hash"
          ,closureField C "StgCompactNFData" "result"
gcampax's avatar
gcampax committed
571 572 573 574 575 576

          ,structSize   C "StgCompactNFDataBlock"
          ,structField  C "StgCompactNFDataBlock" "self"
          ,structField  C "StgCompactNFDataBlock" "owner"
          ,structField  C "StgCompactNFDataBlock" "next"

577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592
          ,structField_ C "RtsFlags_ProfFlags_showCCSOnException"
                          "RTS_FLAGS" "ProfFlags.showCCSOnException"
          ,structField_ C "RtsFlags_DebugFlags_apply"
                          "RTS_FLAGS" "DebugFlags.apply"
          ,structField_ C "RtsFlags_DebugFlags_sanity"
                          "RTS_FLAGS" "DebugFlags.sanity"
          ,structField_ C "RtsFlags_DebugFlags_weak"
                          "RTS_FLAGS" "DebugFlags.weak"
          ,structField_ C "RtsFlags_GcFlags_initialStkSize"
                          "RTS_FLAGS" "GcFlags.initialStkSize"
          ,structField_ C "RtsFlags_MiscFlags_tickInterval"
                          "RTS_FLAGS" "MiscFlags.tickInterval"

          ,structSize   C "StgFunInfoExtraFwd"
          ,structField  C "StgFunInfoExtraFwd" "slow_apply"
          ,structField  C "StgFunInfoExtraFwd" "fun_type"
593
          ,structFieldH Both "StgFunInfoExtraFwd" "arity"
594 595 596 597 598
          ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"

          ,structSize   Both "StgFunInfoExtraRev"
          ,structField  C    "StgFunInfoExtraRev" "slow_apply_offset"
          ,structField  C    "StgFunInfoExtraRev" "fun_type"
599
          ,structFieldH Both "StgFunInfoExtraRev" "arity"
600
          ,structField_ C    "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
601
          ,structField_ C    "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
602 603 604 605 606 607 608 609

          ,structField C "StgLargeBitmap" "size"
          ,fieldOffset C "StgLargeBitmap" "bitmap"

          ,structSize  C "snEntry"
          ,structField C "snEntry" "sn_obj"
          ,structField C "snEntry" "addr"

610 611 612
          ,structSize  C "spEntry"
          ,structField C "spEntry" "addr"

613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
           -- Note that this conditional part only affects the C headers.
           -- That's important, as it means we get the same PlatformConstants
           -- type on all platforms.
          ,if os == "mingw32"
           then concat [structSize  C "StgAsyncIOResult"
                       ,structField C "StgAsyncIOResult" "reqID"
                       ,structField C "StgAsyncIOResult" "len"
                       ,structField C "StgAsyncIOResult" "errCode"]
           else []

          -- pre-compiled thunk types
          ,constantWord Haskell "MAX_SPEC_SELECTEE_SIZE" "MAX_SPEC_SELECTEE_SIZE"
          ,constantWord Haskell "MAX_SPEC_AP_SIZE"       "MAX_SPEC_AP_SIZE"

          -- closure sizes: these do NOT include the header (see below for
          -- header sizes)
          ,constantWord Haskell "MIN_PAYLOAD_SIZE" "MIN_PAYLOAD_SIZE"

          ,constantInt  Haskell "MIN_INTLIKE" "MIN_INTLIKE"
          ,constantWord Haskell "MAX_INTLIKE" "MAX_INTLIKE"

          ,constantWord Haskell "MIN_CHARLIKE" "MIN_CHARLIKE"
          ,constantWord Haskell "MAX_CHARLIKE" "MAX_CHARLIKE"

          ,constantWord Haskell "MUT_ARR_PTRS_CARD_BITS" "MUT_ARR_PTRS_CARD_BITS"

          -- A section of code-generator-related MAGIC CONSTANTS.
          ,constantWord Haskell "MAX_Vanilla_REG"      "MAX_VANILLA_REG"
          ,constantWord Haskell "MAX_Float_REG"        "MAX_FLOAT_REG"
          ,constantWord Haskell "MAX_Double_REG"       "MAX_DOUBLE_REG"
          ,constantWord Haskell "MAX_Long_REG"         "MAX_LONG_REG"
644
          ,constantWord Haskell "MAX_XMM_REG"          "MAX_XMM_REG"
645 646 647
          ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG"
          ,constantWord Haskell "MAX_Real_Float_REG"   "MAX_REAL_FLOAT_REG"
          ,constantWord Haskell "MAX_Real_Double_REG"  "MAX_REAL_DOUBLE_REG"
648
          ,constantWord Haskell "MAX_Real_XMM_REG"     "MAX_REAL_XMM_REG"
649 650 651
          ,constantWord Haskell "MAX_Real_Long_REG"    "MAX_REAL_LONG_REG"

          -- This tells the native code generator the size of the spill
652
          -- area it has available.
653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
          ,constantWord Haskell "RESERVED_C_STACK_BYTES" "RESERVED_C_STACK_BYTES"
          -- The amount of (Haskell) stack to leave free for saving
          -- registers when returning to the scheduler.
          ,constantWord Haskell "RESERVED_STACK_WORDS" "RESERVED_STACK_WORDS"
          -- Continuations that need more than this amount of stack
          -- should do their own stack check (see bug #1466).
          ,constantWord Haskell "AP_STACK_SPLIM" "AP_STACK_SPLIM"

          -- Size of a word, in bytes
          ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD"

          -- Size of a double in StgWords.
          ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE"

          -- Size of a C int, in bytes. May be smaller than wORD_SIZE.
          ,constantWord Haskell "CINT_SIZE"       "SIZEOF_INT"
          ,constantWord Haskell "CLONG_SIZE"      "SIZEOF_LONG"
          ,constantWord Haskell "CLONG_LONG_SIZE" "SIZEOF_LONG_LONG"

          -- Number of bits to shift a bitfield left by in an info table.
          ,constantWord Haskell "BITMAP_BITS_SHIFT" "BITMAP_BITS_SHIFT"

          -- Amount of pointer bits used for semi-tagging constructor closures
          ,constantWord Haskell "TAG_BITS" "TAG_BITS"

          ,constantBool Haskell "WORDS_BIGENDIAN"    "defined(WORDS_BIGENDIAN)"
          ,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"

          ,constantWord    Haskell "LDV_SHIFT"         "LDV_SHIFT"
          ,constantNatural Haskell "ILDV_CREATE_MASK"  "LDV_CREATE_MASK"
          ,constantNatural Haskell "ILDV_STATE_CREATE" "LDV_STATE_CREATE"
          ,constantNatural Haskell "ILDV_STATE_USE"    "LDV_STATE_USE"
          ]

687 688 689 690
getWanted :: Bool -> String -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath
             -> IO Results
getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
    = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds os))
691 692 693
             cFile = tmpdir </> "tmp.c"
             oFile = tmpdir </> "tmp.o"
         writeFile cFile cStuff
694
         execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
695
         xs <- case os of
696
                 "openbsd" -> readProcess objdumpProgam ["--syms", oFile] ""
697
                 "aix"     -> readProcess objdumpProgam ["--syms", oFile] ""
698 699
                 _         -> readProcess nmProgram ["-P", oFile] ""

700
         let ls = lines xs
701 702
             m = Map.fromList $ case os of
                 "aix" -> parseAixObjdump ls
703
                 _     -> mapMaybe parseNmLine ls
704 705 706 707

         case Map.lookup "CONTROL_GROUP_CONST_291" m of
             Just 292   -> return () -- OK
             Nothing    -> die "CONTROL_GROUP_CONST_291 missing!"
708
             Just 0x292 -> die $ "broken 'nm' detected, see https://gitlab.haskell.org/ghc/ghc/issues/11744.\n"
709 710
                              ++ "\n"
                              ++ "Workaround: You may want to pass\n"
711
                              ++ "    --with-nm=$(xcrun --find nm-classic)\n"
712
                              ++ "to 'configure'.\n"
713 714
             Just x     -> die ("unexpected value round-tripped for CONTROL_GROUP_CONST_291: " ++ show x)

715
         mapM (lookupResult m) (wanteds os)
716 717 718 719 720 721 722 723 724 725 726 727 728
    where headers = ["#define IN_STG_CODE 0",
                     "",
                     "/*",
                     " * We need offsets of profiled things...",
                     " * better be careful that this doesn't",
                     " * affect the offsets of anything else.",
                     " */",
                     "",
                     "#define PROFILING",
                     "#define THREADED_RTS",
                     "",
                     "#include \"PosixSource.h\"",
                     "#include \"Rts.h\"",
David Feuer's avatar
David Feuer committed
729
                     "#include \"StableName.h\"",
730 731 732
                     "#include \"Capability.h\"",
                     "",
                     "#include <inttypes.h>",
733
                     "#include <stddef.h>",
734 735 736 737 738
                     "#include <stdio.h>",
                     "#include <string.h>",
                     "",
                     "#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))",
                     "#define TYPE_SIZE(type) (sizeof(type))",
739
                     "#define FUN_OFFSET(sym) (offsetof(Capability,f.sym) - offsetof(Capability,r))",
740 741 742 743
                     "",
                     "#pragma GCC poison sizeof"
                     ]

744
          objdumpProgam = fromMaybe (error "no objdump program given") mobjdumpProgram
745

746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
          prefix = "derivedConstant"
          mkFullName name = prefix ++ name

          -- We add 1 to the value, as some platforms will make a symbol
          -- of size 1 when for
          --     char foo[0];
          -- We then subtract 1 again when parsing.
          doWanted (GetFieldType name (Fst (CExpr cExpr)))
              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
          doWanted (GetClosureSize name (Fst (CExpr cExpr)))
              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
          doWanted (GetWord name (Fst (CExpr cExpr)))
              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
          doWanted (GetInt name (Fst (CExpr cExpr)))
              = ["char " ++ mkFullName name ++ "Mag[1 + ((intptr_t)(" ++ cExpr ++ ") >= 0 ? (" ++ cExpr ++ ") : -(" ++ cExpr ++ "))];",
                 "char " ++ mkFullName name ++ "Sig[(intptr_t)(" ++ cExpr ++ ") >= 0 ? 3 : 1];"]
          doWanted (GetNatural name (Fst (CExpr cExpr)))
              = -- These casts fix "right shift count >= width of type"
                -- warnings
                let cExpr' = "(uint64_t)(size_t)(" ++ cExpr ++ ")"
                in ["char " ++ mkFullName name ++ "0[1 + ((" ++ cExpr' ++ ") & 0xFFFF)];",
                    "char " ++ mkFullName name ++ "1[1 + (((" ++ cExpr' ++ ") >> 16) & 0xFFFF)];",
                    "char " ++ mkFullName name ++ "2[1 + (((" ++ cExpr' ++ ") >> 32) & 0xFFFF)];",
                    "char " ++ mkFullName name ++ "3[1 + (((" ++ cExpr' ++ ") >> 48) & 0xFFFF)];"]
          doWanted (GetBool name (Fst (CPPExpr cppExpr)))
              = ["#if " ++ cppExpr,
                 "char " ++ mkFullName name ++ "[1];",
                 "#else",
                 "char " ++ mkFullName name ++ "[2];",
                 "#endif"]
          doWanted (StructFieldMacro {}) = []
          doWanted (ClosureFieldMacro {}) = []
          doWanted (ClosurePayloadMacro {}) = []
          doWanted (FieldTypeGcptrMacro {}) = []

781 782 783 784 785
          -- parseNmLine parses "nm -P" output that looks like
          -- "derivedConstantMAX_Vanilla_REG C 0000000b 0000000b" (GNU nm)
          -- "_derivedConstantMAX_Vanilla_REG C b 0" (Mac OS X)
          -- "_derivedConstantMAX_Vanilla_REG C 000000b" (MinGW)
          -- "derivedConstantMAX_Vanilla_REG D        1        b" (Solaris)
786
          -- and returns ("MAX_Vanilla_REG", 11)
787 788 789 790 791
          parseNmLine line
              = case words line of
                ('_' : n) : "C" : s : _ -> mkP n s
                n : "C" : s : _ -> mkP n s
                [n, "D", _, s] -> mkP n s
792
                [s, "O", "*COM*", _, n] -> mkP n s
793 794 795 796
                _ -> Nothing
              where mkP r s = case (stripPrefix prefix r, readHex s) of
                        (Just name, [(size, "")]) -> Just (name, size)
                        _ -> Nothing
797

798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817
          -- On AIX, `nm` isn't able to tell us the symbol size, so we
          -- need to use `objdump --syms`. However, unlike on OpenBSD,
          -- `objdump --syms` outputs entries spanning two lines, e.g.
          --
          -- [ 50](sec  3)(fl 0x00)(ty   0)(scl   2) (nx 1) 0x00000318 derivedConstantBLOCK_SIZE
          -- AUX val  4097 prmhsh 0 snhsh 0 typ 3 algn 3 clss 5 stb 0 snstb 0
          --
          parseAixObjdump :: [String] -> [(String,Integer)]
          parseAixObjdump = catMaybes . goAix
            where
              goAix (l1@('[':_):l2@('A':'U':'X':_):ls')
                  = parseObjDumpEntry l1 l2 : goAix ls'
              goAix (_:ls') = goAix ls'
              goAix [] = []

              parseObjDumpEntry l1 l2
                  | ["val",n] <- take 2 (tail $ words l2)
                  , Just sym <- stripPrefix prefix sym0 = Just (sym, read n)
                  | otherwise = Nothing
                where
818
                  [sym0, _] = take 2 (reverse $ words l1)
819

820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
          -- If an Int value is larger than 2^28 or smaller
          -- than -2^28, then fail.
          -- This test is a bit conservative, but if any
          -- constants are roughly maxBound or minBound then
          -- we probably need them to be Integer rather than
          -- Int so that -- cross-compiling between 32bit and
          -- 64bit platforms works.
          lookupSmall :: Map String Integer -> Name -> IO Integer
          lookupSmall m name
              = case Map.lookup name m of
                Just v
                 | v >   2^(28 :: Int) ||
                   v < -(2^(28 :: Int)) ->
                    die ("Value too large for GetWord: " ++ show v)
                 | otherwise -> return v
                Nothing -> die ("Can't find " ++ show name)

          lookupResult :: Map String Integer -> (Where, What Fst)
                       -> IO (Where, What Snd)
          lookupResult m (w, GetWord name _)
              = do v <- lookupSmall m name
                   return (w, GetWord name (Snd (v - 1)))
          lookupResult m (w, GetInt name _)
              = do mag <- lookupSmall m (name ++ "Mag")
                   sig <- lookupSmall m (name ++ "Sig")
                   return (w, GetWord name (Snd ((mag - 1) * (sig - 2))))
          lookupResult m (w, GetNatural name _)
              = do v0 <- lookupSmall m (name ++ "0")
                   v1 <- lookupSmall m (name ++ "1")
                   v2 <- lookupSmall m (name ++ "2")
                   v3 <- lookupSmall m (name ++ "3")
                   let v = (v0 - 1)
                         + shiftL (v1 - 1) 16
                         + shiftL (v2 - 1) 32
                         + shiftL (v3 - 1) 48
                   return (w, GetWord name (Snd v))
          lookupResult m (w, GetBool name _)
              = do v <- lookupSmall m name
                   case v of
                       1 -> return (w, GetBool name (Snd True))
                       2 -> return (w, GetBool name (Snd False))
                       _ -> die ("Bad boolean: " ++ show v)
          lookupResult m (w, GetFieldType name _)
              = do v <- lookupSmall m name
                   return (w, GetFieldType name (Snd (v - 1)))
          lookupResult m (w, GetClosureSize name _)
              = do v <- lookupSmall m name
                   return (w, GetClosureSize name (Snd (v - 1)))
          lookupResult _ (w, StructFieldMacro name)
              = return (w, StructFieldMacro name)
          lookupResult _ (w, ClosureFieldMacro name)
              = return (w, ClosureFieldMacro name)
          lookupResult _ (w, ClosurePayloadMacro name)
              = return (w, ClosurePayloadMacro name)
          lookupResult _ (w, FieldTypeGcptrMacro name)
              = return (w, FieldTypeGcptrMacro name)

writeHaskellType :: FilePath -> [What Fst] -> IO ()
writeHaskellType fn ws = writeFile fn xs
879 880 881 882 883 884 885 886 887 888 889
    where xs = unlines [header, body, footer]
          header = "data PlatformConstants = PlatformConstants {"
          footer = "  } deriving Read"
          body = intercalate ",\n" (concatMap doWhat ws)

          doWhat (GetClosureSize name _) = ["      pc_" ++ name ++ " :: Int"]
          doWhat (GetFieldType   name _) = ["      pc_" ++ name ++ " :: Int"]
          doWhat (GetWord        name _) = ["      pc_" ++ name ++ " :: Int"]
          doWhat (GetInt         name _) = ["      pc_" ++ name ++ " :: Int"]
          doWhat (GetNatural     name _) = ["      pc_" ++ name ++ " :: Integer"]
          doWhat (GetBool        name _) = ["      pc_" ++ name ++ " :: Bool"]
890 891 892 893 894 895 896
          doWhat (StructFieldMacro {}) = []
          doWhat (ClosureFieldMacro {}) = []
          doWhat (ClosurePayloadMacro {}) = []
          doWhat (FieldTypeGcptrMacro {}) = []

writeHaskellValue :: FilePath -> [What Snd] -> IO ()
writeHaskellValue fn rs = writeFile fn xs
897 898 899 900 901 902 903 904 905 906
    where xs = unlines [header, body, footer]
          header = "PlatformConstants {"
          footer = "  }"
          body = intercalate ",\n" (concatMap doWhat rs)
          doWhat (GetClosureSize name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
          doWhat (GetFieldType   name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
          doWhat (GetWord        name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
          doWhat (GetInt         name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
          doWhat (GetNatural     name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
          doWhat (GetBool        name (Snd v)) = ["      pc_" ++ name ++ " = " ++ show v]
907 908 909 910 911 912 913 914 915 916 917 918
          doWhat (StructFieldMacro {}) = []
          doWhat (ClosureFieldMacro {}) = []
          doWhat (ClosurePayloadMacro {}) = []
          doWhat (FieldTypeGcptrMacro {}) = []

writeHaskellWrappers :: FilePath -> [What Fst] -> IO ()
writeHaskellWrappers fn ws = writeFile fn xs
    where xs = unlines body
          body = concatMap doWhat ws
          doWhat (GetFieldType {}) = []
          doWhat (GetClosureSize {}) = []
          doWhat (GetWord name _) = [haskellise name ++ " :: DynFlags -> Int",
919
                                    haskellise name ++ " dflags = pc_" ++ name ++ " (platformConstants dflags)"]
920
          doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
921
                                   haskellise name ++ " dflags = pc_" ++ name ++ " (platformConstants dflags)"]
922
          doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
923
                                        haskellise name ++ " dflags = pc_" ++ name ++ " (platformConstants dflags)"]
924
          doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
925
                                     haskellise name ++ " dflags = pc_" ++ name ++ " (platformConstants dflags)"]
926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949
          doWhat (StructFieldMacro {}) = []
          doWhat (ClosureFieldMacro {}) = []
          doWhat (ClosurePayloadMacro {}) = []
          doWhat (FieldTypeGcptrMacro {}) = []

writeHaskellExports :: FilePath -> [What Fst] -> IO ()
writeHaskellExports fn ws = writeFile fn xs
    where xs = unlines body
          body = concatMap doWhat ws
          doWhat (GetFieldType {}) = []
          doWhat (GetClosureSize {}) = []
          doWhat (GetWord    name _) = ["    " ++ haskellise name ++ ","]
          doWhat (GetInt     name _) = ["    " ++ haskellise name ++ ","]
          doWhat (GetNatural name _) = ["    " ++ haskellise name ++ ","]
          doWhat (GetBool    name _) = ["    " ++ haskellise name ++ ","]
          doWhat (StructFieldMacro {}) = []
          doWhat (ClosureFieldMacro {}) = []
          doWhat (ClosurePayloadMacro {}) = []
          doWhat (FieldTypeGcptrMacro {}) = []

writeHeader :: FilePath -> [What Snd] -> IO ()
writeHeader fn rs = writeFile fn xs
    where xs = unlines (headers ++ body)
          headers = ["/* This file is created automatically.  Do not edit by hand.*/", ""]
950 951 952 953 954 955 956
          body = map doWhat rs
          doWhat (GetFieldType   name (Snd v)) = "#define " ++ name ++ " b" ++ show (v * 8)
          doWhat (GetClosureSize name (Snd v)) = "#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"
          doWhat (GetWord        name (Snd v)) = "#define " ++ name ++ " " ++ show v
          doWhat (GetInt         name (Snd v)) = "#define " ++ name ++ " " ++ show v
          doWhat (GetNatural     name (Snd v)) = "#define " ++ name ++ " " ++ show v
          doWhat (GetBool        name (Snd v)) = "#define " ++ name ++ " " ++ show (fromEnum v)
957
          doWhat (StructFieldMacro nameBase) =
958
                     "#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"
959
          doWhat (ClosureFieldMacro nameBase) =
960
                     "#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"
961
          doWhat (ClosurePayloadMacro nameBase) =
962
                     "#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"
963
          doWhat (FieldTypeGcptrMacro nameBase) =
964
                     "#define REP_" ++ nameBase ++ " gcptr"
965 966 967 968 969

die :: String -> IO a
die err = do hPutStrLn stderr err
             exitFailure

970 971 972 973 974 975
execute :: Bool -> FilePath -> [String] -> IO ()
execute verbose prog args
 = do when verbose $ putStrLn $ showCommandForUser prog args
      ec <- rawSystem prog args
      unless (ec == ExitSuccess) $
          die ("Executing " ++ show prog ++ " failed")
976