content: {-# LANGUAGE LambdaCase #-}
  
  {- ------------------------------------------------------------------------
  
  (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.
  
  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. rts/include/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'.
  
  ------------------------------------------------------------------------ -}
  
  import Control.Monad (when, unless)
  import Data.Bits (shiftL)
  import Data.List (elemIndex, stripPrefix, intercalate)
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
  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)
  import System.Directory (renameFile)
  
  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
  
            case mode of
                Gen_Haskell_Type ->
                    writeHaskellType fn
                        [ what | (wh, what) <- wanteds Nothing -- OS must not matter
                               , wh `elem` [Haskell, Both] ]
                Gen_Computed cm ->
                    do os_str  <- getOption "target os"   o_targetOS
                       tmpdir  <- getOption "tmpdir"      o_tmpdir
                       gccProg <- getOption "gcc program" o_gccProg
                       nmProg  <- getOption "nm program"  o_nmProg
                       let os = case os_str of
                                  "ghcjs"   -> JS
                                  "aix"     -> AIX
                                  "wasi"    -> WASI
                                  "openbsd" -> OpenBSD
                                  "mingw32" -> Windows
                                  _         -> DefaultOS
                           verbose = o_verbose opts
                           gccFlags0 = o_gccFlags opts
                            -- nm applied to COFF files doesn't correctly report
                            -- the size of global variable symbols (it reports 0)
                            -- except for Common symbols (probably because the
                            -- merge algorithm of Common symbols takes symbol size
                            -- into account). So we force the use of `-fcommon`
                            -- here.
                            -- As far as we know, it is only required on Windows
                            -- but enabling it on other platforms does no harm, so
                            -- we enable it unconditionally.
                           gccFlags = "-fcommon" : gccFlags0
                       rs <- case os of
                               JS -> getWantedJS
                               _  -> getWanted verbose os tmpdir gccProg gccFlags nmProg
                                          (o_objdumpProg opts)
                       let haskellRs = [ what
                                       | (wh, what) <- rs
                                       , wh `elem` [Haskell, Both] ]
                       case cm of
                           ComputeHaskell -> writeHaskellValue fn haskellRs
                           ComputeHeader  -> writeHeader       fn rs
  
  data Options = Options {
                     o_verbose :: Bool,
                     o_mode :: Maybe Mode,
                     o_tmpdir :: Maybe FilePath,
                     o_outputFilename :: Maybe FilePath,
                     o_gccProg :: Maybe FilePath,
                     o_gccFlags :: [String],
                     o_nmProg :: Maybe FilePath,
                     o_objdumpProg :: Maybe FilePath,
                     o_targetOS :: Maybe String
                 }
  
  data OS
     = DefaultOS
     | JS
     | AIX
     | WASI
     | OpenBSD
     | Windows
     deriving (Show, Eq)
  
  -- | Write a file atomically
  --
  -- This avoids other processes seeing the file while it is being written into.
  atomicWriteFile :: FilePath -> String -> IO ()
  atomicWriteFile fn s = do
    let tmp = fn <.> "tmp"
    writeFile tmp s
    renameFile tmp fn
  
  
  parseArgs :: IO Options
  parseArgs = do args <- getArgs
                 opts <- f emptyOptions args
                 return (opts {o_gccFlags = reverse (o_gccFlags opts)})
      where emptyOptions = Options {
                               o_verbose = False,
                               o_mode = Nothing,
                               o_tmpdir = Nothing,
                               o_outputFilename = Nothing,
                               o_gccProg = Nothing,
                               o_gccFlags = [],
                               o_nmProg = Nothing,
                               o_objdumpProg = Nothing,
                               o_targetOS = Nothing
                           }
            f opts [] = return opts
            f opts ("-v" : args')
                = f (opts {o_verbose = True}) args'
            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-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'
            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'
            f _ (flag : _) = die ("Unrecognised flag: " ++ show flag)
  
  data Mode = Gen_Haskell_Type
            | 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
            expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ")"
  
  -- 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
      = defOffset w nameBase (CExpr ("offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"))
  
  -- 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
            expr = "offsetof(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"
  
  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))]
  
  wanteds :: Maybe OS -> Wanteds
  wanteds os = concat
            [-- 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"
                               -- grrr.. PROFILING is on so we need to
                               -- subtract sizeofW(StgProfHeader)
                               "sizeofW(StgHeader) - sizeofW(StgProfHeader)"
            ,constantWord Both "PROF_HDR_SIZE" "sizeofW(StgProfHeader)"
  
             -- Stack flags for C--
            ,constantWord C "STACK_DIRTY" "STACK_DIRTY"
  
             -- 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
  
            ,constantWord Both "TICKY_BIN_COUNT" "TICKY_BIN_COUNT"
             -- number of bins for histograms used in ticky code
  
            ,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"
            ,fieldOffset Both "StgRegTable" "rXMM1"
            ,fieldOffset Both "StgRegTable" "rXMM2"
            ,fieldOffset Both "StgRegTable" "rXMM3"
            ,fieldOffset Both "StgRegTable" "rXMM4"
            ,fieldOffset Both "StgRegTable" "rXMM5"
            ,fieldOffset Both "StgRegTable" "rXMM6"
            ,fieldOffset Both "StgRegTable" "rYMM1"
            ,fieldOffset Both "StgRegTable" "rYMM2"
            ,fieldOffset Both "StgRegTable" "rYMM3"
            ,fieldOffset Both "StgRegTable" "rYMM4"
            ,fieldOffset Both "StgRegTable" "rYMM5"
            ,fieldOffset Both "StgRegTable" "rYMM6"
            ,fieldOffset Both "StgRegTable" "rZMM1"
            ,fieldOffset Both "StgRegTable" "rZMM2"
            ,fieldOffset Both "StgRegTable" "rZMM3"
            ,fieldOffset Both "StgRegTable" "rZMM4"
            ,fieldOffset Both "StgRegTable" "rZMM5"
            ,fieldOffset Both "StgRegTable" "rZMM6"
            ,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"
            ,structField C    "Capability" "total_allocated"
            ,structField C    "Capability" "weak_ptr_list_hd"
            ,structField C    "Capability" "weak_ptr_list_tl"
            ,structField C    "Capability" "n_run_queue"
  
            ,structField Both "bdescr" "start"
            ,structField Both "bdescr" "free"
            ,structField Both "bdescr" "blocks"
            ,structField C    "bdescr" "gen_no"
            ,structField C    "bdescr" "link"
            ,structField Both "bdescr" "flags"
  
            ,structSize C  "generation"
            ,structField C "generation" "n_new_large_words"
            ,structField C "generation" "weak_ptr_list"
  
            ,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"
            ,structFieldH Both "StgEntCounter" "allocd"
            ,structField  Both "StgEntCounter" "registeredp"
            ,structField  Both "StgEntCounter" "link"
            ,structField  Both "StgEntCounter" "entry_count"
  
            ,closureSize  Both "StgUpdateFrame"
            ,closureSize  Both "StgOrigThunkInfoFrame"
            ,closureSize  C    "StgCatchFrame"
            ,closureSize  C    "StgStopFrame"
            ,closureSize  C    "StgDeadThreadFrame"
            ,closureField C    "StgDeadThreadFrame" "result"
            ,closureSize  Both "StgAnnFrame"
            ,closureField C    "StgAnnFrame" "ann"
  
            ,closureSize  Both "StgMutArrPtrs"
            ,closureField Both "StgMutArrPtrs" "ptrs"
            ,closureField Both "StgMutArrPtrs" "size"
  
            ,closureSize  Both "StgSmallMutArrPtrs"
            ,closureField Both "StgSmallMutArrPtrs" "ptrs"
  
            ,closureSize    Both "StgArrBytes"
            ,closureField   Both "StgArrBytes" "bytes"
            ,closurePayload C    "StgArrBytes" "payload"
  
            ,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"
            ,closureField  C    "StgTSO"      "label"
            ,closureField  C    "StgTSO"      "bound"
            ,closureField  Both "StgTSO"      "alloc_limit"
            ,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"
            ,closureField       C    "StgStack" "marking"
  
            ,structSize C "StgTSOProfInfo"
  
            ,closureField Both "StgUpdateFrame" "updatee"
            ,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
  
            ,closureField C "StgCatchFrame" "handler"
  
            ,structSize  C "StgRetFun"
            ,fieldOffset C "StgRetFun" "size"
            ,fieldOffset C "StgRetFun" "fun"
            ,fieldOffset C "StgRetFun" "payload"
  
            ,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"
  
            ,closureSize       C "StgContinuation"
            ,closureField      C "StgContinuation" "apply_mask_frame"
            ,closureField      C "StgContinuation" "mask_frame_offset"
            ,closureField      C "StgContinuation" "stack_size"
            ,closurePayload    C "StgContinuation" "stack"
  
            ,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"
            ,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"
  
            ,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"
  
            ,closureSize  C "StgCompactNFData"
            ,closureField C "StgCompactNFData" "totalW"
            ,closureField C "StgCompactNFData" "autoBlockW"
            ,closureField C "StgCompactNFData" "nursery"
            ,closureField C "StgCompactNFData" "last"
            ,closureField C "StgCompactNFData" "hp"
            ,closureField C "StgCompactNFData" "hpLim"
            ,closureField C "StgCompactNFData" "hash"
            ,closureField C "StgCompactNFData" "result"
  
            ,structSize   C "StgCompactNFDataBlock"
            ,structField  C "StgCompactNFDataBlock" "self"
            ,structField  C "StgCompactNFDataBlock" "owner"
            ,structField  C "StgCompactNFDataBlock" "next"
  
            ,structField_ C "RtsFlags_ProfFlags_doHeapProfile"
                            "RTS_FLAGS" "ProfFlags.doHeapProfile"
            ,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"
            ,structFieldH Both "StgFunInfoExtraFwd" "arity"
            ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
  
            ,structSize   Both "StgFunInfoExtraRev"
            ,structField  C    "StgFunInfoExtraRev" "slow_apply_offset"
            ,structField  C    "StgFunInfoExtraRev" "fun_type"
            ,structFieldH Both "StgFunInfoExtraRev" "arity"
            ,structField_ C    "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
            ,structField_ C    "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
  
            ,structField C "StgLargeBitmap" "size"
            ,fieldOffset C "StgLargeBitmap" "bitmap"
  
            ,structSize  C "snEntry"
            ,structField C "snEntry" "sn_obj"
            ,structField C "snEntry" "addr"
  
            ,structSize  C "spEntry"
            ,structField C "spEntry" "addr"
  
             -- 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 == Just Windows
             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"
            ,constantWord Haskell "MAX_XMM_REG"          "MAX_XMM_REG"
            ,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"
            ,constantWord Haskell "MAX_Real_XMM_REG"     "MAX_REAL_XMM_REG"
            ,constantWord Haskell "MAX_Real_Long_REG"    "MAX_REAL_LONG_REG"
  
            -- This tells the native code generator the size of the spill
            -- area it has available.
            ,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 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"
  
            ,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"
            ,constantBool    Haskell "USE_INLINE_SRT_FIELD" "defined(USE_INLINE_SRT_FIELD)"
            ]
  
  getWanted :: Bool -> OS -> 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 (Just os)))
               cFile = tmpdir </> "tmp.c"
               oFile = tmpdir </> "tmp.o"
           atomicWriteFile cFile cStuff
           -- On wasm32-wasi, llvm-nm incorrectly reports length of
           -- buffers defined in wasm object files as 0, see llvm ticket
           -- #58839. Therefore we have to emit .ll file instead, and
           -- use a very crude parser which is just enough to extract
           -- the buffer length info we're interested in.
           execute verbose gccProgram (gccFlags ++ (
               case os of
                   WASI -> ["-emit-llvm", "-S"]
                   _ -> ["-c"]
               ) ++ [cFile, "-o", oFile])
           xs <- case os of
                   OpenBSD -> readProcess objdumpProgam ["--syms", oFile] ""
                   AIX     -> readProcess objdumpProgam ["--syms", oFile] ""
                   WASI    -> readFile oFile
                   _       -> readProcess nmProgram ["-P", oFile] ""
  
           let ls = lines xs
               m = Map.fromList $ case os of
                   AIX   -> parseAixObjdump ls
                   WASI  -> mapMaybe parseLLLine ls
                   _     -> mapMaybe parseNmLine ls
  
           case Map.lookup "CONTROL_GROUP_CONST_291" m of
               Just 292   -> return () -- OK
               Nothing    -> die "CONTROL_GROUP_CONST_291 missing!"
               Just 0x292 -> die $ "broken 'nm' detected, see https://gitlab.haskell.org/ghc/ghc/issues/11744.\n"
                                ++ "\n"
                                ++ "Workaround: You may want to pass\n"
                                ++ "    --with-nm=$(xcrun --find nm-classic)\n"
                                ++ "to 'configure'.\n"
               Just x     -> die ("unexpected value round-tripped for CONTROL_GROUP_CONST_291: " ++ show x ++ "\n" ++ show m ++ "\n" ++ xs)
  
           mapM (lookupResult m) (wanteds (Just os))
      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",
                       -- We need to define this if we want StgAsyncIOResult
                       -- struct to be present after CPP
                       --
                       -- FIXME: rts/PosixSource.h should include ghcplatform.h
                       -- which should set this. There is a mismatch host/target
                       -- again...
                       if os == Windows then "#define mingw32_HOST_OS 1" else "",
                       "",
                       "#include \"rts/PosixSource.h\"",
                       "#include \"Rts.h\"",
                       "#include \"StableName.h\"",
                       "#include \"Capability.h\"",
                       "",
                       "#include <inttypes.h>",
                       "#include <stddef.h>",
                       "#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))",
                       "#define FUN_OFFSET(sym) (offsetof(Capability,f.sym) - offsetof(Capability,r))",
                       "",
                       "#pragma GCC poison sizeof"
                       ]
  
            objdumpProgam = fromMaybe (error "no objdump program given") mobjdumpProgram
  
            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 {}) = []
  
            parseLLLine line = case words line of
              ('@' : prefix_sym) : ts -> do
                  sym <- stripPrefix prefix prefix_sym
                  i <- elemIndex "x" ts
                  pure (sym, read (tail (ts !! (i - 1))))
              _ -> Nothing
  
            -- 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)
            -- and returns ("MAX_Vanilla_REG", 11)
            parseNmLine line
                = case words line of
                  -- in common section
                  (n : "C" : s : _ )           -> mkP n s -- nm format (ELF, COFF)
                  [s, "O", "*COM*", _, n]      -> mkP n s -- objdump format (ELF)
                  -- in .bss section
                  [n, "B", _, s ]              -> mkP n s -- nm format (ELF)
                  [_, "g", "O", ".bss", s, n]  -> mkP n s -- objdump format (ELF)
                  -- in data section
                  [n, "D", _, s]               -> mkP n s -- nm format (ELF)
                  [_, "g", "O", ".data", s, n] -> mkP n s -- objdump format (ELF)
                  _ -> Nothing
                where mkP r s = case (stripPrefix prefix (strip_ r), readHex s) of
                          (Just name, [(size, "")]) -> Just (name, size)
                          _ -> Nothing
                      -- strip leading underscore: some platforms (e.g. Darwin) add one
                      strip_ = \case
                        ('_':n) -> n
                        n       -> n
  
            -- 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
                    sym0 = head $ reverse $ words l1
  
            -- 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)
  
  -- The JavaScript backend doesn't require the native-RTS constants, so we filter those here,
  -- and provide reasonable presets for any remaining constants. This way, `deriveConstants`
  -- can still produce a valid constants file (required by GHC), without the side-effect of
  -- producing a c file.
  getWantedJS :: IO Results
  getWantedJS = mapM lookupResult (wanteds (Just JS))
    where
      jsHardCoded :: Map String Integer
      jsHardCoded = Map.fromList [ ("WORD_SIZE", 4)
                                 , ("DOUBLE_SIZE", 8)
                                 , ("CINT_SIZE", 4)
                                 , ("CLONG_SIZE", 4)
                                 , ("CLONG_LONG_SIZE", 8)
                                 ]
  
      lookupResult :: (Where, What Fst) -> IO (Where, What Snd)
      lookupResult (w, GetWord name _) | Just res <- Map.lookup name jsHardCoded
                   = return (w, GetWord name (Snd res))
      lookupResult (w, what) = return $ case what of
        GetWord             name _ -> (w, GetWord             name (Snd 0))
        GetInt              name _ -> (w, GetWord             name (Snd 0))
        GetNatural          name _ -> (w, GetWord             name (Snd 0))
        GetBool             name _ -> (w, GetBool             name (Snd False))
        GetFieldType        name _ -> (w, GetFieldType        name (Snd 1))
        GetClosureSize      name _ -> (w, GetClosureSize      name (Snd 1))
        StructFieldMacro    name   -> (w, StructFieldMacro    name)
        ClosureFieldMacro   name   -> (w, ClosureFieldMacro   name)
        ClosurePayloadMacro name   -> (w, ClosurePayloadMacro name)
        FieldTypeGcptrMacro name   -> (w, FieldTypeGcptrMacro name)
  
  writeHaskellType :: FilePath -> [What Fst] -> IO ()
  writeHaskellType fn ws = atomicWriteFile fn xs
      where xs = unlines [header, body, footer, parser]
            header = "module GHC.Platform.Constants where\n\n\
                     \import Prelude\n\
                     \import Data.Char\n\n\
                     \data PlatformConstants = PlatformConstants {"
            footer = "  } deriving (Show, Read, Eq, Ord)\n\n"
            body = intercalate ",\n" (concatMap doWhat ws)
  
            doWhat (GetClosureSize name _) = ["      pc_" ++ name ++ " :: {-# UNPACK #-} !Int"]
            doWhat (GetFieldType   name _) = ["      pc_" ++ name ++ " :: {-# UNPACK #-} !Int"]
            doWhat (GetWord        name _) = ["      pc_" ++ name ++ " :: {-# UNPACK #-} !Int"]
            doWhat (GetInt         name _) = ["      pc_" ++ name ++ " :: {-# UNPACK #-} !Int"]
            doWhat (GetNatural     name _) = ["      pc_" ++ name ++ " :: !Integer"]
            doWhat (GetBool        name _) = ["      pc_" ++ name ++ " :: !Bool"]
            doWhat (StructFieldMacro {}) = []
            doWhat (ClosureFieldMacro {}) = []
            doWhat (ClosurePayloadMacro {}) = []
            doWhat (FieldTypeGcptrMacro {}) = []
  
            vs = zip ws [(0::Int)..]
            parser =
              "parseConstantsHeader :: FilePath -> IO PlatformConstants\n\
              \parseConstantsHeader fp = do\n\
              \  s <- readFile fp\n\
              \  let def = \"#define HS_CONSTANTS \\\"\"\n\
              \      find [] xs = xs\n\
              \      find _  [] = error $ \"GHC couldn't find the RTS constants (\"++def++\") in \" ++ fp ++ \": the RTS package you are trying to use is perhaps for another GHC version\" ++\n\
              \                               \"(e.g. you are using the wrong package database) or the package database is broken.\\n\"\n\
              \      find (d:ds) (x:xs)\n\
              \        | d == x    = find ds xs\n\
              \        | otherwise = find def xs\n\n\
              \      readVal' :: Bool -> Integer -> String -> [Integer]\n\
              \      readVal' n     c (x:xs) = case x of\n\
              \        '\"' -> [if n then negate c else c]\n\
              \        '-' -> readVal' True c xs\n\
              \        ',' -> (if n then negate c else c) : readVal' False 0 xs\n\
              \        _   -> readVal' n (c*10 + fromIntegral (ord x - ord '0')) xs\n\
              \      readVal' n     c []     = [if n then negate c else c]\n\n\
              \      readVal = readVal' False 0\n\n\
              \  return $! case readVal (find def s) of\n"
              ++ "    [" ++ concatMap (nicetab . snd) vs
              ++ "\n     ] -> PlatformConstants\n            { "
              ++ intercalate "\n            , " (concatMap (uncurry doParse) vs)
              ++ "\n            }\n"
              ++ "    _ -> error \"Invalid platform constants\"\n"
  
            nicetab 0 = "v0"
            nicetab v
              | v `mod` 16 == 0 = "\n     ,v"++show v
              | otherwise       = ",v"++show v
  
  
            doParse (GetClosureSize name _)   i = ["pc_" ++ name ++ " = fromIntegral v" ++ show i]
            doParse (GetFieldType   name _)   i = ["pc_" ++ name ++ " = fromIntegral v" ++ show i]
            doParse (GetWord        name _)   i = ["pc_" ++ name ++ " = fromIntegral v" ++ show i]
            doParse (GetInt         name _)   i = ["pc_" ++ name ++ " = fromIntegral v" ++ show i]
            doParse (GetNatural     name _)   i = ["pc_" ++ name ++ " = v" ++ show i]
            doParse (GetBool        name _)   i = ["pc_" ++ name ++ " = 0 < v" ++ show i]
            doParse (StructFieldMacro {})    _i = []
            doParse (ClosureFieldMacro {})   _i = []
            doParse (ClosurePayloadMacro {}) _i = []
            doParse (FieldTypeGcptrMacro {}) _i = []
  
  
  writeHaskellValue :: FilePath -> [What Snd] -> IO ()
  writeHaskellValue fn rs = atomicWriteFile fn xs
      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]
            doWhat (StructFieldMacro {}) = []
            doWhat (ClosureFieldMacro {}) = []
            doWhat (ClosurePayloadMacro {}) = []
            doWhat (FieldTypeGcptrMacro {}) = []
  
  writeHeader :: FilePath -> [(Where, What Snd)] -> IO ()
  writeHeader fn rs = atomicWriteFile fn xs
      where xs = headers ++ genapplyBits ++ hs ++ unlines body
            headers = "/* This file is created automatically.  Do not edit by hand.*/\n\n"
            -- See Note [How genapply gets target info] for details
            genapplyBits = mconcat ["// " ++ _name ++ " " ++ show v ++ "\n" | (_name, v) <- genapplyData]
            genapplyData = [(_name, v) | (_, GetWord _name (Snd v)) <- rs, _name `elem` genapplyFields ]
            genapplyFields = [
              "MAX_Real_Vanilla_REG", "MAX_Real_Float_REG", "MAX_Real_Double_REG",
              "MAX_Real_Long_REG", "MAX_Real_XMM_REG",
              "WORD_SIZE", "TAG_BITS", "BITMAP_BITS_SHIFT"
              ]
            haskellRs = fmap snd $ filter (\r -> fst r `elem` [Haskell,Both]) rs
            cRs       = fmap snd $ filter (\r -> fst r `elem` [C,Both]) rs
            hs = concat
                    [ "#define HS_CONSTANTS \""
                    , intercalate "," (mapMaybe doHs haskellRs)
                    , "\"\n"
                    ]
            doHs x = case x of
              GetFieldType   _name (Snd v) -> Just (show v)
              GetClosureSize _name (Snd v) -> Just (show v)
              GetWord        _name (Snd v) -> Just (show v)
              GetInt         _name (Snd v) -> Just (show v)
              GetNatural     _name (Snd v) -> Just (show v)
              GetBool        _name (Snd v) -> Just (if v then "1" else "0")
              StructFieldMacro {}          -> Nothing
              ClosureFieldMacro {}         -> Nothing
              ClosurePayloadMacro {}       -> Nothing
              FieldTypeGcptrMacro {}       -> Nothing
  
            body = map doC cRs
            doC x = case x of
              GetFieldType   name (Snd v)  -> "#define " ++ name ++ " b" ++ show (v * 8)
              GetClosureSize name (Snd v)  -> "#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"
              GetWord        name (Snd v)  -> "#define " ++ name ++ " " ++ show v
              GetInt         name (Snd v)  -> "#define " ++ name ++ " " ++ show v
              GetNatural     name (Snd v)  -> "#define " ++ name ++ " " ++ show v
              GetBool        name (Snd v)  -> "#define " ++ name ++ " " ++ show (fromEnum v)
              StructFieldMacro nameBase    -> "#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"
              ClosureFieldMacro nameBase   -> "#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"
              ClosurePayloadMacro nameBase -> "#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"
              FieldTypeGcptrMacro nameBase -> "#define REP_" ++ nameBase ++ " gcptr"
  
  die :: String -> IO a
  die err = do hPutStrLn stderr err
               exitFailure
  
  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")
  