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 > nome...@debian.org | ICQ# 74513189 | GPG-Keyid: 4743206C > JID: nome...@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 <k...@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)>] > -- To UNSUBSCRIBE, email to debian-haskell-requ...@lists.debian.org with a subject of "unsubscribe". Trouble? Contact listmas...@lists.debian.org
