Hi, I spend some time now (far more than planned, given that this solution is probably not what we want...) to make haddock on amd64 read the interface files generated on 32bit machines. The trick is to replace any all to "Binary.get" to a custom function getTypeName, so that in the end all pointers and Ints are read as 32 bit values. It works nicely, although the code is a bit hackish at times, and everything but elegant. I don’t think though that there is a better way to fix it by only modifying haddock. I did not work on putting all Ints as 32bit (just changed it at some lines, but didn’t test it yet). It should be somewhat easier, as putName and putFastString is already provided to Binary by the using module, so I assume that a large number of normal Binary instances can be used. If we want to go this way (e.g. patching Haddock for Debian), I’m willing to finish this patch, but of course if we stick to putting .haddock in -dev, I won’t :-) Greetings, Joachim -- Joachim "nomeata" Breitner Debian Developer nomeata@debian.org | ICQ# 74513189 | GPG-Keyid: 4743206C JID: nomeata@joachim-breitner.de | http://people.debian.org/~nomeata
diff -u haddock-2.4.1/debian/changelog haddock-2.4.1/debian/changelog
--- haddock-2.4.1/debian/changelog
+++ haddock-2.4.1/debian/changelog
@@ -1,3 +1,10 @@
+haddock (2.4.1-3.nomeata1) UNRELEASED; urgency=low
+
+ * Make haddock read .haddock files from 32bit correctly, even if on
+ 64bit
+
+ -- Kari Pahula <kaol@debian.org> Sun, 22 Feb 2009 01:39:02 +0100
+
haddock (2.4.1-3) unstable; urgency=low
* Uploaded to unstable.
only in patch2:
unchanged:
--- haddock-2.4.1.orig/src/Haddock/InterfaceFile.hs
+++ haddock-2.4.1/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
) where
-import Haddock.DocName ()
+import Haddock.DocName
import Haddock.Types
import Haddock.Utils
@@ -28,7 +28,11 @@
import GHC hiding (NoLink)
import SrcLoc (noSrcSpan) -- tmp, GHC now exports this
-import Binary
+
+import Binary hiding (getDictionary, putDictionary)
+import Unsafe.Coerce
+import Foreign
+
import Name
import UniqSupply
import UniqFM
@@ -81,11 +85,11 @@
-- remember where the dictionary pointer will go
dict_p_p <- tellBin bh0
- put_ bh0 dict_p_p
+ putBin_ bh0 dict_p_p
-- remember where the symbol table pointer will go
symtab_p_p <- tellBin bh0
- put_ bh0 symtab_p_p
+ putBin_ bh0 symtab_p_p
-- Make some intial state
#if __GLASGOW_HASKELL__ >= 609
@@ -127,7 +131,7 @@
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBin bh
- putAt bh dict_p_p dict_p
+ putBinAt bh dict_p_p dict_p
seekBin bh dict_p
-- write the dictionary itself
@@ -216,7 +220,7 @@
return (Right iface)
where
get_dictionary bin_handle = liftIO $ do
- dict_p <- get bin_handle
+ dict_p <- getBin bin_handle
data_p <- tellBin bin_handle
seekBin bin_handle dict_p
dict <- getDictionary bin_handle
@@ -228,7 +232,7 @@
return (setUserData bin_handle ud)
get_symbol_table bh1 theNC = liftIO $ do
- symtab_p <- get bh1
+ symtab_p <- getBin bh1
data_p' <- tellBin bh1
seekBin bh1 symtab_p
(nc', symtab) <- getSymbolTable bh1 theNC
@@ -254,7 +258,7 @@
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
- put_ bh off
+ putInt_ bh off
data BinSymbolTable = BinSymbolTable {
@@ -274,7 +278,7 @@
Just (j, _) -> put_ bh j
Nothing -> do
j <- readFastMutInt j_r
- put_ bh j
+ putInt_ bh j
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out unique (j, f)
@@ -289,14 +293,14 @@
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
- put_ bh next_off
+ putInt_ bh next_off
let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
getSymbolTable bh namecache = do
- sz <- get bh
- od_names <- sequence (replicate sz (get bh))
+ sz <- getInt bh
+ od_names <- sequence (replicate sz (getStuff bh))
let
arr = listArray (0,sz-1) names
(namecache', names) =
@@ -334,6 +338,129 @@
let modu = nameModule name
put_ bh (modulePackageId modu, moduleName modu, nameOccName name)
+------------------------------------------------------------------------------
+-- Helpers to have an arch independent code
+--
+-- This is mostly copying the structure of the Binary instances, giving them
+-- explicit names, to make sure any Int is converted correctly.
+--
+-- Worst hack is the use of unsafeCoerce to create newtypes that are exported
+-- abstractly.
+------------------------------------------------------------------------------
+putInt :: BinHandle -> Int -> IO (Bin Int)
+putInt bh i = castBin `fmap` put bh (fromIntegral i :: Word32)
+
+putInt_ :: BinHandle -> Int -> IO ()
+putInt_ bh i = put_ bh (fromIntegral i :: Word32)
+
+getInt :: BinHandle -> IO Int
+getInt bh = fromIntegral `fmap` (get bh :: IO Word32)
+
+putIntAt :: BinHandle -> Bin Int -> Int -> IO ()
+putIntAt bh p x = do seekBin bh (castBin p); putInt bh x; return ()
+
+-- This is safe, as newtype Bin a = BinPtr Int
+binToInt :: Bin a -> Int
+binToInt = unsafeCoerce
+
+intToBin :: Int -> Bin a
+intToBin = unsafeCoerce
+
+-- We also need to make Pointers 32 bit long
+putBin :: BinHandle -> Bin a -> IO (Bin (Bin a))
+putBin bh b = castBin `fmap` put bh (fromIntegral (binToInt b) :: Word32)
+
+putBin_ :: BinHandle -> Bin a -> IO ()
+putBin_ bh b = put_ bh (fromIntegral (binToInt b) :: Word32)
+
+getBin :: BinHandle -> IO (Bin a)
+getBin bh = (intToBin . fromIntegral) `fmap` (get bh :: IO Word32)
+
+putBinAt :: BinHandle -> Bin (Bin a) -> Bin a -> IO ()
+putBinAt bh p x = do seekBin bh (castBin p :: Bin Int); putBin bh x; return ()
+
+-- Copied from Binary.hs, changed to Word32 size
+putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
+putDictionary bh sz dict = do
+ putInt_ bh sz
+ mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
+
+getDictionary :: BinHandle -> IO (Array Int FastString)
+getDictionary bh = do
+ sz <- getInt bh
+ elems <- sequence (take sz (repeat (getFS bh)))
+ return (listArray (0,sz-1) elems)
+
+-- Copied from Binary.hs, fixed index variable size
+getFS bh = do
+ l <- getInt bh
+ fp <- mallocForeignPtrBytes l
+ withForeignPtr fp $ \ptr -> do
+ let
+ go n | n == l = mkFastStringForeignPtr ptr fp l
+ | otherwise = do
+ b <- getByte bh
+ pokeElemOff ptr n b
+ go (n+1)
+ --
+ go 0
+
+-- This corresponds to the Binary FastString interface. The put methods are ok,
+-- as they are fed via UserData
+getFS' bh = do
+ wh <- tellBin bh
+ j <- getInt bh
+ return $! (ud_dict (getUserData bh) ! j)
+
+-- This corresponds to the Binary Name interface. The put methods are ok,
+-- as they are fed via UserData
+getName' bh = do
+ i <- getInt bh
+ return $! (ud_symtab (getUserData bh) ! i)
+
+getStuff :: BinHandle -> IO (PackageId, ModuleName, OccName)
+getStuff bh = do
+ pi <- do { fs <- getFS' bh; return (fsToPackageId fs) }
+ mn <- do { fs <- getFS' bh; return (fsToModuleName fs) }
+ on <- do { ns <- get bh; fs <- getFS' bh; return (mkOccNameFS ns fs) }
+ return (pi,mn,on)
+
+-- This is safe, as newtype PackageId = PId FastString
+fsToModuleName :: FastString -> ModuleName
+fsToModuleName = unsafeCoerce
+
+getModule bh = do
+ pi <- do { fs <- getFS' bh; return (fsToPackageId fs) }
+ mn <- do { fs <- getFS' bh; return (fsToModuleName fs) }
+ return (mkModule pi mn)
+
+getList :: (BinHandle -> IO a) -> BinHandle -> IO [a]
+getList getter bh = do
+ b <- getByte bh
+ len <- if b == 0xff
+ then get bh
+ else return (fromIntegral b :: Word32)
+ let loop 0 = return []
+ loop n = do
+ a <- getter bh
+ as <- loop (n-1)
+ return (a:as)
+ loop len
+
+getTup :: (BinHandle -> IO a) -> (BinHandle -> IO b) -> (BinHandle -> IO (a,b))
+getTup getter1 getter2 bh = do
+ a1 <- getter1 bh
+ a2 <- getter2 bh
+ return (a1,a2)
+
+getLinkEnv :: BinHandle -> IO [(Name,Module)]
+getLinkEnv = getList (getTup getName' getModule)
+getDocMap :: BinHandle -> IO [(Name,HsDoc DocName)]
+getDocMap = getList (getTup getName' get)
+getSubMap :: BinHandle -> IO [(Name,[Name])]
+getSubMap = getList (getTup getName' (getList getName'))
+getNames :: BinHandle -> IO [Name]
+getNames = getList getName'
-------------------------------------------------------------------------------
-- GhcBinary instances
@@ -346,7 +473,7 @@
put_ bh ifaces
get bh = do
- env <- get bh
+ env <- getLinkEnv bh
ifaces <- get bh
return (InterfaceFile (Map.fromList env) ifaces)
@@ -360,14 +487,13 @@
put_ bh visExps
get bh = do
- modu <- get bh
+ modu <- getModule bh
info <- get bh
- docMap <- get bh
- exps <- get bh
- visExps <- get bh
+ docMap <- getDocMap bh
+ exps <- getNames bh
+ visExps <- getNames bh
return (InstalledInterface modu info (Map.fromList docMap) exps visExps)
-
instance Binary DocOption where
put_ bh OptHide = do
putByte bh 0
@@ -502,3 +628,25 @@
stabi <- get bh
maint <- get bh
return (HaddockModInfo descr porta stabi maint)
+
+instance Binary DocName where
+ put_ bh (Documented name modu) = do
+ putByte bh 0
+ put_ bh name
+ put_ bh modu
+ put_ bh (Undocumented name) = do
+ putByte bh 1
+ put_ bh name
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- getName' bh
+ modu <- getModule bh
+ return (Documented name modu)
+ 1 -> do
+ name <- getName' bh
+ return (Undocumented name)
+ _ -> error "get DocName: Bad h"
+
only in patch2:
unchanged:
--- haddock-2.4.1.orig/src/Haddock/DocName.hs
+++ haddock-2.4.1/src/Haddock/DocName.hs
@@ -26,25 +26,3 @@
docNameOrig :: DocName -> Name
docNameOrig (Documented name _) = name
docNameOrig (Undocumented name) = name
-
-
-instance Binary DocName where
- put_ bh (Documented name modu) = do
- putByte bh 0
- put_ bh name
- put_ bh modu
- put_ bh (Undocumented name) = do
- putByte bh 1
- put_ bh name
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- name <- get bh
- modu <- get bh
- return (Documented name modu)
- 1 -> do
- name <- get bh
- return (Undocumented name)
- _ -> error "get DocName: Bad h"
Attachment:
signature.asc
Description: Dies ist ein digital signierter Nachrichtenteil