X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FUnique.lhs;h=44a06129de8dec7faac4be16b32523c90b20215e;hb=33362962fa2c0cccee533b6cbe36f5cd2b049c8a;hp=953f435214b462656c37ce3a9f6a04f7d803a53e;hpb=9d4c03805bafb6b1e1d47306b6a6c591c998e517;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 953f435..44a0612 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -16,12 +16,8 @@ Some of the other hair in this code is to be able to use a Haskell). \begin{code} -#include "HsVersions.h" - --- UniqSupply - module Unique ( - Unique, + Unique, Uniquable(..), u2i, -- hack: used in UniqFM pprUnique, pprUnique10, showUnique, @@ -30,7 +26,8 @@ module Unique ( mkUniqueGrimily, -- Used in UniqSupply only! incrUnique, -- Used for renumbering - initRenumberingUniques, + initTyVarUnique, mkTyVarUnique, + initTidyUniques, -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] @@ -87,6 +84,7 @@ module Unique ( foreignObjTyConKey, forkIdKey, fractionalClassKey, + fromEnumClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey, @@ -94,7 +92,6 @@ module Unique ( functorClassKey, geClassOpKey, gtDataConKey, - iOTyConKey, intDataConKey, intPrimTyConKey, intTyConKey, @@ -112,26 +109,25 @@ module Unique ( liftTyConKey, listTyConKey, ltDataConKey, - mainIdKey, - mainPrimIOIdKey, + mainKey, + minusClassOpKey, monadClassKey, monadPlusClassKey, monadZeroClassKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, nilDataConKey, - noDefaultMethodErrorIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - nonExplicitMethodErrorIdKey, notIdKey, numClassKey, ordClassKey, orderingTyConKey, + otherwiseIdKey, packCStringIdKey, parErrorIdKey, parIdKey, patErrorIdKey, - primIoTyConKey, ratioDataConKey, ratioTyConKey, rationalTyConKey, @@ -148,7 +144,7 @@ module Unique ( return2GMPsTyConKey, returnIntAndGMPDataConKey, returnIntAndGMPTyConKey, - runSTIdKey, + returnMClassOpKey, seqIdKey, showClassKey, showParenIdKey, @@ -156,6 +152,11 @@ module Unique ( showStringIdKey, stTyConKey, stDataConKey, + ioTyConKey, + ioDataConKey, + ioResultTyConKey, + ioOkDataConKey, + ioFailDataConKey, stablePtrDataConKey, stablePtrPrimTyConKey, stablePtrTyConKey, @@ -188,10 +189,13 @@ module Unique ( stateAndWordPrimDataConKey, stateAndWordPrimTyConKey, stateDataConKey, + stRetDataConKey, statePrimTyConKey, stateTyConKey, + stRetTyConKey, synchVarPrimTyConKey, thenMClassOpKey, + toEnumClassOpKey, traceIdKey, trueDataConKey, unpackCString2IdKey, @@ -214,13 +218,20 @@ module Unique ( , parAtRelIdKey , parGlobalIdKey , parLocalIdKey + , unboundKey + , byteArrayTyConKey + , mutableByteArrayTyConKey + , allClassKey ) where -import PreludeGlaST +#include "HsVersions.h" -IMP_Ubiq(){-uitous-} +import FastString ( uniqueOfFS ) +import GlaExts +import ST +import PrelBase ( Char(..), chr, ord ) -import Pretty +import Outputable import Util \end{code} @@ -234,9 +245,11 @@ The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. Fast comparison is everything on @Uniques@: \begin{code} -u2i :: Unique -> FAST_INT - data Unique = MkUnique Int# +\end{code} + +\begin{code} +u2i :: Unique -> FAST_INT u2i (MkUnique i) = i \end{code} @@ -279,6 +292,26 @@ unpkUnique (MkUnique u) shiftr x y = shiftRA# x y \end{code} + + +%************************************************************************ +%* * +\subsection[Uniquable-class]{The @Uniquable@ class} +%* * +%************************************************************************ + +\begin{code} +class Uniquable a where + uniqueOf :: a -> Unique + +instance Uniquable FastString where + uniqueOf fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + uniqueOf (I# i#) = mkUniqueGrimily i# +\end{code} + + %************************************************************************ %* * \subsection[Unique-instances]{Instance declarations for @Unique@} @@ -295,7 +328,7 @@ ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 cmpUnique (MkUnique u1) (MkUnique u2) - = if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_ + = if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT instance Eq Unique where a == b = eqUnique a b @@ -306,10 +339,7 @@ instance Ord Unique where a <= b = leUnique a b a > b = not (leUnique a b) a >= b = not (ltUnique a b) - _tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 Unique where - cmp = cmpUnique + compare a b = cmpUnique a b ----------------- instance Uniquable Unique where @@ -318,7 +348,7 @@ instance Uniquable Unique where We do sometimes make strings with @Uniques@ in them: \begin{code} -pprUnique, pprUnique10 :: Unique -> Pretty +pprUnique, pprUnique10 :: Unique -> SDoc pprUnique uniq = case unpkUnique uniq of @@ -326,30 +356,22 @@ pprUnique uniq pprUnique10 uniq -- in base-10, dudes = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (ppInt u) - -finish_ppr tag u pp_u - = if tag /= 't' -- this is just to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - then pp_all - else case u of - 1 -> ppChar 'a' - 2 -> ppChar 'b' - 3 -> ppChar 'c' - 4 -> ppChar 'd' - 5 -> ppChar 'e' - _ -> pp_all - where - pp_all = ppBeside (ppChar tag) pp_u + (tag, u) -> finish_ppr tag u (int u) + +finish_ppr 't' u pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + char (chr (ord 'a' + u)) +finish_ppr tag u pp_u = char tag <> pp_u -showUnique :: Unique -> FAST_STRING -showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq)) +showUnique :: Unique -> String +showUnique uniq = showSDoc (pprUnique uniq) instance Outputable Unique where - ppr sty u = pprUnique u + ppr u = pprUnique u instance Text Unique where - showsPrec p uniq rest = _UNPK_ (showUnique uniq) + showsPrec p uniq rest = showUnique uniq \end{code} %************************************************************************ @@ -362,21 +384,13 @@ A character-stingy way to read/write numbers (notably Uniques). The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. Code stolen from Lennart. \begin{code} -#if __GLASGOW_HASKELL__ >= 200 -# define BYTE_ARRAY GHCbase.ByteArray -# define RUN_ST GHCbase.runST +# define BYTE_ARRAY GlaExts.ByteArray +# define RUN_ST ST.runST # define AND_THEN >>= # define AND_THEN_ >> # define RETURN return -#else -# define BYTE_ARRAY _ByteArray -# define RUN_ST _runST -# define AND_THEN `thenStrictlyST` -# define AND_THEN_ `seqStrictlyST` -# define RETURN returnStrictlyST -#endif -iToBase62 :: Int -> Pretty +iToBase62 :: Int -> SDoc iToBase62 n@(I# n#) = ASSERT(n >= 0) @@ -385,11 +399,11 @@ iToBase62 n@(I# n#) in if n# <# 62# then case (indexCharArray# bytes n#) of { c -> - ppChar (C# c) } + char (C# c) } else case (quotRem n 62) of { (q, I# r#) -> case (indexCharArray# bytes r#) of { c -> - ppBeside (iToBase62 q) (ppChar (C# c)) }} + (<>) (iToBase62 q) (char (C# c)) }} -- keep this at top level! (bug on 94/10/24 WDP) chars62 :: BYTE_ARRAY Int @@ -436,7 +450,17 @@ mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels) mkPrimOpIdUnique op = mkUnique '7' op mkPreludeMiscIdUnique i = mkUnique '8' i -initRenumberingUniques = (mkUnique 'v' 1, mkUnique 't' 1, mkUnique 'u' 1) +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkTyVarUnique :: Int -> Unique +mkTyVarUnique n = mkUnique 't' n + +initTidyUniques :: (Unique, Unique) -- Global and local +initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0) mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, mkBuiltinUnique :: Int -> Unique @@ -480,6 +504,7 @@ cCallableClassKey = mkPreludeClassUnique 19 cReturnableClassKey = mkPreludeClassUnique 20 ixClassKey = mkPreludeClassUnique 21 +allClassKey = mkPreludeClassUnique 22 -- Pseudo class used for universal quantification \end{code} %************************************************************************ @@ -501,48 +526,49 @@ doubleTyConKey = mkPreludeTyConUnique 10 floatPrimTyConKey = mkPreludeTyConUnique 11 floatTyConKey = mkPreludeTyConUnique 12 funTyConKey = mkPreludeTyConUnique 13 -iOTyConKey = mkPreludeTyConUnique 14 -intPrimTyConKey = mkPreludeTyConUnique 15 -intTyConKey = mkPreludeTyConUnique 16 -integerTyConKey = mkPreludeTyConUnique 17 -liftTyConKey = mkPreludeTyConUnique 18 -listTyConKey = mkPreludeTyConUnique 19 -foreignObjPrimTyConKey = mkPreludeTyConUnique 20 -foreignObjTyConKey = mkPreludeTyConUnique 21 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 22 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 23 -orderingTyConKey = mkPreludeTyConUnique 24 -synchVarPrimTyConKey = mkPreludeTyConUnique 25 -ratioTyConKey = mkPreludeTyConUnique 26 -rationalTyConKey = mkPreludeTyConUnique 27 -realWorldTyConKey = mkPreludeTyConUnique 28 -return2GMPsTyConKey = mkPreludeTyConUnique 29 -returnIntAndGMPTyConKey = mkPreludeTyConUnique 30 -stablePtrPrimTyConKey = mkPreludeTyConUnique 31 -stablePtrTyConKey = mkPreludeTyConUnique 32 -stateAndAddrPrimTyConKey = mkPreludeTyConUnique 33 -stateAndArrayPrimTyConKey = mkPreludeTyConUnique 34 -stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 35 -stateAndCharPrimTyConKey = mkPreludeTyConUnique 36 -stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37 -stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38 -stateAndIntPrimTyConKey = mkPreludeTyConUnique 39 -stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 40 -stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41 -stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42 -stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43 -stateAndPtrPrimTyConKey = mkPreludeTyConUnique 44 -stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45 -stateAndWordPrimTyConKey = mkPreludeTyConUnique 46 -statePrimTyConKey = mkPreludeTyConUnique 47 -stateTyConKey = mkPreludeTyConUnique 48 - -- 49 is spare -stTyConKey = mkPreludeTyConUnique 50 -primIoTyConKey = mkPreludeTyConUnique 51 - -- 52 is spare -wordPrimTyConKey = mkPreludeTyConUnique 53 -wordTyConKey = mkPreludeTyConUnique 54 -voidTyConKey = mkPreludeTyConUnique 55 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +integerTyConKey = mkPreludeTyConUnique 16 +liftTyConKey = mkPreludeTyConUnique 17 +listTyConKey = mkPreludeTyConUnique 18 +foreignObjPrimTyConKey = mkPreludeTyConUnique 19 +foreignObjTyConKey = mkPreludeTyConUnique 20 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 21 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 22 +orderingTyConKey = mkPreludeTyConUnique 23 +synchVarPrimTyConKey = mkPreludeTyConUnique 24 +ratioTyConKey = mkPreludeTyConUnique 25 +rationalTyConKey = mkPreludeTyConUnique 26 +realWorldTyConKey = mkPreludeTyConUnique 27 +return2GMPsTyConKey = mkPreludeTyConUnique 28 +returnIntAndGMPTyConKey = mkPreludeTyConUnique 29 +stablePtrPrimTyConKey = mkPreludeTyConUnique 30 +stablePtrTyConKey = mkPreludeTyConUnique 31 +stateAndAddrPrimTyConKey = mkPreludeTyConUnique 32 +stateAndArrayPrimTyConKey = mkPreludeTyConUnique 33 +stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 34 +stateAndCharPrimTyConKey = mkPreludeTyConUnique 35 +stateAndDoublePrimTyConKey = mkPreludeTyConUnique 36 +stateAndFloatPrimTyConKey = mkPreludeTyConUnique 37 +stateAndIntPrimTyConKey = mkPreludeTyConUnique 38 +stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 39 +stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 40 +stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 41 +stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 42 +stateAndPtrPrimTyConKey = mkPreludeTyConUnique 43 +stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 44 +stateAndWordPrimTyConKey = mkPreludeTyConUnique 45 +statePrimTyConKey = mkPreludeTyConUnique 46 +stateTyConKey = mkPreludeTyConUnique 47 +mutableByteArrayTyConKey = mkPreludeTyConUnique 48 +stTyConKey = mkPreludeTyConUnique 49 +stRetTyConKey = mkPreludeTyConUnique 50 +ioTyConKey = mkPreludeTyConUnique 51 +ioResultTyConKey = mkPreludeTyConUnique 52 +byteArrayTyConKey = mkPreludeTyConUnique 53 +wordPrimTyConKey = mkPreludeTyConUnique 54 +wordTyConKey = mkPreludeTyConUnique 55 +voidTyConKey = mkPreludeTyConUnique 56 \end{code} %************************************************************************ @@ -589,6 +615,10 @@ stateDataConKey = mkPreludeDataConUnique 39 trueDataConKey = mkPreludeDataConUnique 40 wordDataConKey = mkPreludeDataConUnique 41 stDataConKey = mkPreludeDataConUnique 42 +stRetDataConKey = mkPreludeDataConUnique 43 +ioDataConKey = mkPreludeDataConUnique 44 +ioOkDataConKey = mkPreludeDataConUnique 45 +ioFailDataConKey = mkPreludeDataConUnique 46 \end{code} %************************************************************************ @@ -608,64 +638,68 @@ errorIdKey = mkPreludeMiscIdUnique 7 foldlIdKey = mkPreludeMiscIdUnique 8 foldrIdKey = mkPreludeMiscIdUnique 9 forkIdKey = mkPreludeMiscIdUnique 10 -int2IntegerIdKey = mkPreludeMiscIdUnique 11 integerMinusOneIdKey = mkPreludeMiscIdUnique 12 integerPlusOneIdKey = mkPreludeMiscIdUnique 13 integerPlusTwoIdKey = mkPreludeMiscIdUnique 14 integerZeroIdKey = mkPreludeMiscIdUnique 15 irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 lexIdKey = mkPreludeMiscIdUnique 17 -mainIdKey = mkPreludeMiscIdUnique 18 -mainPrimIOIdKey = mkPreludeMiscIdUnique 19 -noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 20 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21 -nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22 -notIdKey = mkPreludeMiscIdUnique 23 -packCStringIdKey = mkPreludeMiscIdUnique 24 -parErrorIdKey = mkPreludeMiscIdUnique 25 -parIdKey = mkPreludeMiscIdUnique 26 -patErrorIdKey = mkPreludeMiscIdUnique 27 -readParenIdKey = mkPreludeMiscIdUnique 28 -realWorldPrimIdKey = mkPreludeMiscIdUnique 29 -recConErrorIdKey = mkPreludeMiscIdUnique 30 -recUpdErrorIdKey = mkPreludeMiscIdUnique 31 -runSTIdKey = mkPreludeMiscIdUnique 32 -seqIdKey = mkPreludeMiscIdUnique 33 -showParenIdKey = mkPreludeMiscIdUnique 34 -showSpaceIdKey = mkPreludeMiscIdUnique 35 -showStringIdKey = mkPreludeMiscIdUnique 36 -traceIdKey = mkPreludeMiscIdUnique 37 -unpackCString2IdKey = mkPreludeMiscIdUnique 38 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 39 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 40 -unpackCStringIdKey = mkPreludeMiscIdUnique 41 -voidIdKey = mkPreludeMiscIdUnique 42 -ushowListIdKey = mkPreludeMiscIdUnique 43 -ureadListIdKey = mkPreludeMiscIdUnique 44 - -copyableIdKey = mkPreludeMiscIdUnique 45 -noFollowIdKey = mkPreludeMiscIdUnique 46 -parAtAbsIdKey = mkPreludeMiscIdUnique 47 -parAtForNowIdKey = mkPreludeMiscIdUnique 48 -parAtIdKey = mkPreludeMiscIdUnique 49 -parAtRelIdKey = mkPreludeMiscIdUnique 50 -parGlobalIdKey = mkPreludeMiscIdUnique 51 -parLocalIdKey = mkPreludeMiscIdUnique 52 +notIdKey = mkPreludeMiscIdUnique 22 +packCStringIdKey = mkPreludeMiscIdUnique 23 +parErrorIdKey = mkPreludeMiscIdUnique 24 +parIdKey = mkPreludeMiscIdUnique 25 +patErrorIdKey = mkPreludeMiscIdUnique 26 +readParenIdKey = mkPreludeMiscIdUnique 27 +realWorldPrimIdKey = mkPreludeMiscIdUnique 28 +recConErrorIdKey = mkPreludeMiscIdUnique 29 +recUpdErrorIdKey = mkPreludeMiscIdUnique 30 +seqIdKey = mkPreludeMiscIdUnique 31 +showParenIdKey = mkPreludeMiscIdUnique 32 +showSpaceIdKey = mkPreludeMiscIdUnique 33 +showStringIdKey = mkPreludeMiscIdUnique 34 +traceIdKey = mkPreludeMiscIdUnique 35 +unpackCString2IdKey = mkPreludeMiscIdUnique 36 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 37 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 38 +unpackCStringIdKey = mkPreludeMiscIdUnique 39 +voidIdKey = mkPreludeMiscIdUnique 40 +ushowListIdKey = mkPreludeMiscIdUnique 41 +ureadListIdKey = mkPreludeMiscIdUnique 42 + +copyableIdKey = mkPreludeMiscIdUnique 43 +noFollowIdKey = mkPreludeMiscIdUnique 44 +parAtAbsIdKey = mkPreludeMiscIdUnique 45 +parAtForNowIdKey = mkPreludeMiscIdUnique 46 +parAtIdKey = mkPreludeMiscIdUnique 47 +parAtRelIdKey = mkPreludeMiscIdUnique 48 +parGlobalIdKey = mkPreludeMiscIdUnique 49 +parLocalIdKey = mkPreludeMiscIdUnique 50 \end{code} Certain class operations from Prelude classes. They get their own uniques so we can look them up easily when we want to conjure them up during type checking. \begin{code} -fromIntClassOpKey = mkPreludeMiscIdUnique 53 -fromIntegerClassOpKey = mkPreludeMiscIdUnique 54 -fromRationalClassOpKey = mkPreludeMiscIdUnique 55 -enumFromClassOpKey = mkPreludeMiscIdUnique 56 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 57 -enumFromToClassOpKey = mkPreludeMiscIdUnique 58 -enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59 -eqClassOpKey = mkPreludeMiscIdUnique 60 -geClassOpKey = mkPreludeMiscIdUnique 61 -zeroClassOpKey = mkPreludeMiscIdUnique 62 -thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=) +fromIntClassOpKey = mkPreludeMiscIdUnique 51 +fromIntegerClassOpKey = mkPreludeMiscIdUnique 52 +minusClassOpKey = mkPreludeMiscIdUnique 53 +fromRationalClassOpKey = mkPreludeMiscIdUnique 54 +enumFromClassOpKey = mkPreludeMiscIdUnique 55 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 56 +enumFromToClassOpKey = mkPreludeMiscIdUnique 57 +enumFromThenToClassOpKey= mkPreludeMiscIdUnique 58 +eqClassOpKey = mkPreludeMiscIdUnique 59 +geClassOpKey = mkPreludeMiscIdUnique 60 +zeroClassOpKey = mkPreludeMiscIdUnique 61 +thenMClassOpKey = mkPreludeMiscIdUnique 62 -- (>>=) +unboundKey = mkPreludeMiscIdUnique 63 -- Just a place holder for unbound + -- variables produced by the renamer +fromEnumClassOpKey = mkPreludeMiscIdUnique 64 + +mainKey = mkPreludeMiscIdUnique 65 +returnMClassOpKey = mkPreludeMiscIdUnique 66 +otherwiseIdKey = mkPreludeMiscIdUnique 67 +toEnumClassOpKey = mkPreludeMiscIdUnique 68 \end{code}