From b80977561c12b6df38645e87220d0e1f7a61ada3 Mon Sep 17 00:00:00 2001 From: cgibbard Date: Sun, 16 Dec 2007 05:28:44 +0000 Subject: [PATCH] Remove Language.Hi in favour of using the ghc-api directly, fix to work with GHC 6.8.2. This is still *very* kludgey, and it needs lots of work which I'm not entirely prepared for, seeing as I really don't know anything about the ghc-api and how things are supposed to fit together. It is quite conceivable that the code could be simplified much further by someone who actually understands the ghc-api, and there may be bugs related to the fact that I don't actually know what some things do. However, this builds and does appear to work. Most of the testsuite is passing. --- plugins.cabal | 12 +- plugins.cabal.hsx | 36 -- src/Language/Hi/Binary.hs | 581 -------------------------- src/Language/Hi/FastMutInt.hs | 81 ---- src/Language/Hi/FastString.hs | 508 ---------------------- src/Language/Hi/Parser.hs | 720 -------------------------------- src/Language/Hi/PrimPacked.hs | 194 --------- src/Language/Hi/Syntax.hs | 360 ---------------- src/Language/Hi/hschooks.c | 38 -- src/Language/Hi/hschooks.h | 13 - src/System/Plugins/Load.hs | 54 ++- src/System/Plugins/LoadTypes.hs | 6 +- testsuite/eval/eval_/Main.hs | 2 +- 13 files changed, 45 insertions(+), 2560 deletions(-) delete mode 100644 plugins.cabal.hsx delete mode 100644 src/Language/Hi/Binary.hs delete mode 100644 src/Language/Hi/FastMutInt.hs delete mode 100644 src/Language/Hi/FastString.hs delete mode 100644 src/Language/Hi/Parser.hs delete mode 100644 src/Language/Hi/PrimPacked.hs delete mode 100644 src/Language/Hi/Syntax.hs delete mode 100644 src/Language/Hi/hschooks.c delete mode 100644 src/Language/Hi/hschooks.h diff --git a/plugins.cabal b/plugins.cabal index 719e307..7733dcc 100644 --- a/plugins.cabal +++ b/plugins.cabal @@ -5,12 +5,6 @@ License-file: LICENSE author: Don Stewart maintainer: dons@cse.unsw.edu.au exposed-modules: - Language.Hi.Binary, - Language.Hi.FastMutInt, - Language.Hi.FastString, - Language.Hi.Parser, - Language.Hi.PrimPacked, - Language.Hi.Syntax, System.Eval, System.Eval.Haskell, System.Eval.Utils, @@ -27,10 +21,8 @@ exposed-modules: System.Plugins.Parser, System.Plugins.Process, System.Plugins.Utils -c-sources: - src/Language/Hi/hschooks.c includes: Linker.h extensions: CPP, ForeignFunctionInterface -Build-Depends: base, Cabal, haskell-src +Build-Depends: base, Cabal, haskell-src, containers, array, directory, random, process, ghc ghc-options: -Wall -O -fasm -funbox-strict-fields -fno-warn-missing-signatures -hs-source-dir: src +hs-source-dirs: src diff --git a/plugins.cabal.hsx b/plugins.cabal.hsx deleted file mode 100644 index d3212e4..0000000 --- a/plugins.cabal.hsx +++ /dev/null @@ -1,36 +0,0 @@ -name: plugins -version: 1.0 -license: LGPL -License-file: LICENSE -author: Don Stewart -maintainer: dons@cse.unsw.edu.au -exposed-modules: - Language.Hi.Binary, - Language.Hi.FastMutInt, - Language.Hi.FastString, - Language.Hi.Parser, - Language.Hi.PrimPacked, - Language.Hi.Syntax, - System.Eval, - System.Eval.Haskell, - System.Eval.Utils, - System.MkTemp, - System.Plugins, - System.Plugins.Consts, - System.Plugins.Env, - System.Plugins.Load, - System.Plugins.LoadTypes, - System.Plugins.Make, - System.Plugins.Package, - System.Plugins.PackageAPI, - System.Plugins.ParsePkgConfCabal, - System.Plugins.Parser, - System.Plugins.Process, - System.Plugins.Utils -c-sources: - src/Language/Hi/hschooks.c -includes: Linker.h -extensions: CPP, ForeignFunctionInterface -Build-Depends: base, Cabal, haskell-src-exts -ghc-options: -Wall -O -fvia-C -funbox-strict-fields -fno-warn-missing-signatures -hs-source-dir: src diff --git a/src/Language/Hi/Binary.hs b/src/Language/Hi/Binary.hs deleted file mode 100644 index 7f6dbed..0000000 --- a/src/Language/Hi/Binary.hs +++ /dev/null @@ -1,581 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -fno-warn-unused-imports -fno-warn-name-shadowing #-} -{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds #-} --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA - --- Based on $fptools/ghc/compiler/utils/Binary.hs: --- (c) The University of Glasgow 2002 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ --- --- We never have to write stuff, so I've scrubbed all the put* code. --- - -module Language.Hi.Binary ( - {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - - openBinIO, openBinIO_, - openBinMem, --- closeBin, - - seekBin, - tellBin, - castBin, - - readBinMem, - - isEOFBin, - - -- for writing instances: - getByte, - - -- lazy Bin I/O - lazyGet, - - -- GHC only: - ByteArray(..), - getByteArray, - - getBinFileWithDict, -- :: Binary a => FilePath -> IO a - - ) where - --- The *host* architecture version: -#include "MachDeps.h" - --- import Hi.Utils -- ? - -import Language.Hi.FastMutInt -import Language.Hi.FastString - -#if __GLASGOW_HASKELL__ < 604 -import Data.FiniteMap -#else -import qualified Data.Map as M -#endif - -import Data.Unique - -import Data.Array.IO -import Data.Array -import Data.Bits -import Data.Int -import Data.Word -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Array.Base ( unsafeRead, unsafeWrite ) -import Control.Monad ( when ) -import System.IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Exts -import GHC.IOBase ( IO(..) ) -import GHC.Word ( Word8(..) ) -#if __GLASGOW_HASKELL__ < 601 -import GHC.Handle ( openFileEx, IOModeEx(..) ) -#endif - -#if __GLASGOW_HASKELL__ < 601 -openBinaryFile f mode = openFileEx f (BinaryMode mode) -#endif - -type BinArray = IOUArray Int Word8 - ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - bh_usr :: UserData, -- sigh, need parameterized modules :-) - off_r :: !FastMutInt, -- the current offset - sz_r :: !FastMutInt, -- size of the array (cached) - arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - - | BinIO { -- binary data stored in a file - bh_usr :: UserData, - off_r :: !FastMutInt, -- the current offset (cached) - hdl :: !Handle -- the file handle (must be seekable) - } - -- cache the file ptr in BinIO; using hTell is too expensive - -- to call repeatedly. If anyone else is modifying this Handle - -- at the same time, we'll be screwed. - -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh - -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } - - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - -class Binary a where - get :: BinHandle -> IO a - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinIO_ :: Handle -> IO BinHandle -openBinIO_ h = openBinIO h - -openBinIO :: Handle -> IO BinHandle -openBinIO h = do - r <- newFastMutInt - writeFastMutInt r 0 - return (BinIO noUserData r h) - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Hi.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- newArray_ (0,size-1) - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - return (BinMem noUserData ix_r sz_r arr_r) - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin (BinIO _ ix_r h) (BinPtr p) = do - writeFastMutInt ix_r p - hSeek h AbsoluteSeek (fromIntegral p) -seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r a) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - return (ix >= sz) -isEOFBin (BinIO _ ix_r h) = hIsEOF h - -readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- newArray_ (0,filesize-1) - count <- hGetArray h arr filesize - when (count /= filesize) - (error ("Hi.Binary.readBinMem: only read " ++ show count ++ " bytes")) - hClose h - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r filesize - return (BinMem noUserData ix_r sz_r arr_r) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ ix_r sz_r arr_r) off = do - sz <- readFastMutInt sz_r - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) - arr <- readIORef arr_r - arr' <- newArray_ (0,sz'-1) - sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i - | i <- [ 0 .. sz-1 ] ] - writeFastMutInt sz_r sz' - writeIORef arr_r arr' -#ifdef DEBUG - hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') -#endif - return () -expandBin (BinIO _ _ _) _ = return () - -- no need to expand a file, we'll assume they expand by themselves. - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - -getWord8 :: BinHandle -> IO Word8 -getWord8 (BinMem _ ix_r sz_r arr_r) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ -#if __GLASGOW_HASKELL__ <= 408 - throw (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) -#else - ioError (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) -#endif - arr <- readIORef arr_r - w <- unsafeRead arr ix - writeFastMutInt ix_r (ix+1) - return w -getWord8 (BinIO _ ix_r h) = do - ix <- readFastMutInt ix_r - c <- hGetChar h - writeFastMutInt ix_r (ix+1) - return $! (fromIntegral (ord c)) -- XXX not really correct - -getByte :: BinHandle -> IO Word8 -getByte = getWord8 - --- ----------------------------------------------------------------------------- --- Primitve Word writes - -instance Binary Word8 where - get = getWord8 - -instance Binary Word16 where - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) - -instance Binary Word32 where - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 24) .|. - (fromIntegral w2 `shiftL` 16) .|. - (fromIntegral w3 `shiftL` 8) .|. - (fromIntegral w4)) - -instance Binary Word64 where - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - w5 <- getWord8 h - w6 <- getWord8 h - w7 <- getWord8 h - w8 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 56) .|. - (fromIntegral w2 `shiftL` 48) .|. - (fromIntegral w3 `shiftL` 40) .|. - (fromIntegral w4 `shiftL` 32) .|. - (fromIntegral w5 `shiftL` 24) .|. - (fromIntegral w6 `shiftL` 16) .|. - (fromIntegral w7 `shiftL` 8) .|. - (fromIntegral w8)) - --- ----------------------------------------------------------------------------- --- Primitve Int writes - -instance Binary Int8 where - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - get h = do w <- get h; return $! (fromIntegral (w::Word16)) - -instance Binary Int32 where - get h = do w <- get h; return $! (fromIntegral (w::Word32)) - -instance Binary Int64 where - get h = do w <- get h; return $! (fromIntegral (w::Word64)) - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - get _ = return () - -instance Binary Bool where - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) - -instance Binary Char where - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) - -instance Binary Int where -#if SIZEOF_HSINT == 4 - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int32)) -#elif SIZEOF_HSINT == 8 - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) -#else -#error "unsupported sizeof(HsInt)" -#endif - -instance Binary a => Binary [a] where -#if __GLASGOW_HASKELL__ < 605 - get bh = do h <- getWord8 bh - case h of - 0 -> return [] - _ -> do x <- get bh - xs <- get bh - return (x:xs) -#else - get 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 <- get bh; as <- loop (n-1); return (a:as) - loop len -#endif - -instance (Binary a, Binary b) => Binary (a,b) where - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance Binary a => Binary (Maybe a) where - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -#ifdef __GLASGOW_HASKELL__ -instance Binary Integer where - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - - -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newByteArray# sz s of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s, arr #) -> - (# s, BA arr #) } - -#if __GLASGOW_HASKELL__ < 503 -writeByteArray arr i w8 = IO $ \s -> - case word8ToWord w8 of { W# w# -> - case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> - (# s , () #) }} -#else -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } -#endif - -#if __GLASGOW_HASKELL__ < 503 -indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) -#else -indexByteArray a# n# = W8# (indexWord8Array# a# n#) -#endif - -instance (Integral a, Binary a) => Binary (Ratio a) where - get bh = do a <- get bh; b <- get bh; return (a :% b) -#endif - -instance Binary (Bin a) where - get bh = do i <- get bh; return (BinPtr i) - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO (getAt bh p_a) - seekBin bh p -- skip over the object for now - return a - --- -------------------------------------------------------------- --- Main wrappers: getBinFileWithDict, putBinFileWithDict --- --- This layer is built on top of the stuff above, --- and should not know anything about BinHandles --- -------------------------------------------------------------- - -initBinMemSize = (1024*1024) :: Int -#if WORD_SIZE_IN_BITS == 32 -binaryInterfaceMagic = 0x1face :: Word32 -#elif WORD_SIZE_IN_BITS == 64 -binaryInterfaceMagic = 0x1face64 :: Word32 -#endif - -getBinFileWithDict :: Binary a => FilePath -> IO a -getBinFileWithDict file_path = do - bh <- Language.Hi.Binary.readBinMem file_path - - -- Read the magic number to check that this really is a GHC .hi file - -- (This magic number does not change when we change - -- GHC interface file format) - magic <- get bh - - when (magic /= binaryInterfaceMagic) $ - error "magic number mismatch: old/corrupt interface file?" - - -- Read the dictionary - -- The next word in the file is a pointer to where the dictionary is - -- (probably at the end of the file) - dict_p <- Language.Hi.Binary.get bh -- Get the dictionary ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - - seekBin bh data_p -- Back to where we were before - - -- Initialise the user-data field of bh - let bh' = setUserData bh (initReadState dict) - - -- At last, get the thing - get bh' - --- ----------------------------------------------------------------------------- --- UserData --- ----------------------------------------------------------------------------- - -data UserData = - UserData { -- This field is used only when reading - ud_dict :: Dictionary, - - -- The next two fields are only used when writing - ud_next :: IORef Int, -- The next index to use -#if __GLASGOW_HASKELL__ < 604 - ud_map :: IORef (FiniteMap Unique (Int,FastString)) -#else - ud_map :: IORef (M.Map Unique (Int,FastString)) -#endif - } - -noUserData = error "Hi.Binary.UserData: no user data" - -initReadState :: Dictionary -> UserData -initReadState dict = UserData{ ud_dict = dict, - ud_next = undef "next", - ud_map = undef "map" } - -newWriteState :: IO UserData -newWriteState = do - j_r <- newIORef 0 -#if __GLASGOW_HASKELL__ < 604 - out_r <- newIORef emptyFM -#else - out_r <- newIORef M.empty -#endif - return (UserData { ud_dict = error "dict", - ud_next = j_r, - ud_map = out_r }) - - -undef s = error ("Hi.Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh - elems <- sequence (take sz (repeat (getFS bh))) - return (listArray (0,sz-1) elems) - -#if __GLASGOW_HASKELL__ < 604 -constructDictionary :: Int -> FiniteMap Unique (Int,FastString) -> Dictionary -constructDictionary j fm = array (0,j-1) (eltsFM fm) -#else -constructDictionary :: Int -> M.Map Unique (Int,FastString) -> Dictionary -constructDictionary j fm = array (0,j-1) (M.elems fm) -#endif - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -getFS bh = do - (I# l) <- get bh - (BA ba) <- getByteArray bh (I# l) - return $! (mkFastSubStringBA# ba 0# l) - -instance Binary FastString where - get bh = do j <- get bh -- Int - return $! (ud_dict (getUserData bh) ! j) - diff --git a/src/Language/Hi/FastMutInt.hs b/src/Language/Hi/FastMutInt.hs deleted file mode 100644 index 39ea14d..0000000 --- a/src/Language/Hi/FastMutInt.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -fno-warn-name-shadowing #-} --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- --- Based on code from $fptools/ghc/compiler/utils/FastMutInt.lhs --- --- (c) Copyright 2002, The University Court of the University of Glasgow. - --- --- Unboxed mutable Ints --- - -module Language.Hi.FastMutInt ( - FastMutInt, - newFastMutInt, - readFastMutInt, - writeFastMutInt, - incFastMutInt, - incFastMutIntBy - ) where - -#include "MachDeps.h" - -#if __GLASGOW_HASKELL__ < 503 -import GlaExts -import PrelIOBase -#else -import GHC.Base -import GHC.IOBase -#endif - -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif - -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt :: IO FastMutInt -newFastMutInt = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSINT - -readFastMutInt :: FastMutInt -> IO Int -readFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt :: FastMutInt -> Int -> IO () -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> - case writeIntArray# arr 0# i s of { s -> - (# s, () #) } - -incFastMutInt :: FastMutInt -> IO Int -- Returns original value -incFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - case writeIntArray# arr 0# (i +# 1#) s of { s -> - (# s, I# i #) } } - -incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value -incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - case writeIntArray# arr 0# (i +# n) s of { s -> - (# s, I# i #) } } - diff --git a/src/Language/Hi/FastString.hs b/src/Language/Hi/FastString.hs deleted file mode 100644 index 6a23067..0000000 --- a/src/Language/Hi/FastString.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} - -{-# OPTIONS -#include "hschooks.h" #-} - --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- --- Based on $fptools/ghc/compiler/utils/FastString.lhs --- --- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 --- --- Fast strings --- --- Compact representations of character strings with --- unique identifiers (hash-cons'ish). --- - -module Language.Hi.FastString - ( - FastString(..), -- not abstract, for now. - - mkFastString, -- :: String -> FastString - mkFastStringNarrow, -- :: String -> FastString - mkFastSubString, -- :: Addr -> Int -> Int -> FastString - - mkFastString#, -- :: Addr# -> FastString - mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString - - mkFastStringInt, -- :: [Int] -> FastString - - uniqueOfFS, -- :: FastString -> Int# - lengthFS, -- :: FastString -> Int - nullFastString, -- :: FastString -> Bool - - unpackFS, -- :: FastString -> String - unpackIntFS, -- :: FastString -> [Int] - appendFS, -- :: FastString -> FastString -> FastString - headFS, -- :: FastString -> Char - headIntFS, -- :: FastString -> Int - tailFS, -- :: FastString -> FastString - concatFS, -- :: [FastString] -> FastString - consFS, -- :: Char -> FastString -> FastString - indexFS, -- :: FastString -> Int -> Char - nilFS, -- :: FastString - - hPutFS, -- :: Handle -> FastString -> IO () - - LitString, - mkLitString# -- :: Addr# -> LitString - ) where - -import Language.Hi.PrimPacked - -import System.IO -import Data.Char ( chr, ord ) - -import GHC.Exts -import GHC.IOBase -import GHC.Arr ( STArray(..), newSTArray ) -import GHC.Handle - -import Foreign.C - --- import System.IO.Unsafe ( unsafePerformIO ) --- import Control.Monad.ST ( stToIO ) --- import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) - - -#define hASH_TBL_SIZE 993 - -{- -@FastString@s are packed representations of strings -with a unique id for fast comparisons. The unique id -is assigned when creating the @FastString@, using -a hash table to map from the character string representation -to the unique ID. --} - -data FastString - = FastString -- packed repr. on the heap. - Int# -- unique id - -- 0 => string literal, comparison - -- will - Int# -- length - ByteArray# -- stuff - - | UnicodeStr -- if contains characters outside '\1'..'\xFF' - Int# -- unique id - [Int] -- character numbers - -instance Eq FastString where - -- shortcut for real FastStrings - (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2 - a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False } - - (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2 - a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } - -instance Ord FastString where - -- Compares lexicographically, not by unique - a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } - a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } - a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } - a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } - max x y | x >= y = x - | otherwise = y - min x y | x <= y = x - | otherwise = y - compare a b = cmpFS a b - -lengthFS :: FastString -> Int -lengthFS (FastString _ l# _) = I# l# -lengthFS (UnicodeStr _ s) = length s - -nullFastString :: FastString -> Bool -nullFastString (FastString _ l# _) = l# ==# 0# -nullFastString (UnicodeStr _ []) = True -nullFastString (UnicodeStr _ (_:_)) = False - -unpackFS :: FastString -> String -unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#) -unpackFS (UnicodeStr _ s) = map chr s - -unpackIntFS :: FastString -> [Int] -unpackIntFS (UnicodeStr _ s) = s -unpackIntFS fs = map ord (unpackFS fs) - -appendFS :: FastString -> FastString -> FastString -appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2) - -concatFS :: [FastString] -> FastString -concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better - -headFS :: FastString -> Char -headFS (FastString _ l# ba#) = - if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS") -headFS (UnicodeStr _ (c:_)) = chr c -headFS (UnicodeStr _ []) = error ("headFS: empty FS") - -headIntFS :: FastString -> Int -headIntFS (UnicodeStr _ (c:_)) = c -headIntFS fs = ord (headFS fs) - -indexFS :: FastString -> Int -> Char -indexFS f i@(I# i#) = - case f of - FastString _ l# ba# - | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#) - | otherwise -> error (msg (I# l#)) - UnicodeStr _ s -> chr (s!!i) - where - msg l = "indexFS: out of range: " ++ show (l,i) - -tailFS :: FastString -> FastString -tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) -tailFS fs = mkFastStringInt (tail (unpackIntFS fs)) - -consFS :: Char -> FastString -> FastString -consFS c fs = mkFastStringInt (ord c : unpackIntFS fs) - -uniqueOfFS :: FastString -> Int# -uniqueOfFS (FastString u# _ _) = u# -uniqueOfFS (UnicodeStr u# _) = u# - -nilFS = mkFastString "" - -{- -GHC-related stuff: - -Internally, the compiler will maintain a fast string symbol -table, providing sharing and fast comparison. Creation of -new @FastString@s then covertly does a lookup, re-using the -@FastString@ if there was a hit. - -Caution: mkFastStringUnicode assumes that if the string is in the -table, it sits under the UnicodeStr constructor. Other mkFastString -variants analogously assume the FastString constructor. --} - -data FastStringTable = - FastStringTable - Int# - (MutableArray# RealWorld [FastString]) - -type FastStringTableVar = IORef FastStringTable - -string_table :: FastStringTableVar -string_table = - unsafePerformIO ( - stToIO (newSTArray (0::Int,hASH_TBL_SIZE) []) - >>= \ (STArray _ _ arr#) -> - newIORef (FastStringTable 0# arr#)) - -lookupTbl :: FastStringTable -> Int# -> IO [FastString] -lookupTbl (FastStringTable _ arr#) i# = - IO ( \ s# -> - readArray# arr# i# s#) - -updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO () -updTbl fs_table_var (FastStringTable uid# arr#) i# ls = - IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> - (# s2#, () #) }) >> - writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#) - -mkFastString# :: Addr# -> FastString -mkFastString# a# = - case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# } - -mkFastStringLen# :: Addr# -> Int# -> FastString -mkFastStringLen# a# len# = - unsafePerformIO ( - readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> - let - h = hashStr a# len# - in --- _trace ("hashed: "++show (I# h)) $ - lookupTbl ft h >>= \ lookup_result -> - case lookup_result of - [] -> - -- no match, add it to table by copying out the - -- the string into a ByteArray - -- _trace "empty bucket" $ - case copyPrefixStr a# (I# len#) of - BA barr# -> - let f_str = FastString uid# len# barr# in - updTbl string_table ft h [f_str] >> - ({- _trace ("new: " ++ show f_str) $ -} return f_str) - ls -> - -- non-empty `bucket', scan the list looking - -- entry with same length and compare byte by byte. - -- _trace ("non-empty bucket"++show ls) $ - case bucket_match ls len# a# of - Nothing -> - case copyPrefixStr a# (I# len#) of - BA barr# -> - let f_str = FastString uid# len# barr# in - updTbl string_table ft h (f_str:ls) >> - ( {- _trace ("new: " ++ show f_str) $ -} return f_str) - Just v -> {- _trace ("re-use: "++show v) $ -} return v) - where - bucket_match [] _ _ = Nothing - bucket_match (v@(FastString _ l# ba#):ls) len# a# = - if len# ==# l# && eqStrPrefix a# ba# l# then - Just v - else - bucket_match ls len# a# - bucket_match (UnicodeStr _ _ : ls) len# a# = - bucket_match ls len# a# - -mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString -mkFastSubStringBA# barr# start# len# = - unsafePerformIO ( - readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> - let - h = hashSubStrBA barr# start# len# - in --- _trace ("hashed(b): "++show (I# h)) $ - lookupTbl ft h >>= \ lookup_result -> - case lookup_result of - [] -> - -- no match, add it to table by copying out the - -- the string into a ByteArray - -- _trace "empty bucket(b)" $ - case copySubStrBA (BA barr#) (I# start#) (I# len#) of - BA ba# -> - let f_str = FastString uid# len# ba# in - updTbl string_table ft h [f_str] >> - -- _trace ("new(b): " ++ show f_str) $ - return f_str - ls -> - -- non-empty `bucket', scan the list looking - -- entry with same length and compare byte by byte. - -- _trace ("non-empty bucket(b)"++show ls) $ - case bucket_match ls start# len# barr# of - Nothing -> - case copySubStrBA (BA barr#) (I# start#) (I# len#) of - BA ba# -> - let f_str = FastString uid# len# ba# in - updTbl string_table ft h (f_str:ls) >> - -- _trace ("new(b): " ++ show f_str) $ - return f_str - Just v -> - -- _trace ("re-use(b): "++show v) $ - return v - ) - where - bucket_match [] _ _ _ = Nothing - bucket_match (v:ls) start# len# ba# = - case v of - FastString _ l# barr# -> - if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then - Just v - else - bucket_match ls start# len# ba# - UnicodeStr _ _ -> bucket_match ls start# len# ba# - -mkFastStringUnicode :: [Int] -> FastString -mkFastStringUnicode s = - unsafePerformIO ( - readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> - let - h = hashUnicode s - in --- _trace ("hashed(b): "++show (I# h)) $ - lookupTbl ft h >>= \ lookup_result -> - case lookup_result of - [] -> - -- no match, add it to table by copying out the - -- the string into a [Int] - let f_str = UnicodeStr uid# s in - updTbl string_table ft h [f_str] >> - -- _trace ("new(b): " ++ show f_str) $ - return f_str - ls -> - -- non-empty `bucket', scan the list looking - -- entry with same length and compare byte by byte. - -- _trace ("non-empty bucket(b)"++show ls) $ - case bucket_match ls of - Nothing -> - let f_str = UnicodeStr uid# s in - updTbl string_table ft h (f_str:ls) >> - -- _trace ("new(b): " ++ show f_str) $ - return f_str - Just v -> - -- _trace ("re-use(b): "++show v) $ - return v - ) - where - bucket_match [] = Nothing - bucket_match (v@(UnicodeStr _ s'):ls) = - if s' == s then Just v else bucket_match ls - bucket_match (FastString _ _ _ : ls) = bucket_match ls - -mkFastStringNarrow :: String -> FastString -mkFastStringNarrow str = - case packString str of { (I# len#, BA frozen#) -> - mkFastSubStringBA# frozen# 0# len# - } - {- 0-indexed array, len# == index to one beyond end of string, - i.e., (0,1) => empty string. -} - -mkFastString :: String -> FastString -mkFastString str = if all good str - then mkFastStringNarrow str - else mkFastStringUnicode (map ord str) - where - good c = c >= '\1' && c <= '\xFF' - -mkFastStringInt :: [Int] -> FastString -mkFastStringInt str = if all good str - then mkFastStringNarrow (map chr str) - else mkFastStringUnicode str - where - good c = c >= 1 && c <= 0xFF - -mkFastSubString :: Addr# -> Int -> Int -> FastString -mkFastSubString a# (I# start#) (I# len#) = - mkFastStringLen# (a# `plusAddr#` start#) len# - -hashStr :: Addr# -> Int# -> Int# - -- use the Addr to produce a hash value between 0 & m (inclusive) -hashStr a# len# = - case len# of - 0# -> 0# - 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# - 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# - _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# - where - c0 = indexCharOffAddr# a# 0# - c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#) - c2 = indexCharOffAddr# a# (len# -# 1#) -{- - c1 = indexCharOffAddr# a# 1# - c2 = indexCharOffAddr# a# 2# --} - -hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int# - -- use the byte array to produce a hash value between 0 & m (inclusive) -hashSubStrBA ba# start# len# = - case len# of - 0# -> 0# - 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# - 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# - _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# - where - c0 = indexCharArray# ba# (start# +# 0#) - c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#)) - c2 = indexCharArray# ba# (start# +# (len# -# 1#)) - --- c1 = indexCharArray# ba# 1# --- c2 = indexCharArray# ba# 2# - -hashUnicode :: [Int] -> Int# - -- use the Addr to produce a hash value between 0 & m (inclusive) -hashUnicode [] = 0# -hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE# -hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE# -hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# - where - I# len# = length s - I# c0 = s !! 0 - I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#)) - I# c2 = s !! (I# (len# -# 1#)) - -cmpFS :: FastString -> FastString -> Ordering -cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ - else compare s1 s2 -cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2) -cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2 -cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) = - if u1# ==# u2# then EQ else - let l# = if l1# <=# l2# then l1# else l2# in - unsafePerformIO ( - memcmp b1# b2# l# >>= \ (I# res) -> - return ( - if res <# 0# then LT - else if res ==# 0# then - if l1# ==# l2# then EQ - else if l1# <# l2# then LT else GT - else GT - )) - -foreign import ccall unsafe "memcmp" - memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int - --- ----------------------------------------------------------------------------- --- Outputting 'FastString's - -#if __GLASGOW_HASKELL__ >= 504 - --- this is our own version of hPutBuf for FastStrings, because in --- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA. --- The closest is hPutArray in Data.Array.IO, but that does some extra --- range checks that we want to avoid here. - -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) - -hPutFS handle (FastString _ l# ba#) - | l# ==# 0# = return () - | otherwise - = do wantWritableHandle "hPutFS" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - let count = I# l# - raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw w raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return () - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd stream old_buf - writeIORef ref flushed_buf - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=count } - flushWriteBuffer fd stream this_buf - return () - -#else - -hPutFS :: Handle -> FastString -> IO () -hPutFS handle (FastString _ l# ba#) - | l# ==# 0# = return () - | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#) - hPutBufBAFull handle mba (I# l#) - where - bot = error "hPutFS.ba" - -#endif - --- ONLY here for debugging the NCG (so -ddump-stix works for string --- literals); no idea if this is really necessary. JRS, 010131 -hPutFS handle (UnicodeStr _ is) - = hPutStr handle ("(UnicodeStr " ++ show is ++ ")") - --- ----------------------------------------------------------------------------- --- LitStrings, here for convenience only. - -type LitString = Ptr () --- ToDo: make it a Ptr when we don't have to support 4.08 any more - -mkLitString# :: Addr# -> LitString -mkLitString# a# = Ptr a# diff --git a/src/Language/Hi/Parser.hs b/src/Language/Hi/Parser.hs deleted file mode 100644 index 2d166e5..0000000 --- a/src/Language/Hi/Parser.hs +++ /dev/null @@ -1,720 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-name-shadowing #-} --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- - --- --- Based on $fptools/ghc/compiler/iface/BinIface.hs --- --- (c) The University of Glasgow 2002 --- --- Binary interface file support. --- - --- --- This provides the "Binary" instances for the Iface type such that we --- can parse binary representations of that type. i.e. from .hi files --- --- The main problem we have is that all the stuff we don't care about, --- we just want to read in to a string. So this has to be hand-hacked --- somewhat. --- --- The "Binary" class for hs-plugins only includes a get method. We --- don't do any writing. Saves us having to properly reconstruct the --- abstract syntax, which would pull in *way* too much of GHC. --- - - - -module Language.Hi.Parser ( readIface, module Language.Hi.Syntax ) where - -import Language.Hi.Syntax -import Language.Hi.Binary -import Language.Hi.FastString - -#include "../../../config.h" - --- --------------------------------------------------------------------------- --- how to get there from here - -readIface :: FilePath -> IO Iface -readIface hi_path = getBinFileWithDict hi_path - --- --------------------------------------------------------------------- --- All the Binary instances --- --- Reading a binary interface into ParsedIface --- --- We pull the trick of only reading up to the point we need --- - -instance Binary Iface where - get bh = do - version <- get bh :: IO String - build_tag <- get bh :: IO String -- 'way' flag - -#if __GLASGOW_HASKELL__ >= 604 - pkg_name <- get bh :: IO FastString - mod_name <- get bh :: IO FastString - _is_boot <- get bh :: IO Bool -#elif CABAL == 1 && __GLASGOW_HASKELL__ == 603 - mod_name <- get bh :: IO FastString - let pkg_name = mkFastString "unknown" -#else /* <= 622 */ - mod_name <- get bh :: IO FastString - pkg_name <- get bh :: IO FastString -#endif - mod_vers <- get bh :: IO Version - orphan <- get bh :: IO Bool - deps <- get bh :: IO Dependencies - - get bh :: IO (Bin Int) -- fake a lazyGet for [Usage] - usages <- get bh :: IO [Usage] - - exports <- get bh :: IO [IfaceExport] - --- (exp_vers :: Version) <- get bh --- (fixities :: [(OccName,Fixity)]) <- get bh --- (deprecs :: [IfaceDeprec]) <- get bh - --- (decls :: [(Version,IfaceDecl)])<- get bh - --- (insts :: [IfaceInst]) <- get bh --- (rules :: [IfaceRule]) <- get bh --- (rule_vers :: Version) <- get bh - - return $ Iface { - mi_package = unpackFS pkg_name, - mi_module = unpackFS mod_name, - mi_deps = deps , - mi_usages = usages, - mi_exports = exports {-,-} - --- mi_mod_vers = mod_vers, --- mi_boot = False, -- .hi files are never .hi-boot files! --- mi_orphan = orphan, --- mi_usages = usages, --- mi_exports = exports, --- mi_exp_vers = exp_vers, --- mi_fixities = fixities, --- mi_deprecs = deprecs, --- mi_decls = decls, --- mi_insts = insts, --- mi_rules = rules, --- mi_rule_vers = rule_vers - } - ------------------------------------------------------------------------- --- --- Types from: Iface.hs, HscTypes --- - --- fake a lazyGet -instance Binary Dependencies where - get bh = do get bh :: IO (Bin Int) -- really a BinPtr Int - ms <- get bh :: IO [(FastString,Bool)] - ps <- get bh :: IO [FastString] - _ <- get bh :: IO [FastString] -- !!orphans - return Deps { dep_mods = map unpackFS $! map fst ms, - dep_pkgs = map unpackFS ps {-,-} - } - ------------------------------------------------------------------------- --- Usages ------------------------------------------------------------------------- - -instance Binary OccName where - get bh = do aa <- get bh :: IO NameSpace - ab <- get bh :: IO FastString - return $ OccName aa (unpackFS ab) - -instance Binary NameSpace where - get bh = do h <- getByte bh - case h of - 0 -> return VarName - 1 -> return DataName - 2 -> return TvName - _ -> return TcClsName - -instance Binary Usage where - get bh = do (nm :: FastString) <- get bh - (mod :: Version) <- get bh - (exps :: Maybe Version) <- get bh - (ents :: [(OccName,Version)]) <- get bh - (rules :: Version) <- get bh - return $ Usage {usg_name = (unpackFS nm), - usg_mod = mod, - usg_exports = exps, - usg_entities = ents, - usg_rules = rules } - ------------------------------------------------------------------------- --- Exports - -instance (Binary name) => Binary (GenAvailInfo name) where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: name) <- get bh - return $ Avail aa - _ -> do (ab :: name) <- get bh - (ac :: [name]) <- get bh - return $ AvailTC ab ac - -{- -instance Binary a => Binary (Deprecs a) where - get bh = do - h <- getByte bh - case h of - 0 -> return Deprecs - 1 -> do (aa :: FastString) <- get bh - return Deprecs - _ -> do (ab :: a) <- get bh - return Deprecs --} - -------------------------------------------------------------------------- --- Types from: BasicTypes -------------------------------------------------------------------------- - -{- -instance Binary Activation where - get bh = do - h <- getByte bh - case h of - 0 -> return Activation - 1 -> return Activation - 2 -> do (aa :: Int) <- get bh ; return Activation - _ -> do (ab :: Int) <- get bh ; return Activation - -instance Binary StrictnessMark where - get bh = do - h <- getByte bh - case h of - 0 -> return StrictnessMark - 1 -> return StrictnessMark - _ -> return StrictnessMark - -instance Binary Boxity where - get bh = do - h <- getByte bh - case h of - 0 -> return Boxity - _ -> return Boxity - -instance Binary TupCon where - get bh = do - (ab :: Boxity) <- get bh - (ac :: Arity) <- get bh - return TupCon - -instance Binary RecFlag where - get bh = do - h <- getByte bh - case h of - 0 -> return RecFlag - _ -> return RecFlag - -instance Binary DefMeth where - get bh = do - h <- getByte bh - case h of - 0 -> return DefMeth - 1 -> return DefMeth - _ -> return DefMeth - -instance Binary FixityDirection where - get bh = do - h <- getByte bh - case h of - 0 -> return FixityDirection - 1 -> return FixityDirection - _ -> return FixityDirection - -instance Binary Fixity where - get bh = do - (aa :: Int) <- get bh - (ab :: FixityDirection) <- get bh - return Fixity - -instance (Binary name) => Binary (IPName name) where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: name) <- get bh ; return IPName - _ -> do (ab :: name) <- get bh ; return IPName - -------------------------------------------------------------------------- --- Types from: basicTypes/NewDemand -------------------------------------------------------------------------- - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - get bh = do (ds :: [Demand]) <- get bh - (dr :: DmdResult) <- get bh - return DmdType - -instance Binary Demand where - get bh = do - h <- getByte bh - case h of - 0 -> return Demand - 1 -> return Demand - 2 -> do (aa :: Demand) <- get bh ; return Demand - 3 -> do (ab :: Demands) <- get bh ; return Demand - 4 -> do (ac :: Demands) <- get bh ; return Demand - 5 -> do (ad :: Demand) <- get bh ; return Demand - _ -> return Demand - -instance Binary Demands where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: Demand) <- get bh - return Demands - _ -> do (ab :: [Demand]) <- get bh - return Demands - -instance Binary DmdResult where - get bh = do - h <- getByte bh - case h of - 0 -> return DmdResult - 1 -> return DmdResult - _ -> return DmdResult - -instance Binary StrictSig where - get bh = do (aa :: DmdType) <- get bh ; return StrictSig --} - -------------------------------------------------------------------------- --- Types from: CostCentre, from profiling/CostCentre.lhs -------------------------------------------------------------------------- - -{- -instance Binary IsCafCC where - get bh = do - h <- getByte bh - case h of - 0 -> return IsCafCC - _ -> return IsCafCC - -instance Binary IsDupdCC where - get bh = do - h <- getByte bh - case h of - 0 -> return IsDupdCC - _ -> return IsDupdCC - -instance Binary CostCentre where - get bh = do - h <- getByte bh - case h of - 0 -> do return CostCentre - 1 -> do (aa :: CcName) <- get bh - (ab :: ModuleName) <- get bh - (ac :: IsDupdCC) <- get bh - (ad :: IsCafCC) <- get bh - return CostCentre - _ -> do (ae :: ModuleName) <- get bh - return CostCentre --} - -------------------------------------------------------------------------- --- IfaceTypes and friends, from IfaceType.lhs -------------------------------------------------------------------------- - -{- -instance Binary IfaceExtName where - get bh = do - h <- getByte bh - case h of - 0 -> do (mod :: ModuleName) <- get bh - (occ :: OccName) <- get bh - return IfaceExtName - 1 -> do (mod :: ModuleName) <- get bh - (occ :: OccName) <- get bh - (vers :: Version) <- get bh - return IfaceExtName - _ -> do (occ :: OccName) <- get bh - return IfaceExtName - -instance Binary IfaceBndr where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: IfaceIdBndr) <- get bh ; return IfaceBndr - _ -> do (ab :: IfaceTvBndr) <- get bh ; return IfaceBndr - -instance Binary Kind where - get bh = do - h <- getByte bh - case h of - 0 -> return Kind - 1 -> return Kind - 2 -> return Kind - 3 -> return Kind - 4 -> return Kind - _ -> do (k1 :: Kind) <- get bh - (k2 :: Kind) <- get bh - return Kind - -instance Binary IfaceType where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: IfaceTvBndr) <- get bh - (ab :: IfaceType) <- get bh - return IfaceType - 1 -> do (ad :: OccName) <- get bh - return IfaceType - 2 -> do (ae :: IfaceType) <- get bh - (af :: IfaceType) <- get bh - return IfaceType - 3 -> do (ag :: IfaceType) <- get bh - (ah :: IfaceType) <- get bh - return IfaceType - 5 -> do (ap :: IfacePredType) <- get bh - return IfaceType - - -- Now the special cases for TyConApp - 6 -> return IfaceType - 7 -> return IfaceType - 8 -> return IfaceType - 9 -> do (ty :: IfaceType) <- get bh - return IfaceType - 10 -> return IfaceType - 11 -> do (t1 :: IfaceType) <- get bh - (t2 :: IfaceType) <- get bh - return IfaceType - 12 -> do (tc :: IfaceExtName) <- get bh - (tys :: [IfaceType]) <- get bh - return IfaceType - _ -> do (tc :: IfaceTyCon) <- get bh - (tys :: [IfaceType]) <- get bh - return IfaceType - -instance Binary IfaceTyCon where - get bh = do - h <- getByte bh - case h of - 1 -> return IfaceTyCon - 2 -> return IfaceTyCon - _ -> do (bx :: Boxity) <- get bh - (ar :: Arity) <- get bh - return IfaceTyCon - -instance Binary IfacePredType where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: IfaceExtName) <- get bh - (ab :: [IfaceType]) <- get bh - return IfacePredType - _ -> do (ac :: (IPName OccName)) <- get bh - (ad :: IfaceType) <- get bh - return IfacePredType - -instance Binary IfaceExpr where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: OccName) <- get bh - return IfaceExpr - 1 -> do (ab :: IfaceType) <- get bh - return IfaceExpr - 2 -> do (ac :: Boxity) <- get bh - (ad :: [IfaceExpr]) <- get bh - return IfaceExpr - 3 -> do (ae :: IfaceBndr) <- get bh - (af :: IfaceExpr) <- get bh - return IfaceExpr - 4 -> do (ag :: IfaceExpr) <- get bh - (ah :: IfaceExpr) <- get bh - return IfaceExpr - 5 -> do (ai :: IfaceExpr) <- get bh - (aj :: OccName) <- get bh - (ak :: [IfaceAlt]) <- get bh - return IfaceExpr - 6 -> do (al :: IfaceBinding) <- get bh - (am :: IfaceExpr) <- get bh - return IfaceExpr - 7 -> do (an :: IfaceNote) <- get bh - (ao :: IfaceExpr) <- get bh - return IfaceExpr - 8 -> do (ap :: Literal) <- get bh - return IfaceExpr - 9 -> do (as :: ForeignCall) <- get bh - (at :: IfaceType) <- get bh - return IfaceExpr - _ -> do (aa :: IfaceExtName) <- get bh - return IfaceExpr - -instance Binary IfaceConAlt where - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceConAlt - 1 -> do (aa :: OccName) <- get bh - return IfaceConAlt - 2 -> do (ab :: Boxity) <- get bh - return IfaceConAlt - _ -> do (ac :: Literal) <- get bh - return IfaceConAlt - -instance Binary IfaceBinding where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: IfaceIdBndr) <- get bh - (ab :: IfaceExpr) <- get bh - return IfaceBinding - _ -> do (ac :: [(IfaceIdBndr,IfaceExpr)]) <- get bh - return IfaceBinding - -instance Binary IfaceIdInfo where - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceIdInfo - _ -> do (info :: [IfaceInfoItem]) <- lazyGet bh - return IfaceIdInfo - -instance Binary IfaceInfoItem where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: Arity) <- get bh - return IfaceInfoItem - 1 -> do (ab :: StrictSig) <- get bh - return IfaceInfoItem - 2 -> do (ac :: Activation) <- get bh - (ad :: IfaceExpr) <- get bh - return IfaceInfoItem - 3 -> return IfaceInfoItem - _ -> do (ae :: IfaceExtName) <- get bh - (af :: Arity) <- get bh - return IfaceInfoItem - -instance Binary IfaceNote where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: CostCentre) <- get bh - return IfaceNote - 1 -> do (ab :: IfaceType ) <- get bh - return IfaceNote - 2 -> return IfaceNote - 3 -> return IfaceNote - _ -> do (ac :: String) <- get bh - return IfaceNote - -instance Binary IfaceDecl where - get bh = do - h <- getByte bh - case h of - 0 -> do - (name :: OccName) <- get bh - (ty :: IfaceType) <- get bh - (idinfo :: IfaceIdInfo) <- get bh - return IfaceDecl - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do - (a1 :: IfaceContext) <- get bh - (a2 :: OccName) <- get bh - (a3 :: [IfaceTvBndr]) <- get bh - (a4 :: IfaceConDecls) <- get bh - (a5 :: RecFlag) <- get bh - (a6 :: ArgVrcs) <- get bh - (a7 :: Bool) <- get bh - return IfaceDecl - 3 -> do - (aq :: OccName) <- get bh - (ar :: [IfaceTvBndr]) <- get bh - (as :: ArgVrcs) <- get bh - (at :: IfaceType) <- get bh - return IfaceDecl - _ -> do - (a1 :: IfaceContext) <- get bh - (a2 :: OccName) <- get bh - (a3 :: [IfaceTvBndr]) <- get bh - (a4 :: [FunDep OccName])<- get bh - (a5 :: [IfaceClassOp]) <- get bh - (a6 :: RecFlag) <- get bh - (a7 :: ArgVrcs) <- get bh - return IfaceDecl - -instance Binary IfaceInst where - get bh = do - (ty :: IfaceType) <- get bh - (dfun :: OccName) <- get bh - return IfaceInst - -instance Binary IfaceConDecls where - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceConDecls - 1 -> do (aa :: [IfaceConDecl]) <- get bh - return IfaceConDecls - _ -> do (aa :: IfaceConDecl) <- get bh - return IfaceConDecls - -instance Binary IfaceConDecl where - get bh = do - (a1 :: OccName) <- get bh - (a2 :: [IfaceTvBndr]) <- get bh - (a3 :: IfaceContext) <- get bh - (a4 :: [IfaceType]) <- get bh - (a5 :: [StrictnessMark])<- get bh - (a6 :: [OccName]) <- get bh - return IfaceConDecl - -instance Binary IfaceClassOp where - get bh = do - (n :: OccName) <- get bh - (def :: DefMeth) <- get bh - (ty :: IfaceType) <- get bh - return IfaceClassOp - -instance Binary IfaceRule where - get bh = do - (a1 :: RuleName) <- get bh - (a2 :: Activation) <- get bh - (a3 :: [IfaceBndr]) <- get bh - (a4 :: IfaceExtName) <- get bh - (a5 :: [IfaceExpr]) <- get bh - (a6 :: IfaceExpr) <- get bh - return IfaceRule - --} - ------------------------------------------------------------------------- --- from Literal ------------------------------------------------------------------------- - -{- -instance Binary Literal where - get bh = do - h <- getByte bh - case h of - 0 -> do - (aa :: Char) <- get bh - return Literal - 1 -> do - (ab :: FastString) <- get bh - return Literal - 2 -> do return Literal - 3 -> do - (ad :: Integer) <- get bh - return Literal - 4 -> do - (ae :: Integer) <- get bh - return Literal - 5 -> do - (af :: Integer) <- get bh - return Literal - 6 -> do - (ag :: Integer) <- get bh - return Literal - 7 -> do - (ah :: Rational) <- get bh - return Literal - 8 -> do - (ai :: Rational) <- get bh - return Literal - 9 -> do - (aj :: FastString) <- get bh - (mb :: Maybe Int) <- get bh - return Literal - _ -> return Literal -- ? - --} - ------------------------------------------------------------------------- --- prelude/ForeignCall.lhs ------------------------------------------------------------------------- - -{- -instance Binary ForeignCall where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: CCallSpec) <- get bh - return ForeignCall - _ -> do (ab :: DNCallSpec) <- get bh - return ForeignCall - -instance Binary Safety where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: Bool) <- get bh - return Safety - _ -> return Safety - -instance Binary CExportSpec where - get bh = do - (aa :: CLabelString) <- get bh - (ab :: CCallConv) <- get bh - return CExportSpec - -instance Binary CCallSpec where - get bh = do - (aa :: CCallTarget) <- get bh - (ab :: CCallConv) <- get bh - (ac :: Safety) <- get bh - return CCallSpec - -instance Binary CCallTarget where - get bh = do - h <- getByte bh - case h of - 0 -> do (aa :: CLabelString) <- get bh - return CCallTarget - _ -> return CCallTarget - -instance Binary CCallConv where - get bh = do - h <- getByte bh - case h of - 0 -> return CCallConv - _ -> return CCallConv - -instance Binary DNCallSpec where - get bh = do - (isStatic :: Bool) <- get bh - (kind :: DNKind) <- get bh - (ass :: String) <- get bh - (nm :: String) <- get bh - return DNCallSpec - -instance Binary DNKind where - get bh = do - h <- getByte bh - case h of - _ -> return DNKind - -instance Binary DNType where - get bh = do - h <- getByte bh - case h of - _ -> return DNType - --} diff --git a/src/Language/Hi/PrimPacked.hs b/src/Language/Hi/PrimPacked.hs deleted file mode 100644 index 0b13c0b..0000000 --- a/src/Language/Hi/PrimPacked.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} - -{-# OPTIONS -#include "hschooks.h" #-} - --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- --- Based on $fptools/ghc/compiler/utils/PrimPacked.lhs --- --- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 --- --- --- Basic ops on packed representations --- --- Some basic operations for working on packed representations of series --- of bytes (character strings). Used by the interface lexer input --- subsystem, mostly. - -{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} - -module Language.Hi.PrimPacked ( - Ptr(..), nullPtr, plusAddr#, - BA(..), - packString, -- :: String -> (Int, BA) - unpackNBytesBA, -- :: BA -> Int -> [Char] - strLength, -- :: Ptr CChar -> Int - copyPrefixStr, -- :: Addr# -> Int -> BA - copySubStrBA, -- :: BA -> Int -> Int -> BA - eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool - eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool - ) where - -import Foreign -import GHC.Exts -import GHC.ST - --- Wrapper types for bytearrays - -data BA = BA ByteArray# -data MBA s = MBA (MutableByteArray# s) - -packString :: String -> (Int, BA) -packString str = (l, arr) - where - l@(I# length#) = length str - - arr = runST (do - ch_array <- new_ps_array length# - -- fill in packed string from "str" - fill_in ch_array 0# str - -- freeze the puppy: - freeze_ps_array ch_array length# - ) - - fill_in :: MBA s -> Int# -> [Char] -> ST s () - fill_in arr_in# idx [] = - return () - fill_in arr_in# idx (C# c : cs) = - write_ps_array arr_in# idx c >> - fill_in arr_in# (idx +# 1#) cs - --- Unpacking a string - -unpackNBytesBA :: BA -> Int -> [Char] -unpackNBytesBA (BA bytes) (I# len) - = unpack 0# - where - unpack nh - | nh >=# len = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharArray# bytes nh - --- Copying a char string prefix into a byte array. - -copyPrefixStr :: Addr# -> Int -> BA -copyPrefixStr a# len@(I# length#) = copy' length# - where - copy' length# = runST (do - {- allocate an array that will hold the string - -} - ch_array <- new_ps_array length# - {- Revert back to Haskell-only solution for the moment. - _ccall_ memcpy ch_array (A# a) len >>= \ () -> - write_ps_array ch_array length# (chr# 0#) >> - -} - -- fill in packed string from "addr" - fill_in ch_array 0# - -- freeze the puppy: - freeze_ps_array ch_array length# - ) - - fill_in :: MBA s -> Int# -> ST s () - fill_in arr_in# idx - | idx ==# length# - = return () - | otherwise - = case (indexCharOffAddr# a# idx) of { ch -> - write_ps_array arr_in# idx ch >> - fill_in arr_in# (idx +# 1#) } - --- Copying out a substring, assume a 0-indexed string: --- (and positive lengths, thank you). - -copySubStrBA :: BA -> Int -> Int -> BA -copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba - where - ba = runST (do - -- allocate an array that will hold the string - ch_array <- new_ps_array length# - -- fill in packed string from "addr" - fill_in ch_array 0# - -- freeze the puppy: - freeze_ps_array ch_array length# - ) - - fill_in :: MBA s -> Int# -> ST s () - fill_in arr_in# idx - | idx ==# length# - = return () - | otherwise - = case (indexCharArray# barr# (start# +# idx)) of { ch -> - write_ps_array arr_in# idx ch >> - fill_in arr_in# (idx +# 1#) } - --- (Very :-) ``Specialised'' versions of some CharArray things... --- [Copied from PackBase; no real reason -- UGH] - -new_ps_array :: Int# -> ST s (MBA s) -write_ps_array :: MBA s -> Int# -> Char# -> ST s () -freeze_ps_array :: MBA s -> Int# -> ST s BA - -#if __GLASGOW_HASKELL__ < 411 -#define NEW_BYTE_ARRAY newCharArray# -#else -#define NEW_BYTE_ARRAY newByteArray# -#endif - -new_ps_array size = ST $ \ s -> - case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) -> - (# s2#, MBA barr# #) } - -write_ps_array (MBA barr#) n ch = ST $ \ s# -> - case writeCharArray# barr# n ch s# of { s2# -> - (# s2#, () #) } - --- same as unsafeFreezeByteArray -freeze_ps_array (MBA arr#) len# = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, BA frozen# #) } - --- Compare two equal-length strings for equality: - -eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool -eqStrPrefix a# barr# len# = - unsafePerformIO $ do - x <- memcmp_ba a# barr# (I# len#) - return (x == 0) - -eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool -eqStrPrefixBA b1# b2# start# len# = - unsafePerformIO $ do - x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#) - return (x == 0) - ------------------------------------------------------------------------- --- in hschooks --- - -foreign import ccall unsafe "plugin_strlen" - strLength :: Ptr () -> Int - -foreign import ccall unsafe "plugin_memcmp" - memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int - -foreign import ccall unsafe "plugin_memcmp_off" - memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int - diff --git a/src/Language/Hi/Syntax.hs b/src/Language/Hi/Syntax.hs deleted file mode 100644 index dbf64a6..0000000 --- a/src/Language/Hi/Syntax.hs +++ /dev/null @@ -1,360 +0,0 @@ --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- --- Based on code from $fptools/ghc/compiler/main/HscTypes.lhs --- (c) The University of Glasgow 2002 --- - -module Language.Hi.Syntax where - -import Language.Hi.FastString - -import Data.List ( intersperse ) - --- --------------------------------------------------------------------- --- An Iface, the representation of an .hi file. --- --- The abstract syntax that we don't need is blanked with a default --- type, however we must be careful in BinIface to still parse the --- correct number of bytes for each data type. This involves leaving the --- code alone, other than to add the types of the sub-constructors of --- the types we have blanked out (because they can't be inferred --- anymore). --- - -data Iface = Iface { - mi_package :: String, -- what package is this? - mi_module :: String, -- what module is this? - mi_deps :: Dependencies, - mi_usages :: [Usage], - mi_exports :: [IfaceExport] {-,-} - --- mi_decls :: [(Version,IfaceDecl)] {-,-} - --- mi_mod_vers :: !Version, --- mi_orphan :: !Bool, --- mi_boot :: !Bool, --- mi_exp_vers :: !Version, --- mi_fixities :: [(OccName,Fixity)], --- mi_deprecs :: [IfaceDeprec], --- mi_insts :: [IfaceInst], --- mi_rules :: [IfaceRule], --- mi_rule_vers :: !Version, - } - -emptyIface = Iface { - mi_package = undefined, - mi_module = undefined, - mi_deps = noDependencies, - mi_usages = undefined, - mi_exports = undefined - } - --- --------------------------------------------------------------------- --- pretty-print an interface --- -showIface :: Iface -> String -showIface (Iface { mi_package = p, mi_module = m, - mi_deps = deps, mi_usages = us }) = - "interface \"" ++ p ++ "\" " ++ m ++ - "\n" ++ pprDeps deps ++ - "\n" ++ (concat $ intersperse "\n" (map pprUsage us)) - -- "\n" ++ (concat $ intersperse "\n" (map pprExport es)) - -pprDeps :: Dependencies -> String -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs }) - = "module dependencies: " ++ (concat $ intersperse ", " mods) ++ - "\npackage dependencies: " ++ (concat $ intersperse ", " pkgs) - -pprUsage :: Usage -> String -pprUsage usage = hsep ["import", usg_name usage] - -pprExport :: IfaceExport -> String -pprExport (fsmod, items) - = hsep [ "export", unpackFS fsmod, hsep (map pp_avail items) ] - where - pp_avail :: GenAvailInfo OccName -> String - pp_avail (Avail nm) = ppr_occ nm - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = (ppr_occ n) ++ pp_export ns - | otherwise = (ppr_occ n) ++ "|" ++ pp_export (n':ns) - - pp_export [] = empty - pp_export names = "{" ++ (hsep (map ppr_occ names)) ++ "}" - - ppr_occ (OccName _ s) = s - --- --- TODO bring in the Pretty library --- -hsep = \ss -> concat (intersperse " " ss) -empty = "" - --- --------------------------------------------------------------------- --- --- Dependency info about modules and packages below this one --- in the import hierarchy. See TcRnTypes.ImportAvails for details. --- --- Invariant: the dependencies of a module M never includes M --- Invariant: the lists are unordered, with no duplicates --- --- The fields are: --- Home-package module dependencies --- External package dependencies --- Orphan modules (whether home or external pkg) - -data Dependencies = Deps { - dep_mods :: [ModuleName], - dep_pkgs :: [PackageName] {-,-} - } deriving (Show) - -noDependencies :: Dependencies -noDependencies = Deps [] [] - --- --- Type aliases need to have a real type so the parser can work out how --- to parse them. You have to find what these are by reading GHC. --- -type ModuleName = String {- was FastString -} -- Module -type PackageName = String {- was FastString -} -- Packages -type Version = Int -- BasicTypes -type EncodedFS = FastString -- FastString -type IfaceExport = (EncodedFS, [GenAvailInfo OccName]) -- HscTypes - -data GenAvailInfo name - = Avail name -- An ordinary identifier - | AvailTC name -- The name of the type or class - [name] -- The available pieces of type/class. - -- NB: If the type or class is itself - -- to be in scope, it must be in this list. - -- Thus, typically: AvailTC Eq [Eq, ==, /=] - deriving Show - -data OccName = OccName NameSpace String {- was EncodedFS -} - deriving Show - -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -data NameSpace = VarName -- variables, and "source" data constructors - | DataName -- "real" data constructors - | TvName -- tyvars - | TcClsName -- type constructors and classes - deriving (Eq, Show) - -data Usage - = Usage { usg_name :: ModuleName, -- Name of the module - usg_mod :: Version, -- Module version - usg_exports :: Maybe Version, -- Export-list version, if we depend on it - usg_entities :: [(OccName,Version)],-- Sorted by occurrence name - usg_rules :: Version -- Orphan-rules version (for non-orphan - -- modules this will always be initialVersion) - } deriving Show - ------------------------------------------------------------------------- --- TODO parsing type and decl information out of the .hi file --- complex data structure... --- - -{- -data IfaceExtName - = ExtPkg ModuleName OccName -- From an external package; no version # - -- Also used for wired-in things regardless - -- of whether they are home-pkg or not - - | HomePkg ModuleName OccName Version -- From another module in home package; - -- has version # - - | LocalTop OccName -- Top-level from the same module as - -- the enclosing IfaceDecl - - | LocalTopSub -- Same as LocalTop, but for a class method or constr - OccName -- Class-meth/constr name - OccName -- Parent class/datatype name - -- LocalTopSub is written into iface files as LocalTop; the parent - -- info is only used when computing version information in MkIface - -data IfaceTyCon -- Abbreviations for common tycons with known names - = IfaceTc IfaceExtName -- The common case - | IfaceIntTc | IfaceBoolTc | IfaceCharTc - | IfaceListTc | IfacePArrTc - | IfaceTupTc Boxity Arity - -type Arity = Int -- BasicTypes - -data Boxity - = Boxed - | Unboxed - -type IfaceContext = [IfacePredType] - -data IfacePredType -- NewTypes are handled as ordinary TyConApps - = IfaceClassP IfaceExtName [IfaceType] - | IfaceIParam (IPName OccName) IfaceType - -data IPName name - = Dupable name -- ?x: you can freely duplicate this implicit parameter - | Linear name -- %x: you must use the splitting function to duplicate it - deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map - -- (used in HscTypes.OrigIParamCache) - -data IfaceType - = IfaceTyVar OccName -- Type variable only, not tycon - | IfaceAppTy IfaceType IfaceType - | IfaceForAllTy IfaceTvBndr IfaceType - | IfacePredTy IfacePredType - | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceFunTy IfaceType IfaceType - -data IfaceBndr -- Local (non-top-level) binders - = IfaceIdBndr IfaceIdBndr - | IfaceTvBndr IfaceTvBndr - -type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local -type IfaceTvBndr = (OccName, IfaceKind) -type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it - -data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is - -data IfaceInfoItem - = HsArity Arity - | HsStrictness StrictSig - | HsUnfold Activation IfaceExpr - | HsNoCafRefs - | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo - -- for why we want arity here. - -- NB: we need IfaceExtName (not just OccName) because the worker - -- can simplify to a function in another module. --- NB: Specialisations and rules come in separately and are --- only later attached to the Id. Partial reason: some are orphans. - -newtype StrictSig = StrictSig DmdType - -data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifCtxt :: IfaceContext, -- Context - ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifCons :: IfaceConDecls, -- Includes new/data info - ifRec :: RecFlag, -- Recursive or not? - ifVrcs :: ArgVrcs, - ifGeneric :: Bool -- True <=> generic converter functions available - } -- We need this for imported data decls, since the - -- imported modules may have been compiled with - -- different flags to the current compilation unit - - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifVrcs :: ArgVrcs, - ifSynRhs :: IfaceType -- synonym expansion - } - - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep OccName], -- Functional dependencies - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... - } - - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET - ifExtName :: Maybe FastString } --} - ------------------------------------------------------------------------- --- --- all this stuff may be enabled if we ever want other information out --- - -{- -type ArgVrcs = [(Bool,Bool)] -- TyCon -type CLabelString = FastString -- CStrings -type CcName = EncodedFS -- CostCentre -type DeprecTxt = FastString -- BasicTypes -type FunDep a = ([a],[a]) -- Class -type IfaceAlt = (IfaceConAlt,[OccName],IfaceExpr) -- IfaceSyn -type IfaceContext = [IfacePredType] -- IfaceType -type IfaceDeprec = Deprecs [(OccName,DeprecTxt)] -- HscTypes -type IfaceIdBndr = (OccName, IfaceType) -- IfaceType -type IfaceKind = Kind -- IfaceType -type IfaceTvBndr = (OccName, IfaceKind) -- IfaceType -type RuleName = FastString -- CoreSyn - --- --- Empty definitions for the various types we need, but whose results we --- don't care about. --- --- 'data' types that have a parsing method associated with them --- This list corresponds to each instance in BinIface --- --- Try to keep this list ordered by the order they appear in BinIface --- -data Deprecs a = Deprecs -data Activation = Activation -data StrictnessMark = StrictnessMark -data Boxity = Boxity -data TupCon = TupCon -data RecFlag = RecFlag -data DefMeth = DefMeth -data FixityDirection = FixityDirection -data Fixity = Fixity -data DmdType = DmdType -data Demand = Demand -data Demands = Demands -data DmdResult = DmdResult -data StrictSig = StrictSig -data IsCafCC = IsCafCC -data IsDupdCC = IsDupdCC -data CostCentre = CostCentre -data IfaceExtName = IfaceExtName -data IfaceBndr = IfaceBndr -data Kind = Kind -data IfaceTyCon = IfaceTyCon -data IfacePredType = IfacePredType -data IfaceExpr = IfaceExpr -data IfaceConAlt = IfaceConAlt -data IfaceBinding = IfaceBinding -data IfaceIdInfo = IfaceIdInfo -data IfaceNoteItem = IfaceNoteItem -data IfaceInfoItem = IfaceInfoItem -data IfaceNote = IfaceNote -data IfaceInst = IfaceInst -data IfaceConDecls = IfaceConDecls -data IfaceConDecl = IfaceConDecl -data IfaceClassOp = IfaceClassOp -data IfaceRule = IfaceRule -data Literal = Literal -data ForeignCall = ForeignCall -data Safety = Safety -data CExportSpec = CExportSpec -data CCallSpec = CCallSpec -data CCallTarget = CCallTarget -data CCallConv = CCallConv -data DNCallSpec = DNCallSpec -data DNKind = DNKind -data DNType = DNType - --} diff --git a/src/Language/Hi/hschooks.c b/src/Language/Hi/hschooks.c deleted file mode 100644 index d2e4823..0000000 --- a/src/Language/Hi/hschooks.c +++ /dev/null @@ -1,38 +0,0 @@ -/* -These routines customise the error messages -for various bits of the RTS. They are linked -in instead of the defaults. -*/ - -#include - -/* For GHC 4.08, we are relying on the fact that RtsFlags has - * compatibile layout with the current version, because we're - * #including the current version of RtsFlags.h below. 4.08 didn't - * ship with its own RtsFlags.h, unfortunately. For later GHC - * versions, we #include the correct RtsFlags.h. - */ - -#include "Rts.h" -#include "RtsFlags.h" - -#include "HsFFI.h" - -HsInt -plugin_strlen( HsAddr a ) -{ - return (strlen((char *)a)); -} - -HsInt -plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ) -{ - return (memcmp((char *)a1, a2, len)); -} - -HsInt -plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ) -{ - return (memcmp((char *)a1 + i, a2, len)); -} - diff --git a/src/Language/Hi/hschooks.h b/src/Language/Hi/hschooks.h deleted file mode 100644 index a1b47bb..0000000 --- a/src/Language/Hi/hschooks.h +++ /dev/null @@ -1,13 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $ Id: hschooks.h,v 1.1.1.1 2004/05/24 09:35:39 dons Exp $ - * - * Hooks into the RTS from the compiler. - * - * -------------------------------------------------------------------------- */ - -#include "HsFFI.h" - -// Out-of-line string functions, see PrimPacked.lhs -HsInt plugin_strlen( HsAddr a ); -HsInt plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ); -HsInt plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ); diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs index 1243933..946b452 100644 --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -66,7 +66,15 @@ import System.Plugins.Utils import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore ) import System.Plugins.LoadTypes -import Language.Hi.Parser +-- import Language.Hi.Parser +import BinIface +import HscTypes +import Module (moduleName, moduleNameString) +import PackageConfig (packageIdString) +import HscMain (newHscEnv) +import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import Name ( Name, NamedThing(..) ) +import TcRnMonad (initTcRnIf) import Data.Dynamic ( fromDynamic, Dynamic ) import Data.Typeable ( Typeable ) @@ -85,6 +93,20 @@ import System.IO ( hFlush, stdout ) #endif import System.IO ( hClose ) +ifaceModuleName = moduleNameString . moduleName . mi_module + +readBinIface' :: FilePath -> IO ModIface +readBinIface' hi_path = do + -- kludgy as hell + e <- newHscEnv undefined + initTcRnIf 'r' e undefined undefined (readBinIface hi_path) + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames = map getName wiredInThings + ++ basicKnownKeyNames + + -- TODO need a loadPackage p package.conf :: IO () primitive -- @@ -138,10 +160,10 @@ load obj incpaths pkgconfs sym = do -- why is this the package name? #if DEBUG - putStr (' ':(decode $ mi_module hif)) >> hFlush stdout + putStr (' ':(decode $ ifaceModuleName hif)) >> hFlush stdout #endif - m' <- loadObject obj (Object (mi_module hif)) + m' <- loadObject obj . Object . ifaceModuleName $ hif let m = m' { iface = hif } resolveObjs (mapM_ unloadAll (m:moduleDeps)) @@ -366,7 +388,7 @@ reload m@(Module{path = p, iface = hi}) sym = do #if DEBUG putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout #endif - m_ <- loadObject p (Object $ mi_module hi) -- load object at path p + m_ <- loadObject p . Object . ifaceModuleName $ hi -- load object at path p let m' = m_ { iface = hi } resolveObjs (unloadAll m) @@ -408,7 +430,7 @@ loadFunction :: Module -- ^ The module the value is in -> String -- ^ Symbol name of value -> IO (Maybe a) -- ^ The value you want loadFunction (Module { iface = i }) valsym - = loadFunction_ (mi_module i) valsym + = loadFunction_ (ifaceModuleName i) valsym loadFunction_ :: String -> String @@ -487,7 +509,7 @@ loadObject' p ky k addModule k (emptyMod p) -- needs to Z-encode module name return (emptyMod p) - where emptyMod q = Module q (mkModid q) Vanilla emptyIface ky + where emptyMod q = Module q (mkModid q) Vanilla undefined ky -- -- load a single object. no dependencies. You should know what you're @@ -499,8 +521,8 @@ loadModule obj = do exists <- doesFileExist hifile if (not exists) then error $ "No .hi file found for "++show obj - else do hiface <- readIface hifile - loadObject obj (Object (mi_module hiface)) + else do hiface <- readBinIface' hifile + loadObject obj (Object (ifaceModuleName hiface)) -- -- | Load a generic .o file, good for loading C objects. @@ -542,7 +564,7 @@ loadShared str = do #endif maybe_errmsg <- withCString str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr - then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str))) + then return (Module str (mkModid str) Shared undefined (Package (mkModid str))) else do e <- peekCString maybe_errmsg panic $ "loadShared: couldn't load `"++str++"\' because "++e @@ -627,7 +649,7 @@ loadPackageWith p pkgconfs = do -- the modenv fm. We need a canonical form for the keys -- is basename -- good enough? -- -loadDepends :: FilePath -> [FilePath] -> IO (Iface,[Module]) +loadDepends :: FilePath -> [FilePath] -> IO (ModIface,[Module]) loadDepends obj incpaths = do let hifile = replaceSuffix obj hiSuf exists <- doesFileExist hifile @@ -636,13 +658,13 @@ loadDepends obj incpaths = do #if DEBUG putStrLn "No .hi file found." >> hFlush stdout #endif - return (emptyIface,[]) -- could be considered fatal + return (undefined,[]) -- could be considered fatal - else do hiface <- readIface hifile + else do hiface <- readBinIface' hifile let ds = mi_deps hiface -- remove ones that we've already loaded - ds' <- filterM loaded (dep_mods ds) + ds' <- filterM loaded . map (moduleNameString . fst) . dep_mods $ ds -- now, try to generate a path to the actual .o file -- fix up hierachical names @@ -662,7 +684,7 @@ loadDepends obj incpaths = do -- and find some packages to load, as well. let ps = dep_pkgs ds - ps' <- filterM loaded (nub ps) + ps' <- filterM loaded . map packageIdString . nub $ ps #if DEBUG when (not (null ps')) $ @@ -687,8 +709,8 @@ loadDepends obj incpaths = do -- getImports :: String -> IO [String] getImports m = do - hi <- readIface (m ++ hiSuf) - return $ dep_mods (mi_deps hi) + hi <- readBinIface' (m ++ hiSuf) + return . map (moduleNameString . fst) . dep_mods . mi_deps $ hi -- --------------------------------------------------------------------- -- C interface diff --git a/src/System/Plugins/LoadTypes.hs b/src/System/Plugins/LoadTypes.hs index daab96f..06fcd99 100644 --- a/src/System/Plugins/LoadTypes.hs +++ b/src/System/Plugins/LoadTypes.hs @@ -28,7 +28,9 @@ module System.Plugins.LoadTypes , ObjType (..) ) where -import Language.Hi.Parser +-- import Language.Hi.Parser + +import HscTypes data Key = Object String | Package String @@ -40,7 +42,7 @@ type PackageConf = FilePath data Module = Module { path :: !FilePath , mname :: !String , kind :: !ObjType - , iface :: Iface -- cache the iface + , iface :: ModIface -- cache the iface , key :: Key } diff --git a/testsuite/eval/eval_/Main.hs b/testsuite/eval/eval_/Main.hs index 91a0c46..18f10bf 100644 --- a/testsuite/eval/eval_/Main.hs +++ b/testsuite/eval/eval_/Main.hs @@ -2,7 +2,7 @@ import System.Eval.Haskell main = do i <- eval_ "Just (7 :: Int)" - ["Maybe"] + ["Data.Maybe"] ["-fglasgow-exts"] [] [] :: IO (Either [String] (Maybe (Maybe Int)))