-- This program compares the sizes of corresponding files in two trees

--   $ ./compareSizes --hi ~/ghc/darcs/ghc ~/ghc/6.12-branch/ghc
--        Size | Change | Filename
--      25644 | -0.99% | compiler/stage1/build/Demand.hi
--      21103 | -0.98% | compiler/stage2/build/Demand.hi
--     180044 | -0.98% | libraries/base/dist-install/build/GHC/Classes.hi
--       6415 | -0.58% | .../Data/Array/Parallel/Prelude/Base/Tuple.hi
--       6507 | -0.57% | .../Data/Array/Parallel/Prelude/Base/Tuple.hi
--   [...]
--       3264 |  3.16% | .../Parallel/Unlifted/Sequential/Flat/Enum.hi
--      51389 |  3.30% | .../build/Language/Haskell/Extension.hi
--       1415 | 72.18% | libraries/base/dist-install/build/Data/Tuple.hi
--   28752162 | -0.00% | TOTAL

-- Flags:
--    --o to compare object files.
--    --hi to compare interface files [DEFAULT]

-- There's a hack to avoid descending into '*_split' directories

module Main (main) where

import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import Numeric
import System.Directory
import System.Environment
import System.FilePath
import System.IO

main :: IO ()
main = do hSetBuffering stdout LineBuffering
          args <- getArgs
          case args of
              ["--hi", dir1, dir2] -> doit isHiFile dir1 dir2
              ["--o", dir1, dir2]  -> doit isOFile  dir1 dir2
              [dir1, dir2]         -> doit isHiFile dir1 dir2
              _ -> error "Bad arguments"

isHiFile :: FilePath -> Bool
isHiFile = (".hi" `isSuffixOf`)

isOFile :: FilePath -> Bool
isOFile = (".o" `isSuffixOf`)

doit :: (FilePath -> Bool) -> FilePath -> FilePath -> IO ()
doit isFileInteresting dir1 dir2
    = do when verbose $ putStrLn "Reading tree 1"
         tree1 <- getTree isFileInteresting dir1 "." "."
         when verbose $ putStrLn "Reading tree 2"
         tree2 <- getTree isFileInteresting dir2 "." "."
         when verbose $ putStrLn "Comparing trees"
         let ds = compareTree tree1 tree2
             ds' = sortBy comparingPercentage ds
             total = mkTotalDifference ds'
         mapM_ putStrLn $ showDifferences (ds' ++ [total])

verbose :: Bool
verbose = False

----------------------------------------------------------------------
-- Reading the trees

data Tree = Directory { nodeName :: FilePath, _subTrees :: [Tree] }
          | File      { nodeName :: FilePath, _filePath :: FilePath,
                                              _size :: Size }
    deriving Show

type Size = Integer
type Percentage = Double

getTree :: (FilePath -> Bool) -> FilePath -> FilePath -> FilePath -> IO Tree
getTree isFileInteresting root dir subdir
    = do entries <- getDirectoryContents (root </> dir </> subdir)
         mSubtrees <- mapM doEntry $ sort $ filter interesting entries
         return $ Directory subdir $ catMaybes mSubtrees
    where interesting "."  = False
          interesting ".." = False
          -- We don't want to descend into object-splitting directories,
          -- and compare the hundreds of split object files. Instead we
          -- just compare the combined object file outside of the _split
          -- directory.
          interesting d    = not ("_split" `isSuffixOf` d)
          dir' = dir <//> subdir
          doEntry :: FilePath -> IO (Maybe Tree)
          doEntry e = liftM Just (getTree isFileInteresting root dir' e)
            `catchIO` \_ -> -- XXX We ought to check this is a
                            -- "not a directory" exception really
                      if isFileInteresting e
                      then do let fn = dir' <//> e
                              h <- openFile (root </> fn) ReadMode
                              size <- hFileSize h
                              hClose h
                              return $ Just $ File e fn size
                      else return Nothing

catchIO :: IO a -> (IOError -> IO a) -> IO a
catchIO = catch

----------------------------------------------------------------------
-- Comparing the trees

data Difference = Difference FilePath Size Size Percentage
    deriving Show

compareTree :: Tree -> Tree -> [Difference]
compareTree (Directory _ ts1) (Directory _ ts2) = compareTrees ts1 ts2
compareTree (File _ fn s1) (File _ _ s2)
    = [Difference fn s1 s2 (mkPercentage s1 s2)]
compareTree _ _ = []

mkPercentage :: Size -> Size -> Percentage
mkPercentage s1 s2 = fromIntegral (s2 - s1) / fromIntegral s1

compareTrees :: [Tree] -> [Tree] -> [Difference]
compareTrees t1s@(t1 : t1s') t2s@(t2 : t2s')
    = case nodeName t1 `compare` nodeName t2 of
      LT ->                      compareTrees t1s' t2s
      EQ -> compareTree t1 t2 ++ compareTrees t1s' t2s'
      GT ->                      compareTrees t1s  t2s'
compareTrees _ _ = []

showDifferences :: [Difference] -> [String]
showDifferences ds = showTable [lpad, lpad, rpad]
                     (["Size", "Change", "Filename"] :
                      map showDifference ds)

showDifference :: Difference -> [String]
showDifference (Difference fp s1 _ percentage)
    = [show s1, showFFloat (Just 2) percentage "%", shorten fp]

shorten :: FilePath -> FilePath
shorten fp = let xs = map joinPath $ tails $ splitDirectories fp
             in case xs of
                x : _
                 | length x <= allowed ->
                    x
                _ -> case dropWhile ((> allowed - 4) . length) xs of
                     x : _ ->
                         "..." </> x
                     [] ->
                         take (allowed - 3) (takeFileName fp) ++ "..."
    where allowed = 50

comparingPercentage :: Difference -> Difference -> Ordering
comparingPercentage (Difference _ _ _ p1) (Difference _ _ _ p2)
    = compare p1 p2

mkTotalDifference :: [Difference] -> Difference
mkTotalDifference ds = let s1 = sum [ x | Difference _ x _ _ <- ds ]
                           s2 = sum [ x | Difference _ _ x _ <- ds ]
                           percentage = mkPercentage s1 s2
                       in Difference "TOTAL" s1 s2 percentage

----------------------------------------------------------------------
-- Utils

(<//>) :: FilePath -> FilePath -> FilePath
"." <//> fp = fp
dir <//> fn = dir </> fn

showTable :: [Int -> String -> String] -> [[String]] -> [String]
showTable padders xss
    = let lengths = map (maximum . map length) $ transpose xss
      in map (concat . intersperse " | " . zipWith3 id padders lengths) xss

lpad :: Int -> String -> String
lpad n s = replicate (n - length s) ' ' ++ s

rpad :: Int -> String -> String
rpad n s = s ++ replicate (n - length s) ' '


{- ------------------------------------------------------------------------

(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. 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'.

------------------------------------------------------------------------ -}

import Control.Monad (when, unless)
import Data.Bits (shiftL)
import Data.Char (toLower)
import Data.List (stripPrefix)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
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)

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
          os <- getOption "target os"   o_targetOS

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

          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
                     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] ]
                         cRs = [ what
                               | (wh, what) <- rs
                               , wh `elem` [C, Both] ]
                     case cm of
                         ComputeHaskell -> writeHaskellValue fn haskellRs
                         ComputeHeader  -> writeHeader       fn cRs

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
               }

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-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'
          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_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
          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))]

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

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)"

           -- 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_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 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"
          ]

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"
         writeFile 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
                 _     -> catMaybes $ map 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://ghc.haskell.org/ticket/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)

         rs <- mapM (lookupResult m) (wanteds os)
         return rs
    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\"",
                     "#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 = maybe (error "no objdump program given") id 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, _] = take 2 (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 = writeFile fn xs
    where xs = unlines (headers ++ body ++ footers)
          headers = ["data PlatformConstants = PlatformConstants {"
                     -- Now a kludge that allows the real entries to
                     -- all start with a comma, which makes life a
                     -- little easier
                    ,"    pc_platformConstants :: ()"]
          footers = ["  } deriving Read"]
          body = 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"]
          doWhat (StructFieldMacro {}) = []
          doWhat (ClosureFieldMacro {}) = []
          doWhat (ClosurePayloadMacro {}) = []
          doWhat (FieldTypeGcptrMacro {}) = []

writeHaskellValue :: FilePath -> [What Snd] -> IO ()
writeHaskellValue fn rs = writeFile fn xs
    where xs = unlines (headers ++ body ++ footers)
          headers = ["PlatformConstants {"
                    ,"    pc_platformConstants = ()"]
          footers = ["  }"]
          body = 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 {}) = []

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",
                                    haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
          doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
                                   haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
          doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
                                        haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
          doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
                                     haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
          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.*/", ""]
          body = concatMap 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)]
          doWhat (StructFieldMacro nameBase) =
                     ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"]
          doWhat (ClosureFieldMacro nameBase) =
                     ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"]
          doWhat (ClosurePayloadMacro nameBase) =
                     ["#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"]
          doWhat (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")


module Main (main) where

import Data.List

main :: IO ()
main = do xs <- readFile "testlog"
          let ls = lines xs
              tests = breakTests ls
              unexpectedTests = filter (any ("unexpected" `isInfixOf`)) tests
          putStr $ unlines $ concat unexpectedTests

breakTests :: [String] -> [[String]]
breakTests xs = splitStarting ("=====> " `isPrefixOf`)
                -- Ignore lines telling us that we're running a .T file:
              $ filter (not . ("====> Running " `isPrefixOf`)) xs

splitStarting :: (a -> Bool) -> [a] -> [[a]]
splitStarting f xs0 = case break f xs0 of
                      (_, intro : xs) -> ss intro xs
                      _ -> error "No data"
    where ss intro xs = case break f xs of
                        (this, intro' : rest) ->
                            (intro : this) : ss intro' rest
                        (this, []) -> [intro : this]


{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}

{-
  gen-dll is a replacement for dll-split which aims to solve a simple problem
  during the building of stage2. The issue is that the PE image format only has
  a 16-bit field for the symbol count. This means we can't have more than 2^16-1
  symbols in a single PE file. See Trac #5987.

  gen-dll solves this issue by partitioning the object files in such a way that
  a single dll never has more than the allowed amount of symbols. The general
  workflow of gen-dll is:

  1) use nm -g to dump the symbols defined in each object file, from this dump
     we collect three key pieces information:
     a) the object file the symbol belongs to
     b) the symbol's kind (e.g data or function)
     c) the symbol name.

  2) If the amount of symbols is lower than the maximum, we're done and we'll
     just link the entire list of symbols and move on.

     If however we have too many symbols we'll partition the symbols using a
     per object file granularity. This is because we can't split the content of
     an object file. An oc belongs to one and only one image file.

  3) Once we have the partitioning, we sub partition these into two groups for
     each partition:
     a) data
     b) function

     The reason for this is that data exports are directly accessed, whereas
     functions generally go through a trampoline. The trampolines are there to
     allow for extra functionality such as delay loading (if requested) and to
     cover for memory model changes due to linking all the object code in on
     PE image.

     Data is usually accessed direct, so we don't want the trampoline otherwise
        extern int foo;
     would point to executable code instead of data.

  4) Once we have everything correctly tagged, the partitions are dumped into a
     module definition file (def). Each file is named <dll-name>-pt<num>.<ext>
     which is also the partitioning scheme used for all other files including
     the resulting dlls.

     From the .def file we use libtool or genlib (when available) to generate
     an import library. In this case we generate a GNU style import library
     See Note [BFD import library].

     These import libraries are used to break the cyclic dependencies that may
     exist between the symbols due to the random partitioning. e.g. A may
     require B, but A and B can be in different dlls. With the import libraries
     we promise A that at runtime it'll have B, and vice versa. The Windows
     runtime linker and loader will take care of breaking this cycle at runtime.

  5) Once we have an import library for each partition, we start linking the
     final dlls. if e.g. we have 3 dlls, linking dll 1 means passing import
     libraries 2 and 3 as an argument to the linking of dll 1. This allows it
     to find all symbols since PE image files can't have dangling symbols.

  6) After creating the dlls the final step is to create one top level import
     library that is named after the original dll that we were supposed to link.

     To continue the 3 split example. say we were supposed to make libfoo.dll,
     instead we created libfoo-pt1.dll, libfoo-pt2.dll and libfoo-pt3.dll.
     Obviously using -lfoo would no longer locate the dlls.

     This is solved by using import libraries again. GNU style import libraries
     are just plain AR archives where each object file essentially contains
     only 1 symbol and the dll in which to find this symbol.

     A proper linker processes all the object files in this AR file (lld, ld and
     ghci do this.) and so while genlib and libtool don't allow you to create
     import libraries with multiple dll pointers, it is trivial to do.

     We use ar to merge together the import libraries into a large complete one.
     e.g. libfoo-pt1.dll.a, libfoo-pt2.dll.a and libfoo-pt3.dll.a are merged
     into libfoo.dll.a. The name isn't coincidental. On Windows you don't link
     directly against a dll, instead you link against an import library that
     then tells you how to get to the dll functions.

     In this case by creating a correctly named merged import library we solve
     the -lfoo problem.

     In the end we end up with libfoo-pt1.dll, libfoo-pt2.dll and libfoo-pt3.dll
     along with libfoo.dll.a. To the rest of the pipeline the split is
     completely transparent as -lfoo will just continue to work, and the linker
     is responsible for populating the IAT (Import Address Table) with the
     actual dlls we need.

  This scheme is fully scalable and will not need manual maintenance or
  intervention like dll-split needed. If we ever do switch to compiling using
  Microsoft compilers, we need to use a custom tool to modify the PE import
  libraries lib.exe creates. This is slightly more work but for now we can just
  rely on the GNU import libraries.

  If supported by the stage1 compiler, we'll create dll's which can be used as
  SxS assemblies, but in order for us to do so, we have to give GHC some extra
  information such as the stable abi name for the dll and the version of the
  dll being created. This is purely a deployment thing and does not really
  affect the workings of this tool.
-}
module Main(main) where

import Control.Arrow ((***))
import Control.Monad (when, forM_)
import Control.Exception (bracket)

import Data.Char (toLower, isSpace)
import Data.List (isPrefixOf, nub, sort, (\\))
import qualified Data.Map as M (Map(), alter, empty, toList)

import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitWith)
import System.Directory (findFilesWith, getCurrentDirectory)
import System.FilePath (takeBaseName, takeDirectory, dropExtension, (<.>)
                       ,takeFileName)
import System.IO (hClose, hGetContents, withFile, IOMode(..), hPutStrLn, openFile)
import System.Process (proc, createProcess_, StdStream (..), CreateProcess(..)
                      ,waitForProcess)

import Foreign.C.Types (CInt(..), )
import Foreign.C.String (withCWString, peekCWString, CWString)
import Foreign.Ptr (Ptr)
import Foreign.Storable (peek)
import Foreign.Marshal.Array (peekArray)
import Foreign.Marshal.Alloc (alloca)

#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif

-- Setup some standard program names.
nm :: FilePath
nm = NM_TOOL_BIN

libexe :: FilePath
libexe = LIB_TOOL_BIN

genlib :: FilePath
genlib = GENLIB_TOOL_BIN

ar :: FilePath
ar = AR_TOOL_BIN

-- Technically speaking the limit for the amount of symbols you can have in a
-- dll is 2^16-1, however Microsoft's lib.exe for some reason refuses to link
-- up to this amount. The reason is likely that it adds some extra symbols in
-- the generated dll, such as dllmain etc. So we reserve some space in the
-- symbol table to accomodate this. This number is just purely randomly chosen.
#define SYMBOL_PADDING 10

usage :: IO ()
usage = putStrLn $ unlines [ " -= Split a dll if required and perform the linking =- "
                           , ""
                           , " Usage: gen-dll <action>"
                           , ""
                           , " Where <action> is one of:"
                           , "     link     perform a real link of dll, "
                           , "              arguments: dir distdir way flags libs objs out link_cmd delay name version"
                           ]

main :: IO ()
main = do
  args <- getArgs
  if null args
     then usage
     else case (head args) of
             "link" -> let (dir:distdir:way:extra_flags:extra_libs:objs:output:
                            command:delayed:abi_name:abi_version:_) = tail args
                       in process_dll_link dir distdir way extra_flags extra_libs
                                           objs output command delayed abi_name
                                           abi_version
             _      -> usage

type Symbol = String
type Symbols = [Symbol]
type SymbolType = Char
data Obj
  = Obj { objName  :: String
        , objCount :: Int
        , objItems :: [(SymbolType, Symbol)]
        }
    deriving Show
type Objs = [Obj]

-- | Create the final DLL by using the provided arguments
--   This also creates the resulting special import library.
process_dll_link :: String -- ^ dir
                 -> String -- ^ distdir
                 -> String -- ^ way
                 -> String -- ^ extra flags
                 -> String -- ^ extra libraries to link
                 -> String -- ^ object files to link
                 -> String -- ^ output filename
                 -> String -- ^ link command
                 -> String -- ^ create delay load import libs
                 -> String -- ^ SxS Name
                 -> String -- ^ SxS version
                 -> IO ()
process_dll_link _dir _distdir _way extra_flags extra_libs objs_files output
                 link_cmd delay_imp sxs_name sxs_version
  = do let base = dropExtension output
       -- We need to know how many symbols came from other static archives
       -- So take the total number of symbols and remove those we know came
       -- from the object files. Use this to lower the max amount of symbols.
       --
       -- This granularity is the best we can do without --print-map like info.
       raw_exports <- execProg nm Nothing ["-g", "--defined-only", objs_files]
       putStrLn $ "Processing symbols.."

       let objs    = collectObjs raw_exports
           num_sym = foldr (\a b -> b + objCount a) 0 objs
           exports = base <.> "lst"

       putStrLn $ "Number of symbols in object files for " ++ output ++ ": " ++ show num_sym

       _ <- withFile exports WriteMode $ \hExports ->
             mapM_ (hPutStrLn hExports . unlines . map snd . objItems) objs

#if defined(GEN_SXS)
       -- Side-by-Side assembly generation flags for GHC. Pass these along so the DLLs
       -- get the proper manifests generated.
       let sxs_opts = [ "-fgen-sxs-assembly"
                      , "-dylib-abi-name"
                      , show sxs_name
                      , "-dylib-abi-version"
                      , show sxs_version
                      ]
#else
       let sxs_opts = []
#endif

       -- Now check that the DLL doesn't have too many symbols. See trac #5987.
       case num_sym > dll_max_symbols of
         False -> do putStrLn $ "DLL " ++ output ++ " OK, no need to split."
                     let defFile    = base <.> "def"
                         dll_import = base <.> "dll.a"

                     build_import_lib base (takeFileName output) defFile objs

                     _ <- execProg link_cmd Nothing
                              $ concat [[objs_files
                                        ,extra_libs
                                        ,extra_flags
                                        ]
                                       ,sxs_opts
                                       ,["-fno-shared-implib"
                                        ,"-optl-Wl,--retain-symbols-file=" ++ exports
                                        ,"-o"
                                        ,output
                                        ]
                                       ]

                     build_delay_import_lib defFile dll_import delay_imp

         True -> do putStrLn $ "Too many symbols for a single DLL " ++ output
                    putStrLn "We'll have to split the dll..."
                    putStrLn $  "OK, we only have space for "
                             ++ show dll_max_symbols
                             ++ " symbols from object files when building "
                             ++ output

                    -- First split the dlls up by whole object files
                    -- To do this, we iterate over all object file and
                    -- generate a the partitions based on allowing a
                    -- maximum of $DLL_MAX_SYMBOLS in one DLL.
                    let spl_objs   = groupObjs objs
                        n_spl_objs = length spl_objs
                        base'      = base ++ "-pt"

                    mapM_ (\(n, _) -> putStrLn $ ">> DLL split at " ++ show n ++ " symbols.") spl_objs
                    putStrLn $ "OK, based on the amount of symbols we'll split the DLL into " ++ show n_spl_objs ++ " pieces."

                    -- Start off by creating the import libraries to break the
                    -- mutual dependency chain.
                    forM_ (zip [(1::Int)..] spl_objs) $ \(i, (n, o)) ->
                      do putStrLn $ "Processing file " ++ show i   ++ " of "
                                 ++ show n_spl_objs    ++ " with " ++ show n
                                 ++ " symbols."
                         let base_pt = base' ++ show i
                             file    = base_pt <.> "def"
                             dll     = base_pt <.> "dll"
                             lst     = base_pt <.> "lst"

                         _ <- withFile lst WriteMode $ \hExports ->
                               mapM_ (hPutStrLn hExports . unlines . map snd . objItems) o

                         build_import_lib base_pt (takeFileName dll) file o

                    -- Now create the actual DLLs by using the import libraries
                    -- to break the mutual recursion.
                    forM_ (zip [1..] spl_objs) $ \(i, (n, _)) ->
                      do putStrLn $ "Creating DLL " ++ show i   ++ " of "
                                 ++ show n_spl_objs    ++ " with " ++ show n
                                 ++ " symbols."
                         let base_pt = base' ++ show i
                             file    = base_pt <.> "def"
                             dll     = base_pt <.> "dll"
                             lst     = base_pt <.> "lst"
                             imp_lib = base_pt <.> "dll.a"
                             indexes = [1..(length spl_objs)]\\[i]
                             libs    = map (\ix -> (base' ++ show ix) <.> "dll.a") indexes

                         _ <- execProg link_cmd Nothing
                                  $ concat [[objs_files
                                            ,extra_libs
                                            ,extra_flags
                                            ,file
                                            ]
                                           ,libs
                                           ,sxs_opts
                                           ,["-fno-shared-implib"
                                            ,"-optl-Wl,--retain-symbols-file=" ++ lst
                                            ,"-o"
                                            ,dll
                                            ]
                                           ]

                         -- build_delay_import_lib file imp_lib delay_imp
                         putStrLn $ "Created " ++ dll ++ "."

                    -- And finally, merge the individual import libraries into
                    -- one with the name of the original library we were
                    -- supposed to make. This means that nothing has to really
                    -- know how we split up the DLLs, for everything else it'so
                    -- as if it's still one large assembly.
                    create_merged_archive base base' (length spl_objs)

collectObjs :: [String] -> Objs
collectObjs = map snd . M.toList . foldr collectObjs' M.empty

collectObjs' :: String -> M.Map String Obj -> M.Map String Obj
collectObjs' []  m   = m
collectObjs' str_in m
  = let clean        = dropWhile isSpace
        str          = clean str_in
        (file, rest) = ((takeWhile (/=':') . clean) *** clean) $
                         break isSpace str
        (typ , sym ) = (id *** clean) $ break isSpace rest
        obj          = Obj { objName  = file
                           , objCount = 1
                           , objItems = [(head typ, sym)]
                           }
        upd value
          = if length typ /= 1
               then value
               else Just $ maybe obj
                                 (\o -> o { objCount = objCount o + 1
                                          , objItems = (head typ, sym) : objItems o
                                          })
                                 value
    in M.alter upd file m

-- Split a list of objects into globals and functions
splitObjs :: Objs -> (Symbols, Symbols)
splitObjs []     = ([], [])
splitObjs (y:ys) = group_ (objItems y) (splitObjs ys)
  where globals = "DdGgrRSsbBC"
        group_ :: [(Char, Symbol)] -> (Symbols, Symbols) -> (Symbols, Symbols)
        group_ []     x                             = x
        group_ (x:xs) (g, f) | fst x `elem` globals = group_ xs (snd x:g, f)
                             |     otherwise        = group_ xs (g, snd x:f)

-- Determine how to split the objects up.
groupObjs :: Objs -> [(Int, Objs)]
groupObjs = binObjs 0 []
 where binObjs :: Int -> Objs -> Objs -> [(Int, Objs)]
       binObjs n l []     = [(n, l)]
       binObjs n l (o:os)
         = let nx = objCount o
               n' = n + nx
           in if n' > dll_max_symbols
                 then (n, l) : binObjs 0 [] os
                 else binObjs n' (o:l) os

-- Maximum number of symbols to allow into
-- one DLL. This is the split factor used.
dll_max_symbols :: Int
dll_max_symbols = 65535 - SYMBOL_PADDING -- Some padding for required symbols.

isTrue :: String -> Bool
isTrue s = let s' = map toLower s
           in case () of
               () | s' == "yes" -> True
                  | s' == "no"  -> False
                  | otherwise   -> error $ "Expected yes/no but got '" ++ s ++ "'"

foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW"
     c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString)

foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
    localFree :: Ptr a -> IO (Ptr a)

mkArgs :: String -> IO [String]
mkArgs []  = return []
mkArgs arg =
  do withCWString arg $ \c_arg -> do
       alloca $ \c_size -> do
         res <- c_CommandLineToArgvW c_arg c_size
         size <- peek c_size
         args <- peekArray (fromIntegral size) res
         values <- mapM peekCWString args
         _ <- localFree res
         return values

execProg :: String -> Maybe FilePath -> [String] -> IO [String]
execProg prog m_stdin args =
  do args' <- fmap concat $ mapM mkArgs args
     prog' <- mkArgs prog
     let full@(c_prog:c_args) = prog' ++ args'
     -- print the commands we're executing for debugging and transparency
     putStrLn $ unwords $ full ++ [maybe "" ("< " ++) m_stdin]
     cwdir <- getCurrentDirectory
     let cp = (proc c_prog c_args)
              { std_out = CreatePipe, cwd = Just cwdir }
     cp' <- case m_stdin of
              Nothing   -> return cp
              Just path -> do h <- openFile path ReadMode
                              return cp{ std_in = UseHandle h}
     bracket
       (createProcess_ ("execProg: " ++ prog)  cp')
       (\(_, Just hout, _, ph) -> do
         hClose hout
         code <- waitForProcess ph
         case std_in cp' of
           UseHandle h -> hClose h
           _           -> return ()
         case code of
           ExitFailure _ -> exitWith code
           ExitSuccess   -> return ())
       (\(_, Just hout, _, _) -> do
         results <- hGetContents hout
         length results `seq` return $ lines results)

-- | Mingw-w64's genlib.exe is generally a few order of magnitudes faster than
-- libtool which is BFD based. So we prefer it, but it's not standard so
-- support both. We're talking a difference of 45 minutes in build time here.
execLibTool :: String -> String -> IO [String]
execLibTool input_def output_lib =
  do if HAS_GENLIB
        then execProg genlib Nothing [input_def, "-o", output_lib]
        else execProg libexe Nothing ["-d", input_def, "-l", output_lib]

-- Builds a delay import lib at the very end which is used to
-- be able to delay the picking of a DLL on Windows.
-- This function is called always and decided internally
-- what to do.
build_delay_import_lib :: String -- ^ input def file
                       -> String -- ^ ouput import delayed import lib
                       -> String -- ^ flag to indicate if delay import
                                 --   lib should be created
                       -> IO ()
build_delay_import_lib input_def output_lib create_delayed
  = when (isTrue create_delayed) $
       execLibTool input_def output_lib >> return ()

-- Build a normal import library from the object file definitions
build_import_lib :: FilePath -> FilePath -> FilePath -> Objs -> IO ()
build_import_lib base dll_name defFile objs
  = do -- Create a def file hiding symbols not in original object files
       -- because --export-all is re-exporting things from static libs
       -- we need to separate out data from functions. So first create two temporaries
       let (globals, functions) = splitObjs objs

       -- This split is important because for DATA entries the compiler should not generate
       -- a trampoline since CONTS DATA is directly referenced and not executed. This is not very
       -- important for mingw-w64 which would generate both the trampoline and direct referecne
       -- by default, but for libtool is it and even for mingw-w64 we can trim the output.
       _ <- withFile defFile WriteMode $ \hDef -> do
              hPutStrLn hDef $ unlines $ ["LIBRARY " ++ show dll_name
                                         ,"EXPORTS"
                                         ]
              mapM_ (\v -> hPutStrLn hDef $ "    " ++ show v ++ " DATA") globals
              mapM_ (\v -> hPutStrLn hDef $ "    " ++ show v           ) functions

       let dll_import = base <.> "dll.a"
       _ <- execLibTool defFile dll_import
       return ()

-- Do some cleanup and create merged lib.
-- Because we have no split the DLL we need
-- to provide a way for the linker to know about the split
-- DLL. Also the compile was supposed to produce a DLL
-- foo.dll and import library foo.lib. However we've actually
-- produced foo-pt1.dll, foo-pt2.dll etc. What we don't want is to have
-- To somehow convey back to the compiler that we split the DLL in x pieces
-- as this would require a lot of changes.
--
-- Instead we produce a merged import library which contains the union of
-- all the import libraries produced. This works because import libraries contain
-- only .idata section which point to the right dlls. So LD will do the right thing.
-- And this means we don't have to do any special handling for the rest of the pipeline.
create_merged_archive :: FilePath -> String -> Int -> IO ()
create_merged_archive base prefix count
  = do let ar_script = base <.> "mri"
           imp_lib   = base <.> "dll.a"
           imp_libs  = map (\i -> prefix ++ show i <.> "dll.a") [1..count]
       let script = [ "create " ++ imp_lib    ] ++
                    map ("addlib " ++) imp_libs ++
                    [ "save", "end" ]
       writeFile ar_script (unlines script)
       _ <- execProg ar (Just ar_script) ["-M"]
       return ()