{- ------------------------------------------------------------------------ (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 (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 "OS must not matter" , wh `elem` [Haskell, Both] ] Gen_Computed cm -> do os <- getOption "target os" o_targetOS tmpdir <- getOption "tmpdir" o_tmpdir gccProg <- getOption "gcc program" o_gccProg nmProg <- getOption "nm program" o_nmProg let verbose = o_verbose opts gccFlags = o_gccFlags opts rs <- 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 } -- | 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__NoHdr -- Also, we #define SIZEOF_ 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 :: String -> 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 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 C "StgCatchFrame" ,closureSize C "StgStopFrame" ,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 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" ,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" ,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 == "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" ,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 -> 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)) cFile = tmpdir "tmp.c" oFile = tmpdir "tmp.o" atomicWriteFile cFile cStuff execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile]) xs <- case os of "openbsd" -> readProcess objdumpProgam ["--syms", oFile] "" "aix" -> readProcess objdumpProgam ["--syms", oFile] "" _ -> readProcess nmProgram ["-P", oFile] "" let ls = lines xs m = Map.fromList $ case os of "aix" -> parseAixObjdump 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) mapM (lookupResult m) (wanteds 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 == "mingw32" then "#define mingw32_HOST_OS 1" else "", "", "#include \"rts/PosixSource.h\"", "#include \"Rts.h\"", "#include \"StableName.h\"", "#include \"Capability.h\"", "", "#include ", "#include ", "#include ", "#include ", "", "#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 {}) = [] -- 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 ('_' : n) : "C" : s : _ -> mkP n s n : "C" : s : _ -> mkP n s [n, "D", _, s] -> mkP n s [s, "O", "*COM*", _, n] -> mkP n s _ -> Nothing where mkP r s = case (stripPrefix prefix r, readHex s) of (Just name, [(size, "")]) -> Just (name, size) _ -> Nothing -- 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) 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 ++ hs ++ unlines body headers = "/* This file is created automatically. Do not edit by hand.*/\n\n" 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")