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.
This commit is contained in:
parent
642bd3add6
commit
b80977561c
@ -5,12 +5,6 @@ License-file: LICENSE
|
|||||||
author: Don Stewart
|
author: Don Stewart
|
||||||
maintainer: dons@cse.unsw.edu.au
|
maintainer: dons@cse.unsw.edu.au
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Language.Hi.Binary,
|
|
||||||
Language.Hi.FastMutInt,
|
|
||||||
Language.Hi.FastString,
|
|
||||||
Language.Hi.Parser,
|
|
||||||
Language.Hi.PrimPacked,
|
|
||||||
Language.Hi.Syntax,
|
|
||||||
System.Eval,
|
System.Eval,
|
||||||
System.Eval.Haskell,
|
System.Eval.Haskell,
|
||||||
System.Eval.Utils,
|
System.Eval.Utils,
|
||||||
@ -27,10 +21,8 @@ exposed-modules:
|
|||||||
System.Plugins.Parser,
|
System.Plugins.Parser,
|
||||||
System.Plugins.Process,
|
System.Plugins.Process,
|
||||||
System.Plugins.Utils
|
System.Plugins.Utils
|
||||||
c-sources:
|
|
||||||
src/Language/Hi/hschooks.c
|
|
||||||
includes: Linker.h
|
includes: Linker.h
|
||||||
extensions: CPP, ForeignFunctionInterface
|
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
|
ghc-options: -Wall -O -fasm -funbox-strict-fields -fno-warn-missing-signatures
|
||||||
hs-source-dir: src
|
hs-source-dirs: src
|
||||||
|
@ -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
|
|
@ -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)
|
|
||||||
|
|
@ -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 #) } }
|
|
||||||
|
|
@ -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#
|
|
@ -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
|
|
||||||
|
|
||||||
-}
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
||||||
-}
|
|
@ -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 <string.h>
|
|
||||||
|
|
||||||
/* 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));
|
|
||||||
}
|
|
||||||
|
|
@ -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 );
|
|
@ -66,7 +66,15 @@ import System.Plugins.Utils
|
|||||||
import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
|
import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
|
||||||
import System.Plugins.LoadTypes
|
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.Dynamic ( fromDynamic, Dynamic )
|
||||||
import Data.Typeable ( Typeable )
|
import Data.Typeable ( Typeable )
|
||||||
@ -85,6 +93,20 @@ import System.IO ( hFlush, stdout )
|
|||||||
#endif
|
#endif
|
||||||
import System.IO ( hClose )
|
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
|
-- 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?
|
-- why is this the package name?
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr (' ':(decode $ mi_module hif)) >> hFlush stdout
|
putStr (' ':(decode $ ifaceModuleName hif)) >> hFlush stdout
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
m' <- loadObject obj (Object (mi_module hif))
|
m' <- loadObject obj . Object . ifaceModuleName $ hif
|
||||||
let m = m' { iface = hif }
|
let m = m' { iface = hif }
|
||||||
resolveObjs (mapM_ unloadAll (m:moduleDeps))
|
resolveObjs (mapM_ unloadAll (m:moduleDeps))
|
||||||
|
|
||||||
@ -366,7 +388,7 @@ reload m@(Module{path = p, iface = hi}) sym = do
|
|||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
|
putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
|
||||||
#endif
|
#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 }
|
let m' = m_ { iface = hi }
|
||||||
|
|
||||||
resolveObjs (unloadAll m)
|
resolveObjs (unloadAll m)
|
||||||
@ -408,7 +430,7 @@ loadFunction :: Module -- ^ The module the value is in
|
|||||||
-> String -- ^ Symbol name of value
|
-> String -- ^ Symbol name of value
|
||||||
-> IO (Maybe a) -- ^ The value you want
|
-> IO (Maybe a) -- ^ The value you want
|
||||||
loadFunction (Module { iface = i }) valsym
|
loadFunction (Module { iface = i }) valsym
|
||||||
= loadFunction_ (mi_module i) valsym
|
= loadFunction_ (ifaceModuleName i) valsym
|
||||||
|
|
||||||
loadFunction_ :: String
|
loadFunction_ :: String
|
||||||
-> String
|
-> String
|
||||||
@ -487,7 +509,7 @@ loadObject' p ky k
|
|||||||
addModule k (emptyMod p) -- needs to Z-encode module name
|
addModule k (emptyMod p) -- needs to Z-encode module name
|
||||||
return (emptyMod p)
|
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
|
-- load a single object. no dependencies. You should know what you're
|
||||||
@ -499,8 +521,8 @@ loadModule obj = do
|
|||||||
exists <- doesFileExist hifile
|
exists <- doesFileExist hifile
|
||||||
if (not exists)
|
if (not exists)
|
||||||
then error $ "No .hi file found for "++show obj
|
then error $ "No .hi file found for "++show obj
|
||||||
else do hiface <- readIface hifile
|
else do hiface <- readBinIface' hifile
|
||||||
loadObject obj (Object (mi_module hiface))
|
loadObject obj (Object (ifaceModuleName hiface))
|
||||||
|
|
||||||
--
|
--
|
||||||
-- | Load a generic .o file, good for loading C objects.
|
-- | Load a generic .o file, good for loading C objects.
|
||||||
@ -542,7 +564,7 @@ loadShared str = do
|
|||||||
#endif
|
#endif
|
||||||
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
|
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
|
||||||
if maybe_errmsg == nullPtr
|
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
|
else do e <- peekCString maybe_errmsg
|
||||||
panic $ "loadShared: couldn't load `"++str++"\' because "++e
|
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
|
-- the modenv fm. We need a canonical form for the keys -- is basename
|
||||||
-- good enough?
|
-- good enough?
|
||||||
--
|
--
|
||||||
loadDepends :: FilePath -> [FilePath] -> IO (Iface,[Module])
|
loadDepends :: FilePath -> [FilePath] -> IO (ModIface,[Module])
|
||||||
loadDepends obj incpaths = do
|
loadDepends obj incpaths = do
|
||||||
let hifile = replaceSuffix obj hiSuf
|
let hifile = replaceSuffix obj hiSuf
|
||||||
exists <- doesFileExist hifile
|
exists <- doesFileExist hifile
|
||||||
@ -636,13 +658,13 @@ loadDepends obj incpaths = do
|
|||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn "No .hi file found." >> hFlush stdout
|
putStrLn "No .hi file found." >> hFlush stdout
|
||||||
#endif
|
#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
|
let ds = mi_deps hiface
|
||||||
|
|
||||||
-- remove ones that we've already loaded
|
-- 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
|
-- now, try to generate a path to the actual .o file
|
||||||
-- fix up hierachical names
|
-- fix up hierachical names
|
||||||
@ -662,7 +684,7 @@ loadDepends obj incpaths = do
|
|||||||
|
|
||||||
-- and find some packages to load, as well.
|
-- and find some packages to load, as well.
|
||||||
let ps = dep_pkgs ds
|
let ps = dep_pkgs ds
|
||||||
ps' <- filterM loaded (nub ps)
|
ps' <- filterM loaded . map packageIdString . nub $ ps
|
||||||
|
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
when (not (null ps')) $
|
when (not (null ps')) $
|
||||||
@ -687,8 +709,8 @@ loadDepends obj incpaths = do
|
|||||||
--
|
--
|
||||||
getImports :: String -> IO [String]
|
getImports :: String -> IO [String]
|
||||||
getImports m = do
|
getImports m = do
|
||||||
hi <- readIface (m ++ hiSuf)
|
hi <- readBinIface' (m ++ hiSuf)
|
||||||
return $ dep_mods (mi_deps hi)
|
return . map (moduleNameString . fst) . dep_mods . mi_deps $ hi
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
-- ---------------------------------------------------------------------
|
||||||
-- C interface
|
-- C interface
|
||||||
|
@ -28,7 +28,9 @@ module System.Plugins.LoadTypes
|
|||||||
, ObjType (..)
|
, ObjType (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.Hi.Parser
|
-- import Language.Hi.Parser
|
||||||
|
|
||||||
|
import HscTypes
|
||||||
|
|
||||||
data Key = Object String | Package String
|
data Key = Object String | Package String
|
||||||
|
|
||||||
@ -40,7 +42,7 @@ type PackageConf = FilePath
|
|||||||
data Module = Module { path :: !FilePath
|
data Module = Module { path :: !FilePath
|
||||||
, mname :: !String
|
, mname :: !String
|
||||||
, kind :: !ObjType
|
, kind :: !ObjType
|
||||||
, iface :: Iface -- cache the iface
|
, iface :: ModIface -- cache the iface
|
||||||
, key :: Key
|
, key :: Key
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
import System.Eval.Haskell
|
import System.Eval.Haskell
|
||||||
|
|
||||||
main = do i <- eval_ "Just (7 :: Int)"
|
main = do i <- eval_ "Just (7 :: Int)"
|
||||||
["Maybe"]
|
["Data.Maybe"]
|
||||||
["-fglasgow-exts"]
|
["-fglasgow-exts"]
|
||||||
[]
|
[]
|
||||||
[] :: IO (Either [String] (Maybe (Maybe Int)))
|
[] :: IO (Either [String] (Maybe (Maybe Int)))
|
||||||
|
Loading…
x
Reference in New Issue
Block a user