hsc2hs: Update submodule
[ghc.git] / utils / deriveConstants / DeriveConstants.hs
index 3173c27..72605d7 100644 (file)
@@ -10,20 +10,20 @@ into non-C source containing this information.
 
 ------------------------------------------------------------------------ -}
 
-import Control.Monad
-import Data.Bits
-import Data.Char
-import Data.List
+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
-import Numeric
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.IO
-import System.Info
-import System.Process
+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.Info (os)
+import System.Process (showCommandForUser, readProcess, rawSystem)
 
 main :: IO ()
 main = do opts <- parseArgs
@@ -313,6 +313,18 @@ wanteds = concat
           ,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"
@@ -337,6 +349,8 @@ wanteds = concat
           ,structField C    "Capability" "context_switch"
           ,structField C    "Capability" "interrupt"
           ,structField C    "Capability" "sparks"
+          ,structField C    "Capability" "weak_ptr_list_hd"
+          ,structField C    "Capability" "weak_ptr_list_tl"
 
           ,structField Both "bdescr" "start"
           ,structField Both "bdescr" "free"
@@ -379,8 +393,11 @@ wanteds = concat
           ,closureField Both "StgMutArrPtrs" "ptrs"
           ,closureField Both "StgMutArrPtrs" "size"
 
+          ,closureSize  Both "StgSmallMutArrPtrs"
+          ,closureField Both "StgSmallMutArrPtrs" "ptrs"
+
           ,closureSize    Both "StgArrWords"
-          ,closureField   C    "StgArrWords" "bytes"
+          ,closureField   Both "StgArrWords" "bytes"
           ,closurePayload C    "StgArrWords" "payload"
 
           ,closureField  C    "StgTSO"      "_link"
@@ -526,13 +543,13 @@ wanteds = concat
           ,structSize   C "StgFunInfoExtraFwd"
           ,structField  C "StgFunInfoExtraFwd" "slow_apply"
           ,structField  C "StgFunInfoExtraFwd" "fun_type"
-          ,structField  C "StgFunInfoExtraFwd" "arity"
+          ,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"
-          ,structField  C    "StgFunInfoExtraRev" "arity"
+          ,structFieldH Both "StgFunInfoExtraRev" "arity"
           ,structField_ C    "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
 
           ,structField C "StgLargeBitmap" "size"
@@ -576,11 +593,11 @@ wanteds = concat
           ,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_SSE_REG"          "MAX_SSE_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_SSE_REG"     "MAX_REAL_SSE_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
@@ -626,7 +643,10 @@ getWanted verbose tmpdir gccProgram gccFlags nmProgram
              oFile = tmpdir </> "tmp.o"
          writeFile cFile cStuff
          execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
-         xs <- readProcess nmProgram [oFile] ""
+         xs <- case os of
+                 "openbsd" -> readProcess "/usr/bin/objdump" ["--syms", oFile] ""
+                 _         -> readProcess nmProgram ["-P", oFile] ""
+
          let ls = lines xs
              ms = map parseNmLine ls
              m = Map.fromList $ catMaybes ms
@@ -695,28 +715,22 @@ getWanted verbose tmpdir gccProgram gccFlags nmProgram
           doWanted (ClosurePayloadMacro {}) = []
           doWanted (FieldTypeGcptrMacro {}) = []
 
-          -- parseNmLine parses nm output that looks like
-          -- "0000000b C derivedConstantMAX_Vanilla_REG"
+          -- 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 xs0 = case break (' ' ==) xs0 of
-                            (x1, ' ' : xs1) ->
-                                case break (' ' ==) xs1 of
-                                (x2, ' ' : x3) ->
-                                    case readHex x1 of
-                                    [(size, "")] ->
-                                        case x2 of
-                                        "C" ->
-                                            let x3' = case x3 of
-                                                      '_' : rest -> rest
-                                                      _          -> x3
-                                            in case stripPrefix prefix x3' of
-                                               Just name ->
-                                                   Just (name, size)
-                                               _ -> Nothing
-                                        _ -> Nothing
-                                    _ -> Nothing
-                                _ -> Nothing
-                            _ -> Nothing
+          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
 
           -- If an Int value is larger than 2^28 or smaller
           -- than -2^28, then fail.