Add (a) CoreM monad, (b) new Annotations feature

This patch, written by Max Bolingbroke,  does two things

1.  It adds a new CoreM monad (defined in simplCore/CoreMonad),
    which is used as the top-level monad for all the Core-to-Core
    transformations (starting at SimplCore).  It supports
       * I/O (for debug printing)
       * Unique supply
       * Statistics gathering
       * Access to the HscEnv, RuleBase, Annotations, Module
    The patch therefore refactors the top "skin" of every Core-to-Core
    pass, but does not change their functionality.

2.  It adds a completely new facility to GHC: Core "annotations".
    The idea is that you can say
       {#- ANN foo (Just "Hello") #-}
    which adds the annotation (Just "Hello") to the top level function
    foo.  These annotations can be looked up in any Core-to-Core pass,
    and are persisted into interface files.  (Hence a Core-to-Core pass
    can also query the annotations of imported things.)  Furthermore,
    a Core-to-Core pass can add new annotations (eg strictness info)
    of its own, which can be queried by importing modules.

The design of the annotation system is somewhat in flux.  It's
designed to work with the (upcoming) dynamic plug-ins mechanism,
but is meanwhile independently useful.

Do not merge to 6.10!  

1 files changed, 174 insertions, 0 deletions

diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs
new file mode 100644
index 0000000000..9a0e4c5d17
--- /dev/null
+++ b/compiler/utils/Serialized.hs
@@ -0,0 +1,174 @@
+--
+-- (c) The University of Glasgow 2002-2006
+--
+-- Serialized values
+
+{-# LANGUAGE ScopedTypeVariables #-}
+module Serialized (
+    -- * Main Serialized data type
+    Serialized,
+    seqSerialized,
+    
+    -- * Going into and out of 'Serialized'
+    toSerialized, fromSerialized,
+    
+    -- * Handy serialization functions
+    serializeWithData, deserializeWithData,
+  ) where
+
+import Binary
+import Outputable
+import FastString
+import Util
+
+import Data.Bits
+import Data.Word        ( Word8 )
+
+#if __GLASGOW_HASKELL__ > 609
+import Data.Data
+#else
+import Data.Generics
+#endif
+import Data.Typeable
+
+
+-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
+data Serialized = Serialized TypeRep [Word8]
+
+instance Outputable Serialized where
+    ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
+
+instance Binary Serialized where
+    put_ bh (Serialized the_type bytes) = do
+        put_ bh the_type
+        put_ bh bytes
+    get bh = do
+        the_type <- get bh
+        bytes <- get bh
+        return (Serialized the_type bytes)
+
+-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
+toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized
+toSerialized serialize what = Serialized (typeOf what) (serialize what)
+
+-- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
+-- Otherwise return @Nothing@.
+fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
+fromSerialized deserialize (Serialized the_type bytes)
+  | the_type == typeOf (undefined :: a) = Just (deserialize bytes)
+  | otherwise                           = Nothing
+
+-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
+seqSerialized :: Serialized -> ()
+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
+
+
+-- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
+serializeWithData :: Data a => a -> [Word8]
+serializeWithData what = serializeWithData' what []
+
+serializeWithData' :: Data a => a -> [Word8] -> [Word8]
+serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
+                                       (\x -> (serializeConstr (constrRep (toConstr what)), x))
+                                       what
+
+-- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
+deserializeWithData :: Data a => [Word8] -> a
+deserializeWithData = snd . deserializeWithData'
+
+deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
+deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
+                             gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
+                                     (\x -> (bytes, x))
+                                     (repConstr (dataTypeOf (undefined :: a)) constr_rep)
+
+
+serializeConstr :: ConstrRep -> [Word8] -> [Word8]
+serializeConstr (AlgConstr ix)   = serializeWord8 1 . serializeInt ix
+serializeConstr (IntConstr i)    = serializeWord8 2 . serializeInteger i
+serializeConstr (FloatConstr d)  = serializeWord8 3 . serializeDouble d
+serializeConstr (StringConstr s) = serializeWord8 4 . serializeString s
+
+deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
+deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
+                            case constr_ix of
+                                1 -> deserializeInt     bytes $ \ix -> k (AlgConstr ix)
+                                2 -> deserializeInteger bytes $ \i  -> k (IntConstr i)
+                                3 -> deserializeDouble  bytes $ \d  -> k (FloatConstr d)
+                                4 -> deserializeString  bytes $ \s  -> k (StringConstr s)
+                                x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
+
+
+serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
+serializeFixedWidthNum what = go (bitSize what) what
+  where
+    go :: Int -> a -> [Word8] -> [Word8]
+    go size current rest
+      | size <= 0 = rest
+      | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
+
+deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
+  where
+    go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
+    go size bytes k
+      | size <= 0 = k 0 bytes
+      | otherwise = case bytes of
+                        (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
+                        []           -> error "deserializeFixedWidthNum: unexpected end of stream"
+
+
+serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
+serializeEnum = serializeInt . fromEnum
+
+deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
+
+
+serializeWord8 :: Word8 -> [Word8] -> [Word8]
+serializeWord8 x = (x:)
+
+deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
+deserializeWord8 (byte:bytes) k = k byte bytes
+deserializeWord8 []           _ = error "deserializeWord8: unexpected end of stream"
+
+
+serializeInt :: Int -> [Word8] -> [Word8]
+serializeInt = serializeFixedWidthNum
+
+deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
+deserializeInt = deserializeFixedWidthNum
+
+
+serializeDouble :: Double -> [Word8] -> [Word8]
+serializeDouble = serializeString . show
+
+deserializeDouble :: [Word8] -> (Double -> [Word8] -> a) -> a
+deserializeDouble bytes k = deserializeString bytes (k . read)
+
+
+serializeInteger :: Integer -> [Word8] -> [Word8]
+serializeInteger = serializeString . show
+
+deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
+deserializeInteger bytes k = deserializeString bytes (k . read)
+
+
+serializeString :: String -> [Word8] -> [Word8]
+serializeString = serializeList serializeEnum
+
+deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
+deserializeString = deserializeList deserializeEnum
+
+
+serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
+serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
+
+deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
+                -> [Word8] -> ([a] -> [Word8] -> b) -> b
+deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
+  where
+    go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
+    go len bytes k
+      | len <= 0  = k [] bytes
+      | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
\ No newline at end of file