wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove Language.Hi in favour of using the ghc-api directly, fix to work with GHC 6.8.2.

Browse Source 
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:
cgibbard 2007-12-16 05:28:44 +00:00
parent 642bd3add6
commit b80977561c
13 changed files with 45 additions and 2560 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
plugins.cabal
View File

@ -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

36
plugins.cabal.hsx
View File

@ -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

581
src/Language/Hi/Binary.hs
View File

@ -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)

81
src/Language/Hi/FastMutInt.hs
View File

@ -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 #) } }

508
src/Language/Hi/FastString.hs
View File

@ -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#

720
src/Language/Hi/Parser.hs
View File

@ -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
-}

194
src/Language/Hi/PrimPacked.hs
View File

@ -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

360
src/Language/Hi/Syntax.hs
View File

@ -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
-}

38
src/Language/Hi/hschooks.c
View File

@ -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));
}

13
src/Language/Hi/hschooks.h
View File

@ -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 );

54
src/System/Plugins/Load.hs
View File

@ -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

6
src/System/Plugins/LoadTypes.hs
View File

@ -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
testsuite/eval/eval_/Main.hs
View File

@ -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)))