{-# LANGUAGE CPP #-}

-- | This is where we define a mapping from Uniques to their associated
-- known-key Names for things associated with tuples and sums. We use this
-- mapping while deserializing known-key Names in interface file symbol tables,
-- which are encoded as their Unique. See Note [Symbol table representation of
-- names] for details.
--

module KnownUniques
    ( -- * Looking up known-key names
      knownUniqueName

      -- * Getting the 'Unique's of 'Name's
      -- ** Anonymous sums
    , mkSumTyConUnique
    , mkSumDataConUnique
      -- ** Tuples
      -- *** Vanilla
    , mkTupleTyConUnique
    , mkTupleDataConUnique
      -- *** Constraint
    , mkCTupleTyConUnique
    , mkCTupleDataConUnique
    ) where

#include "HsVersions.h"

import GhcPrelude

import TysWiredIn
import TyCon
import DataCon
import Id
import BasicTypes
import Outputable
import Unique
import Name
import Util

import Data.Bits
import Data.Maybe

-- | Get the 'Name' associated with a known-key 'Unique'.
knownUniqueName :: Unique -> Maybe Name
knownUniqueName :: Unique -> Maybe Name
knownUniqueName Unique
u =
    case Char
tag of
      Char
'z' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
getUnboxedSumName Int
n
      Char
'4' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> Name
getTupleTyConName Boxity
Boxed Int
n
      Char
'5' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> Name
getTupleTyConName Boxity
Unboxed Int
n
      Char
'7' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> Name
getTupleDataConName Boxity
Boxed Int
n
      Char
'8' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> Name
getTupleDataConName Boxity
Unboxed Int
n
      Char
'k' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
getCTupleTyConName Int
n
      Char
'm' -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
getCTupleDataConUnique Int
n
      Char
_   -> Maybe Name
forall a. Maybe a
Nothing
  where
    (Char
tag, Int
n) = Unique -> (Char, Int)
unpkUnique Unique
u

--------------------------------------------------
-- Anonymous sums
--
-- Sum arities start from 2. The encoding is a bit funny: we break up the
-- integral part into bitfields for the arity, an alternative index (which is
-- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a
-- tag (used to identify the sum's TypeRep binding).
--
-- This layout is chosen to remain compatible with the usual unique allocation
-- for wired-in data constructors described in Unique.hs
--
-- TyCon for sum of arity k:
--   00000000 kkkkkkkk 11111100

-- TypeRep of TyCon for sum of arity k:
--   00000000 kkkkkkkk 11111101
--
-- DataCon for sum of arity k and alternative n (zero-based):
--   00000000 kkkkkkkk nnnnnn00
--
-- TypeRep for sum DataCon of arity k and alternative n (zero-based):
--   00000000 kkkkkkkk nnnnnn10

mkSumTyConUnique :: Arity -> Unique
mkSumTyConUnique :: Int -> Unique
mkSumTyConUnique Int
arity =
    ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the
                         -- alternative
    Char -> Int -> Unique
mkUnique Char
'z' (Int
arity Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
0xfc)

mkSumDataConUnique :: ConTagZ -> Arity -> Unique
mkSumDataConUnique :: Int -> Int -> Unique
mkSumDataConUnique Int
alt Int
arity
  | Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
arity
  = String -> Unique
forall a. String -> a
panic (String
"mkSumDataConUnique: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
alt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
arity)
  | Bool
otherwise
  = Char -> Int -> Unique
mkUnique Char
'z' (Int
arity Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
alt Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
2) {- skip the tycon -}

getUnboxedSumName :: Int -> Name
getUnboxedSumName :: Int -> Name
getUnboxedSumName Int
n
  | Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xfc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0xfc
  = case Int
tag of
      Int
0x0 -> TyCon -> Name
tyConName (TyCon -> Name) -> TyCon -> Name
forall a b. (a -> b) -> a -> b
$ Int -> TyCon
sumTyCon Int
arity
      Int
0x1 -> TyCon -> Name
getRep (TyCon -> Name) -> TyCon -> Name
forall a b. (a -> b) -> a -> b
$ Int -> TyCon
sumTyCon Int
arity
      Int
_   -> String -> SDoc -> Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getUnboxedSumName: invalid tag" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
tag)
  | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x0
  = DataCon -> Name
dataConName (DataCon -> Name) -> DataCon -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Int -> DataCon
sumDataCon (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
arity
  | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x1
  = Id -> Name
forall a. NamedThing a => a -> Name
getName (Id -> Name) -> Id -> Name
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWrapId (DataCon -> Id) -> DataCon -> Id
forall a b. (a -> b) -> a -> b
$ Int -> Int -> DataCon
sumDataCon (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
arity
  | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x2
  = TyCon -> Name
getRep (TyCon -> Name) -> TyCon -> Name
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> DataCon -> TyCon
forall a b. (a -> b) -> a -> b
$ Int -> Int -> DataCon
sumDataCon (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
arity
  | Bool
otherwise
  = String -> SDoc -> Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getUnboxedSumName" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n)
  where
    arity :: Int
arity = Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
8
    alt :: Int
alt = (Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xfc) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
2
    tag :: Int
tag = Int
0x3 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
n
    getRep :: TyCon -> Name
getRep TyCon
tycon =
        Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> SDoc -> Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getUnboxedSumName(getRep)" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon))
        (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe TyCon
tycon

-- Note [Uniques for tuple type and data constructors]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Wired-in type constructor keys occupy *two* slots:
--    * u: the TyCon itself
--    * u+1: the TyConRepName of the TyCon
--
-- Wired-in tuple data constructor keys occupy *three* slots:
--    * u: the DataCon itself
--    * u+1: its worker Id
--    * u+2: the TyConRepName of the promoted TyCon

--------------------------------------------------
-- Constraint tuples

mkCTupleTyConUnique :: Arity -> Unique
mkCTupleTyConUnique :: Int -> Unique
mkCTupleTyConUnique Int
a = Char -> Int -> Unique
mkUnique Char
'k' (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)

mkCTupleDataConUnique :: Arity -> Unique
mkCTupleDataConUnique :: Int -> Unique
mkCTupleDataConUnique Int
a = Char -> Int -> Unique
mkUnique Char
'm' (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)

getCTupleTyConName :: Int -> Name
getCTupleTyConName :: Int -> Name
getCTupleTyConName Int
n =
    case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2 of
      (Int
arity, Int
0) -> Int -> Name
cTupleTyConName Int
arity
      (Int
arity, Int
1) -> Name -> Name
mkPrelTyConRepName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
cTupleTyConName Int
arity
      (Int, Int)
_          -> String -> Name
forall a. String -> a
panic String
"getCTupleTyConName: impossible"

getCTupleDataConUnique :: Int -> Name
getCTupleDataConUnique :: Int -> Name
getCTupleDataConUnique Int
n =
    case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
3 of
      (Int
arity,  Int
0) -> Int -> Name
cTupleDataConName Int
arity
      (Int
_arity, Int
1) -> String -> Name
forall a. String -> a
panic String
"getCTupleDataConName: no worker"
      (Int
arity,  Int
2) -> Name -> Name
mkPrelTyConRepName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
cTupleDataConName Int
arity
      (Int, Int)
_           -> String -> Name
forall a. String -> a
panic String
"getCTupleDataConName: impossible"

--------------------------------------------------
-- Normal tuples

mkTupleDataConUnique :: Boxity -> Arity -> Unique
mkTupleDataConUnique :: Boxity -> Int -> Unique
mkTupleDataConUnique Boxity
Boxed          Int
a = Char -> Int -> Unique
mkUnique Char
'7' (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)    -- may be used in C labels
mkTupleDataConUnique Boxity
Unboxed        Int
a = Char -> Int -> Unique
mkUnique Char
'8' (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)

mkTupleTyConUnique :: Boxity -> Arity -> Unique
mkTupleTyConUnique :: Boxity -> Int -> Unique
mkTupleTyConUnique Boxity
Boxed           Int
a  = Char -> Int -> Unique
mkUnique Char
'4' (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)
mkTupleTyConUnique Boxity
Unboxed         Int
a  = Char -> Int -> Unique
mkUnique Char
'5' (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
a)

getTupleTyConName :: Boxity -> Int -> Name
getTupleTyConName :: Boxity -> Int -> Name
getTupleTyConName Boxity
boxity Int
n =
    case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2 of
      (Int
arity, Int
0) -> TyCon -> Name
tyConName (TyCon -> Name) -> TyCon -> Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
      (Int
arity, Int
1) -> Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. String -> a
panic String
"getTupleTyConName")
                    (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe (TyCon -> Maybe Name) -> TyCon -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
      (Int, Int)
_          -> String -> Name
forall a. String -> a
panic String
"getTupleTyConName: impossible"

getTupleDataConName :: Boxity -> Int -> Name
getTupleDataConName :: Boxity -> Int -> Name
getTupleDataConName Boxity
boxity Int
n =
    case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
3 of
      (Int
arity, Int
0) -> DataCon -> Name
dataConName (DataCon -> Name) -> DataCon -> Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
arity
      (Int
arity, Int
1) -> Id -> Name
idName (Id -> Name) -> Id -> Name
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId (DataCon -> Id) -> DataCon -> Id
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
arity
      (Int
arity, Int
2) -> Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. String -> a
panic String
"getTupleDataCon")
                    (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe (TyCon -> Maybe Name) -> TyCon -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
promotedTupleDataCon Boxity
boxity Int
arity
      (Int, Int)
_          -> String -> Name
forall a. String -> a
panic String
"getTupleDataConName: impossible"