hsc2hs: Update submodule
[ghc.git] / utils / deriveConstants / DeriveConstants.hs
index 10df61c..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
@@ -349,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"
@@ -391,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"
@@ -638,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
@@ -707,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.