Re: Haddock patch for arch problem
Hello,
Is there any reason not to try to get this patch taken upstream? Does
upstream even know that haddock is architecture dependent these days?
- jeremy
At Sun, 22 Feb 2009 01:46:12 +0100,
Joachim Breitner wrote:
>
> [1 <multipart/mixed (7bit)>]
> [1.1 <text/plain; UTF-8 (quoted-printable)>]
> 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
> [1.2 haddock-arch-indep-read.patch <text/plain; ISO-8859-15 (base64)>]
> 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"
> [2 Dies ist ein digital signierter Nachrichtenteil <application/pgp-signature (7bit)>]
>
Reply to: