diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-04-20 16:54:38 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-26 13:55:14 -0400 |
| commit | af332442123878c1b61d236dce46418efcbe8750 (patch) | |
| tree | ec4b332843cdd4fedb4aa60b11b7b8dba82a0764 /compiler/utils | |
| parent | b0fbfc7582fb81314dc28a056536737fb5eeaa6e (diff) | |
| download | haskell-af332442123878c1b61d236dce46418efcbe8750.tar.gz | |
Modules: Utils and Data (#13009)
Update Haddock submodule
Metric Increase:
haddock.compiler
Diffstat (limited to 'compiler/utils')
40 files changed, 0 insertions, 12325 deletions
diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs deleted file mode 100644 index d3393d71e2..0000000000 --- a/compiler/utils/AsmUtils.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Various utilities used in generating assembler. --- --- These are used not only by the native code generator, but also by the --- GHC.Driver.Pipeline -module AsmUtils - ( sectionType - ) where - -import GhcPrelude - -import GHC.Platform -import Outputable - --- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: Platform -- ^ Target platform - -> String -- ^ section type - -> SDoc -- ^ pretty assembler fragment -sectionType platform ty = - case platformArch platform of - ArchARM{} -> char '%' <> text ty - _ -> char '@' <> text ty diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs deleted file mode 100644 index e1eea48000..0000000000 --- a/compiler/utils/Bag.hs +++ /dev/null @@ -1,335 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Bag: an unordered collection with duplicates --} - -{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-} - -module Bag ( - Bag, -- abstract type - - emptyBag, unitBag, unionBags, unionManyBags, - mapBag, - elemBag, lengthBag, - filterBag, partitionBag, partitionBagWith, - concatBag, catBagMaybes, foldBag, - isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, - listToBag, bagToList, mapAccumBagL, - concatMapBag, concatMapBagPair, mapMaybeBag, - mapBagM, mapBagM_, - flatMapBagM, flatMapBagPairM, - mapAndUnzipBagM, mapAccumBagLM, - anyBagM, filterBagM - ) where - -import GhcPrelude - -import Outputable -import Util - -import MonadUtils -import Control.Monad -import Data.Data -import Data.Maybe( mapMaybe ) -import Data.List ( partition, mapAccumL ) -import qualified Data.Foldable as Foldable - -infixr 3 `consBag` -infixl 3 `snocBag` - -data Bag a - = EmptyBag - | UnitBag a - | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty - | ListBag [a] -- INVARIANT: the list is non-empty - deriving (Functor) - -emptyBag :: Bag a -emptyBag = EmptyBag - -unitBag :: a -> Bag a -unitBag = UnitBag - -lengthBag :: Bag a -> Int -lengthBag EmptyBag = 0 -lengthBag (UnitBag {}) = 1 -lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 -lengthBag (ListBag xs) = length xs - -elemBag :: Eq a => a -> Bag a -> Bool -elemBag _ EmptyBag = False -elemBag x (UnitBag y) = x == y -elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 -elemBag x (ListBag ys) = any (x ==) ys - -unionManyBags :: [Bag a] -> Bag a -unionManyBags xs = foldr unionBags EmptyBag xs - --- This one is a bit stricter! The bag will get completely evaluated. - -unionBags :: Bag a -> Bag a -> Bag a -unionBags EmptyBag b = b -unionBags b EmptyBag = b -unionBags b1 b2 = TwoBags b1 b2 - -consBag :: a -> Bag a -> Bag a -snocBag :: Bag a -> a -> Bag a - -consBag elt bag = (unitBag elt) `unionBags` bag -snocBag bag elt = bag `unionBags` (unitBag elt) - -isEmptyBag :: Bag a -> Bool -isEmptyBag EmptyBag = True -isEmptyBag _ = False -- NB invariants - -isSingletonBag :: Bag a -> Bool -isSingletonBag EmptyBag = False -isSingletonBag (UnitBag _) = True -isSingletonBag (TwoBags _ _) = False -- Neither is empty -isSingletonBag (ListBag xs) = isSingleton xs - -filterBag :: (a -> Bool) -> Bag a -> Bag a -filterBag _ EmptyBag = EmptyBag -filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag -filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 - where sat1 = filterBag pred b1 - sat2 = filterBag pred b2 -filterBag pred (ListBag vs) = listToBag (filter pred vs) - -filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) -filterBagM _ EmptyBag = return EmptyBag -filterBagM pred b@(UnitBag val) = do - flag <- pred val - if flag then return b - else return EmptyBag -filterBagM pred (TwoBags b1 b2) = do - sat1 <- filterBagM pred b1 - sat2 <- filterBagM pred b2 - return (sat1 `unionBags` sat2) -filterBagM pred (ListBag vs) = do - sat <- filterM pred vs - return (listToBag sat) - -allBag :: (a -> Bool) -> Bag a -> Bool -allBag _ EmptyBag = True -allBag p (UnitBag v) = p v -allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 -allBag p (ListBag xs) = all p xs - -anyBag :: (a -> Bool) -> Bag a -> Bool -anyBag _ EmptyBag = False -anyBag p (UnitBag v) = p v -anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 -anyBag p (ListBag xs) = any p xs - -anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool -anyBagM _ EmptyBag = return False -anyBagM p (UnitBag v) = p v -anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 - if flag then return True - else anyBagM p b2 -anyBagM p (ListBag xs) = anyM p xs - -concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldr add emptyBag bss - where - add bs rs = bs `unionBags` rs - -catBagMaybes :: Bag (Maybe a) -> Bag a -catBagMaybes bs = foldr add emptyBag bs - where - add Nothing rs = rs - add (Just x) rs = x `consBag` rs - -partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, - Bag a {- Don't -}) -partitionBag _ EmptyBag = (EmptyBag, EmptyBag) -partitionBag pred b@(UnitBag val) - = if pred val then (b, EmptyBag) else (EmptyBag, b) -partitionBag pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBag pred b1 - (sat2, fail2) = partitionBag pred b2 -partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partition pred vs - - -partitionBagWith :: (a -> Either b c) -> Bag a - -> (Bag b {- Left -}, - Bag c {- Right -}) -partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) -partitionBagWith pred (UnitBag val) - = case pred val of - Left a -> (UnitBag a, EmptyBag) - Right b -> (EmptyBag, UnitBag b) -partitionBagWith pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBagWith pred b1 - (sat2, fail2) = partitionBagWith pred b2 -partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partitionWith pred vs - -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative - -> (a -> r) -- Replace UnitBag with this - -> r -- Replace EmptyBag with this - -> Bag a - -> r - -{- Standard definition -foldBag t u e EmptyBag = e -foldBag t u e (UnitBag x) = u x -foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) -foldBag t u e (ListBag xs) = foldr (t.u) e xs --} - --- More tail-recursive definition, exploiting associativity of "t" -foldBag _ _ e EmptyBag = e -foldBag t u e (UnitBag x) = u x `t` e -foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 -foldBag t u e (ListBag xs) = foldr (t.u) e xs - -mapBag :: (a -> b) -> Bag a -> Bag b -mapBag = fmap - -concatMapBag :: (a -> Bag b) -> Bag a -> Bag b -concatMapBag _ EmptyBag = EmptyBag -concatMapBag f (UnitBag x) = f x -concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) -concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs - -concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) -concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) -concatMapBagPair f (UnitBag x) = f x -concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) - where - (r1, s1) = concatMapBagPair f b1 - (r2, s2) = concatMapBagPair f b2 -concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs - where - go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) - where - (r1, r2) = f a - -mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b -mapMaybeBag _ EmptyBag = EmptyBag -mapMaybeBag f (UnitBag x) = case f x of - Nothing -> EmptyBag - Just y -> UnitBag y -mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) -mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) - -mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) -mapBagM _ EmptyBag = return EmptyBag -mapBagM f (UnitBag x) = do r <- f x - return (UnitBag r) -mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 - r2 <- mapBagM f b2 - return (TwoBags r1 r2) -mapBagM f (ListBag xs) = do rs <- mapM f xs - return (ListBag rs) - -mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () -mapBagM_ _ EmptyBag = return () -mapBagM_ f (UnitBag x) = f x >> return () -mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 -mapBagM_ f (ListBag xs) = mapM_ f xs - -flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) -flatMapBagM _ EmptyBag = return EmptyBag -flatMapBagM f (UnitBag x) = f x -flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 - r2 <- flatMapBagM f b2 - return (r1 `unionBags` r2) -flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs - where - k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } - -flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) -flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) -flatMapBagPairM f (UnitBag x) = f x -flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 - (r2,s2) <- flatMapBagPairM f b2 - return (r1 `unionBags` r2, s1 `unionBags` s2) -flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs - where - k x (r2,s2) = do { (r1,s1) <- f x - ; return (r1 `unionBags` r2, s1 `unionBags` s2) } - -mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) -mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) -mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x - return (UnitBag r, UnitBag s) -mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 - (r2,s2) <- mapAndUnzipBagM f b2 - return (TwoBags r1 r2, TwoBags s1 s2) -mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs - let (rs,ss) = unzip ts - return (ListBag rs, ListBag ss) - -mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> (acc, Bag y) -- ^ final state, outputs -mapAccumBagL _ s EmptyBag = (s, EmptyBag) -mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) -mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 - (s2, b2') = mapAccumBagL f s1 b2 - in (s2, TwoBags b1' b2') -mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs - in (s', ListBag xs') - -mapAccumBagLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> m (acc, Bag y) -- ^ final state, outputs -mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) -mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } -mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 - ; (s2, b2') <- mapAccumBagLM f s1 b2 - ; return (s2, TwoBags b1' b2') } -mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs - ; return (s', ListBag xs') } - -listToBag :: [a] -> Bag a -listToBag [] = EmptyBag -listToBag [x] = UnitBag x -listToBag vs = ListBag vs - -bagToList :: Bag a -> [a] -bagToList b = foldr (:) [] b - -instance (Outputable a) => Outputable (Bag a) where - ppr bag = braces (pprWithCommas ppr (bagToList bag)) - -instance Data a => Data (Bag a) where - gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly - toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Bag" - dataCast1 x = gcast1 x - -instance Foldable.Foldable Bag where - foldr _ z EmptyBag = z - foldr k z (UnitBag x) = k x z - foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 - foldr k z (ListBag xs) = foldr k z xs - - foldl _ z EmptyBag = z - foldl k z (UnitBag x) = k z x - foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 - foldl k z (ListBag xs) = foldl k z xs - - foldl' _ z EmptyBag = z - foldl' k z (UnitBag x) = k z x - foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 - foldl' k z (ListBag xs) = foldl' k z xs - -instance Traversable Bag where - traverse _ EmptyBag = pure EmptyBag - traverse f (UnitBag x) = UnitBag <$> f x - traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 - traverse f (ListBag xs) = ListBag <$> traverse f xs diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs deleted file mode 100644 index 529519df1d..0000000000 --- a/compiler/utils/Binary.hs +++ /dev/null @@ -1,1457 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BangPatterns #-} - -{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- --- (c) The University of Glasgow 2002-2006 --- --- 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/ - -module Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - SymbolTable, Dictionary, - - BinData(..), dataHandle, handleData, - - openBinMem, --- closeBin, - - seekBin, - tellBin, - castBin, - withBinBuffer, - - writeBinMem, - readBinMem, - - putAt, getAt, - - -- * For writing instances - putByte, - getByte, - - -- * Variable length encodings - putULEB128, - getULEB128, - putSLEB128, - getSLEB128, - - -- * Lazy Binary I/O - lazyGet, - lazyPut, - - -- * User data - UserData(..), getUserData, setUserData, - newReadState, newWriteState, - putDictionary, getDictionary, putFS, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} GHC.Types.Name (Name) -import FastString -import PlainPanic -import GHC.Types.Unique.FM -import FastMutInt -import Fingerprint -import GHC.Types.Basic -import GHC.Types.SrcLoc - -import Control.DeepSeq -import Foreign -import Data.Array -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Time -import Data.List (unfoldr) -import Type.Reflection -import Type.Reflection.Unsafe -import Data.Kind (Type) -import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) -import Control.Monad ( when, (<$!>), unless ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Serialized - -type BinArray = ForeignPtr Word8 - - - ---------------------------------------------------------------- --- BinData ---------------------------------------------------------------- - -data BinData = BinData Int BinArray - -instance NFData BinData where - rnf (BinData sz _) = rnf sz - -instance Binary BinData where - put_ bh (BinData sz dat) = do - put_ bh sz - putPrim bh sz $ \dest -> - withForeignPtr dat $ \orig -> - copyBytes dest orig sz - -- - get bh = do - sz <- get bh - dat <- mallocForeignPtrBytes sz - getPrim bh sz $ \orig -> - withForeignPtr dat $ \dest -> - copyBytes dest orig sz - return (BinData sz dat) - -dataHandle :: BinData -> IO BinHandle -dataHandle (BinData size bin) = do - ixr <- newFastMutInt - szr <- newFastMutInt - writeFastMutInt ixr 0 - writeFastMutInt szr size - binr <- newIORef bin - return (BinMem noUserData ixr szr binr) - -handleData :: BinHandle -> IO BinData -handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr - ---------------------------------------------------------------- --- 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. - -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh - -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } - --- | Get access to the underlying buffer. --- --- It is quite important that no references to the 'ByteString' leak out of the --- continuation lest terrible things happen. -withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a -withBinBuffer (BinMem _ ix_r _ arr_r) action = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \ptr -> - BS.unsafePackCStringLen (castPtr ptr, ix) >>= action - - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - --- | Do not rely on instance sizes for general types, --- we use variable length encoding for many of them. -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do _ <- put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put_ bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- mallocForeignPtrBytes size - 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 (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinMem _ ix_r _ arr_r) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> hPutBuf h p ix - hClose 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 <- mallocForeignPtrBytes filesize - count <- withForeignPtr arr $ \p -> hGetBuf h p filesize - when (count /= filesize) $ - error ("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 _ _ sz_r arr_r) !off = do - !sz <- readFastMutInt sz_r - let !sz' = getSize sz - arr <- readIORef arr_r - arr' <- mallocForeignPtrBytes sz' - withForeignPtr arr $ \old -> - withForeignPtr arr' $ \new -> - copyBytes new old sz - writeFastMutInt sz_r sz' - writeIORef arr_r arr' - where - getSize :: Int -> Int - getSize !sz - | sz > off - = sz - | otherwise - = getSize (sz * 2) - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - --- | Takes a size and action writing up to @size@ bytes. --- After the action has run advance the index to the buffer --- by size bytes. -putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () -putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - expandBin h (ix + size) - arr <- readIORef arr_r - withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - --- -- | Similar to putPrim but advances the index by the actual number of --- -- bytes written. --- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () --- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do --- ix <- readFastMutInt ix_r --- sz <- readFastMutInt sz_r --- when (ix + size > sz) $ --- expandBin h (ix + size) --- arr <- readIORef arr_r --- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) --- writeFastMutInt ix_r (ix + written) - -getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a -getPrim (BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - arr <- readIORef arr_r - w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - return w - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h !w = putPrim h 1 (\op -> poke op w) - -getWord8 :: BinHandle -> IO Word8 -getWord8 h = getPrim h 1 peek - --- putWord16 :: BinHandle -> Word16 -> IO () --- putWord16 h w = putPrim h 2 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) --- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord16 :: BinHandle -> IO Word16 --- getWord16 h = getPrim h 2 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- return $! w0 `shiftL` 8 .|. w1 --- ) - -putWord32 :: BinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) - -getWord32 :: BinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) - --- putWord64 :: BinHandle -> Word64 -> IO () --- putWord64 h w = putPrim h 8 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) --- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) --- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) --- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) --- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) --- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) --- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) --- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord64 :: BinHandle -> IO Word64 --- getWord64 h = getPrim h 8 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- w2 <- fromIntegral <$> peekElemOff op 2 --- w3 <- fromIntegral <$> peekElemOff op 3 --- w4 <- fromIntegral <$> peekElemOff op 4 --- w5 <- fromIntegral <$> peekElemOff op 5 --- w6 <- fromIntegral <$> peekElemOff op 6 --- w7 <- fromIntegral <$> peekElemOff op 7 - --- return $! (w0 `shiftL` 56) .|. --- (w1 `shiftL` 48) .|. --- (w2 `shiftL` 40) .|. --- (w3 `shiftL` 32) .|. --- (w4 `shiftL` 24) .|. --- (w5 `shiftL` 16) .|. --- (w6 `shiftL` 8) .|. --- w7 --- ) - -putByte :: BinHandle -> Word8 -> IO () -putByte bh !w = putWord8 bh w - -getByte :: BinHandle -> IO Word8 -getByte h = getWord8 h - --- ----------------------------------------------------------------------------- --- Encode numbers in LEB128 encoding. --- Requires one byte of space per 7 bits of data. --- --- There are signed and unsigned variants. --- Do NOT use the unsigned one for signed values, at worst it will --- result in wrong results, at best it will lead to bad performance --- when coercing negative values to an unsigned type. --- --- We mark them as SPECIALIZE as it's extremely critical that they get specialized --- to their specific types. --- --- TODO: Each use of putByte performs a bounds check, --- we should use putPrimMax here. However it's quite hard to return --- the number of bytes written into putPrimMax without allocating an --- Int for it, while the code below does not allocate at all. --- So we eat the cost of the bounds check instead of increasing allocations --- for now. - --- Unsigned numbers -{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} -putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () -putULEB128 bh w = -#if defined(DEBUG) - (if w < 0 then panic "putULEB128: Signed number" else id) $ -#endif - go w - where - go :: a -> IO () - go w - | w <= (127 :: a) - = putByte bh (fromIntegral w :: Word8) - | otherwise = do - -- bit 7 (8th bit) indicates more to come. - let !byte = setBit (fromIntegral w) 7 :: Word8 - putByte bh byte - go (w `unsafeShiftR` 7) - -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} -getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a -getULEB128 bh = - go 0 0 - where - go :: Int -> a -> IO a - go shift w = do - b <- getByte bh - let !hasMore = testBit b 7 - let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a - if hasMore - then do - go (shift+7) val - else - return $! val - --- Signed numbers -{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} -putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () -putSLEB128 bh initial = go initial - where - go :: a -> IO () - go val = do - let !byte = fromIntegral (clearBit val 7) :: Word8 - let !val' = val `unsafeShiftR` 7 - let !signBit = testBit byte 6 - let !done = - -- Unsigned value, val' == 0 and last value can - -- be discriminated from a negative number. - ((val' == 0 && not signBit) || - -- Signed value, - (val' == -1 && signBit)) - - let !byte' = if done then byte else setBit byte 7 - putByte bh byte' - - unless done $ go val' - -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} -getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a -getSLEB128 bh = do - (val,shift,signed) <- go 0 0 - if signed && (shift < finiteBitSize val ) - then return $! ((complement 0 `unsafeShiftL` shift) .|. val) - else return val - where - go :: Int -> a -> IO (a,Int,Bool) - go shift val = do - byte <- getByte bh - let !byteVal = fromIntegral (clearBit byte 7) :: a - let !val' = val .|. (byteVal `unsafeShiftL` shift) - let !more = testBit byte 7 - let !shift' = shift+7 - if more - then go (shift') val' - else do - let !signed = testBit byte 6 - return (val',shift',signed) - --- ----------------------------------------------------------------------------- --- Primitive Word writes - -instance Binary Word8 where - put_ bh !w = putWord8 bh w - get = getWord8 - -instance Binary Word16 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word32 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word64 where - put_ = putULEB128 - get = getULEB128 - --- ----------------------------------------------------------------------------- --- Primitive Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int32 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int64 where - put_ h w = putSLEB128 h w - get h = getSLEB128 h - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) - -instance Binary Int where - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) - -instance Binary a => Binary [a] where - put_ bh l = do - let len = length l - put_ bh len - mapM_ (put_ bh) l - get bh = do - len <- get bh :: IO Int -- Int is variable length encoded so only - -- one byte for small lists. - let loop 0 = return [] - loop n = do a <- get bh; as <- loop (n-1); return (a:as) - loop len - -instance (Ix a, Binary a, Binary b) => Binary (Array a b) where - put_ bh arr = do - put_ bh $ bounds arr - put_ bh $ elems arr - get bh = do - bounds <- get bh - xs <- get bh - return $ listArray bounds xs - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - 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 - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where - put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where - put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - 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 - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary UTCTime where - put_ bh u = do put_ bh (utctDay u) - put_ bh (utctDayTime u) - get bh = do day <- get bh - dayTime <- get bh - return $ UTCTime { utctDay = day, utctDayTime = dayTime } - -instance Binary Day where - put_ bh d = put_ bh (toModifiedJulianDay d) - get bh = do i <- get bh - return $ ModifiedJulianDay { toModifiedJulianDay = i } - -instance Binary DiffTime where - put_ bh dt = put_ bh (toRational dt) - get bh = do r <- get bh - return $ fromRational r - -{- -Finally - a reasonable portable Integer instance. - -We used to encode values in the Int32 range as such, -falling back to a string of all things. In either case -we stored a tag byte to discriminate between the two cases. - -This made some sense as it's highly portable but also not very -efficient. - -However GHC stores a surprisingly large number off large Integer -values. In the examples looked at between 25% and 50% of Integers -serialized were outside of the Int32 range. - -Consider a valie like `2724268014499746065`, some sort of hash -actually generated by GHC. -In the old scheme this was encoded as a list of 19 chars. This -gave a size of 77 Bytes, one for the length of the list and 76 -since we encode chars as Word32 as well. - -We can easily do better. The new plan is: - -* Start with a tag byte - * 0 => Int64 (LEB128 encoded) - * 1 => Negative large interger - * 2 => Positive large integer -* Followed by the value: - * Int64 is encoded as usual - * Large integers are encoded as a list of bytes (Word8). - We use Data.Bits which defines a bit order independent of the representation. - Values are stored LSB first. - -This means our example value `2724268014499746065` is now only 10 bytes large. -* One byte tag -* One byte for the length of the [Word8] list. -* 8 bytes for the actual date. - -The new scheme also does not depend in any way on -architecture specific details. - -We still use this scheme even with LEB128 available, -as it has less overhead for truly large numbers. (> maxBound :: Int64) - -The instance is used for in Binary Integer and Binary Rational in basicTypes/Literal.hs --} - -instance Binary Integer where - put_ bh i - | i >= lo64 && i <= hi64 = do - putWord8 bh 0 - put_ bh (fromIntegral i :: Int64) - | otherwise = do - if i < 0 - then putWord8 bh 1 - else putWord8 bh 2 - put_ bh (unroll $ abs i) - where - lo64 = fromIntegral (minBound :: Int64) - hi64 = fromIntegral (maxBound :: Int64) - get bh = do - int_kind <- getWord8 bh - case int_kind of - 0 -> fromIntegral <$!> (get bh :: IO Int64) - -- Large integer - 1 -> negate <$!> getInt - 2 -> getInt - _ -> panic "Binary Integer - Invalid byte" - where - getInt :: IO Integer - getInt = roll <$!> (get bh :: IO [Word8]) - -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldl' unstep 0 . reverse - where - unstep a b = a `shiftL` 8 .|. fromIntegral b - - - {- - -- This code is currently commented out. - -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for - -- discussion. - - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - putByte bh 1 - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - 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#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -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 #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# n#) - --} -instance (Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - --- Instance uses fixed-width encoding to allow inserting --- Bin placeholders in the stream. -instance Binary (Bin a) where - put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) - get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) - --- ----------------------------------------------------------------------------- --- Instances for Data.Typeable stuff - -instance Binary TyCon where - put_ bh tc = do - put_ bh (tyConPackage tc) - put_ bh (tyConModule tc) - put_ bh (tyConName tc) - put_ bh (tyConKindArgs tc) - put_ bh (tyConKindRep tc) - get bh = - mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh - -instance Binary VecCount where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary VecElem where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary RuntimeRep where - put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b - put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps - put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps - put_ bh LiftedRep = putByte bh 3 - put_ bh UnliftedRep = putByte bh 4 - put_ bh IntRep = putByte bh 5 - put_ bh WordRep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh Word64Rep = putByte bh 8 - put_ bh AddrRep = putByte bh 9 - put_ bh FloatRep = putByte bh 10 - put_ bh DoubleRep = putByte bh 11 - put_ bh Int8Rep = putByte bh 12 - put_ bh Word8Rep = putByte bh 13 - put_ bh Int16Rep = putByte bh 14 - put_ bh Word16Rep = putByte bh 15 -#if __GLASGOW_HASKELL__ >= 809 - put_ bh Int32Rep = putByte bh 16 - put_ bh Word32Rep = putByte bh 17 -#endif - - get bh = do - tag <- getByte bh - case tag of - 0 -> VecRep <$> get bh <*> get bh - 1 -> TupleRep <$> get bh - 2 -> SumRep <$> get bh - 3 -> pure LiftedRep - 4 -> pure UnliftedRep - 5 -> pure IntRep - 6 -> pure WordRep - 7 -> pure Int64Rep - 8 -> pure Word64Rep - 9 -> pure AddrRep - 10 -> pure FloatRep - 11 -> pure DoubleRep - 12 -> pure Int8Rep - 13 -> pure Word8Rep - 14 -> pure Int16Rep - 15 -> pure Word16Rep -#if __GLASGOW_HASKELL__ >= 809 - 16 -> pure Int32Rep - 17 -> pure Word32Rep -#endif - _ -> fail "Binary.putRuntimeRep: invalid tag" - -instance Binary KindRep where - put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k - put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr - put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b - put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b - put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r - put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r - - get bh = do - tag <- getByte bh - case tag of - 0 -> KindRepTyConApp <$> get bh <*> get bh - 1 -> KindRepVar <$> get bh - 2 -> KindRepApp <$> get bh <*> get bh - 3 -> KindRepFun <$> get bh <*> get bh - 4 -> KindRepTYPE <$> get bh - 5 -> KindRepTypeLit <$> get bh <*> get bh - _ -> fail "Binary.putKindRep: invalid tag" - -instance Binary TypeLitSort where - put_ bh TypeLitSymbol = putByte bh 0 - put_ bh TypeLitNat = putByte bh 1 - get bh = do - tag <- getByte bh - case tag of - 0 -> pure TypeLitSymbol - 1 -> pure TypeLitNat - _ -> fail "Binary.putTypeLitSort: invalid tag" - -putTypeRep :: BinHandle -> TypeRep a -> IO () --- Special handling for TYPE, (->), and RuntimeRep due to recursive kind --- relations. --- See Note [Mutually recursive representations of primitive types] -putTypeRep bh rep - | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) - = put_ bh (0 :: Word8) -putTypeRep bh (Con' con ks) = do - put_ bh (1 :: Word8) - put_ bh con - put_ bh ks -putTypeRep bh (App f x) = do - put_ bh (2 :: Word8) - putTypeRep bh f - putTypeRep bh x -putTypeRep bh (Fun arg res) = do - put_ bh (3 :: Word8) - putTypeRep bh arg - putTypeRep bh res - -getSomeTypeRep :: BinHandle -> IO SomeTypeRep -getSomeTypeRep bh = do - tag <- get bh :: IO Word8 - case tag of - 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) - 1 -> do con <- get bh :: IO TyCon - ks <- get bh :: IO [SomeTypeRep] - return $ SomeTypeRep $ mkTrCon con ks - - 2 -> do SomeTypeRep f <- getSomeTypeRep bh - SomeTypeRep x <- getSomeTypeRep bh - case typeRepKind f of - Fun arg res -> - case arg `eqTypeRep` typeRepKind x of - Just HRefl -> - case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> return $ SomeTypeRep $ mkTrApp f x - _ -> failure "Kind mismatch in type application" [] - _ -> failure "Kind mismatch in type application" - [ " Found argument of kind: " ++ show (typeRepKind x) - , " Where the constructor: " ++ show f - , " Expects kind: " ++ show arg - ] - _ -> failure "Applied non-arrow" - [ " Applied type: " ++ show f - , " To argument: " ++ show x - ] - 3 -> do SomeTypeRep arg <- getSomeTypeRep bh - SomeTypeRep res <- getSomeTypeRep bh - if - | App argkcon _ <- typeRepKind arg - , App reskcon _ <- typeRepKind res - , Just HRefl <- argkcon `eqTypeRep` tYPErep - , Just HRefl <- reskcon `eqTypeRep` tYPErep - -> return $ SomeTypeRep $ Fun arg res - | otherwise -> failure "Kind mismatch" [] - _ -> failure "Invalid SomeTypeRep" [] - where - tYPErep :: TypeRep TYPE - tYPErep = typeRep - - failure description info = - fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] - ++ map (" "++) info - -instance Typeable a => Binary (TypeRep (a :: k)) where - put_ = putTypeRep - get bh = do - SomeTypeRep rep <- getSomeTypeRep bh - case rep `eqTypeRep` expected of - Just HRefl -> pure rep - Nothing -> fail $ unlines - [ "Binary: Type mismatch" - , " Deserialized type: " ++ show rep - , " Expected type: " ++ show expected - ] - where expected = typeRep :: TypeRep a - -instance Binary SomeTypeRep where - put_ bh (SomeTypeRep rep) = putTypeRep bh rep - get = getSomeTypeRep - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO $ do - -- NB: Use a fresh off_r variable in the child thread, for thread - -- safety. - off_r <- newFastMutInt - getAt bh { _off_r = off_r } p_a - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- UserData --- ----------------------------------------------------------------------------- - --- | Information we keep around during interface file --- serialization/deserialization. Namely we keep the functions for serializing --- and deserializing 'Name's and 'FastString's. We do this because we actually --- use serialization in two distinct settings, --- --- * When serializing interface files themselves --- --- * When computing the fingerprint of an IfaceDecl (which we computing by --- hashing its Binary serialization) --- --- These two settings have different needs while serializing Names: --- --- * Names in interface files are serialized via a symbol table (see Note --- [Symbol table representation of names] in GHC.Iface.Binary). --- --- * During fingerprinting a binding Name is serialized as the OccName and a --- non-binding Name is serialized as the fingerprint of the thing they --- represent. See Note [Fingerprinting IfaceDecls] for further discussion. --- -data UserData = - UserData { - -- for *deserialising* only: - ud_get_name :: BinHandle -> IO Name, - ud_get_fs :: BinHandle -> IO FastString, - - -- for *serialising* only: - ud_put_nonbinding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a non-binding 'Name' (e.g. a reference to another - -- binding). - ud_put_binding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) - ud_put_fs :: BinHandle -> FastString -> IO () - } - -newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's - -> (BinHandle -> IO FastString) - -> UserData -newReadState get_name get_fs - = UserData { ud_get_name = get_name, - ud_get_fs = get_fs, - ud_put_nonbinding_name = undef "put_nonbinding_name", - ud_put_binding_name = undef "put_binding_name", - ud_put_fs = undef "put_fs" - } - -newWriteState :: (BinHandle -> Name -> IO ()) - -- ^ how to serialize non-binding 'Name's - -> (BinHandle -> Name -> IO ()) - -- ^ how to serialize binding 'Name's - -> (BinHandle -> FastString -> IO ()) - -> UserData -newWriteState put_nonbinding_name put_binding_name put_fs - = UserData { ud_get_name = undef "get_name", - ud_get_fs = undef "get_fs", - ud_put_nonbinding_name = put_nonbinding_name, - ud_put_binding_name = put_binding_name, - ud_put_fs = put_fs - } - -noUserData :: a -noUserData = undef "UserData" - -undef :: String -> a -undef s = panic ("Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () -putDictionary bh sz dict = do - put_ bh sz - mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) - -- It's OK to use nonDetEltsUFM here because the elements have indices - -- that array uses to create order - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh - elems <- sequence (take sz (repeat (getFS bh))) - return (listArray (0,sz-1) elems) - ---------------------------------------------------------- --- The Symbol Table ---------------------------------------------------------- - --- On disk, the symbol table is an array of IfExtName, when --- reading it in we turn it into a SymbolTable. - -type SymbolTable = Array Int Name - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -putFS :: BinHandle -> FastString -> IO () -putFS bh fs = putBS bh $ bytesFS fs - -getFS :: BinHandle -> IO FastString -getFS bh = do - l <- get bh :: IO Int - getPrim bh l (\src -> pure $! mkFastStringBytes src l ) - -putBS :: BinHandle -> ByteString -> IO () -putBS bh bs = - BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do - put_ bh l - putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) - -getBS :: BinHandle -> IO ByteString -getBS bh = do - l <- get bh :: IO Int - BS.create l $ \dest -> do - getPrim bh l (\src -> BS.memcpy dest src l) - -instance Binary ByteString where - put_ bh f = putBS bh f - get bh = getBS bh - -instance Binary FastString where - put_ bh f = - case getUserData bh of - UserData { ud_put_fs = put_fs } -> put_fs bh f - - get bh = - case getUserData bh of - UserData { ud_get_fs = get_fs } -> get_fs bh - --- Here to avoid loop -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -instance Binary PromotionFlag where - put_ bh NotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 - - get bh = do - n <- getByte bh - case n of - 0 -> return NotPromoted - 1 -> return IsPromoted - _ -> fail "Binary(IsPromoted): fail)" - -instance Binary Fingerprint where - put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 - get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) - -instance Binary FunctionOrData where - put_ bh IsFunction = putByte bh 0 - put_ bh IsData = putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> return IsFunction - 1 -> return IsData - _ -> panic "Binary FunctionOrData" - -instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore src aa) = do - putByte bh 2 - put_ bh src - put_ bh aa - put_ bh (ActiveAfter src ab) = do - putByte bh 3 - put_ bh src - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do src <- get bh - aa <- get bh - return (ActiveBefore src aa) - _ -> do src <- get bh - ab <- get bh - return (ActiveAfter src ab) - -instance Binary InlinePragma where - put_ bh (InlinePragma s a b c d) = do - put_ bh s - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - s <- get bh - a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (InlinePragma s a b c d) - -instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike - -instance Binary InlineSpec where - put_ bh NoUserInline = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return NoUserInline - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> panic ("get OverlapMode" ++ show h) - - -instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh - return OverlapFlag { overlapMode = h, isSafeOverlap = b } - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh - return (Fixity src aa ab) - -instance Binary WarningTxt where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh s - put_ bh w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh s - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - w <- get bh - return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh - return (DeprecatedTxt s d) - -instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do - put_ bh st - put_ bh fs - get bh = do - st <- get bh - fs <- get bh - return (StringLiteral st fs) - -instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L l x) - -instance Binary RealSrcSpan where - put_ bh ss = do - put_ bh (srcSpanFile ss) - put_ bh (srcSpanStartLine ss) - put_ bh (srcSpanStartCol ss) - put_ bh (srcSpanEndLine ss) - put_ bh (srcSpanEndCol ss) - - get bh = do - f <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) - -instance Binary BufPos where - put_ bh (BufPos i) = put_ bh i - get bh = BufPos <$> get bh - -instance Binary BufSpan where - put_ bh (BufSpan start end) = do - put_ bh start - put_ bh end - get bh = do - start <- get bh - end <- get bh - return (BufSpan start end) - -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss sb) = do - putByte bh 0 - put_ bh ss - put_ bh sb - - put_ bh (UnhelpfulSpan s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - sb <- get bh - return (RealSrcSpan ss sb) - _ -> do s <- get bh - return (UnhelpfulSpan s) - -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) - -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs deleted file mode 100644 index 76d80eb305..0000000000 --- a/compiler/utils/BooleanFormula.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} - --------------------------------------------------------------------------------- --- | Boolean formulas without quantifiers and without negation. --- Such a formula consists of variables, conjunctions (and), and disjunctions (or). --- --- This module is used to represent minimal complete definitions for classes. --- -module BooleanFormula ( - BooleanFormula(..), LBooleanFormula, - mkFalse, mkTrue, mkAnd, mkOr, mkVar, - isFalse, isTrue, - eval, simplify, isUnsatisfied, - implies, impliesAtom, - pprBooleanFormula, pprBooleanFormulaNice - ) where - -import GhcPrelude - -import Data.List ( nub, intersperse ) -import Data.Data - -import MonadUtils -import Outputable -import Binary -import GHC.Types.SrcLoc -import GHC.Types.Unique -import GHC.Types.Unique.Set - ----------------------------------------------------------------------- --- Boolean formula type and smart constructors ----------------------------------------------------------------------- - -type LBooleanFormula a = Located (BooleanFormula a) - -data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] - | Parens (LBooleanFormula a) - deriving (Eq, Data, Functor, Foldable, Traversable) - -mkVar :: a -> BooleanFormula a -mkVar = Var - -mkFalse, mkTrue :: BooleanFormula a -mkFalse = Or [] -mkTrue = And [] - --- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula a -mkBool False = mkFalse -mkBool True = mkTrue - --- Make a conjunction, and try to simplify -mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd - where - -- See Note [Simplification of BooleanFormulas] - fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] - fromAnd (L _ (And xs)) = Just xs - -- assume that xs are already simplified - -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - fromAnd (L _ (Or [])) = Nothing - -- in case of False we bail out, And [..,mkFalse,..] == mkFalse - fromAnd x = Just [x] - mkAnd' [x] = unLoc x - mkAnd' xs = And xs - -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr - where - -- See Note [Simplification of BooleanFormulas] - fromOr (L _ (Or xs)) = Just xs - fromOr (L _ (And [])) = Nothing - fromOr x = Just [x] - mkOr' [x] = unLoc x - mkOr' xs = Or xs - - -{- -Note [Simplification of BooleanFormulas] -~~~~~~~~~~~~~~~~~~~~~~ -The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, - 1. Collapsing nested ands and ors, so - `(mkAnd [x, And [y,z]]` - is represented as - `And [x,y,z]` - Implemented by `fromAnd`/`fromOr` - 2. Collapsing trivial ands and ors, so - `mkAnd [x]` becomes just `x`. - Implemented by mkAnd' / mkOr' - 3. Conjunction with false, disjunction with true is simplified, i.e. - `mkAnd [mkFalse,x]` becomes `mkFalse`. - 4. Common subexpression elimination: - `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. - -This simplification is not exhaustive, in the sense that it will not produce -the smallest possible equivalent expression. For example, -`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently -is not. A general simplifier would need to use something like BDDs. - -The reason behind the (crude) simplifier is to make for more user friendly -error messages. E.g. for the code - > class Foo a where - > {-# MINIMAL bar, (foo, baq | foo, quux) #-} - > instance Foo Int where - > bar = ... - > baz = ... - > quux = ... -We don't show a ridiculous error message like - Implement () and (either (`foo' and ()) or (`foo' and ())) --} - ----------------------------------------------------------------------- --- Evaluation and simplification ----------------------------------------------------------------------- - -isFalse :: BooleanFormula a -> Bool -isFalse (Or []) = True -isFalse _ = False - -isTrue :: BooleanFormula a -> Bool -isTrue (And []) = True -isTrue _ = False - -eval :: (a -> Bool) -> BooleanFormula a -> Bool -eval f (Var x) = f x -eval f (And xs) = all (eval f . unLoc) xs -eval f (Or xs) = any (eval f . unLoc) xs -eval f (Parens x) = eval f (unLoc x) - --- Simplify a boolean formula. --- The argument function should give the truth of the atoms, or Nothing if undecided. -simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a -simplify f (Var a) = case f a of - Nothing -> Var a - Just b -> mkBool b -simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Parens x) = simplify f (unLoc x) - --- Test if a boolean formula is satisfied when the given values are assigned to the atoms --- if it is, returns Nothing --- if it is not, return (Just remainder) -isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) -isUnsatisfied f bf - | isTrue bf' = Nothing - | otherwise = Just bf' - where - f' x = if f x then Just True else Nothing - bf' = simplify f' bf - --- prop_simplify: --- eval f x == True <==> isTrue (simplify (Just . f) x) --- eval f x == False <==> isFalse (simplify (Just . f) x) - --- If the boolean formula holds, does that mean that the given atom is always true? -impliesAtom :: Eq a => BooleanFormula a -> a -> Bool -Var x `impliesAtom` y = x == y -And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs - -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs -Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y - -implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool -implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) - where - go :: Uniquable a => Clause a -> Clause a -> Bool - go l@Clause{ clauseExprs = hyp:hyps } r = - case hyp of - Var x | memberClauseAtoms x r -> True - | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r - Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r - And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r - Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' - go l r@Clause{ clauseExprs = con:cons } = - case con of - Var x | memberClauseAtoms x l -> True - | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } - Parens con' -> go l r { clauseExprs = unLoc con':cons } - And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' - Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } - go _ _ = False - --- A small sequent calculus proof engine. -data Clause a = Clause { - clauseAtoms :: UniqSet a, - clauseExprs :: [BooleanFormula a] - } -extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a -extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } - -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool -memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c - ----------------------------------------------------------------------- --- Pretty printing ----------------------------------------------------------------------- - --- Pretty print a BooleanFormula, --- using the arguments as pretty printers for Var, And and Or respectively -pprBooleanFormula' :: (Rational -> a -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula' pprVar pprAnd pprOr = go - where - go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) $ empty - go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) - go _ (Or []) = keyword $ text "FALSE" - go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) - go p (Parens x) = go p (unLoc x) - --- Pretty print in source syntax, "a | b | c,d,e" -pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr - where - pprAnd p = cparen (p > 3) . fsep . punctuate comma - pprOr p = cparen (p > 2) . fsep . intersperse vbar - --- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? -pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc -pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 - where - pprVar _ = quotes . ppr - pprAnd p = cparen (p > 1) . pprAnd' - pprAnd' [] = empty - pprAnd' [x,y] = x <+> text "and" <+> y - pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs - pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) - -instance (OutputableBndr a) => Outputable (BooleanFormula a) where - ppr = pprBooleanFormulaNormal - -pprBooleanFormulaNormal :: (OutputableBndr a) - => BooleanFormula a -> SDoc -pprBooleanFormulaNormal = go - where - go (Var x) = pprPrefixOcc x - go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) - go (Or []) = keyword $ text "FALSE" - go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) - go (Parens x) = parens (go $ unLoc x) - - ----------------------------------------------------------------------- --- Binary ----------------------------------------------------------------------- - -instance Binary a => Binary (BooleanFormula a) where - put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x - - get bh = do - h <- getByte bh - case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs deleted file mode 100644 index 8a28f470f4..0000000000 --- a/compiler/utils/BufWrite.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- --- Fast write-buffered Handles --- --- (c) The University of Glasgow 2005-2006 --- --- This is a simple abstraction over Handles that offers very fast write --- buffering, but without the thread safety that Handles provide. It's used --- to save time in Pretty.printDoc. --- ------------------------------------------------------------------------------ - -module BufWrite ( - BufHandle(..), - newBufHandle, - bPutChar, - bPutStr, - bPutFS, - bPutFZS, - bPutPtrString, - bPutReplicate, - bFlush, - ) where - -import GhcPrelude - -import FastString -import FastMutInt - -import Control.Monad ( when ) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Unsafe as BS -import Data.Char ( ord ) -import Foreign -import Foreign.C.String -import System.IO - --- ----------------------------------------------------------------------------- - -data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) - {-#UNPACK#-}!FastMutInt - Handle - -newBufHandle :: Handle -> IO BufHandle -newBufHandle hdl = do - ptr <- mallocBytes buf_size - r <- newFastMutInt - writeFastMutInt r 0 - return (BufHandle ptr r hdl) - -buf_size :: Int -buf_size = 8192 - -bPutChar :: BufHandle -> Char -> IO () -bPutChar b@(BufHandle buf r hdl) !c = do - i <- readFastMutInt r - if (i >= buf_size) - then do hPutBuf hdl buf buf_size - writeFastMutInt r 0 - bPutChar b c - else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) - writeFastMutInt r (i+1) - -bPutStr :: BufHandle -> String -> IO () -bPutStr (BufHandle buf r hdl) !str = do - i <- readFastMutInt r - loop str i - where loop "" !i = do writeFastMutInt r i; return () - loop (c:cs) !i - | i >= buf_size = do - hPutBuf hdl buf buf_size - loop (c:cs) 0 - | otherwise = do - pokeElemOff buf i (fromIntegral (ord c)) - loop cs (i+1) - -bPutFS :: BufHandle -> FastString -> IO () -bPutFS b fs = bPutBS b $ bytesFS fs - -bPutFZS :: BufHandle -> FastZString -> IO () -bPutFZS b fs = bPutBS b $ fastZStringToByteString fs - -bPutBS :: BufHandle -> ByteString -> IO () -bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b - -bPutCStringLen :: BufHandle -> CStringLen -> IO () -bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do - i <- readFastMutInt r - if (i + len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl ptr len - else bPutCStringLen b cstr - else do - copyBytes (buf `plusPtr` i) ptr len - writeFastMutInt r (i + len) - -bPutPtrString :: BufHandle -> PtrString -> IO () -bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do - i <- readFastMutInt r - if (i+len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl a len - else bPutPtrString b l - else do - copyBytes (buf `plusPtr` i) a len - writeFastMutInt r (i+len) - --- | Replicate an 8-bit character -bPutReplicate :: BufHandle -> Int -> Char -> IO () -bPutReplicate (BufHandle buf r hdl) len c = do - i <- readFastMutInt r - let oc = fromIntegral (ord c) - if (i+len) < buf_size - then do - fillBytes (buf `plusPtr` i) oc len - writeFastMutInt r (i+len) - else do - -- flush the current buffer - when (i /= 0) $ hPutBuf hdl buf i - if (len < buf_size) - then do - fillBytes buf oc len - writeFastMutInt r len - else do - -- fill a full buffer - fillBytes buf oc buf_size - -- flush it as many times as necessary - let go n | n >= buf_size = do - hPutBuf hdl buf buf_size - go (n-buf_size) - | otherwise = writeFastMutInt r n - go len - -bFlush :: BufHandle -> IO () -bFlush (BufHandle buf r hdl) = do - i <- readFastMutInt r - when (i > 0) $ hPutBuf hdl buf i - free buf - return () diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs deleted file mode 100644 index ad5fbf53c3..0000000000 --- a/compiler/utils/Digraph.hs +++ /dev/null @@ -1,524 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Digraph( - Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, - - SCC(..), Node(..), flattenSCC, flattenSCCs, - stronglyConnCompG, - topologicalSortG, - verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, - emptyG, - - findCycle, - - -- For backwards compatibility with the simpler version of Digraph - stronglyConnCompFromEdgedVerticesOrd, - stronglyConnCompFromEdgedVerticesOrdR, - stronglyConnCompFromEdgedVerticesUniq, - stronglyConnCompFromEdgedVerticesUniqR, - - -- Simple way to classify edges - EdgeType(..), classifyEdges - ) where - -#include "HsVersions.h" - ------------------------------------------------------------------------------- --- A version of the graph algorithms described in: --- --- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' --- by David King and John Launchbury --- --- Also included is some additional code for printing tree structures ... --- --- If you ever find yourself in need of algorithms for classifying edges, --- or finding connected/biconnected components, consult the history; Sigbjorn --- Finne contributed some implementations in 1997, although we've since --- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------- - - -import GhcPrelude - -import Util ( minWith, count ) -import Outputable -import Maybes ( expectJust ) - --- std interfaces -import Data.Maybe -import Data.Array -import Data.List hiding (transpose) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Data.Graph as G -import Data.Graph hiding (Graph, Edge, transposeG, reachable) -import Data.Tree -import GHC.Types.Unique -import GHC.Types.Unique.FM - -{- -************************************************************************ -* * -* Graphs and Graph Construction -* * -************************************************************************ - -Note [Nodes, keys, vertices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * A 'node' is a big blob of client-stuff - - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison - - * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n --} - -data Graph node = Graph { - gr_int_graph :: IntGraph, - gr_vertex_to_node :: Vertex -> node, - gr_node_to_vertex :: node -> Maybe Vertex - } - -data Edge node = Edge node node - -{-| Representation for nodes of the Graph. - - * The @payload@ is user data, just carried around in this module - - * The @key@ is the node identifier. - Key has an Ord instance for performance reasons. - - * The @[key]@ are the dependencies of the node; - it's ok to have extra keys in the dependencies that - are not the key of any Node in the graph --} -data Node key payload = DigraphNode { - node_payload :: payload, -- ^ User data - node_key :: key, -- ^ User defined node id - node_dependencies :: [key] -- ^ Dependencies/successors of the node - } - - -instance (Outputable a, Outputable b) => Outputable (Node a b) where - ppr (DigraphNode a b c) = ppr (a, b, c) - -emptyGraph :: Graph a -emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) - --- See Note [Deterministic SCC] -graphFromEdgedVertices - :: ReduceFn key payload - -> [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVertices _reduceFn [] = emptyGraph -graphFromEdgedVertices reduceFn edged_vertices = - Graph graph vertex_fn (key_vertex . key_extractor) - where key_extractor = node_key - (bounds, vertex_fn, key_vertex, numbered_nodes) = - reduceFn edged_vertices key_extractor - graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) - | (v, (node_dependencies -> ks)) <- numbered_nodes] - -- We normalize outgoing edges by sorting on node order, so - -- that the result doesn't depend on the order of the edges - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesOrd - :: Ord key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq - -type ReduceFn key payload = - [Node key payload] -> (Node key payload -> key) -> - (Bounds, Vertex -> Node key payload - , key -> Maybe Vertex, [(Vertex, Node key payload)]) - -{- -Note [reduceNodesIntoVertices implementations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -reduceNodesIntoVertices is parameterized by the container type. -This is to accommodate key types that don't have an Ord instance -and hence preclude the use of Data.Map. An example of such type -would be Unique, there's no way to implement Ord Unique -deterministically. - -For such types, there's a version with a Uniquable constraint. -This leaves us with two versions of every function that depends on -reduceNodesIntoVertices, one with Ord constraint and the other with -Uniquable constraint. -For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. - -The Uniq version should be a tiny bit more efficient since it uses -Data.IntMap internally. --} -reduceNodesIntoVertices - :: ([(key, Vertex)] -> m) - -> (key -> m -> Maybe Vertex) - -> ReduceFn key payload -reduceNodesIntoVertices fromList lookup nodes key_extractor = - (bounds, (!) vertex_map, key_vertex, numbered_nodes) - where - max_v = length nodes - 1 - bounds = (0, max_v) :: (Vertex, Vertex) - - -- Keep the order intact to make the result depend on input order - -- instead of key order - numbered_nodes = zip [0..] nodes - vertex_map = array bounds numbered_nodes - - key_map = fromList - [ (key_extractor node, v) | (v, node) <- numbered_nodes ] - key_vertex k = lookup k key_map - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload -reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload -reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) - -{- -************************************************************************ -* * -* SCC -* * -************************************************************************ --} - -type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a - --- | Find a reasonably short cycle a->b->c->a, in a strongly --- connected component. The input nodes are presumed to be --- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key - => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next -findCycle graph - = go Set.empty (new_work root_deps []) [] - where - env :: Map.Map key (Node key payload) - env = Map.fromList [ (node_key node, node) | node <- graph ] - - -- Find the node with fewest dependencies among the SCC modules - -- This is just a heuristic to find some plausible root module - root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) - (node_dependencies node)) - | node <- graph ]) - DigraphNode root_payload root_key root_deps = root - - - -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle - -- Invariant: in a call (go visited ps qs), - -- visited = union (map tail (ps ++ qs)) - - go _ [] [] = Nothing -- No cycles - go visited [] qs = go visited qs [] - go visited (((DigraphNode payload key deps), path) : ps) qs - | key == root_key = Just (root_payload : reverse path) - | key `Set.member` visited = go visited ps qs - | key `Map.notMember` env = go visited ps qs - | otherwise = go (Set.insert key visited) - ps (new_qs ++ qs) - where - new_qs = new_work deps (payload : path) - - new_work :: [key] -> [payload] -> [WorkItem key payload] - new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] - -{- -************************************************************************ -* * -* Strongly Connected Component wrappers for Graph -* * -************************************************************************ - -Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have -edges going from them to earlier ones. --} - -{- -Note [Deterministic SCC] -~~~~~~~~~~~~~~~~~~~~~~~~ -stronglyConnCompFromEdgedVerticesUniq, -stronglyConnCompFromEdgedVerticesUniqR, -stronglyConnCompFromEdgedVerticesOrd and -stronglyConnCompFromEdgedVerticesOrdR -provide a following guarantee: -Given a deterministically ordered list of nodes it returns a deterministically -ordered list of strongly connected components, where the list of vertices -in an SCC is also deterministically ordered. -Note that the order of edges doesn't need to be deterministic for this to work. -We use the order of nodes to normalize the order of edges. --} - -stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG graph = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) - -decodeSccs :: Graph node -> Forest Vertex -> [SCC node] -decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest - = map decode forest - where - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) - - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrd - :: Ord key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesOrd - = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesUniq - = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you don't want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrdR - :: Ord key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesOrdR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you don't want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniqR - :: Uniquable key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesUniqR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq - -{- -************************************************************************ -* * -* Misc wrappers for Graph -* * -************************************************************************ --} - -topologicalSortG :: Graph node -> [node] -topologicalSortG graph = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) - -reachableG :: Graph node -> node -> [node] -reachableG graph from = map (gr_vertex_to_node graph) result - where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) - result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] - --- | Given a list of roots return all reachable nodes. -reachablesG :: Graph node -> [node] -> [node] -reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} - reachable (gr_int_graph graph) vs - vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] - -hasVertexG :: Graph node -> node -> Bool -hasVertexG graph node = isJust $ gr_node_to_vertex graph node - -verticesG :: Graph node -> [node] -verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) - -edgesG :: Graph node -> [Edge node] -edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) - where v2n = gr_vertex_to_node graph - -transposeG :: Graph node -> Graph node -transposeG graph = Graph (G.transposeG (gr_int_graph graph)) - (gr_vertex_to_node graph) - (gr_node_to_vertex graph) - -emptyG :: Graph node -> Bool -emptyG g = graphEmpty (gr_int_graph g) - -{- -************************************************************************ -* * -* Showing Graphs -* * -************************************************************************ --} - -instance Outputable node => Outputable (Graph node) where - ppr graph = vcat [ - hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), - hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) - ] - -instance Outputable node => Outputable (Edge node) where - ppr (Edge from to) = ppr from <+> text "->" <+> ppr to - -graphEmpty :: G.Graph -> Bool -graphEmpty g = lo > hi - where (lo, hi) = bounds g - -{- -************************************************************************ -* * -* IntGraphs -* * -************************************************************************ --} - -type IntGraph = G.Graph - -{- ------------------------------------------------------------- --- Depth first search numbering ------------------------------------------------------------- --} - --- Data.Tree has flatten for Tree, but nothing for Forest -preorderF :: Forest a -> [a] -preorderF ts = concatMap flatten ts - -{- ------------------------------------------------------------- --- Finding reachable vertices ------------------------------------------------------------- --} - --- This generalizes reachable which was found in Data.Graph -reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (dfs g vs) - -{- -************************************************************************ -* * -* Classify Edge Types -* * -************************************************************************ --} - --- Remark: While we could generalize this algorithm this comes at a runtime --- cost and with no advantages. If you find yourself using this with graphs --- not easily represented using Int nodes please consider rewriting this --- using the more general Graph type. - --- | Edge direction based on DFS Classification -data EdgeType - = Forward - | Cross - | Backward -- ^ Loop back towards the root node. - -- Eg backjumps in loops - | SelfLoop -- ^ v -> v - deriving (Eq,Ord) - -instance Outputable EdgeType where - ppr Forward = text "Forward" - ppr Cross = text "Cross" - ppr Backward = text "Backward" - ppr SelfLoop = text "SelfLoop" - -newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) - ---Allow for specialization -{-# INLINEABLE classifyEdges #-} - --- | Given a start vertex, a way to get successors from a node --- and a list of (directed) edges classify the types of edges. -classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) - -> [(key,key)] -> [((key, key), EdgeType)] -classifyEdges root getSucc edges = - --let uqe (from,to) = (getUnique from, getUnique to) - --in pprTrace "Edges:" (ppr $ map uqe edges) $ - zip edges $ map classify edges - where - (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root - classify :: (key,key) -> EdgeType - classify (from,to) - | startFrom < startTo - , endFrom > endTo - = Forward - | startFrom > startTo - , endFrom < endTo - = Backward - | startFrom > startTo - , endFrom > endTo - = Cross - | getUnique from == getUnique to - = SelfLoop - | otherwise - = pprPanic "Failed to classify edge of Graph" - (ppr (getUnique from, getUnique to)) - - where - getTime event node - | Just time <- lookupUFM event node - = time - | otherwise - = pprPanic "Failed to classify edge of CFG - not not timed" - (text "edges" <> ppr (getUnique from, getUnique to) - <+> ppr starts <+> ppr ends ) - startFrom = getTime starts from - startTo = getTime starts to - endFrom = getTime ends from - endTo = getTime ends to - - addTimes :: (Time, UniqFM Time, UniqFM Time) -> key - -> (Time, UniqFM Time, UniqFM Time) - addTimes (time,starts,ends) n - --Dont reenter nodes - | elemUFM n starts - = (time,starts,ends) - | otherwise = - let - starts' = addToUFM starts n time - time' = time + 1 - succs = getSucc n :: [key] - (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs - ends'' = addToUFM ends' n time'' - in - (time'' + 1, starts'', ends'') diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs deleted file mode 100644 index b4af68621d..0000000000 --- a/compiler/utils/Encoding.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 1997-2006 --- --- Character encodings --- --- ----------------------------------------------------------------------------- - -module Encoding ( - -- * UTF-8 - utf8DecodeChar#, - utf8PrevChar, - utf8CharStart, - utf8DecodeChar, - utf8DecodeByteString, - utf8DecodeStringLazy, - utf8EncodeChar, - utf8EncodeString, - utf8EncodedLength, - countUTF8Chars, - - -- * Z-encoding - zEncodeString, - zDecodeString, - - -- * Base62-encoding - toBase62, - toBase62Padded - ) where - -import GhcPrelude - -import Foreign -import Foreign.ForeignPtr.Unsafe -import Data.Char -import qualified Data.Char as Char -import Numeric -import GHC.IO - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS - -import GHC.Exts - --- ----------------------------------------------------------------------------- --- UTF-8 - --- We can't write the decoder as efficiently as we'd like without --- resorting to unboxed extensions, unfortunately. I tried to write --- an IO version of this function, but GHC can't eliminate boxed --- results from an IO-returning function. --- --- We assume we can ignore overflow when parsing a multibyte character here. --- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences --- before decoding them (see StringBuffer.hs). - -{-# INLINE utf8DecodeChar# #-} -utf8DecodeChar# :: Addr# -> (# Char#, Int# #) -utf8DecodeChar# a# = - let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in - case () of - _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) - - | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ch1 -# 0x80#)), - 2# #) - - | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch2 -# 0x80#)), - 3# #) - - | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in - if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else - (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch3 -# 0x80#)), - 4# #) - - | otherwise -> fail 1# - where - -- all invalid sequences end up here: - fail :: Int# -> (# Char#, Int# #) - fail nBytes# = (# '\0'#, nBytes# #) - -- '\xFFFD' would be the usual replacement character, but - -- that's a valid symbol in Haskell, so will result in a - -- confusing parse error later on. Instead we use '\0' which - -- will signal a lexer error immediately. - -utf8DecodeChar :: Ptr Word8 -> (Char, Int) -utf8DecodeChar (Ptr a#) = - case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) - --- UTF-8 is cleverly designed so that we can always figure out where --- the start of the current character is, given any position in a --- stream. This function finds the start of the previous character, --- assuming there *is* a previous character. -utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) -utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) - -utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) -utf8CharStart p = go p - where go p = do w <- peek p - if w >= 0x80 && w < 0xC0 - then go (p `plusPtr` (-1)) - else return p - -utf8DecodeByteString :: ByteString -> [Char] -utf8DecodeByteString (BS.PS ptr offset len) - = utf8DecodeStringLazy ptr offset len - -utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] -utf8DecodeStringLazy fptr offset len - = unsafeDupablePerformIO $ unpack start - where - !start = unsafeForeignPtrToPtr fptr `plusPtr` offset - !end = start `plusPtr` len - - unpack p - | p >= end = touchForeignPtr fptr >> return [] - | otherwise = - case utf8DecodeChar# (unPtr p) of - (# c#, nBytes# #) -> do - rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) - return (C# c# : rest) - -countUTF8Chars :: Ptr Word8 -> Int -> IO Int -countUTF8Chars ptr len = go ptr 0 - where - !end = ptr `plusPtr` len - - go p !n - | p >= end = return n - | otherwise = do - case utf8DecodeChar# (unPtr p) of - (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) - -unPtr :: Ptr a -> Addr# -unPtr (Ptr a) = a - -plusPtr# :: Ptr a -> Int# -> Ptr a -plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) - -utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) -utf8EncodeChar c ptr = - let x = ord c in - case () of - _ | x > 0 && x <= 0x007f -> do - poke ptr (fromIntegral x) - return (ptr `plusPtr` 1) - -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we - -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). - | x <= 0x07ff -> do - poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 2) - | x <= 0xffff -> do - poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 3) - | otherwise -> do - poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) - pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 4) - -utf8EncodeString :: Ptr Word8 -> String -> IO () -utf8EncodeString ptr str = go ptr str - where go !_ [] = return () - go ptr (c:cs) = do - ptr' <- utf8EncodeChar c ptr - go ptr' cs - -utf8EncodedLength :: String -> Int -utf8EncodedLength str = go 0 str - where go !n [] = n - go n (c:cs) - | ord c > 0 && ord c <= 0x007f = go (n+1) cs - | ord c <= 0x07ff = go (n+2) cs - | ord c <= 0xffff = go (n+3) cs - | otherwise = go (n+4) cs - --- ----------------------------------------------------------------------------- --- The Z-encoding - -{- -This is the main name-encoding and decoding function. It encodes any -string into a string that is acceptable as a C name. This is done -right before we emit a symbol name into the compiled C or asm code. -Z-encoding of strings is cached in the FastString interface, so we -never encode the same string more than once. - -The basic encoding scheme is this. - -* Tuples (,,,) are coded as Z3T - -* Alphabetic characters (upper and lower) and digits - all translate to themselves; - except 'Z', which translates to 'ZZ' - and 'z', which translates to 'zz' - We need both so that we can preserve the variable/tycon distinction - -* Most other printable characters translate to 'zx' or 'Zx' for some - alphabetic character x - -* The others translate as 'znnnU' where 'nnn' is the decimal number - of the character - - Before After - -------------------------- - Trak Trak - foo_wib foozuwib - > zg - >1 zg1 - foo# foozh - foo## foozhzh - foo##1 foozhzh1 - fooZ fooZZ - :+ ZCzp - () Z0T 0-tuple - (,,,,) Z5T 5-tuple - (# #) Z1H unboxed 1-tuple (note the space) - (#,,,,#) Z5H unboxed 5-tuple - (NB: There is no Z1T nor Z0H.) --} - -type UserString = String -- As the user typed it -type EncodedString = String -- Encoded form - - -zEncodeString :: UserString -> EncodedString -zEncodeString cs = case maybe_tuple cs of - Just n -> n -- Tuples go to Z2T etc - Nothing -> go cs - where - go [] = [] - go (c:cs) = encode_digit_ch c ++ go' cs - go' [] = [] - go' (c:cs) = encode_ch c ++ go' cs - -unencodedChar :: Char -> Bool -- True for chars that don't need encoding -unencodedChar 'Z' = False -unencodedChar 'z' = False -unencodedChar c = c >= 'a' && c <= 'z' - || c >= 'A' && c <= 'Z' - || c >= '0' && c <= '9' - --- If a digit is at the start of a symbol then we need to encode it. --- Otherwise package names like 9pH-0.1 give linker errors. -encode_digit_ch :: Char -> EncodedString -encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c -encode_digit_ch c | otherwise = encode_ch c - -encode_ch :: Char -> EncodedString -encode_ch c | unencodedChar c = [c] -- Common case first - --- Constructors -encode_ch '(' = "ZL" -- Needed for things like (,), and (->) -encode_ch ')' = "ZR" -- For symmetry with ( -encode_ch '[' = "ZM" -encode_ch ']' = "ZN" -encode_ch ':' = "ZC" -encode_ch 'Z' = "ZZ" - --- Variables -encode_ch 'z' = "zz" -encode_ch '&' = "za" -encode_ch '|' = "zb" -encode_ch '^' = "zc" -encode_ch '$' = "zd" -encode_ch '=' = "ze" -encode_ch '>' = "zg" -encode_ch '#' = "zh" -encode_ch '.' = "zi" -encode_ch '<' = "zl" -encode_ch '-' = "zm" -encode_ch '!' = "zn" -encode_ch '+' = "zp" -encode_ch '\'' = "zq" -encode_ch '\\' = "zr" -encode_ch '/' = "zs" -encode_ch '*' = "zt" -encode_ch '_' = "zu" -encode_ch '%' = "zv" -encode_ch c = encode_as_unicode_char c - -encode_as_unicode_char :: Char -> EncodedString -encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str - else '0':hex_str - where hex_str = showHex (ord c) "U" - -- ToDo: we could improve the encoding here in various ways. - -- eg. strings of unicode characters come out as 'z1234Uz5678U', we - -- could remove the 'U' in the middle (the 'z' works as a separator). - -zDecodeString :: EncodedString -> UserString -zDecodeString [] = [] -zDecodeString ('Z' : d : rest) - | isDigit d = decode_tuple d rest - | otherwise = decode_upper d : zDecodeString rest -zDecodeString ('z' : d : rest) - | isDigit d = decode_num_esc d rest - | otherwise = decode_lower d : zDecodeString rest -zDecodeString (c : rest) = c : zDecodeString rest - -decode_upper, decode_lower :: Char -> Char - -decode_upper 'L' = '(' -decode_upper 'R' = ')' -decode_upper 'M' = '[' -decode_upper 'N' = ']' -decode_upper 'C' = ':' -decode_upper 'Z' = 'Z' -decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch - -decode_lower 'z' = 'z' -decode_lower 'a' = '&' -decode_lower 'b' = '|' -decode_lower 'c' = '^' -decode_lower 'd' = '$' -decode_lower 'e' = '=' -decode_lower 'g' = '>' -decode_lower 'h' = '#' -decode_lower 'i' = '.' -decode_lower 'l' = '<' -decode_lower 'm' = '-' -decode_lower 'n' = '!' -decode_lower 'p' = '+' -decode_lower 'q' = '\'' -decode_lower 'r' = '\\' -decode_lower 's' = '/' -decode_lower 't' = '*' -decode_lower 'u' = '_' -decode_lower 'v' = '%' -decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch - --- Characters not having a specific code are coded as z224U (in hex) -decode_num_esc :: Char -> EncodedString -> UserString -decode_num_esc d rest - = go (digitToInt d) rest - where - go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest - go n ('U' : rest) = chr n : zDecodeString rest - go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) - -decode_tuple :: Char -> EncodedString -> UserString -decode_tuple d rest - = go (digitToInt d) rest - where - -- NB. recurse back to zDecodeString after decoding the tuple, because - -- the tuple might be embedded in a longer name. - go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T':rest) = "()" ++ zDecodeString rest - go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest - go 1 ('H':rest) = "(# #)" ++ zDecodeString rest - go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest - go n other = error ("decode_tuple: " ++ show n ++ ' ':other) - -{- -Tuples are encoded as - Z3T or Z3H -for 3-tuples or unboxed 3-tuples respectively. No other encoding starts - Z<digit> - -* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) - There are no unboxed 0-tuples. - -* "()" is the tycon for a boxed 0-tuple. - There are no boxed 1-tuples. --} - -maybe_tuple :: UserString -> Maybe EncodedString - -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") - _ -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : _) -> Just ('Z' : shows (n+1) "T") - _ -> Nothing -maybe_tuple _ = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - - -{- -************************************************************************ -* * - Base 62 -* * -************************************************************************ - -Note [Base 62 encoding 128-bit integers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of base-62 encoding a single 128-bit integer -(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers -(2 * ceil(10.75) characters). Luckily for us, it's the same number of -characters! --} - --------------------------------------------------------------------------- --- Base 62 - --- The base-62 code is based off of 'locators' --- ((c) Operational Dynamics Consulting, BSD3 licensed) - --- | Size of a 64-bit word when written as a base-62 string -word64Base62Len :: Int -word64Base62Len = 11 - --- | Converts a 64-bit word into a base-62 string -toBase62Padded :: Word64 -> String -toBase62Padded w = pad ++ str - where - pad = replicate len '0' - len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) - str = toBase62 w - -toBase62 :: Word64 -> String -toBase62 w = showIntAtBase 62 represent w "" - where - represent :: Int -> Char - represent x - | x < 10 = Char.chr (48 + x) - | x < 36 = Char.chr (65 + x - 10) - | x < 62 = Char.chr (97 + x - 36) - | otherwise = error "represent (base 62): impossible!" diff --git a/compiler/utils/EnumSet.hs b/compiler/utils/EnumSet.hs deleted file mode 100644 index 670a5c64c8..0000000000 --- a/compiler/utils/EnumSet.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' --- things. -module EnumSet - ( EnumSet - , member - , insert - , delete - , toList - , fromList - , empty - ) where - -import GhcPrelude - -import qualified Data.IntSet as IntSet - -newtype EnumSet a = EnumSet IntSet.IntSet - -member :: Enum a => a -> EnumSet a -> Bool -member x (EnumSet s) = IntSet.member (fromEnum x) s - -insert :: Enum a => a -> EnumSet a -> EnumSet a -insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s - -delete :: Enum a => a -> EnumSet a -> EnumSet a -delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s - -toList :: Enum a => EnumSet a -> [a] -toList (EnumSet s) = map toEnum $ IntSet.toList s - -fromList :: Enum a => [a] -> EnumSet a -fromList = EnumSet . IntSet.fromList . map fromEnum - -empty :: EnumSet a -empty = EnumSet IntSet.empty diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs deleted file mode 100644 index 9d9b3ae25c..0000000000 --- a/compiler/utils/Exception.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -module Exception - ( - module Control.Exception, - module Exception - ) - where - -import GhcPrelude - -import Control.Exception -import Control.Monad.IO.Class - -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = Control.Exception.catch - -handleIO :: (IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -tryIO :: IO a -> IO (Either IOException a) -tryIO = try - --- | A monad that can catch exceptions. A minimal definition --- requires a definition of 'gcatch'. --- --- Implementations on top of 'IO' should implement 'gmask' to --- eventually call the primitive 'Control.Exception.mask'. --- These are used for --- implementations that support asynchronous exceptions. The default --- implementations of 'gbracket' and 'gfinally' use 'gmask' --- thus rarely require overriding. --- -class MonadIO m => ExceptionMonad m where - - -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gcatch :: Exception e => m a -> (e -> m a) -> m a - - -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gmask :: ((m a -> m a) -> m b) -> m b - - -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c - - -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gfinally :: m a -> m b -> m a - - gbracket before after thing = - gmask $ \restore -> do - a <- before - r <- restore (thing a) `gonException` after a - _ <- after a - return r - - a `gfinally` sequel = - gmask $ \restore -> do - r <- restore a `gonException` sequel - _ <- sequel - return r - -instance ExceptionMonad IO where - gcatch = Control.Exception.catch - gmask f = mask (\x -> f x) - -gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) -gtry act = gcatch (act >>= \a -> return (Right a)) - (\e -> return (Left e)) - --- | Generalised version of 'Control.Exception.handle', allowing an arbitrary --- exception handling monad instead of just 'IO'. -ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a -ghandle = flip gcatch - --- | Always executes the first argument. If this throws an exception the --- second argument is executed and the exception is raised again. -gonException :: (ExceptionMonad m) => m a -> m b -> m a -gonException ioA cleanup = ioA `gcatch` \e -> - do _ <- cleanup - liftIO $ throwIO (e :: SomeException) - diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs deleted file mode 100644 index f0a35d4100..0000000000 --- a/compiler/utils/FV.hs +++ /dev/null @@ -1,200 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook 2015 - -Utilities for efficiently and deterministically computing free variables. - --} - -{-# LANGUAGE BangPatterns #-} - -module FV ( - -- * Deterministic free vars computations - FV, InterestingVarFun, - - -- * Running the computations - fvVarList, fvVarSet, fvDVarSet, - - -- ** Manipulating those computations - unitFV, - emptyFV, - mkFVs, - unionFV, - unionsFV, - delFV, - delFVs, - filterFV, - mapUnionFV, - ) where - -import GhcPrelude - -import GHC.Types.Var -import GHC.Types.Var.Set - --- | Predicate on possible free variables: returns @True@ iff the variable is --- interesting -type InterestingVarFun = Var -> Bool - --- Note [Deterministic FV] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- When computing free variables, the order in which you get them affects --- the results of floating and specialization. If you use UniqFM to collect --- them and then turn that into a list, you get them in nondeterministic --- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - --- A naive algorithm for free variables relies on merging sets of variables. --- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log --- factor. It's cheaper to incrementally add to a list and use a set to check --- for duplicates. -type FV = InterestingVarFun -- Used for filtering sets as we build them - -> VarSet -- Locally bound variables - -> VarAcc -- Accumulator - -> VarAcc - -type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, - -- so that the list doesn't have duplicates - -- For explanation of why using `VarSet` is not deterministic see - -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - --- Note [FV naming conventions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- To get the performance and determinism that FV provides, FV computations --- need to built up from smaller FV computations and then evaluated with --- one of `fvVarList`, `fvDVarSet` That means the functions --- returning FV need to be exported. --- --- The conventions are: --- --- a) non-deterministic functions: --- * a function that returns VarSet --- e.g. `tyVarsOfType` --- b) deterministic functions: --- * a worker that returns FV --- e.g. `tyFVsOfType` --- * a function that returns [Var] --- e.g. `tyVarsOfTypeList` --- * a function that returns DVarSet --- e.g. `tyVarsOfTypeDSet` --- --- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented --- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet --- respectively. - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order and a non-deterministic set containing --- those variables. -fvVarAcc :: FV -> ([Var], VarSet) -fvVarAcc fv = fv (const True) emptyVarSet ([], emptyVarSet) - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order. -fvVarList :: FV -> [Var] -fvVarList = fst . fvVarAcc - --- | Run a free variable computation, returning a deterministic set of free --- variables. Note that this is just a wrapper around the version that --- returns a deterministic list. If you need a list you should use --- `fvVarList`. -fvDVarSet :: FV -> DVarSet -fvDVarSet = mkDVarSet . fvVarList - --- | Run a free variable computation, returning a non-deterministic set of --- free variables. Don't use if the set will be later converted to a list --- and the order of that list will impact the generated code. -fvVarSet :: FV -> VarSet -fvVarSet = snd . fvVarAcc - --- Note [FV eta expansion] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- Let's consider an eta-reduced implementation of freeVarsOf using FV: --- --- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b --- --- If GHC doesn't eta-expand it, after inlining unionFV we end up with --- --- freeVarsOf = \x -> --- case x of --- App a b -> \fv_cand in_scope acc -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which has to create a thunk, resulting in more allocations. --- --- On the other hand if it is eta-expanded: --- --- freeVarsOf (App a b) fv_cand in_scope acc = --- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc --- --- after inlining unionFV we have: --- --- freeVarsOf = \x fv_cand in_scope acc -> --- case x of --- App a b -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which saves allocations. --- --- GHC when presented with knowledge about all the call sites, correctly --- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets --- exported to be composed with other functions, GHC doesn't have that --- information and has to be more conservative here. --- --- Hence functions that get exported and return FV need to be manually --- eta-expanded. See also #11146. - --- | Add a variable - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -unitFV :: Id -> FV -unitFV var fv_cand in_scope acc@(have, haveSet) - | var `elemVarSet` in_scope = acc - | var `elemVarSet` haveSet = acc - | fv_cand var = (var:have, extendVarSet haveSet var) - | otherwise = acc -{-# INLINE unitFV #-} - --- | Return no free variables. -emptyFV :: FV -emptyFV _ _ acc = acc -{-# INLINE emptyFV #-} - --- | Union two free variable computations. -unionFV :: FV -> FV -> FV -unionFV fv1 fv2 fv_cand in_scope acc = - fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc -{-# INLINE unionFV #-} - --- | Mark the variable as not free by putting it in scope. -delFV :: Var -> FV -> FV -delFV var fv fv_cand !in_scope acc = - fv fv_cand (extendVarSet in_scope var) acc -{-# INLINE delFV #-} - --- | Mark many free variables as not free. -delFVs :: VarSet -> FV -> FV -delFVs vars fv fv_cand !in_scope acc = - fv fv_cand (in_scope `unionVarSet` vars) acc -{-# INLINE delFVs #-} - --- | Filter a free variable computation. -filterFV :: InterestingVarFun -> FV -> FV -filterFV fv_cand2 fv fv_cand1 in_scope acc = - fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc -{-# INLINE filterFV #-} - --- | Map a free variable computation over a list and union the results. -mapUnionFV :: (a -> FV) -> [a] -> FV -mapUnionFV _f [] _fv_cand _in_scope acc = acc -mapUnionFV f (a:as) fv_cand in_scope acc = - mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc -{-# INLINABLE mapUnionFV #-} - --- | Union many free variable computations. -unionsFV :: [FV] -> FV -unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc -{-# INLINE unionsFV #-} - --- | Add multiple variables - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -mkFVs :: [Var] -> FV -mkFVs vars fv_cand in_scope acc = - mapUnionFV unitFV vars fv_cand in_scope acc -{-# INLINE mkFVs #-} diff --git a/compiler/utils/FastFunctions.hs b/compiler/utils/FastFunctions.hs deleted file mode 100644 index 9a09bb7b76..0000000000 --- a/compiler/utils/FastFunctions.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 --} - -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} - -module FastFunctions ( - inlinePerformIO, - ) where - -#include "HsVersions.h" - -import GhcPrelude () - -import GHC.Exts -import GHC.IO (IO(..)) - --- Just like unsafeDupablePerformIO, but we inline it. -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/compiler/utils/FastMutInt.hs b/compiler/utils/FastMutInt.hs deleted file mode 100644 index 20206f8b1e..0000000000 --- a/compiler/utils/FastMutInt.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected --- --- (c) The University of Glasgow 2002-2006 --- --- Unboxed mutable Ints - -module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - - FastMutPtr, newFastMutPtr, - readFastMutPtr, writeFastMutPtr - ) where - -import GhcPrelude - -import Data.Bits -import GHC.Base -import GHC.Ptr - -newFastMutInt :: IO FastMutInt -readFastMutInt :: FastMutInt -> IO Int -writeFastMutInt :: FastMutInt -> Int -> IO () - -newFastMutPtr :: IO FastMutPtr -readFastMutPtr :: FastMutPtr -> IO (Ptr a) -writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () - -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> - case writeIntArray# arr 0# i s of { s -> - (# s, () #) } - -data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) - -newFastMutPtr = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutPtr arr #) } - -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutPtr (FastMutPtr arr) = IO $ \s -> - case readAddrArray# arr 0# s of { (# s, i #) -> - (# s, Ptr i #) } - -writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> - case writeAddrArray# arr 0# i s of { s -> - (# s, () #) } diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs deleted file mode 100644 index 9a74eff16d..0000000000 --- a/compiler/utils/FastString.hs +++ /dev/null @@ -1,693 +0,0 @@ --- (c) The University of Glasgow, 1997-2006 - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, - GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- | --- There are two principal string types used internally by GHC: --- --- ['FastString'] --- --- * A compact, hash-consed, representation of character strings. --- * Comparison is O(1), and you can get a 'Unique.Unique' from them. --- * Generated by 'fsLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. --- --- ['PtrString'] --- --- * Pointer and size of a Latin-1 encoded string. --- * Practically no operations. --- * Outputting them is fast. --- * Generated by 'sLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' --- * Requires manual memory management. --- Improper use may lead to memory leaks or dangling pointers. --- * It assumes Latin-1 as the encoding, therefore it cannot represent --- arbitrary Unicode strings. --- --- Use 'PtrString' unless you want the facilities of 'FastString'. -module FastString - ( - -- * ByteString - bytesFS, -- :: FastString -> ByteString - fastStringToByteString, -- = bytesFS (kept for haddock) - mkFastStringByteString, - fastZStringToByteString, - unsafeMkByteString, - - -- * FastZString - FastZString, - hPutFZS, - zString, - lengthFZS, - - -- * FastStrings - FastString(..), -- not abstract, for now. - - -- ** Construction - fsLit, - mkFastString, - mkFastStringBytes, - mkFastStringByteList, - mkFastStringForeignPtr, - mkFastString#, - - -- ** Deconstruction - unpackFS, -- :: FastString -> String - - -- ** Encoding - zEncodeFS, - - -- ** Operations - uniqueOfFS, - lengthFS, - nullFS, - appendFS, - headFS, - tailFS, - concatFS, - consFS, - nilFS, - isUnderscoreFS, - - -- ** Outputting - hPutFS, - - -- ** Internal - getFastStringTable, - getFastStringZEncCounter, - - -- * PtrStrings - PtrString (..), - - -- ** Construction - sLit, - mkPtrString#, - mkPtrString, - - -- ** Deconstruction - unpackPtrString, - - -- ** Operations - lengthPS - ) where - -#include "HsVersions.h" - -import GhcPrelude as Prelude - -import Encoding -import FastFunctions -import PlainPanic -import Util - -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Foreign.C -import GHC.Exts -import System.IO -import Data.Data -import Data.IORef -import Data.Char -import Data.Semigroup as Semi - -import GHC.IO - -import Foreign - -#if GHC_STAGE >= 2 -import GHC.Conc.Sync (sharedCAF) -#endif - -import GHC.Base ( unpackCString#, unpackNBytes# ) - - --- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' -bytesFS :: FastString -> ByteString -bytesFS f = fs_bs f - -{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} -fastStringToByteString :: FastString -> ByteString -fastStringToByteString = bytesFS - -fastZStringToByteString :: FastZString -> ByteString -fastZStringToByteString (FastZString bs) = bs - --- This will drop information if any character > '\xFF' -unsafeMkByteString :: String -> ByteString -unsafeMkByteString = BSC.pack - -hashFastString :: FastString -> Int -hashFastString (FastString _ _ bs _) - = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - return $ hashStr (castPtr ptr) len - --- ----------------------------------------------------------------------------- - -newtype FastZString = FastZString ByteString - deriving NFData - -hPutFZS :: Handle -> FastZString -> IO () -hPutFZS handle (FastZString bs) = BS.hPut handle bs - -zString :: FastZString -> String -zString (FastZString bs) = - inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen - -lengthFZS :: FastZString -> Int -lengthFZS (FastZString bs) = BS.length bs - -mkFastZStringString :: String -> FastZString -mkFastZStringString str = FastZString (BSC.pack str) - --- ----------------------------------------------------------------------------- - -{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All -'FastString's are stored in a global hashtable to support fast O(1) -comparison. - -It is also associated with a lazy reference to the Z-encoding -of this string which is used by the compiler internally. --} -data FastString = FastString { - uniq :: {-# UNPACK #-} !Int, -- unique id - n_chars :: {-# UNPACK #-} !Int, -- number of chars - fs_bs :: {-# UNPACK #-} !ByteString, - fs_zenc :: FastZString - -- ^ Lazily computed z-encoding of this string. - -- - -- Since 'FastString's are globally memoized this is computed at most - -- once for any given string. - } - -instance Eq FastString where - f1 == f2 = uniq f1 == uniq f2 - -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 - -instance IsString FastString where - fromString = fsLit - -instance Semi.Semigroup FastString where - (<>) = appendFS - -instance Monoid FastString where - mempty = nilFS - mappend = (Semi.<>) - mconcat = concatFS - -instance Show FastString where - show fs = show (unpackFS fs) - -instance Data FastString where - -- don't traverse? - toConstr _ = abstractConstr "FastString" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "FastString" - -instance NFData FastString where - rnf fs = seq fs () - -cmpFS :: FastString -> FastString -> Ordering -cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = - if u1 == u2 then EQ else - compare (bytesFS f1) (bytesFS f2) - -foreign import ccall unsafe "memcmp" - memcmp :: Ptr a -> Ptr b -> Int -> IO Int - --- ----------------------------------------------------------------------------- --- Construction - -{- -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. - -The design of the FastString hash table allows for lockless concurrent reads -and updates to multiple buckets with low synchronization overhead. - -See Note [Updating the FastString table] on how it's updated. --} -data FastStringTable = FastStringTable - {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets - {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets - (Array# (IORef FastStringTableSegment)) -- concurrent segments - -data FastStringTableSegment = FastStringTableSegment - {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment - {-# UNPACK #-} !(IORef Int) -- the number of elements - (MutableArray# RealWorld [FastString]) -- buckets in this segment - -{- -Following parameters are determined based on: - -* Benchmark based on testsuite/tests/utils/should_run/T14854.hs -* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: - on 2018-10-24, we have 13920 entries. --} -segmentBits, numSegments, segmentMask, initialNumBuckets :: Int -segmentBits = 8 -numSegments = 256 -- bit segmentBits -segmentMask = 0xff -- bit segmentBits - 1 -initialNumBuckets = 64 - -hashToSegment# :: Int# -> Int# -hashToSegment# hash# = hash# `andI#` segmentMask# - where - !(I# segmentMask#) = segmentMask - -hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# -hashToIndex# buckets# hash# = - (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# - where - !(I# segmentBits#) = segmentBits - size# = sizeofMutableArray# buckets# - -maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment -maybeResizeSegment segmentRef = do - segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef - let oldSize# = sizeofMutableArray# old# - newSize# = oldSize# *# 2# - (I# n#) <- readIORef counter - if isTrue# (n# <# newSize#) -- maximum load of 1 - then return segment - else do - resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> - case newArray# newSize# [] s1# of - (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) - forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do - fsList <- IO $ readArray# old# i# - forM_ fsList $ \fs -> do - let -- Shall we store in hash value in FastString instead? - !(I# hash#) = hashFastString fs - idx# = hashToIndex# new# hash# - IO $ \s1# -> - case readArray# new# idx# s1# of - (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of - s3# -> (# s3#, () #) - writeIORef segmentRef resizedSegment - return resizedSegment - -{-# NOINLINE stringTable #-} -stringTable :: FastStringTable -stringTable = unsafePerformIO $ do - let !(I# numSegments#) = numSegments - !(I# initialNumBuckets#) = initialNumBuckets - loop a# i# s1# - | isTrue# (i# ==# numSegments#) = s1# - | otherwise = case newMVar () `unIO` s1# of - (# s2#, lock #) -> case newIORef 0 `unIO` s2# of - (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of - (# s4#, buckets# #) -> case newIORef - (FastStringTableSegment lock counter buckets#) `unIO` s4# of - (# s5#, segment #) -> case writeArray# a# i# segment s5# of - s6# -> loop a# (i# +# 1#) s6# - uid <- newIORef 603979776 -- ord '$' * 0x01000000 - n_zencs <- newIORef 0 - tab <- IO $ \s1# -> - case newArray# numSegments# (panic "string_table") s1# of - (# s2#, arr# #) -> case loop arr# 0# s2# of - s3# -> case unsafeFreezeArray# arr# s3# of - (# s4#, segments# #) -> - (# s4#, FastStringTable uid n_zencs segments# #) - - -- use the support wired into the RTS to share this CAF among all images of - -- libHSghc -#if GHC_STAGE < 2 - return tab -#else - sharedCAF tab getOrSetLibHSghcFastStringTable - --- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous --- RTS might not have this symbol -foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" - getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) -#endif - -{- - -We include the FastString table in the `sharedCAF` mechanism because we'd like -FastStrings created by a Core plugin to have the same uniques as corresponding -strings created by the host compiler itself. For example, this allows plugins -to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or -even re-invoke the parser. - -In particular, the following little sanity test was failing in a plugin -prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not -be looked up /by the plugin/. - - let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" - putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts - -`mkTcOcc` involves the lookup (or creation) of a FastString. Since the -plugin's FastString.string_table is empty, constructing the RdrName also -allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These -uniques are almost certainly unequal to the ones that the host compiler -originally assigned to those FastStrings. Thus the lookup fails since the -domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's -unique. - -Maintaining synchronization of the two instances of this global is rather -difficult because of the uses of `unsafePerformIO` in this module. Not -synchronizing them risks breaking the rather major invariant that two -FastStrings with the same unique have the same string. Thus we use the -lower-level `sharedCAF` mechanism that relies on Globals.c. - --} - -mkFastString# :: Addr# -> FastString -mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) - where ptr = Ptr a# - -{- Note [Updating the FastString table] - -We use a concurrent hashtable which contains multiple segments, each hash value -always maps to the same segment. Read is lock-free, write to the a segment -should acquire a lock for that segment to avoid race condition, writes to -different segments are independent. - -The procedure goes like this: - -1. Find out which segment to operate on based on the hash value -2. Read the relevant bucket and perform a look up of the string. -3. If it exists, return it. -4. Otherwise grab a unique ID, create a new FastString and atomically attempt - to update the relevant segment with this FastString: - - * Resize the segment by doubling the number of buckets when the number of - FastStrings in this segment grows beyond the threshold. - * Double check that the string is not in the bucket. Another thread may have - inserted it while we were creating our string. - * Return the existing FastString if it exists. The one we preemptively - created will get GCed. - * Otherwise, insert and return the string we created. --} - -mkFastStringWith - :: (Int -> IORef Int-> IO FastString) -> Ptr Word8 -> Int -> IO FastString -mkFastStringWith mk_fs !ptr !len = do - FastStringTableSegment lock _ buckets# <- readIORef segmentRef - let idx# = hashToIndex# buckets# hash# - bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket len ptr - case res of - Just found -> return found - Nothing -> do - -- The withMVar below is not dupable. It can lead to deadlock if it is - -- only run partially and putMVar is not called after takeMVar. - noDuplicate - n <- get_uid - new_fs <- mk_fs n n_zencs - withMVar lock $ \_ -> insert new_fs - where - !(FastStringTable uid n_zencs segments#) = stringTable - get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) - - !(I# hash#) = hashStr ptr len - (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) - insert fs = do - FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef - let idx# = hashToIndex# buckets# hash# - bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket len ptr - case res of - -- The FastString was added by another thread after previous read and - -- before we acquired the write lock. - Just found -> return found - Nothing -> do - IO $ \s1# -> - case writeArray# buckets# idx# (fs: bucket) s1# of - s2# -> (# s2#, () #) - modifyIORef' counter succ - return fs - -bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) -bucket_match [] _ _ = return Nothing -bucket_match (v@(FastString _ _ bs _):ls) len ptr - | len == BS.length bs = do - b <- BS.unsafeUseAsCString bs $ \buf -> - cmpStringPrefix ptr (castPtr buf) len - if b then return (Just v) - else bucket_match ls len ptr - | otherwise = - bucket_match ls len ptr - -mkFastStringBytes :: Ptr Word8 -> Int -> FastString -mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is - -- idempotent. - unsafeDupablePerformIO $ - mkFastStringWith (copyNewFastString ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString -mkFastStringForeignPtr ptr !fp len - = mkFastStringWith (mkNewFastString fp ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringByteString :: ByteString -> FastString -mkFastStringByteString bs = - inlinePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do - let ptr' = castPtr ptr - mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len - --- | Creates a UTF-8 encoded 'FastString' from a 'String' -mkFastString :: String -> FastString -mkFastString str = - inlinePerformIO $ do - let l = utf8EncodedLength str - buf <- mallocForeignPtrBytes l - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - mkFastStringForeignPtr ptr buf l - --- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ -mkFastStringByteList :: [Word8] -> FastString -mkFastStringByteList str = mkFastStringByteString (BS.pack str) - --- | Creates a (lazy) Z-encoded 'FastString' from a 'String' and account --- the number of forced z-strings into the passed 'IORef'. -mkZFastString :: IORef Int -> ByteString -> FastZString -mkZFastString n_zencs bs = unsafePerformIO $ do - atomicModifyIORef' n_zencs $ \n -> (n+1, ()) - return $ mkFastZStringString (zEncodeString (utf8DecodeByteString bs)) - -mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int - -> IORef Int -> IO FastString -mkNewFastString fp ptr len uid n_zencs = do - let bs = BS.fromForeignPtr fp 0 len - zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int - -> IORef Int -> IO FastString -mkNewFastStringByteString bs ptr len uid n_zencs = do - let zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -copyNewFastString :: Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString -copyNewFastString ptr len uid n_zencs = do - fp <- copyBytesToForeignPtr ptr len - let bs = BS.fromForeignPtr fp 0 len - zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) -copyBytesToForeignPtr ptr len = do - fp <- mallocForeignPtrBytes len - withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len - return fp - -cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -cmpStringPrefix ptr1 ptr2 len = - do r <- memcmp ptr1 ptr2 len - return (r == 0) - -hashStr :: Ptr Word8 -> Int -> Int - -- use the Addr to produce a hash value between 0 & m (inclusive) -hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n = - if isTrue# (n ==# len#) then - I# h - else - let - -- DO NOT move this let binding! indexCharOffAddr# reads from the - -- pointer so we need to evaluate this based on the length check - -- above. Not doing this right caused #17909. - !c = ord# (indexCharOffAddr# a# n) - !h2 = (h *# 16777619#) `xorI#` c - in - loop h2 (n +# 1#) - --- ----------------------------------------------------------------------------- --- Operations - --- | Returns the length of the 'FastString' in characters -lengthFS :: FastString -> Int -lengthFS f = n_chars f - --- | Returns @True@ if the 'FastString' is empty -nullFS :: FastString -> Bool -nullFS f = BS.null (fs_bs f) - --- | Unpacks and decodes the FastString -unpackFS :: FastString -> String -unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs - --- | Returns a Z-encoded version of a 'FastString'. This might be the --- original, if it was already Z-encoded. The first time this --- function is applied to a particular 'FastString', the results are --- memoized. --- -zEncodeFS :: FastString -> FastZString -zEncodeFS (FastString _ _ _ ref) = ref - -appendFS :: FastString -> FastString -> FastString -appendFS fs1 fs2 = mkFastStringByteString - $ BS.append (bytesFS fs1) (bytesFS fs2) - -concatFS :: [FastString] -> FastString -concatFS = mkFastStringByteString . BS.concat . map fs_bs - -headFS :: FastString -> Char -headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" -headFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - return (fst (utf8DecodeChar (castPtr ptr))) - -tailFS :: FastString -> FastString -tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" -tailFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - do let (_, n) = utf8DecodeChar (castPtr ptr) - return $! mkFastStringByteString (BS.drop n bs) - -consFS :: Char -> FastString -> FastString -consFS c fs = mkFastString (c : unpackFS fs) - -uniqueOfFS :: FastString -> Int -uniqueOfFS (FastString u _ _ _) = u - -nilFS :: FastString -nilFS = mkFastString "" - -isUnderscoreFS :: FastString -> Bool -isUnderscoreFS fs = fs == fsLit "_" - --- ----------------------------------------------------------------------------- --- Stats - -getFastStringTable :: IO [[[FastString]]] -getFastStringTable = - forM [0 .. numSegments - 1] $ \(I# i#) -> do - let (# segmentRef #) = indexArray# segments# i# - FastStringTableSegment _ _ buckets# <- readIORef segmentRef - let bucketSize = I# (sizeofMutableArray# buckets#) - forM [0 .. bucketSize - 1] $ \(I# j#) -> - IO $ readArray# buckets# j# - where - !(FastStringTable _ _ segments#) = stringTable - -getFastStringZEncCounter :: IO Int -getFastStringZEncCounter = readIORef n_zencs - where - !(FastStringTable _ n_zencs _) = stringTable - --- ----------------------------------------------------------------------------- --- Outputting 'FastString's - --- |Outputs a 'FastString' with /no decoding at all/, that is, you --- get the actual bytes in the 'FastString' written to the 'Handle'. -hPutFS :: Handle -> FastString -> IO () -hPutFS handle fs = BS.hPut handle $ bytesFS fs - --- ToDo: we'll probably want an hPutFSLocal, or something, to output --- in the current locale's encoding (for error messages and suchlike). - --- ----------------------------------------------------------------------------- --- PtrStrings, here for convenience only. - --- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. -data PtrString = PtrString !(Ptr Word8) !Int - --- | Wrap an unboxed address into a 'PtrString'. -mkPtrString# :: Addr# -> PtrString -mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) - --- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 --- encoding. The original string must not contain non-Latin-1 characters --- (above codepoint @0xff@). -{-# INLINE mkPtrString #-} -mkPtrString :: String -> PtrString -mkPtrString s = - -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks - -- and because someone might be using `eqAddr#` to check for string equality. - unsafePerformIO (do - let len = length s - p <- mallocBytes len - let - loop :: Int -> String -> IO () - loop !_ [] = return () - loop n (c:cs) = do - pokeByteOff p n (fromIntegral (ord c) :: Word8) - loop (1+n) cs - loop 0 s - return (PtrString p len) - ) - --- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. --- This does not free the memory associated with 'PtrString'. -unpackPtrString :: PtrString -> String -unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# - --- | Return the length of a 'PtrString' -lengthPS :: PtrString -> Int -lengthPS (PtrString _ n) = n - --- ----------------------------------------------------------------------------- --- under the carpet - -foreign import ccall unsafe "strlen" - ptrStrLength :: Ptr Word8 -> Int - -{-# NOINLINE sLit #-} -sLit :: String -> PtrString -sLit x = mkPtrString x - -{-# NOINLINE fsLit #-} -fsLit :: String -> FastString -fsLit x = mkFastString x - -{-# RULES "slit" - forall x . sLit (unpackCString# x) = mkPtrString# x #-} -{-# RULES "fslit" - forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs deleted file mode 100644 index bc151f736b..0000000000 --- a/compiler/utils/FastStringEnv.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[FastStringEnv]{@FastStringEnv@: FastString environments} --} - -module FastStringEnv ( - -- * FastString environments (maps) - FastStringEnv, - - -- ** Manipulating these environments - mkFsEnv, - emptyFsEnv, unitFsEnv, - extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, - extendFsEnvList, extendFsEnvList_C, - filterFsEnv, - plusFsEnv, plusFsEnv_C, alterFsEnv, - lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, - elemFsEnv, mapFsEnv, - - -- * Deterministic FastString environments (maps) - DFastStringEnv, - - -- ** Manipulating these environments - mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv - ) where - -import GhcPrelude - -import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM -import Maybes -import FastString - - --- | A non-deterministic set of FastStrings. --- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not --- deterministic and why it matters. Use DFastStringEnv if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code. -type FastStringEnv a = UniqFM a -- Domain is FastString - -emptyFsEnv :: FastStringEnv a -mkFsEnv :: [(FastString,a)] -> FastStringEnv a -alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a -extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a -extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b -extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a -plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a -plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a -extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a -delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a -elemFsEnv :: FastString -> FastStringEnv a -> Bool -unitFsEnv :: FastString -> a -> FastStringEnv a -lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a -lookupFsEnv_NF :: FastStringEnv a -> FastString -> a -filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt -mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 - -emptyFsEnv = emptyUFM -unitFsEnv x y = unitUFM x y -extendFsEnv x y z = addToUFM x y z -extendFsEnvList x l = addListToUFM x l -lookupFsEnv x y = lookupUFM x y -alterFsEnv = alterUFM -mkFsEnv l = listToUFM l -elemFsEnv x y = elemUFM x y -plusFsEnv x y = plusUFM x y -plusFsEnv_C f x y = plusUFM_C f x y -extendFsEnv_C f x y z = addToUFM_C f x y z -mapFsEnv f x = mapUFM f x -extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendFsEnvList_C x y z = addListToUFM_C x y z -delFromFsEnv x y = delFromUFM x y -delListFromFsEnv x y = delListFromUFM x y -filterFsEnv x y = filterUFM x y - -lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) - --- Deterministic FastStringEnv --- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need --- DFastStringEnv. - -type DFastStringEnv a = UniqDFM a -- Domain is FastString - -emptyDFsEnv :: DFastStringEnv a -emptyDFsEnv = emptyUDFM - -dFsEnvElts :: DFastStringEnv a -> [a] -dFsEnvElts = eltsUDFM - -mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a -mkDFsEnv l = listToUDFM l - -lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a -lookupDFsEnv = lookupUDFM diff --git a/compiler/utils/Fingerprint.hs b/compiler/utils/Fingerprint.hs deleted file mode 100644 index 21f6a93c77..0000000000 --- a/compiler/utils/Fingerprint.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- ---------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2006 --- --- Fingerprints for recompilation checking and ABI versioning. --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --- --- ---------------------------------------------------------------------------- - -module Fingerprint ( - readHexFingerprint, - fingerprintByteString, - -- * Re-exported from GHC.Fingerprint - Fingerprint(..), fingerprint0, - fingerprintFingerprints, - fingerprintData, - fingerprintString, - getFileHash - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Foreign -import GHC.IO -import Numeric ( readHex ) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -import GHC.Fingerprint - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafeDupablePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/compiler/utils/FiniteMap.hs b/compiler/utils/FiniteMap.hs deleted file mode 100644 index 0692830932..0000000000 --- a/compiler/utils/FiniteMap.hs +++ /dev/null @@ -1,31 +0,0 @@ --- Some extra functions to extend Data.Map - -module FiniteMap ( - insertList, - insertListWith, - deleteList, - foldRight, foldRightWithKey - ) where - -import GhcPrelude - -import Data.Map (Map) -import qualified Data.Map as Map - -insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt -insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs - -insertListWith :: Ord key - => (elt -> elt -> elt) - -> [(key,elt)] - -> Map key elt - -> Map key elt -insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs - -deleteList :: Ord key => [key] -> Map key elt -> Map key elt -deleteList ks m = foldl' (flip Map.delete) m ks - -foldRight :: (elt -> a -> a) -> a -> Map key elt -> a -foldRight = Map.foldr -foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a -foldRightWithKey = Map.foldrWithKey diff --git a/compiler/utils/GhcPrelude.hs b/compiler/utils/GhcPrelude.hs deleted file mode 100644 index dd78f15573..0000000000 --- a/compiler/utils/GhcPrelude.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Custom GHC "Prelude" --- --- This module serves as a replacement for the "Prelude" module --- and abstracts over differences between the bootstrapping --- GHC version, and may also provide a common default vocabulary. - --- Every module in GHC --- * Is compiled with -XNoImplicitPrelude --- * Explicitly imports GhcPrelude - -module GhcPrelude (module X) where - --- We export the 'Semigroup' class but w/o the (<>) operator to avoid --- clashing with the (Outputable.<>) operator which is heavily used --- through GHC's code-base. - -import Prelude as X hiding ((<>)) -import Data.Foldable as X (foldl') - -{- -Note [Why do we import Prelude here?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and -ghc-heap.cabal contain the directive default-extensions: -NoImplicitPrelude. There are two motivations for this: - - Consistency with the compiler directory, which enables - NoImplicitPrelude; - - Allows loading the above dependent packages with ghc-in-ghci, - giving a smoother development experience when adding new - extensions. --} diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs deleted file mode 100644 index 67c362ff00..0000000000 --- a/compiler/utils/GraphBase.hs +++ /dev/null @@ -1,107 +0,0 @@ - --- | Types for the general graph colorer. -module GraphBase ( - Triv, - Graph (..), - initGraph, - graphMapModify, - - Node (..), newNode, -) - - -where - -import GhcPrelude - -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - - --- | A fn to check if a node is trivially colorable --- For graphs who's color classes are disjoint then a node is 'trivially colorable' --- when it has less neighbors and exclusions than available colors for that node. --- --- For graph's who's color classes overlap, ie some colors alias other colors, then --- this can be a bit more tricky. There is a general way to calculate this, but --- it's likely be too slow for use in the code. The coloring algorithm takes --- a canned function which can be optimised by the user to be specific to the --- specific graph being colored. --- --- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" --- Smith, Ramsey, Holloway - PLDI 2004. --- -type Triv k cls color - = cls -- the class of the node we're trying to color. - -> UniqSet k -- the node's neighbors. - -> UniqSet color -- the node's exclusions. - -> Bool - - --- | The Interference graph. --- There used to be more fields, but they were turfed out in a previous revision. --- maybe we'll want more later.. --- -data Graph k cls color - = Graph { - -- | All active nodes in the graph. - graphMap :: UniqFM (Node k cls color) } - - --- | An empty graph. -initGraph :: Graph k cls color -initGraph - = Graph - { graphMap = emptyUFM } - - --- | Modify the finite map holding the nodes in the graph. -graphMapModify - :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) - -> Graph k cls color -> Graph k cls color - -graphMapModify f graph - = graph { graphMap = f (graphMap graph) } - - - --- | Graph nodes. --- Represents a thing that can conflict with another thing. --- For the register allocater the nodes represent registers. --- -data Node k cls color - = Node { - -- | A unique identifier for this node. - nodeId :: k - - -- | The class of this node, - -- determines the set of colors that can be used. - , nodeClass :: cls - - -- | The color of this node, if any. - , nodeColor :: Maybe color - - -- | Neighbors which must be colored differently to this node. - , nodeConflicts :: UniqSet k - - -- | Colors that cannot be used by this node. - , nodeExclusions :: UniqSet color - - -- | Colors that this node would prefer to be, in descending order. - , nodePreference :: [color] - - -- | Neighbors that this node would like to be colored the same as. - , nodeCoalesce :: UniqSet k } - - --- | An empty node. -newNode :: k -> cls -> Node k cls color -newNode k cls - = Node - { nodeId = k - , nodeClass = cls - , nodeColor = Nothing - , nodeConflicts = emptyUniqSet - , nodeExclusions = emptyUniqSet - , nodePreference = [] - , nodeCoalesce = emptyUniqSet } diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs deleted file mode 100644 index d10b28175c..0000000000 --- a/compiler/utils/GraphColor.hs +++ /dev/null @@ -1,375 +0,0 @@ --- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. --- - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph -) - -where - -import GhcPrelude - -import GraphBase -import GraphOps -import GraphPpr - -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import Outputable - -import Data.Maybe -import Data.List - - --- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. --- -colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced - -- r1 should be replaced by r2 in the source - -colorGraph iterative spinCount colors triv spill graph0 - = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. - -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - - --- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. --- --- Checking whether a node is trivially colorable or not is a reasonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. --- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. --- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. - -colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan - - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce - -colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] - -colorScan_spin - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are available - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound@(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - --- Select: --- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. --- -colorScan_spill - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - - --- | Try to assign a color to all these nodes. - -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. - -assignColors colors graph ks - = assignColors' colors graph [] ks - - where assignColors' _ graph prob [] - = (graph, prob) - - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of - - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks - - - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - - | otherwise - = Nothing - - - --- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. --- -selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ nonDetEltsUniqSet - $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concatMap nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- nonDetEltsUniqSet colors_ok - -- See Note [Unique Determinism and code generation] - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor - - - diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs deleted file mode 100644 index a1693c6a5a..0000000000 --- a/compiler/utils/GraphOps.hs +++ /dev/null @@ -1,682 +0,0 @@ --- | Basic operations on graphs. --- - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import GHC.Types.Unique -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - -import Data.List hiding (union) -import Data.Maybe - --- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) - -lookupNode graph k - = lookupUFM (graphMap graph) k - - --- | Get a node from the graph, throwing an error if it's not there -getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color - -getNode graph k - = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" - - --- | Add a node to the graph, linking up its edges -addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - -addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeConflicts = - addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeCoalesce = - addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - - --- | Delete a node and all its edges from the graph. -delNode :: (Uniquable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) - -delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ nonDetEltsUniqSet (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ nonDetEltsUniqSet (nodeCoalesce node) - -- See Note [Unique Determinism and code generation] - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing - - --- | Modify a node in the graph. --- returns Nothing if the node isn't present. --- -modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) - -modNode f k graph - = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph - - Nothing -> Nothing - - --- | Get the size of the graph, O(n) -size :: Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - - --- | Union two graphs together. -union :: Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } - - --- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. -addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - --- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 - - --- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. -addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- nonDetEltsUniqSet conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ nonDetEltsUniqSet conflicts - -- See Note [Unique Determinism and code generation] - - -addConflictSet1 :: Uniquable k - => k -> (k -> cls) -> UniqSet k - -> UniqFM (Node k cls color) - -> UniqFM (Node k cls color) -addConflictSet1 u getClass set - = case delOneFromUniqSet set u of - set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u - - --- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. -addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u - -addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color - -addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors - - --- | Add a coalescence edge to the graph, creating nodes if required. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 - . addCoalesce u2 c2 u1) - - --- | Delete a coalescence edge (k1 -> k2) from the graph. -delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 - - --- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most preferred. --- The algorithm tries to assign a node it's preferred color if possible. --- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u - - --- | Do aggressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coalesced together. --- for each pair, the resulting node will have the least key and be second in the pair. --- -coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. - -coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - -coalesceGraph' - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool - -> Triv k cls color - -> Graph k cls color - -> [(k, k)] - -> ( Graph k cls color - , [(k, k)]) -coalesceGraph' aggressive triv graph kkPairsAcc - = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] - -- See Note [Unique Determinism and code generation] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) - - --- | Coalesce this pair of nodes unconditionally \/ aggressively. --- The resulting node is the one with the least key. --- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one --- --- Nothing if either of the nodes weren't in the graph - -coalesceNodes - :: (Uniquable k, Ord k, Eq cls) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) - -coalesceNodes_merge - :: (Uniquable k, Eq cls) - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." - - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." - - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing - - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax - - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } - - in coalesceNodes_check aggressive triv graph kMin kMax node - -coalesceNodes_check - :: Uniquable k - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_check aggressive triv graph kMin kMax node - - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) - - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 - - in (graph3, Just (kMax, kMin)) - - --- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. --- -freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen - -freezeNode k - = graphMapModify - $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } - - fm1 = addToUFM fm k node' - - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. - - fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - -- It's OK to use nonDetFoldUFM here because the operation - -- is commutative - $ nodeCoalesce node - - in fm2 - - --- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. --- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. --- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. --- -freezeOneInGraph - :: (Uniquable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze - -freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - - in case candidates of - - -- there wasn't anything available to freeze - [] -> (graph, False) - - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) - - --- | Freeze all the nodes in the graph --- for debugging the iterative allocator. --- -freezeAllInGraph - :: (Uniquable k) - => Graph k cls color - -> Graph k cls color - -freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | Find all the nodes in the graph that meet some criteria --- -scanGraph - :: (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] - -scanGraph match graph - = filter match $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error --- -validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph - -validateGraph doc isColored graph - - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existent nodes" - $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ nonDetEltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph - - --- | If this node is colored, check that all the nodes which --- conflict with it have different colors. -checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - -checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ nonDetEltsUniqSet $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True - - - --- | Slurp out a map of how many nodes had a certain number of conflict neighbours - -slurpNodeConflictCount - :: Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) - -slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ graphMap graph - - --- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - -setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a - -adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - --- Argument order different from UniqFM's adjustUFM -{-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a - -adjustUFM_C f k map - = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) - diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs deleted file mode 100644 index 4327ec881c..0000000000 --- a/compiler/utils/GraphPpr.hs +++ /dev/null @@ -1,173 +0,0 @@ - --- | Pretty printing of graphs. - -module GraphPpr ( - dumpGraph, - dotGraph -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import GHC.Types.Unique -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM - -import Data.List (mapAccumL) -import Data.Maybe - - --- | Pretty print a graph in a somewhat human readable format. -dumpGraph - :: (Outputable k, Outputable color) - => Graph k cls color -> SDoc - -dumpGraph graph - = text "Graph" - $$ pprUFM (graphMap graph) (vcat . map dumpNode) - -dumpNode - :: (Outputable k, Outputable color) - => Node k cls color -> SDoc - -dumpNode node - = text "Node " <> ppr (nodeId node) - $$ text "conflicts " - <> parens (int (sizeUniqSet $ nodeConflicts node)) - <> text " = " - <> ppr (nodeConflicts node) - - $$ text "exclusions " - <> parens (int (sizeUniqSet $ nodeExclusions node)) - <> text " = " - <> ppr (nodeExclusions node) - - $$ text "coalesce " - <> parens (int (sizeUniqSet $ nodeCoalesce node)) - <> text " = " - <> ppr (nodeCoalesce node) - - $$ space - - - --- | Pretty print a graph in graphviz .dot format. --- Conflicts get solid edges. --- Coalescences get dashed edges. -dotGraph - :: ( Uniquable k - , Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) -- ^ What graphviz color to use for each node color - -- It's usually safe to return X11 style colors here, - -- ie "red", "green" etc or a hex triplet #aaff55 etc - -> Triv k cls color - -> Graph k cls color -> SDoc - -dotGraph colorMap triv graph - = let nodes = nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - in vcat - ( [ text "graph G {" ] - ++ map (dotNode colorMap triv) nodes - ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) - ++ [ text "}" - , space ]) - - -dotNode :: ( Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) - -> Triv k cls color - -> Node k cls color -> SDoc - -dotNode colorMap triv node - = let name = ppr $ nodeId node - cls = ppr $ nodeClass node - - excludes - = hcat $ punctuate space - $ map (\n -> text "-" <> ppr n) - $ nonDetEltsUniqSet $ nodeExclusions node - -- See Note [Unique Determinism and code generation] - - preferences - = hcat $ punctuate space - $ map (\n -> text "+" <> ppr n) - $ nodePreference node - - expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] - then empty - else text "\\n" <> (excludes <+> preferences) - - -- if the node has been colored then show that, - -- otherwise indicate whether it looks trivially colorable. - color - | Just c <- nodeColor node - = text "\\n(" <> ppr c <> text ")" - - | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = text "\\n(" <> text "triv" <> text ")" - - | otherwise - = text "\\n(" <> text "spill?" <> text ")" - - label = name <> text " :: " <> cls - <> expref - <> color - - pcolorC = case nodeColor node of - Nothing -> text "style=filled fillcolor=white" - Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) - - - pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" - <> space <> doubleQuotes name - <> text ";" - - in pout - - --- | Nodes in the graph are doubly linked, but we only want one edge for each --- conflict if the graphviz graph. Traverse over the graph, but make sure --- to only print the edges for each node once. - -dotNodeEdges - :: ( Uniquable k - , Outputable k) - => UniqSet k - -> Node k cls color - -> (UniqSet k, Maybe SDoc) - -dotNodeEdges visited node - | elementOfUniqSet (nodeId node) visited - = ( visited - , Nothing) - - | otherwise - = let dconflicts - = map (dotEdgeConflict (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeConflicts node) visited - - dcoalesces - = map (dotEdgeCoalesce (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeCoalesce node) visited - - out = vcat dconflicts - $$ vcat dcoalesces - - in ( addOneToUniqSet visited (nodeId node) - , Just out) - - where dotEdgeConflict u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> text ";" - - dotEdgeCoalesce u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> space <> text "[ style = dashed ];" diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs deleted file mode 100644 index f9da146da5..0000000000 --- a/compiler/utils/IOEnv.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} --- --- (c) The University of Glasgow 2002-2006 --- --- The IO Monad with an environment --- --- The environment is passed around as a Reader monad but --- as its in the IO monad, mutable references can be used --- for updating state. --- - -module IOEnv ( - IOEnv, -- Instance of Monad - - -- Monad utilities - module MonadUtils, - - -- Errors - failM, failWithM, - IOEnvFailure(..), - - -- Getting at the environment - getEnv, setEnv, updEnv, - - runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, - tryM, tryAllM, tryMostM, fixM, - - -- I/O operations - IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' - ) where - -import GhcPrelude - -import GHC.Driver.Session -import Exception -import GHC.Types.Module -import Panic - -import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, - atomicModifyIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO ( fixIO ) -import Control.Monad -import MonadUtils -import Control.Applicative (Alternative(..)) - ----------------------------------------------------------------------- --- Defining the monad type ----------------------------------------------------------------------- - - -newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor) - -unIOEnv :: IOEnv env a -> (env -> IO a) -unIOEnv (IOEnv m) = m - -instance Monad (IOEnv m) where - (>>=) = thenM - (>>) = (*>) - -instance MonadFail (IOEnv m) where - fail _ = failM -- Ignore the string - -instance Applicative (IOEnv m) where - pure = returnM - IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) - (*>) = thenM_ - -returnM :: a -> IOEnv env a -returnM a = IOEnv (\ _ -> return a) - -thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b -thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; - unIOEnv (f r) env }) - -thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b -thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) - -failM :: IOEnv env a -failM = IOEnv (\ _ -> throwIO IOEnvFailure) - -failWithM :: String -> IOEnv env a -failWithM s = IOEnv (\ _ -> ioError (userError s)) - -data IOEnvFailure = IOEnvFailure - -instance Show IOEnvFailure where - show IOEnvFailure = "IOEnv failure" - -instance Exception IOEnvFailure - -instance ExceptionMonad (IOEnv a) where - gcatch act handle = - IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s - gmask f = - IOEnv $ \s -> gmask $ \io_restore -> - let - g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) - in - unIOEnv (f g_restore) s - -instance ContainsDynFlags env => HasDynFlags (IOEnv env) where - getDynFlags = do env <- getEnv - return $! extractDynFlags env - -instance ContainsModule env => HasModule (IOEnv env) where - getModule = do env <- getEnv - return $ extractModule env - ----------------------------------------------------------------------- --- Fundamental combinators specific to the monad ----------------------------------------------------------------------- - - ---------------------------- -runIOEnv :: env -> IOEnv env a -> IO a -runIOEnv env (IOEnv m) = m env - - ---------------------------- -{-# NOINLINE fixM #-} - -- Aargh! Not inlining fixM alleviates a space leak problem. - -- Normally fixM is used with a lazy tuple match: if the optimiser is - -- shown the definition of fixM, it occasionally transforms the code - -- in such a way that the code generator doesn't spot the selector - -- thunks. Sigh. - -fixM :: (a -> IOEnv env a) -> IOEnv env a -fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) - - ---------------------------- -tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) --- Reflect UserError exceptions (only) into IOEnv monad --- Other exceptions are not caught; they are simply propagated as exns --- --- The idea is that errors in the program being compiled will give rise --- to UserErrors. But, say, pattern-match failures in GHC itself should --- not be caught here, else they'll be reported as errors in the program --- begin compiled! -tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) - -tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) -tryIOEnvFailure = try - --- XXX We shouldn't be catching everything, e.g. timeouts -tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) --- Catch *all* exceptions --- This is used when running a Template-Haskell splice, when --- even a pattern-match failure is a programmer error -tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) - -tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) -tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) - ---------------------------- -unsafeInterleaveM :: IOEnv env a -> IOEnv env a -unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) - -uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a -uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) - ----------------------------------------------------------------------- --- Alternative/MonadPlus ----------------------------------------------------------------------- - -instance Alternative (IOEnv env) where - empty = IOEnv (const empty) - m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) - -instance MonadPlus (IOEnv env) - ----------------------------------------------------------------------- --- Accessing input/output ----------------------------------------------------------------------- - -instance MonadIO (IOEnv env) where - liftIO io = IOEnv (\ _ -> io) - -newMutVar :: a -> IOEnv env (IORef a) -newMutVar val = liftIO (newIORef val) - -writeMutVar :: IORef a -> a -> IOEnv env () -writeMutVar var val = liftIO (writeIORef var val) - -readMutVar :: IORef a -> IOEnv env a -readMutVar var = liftIO (readIORef var) - -updMutVar :: IORef a -> (a -> a) -> IOEnv env () -updMutVar var upd = liftIO (modifyIORef var upd) - --- | Atomically update the reference. Does not force the evaluation of the --- new variable contents. For strict update, use 'atomicUpdMutVar''. -atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) - --- | Strict variant of 'atomicUpdMutVar'. -atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) - ----------------------------------------------------------------------- --- Accessing the environment ----------------------------------------------------------------------- - -getEnv :: IOEnv env env -{-# INLINE getEnv #-} -getEnv = IOEnv (\ env -> return env) - --- | Perform a computation with a different environment -setEnv :: env' -> IOEnv env' a -> IOEnv env a -{-# INLINE setEnv #-} -setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) - --- | Perform a computation with an altered environment -updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a -{-# INLINE updEnv #-} -updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/compiler/utils/Json.hs b/compiler/utils/Json.hs deleted file mode 100644 index 2bf00d3851..0000000000 --- a/compiler/utils/Json.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Json where - -import GhcPrelude - -import Outputable -import Data.Char -import Numeric - --- | Simple data type to represent JSON documents. -data JsonDoc where - JSNull :: JsonDoc - JSBool :: Bool -> JsonDoc - JSInt :: Int -> JsonDoc - JSString :: String -> JsonDoc - JSArray :: [JsonDoc] -> JsonDoc - JSObject :: [(String, JsonDoc)] -> JsonDoc - - --- This is simple and slow as it is only used for error reporting -renderJSON :: JsonDoc -> SDoc -renderJSON d = - case d of - JSNull -> text "null" - JSBool b -> text $ if b then "true" else "false" - JSInt n -> ppr n - JSString s -> doubleQuotes $ text $ escapeJsonString s - JSArray as -> brackets $ pprList renderJSON as - JSObject fs -> braces $ pprList renderField fs - where - renderField :: (String, JsonDoc) -> SDoc - renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j - - pprList pp xs = hcat (punctuate comma (map pp xs)) - -escapeJsonString :: String -> String -escapeJsonString = concatMap escapeChar - where - escapeChar '\b' = "\\b" - escapeChar '\f' = "\\f" - escapeChar '\n' = "\\n" - escapeChar '\r' = "\\r" - escapeChar '\t' = "\\t" - escapeChar '"' = "\\\"" - escapeChar '\\' = "\\\\" - escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c - escapeChar c = [c] - - uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) - - pad n cs | len < n = replicate (n-len) '0' ++ cs - | otherwise = cs - where len = length cs - -class ToJson a where - json :: a -> JsonDoc diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs deleted file mode 100644 index 85233c9533..0000000000 --- a/compiler/utils/ListSetOps.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ListSetOps]{Set-like operations on lists} --} - -{-# LANGUAGE CPP #-} - -module ListSetOps ( - unionLists, minusList, deleteBys, - - -- Association lists - Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, - - -- Duplicate handling - hasNoDups, removeDups, findDupsEq, - equivClasses, - - -- Indexing - getNth - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import Util - -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Set as S - -getNth :: Outputable a => [a] -> Int -> a -getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) - xs !! n - -deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] --- (deleteBys eq xs ys) returns xs-ys, using the given equality function --- Just like 'Data.List.delete' but with an equality function -deleteBys eq xs ys = foldl' (flip (L.deleteBy eq)) xs ys - -{- -************************************************************************ -* * - Treating lists as sets - Assumes the lists contain no duplicates, but are unordered -* * -************************************************************************ --} - - --- | Assumes that the arguments contain no duplicates -unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] --- We special case some reasonable common patterns. -unionLists xs [] = xs -unionLists [] ys = ys -unionLists [x] ys - | isIn "unionLists" x ys = ys - | otherwise = x:ys -unionLists xs [y] - | isIn "unionLists" y xs = xs - | otherwise = y:xs -unionLists xs ys - = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) - [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys - --- | Calculate the set difference of two lists. This is --- /O((m + n) log n)/, where we subtract a list of /n/ elements --- from a list of /m/ elements. --- --- Extremely short cases are handled specially: --- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, --- it takes /O(n)/ time. -minusList :: Ord a => [a] -> [a] -> [a] --- There's no point building a set to perform just one lookup, so we handle --- extremely short lists specially. It might actually be better to use --- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). --- The tipping point will be somewhere in the area of where /m/ and /log n/ --- become comparable, but we probably don't want to work too hard on this. -minusList [] _ = [] -minusList xs@[x] ys - | x `elem` ys = [] - | otherwise = xs --- Using an empty set or a singleton would also be silly, so let's not. -minusList xs [] = xs -minusList xs [y] = filter (/= y) xs --- When each list has at least two elements, we build a set from the --- second argument, allowing us to filter the first argument fairly --- efficiently. -minusList xs ys = filter (`S.notMember` yss) xs - where - yss = S.fromList ys - -{- -************************************************************************ -* * -\subsection[Utils-assoc]{Association lists} -* * -************************************************************************ - -Inefficient finite maps based on association lists and equality. --} - --- A finite mapping based on equality and association lists -type Assoc a b = [(a,b)] - -assoc :: (Eq a) => String -> Assoc a b -> a -> b -assocDefault :: (Eq a) => b -> Assoc a b -> a -> b -assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b -assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b -assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b - -assocDefaultUsing _ deflt [] _ = deflt -assocDefaultUsing eq deflt ((k,v) : rest) key - | k `eq` key = v - | otherwise = assocDefaultUsing eq deflt rest key - -assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key -assocDefault deflt list key = assocDefaultUsing (==) deflt list key -assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key - -assocMaybe alist key - = lookup alist - where - lookup [] = Nothing - lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest - -{- -************************************************************************ -* * -\subsection[Utils-dups]{Duplicate-handling} -* * -************************************************************************ --} - -hasNoDups :: (Eq a) => [a] -> Bool - -hasNoDups xs = f [] xs - where - f _ [] = True - f seen_so_far (x:xs) = if x `is_elem` seen_so_far - then False - else f (x:seen_so_far) xs - - is_elem = isIn "hasNoDups" - -equivClasses :: (a -> a -> Ordering) -- Comparison - -> [a] - -> [NonEmpty a] - -equivClasses _ [] = [] -equivClasses _ [stuff] = [stuff :| []] -equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) - where - eq a b = case cmp a b of { EQ -> True; _ -> False } - -removeDups :: (a -> a -> Ordering) -- Comparison function - -> [a] - -> ([a], -- List with no duplicates - [NonEmpty a]) -- List of duplicate groups. One representative - -- from each group appears in the first result - -removeDups _ [] = ([], []) -removeDups _ [x] = ([x],[]) -removeDups cmp xs - = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> - (xs', dups) } - where - collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) - collect_dups dups_so_far (x :| []) = (dups_so_far, x) - collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) - -findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] -findDupsEq _ [] = [] -findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs - | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs - where (eq_xs, neq_xs) = L.partition (eq x) xs diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs deleted file mode 100644 index 37acb25a1a..0000000000 --- a/compiler/utils/Maybes.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module Maybes ( - module Data.Maybe, - - MaybeErr(..), -- Instance of Monad - failME, isSuccess, - - orElse, - firstJust, firstJusts, - whenIsJust, - expectJust, - rightToMaybe, - - -- * MaybeT - MaybeT(..), liftMaybeT, tryMaybeT - ) where - -import GhcPrelude - -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Exception (catch, SomeException(..)) -import Data.Maybe -import Util (HasCallStack) - -infixr 4 `orElse` - -{- -************************************************************************ -* * -\subsection[Maybe type]{The @Maybe@ type} -* * -************************************************************************ --} - -firstJust :: Maybe a -> Maybe a -> Maybe a -firstJust a b = firstJusts [a, b] - --- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or --- @Nothing@ otherwise. -firstJusts :: [Maybe a] -> Maybe a -firstJusts = msum - -expectJust :: HasCallStack => String -> Maybe a -> a -{-# INLINE expectJust #-} -expectJust _ (Just x) = x -expectJust err Nothing = error ("expectJust " ++ err) - -whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () - --- | Flipped version of @fromMaybe@, useful for chaining. -orElse :: Maybe a -> a -> a -orElse = flip fromMaybe - -rightToMaybe :: Either a b -> Maybe b -rightToMaybe (Left _) = Nothing -rightToMaybe (Right x) = Just x - -{- -************************************************************************ -* * -\subsection[MaybeT type]{The @MaybeT@ monad transformer} -* * -************************************************************************ --} - --- We had our own MaybeT in the past. Now we reuse transformer's MaybeT - -liftMaybeT :: Monad m => m a -> MaybeT m a -liftMaybeT act = MaybeT $ Just `liftM` act - --- | Try performing an 'IO' action, failing on error. -tryMaybeT :: IO a -> MaybeT IO a -tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler - where - handler (SomeException _) = return Nothing - -{- -************************************************************************ -* * -\subsection[MaybeErr type]{The @MaybeErr@ type} -* * -************************************************************************ --} - -data MaybeErr err val = Succeeded val | Failed err - deriving (Functor) - -instance Applicative (MaybeErr err) where - pure = Succeeded - (<*>) = ap - -instance Monad (MaybeErr err) where - Succeeded v >>= k = k v - Failed e >>= _ = Failed e - -isSuccess :: MaybeErr err val -> Bool -isSuccess (Succeeded {}) = True -isSuccess (Failed {}) = False - -failME :: err -> MaybeErr err val -failME e = Failed e diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs deleted file mode 100644 index 50e53b98c8..0000000000 --- a/compiler/utils/MonadUtils.hs +++ /dev/null @@ -1,215 +0,0 @@ --- | Utilities related to Monad and Applicative classes --- Mostly for backwards compatibility. - -module MonadUtils - ( Applicative(..) - , (<$>) - - , MonadFix(..) - , MonadIO(..) - - , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM - , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M - , mapAccumLM - , mapSndM - , concatMapM - , mapMaybeM - , fmapMaybeM, fmapEitherM - , anyM, allM, orM - , foldlM, foldlM_, foldrM - , maybeMapM - , whenM, unlessM - , filterOutM - ) where - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - -import GhcPrelude - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Data.Foldable (sequenceA_, foldlM, foldrM) -import Data.List (unzip4, unzip5, zipWith4) - -------------------------------------------------------------------------------- --- Common functions --- These are used throughout the compiler -------------------------------------------------------------------------------- - -{- - -Note [Inline @zipWithNM@ functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same -as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see -Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. - -The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and -`sequenceA` functions with which they are defined have an opportunity to fuse. - -Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly -rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for -more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) -for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning -'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and -'zipWithM_', respectively, with regards to fusion. - -As such, since there are not any differences between 2-ary 'zipWithM'/ -'zipWithM_' and their n-ary counterparts below aside from the number of -arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ -functions below as well. - --} - -zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] -{-# INLINE zipWith3M #-} --- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) - -zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () -{-# INLINE zipWith3M_ #-} --- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) - -zipWith4M :: Monad m => (a -> b -> c -> d -> m e) - -> [a] -> [b] -> [c] -> [d] -> m [e] -{-# INLINE zipWith4M #-} --- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) - -zipWithAndUnzipM :: Monad m - => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) -{-# INLINABLE zipWithAndUnzipM #-} --- See Note [flatten_args performance] in GHC.Tc.Solver.Flatten for why this --- pragma is essential. -zipWithAndUnzipM f (x:xs) (y:ys) - = do { (c, d) <- f x y - ; (cs, ds) <- zipWithAndUnzipM f xs ys - ; return (c:cs, d:ds) } -zipWithAndUnzipM _ _ _ = return ([], []) - -{- - -Note [Inline @mapAndUnzipNM@ functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". -The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` -functions with which it is defined have an opportunity to fuse, see -Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. - -Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a -non-recursive way similarly to 'mapAndUnzipM', and for more than just -uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac -ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', -'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards -to fusion. - -As such, since there are not any differences between 2-ary 'mapAndUnzipM' and -its n-ary counterparts below aside from the number of arguments, the `INLINE` -pragma should be replicated in the @mapAndUnzipNM@ functions below as well. - --} - --- | mapAndUnzipM for triples -mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) -{-# INLINE mapAndUnzip3M #-} --- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip3M f xs = unzip3 <$> traverse f xs - -mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) -{-# INLINE mapAndUnzip4M #-} --- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip4M f xs = unzip4 <$> traverse f xs - -mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) -{-# INLINE mapAndUnzip5M #-} --- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip5M f xs = unzip5 <$> traverse f xs - --- | Monadic version of mapAccumL -mapAccumLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM _ s [] = return (s, []) -mapAccumLM f s (x:xs) = do - (s1, x') <- f s x - (s2, xs') <- mapAccumLM f s1 xs - return (s2, x' : xs') - --- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM _ [] = return [] -mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - --- | Applicative version of mapMaybe -mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = foldr g (pure []) - where g a = liftA2 (maybe id (:)) (f a) - --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - --- | Monadic version of 'any', aborts the computation at the first @True@ value -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = return False -anyM f (x:xs) = do b <- f x - if b then return True - else anyM f xs - --- | Monad version of 'all', aborts the computation at the first @False@ value -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) - --- | Monadic version of or -orM :: Monad m => m Bool -> m Bool -> m Bool -orM m1 m2 = m1 >>= \x -> if x then return True else m2 - --- | Monadic version of foldl that discards its result -foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () -foldlM_ = foldM_ - --- | Monadic version of fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - --- | Monadic version of @when@, taking the condition in the monad -whenM :: Monad m => m Bool -> m () -> m () -whenM mb thing = do { b <- mb - ; when b thing } - --- | Monadic version of @unless@, taking the condition in the monad -unlessM :: Monad m => m Bool -> m () -> m () -unlessM condM acc = do { cond <- condM - ; unless cond acc } - --- | Like 'filterM', only it reverses the sense of the test. -filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] -filterOutM p = - foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs deleted file mode 100644 index 8da5038b2c..0000000000 --- a/compiler/utils/OrdList.hs +++ /dev/null @@ -1,194 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -This is useful, general stuff for the Native Code Generator. - -Provide trees (of instructions), so that lists of instructions -can be appended in linear time. --} -{-# LANGUAGE DeriveFunctor #-} - -{-# LANGUAGE BangPatterns #-} - -module OrdList ( - OrdList, - nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, - headOL, - mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, - strictlyEqOL, strictlyOrdOL -) where - -import GhcPrelude -import Data.Foldable - -import Outputable - -import qualified Data.Semigroup as Semigroup - -infixl 5 `appOL` -infixl 5 `snocOL` -infixr 5 `consOL` - -data OrdList a - = None - | One a - | Many [a] -- Invariant: non-empty - | Cons a (OrdList a) - | Snoc (OrdList a) a - | Two (OrdList a) -- Invariant: non-empty - (OrdList a) -- Invariant: non-empty - deriving (Functor) - -instance Outputable a => Outputable (OrdList a) where - ppr ol = ppr (fromOL ol) -- Convert to list and print that - -instance Semigroup (OrdList a) where - (<>) = appOL - -instance Monoid (OrdList a) where - mempty = nilOL - mappend = (Semigroup.<>) - mconcat = concatOL - -instance Foldable OrdList where - foldr = foldrOL - foldl' = foldlOL - toList = fromOL - null = isNilOL - length = lengthOL - -instance Traversable OrdList where - traverse f xs = toOL <$> traverse f (fromOL xs) - -nilOL :: OrdList a -isNilOL :: OrdList a -> Bool - -unitOL :: a -> OrdList a -snocOL :: OrdList a -> a -> OrdList a -consOL :: a -> OrdList a -> OrdList a -appOL :: OrdList a -> OrdList a -> OrdList a -concatOL :: [OrdList a] -> OrdList a -headOL :: OrdList a -> a -lastOL :: OrdList a -> a -lengthOL :: OrdList a -> Int - -nilOL = None -unitOL as = One as -snocOL as b = Snoc as b -consOL a bs = Cons a bs -concatOL aas = foldr appOL None aas - -headOL None = panic "headOL" -headOL (One a) = a -headOL (Many as) = head as -headOL (Cons a _) = a -headOL (Snoc as _) = headOL as -headOL (Two as _) = headOL as - -lastOL None = panic "lastOL" -lastOL (One a) = a -lastOL (Many as) = last as -lastOL (Cons _ as) = lastOL as -lastOL (Snoc _ a) = a -lastOL (Two _ as) = lastOL as - -lengthOL None = 0 -lengthOL (One _) = 1 -lengthOL (Many as) = length as -lengthOL (Cons _ as) = 1 + length as -lengthOL (Snoc as _) = 1 + length as -lengthOL (Two as bs) = length as + length bs - -isNilOL None = True -isNilOL _ = False - -None `appOL` b = b -a `appOL` None = a -One a `appOL` b = Cons a b -a `appOL` One b = Snoc a b -a `appOL` b = Two a b - -fromOL :: OrdList a -> [a] -fromOL a = go a [] - where go None acc = acc - go (One a) acc = a : acc - go (Cons a b) acc = a : go b acc - go (Snoc a b) acc = go a (b:acc) - go (Two a b) acc = go a (go b acc) - go (Many xs) acc = xs ++ acc - -fromOLReverse :: OrdList a -> [a] -fromOLReverse a = go a [] - -- acc is already in reverse order - where go :: OrdList a -> [a] -> [a] - go None acc = acc - go (One a) acc = a : acc - go (Cons a b) acc = go b (a : acc) - go (Snoc a b) acc = b : go a acc - go (Two a b) acc = go b (go a acc) - go (Many xs) acc = reverse xs ++ acc - -mapOL :: (a -> b) -> OrdList a -> OrdList b -mapOL = fmap - -foldrOL :: (a->b->b) -> b -> OrdList a -> b -foldrOL _ z None = z -foldrOL k z (One x) = k x z -foldrOL k z (Cons x xs) = k x (foldrOL k z xs) -foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs -foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 -foldrOL k z (Many xs) = foldr k z xs - --- | Strict left fold. -foldlOL :: (b->a->b) -> b -> OrdList a -> b -foldlOL _ z None = z -foldlOL k z (One x) = k z x -foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs -foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x -foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 -foldlOL k z (Many xs) = foldl' k z xs - -toOL :: [a] -> OrdList a -toOL [] = None -toOL [x] = One x -toOL xs = Many xs - -reverseOL :: OrdList a -> OrdList a -reverseOL None = None -reverseOL (One x) = One x -reverseOL (Cons a b) = Snoc (reverseOL b) a -reverseOL (Snoc a b) = Cons b (reverseOL a) -reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) -reverseOL (Many xs) = Many (reverse xs) - --- | Compare not only the values but also the structure of two lists -strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool -strictlyEqOL None None = True -strictlyEqOL (One x) (One y) = x == y -strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs -strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs -strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 -strictlyEqOL (Many as) (Many bs) = as == bs -strictlyEqOL _ _ = False - --- | Compare not only the values but also the structure of two lists -strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering -strictlyOrdOL None None = EQ -strictlyOrdOL None _ = LT -strictlyOrdOL (One x) (One y) = compare x y -strictlyOrdOL (One _) _ = LT -strictlyOrdOL (Cons a as) (Cons b bs) = - compare a b `mappend` strictlyOrdOL as bs -strictlyOrdOL (Cons _ _) _ = LT -strictlyOrdOL (Snoc as a) (Snoc bs b) = - compare a b `mappend` strictlyOrdOL as bs -strictlyOrdOL (Snoc _ _) _ = LT -strictlyOrdOL (Two a1 a2) (Two b1 b2) = - (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) -strictlyOrdOL (Two _ _) _ = LT -strictlyOrdOL (Many as) (Many bs) = compare as bs -strictlyOrdOL (Many _ ) _ = GT - - diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs deleted file mode 100644 index d36faa4724..0000000000 --- a/compiler/utils/Outputable.hs +++ /dev/null @@ -1,1304 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-1998 --} - --- | This module defines classes and functions for pretty-printing. It also --- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. --- --- The interface to this module is very similar to the standard Hughes-PJ pretty printing --- module, except that it exports a number of additional functions that are rarely used, --- and works over the 'SDoc' type. -module Outputable ( - -- * Type classes - Outputable(..), OutputableBndr(..), - - -- * Pretty printing combinators - SDoc, runSDoc, initSDocContext, - docToSDoc, - interppSP, interpp'SP, - pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, - pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, - int, intWithCommas, integer, word, float, double, rational, doublePrec, - parens, cparen, brackets, braces, quotes, quote, - doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, vbar, - arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, forAllLit, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - hang, hangNotEmpty, punctuate, ppWhen, ppUnless, - ppWhenOption, ppUnlessOption, - speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, itsOrTheir, - unicodeSyntax, - - coloured, keyword, - - -- * Converting 'SDoc' into strings and outputting it - printSDoc, printSDocLn, printForUser, printForUserPartWay, - printForC, bufLeftRenderSDoc, - pprCode, mkCodeStyle, - showSDoc, showSDocUnsafe, showSDocOneLine, - showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, - showSDocUnqual, showPpr, - renderWithStyle, - - pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsBytes, - - primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, - primInt64Suffix, primWord64Suffix, primIntSuffix, - - pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, - - pprFastFilePath, pprFilePathString, - - -- * Controlling the style in which output is printed - BindingSite(..), - - PprStyle, CodeStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, - reallyAlwaysQualify, reallyAlwaysQualifyNames, - alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, - neverQualify, neverQualifyNames, neverQualifyModules, - alwaysQualifyPackages, neverQualifyPackages, - QualifyName(..), queryQual, - sdocWithDynFlags, sdocOption, - updSDocContext, - SDocContext (..), sdocWithContext, - getPprStyle, withPprStyle, setStyleColoured, - pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - qualName, qualModule, qualPackage, - mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, - mkUserStyle, cmdlineParserStyle, Depth(..), - withUserStyle, withErrStyle, - - ifPprDebug, whenPprDebug, getPprDebug, - - -- * Error handling and debugging utilities - pprPanic, pprSorry, assertPprPanic, pprPgmError, - pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, - pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags, - trace, pgmError, panic, sorry, assertPanic, - pprDebugAndThen, callStackDoc, - ) where - -import GhcPrelude - -import {-# SOURCE #-} GHC.Driver.Session - ( DynFlags, hasPprDebug, hasNoDebugOutput - , pprUserLength - , unsafeGlobalDynFlags, initSDocContext - ) -import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) -import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) - -import BufWrite (BufHandle) -import FastString -import qualified Pretty -import Util -import qualified PprColour as Col -import Pretty ( Doc, Mode(..) ) -import Panic -import GHC.Serialized -import GHC.LanguageExtensions (Extension) - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Char -import qualified Data.Map as M -import Data.Int -import qualified Data.IntMap as IM -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String -import Data.Word -import System.IO ( Handle ) -import System.FilePath -import Text.Printf -import Numeric (showFFloat) -import Data.Graph (SCC(..)) -import Data.List (intersperse) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NEL - -import GHC.Fingerprint -import GHC.Show ( showMultiLineString ) -import GHC.Stack ( callStack, prettyCallStack ) -import Control.Monad.IO.Class -import Exception - -{- -************************************************************************ -* * -\subsection{The @PprStyle@ data type} -* * -************************************************************************ --} - -data PprStyle - = PprUser PrintUnqualified Depth Coloured - -- Pretty-print in a way that will make sense to the - -- ordinary user; must be very close to Haskell - -- syntax, etc. - -- Assumes printing tidied code: non-system names are - -- printed without uniques. - - | PprDump PrintUnqualified - -- For -ddump-foo; less verbose than PprDebug, but more than PprUser - -- Does not assume tidied code: non-external names - -- are printed with uniques. - - | PprDebug -- Full debugging output - - | PprCode CodeStyle - -- Print code; either C or assembler - -data CodeStyle = CStyle -- The format of labels differs for C and assembler - | AsmStyle - -data Depth = AllTheWay - | PartWay Int -- 0 => stop - -data Coloured - = Uncoloured - | Coloured - --- ----------------------------------------------------------------------------- --- Printing original names - --- | When printing code that contains original names, we need to map the --- original names back to something the user understands. This is the --- purpose of the triple of functions that gets passed around --- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { - queryQualifyName :: QueryQualifyName, - queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage -} - --- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify --- it. -type QueryQualifyName = Module -> OccName -> QualifyName - --- | For a given module, we need to know whether to print it with --- a package name to disambiguate it. -type QueryQualifyModule = Module -> Bool - --- | For a given package, we need to know whether to print it with --- the component id to disambiguate it. -type QueryQualifyPackage = UnitId -> Bool - --- See Note [Printing original names] in GHC.Driver.Types -data QualifyName -- Given P:M.T - = NameUnqual -- It's in scope unqualified as "T" - -- OR nothing called "T" is in scope - - | NameQual ModuleName -- It's in scope qualified as "X.T" - - | NameNotInScope1 -- It's not in scope at all, but M.T is not bound - -- in the current scope, so we can refer to it as "M.T" - - | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in - -- the current scope, so we must refer to it as "P:M.T" - -instance Outputable QualifyName where - ppr NameUnqual = text "NameUnqual" - ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( - ppr NameNotInScope1 = text "NameNotInScope1" - ppr NameNotInScope2 = text "NameNotInScope2" - -reallyAlwaysQualifyNames :: QueryQualifyName -reallyAlwaysQualifyNames _ _ = NameNotInScope2 - --- | NB: This won't ever show package IDs -alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames m _ = NameQual (moduleName m) - -neverQualifyNames :: QueryQualifyName -neverQualifyNames _ _ = NameUnqual - -alwaysQualifyModules :: QueryQualifyModule -alwaysQualifyModules _ = True - -neverQualifyModules :: QueryQualifyModule -neverQualifyModules _ = False - -alwaysQualifyPackages :: QueryQualifyPackage -alwaysQualifyPackages _ = True - -neverQualifyPackages :: QueryQualifyPackage -neverQualifyPackages _ = False - -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified -reallyAlwaysQualify - = QueryQualify reallyAlwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -alwaysQualify = QueryQualify alwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -neverQualify = QueryQualify neverQualifyNames - neverQualifyModules - neverQualifyPackages - -defaultUserStyle :: DynFlags -> PprStyle -defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay - -defaultDumpStyle :: DynFlags -> PprStyle - -- Print without qualifiers to reduce verbosity, unless -dppr-debug -defaultDumpStyle dflags - | hasPprDebug dflags = PprDebug - | otherwise = PprDump neverQualify - -mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkDumpStyle dflags print_unqual - | hasPprDebug dflags = PprDebug - | otherwise = PprDump print_unqual - -defaultErrStyle :: DynFlags -> PprStyle --- Default style for error messages, when we don't know PrintUnqualified --- It's a bit of a hack because it doesn't take into account what's in scope --- Only used for desugarer warnings, and typechecker errors in interface sigs --- NB that -dppr-debug will still get into PprDebug style -defaultErrStyle dflags = mkErrStyle dflags neverQualify - --- | Style for printing error messages -mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkErrStyle dflags qual = - mkUserStyle dflags qual (PartWay (pprUserLength dflags)) - -cmdlineParserStyle :: DynFlags -> PprStyle -cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay - -mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle -mkUserStyle dflags unqual depth - | hasPprDebug dflags = PprDebug - | otherwise = PprUser unqual depth Uncoloured - -withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc -withUserStyle unqual depth doc = sdocOption sdocPprDebug $ \case - True -> withPprStyle PprDebug doc - False -> withPprStyle (PprUser unqual depth Uncoloured) doc - -withErrStyle :: PrintUnqualified -> SDoc -> SDoc -withErrStyle unqual doc = - sdocWithDynFlags $ \dflags -> - withPprStyle (mkErrStyle dflags unqual) doc - -setStyleColoured :: Bool -> PprStyle -> PprStyle -setStyleColoured col style = - case style of - PprUser q d _ -> PprUser q d c - _ -> style - where - c | col = Coloured - | otherwise = Uncoloured - -instance Outputable PprStyle where - ppr (PprUser {}) = text "user-style" - ppr (PprCode {}) = text "code-style" - ppr (PprDump {}) = text "dump-style" - ppr (PprDebug {}) = text "debug-style" - -{- -Orthogonal to the above printing styles are (possibly) some -command-line flags that affect printing (often carried with the -style). The most likely ones are variations on how much type info is -shown. - -The following test decides whether or not we are actually generating -code (either C or assembly), or generating interface files. - -************************************************************************ -* * -\subsection{The @SDoc@ data type} -* * -************************************************************************ --} - --- | Represents a pretty-printable document. --- --- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', --- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the --- abstraction layer. -newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } - -data SDocContext = SDC - { sdocStyle :: !PprStyle - , sdocColScheme :: !Col.Scheme - , sdocLastColour :: !Col.PprColour - -- ^ The most recently used colour. - -- This allows nesting colours. - , sdocShouldUseColor :: !Bool - , sdocLineLength :: !Int - , sdocCanUseUnicode :: !Bool - -- ^ True if Unicode encoding is supported - -- and not disable by GHC_NO_UNICODE environment variable - , sdocHexWordLiterals :: !Bool - , sdocPprDebug :: !Bool - , sdocPrintUnicodeSyntax :: !Bool - , sdocPrintCaseAsLet :: !Bool - , sdocPrintTypecheckerElaboration :: !Bool - , sdocPrintAxiomIncomps :: !Bool - , sdocPrintExplicitKinds :: !Bool - , sdocPrintExplicitCoercions :: !Bool - , sdocPrintExplicitRuntimeReps :: !Bool - , sdocPrintExplicitForalls :: !Bool - , sdocPrintPotentialInstances :: !Bool - , sdocPrintEqualityRelations :: !Bool - , sdocSuppressTicks :: !Bool - , sdocSuppressTypeSignatures :: !Bool - , sdocSuppressTypeApplications :: !Bool - , sdocSuppressIdInfo :: !Bool - , sdocSuppressCoercions :: !Bool - , sdocSuppressUnfoldings :: !Bool - , sdocSuppressVarKinds :: !Bool - , sdocSuppressUniques :: !Bool - , sdocSuppressModulePrefixes :: !Bool - , sdocSuppressStgExts :: !Bool - , sdocErrorSpans :: !Bool - , sdocStarIsType :: !Bool - , sdocImpredicativeTypes :: !Bool - , sdocDynFlags :: DynFlags -- TODO: remove - } - -instance IsString SDoc where - fromString = text - --- The lazy programmer's friend. -instance Outputable SDoc where - ppr = id - - -withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} - -pprDeeper :: SDoc -> SDoc -pprDeeper d = SDoc $ \ctx -> case ctx of - SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." - SDC{sdocStyle=PprUser q (PartWay n) c} -> - runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - _ -> runSDoc d ctx - --- | Truncate a list that is longer than the current depth. -pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -pprDeeperList f ds - | null ds = f [] - | otherwise = SDoc work - where - work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} - | n==0 = Pretty.text "..." - | otherwise = - runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - work other_ctx = runSDoc (f ds) other_ctx - -pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc = SDoc $ \ctx -> - case ctx of - SDC{sdocStyle=PprUser q _ c} -> - runSDoc doc ctx{sdocStyle = PprUser q depth c} - _ -> - runSDoc doc ctx - -getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx - -sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc -sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx - -sdocWithContext :: (SDocContext -> SDoc) -> SDoc -sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx - -sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc -sdocOption f g = sdocWithContext (g . f) - -updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc -updSDocContext upd doc - = SDoc $ \ctx -> runSDoc doc (upd ctx) - -qualName :: PprStyle -> QueryQualifyName -qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ -qualName (PprDump q) mod occ = queryQualifyName q mod occ -qualName _other mod _ = NameQual (moduleName mod) - -qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser q _ _) m = queryQualifyModule q m -qualModule (PprDump q) m = queryQualifyModule q m -qualModule _other _m = True - -qualPackage :: PprStyle -> QueryQualifyPackage -qualPackage (PprUser q _ _) m = queryQualifyPackage q m -qualPackage (PprDump q) m = queryQualifyPackage q m -qualPackage _other _m = True - -queryQual :: PprStyle -> PrintUnqualified -queryQual s = QueryQualify (qualName s) - (qualModule s) - (qualPackage s) - -codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False - -asmStyle :: PprStyle -> Bool -asmStyle (PprCode AsmStyle) = True -asmStyle _other = False - -dumpStyle :: PprStyle -> Bool -dumpStyle (PprDump {}) = True -dumpStyle _other = False - -debugStyle :: PprStyle -> Bool -debugStyle PprDebug = True -debugStyle _other = False - -userStyle :: PprStyle -> Bool -userStyle (PprUser {}) = True -userStyle _other = False - -getPprDebug :: (Bool -> SDoc) -> SDoc -getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) - -ifPprDebug :: SDoc -> SDoc -> SDoc --- ^ Says what to do with and without -dppr-debug -ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no - -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style --- ^ Says what to do with -dppr-debug; without, return empty -whenPprDebug d = ifPprDebug d empty - --- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the --- terminal doesn't get screwed up by the ANSI color codes if an exception --- is thrown during pretty-printing. -printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO () -printSDoc ctx mode handle doc = - Pretty.printDoc_ mode cols handle (runSDoc doc ctx) - `finally` - Pretty.printDoc_ mode cols handle - (runSDoc (coloured Col.colReset empty) ctx) - where - cols = sdocLineLength ctx - --- | Like 'printSDoc' but appends an extra newline. -printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO () -printSDocLn ctx mode handle doc = - printSDoc ctx mode handle (doc $$ text "") - -printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () -printForUser dflags handle unqual doc - = printSDocLn ctx PageMode handle doc - where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay) - -printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc - -> IO () -printForUserPartWay dflags handle d unqual doc - = printSDocLn ctx PageMode handle doc - where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d)) - --- | Like 'printSDocLn' but specialized with 'LeftMode' and --- @'PprCode' 'CStyle'@. This is typically used to output C-- code. -printForC :: DynFlags -> Handle -> SDoc -> IO () -printForC dflags handle doc = - printSDocLn ctx LeftMode handle doc - where ctx = initSDocContext dflags (PprCode CStyle) - --- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that --- outputs to a 'BufHandle'. -bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () -bufLeftRenderSDoc ctx bufHandle doc = - Pretty.bufLeftRender bufHandle (runSDoc doc ctx) - -pprCode :: CodeStyle -> SDoc -> SDoc -pprCode cs d = withPprStyle (PprCode cs) d - -mkCodeStyle :: CodeStyle -> PprStyle -mkCodeStyle = PprCode - --- Can't make SDoc an instance of Show because SDoc is just a function type --- However, Doc *is* an instance of Show --- showSDoc just blasts it out as a string -showSDoc :: DynFlags -> SDoc -> String -showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags (defaultUserStyle dflags)) sdoc - --- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be --- initialised yet. -showSDocUnsafe :: SDoc -> String -showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc - -showPpr :: Outputable a => DynFlags -> a -> String -showPpr dflags thing = showSDoc dflags (ppr thing) - -showSDocUnqual :: DynFlags -> SDoc -> String --- Only used by Haddock -showSDocUnqual dflags sdoc = showSDoc dflags sdoc - -showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String --- Allows caller to specify the PrintUnqualified to use -showSDocForUser dflags unqual doc - = renderWithStyle (initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)) doc - -showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithStyle (initSDocContext dflags (defaultDumpStyle dflags)) d - -showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = renderWithStyle (initSDocContext dflags PprDebug) d - -renderWithStyle :: SDocContext -> SDoc -> String -renderWithStyle ctx sdoc - = let s = Pretty.style{ Pretty.mode = PageMode, - Pretty.lineLength = sdocLineLength ctx } - in Pretty.renderStyle s $ runSDoc sdoc ctx - --- This shows an SDoc, but on one line only. It's cheaper than a full --- showSDoc, designed for when we're getting results like "Foo.bar" --- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: SDocContext -> SDoc -> String -showSDocOneLine ctx d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = sdocLineLength ctx } in - Pretty.renderStyle s $ - runSDoc d ctx - -showSDocDumpOneLine :: DynFlags -> SDoc -> String -showSDocDumpOneLine dflags d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = irrelevantNCols } in - Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) - -irrelevantNCols :: Int --- Used for OneLineMode and LeftMode when number of cols isn't used -irrelevantNCols = 1 - -isEmpty :: SDocContext -> SDoc -> Bool -isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocStyle = PprDebug}) - -docToSDoc :: Doc -> SDoc -docToSDoc d = SDoc (\_ -> d) - -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -empty = docToSDoc $ Pretty.empty -char c = docToSDoc $ Pretty.char c - -text s = docToSDoc $ Pretty.text s -{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire - -ftext s = docToSDoc $ Pretty.ftext s -ptext s = docToSDoc $ Pretty.ptext s -ztext s = docToSDoc $ Pretty.ztext s -int n = docToSDoc $ Pretty.int n -integer n = docToSDoc $ Pretty.integer n -float n = docToSDoc $ Pretty.float n -double n = docToSDoc $ Pretty.double n -rational n = docToSDoc $ Pretty.rational n - -- See Note [Print Hexadecimal Literals] in Pretty.hs -word n = sdocOption sdocHexWordLiterals $ \case - True -> docToSDoc $ Pretty.hex n - False -> docToSDoc $ Pretty.integer n - --- | @doublePrec p n@ shows a floating point number @n@ with @p@ --- digits of precision after the decimal point. -doublePrec :: Int -> Double -> SDoc -doublePrec p n = text (showFFloat (Just p) n "") - -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc - -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d -angleBrackets d = char '<' <> d <> char '>' - -cparen :: Bool -> SDoc -> SDoc -cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d - --- 'quotes' encloses something in single quotes... --- but it omits them if the thing begins or ends in a single quote --- so that we don't get `foo''. Instead we just have foo'. -quotes d = sdocOption sdocCanUseUnicode $ \case - True -> char '‘' <> d <> char '’' - False -> SDoc $ \sty -> - let pp_d = runSDoc d sty - str = show pp_d - in case (str, lastMaybe str) of - (_, Just '\'') -> pp_d - ('\'' : _, _) -> pp_d - _other -> Pretty.quotes pp_d - -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc - -blankLine = docToSDoc $ Pretty.text "" -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space -underscore = char '_' -dot = char '.' -vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace - -forAllLit :: SDoc -forAllLit = unicodeSyntax (char '∀') (text "forall") - -bullet :: SDoc -bullet = unicode (char '•') (char '*') - -unicodeSyntax :: SDoc -> SDoc -> SDoc -unicodeSyntax unicode plain = - sdocOption sdocCanUseUnicode $ \can_use_unicode -> - sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax -> - if can_use_unicode && print_unicode_syntax - then unicode - else plain - -unicode :: SDoc -> SDoc -> SDoc -unicode unicode plain = sdocOption sdocCanUseUnicode $ \case - True -> unicode - False -> plain - -nest :: Int -> SDoc -> SDoc --- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line -($+$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically - -nest n d = SDoc $ Pretty.nest n . runSDoc d -(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) -(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) -($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) -($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) - -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits -cat :: [SDoc] -> SDoc --- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc --- ^ A paragraph-fill combinator. It's much like sep, only it --- keeps fitting things on one line until it can't fit any more. -fcat :: [SDoc] -> SDoc --- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' - - -hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] -hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] -vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] -sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] -cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] -fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] -fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] - -hang :: SDoc -- ^ The header - -> Int -- ^ Amount to indent the hung body - -> SDoc -- ^ The hung body, indented and placed below the header - -> SDoc -hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) - --- | This behaves like 'hang', but does not indent the second document --- when the header is empty. -hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc -hangNotEmpty d1 n d2 = - SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) - -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list -punctuate _ [] = [] -punctuate p (d:ds) = go d ds - where - go d [] = [d] - go d (e:es) = (d <> p) : go e es - -ppWhen, ppUnless :: Bool -> SDoc -> SDoc -ppWhen True doc = doc -ppWhen False _ = empty - -ppUnless True _ = empty -ppUnless False doc = doc - -ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppWhenOption f doc = sdocOption f $ \case - True -> doc - False -> empty - -ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppUnlessOption f doc = sdocOption f $ \case - True -> empty - False -> doc - --- | Apply the given colour\/style for the argument. --- --- Only takes effect if colours are enabled. -coloured :: Col.PprColour -> SDoc -> SDoc -coloured col sdoc = sdocOption sdocShouldUseColor $ \case - True -> SDoc $ \case - ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } -> - let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in - Pretty.zeroWidthText (Col.renderColour col) - Pretty.<> runSDoc sdoc ctx' - Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) - ctx -> runSDoc sdoc ctx - False -> sdoc - -keyword :: SDoc -> SDoc -keyword = coloured Col.colBold - -{- -************************************************************************ -* * -\subsection[Outputable-class]{The @Outputable@ class} -* * -************************************************************************ --} - --- | Class designating that some type has an 'SDoc' representation -class Outputable a where - ppr :: a -> SDoc - pprPrec :: Rational -> a -> SDoc - -- 0 binds least tightly - -- We use Rational because there is always a - -- Rational between any other two Rationals - - ppr = pprPrec 0 - pprPrec _ = ppr - -instance Outputable Char where - ppr c = text [c] - -instance Outputable Bool where - ppr True = text "True" - ppr False = text "False" - -instance Outputable Ordering where - ppr LT = text "LT" - ppr EQ = text "EQ" - ppr GT = text "GT" - -instance Outputable Int32 where - ppr n = integer $ fromIntegral n - -instance Outputable Int64 where - ppr n = integer $ fromIntegral n - -instance Outputable Int where - ppr n = int n - -instance Outputable Integer where - ppr n = integer n - -instance Outputable Word16 where - ppr n = integer $ fromIntegral n - -instance Outputable Word32 where - ppr n = integer $ fromIntegral n - -instance Outputable Word where - ppr n = integer $ fromIntegral n - -instance Outputable Float where - ppr f = float f - -instance Outputable Double where - ppr f = double f - -instance Outputable () where - ppr _ = text "()" - -instance (Outputable a) => Outputable [a] where - ppr xs = brackets (fsep (punctuate comma (map ppr xs))) - -instance (Outputable a) => Outputable (NonEmpty a) where - ppr = ppr . NEL.toList - -instance (Outputable a) => Outputable (Set a) where - ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) - -instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) - -instance Outputable a => Outputable (Maybe a) where - ppr Nothing = text "Nothing" - ppr (Just x) = text "Just" <+> ppr x - -instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = text "Left" <+> ppr x - ppr (Right y) = text "Right" <+> ppr y - --- ToDo: may not be used -instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where - ppr (x,y,z) = - parens (sep [ppr x <> comma, - ppr y <> comma, - ppr z ]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d) => - Outputable (a, b, c, d) where - ppr (a,b,c,d) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => - Outputable (a, b, c, d, e) where - ppr (a,b,c,d,e) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => - Outputable (a, b, c, d, e, f) where - ppr (a,b,c,d,e,f) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => - Outputable (a, b, c, d, e, f, g) where - ppr (a,b,c,d,e,f,g) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f <> comma, - ppr g]) - -instance Outputable FastString where - ppr fs = ftext fs -- Prints an unadorned string, - -- no double quotes or anything - -instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where - ppr m = ppr (M.toList m) -instance (Outputable elt) => Outputable (IM.IntMap elt) where - ppr m = ppr (IM.toList m) - -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) - -instance Outputable a => Outputable (SCC a) where - ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) - ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) - -instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) - -instance Outputable Extension where - ppr = text . show - -{- -************************************************************************ -* * -\subsection{The @OutputableBndr@ class} -* * -************************************************************************ --} - --- | 'BindingSite' is used to tell the thing that prints binder what --- language construct is binding the identifier. This can be used --- to decide how much info to print. --- Also see Note [Binding-site specific printing] in GHC.Core.Ppr -data BindingSite - = LambdaBind -- ^ The x in (\x. e) - | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } - | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } - | LetBind -- ^ The x in (let x = rhs in e) - --- | When we print a binder, we often want to print its type too. --- The @OutputableBndr@ class encapsulates this idea. -class Outputable a => OutputableBndr a where - pprBndr :: BindingSite -> a -> SDoc - pprBndr _b x = ppr x - - pprPrefixOcc, pprInfixOcc :: a -> SDoc - -- Print an occurrence of the name, suitable either in the - -- prefix position of an application, thus (f a b) or ((+) x) - -- or infix position, thus (a `f` b) or (x + y) - - bndrIsJoin_maybe :: a -> Maybe Int - bndrIsJoin_maybe _ = Nothing - -- When pretty-printing we sometimes want to find - -- whether the binder is a join point. You might think - -- we could have a function of type (a->Var), but Var - -- isn't available yet, alas - -{- -************************************************************************ -* * -\subsection{Random printing helpers} -* * -************************************************************************ --} - --- We have 31-bit Chars and will simply use Show instances of Char and String. - --- | Special combinator for showing character literals. -pprHsChar :: Char -> SDoc -pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) - | otherwise = text (show c) - --- | Special combinator for showing string literals. -pprHsString :: FastString -> SDoc -pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) - --- | Special combinator for showing bytestring literals. -pprHsBytes :: ByteString -> SDoc -pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs - in vcat (map text (showMultiLineString escaped)) <> char '#' - where escape :: Word8 -> String - escape w = let c = chr (fromIntegral w) - in if isAscii c - then [c] - else '\\' : show w - --- Postfix modifiers for unboxed literals. --- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. -primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc -primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc -primCharSuffix = char '#' -primFloatSuffix = char '#' -primIntSuffix = char '#' -primDoubleSuffix = text "##" -primWordSuffix = text "##" -primInt64Suffix = text "L#" -primWord64Suffix = text "L##" - --- | Special combinator for showing unboxed literals. -pprPrimChar :: Char -> SDoc -pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc -pprPrimChar c = pprHsChar c <> primCharSuffix -pprPrimInt i = integer i <> primIntSuffix -pprPrimWord w = word w <> primWordSuffix -pprPrimInt64 i = integer i <> primInt64Suffix -pprPrimWord64 w = word w <> primWord64Suffix - ---------------------- --- Put a name in parens if it's an operator -pprPrefixVar :: Bool -> SDoc -> SDoc -pprPrefixVar is_operator pp_v - | is_operator = parens pp_v - | otherwise = pp_v - --- Put a name in backquotes if it's not an operator -pprInfixVar :: Bool -> SDoc -> SDoc -pprInfixVar is_operator pp_v - | is_operator = pp_v - | otherwise = char '`' <> pp_v <> char '`' - ---------------------- -pprFastFilePath :: FastString -> SDoc -pprFastFilePath path = text $ normalise $ unpackFS path - --- | Normalise, escape and render a string representing a path --- --- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc -pprFilePathString path = doubleQuotes $ text (escape (normalise path)) - where - escape [] = [] - escape ('\\':xs) = '\\':'\\':escape xs - escape (x:xs) = x:escape xs - -{- -************************************************************************ -* * -\subsection{Other helper functions} -* * -************************************************************************ --} - -pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- comma-separated and finally packed into a paragraph. -pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) - -pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- bar-separated and finally packed into a paragraph. -pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) - --- | Returns the separated concatenation of the pretty printed things. -interppSP :: Outputable a => [a] -> SDoc -interppSP xs = sep (map ppr xs) - --- | Returns the comma-separated concatenation of the pretty printed things. -interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = sep (punctuate comma (map ppr xs)) - --- | Returns the comma-separated concatenation of the quoted pretty printed things. --- --- > [x,y,z] ==> `x', `y', `z' -pprQuotedList :: Outputable a => [a] -> SDoc -pprQuotedList = quotedList . map ppr - -quotedList :: [SDoc] -> SDoc -quotedList xs = fsep (punctuate comma (map quotes xs)) - -quotedListWithOr :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' or `z' -quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) -quotedListWithOr xs = quotedList xs - -quotedListWithNor :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' nor `z' -quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) -quotedListWithNor xs = quotedList xs - -{- -************************************************************************ -* * -\subsection{Printing numbers verbally} -* * -************************************************************************ --} - -intWithCommas :: Integral a => a -> SDoc --- Prints a big integer with commas, eg 345,821 -intWithCommas n - | n < 0 = char '-' <> intWithCommas (-n) - | q == 0 = int (fromIntegral r) - | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) - where - (q,r) = n `quotRem` 1000 - zeroes | r >= 100 = empty - | r >= 10 = char '0' - | otherwise = text "00" - --- | Converts an integer to a verbal index: --- --- > speakNth 1 = text "first" --- > speakNth 5 = text "fifth" --- > speakNth 21 = text "21st" -speakNth :: Int -> SDoc -speakNth 1 = text "first" -speakNth 2 = text "second" -speakNth 3 = text "third" -speakNth 4 = text "fourth" -speakNth 5 = text "fifth" -speakNth 6 = text "sixth" -speakNth n = hcat [ int n, text suffix ] - where - suffix | n <= 20 = "th" -- 11,12,13 are non-std - | last_dig == 1 = "st" - | last_dig == 2 = "nd" - | last_dig == 3 = "rd" - | otherwise = "th" - - last_dig = n `rem` 10 - --- | Converts an integer to a verbal multiplicity: --- --- > speakN 0 = text "none" --- > speakN 5 = text "five" --- > speakN 10 = text "10" -speakN :: Int -> SDoc -speakN 0 = text "none" -- E.g. "he has none" -speakN 1 = text "one" -- E.g. "he has one" -speakN 2 = text "two" -speakN 3 = text "three" -speakN 4 = text "four" -speakN 5 = text "five" -speakN 6 = text "six" -speakN n = int n - --- | Converts an integer and object description to a statement about the --- multiplicity of those objects: --- --- > speakNOf 0 (text "melon") = text "no melons" --- > speakNOf 1 (text "melon") = text "one melon" --- > speakNOf 3 (text "melon") = text "three melons" -speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = text "no" <+> d <> char 's' -speakNOf 1 d = text "one" <+> d -- E.g. "one argument" -speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" - --- | Determines the pluralisation suffix appropriate for the length of a list: --- --- > plural [] = char 's' --- > plural ["Hello"] = empty --- > plural ["Hello", "World"] = char 's' -plural :: [a] -> SDoc -plural [_] = empty -- a bit frightening, but there you are -plural _ = char 's' - --- | Determines the form of to be appropriate for the length of a list: --- --- > isOrAre [] = text "are" --- > isOrAre ["Hello"] = text "is" --- > isOrAre ["Hello", "World"] = text "are" -isOrAre :: [a] -> SDoc -isOrAre [_] = text "is" -isOrAre _ = text "are" - --- | Determines the form of to do appropriate for the length of a list: --- --- > doOrDoes [] = text "do" --- > doOrDoes ["Hello"] = text "does" --- > doOrDoes ["Hello", "World"] = text "do" -doOrDoes :: [a] -> SDoc -doOrDoes [_] = text "does" -doOrDoes _ = text "do" - --- | Determines the form of possessive appropriate for the length of a list: --- --- > itsOrTheir [x] = text "its" --- > itsOrTheir [x,y] = text "their" --- > itsOrTheir [] = text "their" -- probably avoid this -itsOrTheir :: [a] -> SDoc -itsOrTheir [_] = text "its" -itsOrTheir _ = text "their" - -{- -************************************************************************ -* * -\subsection{Error handling} -* * -************************************************************************ --} - -callStackDoc :: HasCallStack => SDoc -callStackDoc = - hang (text "Call stack:") - 4 (vcat $ map text $ lines (prettyCallStack callStack)) - -pprPanic :: HasCallStack => String -> SDoc -> a --- ^ Throw an exception saying "bug in GHC" -pprPanic s doc = panicDoc s (doc $$ callStackDoc) - -pprSorry :: String -> SDoc -> a --- ^ Throw an exception saying "this isn't finished yet" -pprSorry = sorryDoc - - -pprPgmError :: String -> SDoc -> a --- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pgmErrorDoc - -pprTraceDebug :: String -> SDoc -> a -> a -pprTraceDebug str doc x - | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x - | otherwise = x - --- | If debug output is on, show some 'SDoc' on the screen -pprTrace :: String -> SDoc -> a -> a -pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x - --- | If debug output is on, show some 'SDoc' on the screen -pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a -pprTraceWithFlags dflags str doc x - | hasNoDebugOutput dflags = x - | otherwise = pprDebugAndThen dflags trace (text str) doc x - -pprTraceM :: Applicative f => String -> SDoc -> f () -pprTraceM str doc = pprTrace str doc (pure ()) - --- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. --- This allows you to print details from the returned value as well as from --- ambient variables. -pprTraceWith :: String -> (a -> SDoc) -> a -> a -pprTraceWith desc f x = pprTrace desc (f x) x - --- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ -pprTraceIt :: Outputable a => String -> a -> a -pprTraceIt desc x = pprTraceWith desc ppr x - --- | @pprTraceException desc x action@ runs action, printing a message --- if it throws an exception. -pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a -pprTraceException heading doc = - handleGhcException $ \exc -> liftIO $ do - putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) - throwGhcExceptionIO exc - --- | If debug output is on, show some 'SDoc' on the screen along --- with a call stack when available. -pprSTrace :: HasCallStack => SDoc -> a -> a -pprSTrace doc = pprTrace "" (doc $$ callStackDoc) - -warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a --- ^ Just warn about an assertion failure, recording the given file and line number. --- Should typically be accessed with the WARN macros -warnPprTrace _ _ _ _ x | not debugIsOn = x -warnPprTrace _ _file _line _msg x - | hasNoDebugOutput unsafeGlobalDynFlags = x -warnPprTrace False _file _line _msg x = x -warnPprTrace True file line msg x - = pprDebugAndThen unsafeGlobalDynFlags trace heading - (msg $$ callStackDoc ) - x - where - heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] - --- | Panic with an assertion failure, recording the given file and --- line number. Should typically be accessed with the ASSERT family of macros -assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a -assertPprPanic _file _line msg - = pprPanic "ASSERT failed!" msg - -pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a -pprDebugAndThen dflags cont heading pretty_msg - = cont (showSDocDump dflags doc) - where - doc = sep [heading, nest 2 pretty_msg] diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot deleted file mode 100644 index 77e0982826..0000000000 --- a/compiler/utils/Outputable.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module Outputable where - -import GhcPrelude -import GHC.Stack( HasCallStack ) - -data SDoc -data PprStyle -data SDocContext - -showSDocUnsafe :: SDoc -> String - -warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a - -text :: String -> SDoc diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs deleted file mode 100644 index e9313f89b2..0000000000 --- a/compiler/utils/Pair.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- -A simple homogeneous pair type with useful Functor, Applicative, and -Traversable instances. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import qualified Data.Semigroup as Semi - -data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Functor) --- Note that Pair is a *unary* type constructor --- whereas (,) is binary - --- The important thing about Pair is that it has a *homogeneous* --- Functor instance, so you can easily apply the same function --- to both components - -instance Applicative Pair where - pure x = Pair x x - (Pair f g) <*> (Pair x y) = Pair (f x) (g y) - -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y - -instance Semi.Semigroup a => Semi.Semigroup (Pair a) where - Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) - -instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where - mempty = Pair mempty mempty - mappend = (Semi.<>) - -instance Outputable a => Outputable (Pair a) where - ppr (Pair a b) = ppr a <+> char '~' <+> ppr b - -unPair :: Pair a -> (a,a) -unPair (Pair x y) = (x,y) - -toPair :: (a,a) -> Pair a -toPair (x,y) = Pair x y - -swap :: Pair a -> Pair a -swap (Pair x y) = Pair y x - -pLiftFst :: (a -> a) -> Pair a -> Pair a -pLiftFst f (Pair a b) = Pair (f a) b - -pLiftSnd :: (a -> a) -> Pair a -> Pair a -pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs deleted file mode 100644 index 16f493826c..0000000000 --- a/compiler/utils/Panic.hs +++ /dev/null @@ -1,259 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP Project, Glasgow University, 1992-2000 - -Defines basic functions for printing error messages. - -It's hard to put these functions anywhere else without causing -some unnecessary loops in the module dependency graph. --} - -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} - -module Panic ( - GhcException(..), showGhcException, - throwGhcException, throwGhcExceptionIO, - handleGhcException, - PlainPanic.progName, - pgmError, - - panic, sorry, assertPanic, trace, - panicDoc, sorryDoc, pgmErrorDoc, - - cmdLineError, cmdLineErrorIO, - - Exception.Exception(..), showException, safeShowException, - try, tryMost, throwTo, - - withSignalHandlers, -) where - -import GhcPrelude - -import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) -import PlainPanic - -import Exception - -import Control.Monad.IO.Class -import Control.Concurrent -import Data.Typeable ( cast ) -import Debug.Trace ( trace ) -import System.IO.Unsafe - -#if !defined(mingw32_HOST_OS) -import System.Posix.Signals as S -#endif - -#if defined(mingw32_HOST_OS) -import GHC.ConsoleHandler as S -#endif - -import System.Mem.Weak ( deRefWeak ) - --- | GHC's own exception type --- error messages all take the form: --- --- @ --- <location>: <error> --- @ --- --- If the location is on the command line, or in GHC itself, then --- <location>="ghc". All of the error types below correspond to --- a <location> of "ghc", except for ProgramError (where the string is --- assumed to contain a location already, so we don't print one). - -data GhcException - -- | Some other fatal signal (SIGHUP,SIGTERM) - = Signal Int - - -- | Prints the short usage msg after the error - | UsageError String - - -- | A problem with the command line arguments, but don't print usage. - | CmdLineError String - - -- | The 'impossible' happened. - | Panic String - | PprPanic String SDoc - - -- | The user tickled something that's known not to work yet, - -- but we're not counting it as a bug. - | Sorry String - | PprSorry String SDoc - - -- | An installation problem. - | InstallationError String - - -- | An error in the user's code, probably. - | ProgramError String - | PprProgramError String SDoc - -instance Exception GhcException where - fromException (SomeException e) - | Just ge <- cast e = Just ge - | Just pge <- cast e = Just $ - case pge of - PlainSignal n -> Signal n - PlainUsageError str -> UsageError str - PlainCmdLineError str -> CmdLineError str - PlainPanic str -> Panic str - PlainSorry str -> Sorry str - PlainInstallationError str -> InstallationError str - PlainProgramError str -> ProgramError str - | otherwise = Nothing - -instance Show GhcException where - showsPrec _ e@(ProgramError _) = showGhcException e - showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e - showsPrec _ e = showString progName . showString ": " . showGhcException e - --- | Show an exception as a string. -showException :: Exception e => e -> String -showException = show - --- | Show an exception which can possibly throw other exceptions. --- Used when displaying exception thrown within TH code. -safeShowException :: Exception e => e -> IO String -safeShowException e = do - -- ensure the whole error message is evaluated inside try - r <- try (return $! forceList (showException e)) - case r of - Right msg -> return msg - Left e' -> safeShowException (e' :: SomeException) - where - forceList [] = [] - forceList xs@(x : xt) = x `seq` forceList xt `seq` xs - --- | Append a description of the given exception to this string. --- --- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some --- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. --- If the error message to be printed includes a pretty-printer document --- which forces one of these fields this call may bottom. -showGhcException :: GhcException -> ShowS -showGhcException = showPlainGhcException . \case - Signal n -> PlainSignal n - UsageError str -> PlainUsageError str - CmdLineError str -> PlainCmdLineError str - Panic str -> PlainPanic str - Sorry str -> PlainSorry str - InstallationError str -> PlainInstallationError str - ProgramError str -> PlainProgramError str - - PprPanic str sdoc -> PlainPanic $ - concat [str, "\n\n", showSDocUnsafe sdoc] - PprSorry str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDocUnsafe sdoc] - PprProgramError str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDocUnsafe sdoc] - -throwGhcException :: GhcException -> a -throwGhcException = Exception.throw - -throwGhcExceptionIO :: GhcException -> IO a -throwGhcExceptionIO = Exception.throwIO - -handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a -handleGhcException = ghandle - -panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a -panicDoc x doc = throwGhcException (PprPanic x doc) -sorryDoc x doc = throwGhcException (PprSorry x doc) -pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) - --- | Like try, but pass through UserInterrupt and Panic exceptions. --- Used when we want soft failures when reading interface files, for example. --- TODO: I'm not entirely sure if this is catching what we really want to catch -tryMost :: IO a -> IO (Either SomeException a) -tryMost action = do r <- try action - case r of - Left se -> - case fromException se of - -- Some GhcException's we rethrow, - Just (Signal _) -> throwIO se - Just (Panic _) -> throwIO se - -- others we return - Just _ -> return (Left se) - Nothing -> - case fromException se of - -- All IOExceptions are returned - Just (_ :: IOException) -> - return (Left se) - -- Anything else is rethrown - Nothing -> throwIO se - Right v -> return (Right v) - --- | We use reference counting for signal handlers -{-# NOINLINE signalHandlersRefCount #-} -#if !defined(mingw32_HOST_OS) -signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler - ,S.Handler,S.Handler)) -#else -signalHandlersRefCount :: MVar (Word, Maybe S.Handler) -#endif -signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) - - --- | Temporarily install standard signal handlers for catching ^C, which just --- throw an exception in the current thread. -withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a -withSignalHandlers act = do - main_thread <- liftIO myThreadId - wtid <- liftIO (mkWeakThreadId main_thread) - - let - interrupt = do - r <- deRefWeak wtid - case r of - Nothing -> return () - Just t -> throwTo t UserInterrupt - -#if !defined(mingw32_HOST_OS) - let installHandlers = do - let installHandler' a b = installHandler a b Nothing - hdlQUIT <- installHandler' sigQUIT (Catch interrupt) - hdlINT <- installHandler' sigINT (Catch interrupt) - -- see #3656; in the future we should install these automatically for - -- all Haskell programs in the same way that we install a ^C handler. - let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) - hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) - hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) - return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) - - let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do - _ <- installHandler sigQUIT hdlQUIT Nothing - _ <- installHandler sigINT hdlINT Nothing - _ <- installHandler sigHUP hdlHUP Nothing - _ <- installHandler sigTERM hdlTERM Nothing - return () -#else - -- GHC 6.3+ has support for console events on Windows - -- NOTE: running GHCi under a bash shell for some reason requires - -- you to press Ctrl-Break rather than Ctrl-C to provoke - -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know - -- why --SDM 17/12/2004 - let sig_handler ControlC = interrupt - sig_handler Break = interrupt - sig_handler _ = return () - - let installHandlers = installHandler (Catch sig_handler) - let uninstallHandlers = installHandler -- directly install the old handler -#endif - - -- install signal handlers if necessary - let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (0,Nothing) -> do - hdls <- installHandlers - return (1,Just hdls) - (c,oldHandlers) -> return (c+1,oldHandlers) - - -- uninstall handlers if necessary - let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (1,Just hdls) -> do - _ <- uninstallHandlers hdls - return (0,Nothing) - (c,oldHandlers) -> return (c-1,oldHandlers) - - mayInstallHandlers - act `gfinally` mayUninstallHandlers diff --git a/compiler/utils/PlainPanic.hs b/compiler/utils/PlainPanic.hs deleted file mode 100644 index 0892ebff7d..0000000000 --- a/compiler/utils/PlainPanic.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} - --- | Defines a simple exception type and utilities to throw it. The --- 'PlainGhcException' type is a subset of the 'Panic.GhcException' --- type. It omits the exception constructors that involve --- pretty-printing via 'Outputable.SDoc'. --- --- There are two reasons for this: --- --- 1. To avoid import cycles / use of boot files. "Outputable" has --- many transitive dependencies. To throw exceptions from these --- modules, the functions here can be used without introducing import --- cycles. --- --- 2. To reduce the number of modules that need to be compiled to --- object code when loading GHC into GHCi. See #13101 -module PlainPanic - ( PlainGhcException(..) - , showPlainGhcException - - , panic, sorry, pgmError - , cmdLineError, cmdLineErrorIO - , assertPanic - - , progName - ) where - -#include "HsVersions.h" - -import Config -import Exception -import GHC.Stack -import GhcPrelude -import System.Environment -import System.IO.Unsafe - --- | This type is very similar to 'Panic.GhcException', but it omits --- the constructors that involve pretty-printing via --- 'Outputable.SDoc'. Due to the implementation of 'fromException' --- for 'Panic.GhcException', this type can be caught as a --- 'Panic.GhcException'. --- --- Note that this should only be used for throwing exceptions, not for --- catching, as 'Panic.GhcException' will not be converted to this --- type when catching. -data PlainGhcException - -- | Some other fatal signal (SIGHUP,SIGTERM) - = PlainSignal Int - - -- | Prints the short usage msg after the error - | PlainUsageError String - - -- | A problem with the command line arguments, but don't print usage. - | PlainCmdLineError String - - -- | The 'impossible' happened. - | PlainPanic String - - -- | The user tickled something that's known not to work yet, - -- but we're not counting it as a bug. - | PlainSorry String - - -- | An installation problem. - | PlainInstallationError String - - -- | An error in the user's code, probably. - | PlainProgramError String - -instance Exception PlainGhcException - -instance Show PlainGhcException where - showsPrec _ e@(PlainProgramError _) = showPlainGhcException e - showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e - showsPrec _ e = showString progName . showString ": " . showPlainGhcException e - --- | The name of this GHC. -progName :: String -progName = unsafePerformIO (getProgName) -{-# NOINLINE progName #-} - --- | Short usage information to display when we are given the wrong cmd line arguments. -short_usage :: String -short_usage = "Usage: For basic information, try the `--help' option." - --- | Append a description of the given exception to this string. -showPlainGhcException :: PlainGhcException -> ShowS -showPlainGhcException = - \case - PlainSignal n -> showString "signal: " . shows n - PlainUsageError str -> showString str . showChar '\n' . showString short_usage - PlainCmdLineError str -> showString str - PlainPanic s -> panicMsg (showString s) - PlainSorry s -> sorryMsg (showString s) - PlainInstallationError str -> showString str - PlainProgramError str -> showString str - where - sorryMsg :: ShowS -> ShowS - sorryMsg s = - showString "sorry! (unimplemented feature or known bug)\n" - . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") - . s . showString "\n" - - panicMsg :: ShowS -> ShowS - panicMsg s = - showString "panic! (the 'impossible' happened)\n" - . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") - . s . showString "\n\n" - . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" - -throwPlainGhcException :: PlainGhcException -> a -throwPlainGhcException = Exception.throw - --- | Panics and asserts. -panic, sorry, pgmError :: String -> a -panic x = unsafeDupablePerformIO $ do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwPlainGhcException (PlainPanic x) - else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) - -sorry x = throwPlainGhcException (PlainSorry x) -pgmError x = throwPlainGhcException (PlainProgramError x) - -cmdLineError :: String -> a -cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO - -cmdLineErrorIO :: String -> IO a -cmdLineErrorIO x = do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwPlainGhcException (PlainCmdLineError x) - else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) - --- | Throw a failed assertion exception for a given filename and line number. -assertPanic :: String -> Int -> a -assertPanic file line = - Exception.throw (Exception.AssertionFailed - ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs deleted file mode 100644 index f32b8b0084..0000000000 --- a/compiler/utils/PprColour.hs +++ /dev/null @@ -1,101 +0,0 @@ -module PprColour where -import GhcPrelude - -import Data.Maybe (fromMaybe) -import Util (OverridingBool(..), split) -import Data.Semigroup as Semi - --- | A colour\/style for use with 'coloured'. -newtype PprColour = PprColour { renderColour :: String } - -instance Semi.Semigroup PprColour where - PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) - --- | Allow colours to be combined (e.g. bold + red); --- In case of conflict, right side takes precedence. -instance Monoid PprColour where - mempty = PprColour mempty - mappend = (<>) - -renderColourAfresh :: PprColour -> String -renderColourAfresh c = renderColour (colReset `mappend` c) - -colCustom :: String -> PprColour -colCustom "" = mempty -colCustom s = PprColour ("\27[" ++ s ++ "m") - -colReset :: PprColour -colReset = colCustom "0" - -colBold :: PprColour -colBold = colCustom ";1" - -colBlackFg :: PprColour -colBlackFg = colCustom "30" - -colRedFg :: PprColour -colRedFg = colCustom "31" - -colGreenFg :: PprColour -colGreenFg = colCustom "32" - -colYellowFg :: PprColour -colYellowFg = colCustom "33" - -colBlueFg :: PprColour -colBlueFg = colCustom "34" - -colMagentaFg :: PprColour -colMagentaFg = colCustom "35" - -colCyanFg :: PprColour -colCyanFg = colCustom "36" - -colWhiteFg :: PprColour -colWhiteFg = colCustom "37" - -data Scheme = - Scheme - { sHeader :: PprColour - , sMessage :: PprColour - , sWarning :: PprColour - , sError :: PprColour - , sFatal :: PprColour - , sMargin :: PprColour - } - -defaultScheme :: Scheme -defaultScheme = - Scheme - { sHeader = mempty - , sMessage = colBold - , sWarning = colBold `mappend` colMagentaFg - , sError = colBold `mappend` colRedFg - , sFatal = colBold `mappend` colRedFg - , sMargin = colBold `mappend` colBlueFg - } - --- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ --- environment variable). -parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) -parseScheme "always" (_, cs) = (Always, cs) -parseScheme "auto" (_, cs) = (Auto, cs) -parseScheme "never" (_, cs) = (Never, cs) -parseScheme input (b, cs) = - ( b - , Scheme - { sHeader = fromMaybe (sHeader cs) (lookup "header" table) - , sMessage = fromMaybe (sMessage cs) (lookup "message" table) - , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) - , sError = fromMaybe (sError cs) (lookup "error" table) - , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) - , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) - } - ) - where - table = do - w <- split ':' input - let (k, v') = break (== '=') w - case v' of - '=' : v -> return (k, colCustom v) - _ -> [] diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs deleted file mode 100644 index 5adfdd7699..0000000000 --- a/compiler/utils/Pretty.hs +++ /dev/null @@ -1,1105 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : Pretty --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : David Terei <code@davidterei.com> --- Stability : stable --- Portability : portable --- --- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators --- --- Based on /The Design of a Pretty-printing Library/ --- in Advanced Functional Programming, --- Johan Jeuring and Erik Meijer (eds), LNCS 925 --- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps> --- ------------------------------------------------------------------------------ - -{- -Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] - -For historical reasons, there are two different copies of `Pretty` in the GHC -source tree: - * `libraries/pretty` is a submodule containing - https://github.com/haskell/pretty. This is the `pretty` library as released - on hackage. It is used by several other libraries in the GHC source tree - (e.g. template-haskell and Cabal). - * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. - -There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and -https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy -of Pretty. - -Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following -major differences: - * GHC's copy uses `Faststring` for performance reasons. - * GHC's copy has received a backported bugfix for #12227, which was - released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", - https://github.com/haskell/pretty/pull/35). - -Other differences are minor. Both copies define some extra functions and -instances not defined in the other copy. To see all differences, do this in a -ghc git tree: - - $ cd libraries/pretty - $ git checkout v1.1.2.0 - $ cd - - $ vimdiff compiler/utils/Pretty.hs \ - libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs - -For parity with `pretty-1.1.2.1`, the following two `pretty` commits would -have to be backported: - * "Resolve foldr-strictness stack overflow bug" - (307b8173f41cd776eae8f547267df6d72bff2d68) - * "Special-case reduce for horiz/vert" - (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) -This has not been done sofar, because these commits seem to cause more -allocation in the compiler (see thomie's comments in -https://github.com/haskell/pretty/pull/9). --} - -module Pretty ( - - -- * The document type - Doc, TextDetails(..), - - -- * Constructing documents - - -- ** Converting values into documents - char, text, ftext, ptext, ztext, sizedText, zeroWidthText, - int, integer, float, double, rational, hex, - - -- ** Simple derived documents - semi, comma, colon, space, equals, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, - - -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, - maybeParens, - - -- ** Combining documents - empty, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, - hang, hangNotEmpty, punctuate, - - -- * Predicates on documents - isEmpty, - - -- * Rendering documents - - -- ** Rendering with a particular style - Style(..), - style, - renderStyle, - Mode(..), - - -- ** General rendering - fullRender, txtPrinter, - - -- ** GHC-specific rendering - printDoc, printDoc_, - bufLeftRender -- performance hack - - ) where - -import GhcPrelude hiding (error) - -import BufWrite -import FastString -import PlainPanic -import System.IO -import Numeric (showHex) - ---for a RULES -import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) -import GHC.Ptr ( Ptr(..) ) - --- --------------------------------------------------------------------------- --- The Doc calculus - -{- -Laws for $$ -~~~~~~~~~~~ -<a1> (x $$ y) $$ z = x $$ (y $$ z) -<a2> empty $$ x = x -<a3> x $$ empty = x - - ...ditto $+$... - -Laws for <> -~~~~~~~~~~~ -<b1> (x <> y) <> z = x <> (y <> z) -<b2> empty <> x = empty -<b3> x <> empty = x - - ...ditto <+>... - -Laws for text -~~~~~~~~~~~~~ -<t1> text s <> text t = text (s++t) -<t2> text "" <> x = x, if x non-empty - -** because of law n6, t2 only holds if x doesn't -** start with `nest'. - - -Laws for nest -~~~~~~~~~~~~~ -<n1> nest 0 x = x -<n2> nest k (nest k' x) = nest (k+k') x -<n3> nest k (x <> y) = nest k x <> nest k y -<n4> nest k (x $$ y) = nest k x $$ nest k y -<n5> nest k empty = empty -<n6> x <> nest k y = x <> y, if x non-empty - -** Note the side condition on <n6>! It is this that -** makes it OK for empty to be a left unit for <>. - -Miscellaneous -~~~~~~~~~~~~~ -<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) - -<m2> (x $$ y) <> z = x $$ (y <> z) - if y non-empty - - -Laws for list versions -~~~~~~~~~~~~~~~~~~~~~~ -<l1> sep (ps++[empty]++qs) = sep (ps ++ qs) - ...ditto hsep, hcat, vcat, fill... - -<l2> nest k (sep ps) = sep (map (nest k) ps) - ...ditto hsep, hcat, vcat, fill... - -Laws for oneLiner -~~~~~~~~~~~~~~~~~ -<o1> oneLiner (nest k p) = nest k (oneLiner p) -<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y - -You might think that the following version of <m1> would -be neater: - -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ - nest (-length s) y) - -But it doesn't work, for if x=empty, we would have - - text s $$ y = text s <> (empty $$ nest (-length s) y) - = text s <> nest (-length s) y --} - --- --------------------------------------------------------------------------- --- Operator fixity - -infixl 6 <> -infixl 6 <+> -infixl 5 $$, $+$ - - --- --------------------------------------------------------------------------- --- The Doc data type - --- | The abstract type of documents. --- A Doc represents a *set* of layouts. A Doc with --- no occurrences of Union or NoDoc represents just one layout. -data Doc - = Empty -- empty - | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x - | Nest {-# UNPACK #-} !Int Doc -- nest k x - | Union Doc Doc -- ul `union` ur - | NoDoc -- The empty set of documents - | Beside Doc Bool Doc -- True <=> space between - | Above Doc Bool Doc -- True <=> never overlap - -{- -Here are the invariants: - -1) The argument of NilAbove is never Empty. Therefore - a NilAbove occupies at least two lines. - -2) The argument of @TextBeside@ is never @Nest@. - -3) The layouts of the two arguments of @Union@ both flatten to the same - string. - -4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. - -5) A @NoDoc@ may only appear on the first line of the left argument of an - union. Therefore, the right argument of an union can never be equivalent - to the empty set (@NoDoc@). - -6) An empty document is always represented by @Empty@. It can't be - hidden inside a @Nest@, or a @Union@ of two @Empty@s. - -7) The first line of every layout in the left argument of @Union@ is - longer than the first line of any layout in the right argument. - (1) ensures that the left argument has a first line. In view of - (3), this invariant means that the right argument must have at - least two lines. - -Notice the difference between - * NoDoc (no documents) - * Empty (one empty document; no height and no width) - * text "" (a document containing the empty string; - one line high, but has no width) --} - - --- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. -type RDoc = Doc - --- | The TextDetails data type --- --- A TextDetails represents a fragment of text that will be --- output at some point. -data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment - | Str String -- ^ A whole String fragment - | PStr FastString -- a hashed string - | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !PtrString - -- a '\0'-terminated array of bytes - | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char - -- a repeated character (e.g., ' ') - -instance Show Doc where - showsPrec _ doc cont = fullRender (mode style) (lineLength style) - (ribbonsPerLine style) - txtPrinter cont doc - - --- --------------------------------------------------------------------------- --- Values and Predicates on GDocs and TextDetails - --- | A document of height and width 1, containing a literal character. -char :: Char -> Doc -char c = textBeside_ (Chr c) 1 Empty - --- | A document of height 1 containing a literal string. --- 'text' satisfies the following laws: --- --- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ --- --- * @'text' \"\" '<>' x = x@, if @x@ non-empty --- --- The side condition on the last law is necessary because @'text' \"\"@ --- has height 1, while 'empty' has no height. -text :: String -> Doc -text s = textBeside_ (Str s) (length s) Empty -{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire - -- It must wait till after phase 1 when - -- the unpackCString first is manifested - --- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the --- intermediate packing/unpacking of the string. -{-# RULES "text/str" - forall a. text (unpackCString# a) = ptext (mkPtrString# a) - #-} -{-# RULES "text/unpackNBytes#" - forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) - #-} - -ftext :: FastString -> Doc -ftext s = textBeside_ (PStr s) (lengthFS s) Empty - -ptext :: PtrString -> Doc -ptext s = textBeside_ (LStr s) (lengthPS s) Empty - -ztext :: FastZString -> Doc -ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty - --- | Some text with any width. (@text s = sizedText (length s) s@) -sizedText :: Int -> String -> Doc -sizedText l s = textBeside_ (Str s) l Empty - --- | Some text, but without any width. Use for non-printing text --- such as a HTML or Latex tags -zeroWidthText :: String -> Doc -zeroWidthText = sizedText 0 - --- | The empty document, with no height and no width. --- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere --- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. -empty :: Doc -empty = Empty - --- | Returns 'True' if the document is empty -isEmpty :: Doc -> Bool -isEmpty Empty = True -isEmpty _ = False - -{- -Q: What is the reason for negative indentation (i.e. argument to indent - is < 0) ? - -A: -This indicates an error in the library client's code. -If we compose a <> b, and the first line of b is more indented than some -other lines of b, the law <n6> (<> eats nests) may cause the pretty -printer to produce an invalid layout: - -doc |0123345 ------------------- -d1 |a...| -d2 |...b| - |c...| - -d1<>d2 |ab..| - c|....| - -Consider a <> b, let `s' be the length of the last line of `a', `k' the -indentation of the first line of b, and `k0' the indentation of the -left-most line b_i of b. - -The produced layout will have negative indentation if `k - k0 > s', as -the first line of b will be put on the (s+1)th column, effectively -translating b horizontally by (k-s). Now if the i^th line of b has an -indentation k0 < (k-s), it is translated out-of-page, causing -`negative indentation'. --} - - -semi :: Doc -- ^ A ';' character -comma :: Doc -- ^ A ',' character -colon :: Doc -- ^ A ':' character -space :: Doc -- ^ A space character -equals :: Doc -- ^ A '=' character -lparen :: Doc -- ^ A '(' character -rparen :: Doc -- ^ A ')' character -lbrack :: Doc -- ^ A '[' character -rbrack :: Doc -- ^ A ']' character -lbrace :: Doc -- ^ A '{' character -rbrace :: Doc -- ^ A '}' character -semi = char ';' -comma = char ',' -colon = char ':' -space = char ' ' -equals = char '=' -lparen = char '(' -rparen = char ')' -lbrack = char '[' -rbrack = char ']' -lbrace = char '{' -rbrace = char '}' - -spaceText, nlText :: TextDetails -spaceText = Chr ' ' -nlText = Chr '\n' - -int :: Int -> Doc -- ^ @int n = text (show n)@ -integer :: Integer -> Doc -- ^ @integer n = text (show n)@ -float :: Float -> Doc -- ^ @float n = text (show n)@ -double :: Double -> Doc -- ^ @double n = text (show n)@ -rational :: Rational -> Doc -- ^ @rational n = text (show n)@ -hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] -int n = text (show n) -integer n = text (show n) -float n = text (show n) -double n = text (show n) -rational n = text (show n) -hex n = text ('0' : 'x' : padded) - where - str = showHex n "" - strLen = max 1 (length str) - len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) - padded = replicate (len - strLen) '0' ++ str - -parens :: Doc -> Doc -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ -quote :: Doc -> Doc -doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ -quotes p = char '`' <> p <> char '\'' -quote p = char '\'' <> p -doubleQuotes p = char '"' <> p <> char '"' -parens p = char '(' <> p <> char ')' -brackets p = char '[' <> p <> char ']' -braces p = char '{' <> p <> char '}' - -{- -Note [Print Hexadecimal Literals] - -Relevant discussions: - * Phabricator: https://phabricator.haskell.org/D4465 - * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 - -There is a flag `-dword-hex-literals` that causes literals of -type `Word#` or `Word64#` to be displayed in hexadecimal instead -of decimal when dumping GHC core. It also affects the presentation -of these in GHC's error messages. Additionally, the hexadecimal -encoding of these numbers is zero-padded so that its length is -a power of two. As an example of what this does, -consider the following haskell file `Literals.hs`: - - module Literals where - - alpha :: Int - alpha = 100 + 200 - - beta :: Word -> Word - beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 - -We get the following dumped core when we compile on a 64-bit -machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all --dhex-word-literals literals.hs: - - ==================== Tidy Core ==================== - - ... omitted for brevity ... - - -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} - alpha - alpha = I# 300# - - -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} - beta - beta - = \ x_aYE -> - case x_aYE of { W# x#_a1v0 -> - W# - (plusWord# - (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) - 0x0202##) - } - -Notice that the word literals are in hexadecimals and that they have -been padded with zeroes so that their lengths are 16, 8, and 4, respectively. - --} - --- | Apply 'parens' to 'Doc' if boolean is true. -maybeParens :: Bool -> Doc -> Doc -maybeParens False = id -maybeParens True = parens - --- --------------------------------------------------------------------------- --- Structural operations on GDocs - --- | Perform some simplification of a built up @GDoc@. -reduceDoc :: Doc -> RDoc -reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) -reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) -reduceDoc p = p - --- | List version of '<>'. -hcat :: [Doc] -> Doc -hcat = reduceAB . foldr (beside_' False) empty - --- | List version of '<+>'. -hsep :: [Doc] -> Doc -hsep = reduceAB . foldr (beside_' True) empty - --- | List version of '$$'. -vcat :: [Doc] -> Doc -vcat = reduceAB . foldr (above_' False) empty - --- | Nest (or indent) a document by a given number of positions --- (which may also be negative). 'nest' satisfies the laws: --- --- * @'nest' 0 x = x@ --- --- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ --- --- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ --- --- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ --- --- * @'nest' k 'empty' = 'empty'@ --- --- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty --- --- The side condition on the last law is needed because --- 'empty' is a left identity for '<>'. -nest :: Int -> Doc -> Doc -nest k p = mkNest k (reduceDoc p) - --- | @hang d1 n d2 = sep [d1, nest n d2]@ -hang :: Doc -> Int -> Doc -> Doc -hang d1 n d2 = sep [d1, nest n d2] - --- | Apply 'hang' to the arguments if the first 'Doc' is not empty. -hangNotEmpty :: Doc -> Int -> Doc -> Doc -hangNotEmpty d1 n d2 = if isEmpty d1 - then d2 - else hang d1 n d2 - --- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -punctuate :: Doc -> [Doc] -> [Doc] -punctuate _ [] = [] -punctuate p (x:xs) = go x xs - where go y [] = [y] - go y (z:zs) = (y <> p) : go z zs - --- mkNest checks for Nest's invariant that it doesn't have an Empty inside it -mkNest :: Int -> Doc -> Doc -mkNest k _ | k `seq` False = undefined -mkNest k (Nest k1 p) = mkNest (k + k1) p -mkNest _ NoDoc = NoDoc -mkNest _ Empty = Empty -mkNest 0 p = p -mkNest k p = nest_ k p - --- mkUnion checks for an empty document -mkUnion :: Doc -> Doc -> Doc -mkUnion Empty _ = Empty -mkUnion p q = p `union_` q - -beside_' :: Bool -> Doc -> Doc -> Doc -beside_' _ p Empty = p -beside_' g p q = Beside p g q - -above_' :: Bool -> Doc -> Doc -> Doc -above_' _ p Empty = p -above_' g p q = Above p g q - -reduceAB :: Doc -> Doc -reduceAB (Above Empty _ q) = q -reduceAB (Beside Empty _ q) = q -reduceAB doc = doc - -nilAbove_ :: RDoc -> RDoc -nilAbove_ = NilAbove - --- Arg of a TextBeside is always an RDoc -textBeside_ :: TextDetails -> Int -> RDoc -> RDoc -textBeside_ = TextBeside - -nest_ :: Int -> RDoc -> RDoc -nest_ = Nest - -union_ :: RDoc -> RDoc -> RDoc -union_ = Union - - --- --------------------------------------------------------------------------- --- Vertical composition @$$@ - --- | Above, except that if the last line of the first argument stops --- at least one position before the first line of the second begins, --- these two lines are overlapped. For example: --- --- > text "hi" $$ nest 5 (text "there") --- --- lays out as --- --- > hi there --- --- rather than --- --- > hi --- > there --- --- '$$' is associative, with identity 'empty', and also satisfies --- --- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. --- -($$) :: Doc -> Doc -> Doc -p $$ q = above_ p False q - --- | Above, with no overlapping. --- '$+$' is associative, with identity 'empty'. -($+$) :: Doc -> Doc -> Doc -p $+$ q = above_ p True q - -above_ :: Doc -> Bool -> Doc -> Doc -above_ p _ Empty = p -above_ Empty _ q = q -above_ p g q = Above p g q - -above :: Doc -> Bool -> RDoc -> RDoc -above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) -above p g q = aboveNest p g 0 (reduceDoc q) - --- Specification: aboveNest p g k q = p $g$ (nest k q) -aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc -aboveNest _ _ k _ | k `seq` False = undefined -aboveNest NoDoc _ _ _ = NoDoc -aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` - aboveNest p2 g k q - -aboveNest Empty _ k q = mkNest k q -aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) - -- p can't be Empty, so no need for mkNest - -aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) -aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest - where - !k1 = k - sl - rest = case p of - Empty -> nilAboveNest g k1 q - _ -> aboveNest p g k1 q -aboveNest (Above {}) _ _ _ = error "aboveNest Above" -aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" - --- Specification: text s <> nilaboveNest g k q --- = text s <> (text "" $g$ nest k q) -nilAboveNest :: Bool -> Int -> RDoc -> RDoc -nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest _ _ Empty = Empty - -- Here's why the "text s <>" is in the spec! -nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q -nilAboveNest g k q | not g && k > 0 -- No newline if no overlap - = textBeside_ (RStr k ' ') k q - | otherwise -- Put them really above - = nilAbove_ (mkNest k q) - - --- --------------------------------------------------------------------------- --- Horizontal composition @<>@ - --- We intentionally avoid Data.Monoid.(<>) here due to interactions of --- Data.Monoid.(<>) and (<+>). See --- http://www.haskell.org/pipermail/libraries/2011-November/017066.html - --- | Beside. --- '<>' is associative, with identity 'empty'. -(<>) :: Doc -> Doc -> Doc -p <> q = beside_ p False q - --- | Beside, separated by space, unless one of the arguments is 'empty'. --- '<+>' is associative, with identity 'empty'. -(<+>) :: Doc -> Doc -> Doc -p <+> q = beside_ p True q - -beside_ :: Doc -> Bool -> Doc -> Doc -beside_ p _ Empty = p -beside_ Empty _ q = q -beside_ p g q = Beside p g q - --- Specification: beside g p q = p <g> q -beside :: Doc -> Bool -> RDoc -> RDoc -beside NoDoc _ _ = NoDoc -beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q -beside Empty _ q = q -beside (Nest k p) g q = nest_ k $! beside p g q -beside p@(Beside p1 g1 q1) g2 q2 - | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 - | otherwise = beside (reduceDoc p) g2 q2 -beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q -beside (NilAbove p) g q = nilAbove_ $! beside p g q -beside (TextBeside s sl p) g q = textBeside_ s sl rest - where - rest = case p of - Empty -> nilBeside g q - _ -> beside p g q - --- Specification: text "" <> nilBeside g p --- = text "" <g> p -nilBeside :: Bool -> RDoc -> RDoc -nilBeside _ Empty = Empty -- Hence the text "" in the spec -nilBeside g (Nest _ p) = nilBeside g p -nilBeside g p | g = textBeside_ spaceText 1 p - | otherwise = p - - --- --------------------------------------------------------------------------- --- Separate, @sep@ - --- Specification: sep ps = oneLiner (hsep ps) --- `union` --- vcat ps - --- | Either 'hsep' or 'vcat'. -sep :: [Doc] -> Doc -sep = sepX True -- Separate with spaces - --- | Either 'hcat' or 'vcat'. -cat :: [Doc] -> Doc -cat = sepX False -- Don't - -sepX :: Bool -> [Doc] -> Doc -sepX _ [] = empty -sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps - - --- Specification: sep1 g k ys = sep (x : map (nest k) ys) --- = oneLiner (x <g> nest k (hsep ys)) --- `union` x $$ nest k (vcat ys) -sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc -sep1 _ _ k _ | k `seq` False = undefined -sep1 _ NoDoc _ _ = NoDoc -sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - aboveNest q False k (reduceDoc (vcat ys)) - -sep1 g Empty k ys = mkNest k (sepX g ys) -sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) - -sep1 _ (NilAbove p) k ys = nilAbove_ - (aboveNest p False k (reduceDoc (vcat ys))) -sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) -sep1 _ (Above {}) _ _ = error "sep1 Above" -sep1 _ (Beside {}) _ _ = error "sep1 Beside" - --- Specification: sepNB p k ys = sep1 (text "" <> p) k ys --- Called when we have already found some text in the first item --- We have to eat up nests -sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys - = sepNB g p k ys -- Never triggered, because of invariant (2) -sepNB g Empty k ys - = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - nilAboveNest False k (reduceDoc (vcat ys)) - where - rest | g = hsep ys - | otherwise = hcat ys -sepNB g p k ys - = sep1 g p k ys - - --- --------------------------------------------------------------------------- --- @fill@ - --- | \"Paragraph fill\" version of 'cat'. -fcat :: [Doc] -> Doc -fcat = fill False - --- | \"Paragraph fill\" version of 'sep'. -fsep :: [Doc] -> Doc -fsep = fill True - --- Specification: --- --- fill g docs = fillIndent 0 docs --- --- fillIndent k [] = [] --- fillIndent k [p] = p --- fillIndent k (p1:p2:ps) = --- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) --- (remove_nests (oneLiner p2) : ps) --- `Union` --- (p1 $*$ nest (-k) (fillIndent 0 ps)) --- --- $*$ is defined for layouts (not Docs) as --- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 --- | otherwise = layout1 $+$ layout2 - -fill :: Bool -> [Doc] -> RDoc -fill _ [] = empty -fill g (p:ps) = fill1 g (reduceDoc p) 0 ps - -fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc -fill1 _ _ k _ | k `seq` False = undefined -fill1 _ NoDoc _ _ = NoDoc -fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - aboveNest q False k (fill g ys) -fill1 g Empty k ys = mkNest k (fill g ys) -fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) -fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) -fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) -fill1 _ (Above {}) _ _ = error "fill1 Above" -fill1 _ (Beside {}) _ _ = error "fill1 Beside" - -fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc -fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys - -- Never triggered, because of invariant (2) -fillNB _ Empty _ [] = Empty -fillNB g Empty k (Empty:ys) = fillNB g Empty k ys -fillNB g Empty k (y:ys) = fillNBE g k y ys -fillNB g p k ys = fill1 g p k ys - - -fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys - = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - `mkUnion` nilAboveNest False k (fill g (y:ys)) - where k' = if g then k - 1 else k - -elideNest :: Doc -> Doc -elideNest (Nest _ d) = d -elideNest d = d - --- --------------------------------------------------------------------------- --- Selecting the best layout - -best :: Int -- Line length - -> Int -- Ribbon length - -> RDoc - -> RDoc -- No unions in here! -best w0 r = get w0 - where - get :: Int -- (Remaining) width of line - -> Doc -> Doc - get w _ | w == 0 && False = undefined - get _ Empty = Empty - get _ NoDoc = NoDoc - get w (NilAbove p) = nilAbove_ (get w p) - get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) - get w (Nest k p) = nest_ k (get (w - k) p) - get w (p `Union` q) = nicest w r (get w p) (get w q) - get _ (Above {}) = error "best get Above" - get _ (Beside {}) = error "best get Beside" - - get1 :: Int -- (Remaining) width of line - -> Int -- Amount of first line already eaten up - -> Doc -- This is an argument to TextBeside => eat Nests - -> Doc -- No unions in here! - - get1 w _ _ | w == 0 && False = undefined - get1 _ _ Empty = Empty - get1 _ _ NoDoc = NoDoc - get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) - get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) - get1 w sl (Nest _ p) = get1 w sl p - get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) - (get1 w sl q) - get1 _ _ (Above {}) = error "best get1 Above" - get1 _ _ (Beside {}) = error "best get1 Beside" - -nicest :: Int -> Int -> Doc -> Doc -> Doc -nicest !w !r = nicest1 w r 0 - -nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc -nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p - | otherwise = q - -fits :: Int -- Space available - -> Doc - -> Bool -- True if *first line* of Doc fits in space available -fits n _ | n < 0 = False -fits _ NoDoc = False -fits _ Empty = True -fits _ (NilAbove _) = True -fits n (TextBeside _ sl p) = fits (n - sl) p -fits _ (Above {}) = error "fits Above" -fits _ (Beside {}) = error "fits Beside" -fits _ (Union {}) = error "fits Union" -fits _ (Nest {}) = error "fits Nest" - --- | @first@ returns its first argument if it is non-empty, otherwise its second. -first :: Doc -> Doc -> Doc -first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused - | otherwise = q - -nonEmptySet :: Doc -> Bool -nonEmptySet NoDoc = False -nonEmptySet (_ `Union` _) = True -nonEmptySet Empty = True -nonEmptySet (NilAbove _) = True -nonEmptySet (TextBeside _ _ p) = nonEmptySet p -nonEmptySet (Nest _ p) = nonEmptySet p -nonEmptySet (Above {}) = error "nonEmptySet Above" -nonEmptySet (Beside {}) = error "nonEmptySet Beside" - --- @oneLiner@ returns the one-line members of the given set of @GDoc@s. -oneLiner :: Doc -> Doc -oneLiner NoDoc = NoDoc -oneLiner Empty = Empty -oneLiner (NilAbove _) = NoDoc -oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) -oneLiner (Nest k p) = nest_ k (oneLiner p) -oneLiner (p `Union` _) = oneLiner p -oneLiner (Above {}) = error "oneLiner Above" -oneLiner (Beside {}) = error "oneLiner Beside" - - --- --------------------------------------------------------------------------- --- Rendering - --- | A rendering style. -data Style - = Style { mode :: Mode -- ^ The rendering mode - , lineLength :: Int -- ^ Length of line, in chars - , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length - } - --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). -style :: Style -style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } - --- | Rendering mode. -data Mode = PageMode -- ^ Normal - | ZigZagMode -- ^ With zig-zag cuts - | LeftMode -- ^ No indentation, infinitely long lines - | OneLineMode -- ^ All on one line - --- | Render the @Doc@ to a String using the given @Style@. -renderStyle :: Style -> Doc -> String -renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) - txtPrinter "" - --- | Default TextDetails printer -txtPrinter :: TextDetails -> String -> String -txtPrinter (Chr c) s = c:s -txtPrinter (Str s1) s2 = s1 ++ s2 -txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 -txtPrinter (ZStr s1) s2 = zString s1 ++ s2 -txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 -txtPrinter (RStr n c) s2 = replicate n c ++ s2 - --- | The general rendering interface. -fullRender :: Mode -- ^ Rendering mode - -> Int -- ^ Line length - -> Float -- ^ Ribbons per line - -> (TextDetails -> a -> a) -- ^ What to do with text - -> a -- ^ What to do at the end - -> Doc -- ^ The document - -> a -- ^ Result -fullRender OneLineMode _ _ txt end doc - = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc - = easyDisplay nlText first txt end (reduceDoc doc) - -fullRender m lineLen ribbons txt rest doc - = display m lineLen ribbonLen txt rest doc' - where - doc' = best bestLineLen ribbonLen (reduceDoc doc) - - bestLineLen, ribbonLen :: Int - ribbonLen = round (fromIntegral lineLen / ribbons) - bestLineLen = case m of - ZigZagMode -> maxBound - _ -> lineLen - -easyDisplay :: TextDetails - -> (Doc -> Doc -> Doc) - -> (TextDetails -> a -> a) - -> a - -> Doc - -> a -easyDisplay nlSpaceText choose txt end - = lay - where - lay NoDoc = error "easyDisplay: NoDoc" - lay (Union p q) = lay (choose p q) - lay (Nest _ p) = lay p - lay Empty = end - lay (NilAbove p) = nlSpaceText `txt` lay p - lay (TextBeside s _ p) = s `txt` lay p - lay (Above {}) = error "easyDisplay Above" - lay (Beside {}) = error "easyDisplay Beside" - -display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a -display m !page_width !ribbon_width txt end doc - = case page_width - ribbon_width of { gap_width -> - case gap_width `quot` 2 of { shift -> - let - lay k _ | k `seq` False = undefined - lay k (Nest k1 p) = lay (k + k1) p - lay _ Empty = end - lay k (NilAbove p) = nlText `txt` lay k p - lay k (TextBeside s sl p) - = case m of - ZigZagMode | k >= gap_width - -> nlText `txt` ( - Str (replicate shift '/') `txt` ( - nlText `txt` - lay1 (k - shift) s sl p )) - - | k < 0 - -> nlText `txt` ( - Str (replicate shift '\\') `txt` ( - nlText `txt` - lay1 (k + shift) s sl p )) - - _ -> lay1 k s sl p - lay _ (Above {}) = error "display lay Above" - lay _ (Beside {}) = error "display lay Beside" - lay _ NoDoc = error "display lay NoDoc" - lay _ (Union {}) = error "display lay Union" - - lay1 !k s !sl p = let !r = k + sl - in indent k (s `txt` lay2 r p) - - lay2 k _ | k `seq` False = undefined - lay2 k (NilAbove p) = nlText `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p - lay2 k (Nest _ p) = lay2 k p - lay2 _ Empty = end - lay2 _ (Above {}) = error "display lay2 Above" - lay2 _ (Beside {}) = error "display lay2 Beside" - lay2 _ NoDoc = error "display lay2 NoDoc" - lay2 _ (Union {}) = error "display lay2 Union" - - indent !n r = RStr n ' ' `txt` r - in - lay 0 doc - }} - -printDoc :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc adds a newline to the end -printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") - -printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc_ does not add a newline at the end, so that --- successive calls can output stuff on the same line --- Rather like putStr vs putStrLn -printDoc_ LeftMode _ hdl doc - = do { printLeftRender hdl doc; hFlush hdl } -printDoc_ mode pprCols hdl doc - = do { fullRender mode pprCols 1.5 put done doc ; - hFlush hdl } - where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutStr hdl (unpackFS s) >> next - -- NB. not hPutFS, we want this to go through - -- the I/O library's encoding layer. (#3398) - put (ZStr s) next = hPutFZS hdl s >> next - put (LStr s) next = hPutPtrString hdl s >> next - put (RStr n c) next = hPutStr hdl (replicate n c) >> next - - done = return () -- hPutChar hdl '\n' - - -- some versions of hPutBuf will barf if the length is zero -hPutPtrString :: Handle -> PtrString -> IO () -hPutPtrString _handle (PtrString _ 0) = return () -hPutPtrString handle (PtrString a l) = hPutBuf handle a l - --- Printing output in LeftMode is performance critical: it's used when --- dumping C and assembly output, so we allow ourselves a few dirty --- hacks: --- --- (1) we specialise fullRender for LeftMode with IO output. --- --- (2) we add a layer of buffering on top of Handles. Handles --- don't perform well with lots of hPutChars, which is mostly --- what we're doing here, because Handles have to be thread-safe --- and async exception-safe. We only have a single thread and don't --- care about exceptions, so we add a layer of fast buffering --- over the Handle interface. - -printLeftRender :: Handle -> Doc -> IO () -printLeftRender hdl doc = do - b <- newBufHandle hdl - bufLeftRender b doc - bFlush b - -bufLeftRender :: BufHandle -> Doc -> IO () -bufLeftRender b doc = layLeft b (reduceDoc doc) - -layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" -layLeft b (Union p q) = layLeft b $! first p q -layLeft b (Nest _ p) = layLeft b $! p -layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) - where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c - put b (Str s) = bPutStr b s - put b (PStr s) = bPutFS b s - put b (ZStr s) = bPutFZS b s - put b (LStr s) = bPutPtrString b s - put b (RStr n c) = bPutReplicate b n c -layLeft _ _ = panic "layLeft: Unhandled case" - --- Define error=panic, for easier comparison with libraries/pretty. -error :: String -> a -error = panic diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs deleted file mode 100644 index 92269e91e7..0000000000 --- a/compiler/utils/State.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} - -module State where - -import GhcPrelude - -newtype State s a = State { runState' :: s -> (# a, s #) } - deriving (Functor) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs deleted file mode 100644 index 7eabbe1958..0000000000 --- a/compiler/utils/Stream.hs +++ /dev/null @@ -1,135 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2012 --- --- Monadic streams --- --- ----------------------------------------------------------------------------- -module Stream ( - Stream(..), yield, liftIO, - collect, collect_, consume, fromList, - Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_ - ) where - -import GhcPrelude - -import Control.Monad - --- | --- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence --- of elements of type @a@ followed by a result of type @b@. --- --- More concretely, a value of type @Stream m a b@ can be run using @runStream@ --- in the Monad @m@, and it delivers either --- --- * the final result: @Left b@, or --- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ --- is a computation to get the rest of the stream. --- --- Stream is itself a Monad, and provides an operation 'yield' that --- produces a new element of the stream. This makes it convenient to turn --- existing monadic computations into streams. --- --- The idea is that Stream is useful for making a monadic computation --- that produces values from time to time. This can be used for --- knitting together two complex monadic operations, so that the --- producer does not have to produce all its values before the --- consumer starts consuming them. We make the producer into a --- Stream, and the consumer pulls on the stream each time it wants a --- new value. --- -newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } - -instance Monad f => Functor (Stream f a) where - fmap = liftM - -instance Monad m => Applicative (Stream m a) where - pure a = Stream (return (Left a)) - (<*>) = ap - -instance Monad m => Monad (Stream m a) where - - Stream m >>= k = Stream $ do - r <- m - case r of - Left b -> runStream (k b) - Right (a,str) -> return (Right (a, str >>= k)) - -yield :: Monad m => a -> Stream m a () -yield a = Stream (return (Right (a, return ()))) - -liftIO :: IO a -> Stream IO b a -liftIO io = Stream $ io >>= return . Left - --- | Turn a Stream into an ordinary list, by demanding all the elements. -collect :: Monad m => Stream m a () -> m [a] -collect str = go str [] - where - go str acc = do - r <- runStream str - case r of - Left () -> return (reverse acc) - Right (a, str') -> go str' (a:acc) - --- | Turn a Stream into an ordinary list, by demanding all the elements. -collect_ :: Monad m => Stream m a r -> m ([a], r) -collect_ str = go str [] - where - go str acc = do - r <- runStream str - case r of - Left r -> return (reverse acc, r) - Right (a, str') -> go str' (a:acc) - -consume :: Monad m => Stream m a b -> (a -> m ()) -> m b -consume str f = do - r <- runStream str - case r of - Left ret -> return ret - Right (a, str') -> do - f a - consume str' f - --- | Turn a list into a 'Stream', by yielding each element in turn. -fromList :: Monad m => [a] -> Stream m a () -fromList = mapM_ yield - --- | Apply a function to each element of a 'Stream', lazily -map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x -map f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> return (Right (f a, Stream.map f str')) - --- | Apply a monadic operation to each element of a 'Stream', lazily -mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x -mapM f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> do - b <- f a - return (Right (b, Stream.mapM f str')) - --- | analog of the list-based 'mapAccumL' on Streams. This is a simple --- way to map over a Stream while carrying some state around. -mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () - -> Stream m b c -mapAccumL f c str = Stream $ do - r <- runStream str - case r of - Left () -> return (Left c) - Right (a, str') -> do - (c',b) <- f c a - return (Right (b, mapAccumL f c' str')) - -mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r - -> Stream m b (c, r) -mapAccumL_ f c str = Stream $ do - r <- runStream str - case r of - Left r -> return (Left (c, r)) - Right (a, str') -> do - (c',b) <- f c a - return (Right (b, mapAccumL_ f c' str')) diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs deleted file mode 100644 index 91377cad17..0000000000 --- a/compiler/utils/StringBuffer.hs +++ /dev/null @@ -1,334 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The University of Glasgow, 1997-2006 - - -Buffers for scanning string input stored in external arrays. --} - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - -module StringBuffer - ( - StringBuffer(..), - -- non-abstract for vs\/HaskellService - - -- * Creation\/destruction - hGetStringBuffer, - hGetStringBufferBlock, - hPutStringBuffer, - appendStringBuffers, - stringToStringBuffer, - - -- * Inspection - nextChar, - currentChar, - prevChar, - atEnd, - - -- * Moving and comparison - stepOn, - offsetBytes, - byteDiff, - atLine, - - -- * Conversion - lexemeToString, - lexemeToFastString, - decodePrevNChars, - - -- * Parsing integers - parseUnsignedInteger, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Encoding -import FastString -import FastFunctions -import PlainPanic -import Util - -import Data.Maybe -import Control.Exception -import System.IO -import System.IO.Unsafe ( unsafePerformIO ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) - -import GHC.Exts - -import Foreign - --- ----------------------------------------------------------------------------- --- The StringBuffer type - --- |A StringBuffer is an internal pointer to a sized chunk of bytes. --- The bytes are intended to be *immutable*. There are pure --- operations to read the contents of a StringBuffer. --- --- A StringBuffer may have a finalizer, depending on how it was --- obtained. --- -data StringBuffer - = StringBuffer { - buf :: {-# UNPACK #-} !(ForeignPtr Word8), - len :: {-# UNPACK #-} !Int, -- length - cur :: {-# UNPACK #-} !Int -- current pos - } - -- The buffer is assumed to be UTF-8 encoded, and furthermore - -- we add three @\'\\0\'@ bytes to the end as sentinels so that the - -- decoder doesn't have to check for overflow at every single byte - -- of a multibyte sequence. - -instance Show StringBuffer where - showsPrec _ s = showString "<stringbuffer(" - . shows (len s) . showString "," . shows (cur s) - . showString ")>" - --- ----------------------------------------------------------------------------- --- Creation / Destruction - --- | Read a file into a 'StringBuffer'. The resulting buffer is automatically --- managed by the garbage collector. -hGetStringBuffer :: FilePath -> IO StringBuffer -hGetStringBuffer fname = do - h <- openBinaryFile fname ReadMode - size_i <- hFileSize h - offset_i <- skipBOM h size_i 0 -- offset is 0 initially - let size = fromIntegral $ size_i - offset_i - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - r <- if size == 0 then return 0 else hGetBuf h ptr size - hClose h - if (r /= size) - then ioError (userError "short read of file") - else newUTF8StringBuffer buf ptr size - -hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer -hGetStringBufferBlock handle wanted - = do size_i <- hFileSize handle - offset_i <- hTell handle >>= skipBOM handle size_i - let size = min wanted (fromIntegral $ size_i-offset_i) - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> - do r <- if size == 0 then return 0 else hGetBuf handle ptr size - if r /= size - then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) - else newUTF8StringBuffer buf ptr size - -hPutStringBuffer :: Handle -> StringBuffer -> IO () -hPutStringBuffer hdl (StringBuffer buf len cur) - = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> - hPutBuf hdl ptr len - --- | Skip the byte-order mark if there is one (see #1744 and #6016), --- and return the new position of the handle in bytes. --- --- This is better than treating #FEFF as whitespace, --- because that would mess up layout. We don't have a concept --- of zero-width whitespace in Haskell: all whitespace codepoints --- have a width of one column. -skipBOM :: Handle -> Integer -> Integer -> IO Integer -skipBOM h size offset = - -- Only skip BOM at the beginning of a file. - if size > 0 && offset == 0 - then do - -- Validate assumption that handle is in binary mode. - ASSERTM( hGetEncoding h >>= return . isNothing ) - -- Temporarily select utf8 encoding with error ignoring, - -- to make `hLookAhead` and `hGetChar` return full Unicode characters. - bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do - c <- hLookAhead h - if c == '\xfeff' - then hGetChar h >> hTell h - else return offset - else return offset - where - safeEncoding = mkUTF8 IgnoreCodingFailure - -newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer -newUTF8StringBuffer buf ptr size = do - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return $ StringBuffer buf size 0 - -appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer -appendStringBuffers sb1 sb2 - = do newBuf <- mallocForeignPtrArray (size+3) - withForeignPtr newBuf $ \ptr -> - withForeignPtr (buf sb1) $ \sb1Ptr -> - withForeignPtr (buf sb2) $ \sb2Ptr -> - do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len - copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len - pokeArray (ptr `advancePtr` size) [0,0,0] - return (StringBuffer newBuf size 0) - where sb1_len = calcLen sb1 - sb2_len = calcLen sb2 - calcLen sb = len sb - cur sb - size = sb1_len + sb2_len - --- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer --- is automatically managed by the garbage collector. -stringToStringBuffer :: String -> StringBuffer -stringToStringBuffer str = - unsafePerformIO $ do - let size = utf8EncodedLength str - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return (StringBuffer buf size 0) - --- ----------------------------------------------------------------------------- --- Grab a character - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well --- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The --- behavior is undefined if the 'StringBuffer' is empty. The result shares --- the same buffer as the original. Similar to 'utf8DecodeChar', if the --- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. -{-# INLINE nextChar #-} -nextChar :: StringBuffer -> (Char,StringBuffer) -nextChar (StringBuffer buf len (I# cur#)) = - -- Getting our fingers dirty a little here, but this is performance-critical - inlinePerformIO $ do - withForeignPtr buf $ \(Ptr a#) -> do - case utf8DecodeChar# (a# `plusAddr#` cur#) of - (# c#, nBytes# #) -> - let cur' = I# (cur# +# nBytes#) in - return (C# c#, StringBuffer buf len cur') - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous --- to 'Data.List.head'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character --- cannot be decoded as UTF-8, @\'\\0\'@ is returned. -currentChar :: StringBuffer -> Char -currentChar = fst . nextChar - -prevChar :: StringBuffer -> Char -> Char -prevChar (StringBuffer _ _ 0) deflt = deflt -prevChar (StringBuffer buf _ cur) _ = - inlinePerformIO $ do - withForeignPtr buf $ \p -> do - p' <- utf8PrevChar (p `plusPtr` cur) - return (fst (utf8DecodeChar p')) - --- ----------------------------------------------------------------------------- --- Moving - --- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous --- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. The result shares the same buffer as the --- original. -stepOn :: StringBuffer -> StringBuffer -stepOn s = snd (nextChar s) - --- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ --- If there aren't enough characters, the returned 'StringBuffer' will be --- invalid and any use of it may lead to undefined behavior. The result --- shares the same buffer as the original. -offsetBytes :: Int -- ^ @n@, the number of bytes - -> StringBuffer - -> StringBuffer -offsetBytes i s = s { cur = cur s + i } - --- | Compute the difference in offset between two 'StringBuffer's that share --- the same buffer. __Warning:__ The behavior is undefined if the --- 'StringBuffer's use separate buffers. -byteDiff :: StringBuffer -> StringBuffer -> Int -byteDiff s1 s2 = cur s2 - cur s1 - --- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). -atEnd :: StringBuffer -> Bool -atEnd (StringBuffer _ l c) = l == c - --- | Computes a 'StringBuffer' which points to the first character of the --- wanted line. Lines begin at 1. -atLine :: Int -> StringBuffer -> Maybe StringBuffer -atLine line sb@(StringBuffer buf len _) = - inlinePerformIO $ - withForeignPtr buf $ \p -> do - p' <- skipToLine line len p - if p' == nullPtr - then return Nothing - else - let - delta = p' `minusPtr` p - in return $ Just (sb { cur = delta - , len = len - delta - }) - -skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) -skipToLine !line !len !op0 = go 1 op0 - where - !opend = op0 `plusPtr` len - - go !i_line !op - | op >= opend = pure nullPtr - | i_line == line = pure op - | otherwise = do - w <- peek op :: IO Word8 - case w of - 10 -> go (i_line + 1) (plusPtr op 1) - 13 -> do - -- this is safe because a 'StringBuffer' is - -- guaranteed to have 3 bytes sentinel values. - w' <- peek (plusPtr op 1) :: IO Word8 - case w' of - 10 -> go (i_line + 1) (plusPtr op 2) - _ -> go (i_line + 1) (plusPtr op 1) - _ -> go i_line (plusPtr op 1) - --- ----------------------------------------------------------------------------- --- Conversion - --- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. --- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, --- they will be replaced with @\'\\0\'@. -lexemeToString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> String -lexemeToString _ 0 = "" -lexemeToString (StringBuffer buf _ cur) bytes = - utf8DecodeStringLazy buf cur bytes - -lexemeToFastString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> FastString -lexemeToFastString _ 0 = nilFS -lexemeToFastString (StringBuffer buf _ cur) len = - inlinePerformIO $ - withForeignPtr buf $ \ptr -> - return $! mkFastStringBytes (ptr `plusPtr` cur) len - --- | Return the previous @n@ characters (or fewer if we are less than @n@ --- characters into the buffer. -decodePrevNChars :: Int -> StringBuffer -> String -decodePrevNChars n (StringBuffer buf _ cur) = - inlinePerformIO $ withForeignPtr buf $ \p0 -> - go p0 n "" (p0 `plusPtr` (cur - 1)) - where - go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String - go buf0 n acc p | n == 0 || buf0 >= p = return acc - go buf0 n acc p = do - p' <- utf8PrevChar p - let (c,_) = utf8DecodeChar p' - go buf0 (n - 1) (c:acc) p' - --- ----------------------------------------------------------------------------- --- Parsing integer strings in various bases -parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer -parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int - = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let - go i x | i == len = x - | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of - '_' -> go (i + 1) x -- skip "_" (#14473) - char -> go (i + 1) (x * radix + toInteger (char_to_int char)) - in go 0 0 diff --git a/compiler/utils/TrieMap.hs b/compiler/utils/TrieMap.hs deleted file mode 100644 index 815a060a0c..0000000000 --- a/compiler/utils/TrieMap.hs +++ /dev/null @@ -1,406 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -module TrieMap( - -- * Maps over 'Maybe' values - MaybeMap, - -- * Maps over 'List' values - ListMap, - -- * Maps over 'Literal's - LiteralMap, - -- * 'TrieMap' class - TrieMap(..), insertTM, deleteTM, - - -- * Things helpful for adding additional Instances. - (>.>), (|>), (|>>), XT, - foldMaybe, - -- * Map for leaf compression - GenMap, - lkG, xtG, mapG, fdG, - xtList, lkList - - ) where - -import GhcPrelude - -import GHC.Types.Literal -import GHC.Types.Unique.DFM -import GHC.Types.Unique( Unique ) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Outputable -import Control.Monad( (>=>) ) -import Data.Kind( Type ) - -{- -This module implements TrieMaps, which are finite mappings -whose key is a structured value like a CoreExpr or Type. - -This file implements tries over general data structures. -Implementation for tries over Core Expressions/Types are -available in GHC.Core.Map. - -The regular pattern for handling TrieMaps on data structures was first -described (to my knowledge) in Connelly and Morris's 1995 paper "A -generalization of the Trie Data Structure"; there is also an accessible -description of the idea in Okasaki's book "Purely Functional Data -Structures", Section 10.3.2 - -************************************************************************ -* * - The TrieMap class -* * -************************************************************************ --} - -type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) - -- or an existing elt (Just) - -class TrieMap m where - type Key m :: Type - emptyTM :: m a - lookupTM :: forall b. Key m -> m b -> Maybe b - alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b - - foldTM :: (a -> b -> b) -> m a -> b -> b - -- The unusual argument order here makes - -- it easy to compose calls to foldTM; - -- see for example fdE below - -insertTM :: TrieMap m => Key m -> a -> m a -> m a -insertTM k v m = alterTM k (\_ -> Just v) m - -deleteTM :: TrieMap m => Key m -> m a -> m a -deleteTM k m = alterTM k (\_ -> Nothing) m - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - -(>.>) :: (a -> b) -> (b -> c) -> a -> c --- Reverse function composition (do f first, then g) -infixr 1 >.> -(f >.> g) x = g (f x) -infixr 1 |>, |>> - -(|>) :: a -> (a->b) -> b -- Reverse application -x |> f = f x - ----------------------- -(|>>) :: TrieMap m2 - => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) - -> (m2 a -> m2 a) - -> m1 (m2 a) -> m1 (m2 a) -(|>>) f g = f (Just . g . deMaybe) - -deMaybe :: TrieMap m => Maybe (m a) -> m a -deMaybe Nothing = emptyTM -deMaybe (Just m) = m - -{- -************************************************************************ -* * - IntMaps -* * -************************************************************************ --} - -instance TrieMap IntMap.IntMap where - type Key IntMap.IntMap = Int - emptyTM = IntMap.empty - lookupTM k m = IntMap.lookup k m - alterTM = xtInt - foldTM k m z = IntMap.foldr k z m - mapTM f m = IntMap.map f m - -xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a -xtInt k f m = IntMap.alter f k m - -instance Ord k => TrieMap (Map.Map k) where - type Key (Map.Map k) = k - emptyTM = Map.empty - lookupTM = Map.lookup - alterTM k f m = Map.alter f k m - foldTM k m z = Map.foldr k z m - mapTM f m = Map.map f m - - -{- -Note [foldTM determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We want foldTM to be deterministic, which is why we have an instance of -TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that -go wrong if foldTM is nondeterministic. Consider: - - f a b = return (a <> b) - -Depending on the order that the typechecker generates constraints you -get either: - - f :: (Monad m, Monoid a) => a -> a -> m a - -or: - - f :: (Monoid a, Monad m) => a -> a -> m a - -The generated code will be different after desugaring as the dictionaries -will be bound in different orders, leading to potential ABI incompatibility. - -One way to solve this would be to notice that the typeclasses could be -sorted alphabetically. - -Unfortunately that doesn't quite work with this example: - - f a b = let x = a <> a; y = b <> b in x - -where you infer: - - f :: (Monoid m, Monoid m1) => m1 -> m -> m1 - -or: - - f :: (Monoid m1, Monoid m) => m1 -> m -> m1 - -Here you could decide to take the order of the type variables in the type -according to depth first traversal and use it to order the constraints. - -The real trouble starts when the user enables incoherent instances and -the compiler has to make an arbitrary choice. Consider: - - class T a b where - go :: a -> b -> String - - instance (Show b) => T Int b where - go a b = show a ++ show b - - instance (Show a) => T a Bool where - go a b = show a ++ show b - - f = go 10 True - -GHC is free to choose either dictionary to implement f, but for the sake of -determinism we'd like it to be consistent when compiling the same sources -with the same flags. - -inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it -gets converted to a bag of (Wanted) Cts using a fold. Then in -solve_simple_wanteds it's merged with other WantedConstraints. We want the -conversion to a bag to be deterministic. For that purpose we use UniqDFM -instead of UniqFM to implement the TrieMap. - -See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made -deterministic. --} - -instance TrieMap UniqDFM where - type Key UniqDFM = Unique - emptyTM = emptyUDFM - lookupTM k m = lookupUDFM m k - alterTM k f m = alterUDFM f m k - foldTM k m z = foldUDFM k z m - mapTM f m = mapUDFM f m - -{- -************************************************************************ -* * - Maybes -* * -************************************************************************ - -If m is a map from k -> val -then (MaybeMap m) is a map from (Maybe k) -> val --} - -data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } - -instance TrieMap m => TrieMap (MaybeMap m) where - type Key (MaybeMap m) = Maybe (Key m) - emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } - lookupTM = lkMaybe lookupTM - alterTM = xtMaybe alterTM - foldTM = fdMaybe - mapTM = mapMb - -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - -lkMaybe :: (forall b. k -> m b -> Maybe b) - -> Maybe k -> MaybeMap m a -> Maybe a -lkMaybe _ Nothing = mm_nothing -lkMaybe lk (Just x) = mm_just >.> lk x - -xtMaybe :: (forall b. k -> XT b -> m b -> m b) - -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a -xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } -xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } - -fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b -fdMaybe k m = foldMaybe k (mm_nothing m) - . foldTM k (mm_just m) - -{- -************************************************************************ -* * - Lists -* * -************************************************************************ --} - -data ListMap m a - = LM { lm_nil :: Maybe a - , lm_cons :: m (ListMap m a) } - -instance TrieMap m => TrieMap (ListMap m) where - type Key (ListMap m) = [Key m] - emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } - lookupTM = lkList lookupTM - alterTM = xtList alterTM - foldTM = fdList - mapTM = mapList - -instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where - ppr m = text "List elts" <+> ppr (foldTM (:) m []) - -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - -lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) - -> [k] -> ListMap m a -> Maybe a -lkList _ [] = lm_nil -lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs - -xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) - -> [k] -> XT a -> ListMap m a -> ListMap m a -xtList _ [] f m = m { lm_nil = f (lm_nil m) } -xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } - -fdList :: forall m a b. TrieMap m - => (a -> b -> b) -> ListMap m a -> b -> b -fdList k m = foldMaybe k (lm_nil m) - . foldTM (fdList k) (lm_cons m) - -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b -foldMaybe _ Nothing b = b -foldMaybe k (Just a) b = k a b - -{- -************************************************************************ -* * - Basic maps -* * -************************************************************************ --} - -type LiteralMap a = Map.Map Literal a - -{- -************************************************************************ -* * - GenMap -* * -************************************************************************ - -Note [Compressed TrieMap] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -The GenMap constructor augments TrieMaps with leaf compression. This helps -solve the performance problem detailed in #9960: suppose we have a handful -H of entries in a TrieMap, each with a very large key, size K. If you fold over -such a TrieMap you'd expect time O(H). That would certainly be true of an -association list! But with TrieMap we actually have to navigate down a long -singleton structure to get to the elements, so it takes time O(K*H). This -can really hurt on many type-level computation benchmarks: -see for example T9872d. - -The point of a TrieMap is that you need to navigate to the point where only one -key remains, and then things should be fast. So the point of a SingletonMap -is that, once we are down to a single (key,value) pair, we stop and -just use SingletonMap. - -'EmptyMap' provides an even more basic (but essential) optimization: if there is -nothing in the map, don't bother building out the (possibly infinite) recursive -TrieMap structure! - -Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things -as INLINEABLE to permit specialization. --} - -data GenMap m a - = EmptyMap - | SingletonMap (Key m) a - | MultiMap (m a) - -instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where - ppr EmptyMap = text "Empty map" - ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v - ppr (MultiMap m) = ppr m - --- TODO undecidable instance -instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where - type Key (GenMap m) = Key m - emptyTM = EmptyMap - lookupTM = lkG - alterTM = xtG - foldTM = fdG - mapTM = mapG - ---We want to be able to specialize these functions when defining eg ---tries over (GenMap CoreExpr) which requires INLINEABLE - -{-# INLINEABLE lkG #-} -lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a -lkG _ EmptyMap = Nothing -lkG k (SingletonMap k' v') | k == k' = Just v' - | otherwise = Nothing -lkG k (MultiMap m) = lookupTM k m - -{-# INLINEABLE xtG #-} -xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a -xtG k f EmptyMap - = case f Nothing of - Just v -> SingletonMap k v - Nothing -> EmptyMap -xtG k f m@(SingletonMap k' v') - | k' == k - -- The new key matches the (single) key already in the tree. Hence, - -- apply @f@ to @Just v'@ and build a singleton or empty map depending - -- on the 'Just'/'Nothing' response respectively. - = case f (Just v') of - Just v'' -> SingletonMap k' v'' - Nothing -> EmptyMap - | otherwise - -- We've hit a singleton tree for a different key than the one we are - -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then - -- we can just return the old map. If not, we need a map with *two* - -- entries. The easiest way to do that is to insert two items into an empty - -- map of type @m a@. - = case f Nothing of - Nothing -> m - Just v -> emptyTM |> alterTM k' (const (Just v')) - >.> alterTM k (const (Just v)) - >.> MultiMap -xtG k f (MultiMap m) = MultiMap (alterTM k f m) - -{-# INLINEABLE mapG #-} -mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b -mapG _ EmptyMap = EmptyMap -mapG f (SingletonMap k v) = SingletonMap k (f v) -mapG f (MultiMap m) = MultiMap (mapTM f m) - -{-# INLINEABLE fdG #-} -fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b -fdG _ EmptyMap = \z -> z -fdG k (SingletonMap _ v) = \z -> k v z -fdG k (MultiMap m) = foldTM k m diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs deleted file mode 100644 index 20eff96c2c..0000000000 --- a/compiler/utils/UnVarGraph.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- - -Copyright (c) 2014 Joachim Breitner - -A data structure for undirected graphs of variables -(or in plain terms: Sets of unordered pairs of numbers) - - -This is very specifically tailored for the use in CallArity. In particular it -stores the graph as a union of complete and complete bipartite graph, which -would be very expensive to store as sets of edges or as adjanceny lists. - -It does not normalize the graphs. This means that g `unionUnVarGraph` g is -equal to g, but twice as expensive and large. - --} -module UnVarGraph - ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets - , delUnVarSet - , elemUnVarSet, isEmptyUnVarSet - , UnVarGraph - , emptyUnVarGraph - , unionUnVarGraph, unionUnVarGraphs - , completeGraph, completeBipartiteGraph - , neighbors - , hasLoopAt - , delNode - ) where - -import GhcPrelude - -import GHC.Types.Id -import GHC.Types.Var.Env -import GHC.Types.Unique.FM -import Outputable -import Bag -import GHC.Types.Unique - -import qualified Data.IntSet as S - --- We need a type for sets of variables (UnVarSet). --- We do not use VarSet, because for that we need to have the actual variable --- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. --- Therefore, use a IntSet directly (which is likely also a bit more efficient). - --- Set of uniques, i.e. for adjancet nodes -newtype UnVarSet = UnVarSet (S.IntSet) - deriving Eq - -k :: Var -> Int -k v = getKey (getUnique v) - -emptyUnVarSet :: UnVarSet -emptyUnVarSet = UnVarSet S.empty - -elemUnVarSet :: Var -> UnVarSet -> Bool -elemUnVarSet v (UnVarSet s) = k v `S.member` s - - -isEmptyUnVarSet :: UnVarSet -> Bool -isEmptyUnVarSet (UnVarSet s) = S.null s - -delUnVarSet :: UnVarSet -> Var -> UnVarSet -delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s - -mkUnVarSet :: [Var] -> UnVarSet -mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs - -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae - -unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet -unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) - -unionUnVarSets :: [UnVarSet] -> UnVarSet -unionUnVarSets = foldr unionUnVarSet emptyUnVarSet - -instance Outputable UnVarSet where - ppr (UnVarSet s) = braces $ - hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) - -emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag - -unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph -{- -Premature optimisation, it seems. -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s1 == s3 && s2 == s4 - = pprTrace "unionUnVarGraph fired" empty $ - completeGraph (s1 `unionUnVarSet` s2) -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s2 == s3 && s1 == s4 - = pprTrace "unionUnVarGraph fired2" empty $ - completeGraph (s1 `unionUnVarSet` s2) --} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) - -unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph -unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph - --- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } -completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 - -completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s - -neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) - --- hasLoopAt G v <=> v--v ∈ G -hasLoopAt :: UnVarGraph -> Var -> Bool -hasLoopAt (UnVarGraph g) v = any go $ bagToList g - where go (CG s) = v `elemUnVarSet` s - go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 - - -delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) - -prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) - -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 -instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs deleted file mode 100644 index b343d9cf8b..0000000000 --- a/compiler/utils/Util.hs +++ /dev/null @@ -1,1465 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Highly random utility functions --- -module Util ( - -- * Flags dependent on the compiler build - ghciSupported, debugIsOn, - isWindowsHost, isDarwinHost, - - -- * Miscellaneous higher-order functions - applyWhen, nTimes, - - -- * General list processing - zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, - - zipWithLazy, zipWith3Lazy, - - filterByList, filterByLists, partitionByList, - - unzipWith, - - mapFst, mapSnd, chkAppend, - mapAndUnzip, mapAndUnzip3, mapAccumL2, - filterOut, partitionWith, - - dropWhileEndLE, spanEnd, last2, lastMaybe, - - foldl1', foldl2, count, countWhile, all2, - - lengthExceeds, lengthIs, lengthIsNot, - lengthAtLeast, lengthAtMost, lengthLessThan, - listLengthCmp, atLength, - equalLength, compareLength, leLength, ltLength, - - isSingleton, only, singleton, - notNull, snocView, - - isIn, isn'tIn, - - chunkList, - - changeLast, - - whenNonEmpty, - - -- * Tuples - fstOf3, sndOf3, thdOf3, - firstM, first3M, secondM, - fst3, snd3, third3, - uncurry3, - liftFst, liftSnd, - - -- * List operations controlled by another list - takeList, dropList, splitAtList, split, - dropTail, capitalise, - - -- * Sorting - sortWith, minWith, nubSort, ordNub, - - -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, - removeSpaces, - (<&&>), (<||>), - - -- * Edit distance - fuzzyMatch, fuzzyLookup, - - -- * Transitive closures - transitiveClosure, - - -- * Strictness - seqList, strictMap, - - -- * Module names - looksLikeModuleName, - looksLikePackageName, - - -- * Argument processing - getCmd, toCmdArgs, toArgs, - - -- * Integers - exactLog2, - - -- * Floating point - readRational, - readHexRational, - - -- * IO-ish utilities - doesDirNameExist, - getModificationUTCTime, - modificationTimeIfExists, - withAtomicRename, - - global, consIORef, globalM, - sharedGlobal, sharedGlobalM, - - -- * Filenames and paths - Suffix, - splitLongestPrefix, - escapeSpaces, - Direction(..), reslash, - makeRelativeTo, - - -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType, - - -- * Utils for printing C code - charToC, - - -- * Hashing - hashString, - - -- * Call stacks - HasCallStack, - HasDebugCallStack, - - -- * Utils for flags - OverridingBool(..), - overrideWith, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Exception -import PlainPanic - -import Data.Data -import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.List hiding (group) -import Data.List.NonEmpty ( NonEmpty(..) ) - -import GHC.Exts -import GHC.Stack (HasCallStack) - -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM, guard ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) -import GHC.Conc.Sync ( sharedCAF ) -import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) -import System.FilePath - -import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper - , isHexDigit, digitToInt ) -import Data.Int -import Data.Ratio ( (%) ) -import Data.Ord ( comparing ) -import Data.Bits -import Data.Word -import qualified Data.IntMap as IM -import qualified Data.Set as Set - -import Data.Time - -#if defined(DEBUG) -import {-# SOURCE #-} Outputable ( warnPprTrace, text ) -#endif - -infixr 9 `thenCmp` - -{- -************************************************************************ -* * -\subsection{Is DEBUG on, are we on Windows, etc?} -* * -************************************************************************ - -These booleans are global constants, set by CPP flags. They allow us to -recompile a single module (this one) to change whether or not debug output -appears. They sometimes let us avoid even running CPP elsewhere. - -It's important that the flags are literal constants (True/False). Then, -with -0, tests of the flags in other modules will simplify to the correct -branch of the conditional, thereby dropping debug code altogether when -the flags are off. --} - -ghciSupported :: Bool -#if defined(HAVE_INTERNAL_INTERPRETER) -ghciSupported = True -#else -ghciSupported = False -#endif - -debugIsOn :: Bool -#if defined(DEBUG) -debugIsOn = True -#else -debugIsOn = False -#endif - -isWindowsHost :: Bool -#if defined(mingw32_HOST_OS) -isWindowsHost = True -#else -isWindowsHost = False -#endif - -isDarwinHost :: Bool -#if defined(darwin_HOST_OS) -isDarwinHost = True -#else -isDarwinHost = False -#endif - -{- -************************************************************************ -* * -\subsection{Miscellaneous higher-order functions} -* * -************************************************************************ --} - --- | Apply a function iff some condition is met. -applyWhen :: Bool -> (a -> a) -> a -> a -applyWhen True f x = f x -applyWhen _ _ x = x - --- | A for loop: Compose a function with itself n times. (nth rather than twice) -nTimes :: Int -> (a -> a) -> (a -> a) -nTimes 0 _ = id -nTimes 1 f = f -nTimes n f = f . nTimes (n-1) f - -fstOf3 :: (a,b,c) -> a -sndOf3 :: (a,b,c) -> b -thdOf3 :: (a,b,c) -> c -fstOf3 (a,_,_) = a -sndOf3 (_,b,_) = b -thdOf3 (_,_,c) = c - -fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) -fst3 f (a, b, c) = (f a, b, c) - -snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) -snd3 f (a, b, c) = (a, f b, c) - -third3 :: (c -> d) -> (a, b, c) -> (a, b, d) -third3 f (a, b, c) = (a, b, f c) - -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c - -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) -secondM f (x, y) = (x,) <$> f y - -{- -************************************************************************ -* * -\subsection[Utils-lists]{General list processing} -* * -************************************************************************ --} - -filterOut :: (a->Bool) -> [a] -> [a] --- ^ Like filter, only it reverses the sense of the test -filterOut _ [] = [] -filterOut p (x:xs) | p x = filterOut p xs - | otherwise = x : filterOut p xs - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) --- ^ Uses a function to determine which of two output lists an input element should join -partitionWith _ [] = ([],[]) -partitionWith f (x:xs) = case f x of - Left b -> (b:bs, cs) - Right c -> (bs, c:cs) - where (bs,cs) = partitionWith f xs - -chkAppend :: [a] -> [a] -> [a] --- Checks for the second argument being empty --- Used in situations where that situation is common -chkAppend xs ys - | null ys = xs - | otherwise = xs ++ ys - -{- -A paranoid @zip@ (and some @zipWith@ friends) that checks the lists -are of equal length. Alastair Reid thinks this should only happen if -DEBUGging on; hey, why not? --} - -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] - -#if !defined(DEBUG) -zipEqual _ = zip -zipWithEqual _ = zipWith -zipWith3Equal _ = zipWith3 -zipWith4Equal _ = zipWith4 -#else -zipEqual _ [] [] = [] -zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs -zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg) - -zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs -zipWithEqual _ _ [] [] = [] -zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg) - -zipWith3Equal msg z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal msg z as bs cs -zipWith3Equal _ _ [] [] [] = [] -zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg) - -zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal msg z as bs cs ds -zipWith4Equal _ _ [] [] [] [] = [] -zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) -#endif - --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - --- | 'filterByList' takes a list of Bools and a list of some elements and --- filters out these elements for which the corresponding value in the list of --- Bools is False. This function does not check whether the lists have equal --- length. -filterByList :: [Bool] -> [a] -> [a] -filterByList (True:bs) (x:xs) = x : filterByList bs xs -filterByList (False:bs) (_:xs) = filterByList bs xs -filterByList _ _ = [] - --- | 'filterByLists' takes a list of Bools and two lists as input, and --- outputs a new list consisting of elements from the last two input lists. For --- each Bool in the list, if it is 'True', then it takes an element from the --- former list. If it is 'False', it takes an element from the latter list. --- The elements taken correspond to the index of the Bool in its list. --- For example: --- --- @ --- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" --- @ --- --- This function does not check whether the lists have equal length. -filterByLists :: [Bool] -> [a] -> [a] -> [a] -filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys -filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys -filterByLists _ _ _ = [] - --- | 'partitionByList' takes a list of Bools and a list of some elements and --- partitions the list according to the list of Bools. Elements corresponding --- to 'True' go to the left; elements corresponding to 'False' go to the right. --- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ --- This function does not check whether the lists have equal --- length; when one list runs out, the function stops. -partitionByList :: [Bool] -> [a] -> ([a], [a]) -partitionByList = go [] [] - where - go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs - go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs - go trues falses _ _ = (reverse trues, reverse falses) - -stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] --- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in --- the places where @p@ returns @True@ - -stretchZipWith _ _ _ [] _ = [] -stretchZipWith p z f (x:xs) ys - | p x = f x z : stretchZipWith p z f xs ys - | otherwise = case ys of - [] -> [] - (y:ys) -> f x y : stretchZipWith p z f xs ys - -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] - -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] - -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) - -mapAndUnzip _ [] = ([], []) -mapAndUnzip f (x:xs) - = let (r1, r2) = f x - (rs1, rs2) = mapAndUnzip f xs - in - (r1:rs1, r2:rs2) - -mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) - -mapAndUnzip3 _ [] = ([], [], []) -mapAndUnzip3 f (x:xs) - = let (r1, r2, r3) = f x - (rs1, rs2, rs3) = mapAndUnzip3 f xs - in - (r1:rs1, r2:rs2, r3:rs3) - -zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) -zipWithAndUnzip f (a:as) (b:bs) - = let (r1, r2) = f a b - (rs1, rs2) = zipWithAndUnzip f as bs - in - (r1:rs1, r2:rs2) -zipWithAndUnzip _ _ _ = ([],[]) - --- | This has the effect of making the two lists have equal length by dropping --- the tail of the longer one. -zipAndUnzip :: [a] -> [b] -> ([a],[b]) -zipAndUnzip (a:as) (b:bs) - = let (rs1, rs2) = zipAndUnzip as bs - in - (a:rs1, b:rs2) -zipAndUnzip _ _ = ([],[]) - -mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) -mapAccumL2 f s1 s2 xs = (s1', s2', ys) - where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of - (s1', s2', y) -> ((s1', s2'), y)) - (s1, s2) xs - --- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: --- --- @ --- atLength atLenPred atEndPred ls n --- | n < 0 = atLenPred ls --- | length ls < n = atEndPred (n - length ls) --- | otherwise = atLenPred (drop n ls) --- @ -atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) - -- NB: arg passed to this function may be [] - -> b -- Called when length ls < n - -> [a] - -> Int - -> b -atLength atLenPred atEnd ls0 n0 - | n0 < 0 = atLenPred ls0 - | otherwise = go n0 ls0 - where - -- go's first arg n >= 0 - go 0 ls = atLenPred ls - go _ [] = atEnd -- n > 0 here - go n (_:xs) = go (n-1) xs - --- Some special cases of atLength: - --- | @(lengthExceeds xs n) = (length xs > n)@ -lengthExceeds :: [a] -> Int -> Bool -lengthExceeds lst n - | n < 0 - = True - | otherwise - = atLength notNull False lst n - --- | @(lengthAtLeast xs n) = (length xs >= n)@ -lengthAtLeast :: [a] -> Int -> Bool -lengthAtLeast = atLength (const True) False - --- | @(lengthIs xs n) = (length xs == n)@ -lengthIs :: [a] -> Int -> Bool -lengthIs lst n - | n < 0 - = False - | otherwise - = atLength null False lst n - --- | @(lengthIsNot xs n) = (length xs /= n)@ -lengthIsNot :: [a] -> Int -> Bool -lengthIsNot lst n - | n < 0 = True - | otherwise = atLength notNull True lst n - --- | @(lengthAtMost xs n) = (length xs <= n)@ -lengthAtMost :: [a] -> Int -> Bool -lengthAtMost lst n - | n < 0 - = False - | otherwise - = atLength null True lst n - --- | @(lengthLessThan xs n) == (length xs < n)@ -lengthLessThan :: [a] -> Int -> Bool -lengthLessThan = atLength (const False) True - -listLengthCmp :: [a] -> Int -> Ordering -listLengthCmp = atLength atLen atEnd - where - atEnd = LT -- Not yet seen 'n' elts, so list length is < n. - - atLen [] = EQ - atLen _ = GT - -equalLength :: [a] -> [b] -> Bool --- ^ True if length xs == length ys -equalLength [] [] = True -equalLength (_:xs) (_:ys) = equalLength xs ys -equalLength _ _ = False - -compareLength :: [a] -> [b] -> Ordering -compareLength [] [] = EQ -compareLength (_:xs) (_:ys) = compareLength xs ys -compareLength [] _ = LT -compareLength _ [] = GT - -leLength :: [a] -> [b] -> Bool --- ^ True if length xs <= length ys -leLength xs ys = case compareLength xs ys of - LT -> True - EQ -> True - GT -> False - -ltLength :: [a] -> [b] -> Bool --- ^ True if length xs < length ys -ltLength xs ys = case compareLength xs ys of - LT -> True - EQ -> False - GT -> False - ----------------------------- -singleton :: a -> [a] -singleton x = [x] - -isSingleton :: [a] -> Bool -isSingleton [_] = True -isSingleton _ = False - -notNull :: [a] -> Bool -notNull [] = False -notNull _ = True - -only :: [a] -> a -#if defined(DEBUG) -only [a] = a -#else -only (a:_) = a -#endif -only _ = panic "Util: only" - --- Debugging/specialising versions of \tr{elem} and \tr{notElem} - -# if !defined(DEBUG) -isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool -isIn _msg x ys = x `elem` ys -isn'tIn _msg x ys = x `notElem` ys - -# else /* DEBUG */ -isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool -isIn msg x ys - = elem100 0 x ys - where - elem100 :: Eq a => Int -> a -> [a] -> Bool - elem100 _ _ [] = False - elem100 i x (y:ys) - | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) - | otherwise = x == y || elem100 (i + 1) x ys - -isn'tIn msg x ys - = notElem100 0 x ys - where - notElem100 :: Eq a => Int -> a -> [a] -> Bool - notElem100 _ _ [] = True - notElem100 i x (y:ys) - | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) - | otherwise = x /= y && notElem100 (i + 1) x ys -# endif /* DEBUG */ - - --- | Split a list into chunks of /n/ elements -chunkList :: Int -> [a] -> [[a]] -chunkList _ [] = [] -chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs - --- | Replace the last element of a list with another element. -changeLast :: [a] -> a -> [a] -changeLast [] _ = panic "changeLast" -changeLast [_] x = [x] -changeLast (x:xs) x' = x : changeLast xs x' - -whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () -whenNonEmpty [] _ = pure () -whenNonEmpty (x:xs) f = f (x :| xs) - -{- -************************************************************************ -* * -\subsubsection{Sort utils} -* * -************************************************************************ --} - -minWith :: Ord b => (a -> b) -> [a] -> a -minWith get_key xs = ASSERT( not (null xs) ) - head (sortWith get_key xs) - -nubSort :: Ord a => [a] -> [a] -nubSort = Set.toAscList . Set.fromList - --- | Remove duplicates but keep elements in order. --- O(n * log n) -ordNub :: Ord a => [a] -> [a] -ordNub xs - = go Set.empty xs - where - go _ [] = [] - go s (x:xs) - | Set.member x s = go s xs - | otherwise = x : go (Set.insert x s) xs - - -{- -************************************************************************ -* * -\subsection[Utils-transitive-closure]{Transitive closure} -* * -************************************************************************ - -This algorithm for transitive closure is straightforward, albeit quadratic. --} - -transitiveClosure :: (a -> [a]) -- Successor function - -> (a -> a -> Bool) -- Equality predicate - -> [a] - -> [a] -- The transitive closure - -transitiveClosure succ eq xs - = go [] xs - where - go done [] = done - go done (x:xs) | x `is_in` done = go done xs - | otherwise = go (x:done) (succ x ++ xs) - - _ `is_in` [] = False - x `is_in` (y:ys) | eq x y = True - | otherwise = x `is_in` ys - -{- -************************************************************************ -* * -\subsection[Utils-accum]{Accumulating} -* * -************************************************************************ - -A combination of foldl with zip. It works with equal length lists. --} - -foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc -foldl2 _ z [] [] = z -foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs -foldl2 _ _ _ _ = panic "Util: foldl2" - -all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool --- True if the lists are the same length, and --- all corresponding elements satisfy the predicate -all2 _ [] [] = True -all2 p (x:xs) (y:ys) = p x y && all2 p xs ys -all2 _ _ _ = False - --- Count the number of times a predicate is true - -count :: (a -> Bool) -> [a] -> Int -count p = go 0 - where go !n [] = n - go !n (x:xs) | p x = go (n+1) xs - | otherwise = go n xs - -countWhile :: (a -> Bool) -> [a] -> Int --- Length of an /initial prefix/ of the list satisfying p -countWhile p = go 0 - where go !n (x:xs) | p x = go (n+1) xs - go !n _ = n - -{- -@splitAt@, @take@, and @drop@ but with length of another -list giving the break-off point: --} - -takeList :: [b] -> [a] -> [a] --- (takeList as bs) trims bs to the be same length --- as as, unless as is longer in which case it's a no-op -takeList [] _ = [] -takeList (_:xs) ls = - case ls of - [] -> [] - (y:ys) -> y : takeList xs ys - -dropList :: [b] -> [a] -> [a] -dropList [] xs = xs -dropList _ xs@[] = xs -dropList (_:xs) (_:ys) = dropList xs ys - - -splitAtList :: [b] -> [a] -> ([a], [a]) -splitAtList [] xs = ([], xs) -splitAtList _ xs@[] = (xs, xs) -splitAtList (_:xs) (y:ys) = (y:ys', ys'') - where - (ys', ys'') = splitAtList xs ys - --- drop from the end of a list -dropTail :: Int -> [a] -> [a] --- Specification: dropTail n = reverse . drop n . reverse --- Better implemention due to Joachim Breitner --- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html -dropTail n xs - = go (drop n xs) xs - where - go (_:ys) (x:xs) = x : go ys xs - go _ _ = [] -- Stop when ys runs out - -- It'll always run out before xs does - --- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, --- but is lazy in the elements and strict in the spine. For reasonably short lists, --- such as path names and typical lines of text, dropWhileEndLE is generally --- faster than dropWhileEnd. Its advantage is magnified when the predicate is --- expensive--using dropWhileEndLE isSpace to strip the space off a line of text --- is generally much faster than using dropWhileEnd isSpace for that purpose. --- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse --- Pay attention to the short-circuit (&&)! The order of its arguments is the only --- difference between dropWhileEnd and dropWhileEndLE. -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @spanEnd p l == reverse (span p (reverse l))@. The first list --- returns actually comes after the second list (when you look at the --- input list). -spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) -spanEnd p l = go l [] [] l - where go yes _rev_yes rev_no [] = (yes, reverse rev_no) - go yes rev_yes rev_no (x:xs) - | p x = go yes (x : rev_yes) rev_no xs - | otherwise = go xs [] (x : rev_yes ++ rev_no) xs - --- | Get the last two elements in a list. Partial! -{-# INLINE last2 #-} -last2 :: [a] -> (a,a) -last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) - where - partialError = panic "last2 - list length less than two" - -lastMaybe :: [a] -> Maybe a -lastMaybe [] = Nothing -lastMaybe xs = Just $ last xs - --- | Split a list into its last element and the initial part of the list. --- @snocView xs = Just (init xs, last xs)@ for non-empty lists. --- @snocView xs = Nothing@ otherwise. --- Unless both parts of the result are guaranteed to be used --- prefer separate calls to @last@ + @init@. --- If you are guaranteed to use both, this will --- be more efficient. -snocView :: [a] -> Maybe ([a],a) -snocView [] = Nothing -snocView xs - | (xs,x) <- go xs - = Just (xs,x) - where - go :: [a] -> ([a],a) - go [x] = ([],x) - go (x:xs) - | !(xs',x') <- go xs - = (x:xs', x') - go [] = error "impossible" - -split :: Char -> String -> [String] -split c s = case rest of - [] -> [chunk] - _:rest -> chunk : split c rest - where (chunk, rest) = break (==c) s - --- | Convert a word to title case by capitalising the first letter -capitalise :: String -> String -capitalise [] = [] -capitalise (c:cs) = toUpper c : cs - - -{- -************************************************************************ -* * -\subsection[Utils-comparison]{Comparisons} -* * -************************************************************************ --} - -isEqual :: Ordering -> Bool --- Often used in (isEqual (a `compare` b)) -isEqual GT = False -isEqual EQ = True -isEqual LT = False - -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - -removeSpaces :: String -> String -removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace - --- Boolean operators lifted to Applicative -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) -infixr 3 <&&> -- same as (&&) - -(<||>) :: Applicative f => f Bool -> f Bool -> f Bool -(<||>) = liftA2 (||) -infixr 2 <||> -- same as (||) - -{- -************************************************************************ -* * -\subsection{Edit distance} -* * -************************************************************************ --} - --- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. --- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. --- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing --- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). --- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and --- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation -restrictedDamerauLevenshteinDistance :: String -> String -> Int -restrictedDamerauLevenshteinDistance str1 str2 - = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - where - m = length str1 - n = length str2 - -restrictedDamerauLevenshteinDistanceWithLengths - :: Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - | m <= n - = if n <= 32 -- n must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 - - | otherwise - = if m <= 32 -- m must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 - -restrictedDamerauLevenshteinDistance' - :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 - | [] <- str1 = n - | otherwise = extractAnswer $ - foldl' (restrictedDamerauLevenshteinDistanceWorker - (matchVectors str1) top_bit_mask vector_mask) - (0, 0, m_ones, 0, m) str2 - where - m_ones@vector_mask = (2 ^ m) - 1 - top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy - extractAnswer (_, _, _, _, distance) = distance - -restrictedDamerauLevenshteinDistanceWorker - :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv - -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) -restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask - (pm, d0, vp, vn, distance) char2 - = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ - seq pm' $ seq d0' $ seq vp' $ seq vn' $ - seq distance'' $ seq char2 $ - (pm', d0', vp', vn', distance'') - where - pm' = IM.findWithDefault 0 (ord char2) str1_mvs - - d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) - .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn - -- No need to mask the shiftL because of the restricted range of pm - - hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) - hn' = d0' .&. vp - - hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask - hn'_shift = (hn' `shiftL` 1) .&. vector_mask - vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) - vn' = d0' .&. hp'_shift - - distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance - distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' - -sizedComplement :: Bits bv => bv -> bv -> bv -sizedComplement vector_mask vect = vector_mask `xor` vect - -matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv -matchVectors = snd . foldl' go (0 :: Int, IM.empty) - where - go (ix, im) char = let ix' = ix + 1 - im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im - in seq ix' $ seq im' $ (ix', im') - -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Word32 -> Int -> Int -> String -> String -> Int #-} -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Integer -> Int -> Int -> String -> String -> Int #-} - -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Word32 -> Word32 -> Word32 - -> (Word32, Word32, Word32, Word32, Int) - -> Char -> (Word32, Word32, Word32, Word32, Int) #-} -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Integer -> Integer -> Integer - -> (Integer, Integer, Integer, Integer, Int) - -> Char -> (Integer, Integer, Integer, Integer, Int) #-} - -{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} -{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} - -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} - -fuzzyMatch :: String -> [String] -> [String] -fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] - --- | Search for possible matches to the users input in the given list, --- returning a small number of ranked results -fuzzyLookup :: String -> [(String,a)] -> [a] -fuzzyLookup user_entered possibilites - = map fst $ take mAX_RESULTS $ sortBy (comparing snd) - [ (poss_val, distance) | (poss_str, poss_val) <- possibilites - , let distance = restrictedDamerauLevenshteinDistance - poss_str user_entered - , distance <= fuzzy_threshold ] - where - -- Work out an appropriate match threshold: - -- We report a candidate if its edit distance is <= the threshold, - -- The threshold is set to about a quarter of the # of characters the user entered - -- Length Threshold - -- 1 0 -- Don't suggest *any* candidates - -- 2 1 -- for single-char identifiers - -- 3 1 - -- 4 1 - -- 5 1 - -- 6 2 - -- - fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) - mAX_RESULTS = 3 - -{- -************************************************************************ -* * -\subsection[Utils-pairs]{Pairs} -* * -************************************************************************ --} - -unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs - -seqList :: [a] -> b -> b -seqList [] b = b -seqList (x:xs) b = x `seq` seqList xs b - -strictMap :: (a -> b) -> [a] -> [b] -strictMap _ [] = [] -strictMap f (x : xs) = - let - !x' = f x - !xs' = strictMap f xs - in - x' : xs' - -{- -************************************************************************ -* * - Globals and the RTS -* * -************************************************************************ - -When a plugin is loaded, it currently gets linked against a *newly -loaded* copy of the GHC package. This would not be a problem, except -that the new copy has its own mutable state that is not shared with -that state that has already been initialized by the original GHC -package. - -(Note that if the GHC executable was dynamically linked this -wouldn't be a problem, because we could share the GHC library it -links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) - -The solution is to make use of @sharedCAF@ through @sharedGlobal@ -for globals that are shared between multiple copies of ghc packages. --} - --- Global variables: - -global :: a -> IORef a -global a = unsafePerformIO (newIORef a) - -consIORef :: IORef [a] -> a -> IO () -consIORef var x = do - atomicModifyIORef' var (\xs -> (x:xs,())) - -globalM :: IO a -> IORef a -globalM ma = unsafePerformIO (ma >>= newIORef) - --- Shared global variables: - -sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobal a get_or_set = unsafePerformIO $ - newIORef a >>= flip sharedCAF get_or_set - -sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobalM ma get_or_set = unsafePerformIO $ - ma >>= newIORef >>= flip sharedCAF get_or_set - --- Module names: - -looksLikeModuleName :: String -> Bool -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && go cs - where go [] = True - go ('.':cs) = looksLikeModuleName cs - go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs - --- Similar to 'parse' for Distribution.Package.PackageName, --- but we don't want to depend on Cabal. -looksLikePackageName :: String -> Bool -looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' - -{- -Akin to @Prelude.words@, but acts like the Bourne shell, treating -quoted strings as Haskell Strings, and also parses Haskell [String] -syntax. --} - -getCmd :: String -> Either String -- Error - (String, String) -- (Cmd, Rest) -getCmd s = case break isSpace $ dropWhile isSpace s of - ([], _) -> Left ("Couldn't find command in " ++ show s) - res -> Right res - -toCmdArgs :: String -> Either String -- Error - (String, [String]) -- (Cmd, Args) -toCmdArgs s = case getCmd s of - Left err -> Left err - Right (cmd, s') -> case toArgs s' of - Left err -> Left err - Right args -> Right (cmd, args) - -toArgs :: String -> Either String -- Error - [String] -- Args -toArgs str - = case dropWhile isSpace str of - s@('[':_) -> case reads s of - [(args, spaces)] - | all isSpace spaces -> - Right args - _ -> - Left ("Couldn't read " ++ show str ++ " as [String]") - s -> toArgs' s - where - toArgs' :: String -> Either String [String] - -- Remove outer quotes: - -- > toArgs' "\"foo\" \"bar baz\"" - -- Right ["foo", "bar baz"] - -- - -- Keep inner quotes: - -- > toArgs' "-DFOO=\"bar baz\"" - -- Right ["-DFOO=\"bar baz\""] - toArgs' s = case dropWhile isSpace s of - [] -> Right [] - ('"' : _) -> do - -- readAsString removes outer quotes - (arg, rest) <- readAsString s - (arg:) `fmap` toArgs' rest - s' -> case break (isSpace <||> (== '"')) s' of - (argPart1, s''@('"':_)) -> do - (argPart2, rest) <- readAsString s'' - -- show argPart2 to keep inner quotes - ((argPart1 ++ show argPart2):) `fmap` toArgs' rest - (arg, s'') -> (arg:) `fmap` toArgs' s'' - - readAsString :: String -> Either String (String, String) - readAsString s = case reads s of - [(arg, rest)] - -- rest must either be [] or start with a space - | all isSpace (take 1 rest) -> - Right (arg, rest) - _ -> - Left ("Couldn't read " ++ show s ++ " as String") ------------------------------------------------------------------------------ --- Integers - --- | Determine the $\log_2$ of exact powers of 2 -exactLog2 :: Integer -> Maybe Integer -exactLog2 x - | x <= 0 = Nothing - | x > fromIntegral (maxBound :: Int32) = Nothing - | x' .&. (-x') /= x' = Nothing - | otherwise = Just (fromIntegral c) - where - x' = fromIntegral x :: Int32 - c = countTrailingZeros x' - -{- --- ----------------------------------------------------------------------------- --- Floats --} - -readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" -readRational__ r = do - (n,d,s) <- readFix r - (k,t) <- readExp s - return ((n%1)*10^^(k-d), t) - where - readFix r = do - (ds,s) <- lexDecDigits r - (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = return (0,s) - - readExp' ('+':s) = readDec s - readExp' ('-':s) = do (k,t) <- readDec s - return (-k,t) - readExp' s = readDec s - - readDec s = do - (ds,r) <- nonnull isDigit s - return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], - r) - - lexDecDigits = nonnull isDigit - - lexDotDigits ('.':s) = return (span' isDigit s) - lexDotDigits s = return ("",s) - - nonnull p s = do (cs@(_:_),t) <- return (span' p s) - return (cs,t) - - span' _ xs@[] = (xs, xs) - span' p xs@(x:xs') - | x == '_' = span' p xs' -- skip "_" (#14473) - | p x = let (ys,zs) = span' p xs' in (x:ys,zs) - | otherwise = ([],xs) - -readRational :: String -> Rational -- NB: *does* handle a leading "-" -readRational top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = case (do { (x,"") <- readRational__ s ; return x }) of - [x] -> x - [] -> error ("readRational: no parse:" ++ top_s) - _ -> error ("readRational: ambiguous parse:" ++ top_s) - - -readHexRational :: String -> Rational -readHexRational str = - case str of - '-' : xs -> - (readMe xs) - xs -> readMe xs - where - readMe as = - case readHexRational__ as of - Just n -> n - _ -> error ("readHexRational: no parse:" ++ str) - - -readHexRational__ :: String -> Maybe Rational -readHexRational__ ('0' : x : rest) - | x == 'X' || x == 'x' = - do let (front,rest2) = span' isHexDigit rest - guard (not (null front)) - let frontNum = steps 16 0 front - case rest2 of - '.' : rest3 -> - do let (back,rest4) = span' isHexDigit rest3 - guard (not (null back)) - let backNum = steps 16 frontNum back - exp1 = -4 * length back - case rest4 of - p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) - _ -> return (mk backNum exp1) - p : ps | isExp p -> fmap (mk frontNum) (getExp ps) - _ -> Nothing - - where - isExp p = p == 'p' || p == 'P' - - getExp ('+' : ds) = dec ds - getExp ('-' : ds) = fmap negate (dec ds) - getExp ds = dec ds - - mk :: Integer -> Int -> Rational - mk n e = fromInteger n * 2^^e - - dec cs = case span' isDigit cs of - (ds,"") | not (null ds) -> Just (steps 10 0 ds) - _ -> Nothing - - steps base n ds = foldl' (step base) n ds - step base n d = base * n + fromIntegral (digitToInt d) - - span' _ xs@[] = (xs, xs) - span' p xs@(x:xs') - | x == '_' = span' p xs' -- skip "_" (#14473) - | p x = let (ys,zs) = span' p xs' in (x:ys,zs) - | otherwise = ([],xs) - -readHexRational__ _ = Nothing - ------------------------------------------------------------------------------ --- Verify that the 'dirname' portion of a FilePath exists. --- -doesDirNameExist :: FilePath -> IO Bool -doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) - ------------------------------------------------------------------------------ --- Backwards compatibility definition of getModificationTime - -getModificationUTCTime :: FilePath -> IO UTCTime -getModificationUTCTime = getModificationTime - --- -------------------------------------------------------------- --- check existence & modification time at the same time - -modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) -modificationTimeIfExists f = do - (do t <- getModificationUTCTime f; return (Just t)) - `catchIO` \e -> if isDoesNotExistError e - then return Nothing - else ioError e - --- -------------------------------------------------------------- --- atomic file writing by writing to a temporary file first (see #14533) --- --- This should be used in all cases where GHC writes files to disk --- and uses their modification time to skip work later, --- as otherwise a partially written file (e.g. due to crash or Ctrl+C) --- also results in a skip. - -withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a -withAtomicRename targetFile f = do - -- The temp file must be on the same file system (mount) as the target file - -- to result in an atomic move on most platforms. - -- The standard way to ensure that is to place it into the same directory. - -- This can still be fooled when somebody mounts a different file system - -- at just the right time, but that is not a case we aim to cover here. - let temp = targetFile <.> "tmp" - res <- f temp - liftIO $ renameFile temp targetFile - return res - --- -------------------------------------------------------------- --- split a string at the last character where 'pred' is True, --- returning a pair of strings. The first component holds the string --- up (but not including) the last character for which 'pred' returned --- True, the second whatever comes after (but also not including the --- last character). --- --- If 'pred' returns False for all characters in the string, the original --- string is returned in the first component (and the second one is just --- empty). -splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) -splitLongestPrefix str pred - | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred (reverse str) - -escapeSpaces :: String -> String -escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" - -type Suffix = String - --------------------------------------------------------------- --- * Search path --------------------------------------------------------------- - -data Direction = Forwards | Backwards - -reslash :: Direction -> FilePath -> FilePath -reslash d = f - where f ('/' : xs) = slash : f xs - f ('\\' : xs) = slash : f xs - f (x : xs) = x : f xs - f "" = "" - slash = case d of - Forwards -> '/' - Backwards -> '\\' - -makeRelativeTo :: FilePath -> FilePath -> FilePath -this `makeRelativeTo` that = directory </> thisFilename - where (thisDirectory, thisFilename) = splitFileName this - thatDirectory = dropFileName that - directory = joinPath $ f (splitPath thisDirectory) - (splitPath thatDirectory) - - f (x : xs) (y : ys) - | x == y = f xs ys - f xs ys = replicate (length ys) ".." ++ xs - -{- -************************************************************************ -* * -\subsection[Utils-Data]{Utils for defining Data instances} -* * -************************************************************************ - -These functions helps us to define Data instances for abstract types. --} - -abstractConstr :: String -> Constr -abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix - -abstractDataType :: String -> DataType -abstractDataType n = mkDataType n [abstractConstr n] - -{- -************************************************************************ -* * -\subsection[Utils-C]{Utils for printing C code} -* * -************************************************************************ --} - -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -{- -************************************************************************ -* * -\subsection[Utils-Hashing]{Utils for hashing} -* * -************************************************************************ --} - --- | A sample hash function for Strings. We keep multiplying by the --- golden ratio and adding. The implementation is: --- --- > hashString = foldl' f golden --- > where f m c = fromIntegral (ord c) * magic + hashInt32 m --- > magic = 0xdeadbeef --- --- Where hashInt32 works just as hashInt shown above. --- --- Knuth argues that repeated multiplication by the golden ratio --- will minimize gaps in the hash space, and thus it's a good choice --- for combining together multiple keys to form one. --- --- Here we know that individual characters c are often small, and this --- produces frequent collisions if we use ord c alone. A --- particular problem are the shorter low ASCII and ISO-8859-1 --- character strings. We pre-multiply by a magic twiddle factor to --- obtain a good distribution. In fact, given the following test: --- --- > testp :: Int32 -> Int --- > testp k = (n - ) . length . group . sort . map hs . take n $ ls --- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] --- > hs = foldl' f golden --- > f m c = fromIntegral (ord c) * k + hashInt32 m --- > n = 100000 --- --- We discover that testp magic = 0. -hashString :: String -> Int32 -hashString = foldl' f golden - where f m c = fromIntegral (ord c) * magic + hashInt32 m - magic = fromIntegral (0xdeadbeef :: Word32) - -golden :: Int32 -golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 --- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 --- but that has bad mulHi properties (even adding 2^32 to get its inverse) --- Whereas the above works well and contains no hash duplications for --- [-32767..65536] - --- | A sample (and useful) hash function for Int32, --- implemented by extracting the uppermost 32 bits of the 64-bit --- result of multiplying by a 33-bit constant. The constant is from --- Knuth, derived from the golden ratio: --- --- > golden = round ((sqrt 5 - 1) * 2^32) --- --- We get good key uniqueness on small inputs --- (a problem with previous versions): --- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 --- -hashInt32 :: Int32 -> Int32 -hashInt32 x = mulHi x golden + x - --- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply -mulHi :: Int32 -> Int32 -> Int32 -mulHi a b = fromIntegral (r `shiftR` 32) - where r :: Int64 - r = fromIntegral a * fromIntegral b - --- | A call stack constraint, but only when 'isDebugOn'. -#if defined(DEBUG) -type HasDebugCallStack = HasCallStack -#else -type HasDebugCallStack = (() :: Constraint) -#endif - -data OverridingBool - = Auto - | Always - | Never - deriving Show - -overrideWith :: Bool -> OverridingBool -> Bool -overrideWith b Auto = b -overrideWith _ Always = True -overrideWith _ Never = False |