diff options
Diffstat (limited to 'ghc/compiler/utils')
28 files changed, 5924 insertions, 0 deletions
diff --git a/ghc/compiler/utils/Bag.hi b/ghc/compiler/utils/Bag.hi new file mode 100644 index 0000000000..caf1465199 --- /dev/null +++ b/ghc/compiler/utils/Bag.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Bag where +import Outputable(Outputable) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +bagToList :: Bag a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +emptyBag :: Bag a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-} +filterBag :: (a -> Bool) -> Bag a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +isEmptyBag :: Bag a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToBag :: [a] -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +partitionBag :: (a -> Bool) -> Bag a -> (Bag a, Bag a) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +snocBag :: Bag a -> a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +unionBags :: Bag a -> Bag a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 1 2 CC 13 _/\_ u0 -> \ (u1 :: Bag u0) (u2 :: Bag u0) -> case u1 of { _ALG_ _ORIG_ Bag EmptyBag -> u2; (u3 :: Bag u0) -> case u2 of { _ALG_ _ORIG_ Bag EmptyBag -> u3; (u4 :: Bag u0) -> _!_ _ORIG_ Bag TwoBags [u0] [u1, u2] } } _N_ #-} +unionManyBags :: [Bag a] -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: [Bag u0]) -> case u1 of { _ALG_ (:) (u2 :: Bag u0) (u3 :: [Bag u0]) -> _!_ _ORIG_ Bag ListOfBags [u0] [u1]; _NIL_ -> _!_ _ORIG_ Bag EmptyBag [u0] []; _NO_DEFLT_ } _N_ #-} +unitBag :: a -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Bag UnitBag [u0] [u1] _N_ #-} +instance Outputable a => Outputable (Bag a) + {-# GHC_PRAGMA _M_ Bag {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs new file mode 100644 index 0000000000..3734df5886 --- /dev/null +++ b/ghc/compiler/utils/Bag.lhs @@ -0,0 +1,110 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Bags]{@Bag@: an unordered collection with duplicates} + +\begin{code} +module Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, +#if ! defined(COMPILING_GHC) + elemBag, +#endif + filterBag, partitionBag, + isEmptyBag, snocBag, listToBag, bagToList + ) where + +#if defined(COMPILING_GHC) +import Id ( Id ) +import Outputable +import Pretty +import Util +#endif + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least + -- one branch is non-empty. + | ListOfBags [Bag a] -- The list is non-empty + +emptyBag = EmptyBag +unitBag = UnitBag + +#if ! defined(COMPILING_GHC) +-- not used in GHC +elemBag :: Eq a => a -> Bag a -> Bool +elemBag x EmptyBag = False +elemBag x (UnitBag y) = x==y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListOfBags bs) = any (x `elemBag`) bs +#endif + +unionManyBags [] = EmptyBag +unionManyBags xs = ListOfBags xs + +-- This one is a bit stricter! The bag will get completely evaluated. + + +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +snocBag :: Bag a -> a -> Bag a +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag EmptyBag = True +isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe +isEmptyBag (ListOfBags bs) = all isEmptyBag bs +isEmptyBag other = False + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag pred 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 (ListOfBags bs) = ListOfBags sats + where + sats = [filterBag pred b | b <- bs] + + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag pred 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 (ListOfBags bs) = (ListOfBags sats, ListOfBags fails) + where + (sats, fails) = unzip [partitionBag pred b | b <- bs] + + +listToBag :: [a] -> Bag a +listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst) + +bagToList :: Bag a -> [a] +bagToList b = b_to_l b [] + where + -- (b_to_l b xs) flattens b and puts xs on the end. + b_to_l EmptyBag xs = xs + b_to_l (UnitBag x) xs = x:xs + b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs) + b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs +\end{code} + +\begin{code} +#if defined(COMPILING_GHC) + +instance (Outputable a) => Outputable (Bag a) where + ppr sty EmptyBag = ppStr "emptyBag" + ppr sty (UnitBag a) = ppr sty a + ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2] + ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack] + +#endif {- COMPILING_GHC -} +\end{code} diff --git a/ghc/compiler/utils/BitSet.hi b/ghc/compiler/utils/BitSet.hi new file mode 100644 index 0000000000..92300ab028 --- /dev/null +++ b/ghc/compiler/utils/BitSet.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface BitSet where +data BitSet {-# GHC_PRAGMA MkBS Word# #-} +emptyBS :: BitSet + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 case _#_ int2Word# [] [0#] of { _PRIM_ (u0 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u0] } _N_ #-} +listBS :: BitSet -> [Int] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +minusBS :: BitSet -> BitSet -> BitSet + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ not# [] [u1] of { _PRIM_ (u2 :: Word#) -> case _#_ and# [] [u0, u2] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } } _N_} _F_ _IF_ARGS_ 0 2 CC 6 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ not# [] [u3] of { _PRIM_ (u4 :: Word#) -> case _#_ and# [] [u2, u4] of { _PRIM_ (u5 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u5] } }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +mkBS :: [Int] -> BitSet + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +singletonBS :: Int -> BitSet + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u1 :: Word#) -> case _#_ shiftL# [] [u1, u0] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Int) -> case u0 of { _ALG_ I# (u1 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u2 :: Word#) -> case _#_ shiftL# [] [u2, u1] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } }; _NO_DEFLT_ } _N_ #-} +unionBS :: BitSet -> BitSet -> BitSet + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ or# [] [u0, u1] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ or# [] [u2, u3] of { _PRIM_ (u4 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u4] }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs new file mode 100644 index 0000000000..eb6b52396f --- /dev/null +++ b/ghc/compiler/utils/BitSet.lhs @@ -0,0 +1,197 @@ +% +% (c) The GRASP Project, Glasgow University, 1994-1995 +% +\section[BitSet]{An implementation of very small sets} + +Bit sets are a fast implementation of sets of integers ranging from 0 +to one less than the number of bits in a machine word (typically 31). +If any element exceeds the maximum value for a particular machine +architecture, the results of these operations are undefined. You have +been warned. If you put any safety checks in this code, I will have +to kill you. + +Note: the Yale Haskell implementation won't provide a full 32 bits. +However, if you can handle the performance loss, you could change to +Integer and get virtually unlimited sets. + +\begin{code} + +module BitSet ( + BitSet, -- abstract type + mkBS, listBS, emptyBS, singletonBS, + unionBS, minusBS +#if ! defined(COMPILING_GHC) + , elementBS, intersectBS, isEmptyBS +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +-- nothing to import +#elif defined(__YALE_HASKELL__) +{-hide import from mkdependHS-} +import + LogOpPrims +#else +{-hide import from mkdependHS-} +import + Word +#endif + +#ifdef __GLASGOW_HASKELL__ + +data BitSet = MkBS Word# + +emptyBS :: BitSet +emptyBS = MkBS (int2Word# 0#) + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = case x of + I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#) + +unionBS :: BitSet -> BitSet -> BitSet +unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#) + +minusBS :: BitSet -> BitSet -> BitSet +minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#)) + +#if ! defined(COMPILING_GHC) +-- not used in GHC +isEmptyBS :: BitSet -> Bool +isEmptyBS (MkBS s#) = + case word2Int# s# of + 0# -> True + _ -> False + +intersectBS :: BitSet -> BitSet -> BitSet +intersectBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` y#) + +elementBS :: Int -> BitSet -> Bool +elementBS x (MkBS s#) = case x of + I# i# -> case word2Int# (((int2Word# 1#) `shiftL#` i#) `and#` s#) of + 0# -> False + _ -> True +#endif + +listBS :: BitSet -> [Int] +listBS s = listify s 0 + where listify (MkBS s#) n = + case word2Int# s# of + 0# -> [] + _ -> let s' = (MkBS (s# `shiftr` 1#)) + more = listify s' (n + 1) + in case word2Int# (s# `and#` (int2Word# 1#)) of + 0# -> more + _ -> n : more +# if __GLASGOW_HASKELL__ >= 23 + shiftr x y = shiftRL# x y +# else + shiftr x y = shiftR# x y +# endif + +#elif defined(__YALE_HASKELL__) + +data BitSet = MkBS Int + +emptyBS :: BitSet +emptyBS = MkBS 0 + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = MkBS (1 `ashInt` x) + +unionBS :: BitSet -> BitSet -> BitSet +unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y) + +#if ! defined(COMPILING_GHC) +-- not used in GHC +isEmptyBS :: BitSet -> Bool +isEmptyBS (MkBS s) = + case s of + 0 -> True + _ -> False + +intersectBS :: BitSet -> BitSet -> BitSet +intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y) + +elementBS :: Int -> BitSet -> Bool +elementBS x (MkBS s) = + case logbitpInt x s of + 0 -> False + _ -> True +#endif + +minusBS :: BitSet -> BitSet -> BitSet +minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y) + +-- rewritten to avoid right shifts (which would give nonsense on negative +-- values. +listBS :: BitSet -> [Int] +listBS (MkBS s) = listify s 0 1 + where listify s n m = + case s of + 0 -> [] + _ -> let n' = n+1; m' = m+m in + case logbitpInt s m of + 0 -> listify s n' m' + _ -> n : listify (s `logandc2Int` m) n' m' + +#else /* HBC, perhaps? */ + +data BitSet = MkBS Word + +emptyBS :: BitSet +emptyBS = MkBS 0 + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = MkBS (1 `bitLsh` x) + +unionBS :: BitSet -> BitSet -> BitSet +unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y) + +#if ! defined(COMPILING_GHC) +-- not used in GHC +isEmptyBS :: BitSet -> Bool +isEmptyBS (MkBS s) = + case s of + 0 -> True + _ -> False + +intersectBS :: BitSet -> BitSet -> BitSet +intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y) + +elementBS :: Int -> BitSet -> Bool +elementBS x (MkBS s) = + case (1 `bitLsh` x) `bitAnd` s of + 0 -> False + _ -> True +#endif + +minusBS :: BitSet -> BitSet -> BitSet +minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y)) + +listBS :: BitSet -> [Int] +listBS (MkBS s) = listify s 0 + where listify s n = + case s of + 0 -> [] + _ -> let s' = s `bitRsh` 1 + more = listify s' (n + 1) + in case (s `bitAnd` 1) of + 0 -> more + _ -> n : more + +#endif + +\end{code} + + + + diff --git a/ghc/compiler/utils/CharSeq.hi b/ghc/compiler/utils/CharSeq.hi new file mode 100644 index 0000000000..3d22652cf4 --- /dev/null +++ b/ghc/compiler/utils/CharSeq.hi @@ -0,0 +1,26 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CharSeq where +import PreludePS(_PackedString) +import Stdio(_FILE) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +cAppend :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cCh :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +cIndent :: Int -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CIndent [] [u0, u1] _N_ #-} +cInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +cNL :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNewline [] [] _N_ #-} +cNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +cPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +cShow :: CSeq -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +cStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} + diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs new file mode 100644 index 0000000000..d5520272fc --- /dev/null +++ b/ghc/compiler/utils/CharSeq.lhs @@ -0,0 +1,282 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CharSeq]{Characters sequences: the @CSeq@ type} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +#else +# define FAST_STRING String +# define FAST_INT Int +# define ILIT(x) (x) +# define IBOX(x) (x) +# define _GE_ >= +# define _ADD_ + +# define _SUB_ - +# define FAST_BOOL Bool +# define _TRUE_ True +# define _FALSE_ False +#endif + +module CharSeq ( + CSeq, + cNil, cAppend, cIndent, cNL, cStr, cPStr, cCh, cInt, +#if ! defined(COMPILING_GHC) + cLength, + cShows, +#endif + cShow + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + , cAppendFile + ) where + +#if __GLASGOW_HASKELL__ < 26 +import PreludePrimIO +#endif +import PreludeGlaST + +#else + ) where +#endif +\end{code} + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +cShow :: CSeq -> [Char] + +#if ! defined(COMPILING_GHC) +-- not used in GHC +cShows :: CSeq -> ShowS +cLength :: CSeq -> Int +#endif + +cNil :: CSeq +cAppend :: CSeq -> CSeq -> CSeq +cIndent :: Int -> CSeq -> CSeq +cNL :: CSeq +cStr :: [Char] -> CSeq +cPStr :: FAST_STRING -> CSeq +cCh :: Char -> CSeq +cInt :: Int -> CSeq + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif + +cAppendFile :: _FILE -> CSeq -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +data CSeq + = CNil + | CAppend CSeq CSeq + | CIndent Int CSeq + | CNewline -- Move to start of next line, unless we're + -- already at the start of a line. + | CStr [Char] + | CCh Char + | CInt Int -- equiv to "CStr (show the_int)" +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 + | CPStr _PackedString +#endif +\end{code} + +The construction functions do pattern matching, to ensure that +redundant CNils are eliminated. This is bound to have some effect on +evaluation order, but quite what I don't know. + +\begin{code} +cNil = CNil +\end{code} + +The following special cases were eating our lunch! They make the whole +thing too strict. A classic strictness bug! +\begin{code} +-- cAppend CNil cs2 = cs2 +-- cAppend cs1 CNil = cs1 + +cAppend cs1 cs2 = CAppend cs1 cs2 + +cIndent n cs = CIndent n cs + +cNL = CNewline +cStr = CStr +cCh = CCh +cInt = CInt + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +cPStr = CPStr +#else +cPStr = CStr +#endif + +cShow seq = flatten ILIT(0) _TRUE_ seq [] + +#if ! defined(COMPILING_GHC) +cShows seq rest = cShow seq ++ rest +cLength seq = length (cShow seq) -- *not* the best way to do this! +#endif + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +cAppendFile file_star seq + = flattenIO file_star seq +#endif +\end{code} + +This code is {\em hammered}. We are not above doing sleazy +non-standard things. (WDP 94/10) + +\begin{code} +data WorkItem = WI FAST_INT CSeq -- indentation, and sequence + +flatten :: FAST_INT -- Indentation + -> FAST_BOOL -- True => just had a newline + -> CSeq -- Current seq to flatten + -> [WorkItem] -- Work list with indentation + -> String + +flatten n nlp CNil seqs = flattenS nlp seqs + +flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs) +flatten n nlp (CIndent IBOX(n2) seq) seqs = flatten (n2 _ADD_ n) nlp seq seqs + +flatten n _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs +flatten n _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line + +flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs +flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs +flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs +#endif + +flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs) +flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs) +flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs) +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs) +#endif +\end{code} + +\begin{code} +flattenS :: FAST_BOOL -> [WorkItem] -> String +flattenS nlp [] = "" +flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs +\end{code} + +\begin{code} +mkIndent :: FAST_INT -> String -> String +mkIndent ILIT(0) s = s +mkIndent n s + = if (n _GE_ ILIT(8)) + then '\t' : mkIndent (n _SUB_ ILIT(8)) s + else ' ' : mkIndent (n _SUB_ ILIT(1)) s + -- Hmm.. a little Unix-y. +\end{code} + +Now the I/O version. +This code is massively {\em hammered}. +It {\em ignores} indentation. + +\begin{code} +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + +flattenIO :: _FILE -- file we are writing to + -> CSeq -- Seq to print + -> PrimIO () + +flattenIO file sq +# if __GLASGOW_HASKELL__ >= 23 + | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-) + | otherwise +# endif + = flat sq + where + flat CNil = BSCC("flatCNil") returnPrimIO () ESCC + + flat (CIndent n2 seq) = BSCC("flatCIndent") flat seq ESCC + + flat (CAppend seq1 seq2) + = BSCC("flatCAppend") + flat seq1 `seqPrimIO` flat seq2 + ESCC + + flat CNewline = BSCC("flatCNL") _ccall_ stg_putc '\n' file ESCC + + flat (CCh c) = BSCC("flatCCh") _ccall_ stg_putc c file ESCC + + flat (CInt i) = BSCC("flatCInt") _ccall_ fprintf file percent_d i ESCC + + flat (CStr s) = BSCC("flatCStr") put_str s ESCC + +# if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 + flat (CPStr s) = BSCC("flatCPStr") put_pstr s ESCC +# endif + + ----- + put_str, put_str2 :: String -> PrimIO () + + put_str str + = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO` + put_str2 str + + put_str2 [] = BSCC("putNil") returnPrimIO () ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs) + = BSCC("put4") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + _ccall_ stg_putc c3 file `seqPrimIO` + _ccall_ stg_putc c4 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs) + = BSCC("put3") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + _ccall_ stg_putc c3 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : cs) + = BSCC("put2") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : cs) + = BSCC("put1") + _ccall_ stg_putc c1 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + +# if __GLASGOW_HASKELL__ >= 23 + put_pstr ps = _putPS file ps +# endif + +# if __GLASGOW_HASKELL__ >= 23 +percent_d = _psToByteArray SLIT("%d") +# else +percent_d = "%d" +# endif + +#endif {- __GLASGOW_HASKELL__ >= 22 -} +\end{code} diff --git a/ghc/compiler/utils/Digraph.hi b/ghc/compiler/utils/Digraph.hi new file mode 100644 index 0000000000..98e65fecc1 --- /dev/null +++ b/ghc/compiler/utils/Digraph.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Digraph where +import Maybes(MaybeErr) +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +dfs :: (a -> a -> Bool) -> (a -> [a]) -> ([a], [a]) -> [a] -> ([a], [a]) + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(LL)S" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +stronglyConnComp :: (a -> a -> Bool) -> [(a, a)] -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +topologicalSort :: (a -> a -> Bool) -> [(a, a)] -> [a] -> MaybeErr [a] [[a]] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs new file mode 100644 index 0000000000..84cf220919 --- /dev/null +++ b/ghc/compiler/utils/Digraph.lhs @@ -0,0 +1,159 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Digraph]{An implementation of directed graphs} + +\begin{code} +module Digraph ( + stronglyConnComp, +--OLD: whichCycle, -- MOVED: isCyclic, + topologicalSort, + dfs, -- deforester + MaybeErr + ) where + +import Maybes ( MaybeErr(..) ) +import Util +\end{code} + +This module implements at least part of an abstract data type for +directed graphs. The part implemented is what we need for doing +dependency analyses. + +>type Edge vertex = (vertex, vertex) +>type Cycle vertex = [vertex] + +%************************************************************************ +%* * +%* Strongly connected components * +%* * +%************************************************************************ + +John Launchbury provided the basic code for doing strongly-connected +components. + +The result is a list of cycles (each of which is a list of vertices), +and these cycles are topologically sorted, so that if there is an edge from +cycle A to cycle B, then A occurs after B in the result list. + +\begin{code} +stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[vertex]] + +stronglyConnComp eq edges vertices + = snd (span_tree (new_range reversed_edges) + ([],[]) + ( snd (dfs (new_range edges) ([],[]) vertices) ) + ) + where + reversed_edges = map swap edges + + swap (x,y) = (y, x) + + -- new_range :: Eq v => [Edge v] -> v -> [v] + + new_range [] w = [] + new_range ((x,y):xys) w + = if x `eq` w + then (y : (new_range xys w)) + else (new_range xys w) + + elem x [] = False + elem x (y:ys) = x `eq` y || x `elem` ys + +{- span_tree :: Eq v => (v -> [v]) + -> ([v], [[v]]) + -> [v] + -> ([v], [[v]]) +-} + span_tree r (vs,ns) [] = (vs,ns) + span_tree r (vs,ns) (x:xs) + | x `elem` vs = span_tree r (vs,ns) xs + | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') -> + span_tree r (vs',(x:ns'):ns) xs } + +{- dfs :: Eq v => (v -> [v]) + -> ([v], [v]) + -> [v] + -> ([v], [v]) +-} + dfs r (vs,ns) [] = (vs,ns) + dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs + | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') -> + dfs r (vs',(x:ns')++ns) xs } +\end{code} + +\begin{code} +dfs :: (v -> v -> Bool) + -> (v -> [v]) + -> ([v], [v]) + -> [v] + -> ([v], [v]) + +dfs eq r (vs,ns) [] = (vs,ns) +dfs eq r (vs,ns) (x:xs) + | any (eq x) vs = dfs eq r (vs,ns) xs + | True = case (dfs eq r (x:vs,[]) (r x)) of + (vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs + +\end{code} + + +@isCyclic@ expects to be applied to an element of the result of a +stronglyConnComp; it tells whether such an element is a cycle. The +answer is True if it is not a singleton, of course, but if it is a +singleton we have to look up in the edges to see if it refers to +itself. + +\begin{code} +{- MOVED TO POINT OF SINGLE USE: RenameBinds4 (WDP 95/02) + +isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool + +isCyclic edges [] = panic "isCyclic: empty component" +isCyclic edges [v] = (v,v) `is_elem` edges where { is_elem = isIn "isCyclic" } +isCyclic edges vs = True +-} +\end{code} + +OLD: The following @whichCycle@ should be called only when the given +@vertex@ is known to be in one of the cycles. This isn't difficult to +achieve if the call follows the creation of the list of components by +@cycles@ (NB: strictness analyser) with all vertices of interest in +them. + +>{- UNUSED: +>whichCycle :: Eq vertex => [Cycle vertex] -> vertex -> (Cycle vertex) +>whichCycle vss v = head [vs | vs <-vss, v `is_elem` vs] where { is_elem = isIn "whichCycle" } +>-} + +%************************************************************************ +%* * +%* Topological sort * +%* * +%************************************************************************ + +Topological sort fails if it finds any cycles, returning the offending cycles. + +If it succeeds, the result is a list of vertices, such that if there is +an edge from vertex A to vertex B then A occurs after B in the result list. + +\begin{code} +topologicalSort :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] + -> MaybeErr [vertex] -- Success: the sorted list + [[vertex]] -- Failure: the cycles + +topologicalSort eq edges vertices + = case (stronglyConnComp eq edges vertices) of { sccs -> + case (partition (is_cyclic edges) sccs) of { (cycles, singletons) -> + if null cycles + then Succeeded [ v | [v] <- singletons ] + else Failed cycles + }} + where + is_cyclic es [] = panic "is_cyclic: empty component" + is_cyclic es [v] = (v,v) `elem` es + is_cyclic es vs = True + + elem (x,y) [] = False + elem z@(x,y) ((a,b):cs) = (x `eq` a && y `eq` b) || z `elem` cs +\end{code} diff --git a/ghc/compiler/utils/FiniteMap.hi b/ghc/compiler/utils/FiniteMap.hi new file mode 100644 index 0000000000..4d31462387 --- /dev/null +++ b/ghc/compiler/utils/FiniteMap.hi @@ -0,0 +1,58 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FiniteMap where +import Maybes(Labda) +import Outputable(Outputable) +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +type FiniteSet a = FiniteMap a () +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +addListToFM :: Ord a => FiniteMap a b -> [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-} +addListToFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLLS" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ } #-} +addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 1122 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ } #-} +delListFromFM :: Ord a => FiniteMap a b -> [a] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-} +elemFM :: Ord a => a -> FiniteMap a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _SPECIALISE_ [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +elementOf :: Ord a => a -> FiniteMap a () -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap elemFM { u0 } { () } _N_ #-} +eltsFM :: FiniteMap a b -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +emptyFM :: FiniteMap a b + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-} +emptySet :: FiniteMap a () + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-} +fmToList :: FiniteMap a b -> [(a, b)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEmptyFM :: FiniteMap a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEmptySet :: FiniteMap a () -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap isEmptyFM { u0 } { () } _N_ #-} +keysFM :: FiniteMap b a -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToFM :: Ord a => [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +lookupFM :: Ord a => FiniteMap a b -> a -> Labda b + {-# GHC_PRAGMA _A_ 1 _U_ 112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +lookupWithDefaultFM :: Ord a => FiniteMap a b -> b -> a -> b + {-# GHC_PRAGMA _A_ 1 _U_ 1112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ } #-} +minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ } #-} +minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-} +mkSet :: Ord a => [a] -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _N_ #-} +plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ } #-} +plusFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 2221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ } #-} +setToList :: FiniteMap a () -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-} +singletonFM :: a -> b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-} +instance Outputable a => Outputable (FiniteMap a b) + {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs new file mode 100644 index 0000000000..03f087a1fe --- /dev/null +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -0,0 +1,851 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[FiniteMap]{An implementation of finite maps} + +``Finite maps'' are the heart of the compiler's +lookup-tables/environments and its implementation of sets. Important +stuff! + +This code is derived from that in the paper: +\begin{display} + S Adams + "Efficient sets: a balancing act" + Journal of functional programming 3(4) Oct 1993, pp553-562 +\end{display} + +The code is SPECIALIZEd to various highly-desirable types (e.g., Id) +near the end (only \tr{#ifdef COMPILING_GHC}). + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} +#else +#define ASSERT(e) {--} +#define IF_NOT_GHC(a) a +#define COMMA , +#endif + +#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */ +#define OUTPUTABLE_key , Outputable key +#else +#define OUTPUTABLE_key {--} +#endif + +module FiniteMap ( + FiniteMap, -- abstract type + + emptyFM, singletonFM, listToFM, + + addToFM, addListToFM, + IF_NOT_GHC(addToFM_C COMMA) + addListToFM_C, + IF_NOT_GHC(delFromFM COMMA) + delListFromFM, + + plusFM, plusFM_C, + IF_NOT_GHC(intersectFM COMMA intersectFM_C COMMA) + minusFM, -- exported for GHCI only + + IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA) + + IF_NOT_GHC(sizeFM COMMA) + isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, + + fmToList, keysFM, eltsFM{-used in GHCI-} + +#if defined(COMPILING_GHC) + , FiniteSet(..), emptySet, mkSet, isEmptySet + , elementOf, setToList, union, minusSet{-exported for GHCI-} +#endif + + -- To make it self-sufficient +#if __HASKELL1__ < 3 + , Maybe +#endif + ) where + +import Maybes + +#if defined(COMPILING_GHC) +import AbsUniType +import Pretty +import Outputable +import Util +import CLabelInfo ( CLabel ) -- for specialising +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) -- ditto +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +#endif + +-- SIGH: but we use unboxed "sizes"... +#if __GLASGOW_HASKELL__ +#define IF_GHC(a,b) a +#else /* not GHC */ +#define IF_GHC(a,b) b +#endif /* not GHC */ +\end{code} + + +%************************************************************************ +%* * +\subsection{The signature of the module} +%* * +%************************************************************************ + +\begin{code} +-- BUILDING +emptyFM :: FiniteMap key elt +singletonFM :: key -> elt -> FiniteMap key elt +listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt + -- In the case of duplicates, the last is taken + +-- ADDING AND DELETING + -- Throws away any previous binding + -- In the list case, the items are added starting with the + -- first one in the list +addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt +addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt + + -- Combines with previous binding +addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> key -> elt + -> FiniteMap key elt +addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> [(key,elt)] + -> FiniteMap key elt + + -- Deletion doesn't complain if you try to delete something + -- which isn't there +delFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt +delListFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt + +-- COMBINING + -- Bindings in right argument shadow those in the left +plusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + + -- Combines bindings for the same thing with the given function +plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + +minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 + +intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + +-- MAPPING, FOLDING, FILTERING +foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a +mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 +filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool) + -> FiniteMap key elt -> FiniteMap key elt + +-- INTERROGATING +sizeFM :: FiniteMap key elt -> Int +isEmptyFM :: FiniteMap key elt -> Bool + +elemFM :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool +lookupFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt +lookupWithDefaultFM + :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt + -- lookupWithDefaultFM supplies a "default" elt + -- to return for an unmapped key + +-- LISTIFYING +fmToList :: FiniteMap key elt -> [(key,elt)] +keysFM :: FiniteMap key elt -> [key] +eltsFM :: FiniteMap key elt -> [elt] +\end{code} + +%************************************************************************ +%* * +\subsection{The @FiniteMap@ data type, and building of same} +%* * +%************************************************************************ + +Invariants about @FiniteMap@: +\begin{enumerate} +\item +all keys in a FiniteMap are distinct +\item +all keys in left subtree are $<$ key in Branch and +all keys in right subtree are $>$ key in Branch +\item +size field of a Branch gives number of Branch nodes in the tree +\item +size of left subtree is differs from size of right subtree by a +factor of at most \tr{sIZE_RATIO} +\end{enumerate} + +\begin{code} +data FiniteMap key elt + = EmptyFM + | Branch key elt -- Key and elt stored here + IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1 + (FiniteMap key elt) -- Children + (FiniteMap key elt) +\end{code} + +\begin{code} +emptyFM = EmptyFM +{- +emptyFM + = Branch bottom bottom IF_GHC(0#,0) bottom bottom + where + bottom = panic "emptyFM" +-} + +-- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _) + +singletonFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM + +listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs +\end{code} + +%************************************************************************ +%* * +\subsection{Adding to and deleting from @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt + +addToFM_C combiner EmptyFM key elt = singletonFM key elt +addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp new_key key of + _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r +#else + | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r +#endif + +addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs + +addListToFM_C combiner fm key_elt_pairs + = foldl add fm key_elt_pairs -- foldl adds from the left + where + add fmap (key,elt) = addToFM_C combiner fmap key elt +\end{code} + +\begin{code} +delFromFM EmptyFM del_key = emptyFM +delFromFM (Branch key elt size fm_l fm_r) del_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp del_key key of + _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) + _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r + _EQ -> glueBal fm_l fm_r +#else + | del_key > key + = mkBalBranch key elt fm_l (delFromFM fm_r del_key) + + | del_key < key + = mkBalBranch key elt (delFromFM fm_l del_key) fm_r + + | key == del_key + = glueBal fm_l fm_r +#endif + +delListFromFM fm keys = foldl delFromFM fm keys +\end{code} + +%************************************************************************ +%* * +\subsection{Combining @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +plusFM_C combiner EmptyFM fm2 = fm2 +plusFM_C combiner fm1 EmptyFM = fm1 +plusFM_C combiner fm1 (Branch split_key elt2 _ left right) + = mkVBalBranch split_key new_elt + (plusFM_C combiner lts left) + (plusFM_C combiner gts right) + where + lts = splitLT fm1 split_key + gts = splitGT fm1 split_key + new_elt = case lookupFM fm1 split_key of + Nothing -> elt2 + Just elt1 -> combiner elt1 elt2 + +-- It's worth doing plusFM specially, because we don't need +-- to do the lookup in fm1. + +plusFM EmptyFM fm2 = fm2 +plusFM fm1 EmptyFM = fm1 +plusFM fm1 (Branch split_key elt1 _ left right) + = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right) + where + lts = splitLT fm1 split_key + gts = splitGT fm1 split_key + +minusFM EmptyFM fm2 = emptyFM +minusFM fm1 EmptyFM = fm1 +minusFM fm1 (Branch split_key elt _ left right) + = glueVBal (minusFM lts left) (minusFM gts right) + -- The two can be way different, so we need glueVBal + where + lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones + gts = splitGT fm1 split_key -- are not in either. + +intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2 + +intersectFM_C combiner fm1 EmptyFM = emptyFM +intersectFM_C combiner EmptyFM fm2 = emptyFM +intersectFM_C combiner fm1 (Branch split_key elt2 _ left right) + + | maybeToBool maybe_elt1 -- split_elt *is* in intersection + = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left) + (intersectFM_C combiner gts right) + + | otherwise -- split_elt is *not* in intersection + = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right) + + where + lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones + gts = splitGT fm1 split_key -- are not in either. + + maybe_elt1 = lookupFM fm1 split_key + Just elt1 = maybe_elt1 +\end{code} + +%************************************************************************ +%* * +\subsection{Mapping, folding, and filtering with @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +foldFM k z EmptyFM = z +foldFM k z (Branch key elt _ fm_l fm_r) + = foldFM k (k key elt (foldFM k z fm_r)) fm_l + +mapFM f EmptyFM = emptyFM +mapFM f (Branch key elt size fm_l fm_r) + = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r) + +filterFM p EmptyFM = emptyFM +filterFM p (Branch key elt _ fm_l fm_r) + | p key elt -- Keep the item + = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r) + + | otherwise -- Drop the item + = glueVBal (filterFM p fm_l) (filterFM p fm_r) +\end{code} + +%************************************************************************ +%* * +\subsection{Interrogating @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +--{-# INLINE sizeFM #-} +sizeFM EmptyFM = 0 +sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size) + +isEmptyFM fm = sizeFM fm == 0 + +lookupFM EmptyFM key = Nothing +lookupFM (Branch key elt _ fm_l fm_r) key_to_find +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp key_to_find key of + _LT -> lookupFM fm_l key_to_find + _GT -> lookupFM fm_r key_to_find + _EQ -> Just elt +#else + | key_to_find < key = lookupFM fm_l key_to_find + | key_to_find > key = lookupFM fm_r key_to_find + | otherwise = Just elt +#endif + +key `elemFM` fm + = case (lookupFM fm key) of { Nothing -> False; Just elt -> True } + +lookupWithDefaultFM fm deflt key + = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt } +\end{code} + +%************************************************************************ +%* * +\subsection{Listifying @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm +keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm +eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm +\end{code} + + +%************************************************************************ +%* * +\subsection{The implementation of balancing} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection{Basic construction of a @FiniteMap@} +%* * +%************************************************************************ + +@mkBranch@ simply gets the size component right. This is the ONLY +(non-trivial) place the Branch object is built, so the ASSERTion +recursively checks consistency. (The trivial use of Branch is in +@singletonFM@.) + +\begin{code} +sIZE_RATIO :: Int +sIZE_RATIO = 5 + +mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only + => Int + -> key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +mkBranch which key elt fm_l fm_r + = --ASSERT( left_ok && right_ok && balance_ok ) +#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS) + if not ( left_ok && right_ok && balance_ok ) then + pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok], + ppr PprDebug key, + ppr PprDebug fm_l, + ppr PprDebug fm_r]) + else +#endif + let + result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r + in +-- if sizeFM result <= 8 then + result +-- else +-- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) ( +-- result +-- ) + where + left_ok = case fm_l of + EmptyFM -> True + Branch left_key _ _ _ _ -> let + biggest_left_key = fst (findMax fm_l) + in + biggest_left_key < key + right_ok = case fm_r of + EmptyFM -> True + Branch right_key _ _ _ _ -> let + smallest_right_key = fst (findMin fm_r) + in + key < smallest_right_key + balance_ok = True -- sigh +{- LATER: + balance_ok + = -- Both subtrees have one or no elements... + (left_size + right_size <= 1) +-- NO || left_size == 0 -- ??? +-- NO || right_size == 0 -- ??? + -- ... or the number of elements in a subtree does not exceed + -- sIZE_RATIO times the number of elements in the other subtree + || (left_size * sIZE_RATIO >= right_size && + right_size * sIZE_RATIO >= left_size) +-} + + left_size = sizeFM fm_l + right_size = sizeFM fm_r + +#ifdef __GLASGOW_HASKELL__ + unbox :: Int -> Int# + unbox (I# size) = size +#else + unbox :: Int -> Int + unbox x = x +#endif +\end{code} + +%************************************************************************ +%* * +\subsubsection{{\em Balanced} construction of a @FiniteMap@} +%* * +%************************************************************************ + +@mkBalBranch@ rebalances, assuming that the subtrees aren't too far +out of whack. + +\begin{code} +mkBalBranch :: (Ord key OUTPUTABLE_key) + => key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +mkBalBranch key elt fm_L fm_R + + | size_l + size_r < 2 + = mkBranch 1{-which-} key elt fm_L fm_R + + | size_r > sIZE_RATIO * size_l -- Right tree too big + = case fm_R of + Branch _ _ _ fm_rl fm_rr + | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R + | otherwise -> double_L fm_L fm_R + -- Other case impossible + + | size_l > sIZE_RATIO * size_r -- Left tree too big + = case fm_L of + Branch _ _ _ fm_ll fm_lr + | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R + | otherwise -> double_R fm_L fm_R + -- Other case impossible + + | otherwise -- No imbalance + = mkBranch 2{-which-} key elt fm_L fm_R + + where + size_l = sizeFM fm_L + size_r = sizeFM fm_R + + single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr) + = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr + + double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr) + = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll) + (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr) + + single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r + = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r) + + double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r + = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl) + (mkBranch 12{-which-} key elt fm_lrr fm_r) +\end{code} + + +\begin{code} +mkVBalBranch :: (Ord key OUTPUTABLE_key) + => key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +-- Assert: in any call to (mkVBalBranch_C comb key elt l r), +-- (a) all keys in l are < all keys in r +-- (b) all keys in l are < key +-- (c) all keys in r are > key + +mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt +mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt + +mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr) + fm_r@(Branch key_r elt_r _ fm_rl fm_rr) + | sIZE_RATIO * size_l < size_r + = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr + + | sIZE_RATIO * size_r < size_l + = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r) + + | otherwise + = mkBranch 13{-which-} key elt fm_l fm_r + + where + size_l = sizeFM fm_l + size_r = sizeFM fm_r +\end{code} + +%************************************************************************ +%* * +\subsubsection{Gluing two trees together} +%* * +%************************************************************************ + +@glueBal@ assumes its two arguments aren't too far out of whack, just +like @mkBalBranch@. But: all keys in first arg are $<$ all keys in +second. + +\begin{code} +glueBal :: (Ord key OUTPUTABLE_key) + => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +glueBal EmptyFM fm2 = fm2 +glueBal fm1 EmptyFM = fm1 +glueBal fm1 fm2 + -- The case analysis here (absent in Adams' program) is really to deal + -- with the case where fm2 is a singleton. Then deleting the minimum means + -- we pass an empty tree to mkBalBranch, which breaks its invariant. + | sizeFM fm2 > sizeFM fm1 + = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2) + + | otherwise + = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2 + where + (mid_key1, mid_elt1) = findMax fm1 + (mid_key2, mid_elt2) = findMin fm2 +\end{code} + +@glueVBal@ copes with arguments which can be of any size. +But: all keys in first arg are $<$ all keys in second. + +\begin{code} +glueVBal :: (Ord key OUTPUTABLE_key) + => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +glueVBal EmptyFM fm2 = fm2 +glueVBal fm1 EmptyFM = fm1 +glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr) + fm_r@(Branch key_r elt_r _ fm_rl fm_rr) + | sIZE_RATIO * size_l < size_r + = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr + + | sIZE_RATIO * size_r < size_l + = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r) + + | otherwise -- We now need the same two cases as in glueBal above. + = glueBal fm_l fm_r + where + (mid_key_l,mid_elt_l) = findMax fm_l + (mid_key_r,mid_elt_r) = findMin fm_r + size_l = sizeFM fm_l + size_r = sizeFM fm_r +\end{code} + +%************************************************************************ +%* * +\subsection{Local utilities} +%* * +%************************************************************************ + +\begin{code} +splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt + +-- splitLT fm split_key = fm restricted to keys < split_key +-- splitGE fm split_key = fm restricted to keys >= split_key (UNUSED) +-- splitGT fm split_key = fm restricted to keys > split_key + +splitLT EmptyFM split_key = emptyFM +splitLT (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _LT -> splitLT fm_l split_key + _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) + _EQ -> fm_l +#else + | split_key < key = splitLT fm_l split_key + | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key) + | otherwise = fm_l +#endif + +{- UNUSED: +splitGE EmptyFM split_key = emptyFM +splitGE (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _GT -> splitGE fm_r split_key + _LT -> mkVBalBranch key elt (splitGE fm_l split_key) fm_r + _EQ -> mkVBalBranch key elt emptyFM fm_r +#else + | split_key > key = splitGE fm_r split_key + | split_key < key = mkVBalBranch key elt (splitGE fm_l split_key) fm_r + | otherwise = mkVBalBranch key elt emptyFM fm_r +#endif +-} + +splitGT EmptyFM split_key = emptyFM +splitGT (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _GT -> splitGT fm_r split_key + _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r + _EQ -> fm_r +#else + | split_key > key = splitGT fm_r split_key + | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r + | otherwise = fm_r +#endif + +findMin :: FiniteMap key elt -> (key,elt) +findMin (Branch key elt _ EmptyFM _) = (key,elt) +findMin (Branch key elt _ fm_l _) = findMin fm_l + +deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt +deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r +deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r + +findMax :: FiniteMap key elt -> (key,elt) +findMax (Branch key elt _ _ EmptyFM) = (key,elt) +findMax (Branch key elt _ _ fm_r) = findMax fm_r + +deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt +deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l +deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r) +\end{code} + +%************************************************************************ +%* * +\subsection{Output-ery} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) + +{- this is the real one actually... +instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where + ppr sty fm = ppr sty (fmToList fm) +-} + +-- temp debugging (ToDo: rm) +instance (Outputable key) => Outputable (FiniteMap key elt) where + ppr sty fm = pprX sty fm + +pprX sty EmptyFM = ppChar '!' +pprX sty (Branch key elt sz fm_l fm_r) + = ppBesides [ppLparen, pprX sty fm_l, ppSP, + ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP, + pprX sty fm_r, ppRparen] +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{FiniteSets---a thin veneer} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) + +type FiniteSet key = FiniteMap key () +emptySet :: FiniteSet key +mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key +isEmptySet :: FiniteSet key -> Bool +elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool +minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key +setToList :: FiniteSet key -> [key] +union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key + +emptySet = emptyFM +mkSet xs = listToFM [ (x, ()) | x <- xs] +isEmptySet = isEmptyFM +elementOf = elemFM +minusSet = minusFM +setToList = keysFM +union = plusFM + +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Efficiency pragmas for GHC} +%* * +%************************************************************************ + +When the FiniteMap module is used in GHC, we specialise it for +\tr{Uniques}, for dastardly efficiency reasons. + +\begin{code} +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ + -- the __GLASGOW_HASKELL__ chk avoids an hbc 0.999.7 bug + +{-# SPECIALIZE listToFM + :: [(Int,elt)] -> FiniteMap Int elt, + [(CLabel,elt)] -> FiniteMap CLabel elt, + [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt, + [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addToFM + :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, + FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt, + FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addListToFM + :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, + FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!! # SPECIALIZE addToFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addListToFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!!! # SPECIALIZE delFromFM + :: FiniteMap Int elt -> Int -> FiniteMap Int elt, + FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE delListFromFM + :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt, + FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE elemFM + :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool + #-} +{-not EXPORTED!!! # SPECIALIZE filterFM + :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt, + (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!!! # SPECIALIZE intersectFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-not EXPORTED !!!# SPECIALIZE intersectFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE lookupFM + :: FiniteMap Int elt -> Int -> Maybe elt, + FiniteMap CLabel elt -> CLabel -> Maybe elt, + FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt, + FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) + #-} +{-# SPECIALIZE lookupWithDefaultFM + :: FiniteMap Int elt -> elt -> Int -> elt, + FiniteMap CLabel elt -> elt -> CLabel -> elt + IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) + #-} +{-# SPECIALIZE minusFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, + FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE plusFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE plusFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} + +#endif {- compiling for GHC -} +\end{code} diff --git a/ghc/compiler/utils/LiftMonad.hi b/ghc/compiler/utils/LiftMonad.hi new file mode 100644 index 0000000000..fd54066ee1 --- /dev/null +++ b/ghc/compiler/utils/LiftMonad.hi @@ -0,0 +1,5 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LiftMonad where +bogusLiftMonadThing :: Bool + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_ #-} + diff --git a/ghc/compiler/utils/LiftMonad.lhs b/ghc/compiler/utils/LiftMonad.lhs new file mode 100644 index 0000000000..40a84e5802 --- /dev/null +++ b/ghc/compiler/utils/LiftMonad.lhs @@ -0,0 +1,39 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[LiftMonad]{A lifting monad} + +\begin{code} +#if defined(__GLASGOW_HASKELL__) +module LiftMonad where { bogusLiftMonadThing = True } + +#else +module LiftMonad ( + LiftM, -- abstract + thenLft, returnLft, mapLft + ) where + +infixr 9 `thenLft` + +data LiftM a = MkLiftM a + -- Just add a bottom element under the domain +\end{code} + +Notice that @thenLft@ is strict in its first argument. + +\begin{code} +thenLft :: LiftM a -> (a -> b) -> b +(MkLiftM x) `thenLft` cont = cont x + +returnLft :: a -> LiftM a +returnLft a = MkLiftM a + +mapLft :: (a -> LiftM b) -> [a] -> LiftM [b] +mapLft f [] = returnLft [] +mapLft f (x:xs) + = f x `thenLft` \ x2 -> + mapLft f xs `thenLft` \ xs2 -> + returnLft (x2 : xs2) + +#endif +\end{code} diff --git a/ghc/compiler/utils/ListSetOps.hi b/ghc/compiler/utils/ListSetOps.hi new file mode 100644 index 0000000000..d7e73e2951 --- /dev/null +++ b/ghc/compiler/utils/ListSetOps.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ListSetOps where +intersectLists :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-} +minusList :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +unionLists :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-} + diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs new file mode 100644 index 0000000000..dbc749c2e2 --- /dev/null +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -0,0 +1,95 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[ListSetOps]{Set-like operations on lists} + +\begin{code} +module ListSetOps ( + unionLists, + intersectLists, + minusList +#if ! defined(COMPILING_GHC) + , disjointLists, intersectingLists +#endif + ) where + +#if defined(COMPILING_GHC) +import Util +# ifdef USE_ATTACK_PRAGMAS +import AbsUniType +import Id ( Id ) +# endif +#endif +\end{code} + +\begin{code} +unionLists :: (Eq a) => [a] -> [a] -> [a] +unionLists [] [] = [] +unionLists [] b = b +unionLists a [] = a +unionLists (a:as) b + | a `is_elem` b = unionLists as b + | otherwise = a : unionLists as b + where +#if defined(COMPILING_GHC) + is_elem = isIn "unionLists" +#else + is_elem = elem +#endif + +intersectLists :: (Eq a) => [a] -> [a] -> [a] +intersectLists [] [] = [] +intersectLists [] b = [] +intersectLists a [] = [] +intersectLists (a:as) b + | a `is_elem` b = a : intersectLists as b + | otherwise = intersectLists as b + where +#if defined(COMPILING_GHC) + is_elem = isIn "intersectLists" +#else + is_elem = elem +#endif +\end{code} + +Everything in the first list that is not in the second list: +\begin{code} +minusList :: (Eq a) => [a] -> [a] -> [a] +minusList xs ys = [ x | x <- xs, x `not_elem` ys] + where +#if defined(COMPILING_GHC) + not_elem = isn'tIn "minusList" +#else + not_elem = notElem +#endif +\end{code} + +\begin{code} +#if ! defined(COMPILING_GHC) + +disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool + +disjointLists [] bs = True +disjointLists (a:as) bs + | a `elem` bs = False + | otherwise = disjointLists as bs + +intersectingLists xs ys = not (disjointLists xs ys) +#endif +\end{code} + +\begin{code} +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS + +{-# SPECIALIZE unionLists :: [TyVar] -> [TyVar] -> [TyVar] #-} +{-# SPECIALIZE intersectLists :: [TyVar] -> [TyVar] -> [TyVar] #-} + +{-# SPECIALIZE minusList :: [TyVar] -> [TyVar] -> [TyVar], + [Id] -> [Id] -> [Id], + [Int] -> [Int] -> [Int] + #-} + +# endif +#endif +\end{code} diff --git a/ghc/compiler/utils/Maybes.hi b/ghc/compiler/utils/Maybes.hi new file mode 100644 index 0000000000..d4c5c14d11 --- /dev/null +++ b/ghc/compiler/utils/Maybes.hi @@ -0,0 +1,31 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Maybes where +data Labda a = Hamna | Ni a +data MaybeErr a b = Succeeded a | Failed b +allMaybes :: [Labda a] -> Labda [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +assocMaybe :: Eq a => [(a, b)] -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ [Char], _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +catMaybes :: [Labda a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +failMaB :: b -> MaybeErr a b + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u1) -> _!_ _ORIG_ Maybes Failed [u0, u1] [u2] _N_ #-} +failMaybe :: Labda a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Maybes Hamna [u0] [] _N_ #-} +firstJust :: [Labda a] -> Labda a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mapMaybe :: (a -> Labda b) -> [a] -> Labda [b] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +maybeToBool :: Labda a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 4 _/\_ u0 -> \ (u1 :: Labda u0) -> case u1 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ False [] []; _ORIG_ Maybes Ni (u2 :: u0) -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +mkLookupFun :: (a -> a -> Bool) -> [(a, b)] -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-} +returnMaB :: a -> MaybeErr a b + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u0) -> _!_ _ORIG_ Maybes Succeeded [u0, u1] [u2] _N_ #-} +returnMaybe :: a -> Labda a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Maybes Ni [u0] [u1] _N_ #-} +thenMaB :: MaybeErr a c -> (a -> MaybeErr b c) -> MaybeErr b c + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 3 2 CX 6 _/\_ u0 u1 u2 -> \ (u3 :: MaybeErr u0 u2) (u4 :: u0 -> MaybeErr u1 u2) -> case u3 of { _ALG_ _ORIG_ Maybes Succeeded (u5 :: u0) -> _APP_ u4 [ u5 ]; _ORIG_ Maybes Failed (u6 :: u2) -> _!_ _ORIG_ Maybes Failed [u1, u2] [u6]; _NO_DEFLT_ } _N_ #-} +thenMaybe :: Labda a -> (a -> Labda b) -> Labda b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 2 2 CX 5 _/\_ u0 u1 -> \ (u2 :: Labda u0) (u3 :: u0 -> Labda u1) -> case u2 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ _ORIG_ Maybes Hamna [u1] []; _ORIG_ Maybes Ni (u4 :: u0) -> _APP_ u3 [ u4 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs new file mode 100644 index 0000000000..66c12797bc --- /dev/null +++ b/ghc/compiler/utils/Maybes.lhs @@ -0,0 +1,222 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Maybes]{The `Maybe' types and associated utility functions} + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#endif + +module Maybes ( + Maybe(..), MaybeErr(..), + + allMaybes, -- GHCI only + assocMaybe, + catMaybes, + failMaB, + failMaybe, + firstJust, + mapMaybe, -- GHCI only + maybeToBool, + mkLookupFun, + returnMaB, + returnMaybe, -- GHCI only + thenMaB, + thenMaybe -- GHCI only + +#if ! defined(COMPILING_GHC) + , findJust + , foldlMaybeErrs + , listMaybeErrs +#endif + ) where + +#if defined(COMPILING_GHC) +import AbsUniType +import Id +import IdInfo +import Name +import Outputable +#if USE_ATTACK_PRAGMAS +import Util +#endif +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection[Maybe type]{The @Maybe@ type} +%* * +%************************************************************************ + +\begin{code} +#if __HASKELL1__ < 3 +data Maybe a + = Nothing + | Just a +#endif +\end{code} + +\begin{code} +maybeToBool :: Maybe a -> Bool +maybeToBool Nothing = False +maybeToBool (Just x) = True +\end{code} + +@catMaybes@ takes a list of @Maybe@s and returns a list of +the contents of all the @Just@s in it. @allMaybes@ collects +a list of @Justs@ into a single @Just@, returning @Nothing@ if there +are any @Nothings@. + +\begin{code} +catMaybes :: [Maybe a] -> [a] +catMaybes [] = [] +catMaybes (Nothing : xs) = catMaybes xs +catMaybes (Just x : xs) = (x : catMaybes xs) + +allMaybes :: [Maybe a] -> Maybe [a] +allMaybes [] = Just [] +allMaybes (Nothing : ms) = Nothing +allMaybes (Just x : ms) = case (allMaybes ms) of + Nothing -> Nothing + Just xs -> Just (x:xs) +\end{code} + +@firstJust@ takes a list of @Maybes@ and returns the +first @Just@ if there is one, or @Nothing@ otherwise. + +\begin{code} +firstJust :: [Maybe a] -> Maybe a +firstJust [] = Nothing +firstJust (Just x : ms) = Just x +firstJust (Nothing : ms) = firstJust ms +\end{code} + +\begin{code} +findJust :: (a -> Maybe b) -> [a] -> Maybe b +findJust f [] = Nothing +findJust f (a:as) = case f a of + Nothing -> findJust f as + b -> b +\end{code} + +@assocMaybe@ looks up in an assocation list, returning +@Nothing@ if it fails. + +\begin{code} +assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +#if defined(COMPILING_GHC) +{-# SPECIALIZE assocMaybe + :: [(String, b)] -> String -> Maybe b, + [(Id, b)] -> Id -> Maybe b, + [(Class, b)] -> Class -> Maybe b, + [(Int, b)] -> Int -> Maybe b, + [(Name, b)] -> Name -> Maybe b, + [(TyVar, b)] -> TyVar -> Maybe b, + [(TyVarTemplate, b)] -> TyVarTemplate -> Maybe b + #-} +#endif +\end{code} + +@mkLookupFun alist s@ is a function which looks up +@s@ in the association list @alist@, returning a Maybe type. + +\begin{code} +mkLookupFun :: (key -> key -> Bool) -- Equality predicate + -> [(key,val)] -- The assoc list + -> key -- The key + -> Maybe val -- The corresponding value + +mkLookupFun eq alist s + = case [a | (s',a) <- alist, s' `eq` s] of + [] -> Nothing + (a:_) -> Just a +\end{code} + +\begin{code} +#if __HASKELL1__ < 3 +thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b +m `thenMaybe` k = case m of + Nothing -> Nothing + Just a -> k a +#endif +returnMaybe :: a -> Maybe a +returnMaybe = Just + +failMaybe :: Maybe a +failMaybe = Nothing + +mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] +mapMaybe f [] = returnMaybe [] +mapMaybe f (x:xs) = f x `thenMaybe` (\ x' -> + mapMaybe f xs `thenMaybe` (\ xs' -> + returnMaybe (x':xs') )) +\end{code} + +%************************************************************************ +%* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +%* * +%************************************************************************ + +\begin{code} +data MaybeErr val err = Succeeded val | Failed err +\end{code} + +\begin{code} +thenMaB :: MaybeErr val1 err -> (val1 -> MaybeErr val2 err) -> MaybeErr val2 err +thenMaB m k + = case m of + Succeeded v -> k v + Failed e -> Failed e + +returnMaB :: val -> MaybeErr val err +returnMaB v = Succeeded v + +failMaB :: err -> MaybeErr val err +failMaB e = Failed e +\end{code} + + +@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, returns +a @Succeeded@ of a list of their values. If any fail, it returns a +@Failed@ of the list of all the errors in the list. + +\begin{code} +listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err] +listMaybeErrs + = foldr combine (Succeeded []) + where + combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs) + combine (Failed err) (Succeeded _) = Failed [err] + combine (Succeeded v) (Failed errs) = Failed errs + combine (Failed err) (Failed errs) = Failed (err:errs) +\end{code} + +@foldlMaybeErrs@ works along a list, carrying an accumulator; it +applies the given function to the accumulator and the next list item, +accumulating any errors that occur. + +\begin{code} +foldlMaybeErrs :: (acc -> input -> MaybeErr acc err) + -> acc + -> [input] + -> MaybeErr acc [err] + +foldlMaybeErrs k accum ins = do_it [] accum ins + where + do_it [] acc [] = Succeeded acc + do_it errs acc [] = Failed errs + do_it errs acc (v:vs) = case (k acc v) of + Succeeded acc' -> do_it errs acc' vs + Failed err -> do_it (err:errs) acc vs +\end{code} diff --git a/ghc/compiler/utils/Outputable.hi b/ghc/compiler/utils/Outputable.hi new file mode 100644 index 0000000000..8b676529b2 --- /dev/null +++ b/ghc/compiler/utils/Outputable.hi @@ -0,0 +1,100 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Outputable where +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle(..), Pretty(..), PrettyRep) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> ExportFlag) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> _PackedString) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [_PackedString]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> SrcLoc) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Unique) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> UniType) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data ExportFlag = ExportAll | ExportAbs | NotExported +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +getLocalName :: NamedThing a => a -> _PackedString + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) (u2 :: u0) -> case _APP_ u1 [ u2 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> case u1 of { _ALG_ _TUP_10 (u3 :: u0 -> ExportFlag) (u4 :: u0 -> Bool) (u5 :: u0 -> (_PackedString, _PackedString)) (u6 :: u0 -> _PackedString) (u7 :: u0 -> [_PackedString]) (u8 :: u0 -> SrcLoc) (u9 :: u0 -> Unique) (ua :: u0 -> Bool) (ub :: u0 -> UniType) (uc :: u0 -> Bool) -> case _APP_ u5 [ u2 ] of { _ALG_ _TUP_2 (ud :: _PackedString) (ue :: _PackedString) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _SPECIALISE_ [ ShortName ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: _PackedString) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u0 ] of { _ALG_ _TUP_2 (u1 :: _PackedString) (u2 :: _PackedString) -> u2; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u1 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +ifPprDebug :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprDebug -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-} +ifPprInterface :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprInterface (u2 :: GlobalSwitch -> Bool) -> u1; (u3 :: PprStyle) -> \ (u4 :: Int) (u5 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u4 ] } _N_ #-} +ifPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-} +ifnotPprForUser :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprForUser -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-} +ifnotPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-} +interpp'SP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ UniType ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ }, [ ProtoName ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-} +interppSP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-} +isAconop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isAvarid :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isAvarop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isConop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isExported :: NamedThing a => a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ }, [ Class ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ExportFlag) -> case u0 of { _ALG_ _ORIG_ Outputable NotExported -> _!_ False [] []; (u1 :: ExportFlag) -> _!_ True [] [] } _N_} _N_ _N_ } #-} +isOpLexeme :: NamedThing a => a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ } #-} +ltLexical :: (NamedThing a, NamedThing b) => a -> b -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "U(ASSAAAAAAA)U(ALSAAAAAAA)LL" {_A_ 5 _U_ 11122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id, Id ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(LAAS)U(LAAS)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon, TyCon ] 2 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Class, Class ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(AU(LLSAAA)AAAAAAAA)U(AU(LLLAAA)AAAAAAAA)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +pprNonOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 2 { _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ } #-} +pprOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs new file mode 100644 index 0000000000..2e9a382fad --- /dev/null +++ b/ghc/compiler/utils/Outputable.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[Outputable]{Classes for pretty-printing} + +Defines classes for pretty-printing and forcing, both forms of +``output.'' + +\begin{code} +#include "HsVersions.h" + +module Outputable ( + -- NAMED-THING-ERY + NamedThing(..), -- class + ExportFlag(..), + isExported, getLocalName, ltLexical, + + -- PRINTERY AND FORCERY + Outputable(..), -- class + PprStyle(..), -- style-ry (re-exported) + + interppSP, interpp'SP, +--UNUSED: ifPprForUser, + ifnotPprForUser, + ifPprDebug, --UNUSED: ifnotPprDebug, + ifPprShowAll, ifnotPprShowAll, + ifPprInterface, --UNUSED: ifnotPprInterface, +--UNUSED: ifPprForC, ifnotPprForC, +--UNUSED: ifPprUnfolding, ifnotPprUnfolding, + + isOpLexeme, pprOp, pprNonOp, + isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid, + + -- and to make the interface self-sufficient... + Pretty(..), GlobalSwitch, + PrettyRep, UniType, Unique, SrcLoc + ) where + +import AbsUniType ( UniType, + TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import Id ( Id ) -- for specialising +import NameTypes -- for specialising +import ProtoName -- for specialising +import Pretty +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[NamedThing-class]{The @NamedThing@ class} +%* * +%************************************************************************ + +\begin{code} +class NamedThing a where + getExportFlag :: a -> ExportFlag + isLocallyDefined :: a -> Bool + getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-}) + getOccurrenceName :: a -> FAST_STRING + getInformingModules :: a -> [FAST_STRING] + getSrcLoc :: a -> SrcLoc + getTheUnique :: a -> Unique + hasType :: a -> Bool + getType :: a -> UniType + fromPreludeCore :: a -> Bool + -- see also friendly functions that follow... +\end{code} + +\begin{description} +\item[@getExportFlag@:] +Obvious. + +\item[@getOrigName@:] +Obvious. + +\item[@isLocallyDefined@:] +Whether the thing is defined in this module or not. + +\item[@getOccurrenceName@:] +Gets the name by which a thing is known in this module (e.g., if +renamed, or whatever)... + +\item[@getInformingModules@:] +Gets the name of the modules that told me about this @NamedThing@. + +\item[@getSrcLoc@:] +Obvious. + +\item[@hasType@ and @getType@:] +In pretty-printing @AbsSyntax@, we need to query if a datatype has +types attached yet or not. We use @hasType@ to see if there are types +available; and @getType@ if we want to grab one... (Ugly but effective) + +\item[@fromPreludeCore@:] +Tests a quite-delicate property: it is \tr{True} iff the entity is +actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if +it is re-exported by \tr{PreludeCore}. See the @FullName@ type in +module \tr{NameTypes}. + +NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test. +This is a bummer for types that are wired into the compiler. +\end{description} + +Some functions to go with: +\begin{code} +isExported a + = case (getExportFlag a) of + NotExported -> False + _ -> True + +getLocalName :: (NamedThing a) => a -> FAST_STRING + +getLocalName = snd . getOrigName + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isExported :: Class -> Bool #-} +{-# SPECIALIZE isExported :: Id -> Bool #-} +{-# SPECIALIZE isExported :: TyCon -> Bool #-} +{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-} +#endif +\end{code} + +@ltLexical@ is used for sorting things into lexicographical order, so +as to canonicalize interfaces. [Regular @(<)@ should be used for fast +comparison.] + +\begin{code} +a `ltLexical` b + = BIND isLocallyDefined a _TO_ a_local -> + BIND isLocallyDefined b _TO_ b_local -> + BIND getOrigName a _TO_ (a_mod, a_name) -> + BIND getOrigName b _TO_ (b_mod, b_name) -> + if a_local || b_local then + a_name < b_name -- can't compare module names + else + case _CMP_STRING_ a_mod b_mod of + LT_ -> True + EQ_ -> a_name < b_name + GT__ -> False + BEND BEND BEND BEND + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} +{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} +{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +%* * +%************************************************************************ + +The export flag @ExportAll@ means `export all there is', so there are +times when it is attached to a class or data type which has no +ops/constructors (if the class/type was imported abstractly). In +fact, @ExportAll@ is attached to everything except to classes/types +which are being {\em exported} abstractly, regardless of how they were +imported. + +\begin{code} +data ExportFlag + = ExportAll -- export with all constructors/methods + | ExportAbs -- export abstractly + | NotExported +\end{code} + +%************************************************************************ +%* * +\subsection[Outputable-class]{The @Outputable@ class} +%* * +%************************************************************************ + +\begin{code} +class Outputable a where + ppr :: PprStyle -> a -> Pretty +\end{code} + +\begin{code} +-- the ppSep in the ppInterleave puts in the spaces +-- Death to ppSep! (WDP 94/11) + +interppSP :: Outputable a => PprStyle -> [a] -> Pretty +interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs) + +interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty +interpp'SP sty xs + = ppInterleave sep (map (ppr sty) xs) + where + sep = ppBeside ppComma ppSP + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-} +{-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-} + +{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-} +#endif +\end{code} + +\begin{code} +--UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil +ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil +ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil +ifPprInterface sty p = case sty of PprInterface _ -> p ; _ -> ppNil +--UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil +--UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil + +ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p +--UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p +ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p +--UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p +--UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p +--UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p +\end{code} + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. Normally applied as in, e.g., +@isConop (getOccurrenceName foo)@... [just for pretty-printing] + +\begin{code} +isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool + +isConop cs + | _NULL_ cs = False + | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s + | otherwise = isUpper c || c == ':' + where + c = _HEAD_ cs + +{- UNUSED: +isAconid [] = False +isAconid ('_':cs) = isAconid cs +isAconid (c:cs) = isUpper c +-} + +isAconop cs + | _NULL_ cs = False + | otherwise = c == ':' + where + c = _HEAD_ cs + +isAvarid cs + | _NULL_ cs = False + | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s + | otherwise = isLower c + where + c = _HEAD_ cs + +isAvarop cs + | _NULL_ cs = False + | isLower c = False -- shortcut + | isUpper c = False -- ditto + | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus + where + c = _HEAD_ cs +\end{code} + +And one ``higher-level'' interface to those: + +\begin{code} +isOpLexeme :: NamedThing a => a -> Bool + +isOpLexeme v + = let str = getOccurrenceName v in isAvarop str || isAconop str + +-- print `vars`, (op) correctly +pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty + +pprOp sty var + = if isOpLexeme var + then ppr sty var + else ppBesides [ppChar '`', ppr sty var, ppChar '`'] + +pprNonOp sty var + = if isOpLexeme var + then ppBesides [ppLparen, ppr sty var, ppRparen] + else ppr sty var + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isOpLexeme :: Id -> Bool #-} +{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-} +{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-} +{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-} +#endif +\end{code} + +\begin{code} +instance Outputable Bool where + ppr sty True = ppPStr SLIT("True") + ppr sty False = ppPStr SLIT("False") + +instance (Outputable a) => Outputable [a] where + ppr sty xs = + ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ] + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr sty (x,y) = + ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen) + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr sty (x,y,z) = + ppSep [ ppBesides [ppLparen, ppr sty x, ppComma], + ppBeside (ppr sty y) ppComma, + ppBeside (ppr sty z) ppRparen ] +\end{code} diff --git a/ghc/compiler/utils/Pretty.hi b/ghc/compiler/utils/Pretty.hi new file mode 100644 index 0000000000..50f76528d8 --- /dev/null +++ b/ghc/compiler/utils/Pretty.hi @@ -0,0 +1,81 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Pretty where +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Stdio(_FILE) +import Unpretty(Unpretty(..)) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data Delay a {-# GHC_PRAGMA MkDelay a #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep = MkPrettyRep CSeq (Delay Int) Bool Bool +type Unpretty = CSeq +codeStyle :: PprStyle -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: PprStyle) -> case u0 of { _ALG_ _ORIG_ Pretty PprForC (u1 :: GlobalSwitch -> Bool) -> _!_ True [] []; _ORIG_ Pretty PprForAsm (u2 :: GlobalSwitch -> Bool) (u3 :: Bool) (u4 :: [Char] -> [Char]) -> _!_ True [] []; (u5 :: PprStyle) -> _!_ False [] [] } _N_ #-} +pp'SP :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ Pretty ppStr [ _NOREP_S_ ", " ] _N_ #-} +ppAbove :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppAboves :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppAbove, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-} +ppAppendFile :: _FILE -> Int -> (Int -> Bool -> PrettyRep) -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "U(P)LSL" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppBeside :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppBesides :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppBeside, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-} +ppCat :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +ppChar :: Char -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppComma :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppDouble :: Double -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppEquals :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppFloat :: Float -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 210 _N_ _N_ _N_ _N_ #-} +ppHang :: (Int -> Bool -> PrettyRep) -> Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 12222 _N_ _S_ "SLLLL" _N_ _N_ #-} +ppInt :: Int -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppInteger :: Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppInterleave :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +ppIntersperse :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +ppLbrack :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppLparen :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppNest :: Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLE" _N_ _N_ #-} +ppNil :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppPStr :: _PackedString -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppRbrack :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppRparen :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSP :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSemi :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSep :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +ppShow :: Int -> (Int -> Bool -> PrettyRep) -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +ppStr :: [Char] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +prettyToUn :: (Int -> Bool -> PrettyRep) -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs new file mode 100644 index 0000000000..f4169255ce --- /dev/null +++ b/ghc/compiler/utils/Pretty.lhs @@ -0,0 +1,439 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Pretty]{Pretty-printing data type} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +#else +# define FAST_STRING String +# define _LENGTH_ length +#endif + +module Pretty ( + Pretty(..), + +#if defined(COMPILING_GHC) + PprStyle(..), + prettyToUn, + codeStyle, -- UNUSED: stySwitch, +#endif + ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger, + ppFloat, ppDouble, +#if __GLASGOW_HASKELL__ >= 23 + -- may be able to *replace* ppDouble + ppRational, +#endif + ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, + ppSemi, ppComma, ppEquals, + + ppCat, ppBeside, ppBesides, ppAbove, ppAboves, + ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, + ppShow, +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + ppAppendFile, +#endif + + -- abstract type, to complete the interface... + PrettyRep(..), CSeq, Delay +#if defined(COMPILING_GHC) + , GlobalSwitch, Unpretty(..) +#endif + ) where + +import CharSeq +#if defined(COMPILING_GHC) +import Unpretty ( Unpretty(..) ) +import CmdLineOpts ( GlobalSwitch ) +#endif +\end{code} + +Based on John Hughes's pretty-printing library. For now, that code +and notes for it are in files \tr{pp-rjmh*} (ToDo: rm). + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +ppNil :: Pretty +ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty + +ppStr :: [Char] -> Pretty +ppPStr :: FAST_STRING -> Pretty +ppChar :: Char -> Pretty +ppInt :: Int -> Pretty +ppInteger :: Integer -> Pretty +ppDouble :: Double -> Pretty +ppFloat :: Float -> Pretty +#if __GLASGOW_HASKELL__ >= 23 +ppRational :: Rational -> Pretty +#endif + +ppBeside :: Pretty -> Pretty -> Pretty +ppBesides :: [Pretty] -> Pretty +ppBesideSP :: Pretty -> Pretty -> Pretty +ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP + +ppAbove :: Pretty -> Pretty -> Pretty +ppAboves :: [Pretty] -> Pretty + +ppInterleave :: Pretty -> [Pretty] -> Pretty +ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep +ppSep :: [Pretty] -> Pretty +ppHang :: Pretty -> Int -> Pretty -> Pretty +ppNest :: Int -> Pretty -> Pretty + +ppShow :: Int -> Pretty -> [Char] + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif +ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +type Pretty = Int -- The width to print in + -> Bool -- True => vertical context + -> PrettyRep + +data PrettyRep + = MkPrettyRep CSeq -- The text + (Delay Int) -- No of chars in last line + Bool -- True if empty object + Bool -- Fits on a single line in specified width + +data Delay a = MkDelay a + +forceDel (MkDelay _) r = r + +forceBool True r = r +forceBool False r = r + +forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r)) + +ppShow width p + = case (p width False) of + MkPrettyRep seq ll emp sl -> cShow seq + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +ppAppendFile f width p + = case (p width False) of + MkPrettyRep seq ll emp sl -> cAppendFile f seq +#endif + +ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0) + -- Doesn't fit if width < 0, otherwise, ppNil + -- will make ppBesides always return True. + +ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) + where ls = length s +ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls) + where ls = _LENGTH_ s +ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1) + +ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) + where s = show n; ls = length s + +ppInteger n = ppStr (show n) +ppDouble n = ppStr (show n) +ppFloat n = ppStr (show n) +#if __GLASGOW_HASKELL__ >= 23 +--ppRational n = ppStr (_showRational 30 n) +ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n) +#endif + +ppSP = ppChar ' ' +pp'SP = ppStr ", " +ppLbrack = ppChar '[' +ppRbrack = ppChar ']' +ppLparen = ppChar '(' +ppRparen = ppChar ')' +ppSemi = ppChar ';' +ppComma = ppChar ',' +ppEquals = ppChar '=' + +ppInterleave sep ps = ppSep (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (ppBeside x sep) : pi xs +\end{code} + +ToDo: this could be better: main pt is: no extra spaces in between. + +\begin{code} +ppIntersperse sep ps = ppBesides (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (ppBeside x sep) : pi xs +\end{code} + +Laziness is important in @ppBeside@. If the first thing is not a +single line it will return @False@ for the single-line boolean without +laying out the second. + +\begin{code} +ppBeside p1 p2 width is_vert + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2)) + (MkDelay (ll1 + ll2)) + (emp1 && emp2) + ((width >= 0) && (sl1 && sl2)) + -- This sequence of (&&)'s ensures that ppBeside + -- returns a False for sl as soon as possible. + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False + -- ToDo: if emp{1,2} then we really + -- should be passing on "is_vert" to p{2,1}. + +ppBesides [] = ppNil +ppBesides ps = foldr1 ppBeside ps +\end{code} + +@ppBesideSP@ puts two things beside each other separated by a space. + +\begin{code} +ppBesideSP p1 p2 width is_vert + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2))) + (MkDelay (li + ll2)) + (emp1 && emp2) + ((width >= wi) && (sl1 && sl2)) + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False + li, wi :: Int + li = if emp1 then 0 else ll1+1 + wi = if emp1 then 0 else 1 + sp = if emp1 || emp2 then cNil else (cCh ' ') +\end{code} + +@ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@. + +\begin{code} +ppCat [] = ppNil +ppCat ps = foldr1 ppBesideSP ps +\end{code} + +\begin{code} +ppAbove p1 p2 width is_vert + = case (p1 width True) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2)) + (MkDelay ll2) + -- ToDo: make ll depend on empties? + (emp1 && emp2) + False + where -- NB: for case alt + nl = if emp1 || emp2 then cNil else cNL + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 -- Don't "optimise" this away! + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True + -- ToDo: ditto about passing is_vert if empties + +ppAboves [] = ppNil +ppAboves ps = foldr1 ppAbove ps +\end{code} + +\begin{code} +ppNest n p width False = p width False +ppNest n p width True + = case (p (width-n) True) of + MkPrettyRep seq (MkDelay ll) emp sl -> + MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl +\end{code} + +The length-check below \tr{(ll1+ll2+1) <= width} should really check for +max widths not the width of the last line. + +\begin{code} +ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could + -- be made with a little more effort. + -- Eg the output always starts with seq1 + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + if emp1 then + p2 width is_vert + else + if (ll1 <= n) || sl2 then -- very ppBesideSP'ish + -- Hang it if p1 shorter than indent or if it doesn't fit + MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2))) + (MkDelay (ll1 + 1 + ll2)) + False + (sl1 && sl2) + else + -- Nest it (pretty ppAbove-ish) + MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2'))) + (MkDelay ll2') -- ToDo: depend on empties + False + False + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False + -- ToDo: more "is_vert if empty" stuff + + seq2' = forceInfo x_ll2' emp2' sl2' x_seq2' + MkDelay ll2' = x_ll2' -- Don't "optimise" this away! + MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True? +\end{code} + +\begin{code} +ppSep [] width is_vert = ppNil width is_vert +ppSep [p] width is_vert = p width is_vert + +-- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable +-- ppSep [a, ppSep[b, ppSep [c, ... ]]] + +ppSep ps width is_vert + = case (ppCat ps width is_vert) of + MkPrettyRep seq x_ll emp sl -> + if sl then -- Fits on one line + MkPrettyRep seq x_ll emp sl + else + ppAboves ps width is_vert -- Takes several lines +\end{code} + +%************************************************************************ +%* * +\subsection[Outputable-print]{Pretty-printing stuff} +%* * +%************************************************************************ + +ToDo: this is here for no-original-name reasons (mv?). + +There is no clearly definitive list of @PprStyles@; I suggest the +following: + +\begin{code} +#if defined(COMPILING_GHC) + -- to the end of file + +data PprStyle + = PprForUser -- Pretty-print in a way that will + -- make sense to the ordinary user; + -- must be very close to Haskell + -- syntax, etc. ToDo: how diff is + -- this from what pprInterface must + -- do? + | PprDebug -- Standard debugging output + | PprShowAll -- Debugging output which leaves + -- nothing to the imagination + | PprInterface -- Interface generation + (GlobalSwitch -> Bool) -- (we can look at cmd-line flags) + | PprForC -- must print out C-acceptable names + (GlobalSwitch -> Bool) -- (ditto) + | PprUnfolding -- for non-interface intermodule info + (GlobalSwitch -> Bool) -- the compiler writes/reads + | PprForAsm -- must print out assembler-acceptable names + (GlobalSwitch -> Bool) -- (ditto) + Bool -- prefix CLabel with underscore? + (String -> String) -- format AsmTempLabel +\end{code} + +The following test decides whether or not we are actually generating +code (either C or assembly). +\begin{code} +codeStyle :: PprStyle -> Bool +codeStyle (PprForC _) = True +codeStyle (PprForAsm _ _ _) = True +codeStyle _ = False + +{- UNUSED: +stySwitch :: PprStyle -> GlobalSwitch -> Bool +stySwitch (PprInterface sw) = sw +stySwitch (PprForC sw) = sw +stySwitch (PprForAsm sw _ _) = sw +-} +\end{code} + +Orthogonal to these 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. + +\begin{code} +prettyToUn :: Pretty -> Unpretty + +prettyToUn p + = case (p 999999{-totally bogus width-} False{-also invented-}) of + MkPrettyRep seq ll emp sl -> seq + +#endif {-COMPILING_GHC-} +\end{code} + +----------------------------------- +\begin{code} +-- from Lennart +fromRationalX :: (RealFloat a) => Rational -> a + +fromRationalX r = + let + h = ceiling (huge `asTypeOf` x) + b = toInteger (floatRadix x) + x = fromRat 0 r + fromRat e0 r' = + let d = denominator r' + n = numerator r' + in if d > h then + let e = integerLogBase b (d `div` h) + 1 + in fromRat (e0-e) (n % (d `div` (b^e))) + else if abs n > h then + let e = integerLogBase b (abs n `div` h) + 1 + in fromRat (e0+e) ((n `div` (b^e)) % d) + else + scaleFloat e0 (fromRational r') + in x + +-- Compute the discrete log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + + doDiv :: Integer -> Int -> Int + doDiv j k = if j < b then k else doDiv (j `div` b) (k+1) + in + doDiv (i `div` (b^l)) l + + +------------ + +-- Compute smallest and largest floating point values. +{- +tiny :: (RealFloat a) => a +tiny = + let (l, _) = floatRange x + x = encodeFloat 1 (l-1) + in x +-} + +huge :: (RealFloat a) => a +huge = + let (_, u) = floatRange x + d = floatDigits x + x = encodeFloat (floatRadix x ^ d - 1) (u - d) + in x +\end{code} diff --git a/ghc/compiler/utils/UniqFM.hi b/ghc/compiler/utils/UniqFM.hi new file mode 100644 index 0000000000..6947486603 --- /dev/null +++ b/ghc/compiler/utils/UniqFM.hi @@ -0,0 +1,59 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniqFM where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(ShortName) +import Outputable(NamedThing) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique, u2i) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +addToUFM_Directly :: UniqFM a -> Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +isNullUFM :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-} +listToUFM :: NamedThing a => [(a, b)] -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +listToUFM_Directly :: [(Unique, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +lookupDirectlyUFM :: UniqFM a -> Unique -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +mapUFM :: (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +singletonDirectlyUFM :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +sizeUFM :: UniqFM a -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +ufmToList :: UniqFM a -> [(Unique, a)] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs new file mode 100644 index 0000000000..92839cbdb6 --- /dev/null +++ b/ghc/compiler/utils/UniqFM.lhs @@ -0,0 +1,881 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[UniqFM]{Specialised finite maps, for things with @Uniques@} + +Based on @FiniteMaps@ (as you would expect). + +Basically, the things need to be in class @NamedThing@, and we use the +@getTheUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations +of this stuff for Ids and TyVars, respectively. + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} +#else +#define ASSERT(e) {--} +#define IF_NOT_GHC(a) a +#endif + +module UniqFM ( + UniqFM, -- abstract type + + emptyUFM, + singletonUFM, + singletonDirectlyUFM, + listToUFM, + listToUFM_Directly, + addToUFM, + IF_NOT_GHC(addListToUFM COMMA) + addToUFM_Directly, + IF_NOT_GHC(addToUFM_C COMMA) + IF_NOT_GHC(addListToUFM_C COMMA) + delFromUFM, + delListFromUFM, + plusUFM, + plusUFM_C, + minusUFM, + intersectUFM, + IF_NOT_GHC(intersectUFM_C COMMA) + IF_NOT_GHC(foldUFM COMMA) + mapUFM, + filterUFM, + sizeUFM, + isNullUFM, + lookupUFM, + lookupDirectlyUFM, + IF_NOT_GHC(lookupWithDefaultUFM COMMA) + eltsUFM, + ufmToList, + + -- to make the interface self-sufficient + Id, TyVar, Unique + IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling + ) where + +import AbsUniType -- for specialisation to TyVars +import Id -- for specialisation to Ids +import IdInfo -- sigh +import Maybes ( maybeToBool, Maybe(..) ) +import Name +import Outputable +import Unique ( u2i, mkUniqueGrimily, Unique ) +import Util +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''. + +\begin{code} +emptyUFM :: UniqFM elt +isNullUFM :: UniqFM elt -> Bool +singletonUFM :: NamedThing key => key -> elt -> UniqFM elt +singletonDirectlyUFM -- got the Unique already + :: Unique -> elt -> UniqFM elt +listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt +listToUFM_Directly + :: [(Unique, elt)] -> UniqFM elt + +addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addToUFM_Directly + :: UniqFM elt -> Unique -> elt -> UniqFM elt + +addToUFM_C :: NamedThing key => (elt -> elt -> elt) + -> UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM_C :: NamedThing key => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt + +delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt +delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt + +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt + +plusUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt + +minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt + +intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +intersectUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt + +sizeUFM :: UniqFM elt -> Int + +lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt +lookupDirectlyUFM -- when you've got the Unique already + :: UniqFM elt -> Unique -> Maybe elt +lookupWithDefaultUFM + :: NamedThing key => UniqFM elt -> elt -> key -> elt + +eltsUFM :: UniqFM elt -> [elt] +ufmToList :: UniqFM elt -> [(Unique, elt)] +\end{code} + +%************************************************************************ +%* * +\subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars} +%* * +%************************************************************************ + +\begin{code} +type IdFinMap elt = UniqFM elt +type TyVarFinMap elt = UniqFM elt +type NameFinMap elt = UniqFM elt +type RegFinMap elt = UniqFM elt +\end{code} + +\begin{code} +#ifdef __GLASGOW_HASKELL__ +-- I don't think HBC was too happy about this (WDP 94/10) + +{-# SPECIALIZE + singletonUFM :: Id -> elt -> IdFinMap elt, + TyVar -> elt -> TyVarFinMap elt, + Name -> elt -> NameFinMap elt + IF_NCG(COMMA Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + listToUFM :: [(Id, elt)] -> IdFinMap elt, + [(TyVar,elt)] -> TyVarFinMap elt, + [(Name, elt)] -> NameFinMap elt + IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt, + TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, + NameFinMap elt -> Name -> elt -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt, + TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, + NameFinMap elt -> [(Name,elt)] -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + addToUFM_C :: (elt -> elt -> elt) + -> IdFinMap elt -> Id -> elt -> IdFinMap elt, + (elt -> elt -> elt) + -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, + (elt -> elt -> elt) + -> NameFinMap elt -> Name -> elt -> NameFinMap elt + IF_NCG(COMMA (elt -> elt -> elt) + -> RegFinMap elt -> Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + addListToUFM_C :: (elt -> elt -> elt) + -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt, + (elt -> elt -> elt) + -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, + (elt -> elt -> elt) + -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt + IF_NCG(COMMA (elt -> elt -> elt) + -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt, + TyVarFinMap elt -> TyVar -> TyVarFinMap elt, + NameFinMap elt -> Name -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt) + #-} +{-# SPECIALIZE + delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt, + TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt, + NameFinMap elt -> [Name] -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt) + #-} + +{-# SPECIALIZE + lookupUFM :: IdFinMap elt -> Id -> Maybe elt, + TyVarFinMap elt -> TyVar -> Maybe elt, + NameFinMap elt -> Name -> Maybe elt + IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt) + #-} +{-# SPECIALIZE + lookupWithDefaultUFM + :: IdFinMap elt -> elt -> Id -> elt, + TyVarFinMap elt -> elt -> TyVar -> elt, + NameFinMap elt -> elt -> Name -> elt + IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt) + #-} + +#endif {- __GLASGOW_HASKELL__ -} +\end{code} + +%************************************************************************ +%* * +\subsection{Andy Gill's underlying @UniqFM@ machinery} +%* * +%************************************************************************ + +``Uniq Finite maps'' are the heart and soul of the compiler's +lookup-tables/environments. Important stuff! It works well with +Dense and Sparse ranges. +Both @Uq@ Finite maps and @Hash@ Finite Maps +are built ontop of Int Finite Maps. + +This code is explained in the paper: +\begin{display} + A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends + "A Cheap balancing act that grows on a tree" + Glasgow FP Workshop, Sep 1994, pp??-?? +\end{display} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +@UniqFM a@ is a mapping from Unique to a. + +First, the DataType itself; which is either a Node, a Leaf, or an Empty. + +\begin{code} +data UniqFM ele + = EmptyUFM + | LeafUFM FAST_INT ele + | NodeUFM FAST_INT -- the switching + FAST_INT -- the delta + (UniqFM ele) + (UniqFM ele) + +-- for debugging only :-) +{- +instance Text (UniqFM a) where + showsPrec _ (NodeUFM a b t1 t2) = + showString "NodeUFM " . shows (IBOX(a)) + . showString " " . shows (IBOX(b)) + . showString " (" . shows t1 + . showString ") (" . shows t2 + . showString ")" + showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x)) + showsPrec _ (EmptyUFM) = id +-} +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ functions} +%* * +%************************************************************************ + +First the ways of building a UniqFM. + +\begin{code} +emptyUFM = EmptyUFM +singletonUFM key elt = mkLeafUFM (u2i (getTheUnique key)) elt +singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt + +listToUFM key_elt_pairs + = addListToUFM_C use_snd EmptyUFM key_elt_pairs + +listToUFM_Directly uniq_elt_pairs + = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs +\end{code} + +Now ways of adding things to UniqFMs. + +There is an alternative version of @addListToUFM_C@, that uses @plusUFM@, +but the semantics of this operation demands a linear insertion; +perhaps the version without the combinator function +could be optimised using it. + +\begin{code} +addToUFM fm key elt = addToUFM_C use_snd fm key elt + +addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt + +addToUFM_C combiner fm key elt + = insert_ele combiner fm (u2i (getTheUnique key)) elt + +addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs + +addListToUFM_C combiner fm key_elt_pairs + = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getTheUnique k)) e) + fm key_elt_pairs + +addListToUFM_directly_C combiner fm uniq_elt_pairs + = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e) + fm uniq_elt_pairs +\end{code} + +Now ways of removing things from UniqFM. + +\begin{code} +delListFromUFM fm lst = foldl delFromUFM fm lst + +delFromUFM fm key = delete fm (u2i (getTheUnique key)) + +delete EmptyUFM _ = EmptyUFM +delete fm key = del_ele fm + where + del_ele :: UniqFM a -> UniqFM a + + del_ele lf@(LeafUFM j _) + | j _EQ_ key = EmptyUFM + | otherwise = lf -- no delete! + + del_ele nd@(NodeUFM j p t1 t2) + | j _GT_ key + = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2 + | otherwise + = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2) + + del_ele _ = panic "Found EmptyUFM FM when rec-deleting" +\end{code} + +Now ways of adding two UniqFM's together. + +\begin{code} +plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2 + +plusUFM_C f EmptyUFM tr = tr +plusUFM_C f tr EmptyUFM = tr +plusUFM_C f fm1 fm2 = mix_trees fm1 fm2 + where + mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a + mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a + + mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = mix_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' (C j j') + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' j j' + -- / \ / \ + -- t1 t2 t1' t2' + -- Fast, Ehh ! + -- + mix_branches (NewRoot nd False) + = mkLLNodeUFM nd left_t right_t + mix_branches (NewRoot nd True) + = mkLLNodeUFM nd right_t left_t + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 + t1' t2 + t2' + -- + mix_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (mix_trees t1 t1') + (mix_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- + -- Given j >^ j' (and, say, j > j') + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 t2 + j' + -- / \ + -- t1' t2' + mix_branches (LeftRoot Left) -- | trace "LL" True + = mkSLNodeUFM + (NodeUFMData j p) + (mix_trees t1 right_t) + t2 + + mix_branches (LeftRoot Right) -- | trace "LR" True + = mkLSNodeUFM + (NodeUFMData j p) + t1 + (mix_trees t2 right_t) + + mix_branches (RightRoot Left) -- | trace "RL" True + = mkSLNodeUFM + (NodeUFMData j' p') + (mix_trees left_t t1') + t2' + + mix_branches (RightRoot Right) -- | trace "RR" True + = mkLSNodeUFM + (NodeUFMData j' p') + t1' + (mix_trees left_t t2') + + mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt" +\end{code} + +And ways of subtracting them. First the base cases, +then the full D&C approach. + +\begin{code} +minusUFM EmptyUFM _ = EmptyUFM +minusUFM t1 EmptyUFM = t1 +minusUFM fm1 fm2 = minus_trees fm1 fm2 + where + -- + -- Notice the asymetry of subtraction + -- + minus_trees lf@(LeafUFM i a) t2 = + case lookup t2 i of + Nothing -> lf + Just b -> EmptyUFM + + minus_trees t1 (LeafUFM i _) = delete t1 i + + minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = minus_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 t2 + -- + -- + -- Fast, Ehh ! + -- + minus_branches (NewRoot nd _) = left_t + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 + t1' t2 + t2' + -- + minus_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (minus_trees t1 t1') + (minus_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- again, with asymatry + + -- + -- The left is above the right + -- + minus_branches (LeftRoot Left) + = mkSLNodeUFM + (NodeUFMData j p) + (minus_trees t1 right_t) + t2 + minus_branches (LeftRoot Right) + = mkLSNodeUFM + (NodeUFMData j p) + t1 + (minus_trees t2 right_t) + + -- + -- The right is above the left + -- + minus_branches (RightRoot Left) + = minus_trees left_t t1' + minus_branches (RightRoot Right) + = minus_trees left_t t2' + + minus_trees _ _ = panic "EmptyUFM found when insering into plusInt" +\end{code} + +And taking the intersection of two UniqFM's. + +\begin{code} +intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2 + +intersectUFM_C f EmptyUFM _ = EmptyUFM +intersectUFM_C f _ EmptyUFM = EmptyUFM +intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2 + where + intersect_trees (LeafUFM i a) t2 = + case lookup t2 i of + Nothing -> EmptyUFM + Just b -> mkLeafUFM i (f a b) + + intersect_trees t1 (LeafUFM i a) = + case lookup t1 i of + Nothing -> EmptyUFM + Just b -> mkLeafUFM i (f b a) + + intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = intersect_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' + -- / \ + / \ ==> EmptyUFM + -- t1 t2 t1' t2' + -- + -- Fast, Ehh ! + -- + intersect_branches (NewRoot nd _) = EmptyUFM + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 x t1' t2 x t2' + -- + intersect_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (intersect_trees t1 t1') + (intersect_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- + -- Given j >^ j' (and, say, j > j') + -- + -- j j' t2 + j' + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1' t2' + -- + -- This does cut down the search space quite a bit. + + intersect_branches (LeftRoot Left) + = intersect_trees t1 right_t + intersect_branches (LeftRoot Right) + = intersect_trees t2 right_t + intersect_branches (RightRoot Left) + = intersect_trees left_t t1' + intersect_branches (RightRoot Right) + = intersect_trees left_t t2' + + intersect_trees x y = panic ("EmptyUFM found when intersecting trees") +\end{code} + +Now the usual set of `collection' operators, like map, fold, etc. + +\begin{code} +foldUFM fn a EmptyUFM = a +foldUFM fn a fm = fold_tree fn a fm + +mapUFM fn EmptyUFM = EmptyUFM +mapUFM fn fm = map_tree fn fm + +filterUFM fn EmptyUFM = EmptyUFM +filterUFM fn fm = filter_tree fn fm +\end{code} + +Note, this takes a long time, O(n), but +because we dont want to do this very often, we put up with this. +O'rable, but how often do we look at the size of +a finite map? + +\begin{code} +sizeUFM EmptyUFM = 0 +sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2 +sizeUFM (LeafUFM _ _) = 1 + +isNullUFM EmptyUFM = True +isNullUFM _ = False +\end{code} + +looking up in a hurry is the {\em whole point} of this binary tree lark. +Lookup up a binary tree is easy (and fast). + +\begin{code} +lookupUFM fm key = lookup fm (u2i (getTheUnique key)) +lookupDirectlyUFM fm key = lookup fm (u2i key) + +lookupWithDefaultUFM fm deflt key + = case lookup fm (u2i (getTheUnique key)) of + Nothing -> deflt + Just elt -> elt + +lookup EmptyUFM _ = Nothing +lookup fm i = lookup_tree fm + where + lookup_tree :: UniqFM a -> Maybe a + + lookup_tree (LeafUFM j b) + | j _EQ_ i = Just b + | otherwise = Nothing + lookup_tree (NodeUFM j p t1 t2) + | j _GT_ i = lookup_tree t1 + | otherwise = lookup_tree t2 + + lookup_tree EmptyUFM = panic "lookup Failed" +\end{code} + +folds are *wonderful* things. + +\begin{code} +eltsUFM EmptyUFM = [] +eltsUFM fm = fold_tree (:) [] fm + +ufmToList EmptyUFM = [] +ufmToList fm + = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm + where + fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1 + fold_tree f a (LeafUFM iu obj) = f iu obj a + + fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM" +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and its functions} +%* * +%************************************************************************ + +You should always use these to build the tree. +There are 4 versions of mkNodeUFM, depending on +the strictness of the two sub-tree arguments. +The strictness is used *both* to prune out +empty trees, *and* to improve performance, +stoping needless thunks lying around. +The rule of thumb (from experence with these trees) +is make thunks strict, but data structures lazy. +If in doubt, use mkSSNodeUFM, which has the `strongest' +functionality, but may do a few needless evaluations. + +\begin{code} +mkLeafUFM :: FAST_INT -> a -> UniqFM a +mkLeafUFM i a = LeafUFM i a + +-- The *ONLY* ways of building a NodeUFM. + +mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 +mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 +mkSSNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 +mkSLNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 +mkLSNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkLLNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +correctNodeUFM + :: Int + -> Int + -> UniqFM a + -> UniqFM a + -> Bool + +correctNodeUFM j p t1 t2 + = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2 + where + correct low high _ (LeafUFM i _) + = low <= IBOX(i) && IBOX(i) <= high + correct low high above_p (NodeUFM j p _ _) + = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p) + correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree" +\end{code} + +Note: doing SAT on this by hand seems to make it worse. Todo: Investigate, +and if necessary do $\lambda$ lifting on our functions that are bound. + +\begin{code} +insert_ele + :: (a -> a -> a) + -> UniqFM a + -> FAST_INT + -> a + -> UniqFM a + +insert_ele f EmptyUFM i new = mkLeafUFM i new + +insert_ele f (LeafUFM j old) i new + | j _GT_ i = + mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + (indexToRoot j)) + (mkLeafUFM i new) + (mkLeafUFM j old) + | j _EQ_ i = mkLeafUFM j (f old new) + | otherwise = + mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + (indexToRoot j)) + (mkLeafUFM j old) + (mkLeafUFM i new) + +insert_ele f n@(NodeUFM j p t1 t2) i a + | i _LT_ j + = if (i _GE_ (j _SUB_ p)) + then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2 + else mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + ((NodeUFMData j p))) + (mkLeafUFM i a) + n + | otherwise + = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p)) + then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a) + else mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + ((NodeUFMData j p))) + n + (mkLeafUFM i a) +\end{code} + +This has got a left to right ordering. + +\begin{code} +fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1 +fold_tree f a (LeafUFM _ obj) = f obj a + +fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM" +\end{code} + +\begin{code} +map_tree f (NodeUFM j p t1 t2) + = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2) +map_tree f (LeafUFM i obj) + = mkLeafUFM i (f obj) + +map_tree f _ = panic "map_tree failed" +\end{code} + +\begin{code} +filter_tree f nd@(NodeUFM j p t1 t2) + = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2) + +filter_tree f lf@(LeafUFM i obj) + | f obj = lf + | otherwise = EmptyUFM +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +Now some Utilities; + +This is the information that is held inside a NodeUFM, packaged up for +consumer use. + +\begin{code} +data NodeUFMData + = NodeUFMData FAST_INT + FAST_INT +\end{code} + +This is the information used when computing new NodeUFMs. + +\begin{code} +data Side = Left | Right +data CommonRoot + = LeftRoot Side -- which side is the right down ? + | RightRoot Side -- which side is the left down ? + | SameRoot -- they are the same ! + | NewRoot NodeUFMData -- here's the new, common, root + Bool -- do you need to swap left and right ? +\end{code} + +This specifies the relationship between NodeUFMData and CalcNodeUFMData. + +\begin{code} +indexToRoot :: FAST_INT -> NodeUFMData + +indexToRoot i + = let + l = (ILIT(1) :: FAST_INT) + in + NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l + +getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData + +getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) + | p _EQ_ p2 = getCommonNodeUFMData_ p j j2 + | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2 + | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2)) + where + l = (ILIT(1) :: FAST_INT) + j = i _QUOT_ (p `shiftL_` l) + j2 = i2 _QUOT_ (p2 `shiftL_` l) + + getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData + + getCommonNodeUFMData_ p j j_ + | j _EQ_ j_ + = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p + | otherwise + = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l) + +ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot + +ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2) + | j _EQ_ j2 = SameRoot + | otherwise + = case getCommonNodeUFMData x y of + nd@(NodeUFMData j3 p3) + | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2)) + | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2)) + | otherwise -> NewRoot nd (j _GT_ j2) + where + decideSide :: Bool -> Side + decideSide True = Left + decideSide False = Right +\end{code} + +This might be better in Util.lhs ? + + +Now the bit twiddling functions. +\begin{code} +shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT +shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT + +#if __GLASGOW_HASKELL__ +{-# INLINE shiftL_ #-} +{-# INLINE shiftR_ #-} +shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p) +shiftR_ n p = word2Int#((int2Word# n) `shiftr` p) +# if __GLASGOW_HASKELL__ >= 23 + where + shiftr x y = shiftRA# x y +# else + shiftr x y = shiftR# x y +# endif + +#else {- not GHC -} +shiftL_ n p = n * (2 ^ p) +shiftR_ n p = n `quot` (2 ^ p) + +#endif {- not GHC -} +\end{code} + +Andy's extras: ToDo: to Util. + +\begin{code} +use_fst :: a -> b -> a +use_fst a b = a + +use_snd :: a -> b -> b +use_snd a b = b +\end{code} diff --git a/ghc/compiler/utils/UniqSet.hi b/ghc/compiler/utils/UniqSet.hi new file mode 100644 index 0000000000..1abe6e0944 --- /dev/null +++ b/ghc/compiler/utils/UniqSet.hi @@ -0,0 +1,61 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniqSet where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(NamedThing) +import PreludePS(_PackedString) +import TyCon(TyCon) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM, eltsUFM, emptyUFM, intersectUFM, isNullUFM, minusUFM, plusUFM, singletonUFM) +import Unique(Unique, u2i) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdSet = UniqFM Id +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type NameSet = UniqFM Name +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TyVarSet = UniqFM TyVar +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +elementOfUniqSet :: NamedThing a => a -> UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LS" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ } #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +emptyUniqSet :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +intersectUniqSets :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM intersectUFM _N_ #-} +isEmptyUniqSet :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM isNullUFM _N_ #-} +isNullUFM :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-} +mapUniqSet :: NamedThing b => (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ _N_, TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Id ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ } #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +minusUniqSet :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM minusUFM _N_ #-} +mkUniqSet :: NamedThing a => [a] -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Name ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +singletonUniqSet :: NamedThing a => a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAASAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ UniqFM singletonUFM { u0 } { u0 } [ u1, u2, u2 ] _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (TyVar), _N_ ] { TyVar } [ u0, u0 ] _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(U(P)LLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Id] [u5, u0]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ }, [ Name ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Name) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (Name), _N_ ] { Name } [ u0, u0 ] _N_ } #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unionManyUniqSets :: [UniqFM a] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unionUniqSets :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-} +uniqSetToList :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-} + diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs new file mode 100644 index 0000000000..3adc33b174 --- /dev/null +++ b/ghc/compiler/utils/UniqSet.lhs @@ -0,0 +1,164 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @NamedThing@. + +We also export specialisations for @Ids@ and @TyVars@. + +\begin{code} +#include "HsVersions.h" + +module UniqSet ( + UniqSet(..), -- abstract type: NOT + + mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet, + unionUniqSets, unionManyUniqSets, minusUniqSet, + elementOfUniqSet, mapUniqSet, + intersectUniqSets, isEmptyUniqSet, + + -- specalised for Ids: + IdSet(..), + + -- specalised for TyVars: + TyVarSet(..), + + -- specalised for Names: + NameSet(..), + + -- to make the interface self-sufficient + Id, TyVar, Name, + + UniqFM, Unique + + -- and to be pragma friendly +#ifdef USE_ATTACK_PRAGMAS + , emptyUFM, intersectUFM, isNullUFM, minusUFM, singletonUFM, + plusUFM, eltsUFM, + u2i +#endif + ) where + +import UniqFM +import Id -- for specialisation to Ids +import IdInfo -- sigh +import Maybes ( maybeToBool, Maybe(..) ) +import Name +import Outputable +import AbsUniType -- for specialisation to TyVars +import Util +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{The @UniqSet@ type} +%* * +%************************************************************************ + +We use @UniqFM@, with a (@getTheUnique@-able) @Unique@ as ``key'' +and the thing itself as the ``value'' (for later retrieval). + +\begin{code} +--data UniqSet a = MkUniqSet (FiniteMap Unique a) : NOT + +type UniqSet a = UniqFM a +#define MkUniqSet {--} + +emptyUniqSet :: UniqSet a +emptyUniqSet = MkUniqSet emptyUFM + +singletonUniqSet :: NamedThing a => a -> UniqSet a +singletonUniqSet x = MkUniqSet (singletonUFM x x) + +uniqSetToList :: UniqSet a -> [a] +uniqSetToList (MkUniqSet set) = BSCC("uniqSetToList") eltsUFM set ESCC + +mkUniqSet :: NamedThing a => [a] -> UniqSet a +mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs]) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a + -- = foldr unionUniqSets emptyUniqSet ss +unionManyUniqSets [] = emptyUniqSet +unionManyUniqSets [s] = s +unionManyUniqSets (s:ss) = s `unionUniqSets` unionManyUniqSets ss + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2) + +elementOfUniqSet :: NamedThing a => a -> UniqSet a -> Bool +elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x) + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-} + +mapUniqSet :: NamedThing b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f (MkUniqSet set) + = MkUniqSet (listToUFM [ let + mapped_thing = f thing + in + (mapped_thing, mapped_thing) + | thing <- eltsUFM set ]) +\end{code} + +%************************************************************************ +%* * +\subsection{The @IdSet@ and @TyVarSet@ specialisations for sets of Ids/TyVars} +%* * +%************************************************************************ + +@IdSet@ is a specialised version, optimised for sets of Ids. + +\begin{code} +type IdSet = UniqSet Id +type TyVarSet = UniqSet TyVar +type NameSet = UniqSet Name +#if ! OMIT_NATIVE_CODEGEN +type RegSet = UniqSet Reg +#endif + +#if __GLASGOW_HASKELL__ + -- avoid hbc bug (0.999.7) +{-# SPECIALIZE + singletonUniqSet :: Id -> IdSet, + TyVar -> TyVarSet, + Name -> NameSet + IF_NCG(COMMA Reg -> RegSet) + #-} + +{-# SPECIALIZE + mkUniqSet :: [Id] -> IdSet, + [TyVar] -> TyVarSet, + [Name] -> NameSet + IF_NCG(COMMA [Reg] -> RegSet) + #-} + +{-# SPECIALIZE + elementOfUniqSet :: Id -> IdSet -> Bool, + TyVar -> TyVarSet -> Bool, + Name -> NameSet -> Bool + IF_NCG(COMMA Reg -> RegSet -> Bool) + #-} + +{-# SPECIALIZE + mapUniqSet :: (Id -> Id) -> IdSet -> IdSet, + (TyVar -> TyVar) -> TyVarSet -> TyVarSet, + (Name -> Name) -> NameSet -> NameSet + IF_NCG(COMMA (Reg -> Reg) -> RegSet -> RegSet) + #-} +#endif +\end{code} diff --git a/ghc/compiler/utils/Unpretty.hi b/ghc/compiler/utils/Unpretty.hi new file mode 100644 index 0000000000..3cc000531f --- /dev/null +++ b/ghc/compiler/utils/Unpretty.hi @@ -0,0 +1,67 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Unpretty where +import CharSeq(CSeq, cAppendFile, cInt) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import Pretty(PprStyle(..)) +import Stdio(_FILE) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Unpretty = CSeq +cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +uppAbove :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +uppAboves :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppAppendFile :: _FILE -> Int -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1022 _N_ _S_ "U(P)ASL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +uppBeside :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +uppBesides :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppCat :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppChar :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +uppComma :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppEquals :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +uppInteger :: Integer -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +uppInterleave :: CSeq -> [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +uppIntersperse :: CSeq -> [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +uppLbrack :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppLparen :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppNest :: Int -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AS" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int) (u1 :: CSeq) -> u1 _N_ #-} +uppNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +uppPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +uppRbrack :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppRparen :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSP :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSemi :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSep :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ Unpretty uppBesides _N_ #-} +uppShow :: Int -> CSeq -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ CharSeq cShow _N_} _F_ _IF_ARGS_ 0 2 XX 2 \ (u0 :: Int) (u1 :: CSeq) -> _APP_ _ORIG_ CharSeq cShow [ u1 ] _N_ #-} +uppStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} + diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs new file mode 100644 index 0000000000..2cdf8d4cad --- /dev/null +++ b/ghc/compiler/utils/Unpretty.lhs @@ -0,0 +1,170 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Unpretty]{Unpretty-printing data type} + +\begin{code} +#include "HsVersions.h" + +module Unpretty ( + Unpretty(..), + PprStyle(..), -- re-exported from Pretty + uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, --UNUSED: uppDouble, + uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, -- UNUSED: upp'SP, + uppSemi, uppComma, uppEquals, + + uppCat, uppBeside, uppBesides, uppAbove, uppAboves, + uppNest, uppSep, uppInterleave, uppIntersperse, --UNUSED: uppHang, + uppShow, +#ifdef __GLASGOW_HASKELL__ + uppAppendFile, + IF_ATTACK_PRAGMAS(cAppendFile COMMA) + IF_ATTACK_PRAGMAS(cInt COMMA) +#endif +#ifdef DPH + unprettyToStr, +#endif {- Data Parallel Haskell -} + + -- abstract type, to complete the interface... + CSeq, GlobalSwitch + ) where + +import CharSeq +import Outputable +import Pretty ( PprStyle(..), Pretty(..), GlobalSwitch ) +import Util +\end{code} + +Same interface as @Pretty@, but doesn't do anything. + +The pretty type is redefined here: +\begin{code} +type Unpretty = CSeq +\end{code} + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +uppNil :: Unpretty +uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty +--UNUSED: upp'SP :: Unpretty + +uppStr :: [Char] -> Unpretty +uppPStr :: FAST_STRING -> Unpretty +uppChar :: Char -> Unpretty +uppInt :: Int -> Unpretty +uppInteger :: Integer -> Unpretty +--UNUSED:uppDouble :: Double -> Unpretty + +uppBeside :: Unpretty -> Unpretty -> Unpretty +uppBesides :: [Unpretty] -> Unpretty +ppBesideSP :: Unpretty -> Unpretty -> Unpretty +uppCat :: [Unpretty] -> Unpretty -- i.e., ppBesidesSP + +uppAbove :: Unpretty -> Unpretty -> Unpretty +uppAboves :: [Unpretty] -> Unpretty + +uppInterleave :: Unpretty -> [Unpretty] -> Unpretty +uppIntersperse :: Unpretty -> [Unpretty] -> Unpretty -- no spaces between +uppSep :: [Unpretty] -> Unpretty +--UNUSED:uppHang :: Unpretty -> Int -> Unpretty -> Unpretty +uppNest :: Int -> Unpretty -> Unpretty + +uppShow :: Int -> Unpretty -> [Char] + +#ifdef __GLASGOW_HASKELL__ +uppAppendFile :: _FILE -> Int -> Unpretty -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +uppShow _ p = cShow p + +#ifdef __GLASGOW_HASKELL__ +uppAppendFile f _ p = cAppendFile f p +#endif + +uppNil = cNil +uppStr s = cStr s +uppPStr s = cPStr s +uppChar c = cCh c +uppInt n = cInt n + +uppInteger n = cStr (show n) +--UNUSED:uppDouble n = cStr (show n) + +uppSP = cCh ' ' +--UNUSED:upp'SP = cStr ", " +uppLbrack = cCh '[' +uppRbrack = cCh ']' +uppLparen = cCh '(' +uppRparen = cCh ')' +uppSemi = cCh ';' +uppComma = cCh ',' +uppEquals = cCh '=' + +uppInterleave sep ps = uppSep (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (cAppend{-uppBeside-} x sep) : pi xs +\end{code} + +\begin{code} +uppIntersperse sep ps = uppBesides (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (cAppend{-uppBeside-} x sep) : pi xs +\end{code} + +\begin{code} +uppBeside p1 p2 = p1 `cAppend` p2 + +uppBesides [] = cNil{-uppNil-} +uppBesides [p] = p +uppBesides (p:ps) = p `cAppend`{-uppBeside-} uppBesides ps +\end{code} + +\begin{code} +ppBesideSP p1 p2 = p1 `cAppend` (cCh ' ') `cAppend` p2 +\end{code} + +@uppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@. + +\begin{code} +uppCat [] = cNil{-uppNil-} +uppCat [p] = p +uppCat (p:ps) = ppBesideSP p (uppCat ps) + +uppAbove p1 p2 = p1 `cAppend` (cCh '\n') `cAppend` p2 + +uppAboves [] = cNil{-uppNil-} +uppAboves [p] = p +uppAboves (p:ps) = p `cAppend` (cCh '\n') `cAppend` (uppAboves ps) + +uppNest n p = p +\end{code} + +\begin{code} +--UNUSED: uppHang p1 n p2 = ppBesideSP p1 p2 + +uppSep ps = uppBesides ps +\end{code} + +\begin{code} +#ifdef DPH +unprettyToStr:: Unpretty -> String +unprettyToStr thing = uppShow 80 thing +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/utils/Util.hi b/ghc/compiler/utils/Util.hi new file mode 100644 index 0000000000..0483090297 --- /dev/null +++ b/ghc/compiler/utils/Util.hi @@ -0,0 +1,390 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Util where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import AbsSyn(Module) +import Bag(Bag, emptyBag, snocBag) +import BasicLit(BasicLit, kindOfBasicLit, typeOfBasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CLabelInfo(CLabel) +import CgBindery(StableLoc, VolatileLoc) +import CgMonad(EndOfBlockInfo, Sequel, StubFlag) +import CharSeq(CSeq, cAppend, cCh, cNil, cPStr, cShow, cStr) +import Class(Class, ClassOp) +import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult, switchIsOn) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr, pprCoreBinding, pprCoreExpr) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import FiniteMap(FiniteMap, emptyFM) +import HeapOffs(HeapOffset) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsCore(UfCostCentre, UfId, UnfoldingCoreAlts, UnfoldingCoreAtom, UnfoldingCoreBinding, UnfoldingCoreDefault, UnfoldingCoreExpr, UnfoldingPrimOp) +import HsDecls(ClassDecl, ConDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsImpExp(IE, IfaceImportDecl, ImportedInterface, Interface, Renaming) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat, typeOfPat) +import HsPragmas(ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, ImpStrictness, ImpUnfolding, InstancePragmas, TypePragmas) +import HsTypes(MonoType, PolyType) +import Id(Id, IdDetails, cmpId, eqId, getIdKind, getIdUniType) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate, InstTy) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda(..)) +import Name(Name, cmpName, eqName) +import NameTypes(FullName, Provenance, ShortName) +import OrdList(OrdList) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep, ppDouble, ppInt, ppInteger, ppNil, ppRational, ppStr) +import PrimKind(PrimKind) +import PrimOps(PrimOp, pprPrimOp, tagOf_PrimOp) +import ProtoName(ProtoName, cmpByLocalName, cmpProtoName, eqByLocalName, eqProtoName) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SimplEnv(EnclosingCcDetails, FormSummary, IdVal, SimplEnv, UnfoldConApp, UnfoldEnv, UnfoldItem, UnfoldingDetails, UnfoldingGuidance) +import SimplMonad(SimplCount, TickType) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc, mkUnknownSrcLoc) +import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr, StgRhs, UpdateFlag) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..)) +import UniTyFuns(kindFromType, pprTyCon, pprUniType) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique, UniqueSupply, cmpUnique, eqUnique, showUnique) +class OptIdInfo a where + noInfo :: a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-} + getInfo :: IdInfo -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-} + addInfo :: IdInfo -> a -> IdInfo + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-} + ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-} +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} +data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} +data ReturnInfo {-# GHC_PRAGMA DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode #-} +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-} +data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-} +data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-} +data CLabel +data StableLoc {-# GHC_PRAGMA NoStableLoc | VirAStkLoc Int | VirBStkLoc Int | LitLoc BasicLit | StableAmodeLoc CAddrMode #-} +data VolatileLoc {-# GHC_PRAGMA NoVolatileLoc | TempVarLoc Unique | RegLoc MagicId | VirHpLoc HeapOffset | VirNodeLoc HeapOffset #-} +data EndOfBlockInfo {-# GHC_PRAGMA EndOfBlockInfo Int Int Sequel #-} +data Sequel {-# GHC_PRAGMA InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))) #-} +data StubFlag {-# GHC_PRAGMA Stubbed | NotStubbed #-} +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-} +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data StandardFormInfo {-# GHC_PRAGMA NonStandardThunk | SelectorThunk Id Id Int | VapThunk Id [StgAtom Id] Bool #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-} +data CoreCaseDefault a b {-# GHC_PRAGMA CoNoDefault | CoBindDefault a (CoreExpr a b) #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data CcKind {-# GHC_PRAGMA UserCC _PackedString | AutoCC Id | DictCC Id #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data IsCafCC {-# GHC_PRAGMA IsCafCC | IsNotCafCC #-} +data IsDupdCC {-# GHC_PRAGMA AnOriginalCC | ADupdCC #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data HeapOffset +data Bind a b {-# GHC_PRAGMA EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +data Sig a {-# GHC_PRAGMA Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc #-} +data UfCostCentre a {-# GHC_PRAGMA UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool #-} +data UfId a {-# GHC_PRAGMA BoringUfId a | SuperDictSelUfId a a | ClassOpUfId a a | DictFunUfId a (PolyType a) | ConstMethodUfId a a (PolyType a) | DefaultMethodUfId a a | SpecUfId (UfId a) [Labda (MonoType a)] | WorkerUfId (UfId a) #-} +data UnfoldingCoreAlts a {-# GHC_PRAGMA UfCoAlgAlts [(a, [(a, PolyType a)], UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) #-} +data UnfoldingCoreAtom a {-# GHC_PRAGMA UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit #-} +data UnfoldingCoreBinding a {-# GHC_PRAGMA UfCoNonRec (a, PolyType a) (UnfoldingCoreExpr a) | UfCoRec [((a, PolyType a), UnfoldingCoreExpr a)] #-} +data UnfoldingCoreDefault a {-# GHC_PRAGMA UfCoNoDefault | UfCoBindDefault (a, PolyType a) (UnfoldingCoreExpr a) #-} +data UnfoldingCoreExpr a {-# GHC_PRAGMA UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) #-} +data UnfoldingPrimOp a {-# GHC_PRAGMA UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp #-} +data ClassDecl a b {-# GHC_PRAGMA ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc #-} +data ConDecl a {-# GHC_PRAGMA ConDecl a [MonoType a] SrcLoc #-} +data DataTypeSig a {-# GHC_PRAGMA AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc #-} +data DefaultDecl a {-# GHC_PRAGMA DefaultDecl [MonoType a] SrcLoc #-} +data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-} +data InstDecl a b {-# GHC_PRAGMA InstDecl [(a, a)] a (MonoType a) (MonoBinds a b) Bool _PackedString _PackedString [Sig a] (InstancePragmas a) SrcLoc #-} +data SpecialisedInstanceSig a {-# GHC_PRAGMA InstSpecSig a (MonoType a) SrcLoc #-} +data TyDecl a {-# GHC_PRAGMA TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc #-} +data ArithSeqInfo a b {-# GHC_PRAGMA From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data Qual a b {-# GHC_PRAGMA GeneratorQual b (Expr a b) | FilterQual (Expr a b) #-} +data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-} +data IfaceImportDecl {-# GHC_PRAGMA IfaceImportDecl _PackedString [IE] [Renaming] SrcLoc #-} +data ImportedInterface a b {-# GHC_PRAGMA ImportAll (Interface a b) [Renaming] | ImportSome (Interface a b) [IE] [Renaming] | ImportButHide (Interface a b) [IE] [Renaming] #-} +data Interface a b {-# GHC_PRAGMA MkInterface _PackedString [IfaceImportDecl] [FixityDecl a] [TyDecl a] [ClassDecl a b] [InstDecl a b] [Sig a] SrcLoc #-} +data Renaming {-# GHC_PRAGMA MkRenaming _PackedString _PackedString #-} +data Literal {-# GHC_PRAGMA CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) #-} +data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data Match a b {-# GHC_PRAGMA PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data ClassOpPragmas a {-# GHC_PRAGMA NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) #-} +data ClassPragmas a {-# GHC_PRAGMA NoClassPragmas | SuperDictPragmas [GenPragmas a] #-} +data DataPragmas a {-# GHC_PRAGMA DataPragmas [ConDecl a] [[Labda (MonoType a)]] #-} +data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-} +data ImpStrictness a {-# GHC_PRAGMA NoImpStrictness | ImpStrictness Bool [Demand] (GenPragmas a) #-} +data ImpUnfolding a {-# GHC_PRAGMA NoImpUnfolding | ImpMagicUnfolding _PackedString | ImpUnfolding UnfoldingGuidance (UnfoldingCoreExpr a) #-} +data InstancePragmas a {-# GHC_PRAGMA NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] #-} +data TypePragmas {-# GHC_PRAGMA NoTypePragmas | AbstractTySynonym #-} +data MonoType a {-# GHC_PRAGMA MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a) #-} +data PolyType a {-# GHC_PRAGMA UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data IdDetails {-# GHC_PRAGMA LocalId ShortName Bool | SysLocalId ShortName Bool | SpecPragmaId ShortName (Labda SpecInfo) Bool | ImportedId FullName | PreludeId FullName | TopLevId FullName | DataConId FullName Int [TyVarTemplate] [(Class, UniType)] [UniType] TyCon | TupleConId Int | SuperDictSelId Class Class | ClassOpId Class ClassOp | DefaultMethodId Class ClassOp Bool | DictFunId Class UniType Bool | ConstMethodId Class UniType ClassOp Bool | InstId Inst | SpecId Id [Labda UniType] Bool | WorkerId Id #-} +type IdEnv a = UniqFM a +data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-} +data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-} +data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-} +data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-} +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-} +data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-} +data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-} +data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-} +data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-} +data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-} +data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-} +data OverloadedLit {-# GHC_PRAGMA OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data InstTy {-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-} +data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-} +data Labda a = Hamna | Ni a +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data Provenance {-# GHC_PRAGMA ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString] #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data Delay a {-# GHC_PRAGMA MkDelay a #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data SMSpecRepKind {-# GHC_PRAGMA SpecRep | ConstantRep | CharLikeRep | IntLikeRep #-} +data SMUpdateKind {-# GHC_PRAGMA SMNormalForm | SMSingleEntry | SMUpdatable #-} +data EnclosingCcDetails {-# GHC_PRAGMA NoEnclosingCcDetails | EnclosingCC CostCentre #-} +data FormSummary {-# GHC_PRAGMA WhnfForm | BottomForm | OtherForm #-} +data IdVal {-# GHC_PRAGMA InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) #-} +data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-} +data UnfoldConApp {-# GHC_PRAGMA UCA Id [UniType] [CoreAtom Id] #-} +data UnfoldEnv {-# GHC_PRAGMA UFE (UniqFM UnfoldItem) (UniqFM Id) (FiniteMap UnfoldConApp Id) #-} +data UnfoldItem {-# GHC_PRAGMA UnfoldItem Id UnfoldingDetails EnclosingCcDetails #-} +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-} +data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-} +data TickType {-# GHC_PRAGMA UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgCaseAlternatives a b {-# GHC_PRAGMA StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) #-} +data StgCaseDefault a b {-# GHC_PRAGMA StgNoDefault | StgBindDefault a Bool (StgExpr a b) #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-} +data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +assoc :: Eq a => [Char] -> [(a, b)] -> a -> b + {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "LLSL" _N_ _SPECIALISE_ [ [Char], _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ UniType, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ PrimKind, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ } #-} +emptyBag :: Bag a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-} +snocBag :: Bag a -> a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +kindOfBasicLit :: BasicLit -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfBasicLit :: BasicLit -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cAppend :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +cCh :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +cNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +cPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +cShow :: CSeq -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +cStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} +emptyFM :: FiniteMap a b + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-} +cmpId :: Id -> Id -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +eqId :: Id -> Id -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +getIdKind :: Id -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns kindFromType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns kindFromType [ u5 ] _N_ #-} +getIdUniType :: Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_ #-} +cmpName :: Name -> Name -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqName :: Name -> Name -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +cmpByLocalName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpPString :: _PackedString -> _PackedString -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpProtoName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqByLocalName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqProtoName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUnique :: Unique -> Unique -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> 0#; False -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> -1#; False -> 1#; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +eqUnique :: Unique -> Unique -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +equivClasses :: (a -> a -> Int#) -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +hasNoDups :: Eq a => [a] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ } #-} +isIn :: Eq a => [Char] -> a -> [a] -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ _PackedString ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Class ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ BasicLit ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Unique ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +isSingleton :: [a] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isn'tIn :: Eq a => [Char] -> a -> [a] -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 0 _U_ 021 _N_ _N_ _N_ _N_ } #-} +kindFromType :: UniType -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +lengthExceeds :: [a] -> Int -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SU(P)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mapAccumB :: (b -> c -> a -> (b, c, d)) -> b -> c -> [a] -> (b, c, [d]) + {-# GHC_PRAGMA _A_ 4 _U_ 2221 _N_ _S_ "LLLS" _N_ _N_ #-} +mapAccumL :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c]) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +mapAccumR :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c]) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +mkUnknownSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +nOfThem :: Int -> a -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +naturalMergeSortLe :: (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-} +nullSpecEnv :: SpecEnv + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +panic :: [Char] -> a + {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-} +pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLS" _N_ _N_ #-} +pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-} +ppDouble :: Double -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppInt :: Int -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppInteger :: Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppNil :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppStr :: [Char] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprPanic :: [Char] -> (Int -> Bool -> PrettyRep) -> a + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ _!_ _N_ _N_ #-} +pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +pprTrace :: [Char] -> (Int -> Bool -> PrettyRep) -> a -> a + {-# GHC_PRAGMA _A_ 2 _U_ 112 _N_ _N_ _N_ _N_ #-} +switchIsOn :: (a -> SwitchResult) -> a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +typeOfPat :: TypecheckedPat -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +tagOf_PrimOp :: PrimOp -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-} +pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +removeDups :: (a -> a -> Int#) -> [a] -> ([a], [[a]]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +runs :: (a -> a -> Bool) -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +showUnique :: Unique -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +sortLt :: (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +zipEqual :: [a] -> [b] -> [(a, b)] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs new file mode 100644 index 0000000000..7f0d40680b --- /dev/null +++ b/ghc/compiler/utils/Util.lhs @@ -0,0 +1,1056 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Util]{Highly random utility functions} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +# define IF_NOT_GHC(a) {--} +#else +# define panic error +# define TAG_ _CMP_TAG +# define LT_ _LT +# define EQ_ _EQ +# define GT_ _GT +# define GT__ _ +# define tagCmp_ _tagCmp +# define FAST_STRING String +# define ASSERT(x) {-nothing-} +# define IF_NOT_GHC(a) a +# define COMMA , +#endif + +#ifndef __GLASGOW_HASKELL__ +# undef TAG_ +# undef LT_ +# undef EQ_ +# undef GT_ +# undef tagCmp_ +#endif + +module Util ( + -- Haskell-version support +#ifndef __GLASGOW_HASKELL__ + tagCmp_, + TAG_(..), +#endif + -- general list processing + IF_NOT_GHC(forall COMMA exists COMMA) + zipEqual, nOfThem, lengthExceeds, isSingleton, +#if defined(COMPILING_GHC) + isIn, isn'tIn, +#endif + + -- association lists + assoc, +#ifdef USE_SEMANTIQUE_STRANAL + clookup, clookrepl, elemIndex, (\\\), +#endif + + -- duplicate handling + hasNoDups, equivClasses, runs, removeDups, + + -- sorting + IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) + sortLt, + IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten + IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA) + + -- transitive closures + transitiveClosure, + + -- accumulating + mapAccumL, mapAccumR, mapAccumB, + + -- comparisons + IF_NOT_GHC(cmpString COMMA) +#ifdef USE_FAST_STRINGS + cmpPString, +#else + substr, +#endif + -- pairs + IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) + IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) + unzipWith + + -- error handling +#if defined(COMPILING_GHC) + , panic, pprPanic, pprTrace +# ifdef DEBUG + , assertPanic +# endif +#endif {- COMPILING_GHC -} + + -- and to make the interface self-sufficient... +#if __HASKELL1__ < 3 +# if defined(COMPILING_GHC) + , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..) +# else + , Maybe +# endif +#endif + +#ifdef USE_ATTACK_PRAGMAS + -- as more-or-less of a *HACK*, Util exports + -- many types abstractly, so that pragmas will be + -- able to see them (given that most modules + -- import Util). + , + AbstractC, + ArgUsage, + ArgUsageInfo, + ArithSeqInfo, + ArityInfo, + Bag, + BasicLit, + Bind, + BinderInfo, + Binds, + CAddrMode, + CExprMacro, + CLabel, + CSeq, + CStmtMacro, + CcKind, + Class, + ClassDecl, + ClassOp, + ClassOpPragmas, + ClassPragmas, + ClosureInfo, + ConDecl, + CoreArg, + CoreAtom, + CoreBinding, + CoreCaseAlternatives, + CoreCaseDefault, + CoreExpr, + CostCentre, + DataPragmas, + DataTypeSig, + DefaultDecl, + DeforestInfo, + Delay, + Demand, + DemandInfo, + DuplicationDanger, + EnclosingCcDetails, + EndOfBlockInfo, + ExportFlag, + Expr, + FBConsum, + FBProd, + FBType, + FBTypeInfo, + FiniteMap, + FixityDecl, + FormSummary, + FullName, + FunOrArg, + GRHS, + GRHSsAndBinds, + GenPragmas, + GlobalSwitch, + HeapOffset, + IE, + Id, + IdDetails, + IdEnv(..), -- UGH + IdInfo, + IdVal, + IfaceImportDecl, + ImpStrictness, + ImpUnfolding, + ImportedInterface, + InPat, + InsideSCC, + Inst, + InstDecl, + InstOrigin, + InstTemplate, + InstTy, + InstancePragmas, + Interface, + IsDupdCC, IsCafCC, + LambdaFormInfo, + Literal, + MagicId, + MagicUnfoldingFun, + Match, + Module, + MonoBinds, + MonoType, + Name, + NamedThing(..), -- SIGH + OptIdInfo(..), -- SIGH + OrdList, + Outputable(..), -- SIGH + OverloadedLit, + PolyType, + PprStyle, + PrimKind, + PrimOp, + ProtoName, + Provenance, + Qual, + RegRelative, + Renaming, + ReturnInfo, + SMRep, + SMSpecRepKind, + SMUpdateKind, + Sequel, + ShortName, + Sig, + SimplCount, + SimplEnv, + SimplifierSwitch, + SpecEnv, + SpecInfo, + SpecialisedInstanceSig, + SplitUniqSupply, + SrcLoc, + StableLoc, + StandardFormInfo, + StgAtom, + StgBinderInfo, + StgBinding, + StgCaseAlternatives, + StgCaseDefault, + StgExpr, + StgRhs, + StrictnessInfo, + StubFlag, + SwitchResult, + TickType, + TyCon, + TyDecl, + TyVar, + TyVarEnv(..), + TyVarTemplate, + TypePragmas, + TypecheckedPat, + UfCostCentre, + UfId, + UnfoldEnv, + UnfoldItem, + UnfoldConApp, + UnfoldingCoreAlts, + UnfoldingCoreAtom, + UnfoldingCoreBinding, + UnfoldingCoreDefault, + UnfoldingCoreExpr, + UnfoldingDetails, + UnfoldingGuidance, + UnfoldingPrimOp, + UniType, + UniqFM, + Unique, + UniqueSupply, + UpdateFlag, + UpdateInfo, + VolatileLoc, + +#if ! OMIT_NATIVE_CODEGEN + Reg, + CodeSegment, + RegLoc, + StixReg, + StixTree, +#endif + + getIdUniType, typeOfBasicLit, typeOfPat, + getIdKind, kindOfBasicLit, + kindFromType, + + eqId, cmpId, + eqName, cmpName, + cmpProtoName, eqProtoName, + cmpByLocalName, eqByLocalName, + eqUnique, cmpUnique, + showUnique, + + switchIsOn, + + ppNil, ppStr, ppInt, ppInteger, ppDouble, +#if __GLASGOW_HASKELL__ >= 23 + ppRational, --- ??? +#endif + cNil, cStr, cAppend, cCh, cShow, +#if __GLASGOW_HASKELL__ >= 23 + cPStr, +#endif + +-- mkBlackHoleCLabel, + + emptyBag, snocBag, + emptyFM, +--OLD: emptySet, + nullSpecEnv, + + mkUnknownSrcLoc, + + pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType, + + tagOf_PrimOp, + pprPrimOp + +#endif {-USE_ATTACK_PRAGMAS-} + ) where + +#if defined(COMPILING_GHC) +IMPORT_Trace +import Pretty +#endif +#if __HASKELL1__ < 3 +import Maybes ( Maybe(..) ) +#endif + +#if defined(COMPILING_GHC) +import Id +import IdInfo +import Outputable + +# ifdef USE_ATTACK_PRAGMAS + +import AbsCSyn +import AbsSyn +import AbsUniType +import Bag +import BasicLit +import BinderInfo +import CLabelInfo +import CgBindery +import CgMonad +import CharSeq +import ClosureInfo +import CmdLineOpts +import CoreSyn +import FiniteMap +import HsCore +import HsPragmas +import Inst +import InstEnv +import Name +import NameTypes +import OrdList +import PlainCore +import PrimOps +import ProtoName +import CostCentre +import SMRep +import SimplEnv +import SimplMonad +import SplitUniq +import SrcLoc +import StgSyn +import TyVarEnv +import UniqFM +import Unique + +# if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +import MachDesc +import Stix +# endif + +# endif {-USE_ATTACK_PRAGMAS-} + +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell} +%* * +%************************************************************************ + +This is our own idea: +\begin{code} +#ifndef __GLASGOW_HASKELL__ +data TAG_ = LT_ | EQ_ | GT_ + +tagCmp_ :: Ord a => a -> a -> TAG_ +tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_ +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-lists]{General list processing} +%* * +%************************************************************************ + +Quantifiers are not standard in Haskell. The following fill in the gap. + +\begin{code} +forall :: (a -> Bool) -> [a] -> Bool +forall pred [] = True +forall pred (x:xs) = pred x && forall pred xs + +exists :: (a -> Bool) -> [a] -> Bool +exists pred [] = False +exists pred (x:xs) = pred x || exists pred xs +\end{code} + +A paranoid @zip@ that checks the lists are of equal length. +Alastair Reid thinks this should only happen if DEBUGging on; +hey, why not? + +\begin{code} +zipEqual :: [a] -> [b] -> [(a,b)] + +#ifndef DEBUG +zipEqual a b = zip a b +#else +zipEqual [] [] = [] +zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs +zipEqual as bs = panic "zipEqual: unequal lists" +#endif +\end{code} + +\begin{code} +nOfThem :: Int -> a -> [a] +nOfThem n thing = take n (repeat thing) + +lengthExceeds :: [a] -> Int -> Bool + +[] `lengthExceeds` n = 0 > n +(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1)) + +isSingleton :: [a] -> Bool + +isSingleton [x] = True +isSingleton _ = False +\end{code} + +Debugging/specialising versions of \tr{elem} and \tr{notElem} +\begin{code} +#if defined(COMPILING_GHC) +isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool + +# ifndef DEBUG +isIn msg x ys = elem__ x ys +isn'tIn msg x ys = notElem__ x ys + +--these are here to be SPECIALIZEd (automagically) +elem__ _ [] = False +elem__ x (y:ys) = x==y || elem__ x ys + +notElem__ x [] = True +notElem__ x (y:ys) = x /= y && notElem__ x ys + +# else {- DEBUG -} +isIn msg x ys + = elem ILIT(0) x ys + where + elem i _ [] = False + elem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg) + | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys + +isn'tIn msg x ys + = notElem ILIT(0) x ys + where + notElem i x [] = True + notElem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg) + | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys + +# endif {- DEBUG -} + +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-} +{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +# endif + +#endif {- COMPILING_GHC -} +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-assoc]{Association lists} +%* * +%************************************************************************ + +See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@. + +\begin{code} +assoc :: (Eq a) => String -> [(a, b)] -> a -> b + +assoc crash_msg lst key + = if (null res) + then panic ("Failed in assoc: " ++ crash_msg) + else head res + where res = [ val | (key', val) <- lst, key == key'] + +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-} +{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-} +{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-} +{-# SPECIALIZE assoc :: String -> [(PrimKind, a)] -> PrimKind -> a #-} +{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-} +{-# SPECIALIZE assoc :: String -> [(UniType, a)] -> UniType -> a #-} +{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-} +# endif +#endif +\end{code} + +Given a list of associations one wants to look for the most recent +association for a given key. A couple of functions follow that cover +the simple lookup, the lookup with a default value when the key not +found, and two corresponding functions operating on unzipped lists +of associations. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +clookup :: (Eq a) => [a] -> [b] -> a -> b +clookup = clookupElse (panic "clookup") + where + -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b + clookupElse d [] [] a = d + clookupElse d (x:xs) (y:ys) a + | a==x = y + | True = clookupElse d xs ys a +#endif +\end{code} + +The following routine given a curried environment replaces the entry +labelled with a given name with a new value given. The new value is +given in the form of a function that allows to transform the old entry. + +Assumption is that the list of labels contains the given one and that +the two lists of the curried environment are of equal lengths. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b] +clookrepl (a:as) (b:bs) x f + = if x == a then (f b:bs) else (b:clookrepl as bs x f) +#endif +\end{code} + +The following returns the index of an element in a list. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +elemIndex :: Eq a => [a] -> a -> Int +elemIndex as x = indx as x 0 + where + indx :: Eq a => [a] -> a -> Int -> Int + indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int) +# if defined(COMPILING_GHC) + indx [] x n = pprPanic "element not in list in elemIndex" ppNil +# else + indx [] x n = error "element not in list in elemIndex" +# endif +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-dups]{Duplicate-handling} +%* * +%************************************************************************ + +List difference (non-associative). In the result of @xs \\\ ys@, the +first occurrence of each element of ys in turn (if any) has been +removed from xs. Thus, @(xs ++ ys) \\\ xs == ys@. This function is +a copy of @\\@ from report 1.1 and is added to overshade the buggy +version from the 1.0 version of Haskell. + +This routine can be removed after the compiler bootstraps itself and +a proper @\\@ is can be applied. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) = foldl del + where + [] `del` _ = [] + (x:xs) `del` y + | x == y = xs + | otherwise = x : xs `del` y +#endif +\end{code} + +\begin{code} +hasNoDups :: (Eq a) => [a] -> Bool +hasNoDups xs = f [] xs + where + f seen_so_far [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far then + False + else + f (x:seen_so_far) xs + +#if defined(COMPILING_GHC) + is_elem = isIn "hasNoDups" +#else + is_elem = elem +#endif +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-} +# endif +#endif +\end{code} + +\begin{code} +equivClasses :: (a -> a -> TAG_) -- Comparison + -> [a] + -> [[a]] + +equivClasses cmp stuff@[] = [] +equivClasses cmp stuff@[item] = [stuff] +equivClasses cmp items + = runs eq (sortLt lt items) + where + eq a b = case cmp a b of { EQ_ -> True; _ -> False } + lt a b = case cmp a b of { LT_ -> True; _ -> False } +\end{code} + +The first cases in @equivClasses@ above are just to cut to the point +more quickly... + +@runs@ groups a list into a list of lists, each sublist being a run of +identical elements of the input list. It is passed a predicate @p@ which +tells when two elements are equal. + +\begin{code} +runs :: (a -> a -> Bool) -- Equality + -> [a] + -> [[a]] + +runs p [] = [] +runs p (x:xs) = case (span (p x) xs) of + (first, rest) -> (x:first) : (runs p rest) +\end{code} + +\begin{code} +removeDups :: (a -> a -> TAG_) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [[a]]) -- List of duplicate groups. One representative from + -- each group appears in the first result + +removeDups cmp [] = ([], []) +removeDups cmp [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups dups_so_far [x] = (dups_so_far, x) + collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-sorting]{Sorting} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection[Utils-quicksorting]{Quicksorts} +%* * +%************************************************************************ + +\begin{code} +-- tail-recursive, etc., "quicker sort" [as per Meira thesis] +quicksort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list in increasing order + +quicksort lt [] = [] +quicksort lt [x] = [x] +quicksort lt (x:xs) = split x [] [] xs + where + split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) + split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys + | True = split x lo (y:hi) ys +\end{code} + +Quicksort variant from Lennart's Haskell-library contribution. This +is a {\em stable} sort. + +\begin{code} +stableSortLt = sortLt -- synonym; when we want to highlight stable-ness + +sortLt :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list + +sortLt lt l = qsort lt l [] + +-- qsort is stable and does not concatenate. +qsort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- xs, Input list + -> [a] -- r, Concatenate this list to the sorted input list + -> [a] -- Result = sort xs ++ r + +qsort lt [] r = r +qsort lt [x] r = x:r +qsort lt (x:xs) r = qpart lt x xs [] [] r + +-- qpart partitions and sorts the sublists +-- rlt contains things less than x, +-- rge contains the ones greater than or equal to x. +-- Both have equal elements reversed with respect to the original list. + +qpart lt x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort lt rlt (x : rqsort lt rge r) + +qpart lt x (y:ys) rlt rge r = + if lt y x then + -- y < x + qpart lt x ys (y:rlt) rge r + else + -- y >= x + qpart lt x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort lt [] r = r +rqsort lt [x] r = x:r +rqsort lt (x:xs) r = rqpart lt x xs [] [] r + +rqpart lt x [] rle rgt r = + qsort lt rle (x : qsort lt rgt r) + +rqpart lt x (y:ys) rle rgt r = + if lt x y then + -- y > x + rqpart lt x ys rle (y:rgt) r + else + -- y <= x + rqpart lt x ys (y:rle) rgt r +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-dull-mergesort]{A rather dull mergesort} +%* * +%************************************************************************ + +\begin{code} +mergesort :: (a -> a -> TAG_) -> [a] -> [a] + +mergesort cmp xs = merge_lists (split_into_runs [] xs) + where + a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + + split_into_runs [] [] = [] + split_into_runs run [] = [run] + split_into_runs [] (x:xs) = split_into_runs [x] xs + split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs + split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs + | True = rl : (split_into_runs [x] xs) + + merge_lists [] = [] + merge_lists (x:xs) = merge x (merge_lists xs) + + merge [] ys = ys + merge xs [] = xs + merge xl@(x:xs) yl@(y:ys) + = case cmp x y of + EQ_ -> x : y : (merge xs ys) + LT_ -> x : (merge xs yl) + GT__ -> y : (merge xl ys) +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} +%* * +%************************************************************************ + +\begin{display} +Date: Mon, 3 May 93 20:45:23 +0200 +From: Carsten Kehler Holst <kehler@cs.chalmers.se> +To: partain@dcs.gla.ac.uk +Subject: natural merge sort beats quick sort [ and it is prettier ] + + Here a piece of Haskell code that I'm rather fond of. See it as an +attempt to get rid of the ridiculous quick-sort rutine. group is quite +useful by itself I think it was John's idea originally though I +believe the lazy version is due to me [surprisingly complicated]. +gamma [used to be called] called gamma because I got inspired by the Gamma calculus. It +is not very close to the calculus but does behave less sequential that +both foldr and foldl. One could imagine a version of gamma that took a +unit element as well thereby avoiding the problem with empty lists. + +I've tried this code against + + 1) insertion sort - as provided by haskell + 2) the normal implementation of quick sort + 3) a deforested version of quick sort due to Jan Sparud + 4) a super-optimized-quick-sort of Lennarts + +If the list is partially sorted both merge sort and in particular +natural merge sort wins. If the list is random [ average length of +rising subsequences = approx 2 ] mergesort still wins and natural +merge sort is marginally beeten by lennart's soqs. The space +consumption of merge sort is a bit worse than Lennarts quick sort +approx a factor of 2. And a lot worse if Sparud's bug-fix [see his +fpca article ] isn't used because of group. + +have fun +Carsten +\end{display} + +\begin{code} +group :: (a -> a -> Bool) -> [a] -> [[a]] +group p [] = [[]] +group p (x:xs) = + let ((h1:t1):tt1) = group p xs + (t,tt) = if null xs then ([],[]) else + if x `p` h1 then (h1:t1,tt1) else + ([], (h1:t1):tt1) + in ((x:t):tt) + +generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] +generalMerge p xs [] = xs +generalMerge p [] ys = ys +generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) + | y `p` x = y : generalMerge p (x:xs) ys + +-- gamma is now called balancedFold + +balancedFold :: (a -> a -> a) -> [a] -> a +balancedFold f [] = error "can't reduce an empty list using balancedFold" +balancedFold f [x] = x +balancedFold f l = balancedFold f (balancedFold' f l) + +balancedFold' :: (a -> a -> a) -> [a] -> [a] +balancedFold' f (x:y:xs) = f x y : balancedFold' f xs +balancedFold' f xs = xs + +generalMergeSort p = balancedFold (generalMerge p) . map (:[]) +generalNaturalMergeSort p = balancedFold (generalMerge p) . group p + +mergeSort, naturalMergeSort :: Ord a => [a] -> [a] + +mergeSort = generalMergeSort (<=) +naturalMergeSort = generalNaturalMergeSort (<=) + +mergeSortLe le = generalMergeSort le +naturalMergeSortLe le = generalNaturalMergeSort le +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-transitive-closure]{Transitive closure} +%* * +%************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. + +\begin{code} +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = do [] xs + where + do done [] = done + do done (x:xs) | x `is_in` done = do done xs + | otherwise = do (x:done) (succ x ++ xs) + + x `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-accum]{Accumulating} +%* * +%************************************************************************ + +@mapAccumL@ behaves like a combination +of @map@ and @foldl@; +it applies a function to each element of a list, passing an accumulating +parameter from left to right, and returning a final value of this +accumulator together with the new list. + +\begin{code} +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumL f b [] = (b, []) +mapAccumL f b (x:xs) = (b'', x':xs') where + (b', x') = f b x + (b'', xs') = mapAccumL f b' xs +\end{code} + +@mapAccumR@ does the same, but working from right to left instead. Its type is +the same as @mapAccumL@, though. + +\begin{code} +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumR f b [] = (b, []) +mapAccumR f b (x:xs) = (b'', x':xs') where + (b'', x') = f b' x + (b', xs') = mapAccumR f b xs +\end{code} + +Here is the bi-directional version, that works from both left and right. + +\begin{code} +mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) + -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> accl -- Initial accumulator from left + -> accr -- Initial accumulator from right + -> [x] -- Input list + -> (accl, accr, [y]) -- Final accumulators and result list + +mapAccumB f a b [] = (a,b,[]) +mapAccumB f a b (x:xs) = (a'',b'',y:ys) + where + (a',b'',y) = f a b' x + (a'',b',ys) = mapAccumB f a' b xs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-comparison]{Comparisons} +%* * +%************************************************************************ + +See also @tagCmp_@ near the versions-compatibility section. + +\begin{code} +cmpString :: String -> String -> TAG_ + +cmpString [] [] = EQ_ +cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys + else if x < y then LT_ + else GT_ +cmpString [] ys = LT_ +cmpString xs [] = GT_ + +cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here + cmpString s "" -- will never get here + } +\end{code} + +\begin{code} +#ifdef USE_FAST_STRINGS +cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ + +cmpPString x y + = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } +#endif +\end{code} + +\begin{code} +#ifndef USE_FAST_STRINGS +substr :: FAST_STRING -> Int -> Int -> FAST_STRING + +substr str beg end + = ASSERT (beg >= 0 && beg <= end) + take (end - beg + 1) (drop beg str) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-pairs]{Pairs} +%* * +%************************************************************************ + +The following are curried versions of @fst@ and @snd@. + +\begin{code} +cfst :: a -> b -> a -- stranal-sem only (Note) +cfst x y = x +\end{code} + +The following provide us higher order functions that, when applied +to a function, operate on pairs. + +\begin{code} +applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) +applyToPair (f,g) (x,y) = (f x, g y) + +applyToFst :: (a -> c) -> (a,b)-> (c,b) +applyToFst f (x,y) = (f x,y) + +applyToSnd :: (b -> d) -> (a,b) -> (a,d) +applyToSnd f (x,y) = (x,f y) + +foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) +foldPair fg ab [] = ab +foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) + where (u,v) = foldPair fg ab abs +\end{code} + +\begin{code} +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-errors]{Error handling} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) +panic x = error ("panic! (the `impossible' happened):\n\t" + ++ x ++ "\n\n" + ++ "Please report it as a compiler bug " + ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" ) + +pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) + +pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg)) + +# ifdef DEBUG +assertPanic :: String -> Int -> a +assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line) +# endif +#endif {- COMPILING_GHC -} +\end{code} |