{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Compact.Serialized
-- Copyright   :  (c) The University of Glasgow 2001-2009
--                (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  unstable
-- Portability :  non-portable (GHC Extensions)
--
-- This module contains support for serializing a Compact for network
-- transmission and on-disk storage.
--
-- /Since: 1.0.0/

module GHC.Compact.Serialized(
  SerializedCompact(..),
  withSerializedCompact,
  importCompact,
  importCompactByteStrings,
) where

import GHC.Prim
import GHC.Types
import GHC.Word (Word8)

import GHC.Ptr (Ptr(..), plusPtr)

import Control.Concurrent
import qualified Data.ByteString as ByteString
import Data.ByteString.Internal(toForeignPtr)
import Data.IORef(newIORef, readIORef, writeIORef)
import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Marshal.Utils(copyBytes)

import GHC.Compact

-- | A serialized version of the 'Compact' metadata (each block with
-- address and size and the address of the root). This structure is
-- meant to be sent alongside the actual 'Compact' data. It can be
-- sent out of band in advance if the data is to be sent over RDMA
-- (which requires both sender and receiver to have pinned buffers).
data SerializedCompact a = SerializedCompact
  { serializedCompactBlockList :: [(Ptr a, Word)]
  , serializedCompactRoot :: Ptr a
  }

addrIsNull :: Addr# -> Bool
addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr)

compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
compactGetFirstBlock buffer =
  IO (\s -> case compactGetFirstBlock# buffer s of
         (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )

compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock buffer block =
  IO (\s -> case compactGetNextBlock# buffer block s of
         (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )

mkBlockList :: Compact# -> IO [(Ptr a, Word)]
mkBlockList buffer = compactGetFirstBlock buffer >>= go
  where
    go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
    go (Ptr block, _) | addrIsNull block = return []
    go item@(Ptr block, _) = do
      next <- compactGetNextBlock buffer block
      rest <- go next
      return $ item : rest

-- We MUST mark withSerializedCompact as NOINLINE
-- Otherwise the compiler will eliminate the call to touch#
-- causing the Compact# to be potentially GCed too eagerly,
-- before func had a chance to copy everything into its own
-- buffers/sockets/whatever

-- | Serialize the 'Compact', and call the provided function with
-- with the 'Compact' serialized representation.  It is not safe
-- to return the pointer from the action and use it after
-- the action completes: all uses must be inside this bracket,
-- since we cannot guarantee that the compact region will stay
-- live from the 'Ptr' object.  For example, it would be
-- unsound to use 'unsafeInterleaveIO' to lazily construct
-- a lazy bytestring from the 'Ptr'.
--
{-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: Compact a ->
                         (SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
  rootPtr <- IO (\s -> case anyToAddr# root s of
                    (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
  blockList <- mkBlockList buffer
  let serialized = SerializedCompact blockList rootPtr
  r <- func serialized
  IO (\s -> case touch# buffer s of
         s' -> (# s', r #) )

fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
                 (# State# RealWorld, Maybe (Compact a) #)
fixupPointers firstBlock rootAddr s =
  case compactFixupPointers# firstBlock rootAddr s of
    (# s', buffer, adjustedRoot #) ->
      if addrIsNull adjustedRoot then (# s', Nothing #)
      else case addrToAny# adjustedRoot of
        (# root #) -> case mkCompact buffer root s' of
          (# s'', c #) -> (# s'', Just c #)

-- | Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The
-- provided function will be called with the address and size of each
-- newly allocated block in succession, and should fill the memory
-- from the external source (eg. by reading from a socket or from disk)
-- 'importCompact' can return Nothing if the 'Compact' was corrupt
-- or it had pointers that could not be adjusted.
importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) ->
                 IO (Maybe (Compact a))

-- what we would like is
{-
 importCompactPtrs ((firstAddr, firstSize):rest) = do
   (firstBlock, compact) <- compactAllocateAt firstAddr firstSize
 #nullAddr
   fillBlock firstBlock firstAddr firstSize
   let go prev [] = return ()
       go prev ((addr, size):rest) = do
         (block, _) <- compactAllocateAt addr size prev
         fillBlock block addr size
         go block rest
   go firstBlock rest
   if isTrue# (compactFixupPointers compact) then
     return $ Just compact
     else
     return Nothing

But we can't do that because IO Addr# is not valid (kind mismatch)
This check exists to prevent a polymorphic data constructor from using
an unlifted type (which would break GC) - it would not a problem for IO
because IO stores a function, not a value, but the kind check is there
anyway.
Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor
we can do IO (Addr#, Word#) (that would break the GC for real!)

And therefore we need to do everything with State# explicitly.
-}

-- just do shut up GHC
importCompact (SerializedCompact [] _) _ = return Nothing
importCompact (SerializedCompact blocks root) filler = do
  -- I'm not sure why we need a bang pattern here, given that
  -- these are obviously strict lets, but ghc complains otherwise
  let !((_, W# firstSize):otherBlocks) = blocks
  let !(Ptr rootAddr) = root
  IO $ \s0 ->
    case compactAllocateBlock# firstSize nullAddr# s0 of {
      (# s1, firstBlock #) ->
    case fillBlock firstBlock firstSize s1 of { s2 ->
    case go firstBlock otherBlocks s2 of { s3 ->
    fixupPointers firstBlock rootAddr s3
    }}}
  where
    -- note that the case statements above are strict even though
    -- they don't seem to inspect their argument because State#
    -- is an unlifted type
    fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld
    fillBlock addr size s = case filler (Ptr addr) (W# size) of
      IO action -> case action s of
        (# s', _ #) -> s'

    go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
    go _ [] s = s
    go previous ((_, W# size):rest) s =
      case compactAllocateBlock# size previous s of
        (# s', block #) -> case fillBlock block size s' of
          s'' -> go block rest s''

sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool
sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl
  where
    go [] [] = True
    go (_:_) [] = False
    go [] (_:_) = False
    go ((_, size):scs) (bs:bss) =
      fromIntegral size == ByteString.length bs && go scs bss

-- | Convenience function for importing a compact region that is represented
-- by a list of strict 'ByteString's.
--
importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] ->
                            IO (Maybe (Compact a))
importCompactByteStrings serialized stringList =
  -- sanity check stringList first - if we throw an exception later we leak
  -- memory!
  if not (sanityCheckByteStrings serialized stringList) then
    return Nothing
  else do
    state <- newIORef stringList
    let filler :: Ptr Word8 -> Word -> IO ()
        filler to size = do
          -- this pattern match will never fail
          (next:rest) <- readIORef state
          let (fp, off, _) = toForeignPtr next
          withForeignPtr fp $ \from -> do
            copyBytes to (from `plusPtr` off) (fromIntegral size)
          writeIORef state rest
    importCompact serialized filler


module Main where

import Control.Exception
import System.Mem

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

main = do
  let val = ("hello", Just 42) :: (String, Maybe Int)
  str <- compactWithSharing val

  let val2 = ("world", 42) :: (String, Int)
  str2 <- compactAddWithSharing str val2

  -- check that values where not corrupted
  assertEquals ("hello", Just 42) val
  assertEquals ("world", 42) val2
  -- check the values in the compact
  assertEquals ("hello", Just 42) (getCompact str)
  assertEquals ("world", 42) (getCompact str2)

  performMajorGC

  -- same checks again
  assertEquals ("hello", Just 42) val
  assertEquals ("world", 42) val2
  -- check the values in the compact
  assertEquals ("hello", Just 42) (getCompact str)
  assertEquals ("world", 42) (getCompact str2)


module Main where

import Control.Exception
import System.Mem

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

main = do
  -- create a compact large 4096 bytes (minus the size of header)
  -- add a value that is 1024 cons cells, pointing to 7 INTLIKE
  -- each cons cell is 1 word header, 1 word data, 1 word next
  -- so total 3072 words, 12288 bytes on x86, 24576 on x86_64
  -- it should not fit in one block
  let val = replicate 4096 7 :: [Int]
  str <- compactSized 1 True val
  assertEquals val (getCompact str)
  performMajorGC
  assertEquals val (getCompact str)


import Control.Exception
import GHC.Compact
import qualified Data.Map as Map
import Data.Time.Clock
import Text.Printf
import System.Environment
import System.Mem
import Control.DeepSeq

-- Benchmark compact against compactWithSharing. e.g.
--   ./compact_bench 1000000

main = do
  [n] <- map read <$> getArgs
  let m = Map.fromList [(x,[x*1000..x*1000+10]) | x <- [1..(n::Integer)]]
  evaluate (force m)
  timeIt "compact" $ compact m >>= compactSize >>= print
  timeIt "compactWithSharing" $ compactWithSharing m >>= compactSize >>= print

timeIt :: String -> IO a -> IO a
timeIt str io = do
  performMajorGC
  t0 <- getCurrentTime
  a <- io
  t1 <- getCurrentTime
  printf "%s: %.2f\n" str (realToFrac (t1 `diffUTCTime` t0) :: Double)
  return a


import qualified Data.ByteString.Char8 as B
import GHC.Compact
import qualified Data.Map as Map

main = do
  c <- compact (Map.fromList [(B.pack (show x), x) | x <- [1..(10000::Int)]])
  print (getCompact c)


import Control.Exception
import GHC.Compact
import qualified Data.Map as Map
import System.Exit

main = do
  c <- compactWithSharing (cycle "abc") -- magic!
  print (length (show (take 100 (getCompact c))))
  print =<< compactSize c


import Control.Exception
import GHC.Compact

data HiddenFunction = HiddenFunction (Int -> Int)

main = compact (HiddenFunction (+1))


import Control.Monad
import GHC.Compact
import qualified Data.Map as Map

main = do
  let m = Map.fromList [(x,show x) | x <- [1..(10000::Int)]]
  c <- compactWithSharing m
  print =<< compactSize c
  c <- foldM (\c _ -> do c <- compactWithSharing (getCompact c); print =<< compactSize c; return c) c [1..10]
  print (length (show (getCompact c)))
  print =<< compactSize c


module Main where

import Control.Exception
import Control.Monad
import System.Mem

import Control.Monad.ST
import Data.Array
import Data.Array.ST
import qualified Data.Array.Unboxed as U

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

arrTest :: (Monad m, MArray a e m, Num e) => m (a Int e)
arrTest = do
  arr <- newArray (1, 10) 0
  forM_ [1..10] $ \j -> do
    writeArray arr j (fromIntegral $ 2*j + 1)
  return arr

-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
test func = do
  let fromList :: Array Int Int
      fromList = listArray (1, 300000) [1..]
      frozen :: Array Int Int
      frozen = runST $ do
        arr <- arrTest :: ST s (STArray s Int Int)
        freeze arr
      stFrozen :: Array Int Int
      stFrozen = runSTArray arrTest
      unboxedFrozen :: U.UArray Int Int
      unboxedFrozen = runSTUArray arrTest

  let val = (fromList, frozen, stFrozen, unboxedFrozen)
  str <- func val

  -- check that val is still good
  assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val
  -- check the value in the compact
  assertEquals val (getCompact str)
  performMajorGC
  -- check again the value in the compact
  assertEquals val (getCompact str)

main = do
  test (compactSized 4096 True)
  test (compactSized 4096 False)


import GHC.Compact
import qualified Data.Map as Map

main = do
  let m = Map.fromList [(x,show x) | x <- [1..(10000::Integer)]]
  c <- compactWithSharing m
  print (length (show (getCompact c)))
  c <- compact m
  print (length (show (getCompact c)))


module Main where

import Control.Exception
import System.Mem
import Text.Show

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

data Tree = Nil | Node Tree Tree Tree

instance Eq Tree where
  Nil == Nil = True
  Node _ l1 r1 == Node _ l2 r2 = l1 == l2 && r1 == r2
  _ == _ = False

instance Show Tree where
  showsPrec _ Nil = showString "Nil"
  showsPrec _ (Node _ l r) = showString "(Node " . shows l .
                             showString " " . shows r . showString ")"

{-# NOINLINE test #-}
test x = do
  let a = Node Nil x b
      b = Node a Nil Nil
  str <- compactSized 4096 True a

  -- check the value in the compact
  assertEquals a (getCompact str)
  performMajorGC
  -- check again the value in the compact
  assertEquals a (getCompact str)

main = test Nil


import Control.Concurrent
import Control.Exception
import GHC.Compact

data HiddenMVar = HiddenMVar (MVar ())

main = do
  m <- newEmptyMVar
  compact (HiddenMVar m)


import Control.Exception
import qualified Data.ByteString.Char8 as B
import GHC.Compact

main = compact (B.pack ['a'..'c'])


module Main where

import Control.Exception
import Control.Monad
import System.Mem

import Data.IORef
import Data.ByteString (ByteString, packCStringLen)
import Foreign.Ptr

import GHC.Compact
import GHC.Compact.Serialized

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

serialize :: a -> IO (SerializedCompact a, [ByteString])
serialize val = do
  cnf <- compactSized 4096 True val

  bytestrref <- newIORef undefined
  scref <- newIORef undefined
  withSerializedCompact cnf $ \sc -> do
    writeIORef scref sc
    performMajorGC
    bytestrs <- forM (serializedCompactBlockList sc) $ \(ptr, size) -> do
      packCStringLen (castPtr ptr, fromIntegral size)
    writeIORef bytestrref bytestrs

  performMajorGC

  bytestrs <- readIORef bytestrref
  sc <- readIORef scref
  return (sc, bytestrs)

main = do
  let val = ("hello", 1, 42, 42, Just 42) ::
        (String, Int, Int, Integer, Maybe Int)

  (sc, bytestrs) <- serialize val
  performMajorGC

  mcnf <- importCompactByteStrings sc bytestrs
  case mcnf of
    Nothing -> assertFail "import failed"
    Just cnf -> assertEquals val (getCompact cnf)


import Data.Char
import GHC.Compact
import qualified Data.Map as Map

main = do
  let m1 = Map.fromList [(x,show x) | x <- ['a'..chr 10000]]
      m2 = Map.fromList [(x,y) | x <- ['a'..chr 10000],
                                 Just y <- [Map.lookup x m1]]
  c <- compact (m1,m2)
  print (length (show (getCompact c)))
  print =<< compactSize c
  c <- compactWithSharing (m1,m2)
  print (length (show (getCompact c)))
  print =<< compactSize c


module Main where

import Control.Exception
import System.Mem

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
test func = do
  let val = ("hello", 1, 42, 42, Just 42) ::
        (String, Int, Int, Integer, Maybe Int)
  str <- func val

  -- check that val is still good
  assertEquals ("hello", 1, 42, 42, Just 42) val
  -- check the value in the compact
  assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str)
  performMajorGC
  -- check again val
  assertEquals ("hello", 1, 42, 42, Just 42) val
  -- check again the value in the compact
  assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str)

  print =<< compactSize str

main = do
  test compactWithSharing
  test compact


module Main where

import Control.Exception
import Control.Monad
import System.Mem

import Control.Monad.ST
import Data.Array
import Data.Array.ST
import qualified Data.Array.Unboxed as U

import GHC.Compact

assertFail :: String -> IO ()
assertFail msg = throwIO $ AssertionFailed msg

assertEquals :: (Eq a, Show a) => a -> a -> IO ()
assertEquals expected actual =
  if expected == actual then return ()
  else assertFail $ "expected " ++ (show expected)
       ++ ", got " ++ (show actual)

arrTest :: (Monad m, MArray a e m, Num e) => m (a Int e)
arrTest = do
  arr <- newArray (1, 10) 0
  forM_ [1..10] $ \j -> do
    writeArray arr j (fromIntegral $ 2*j + 1)
  return arr

-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
test func = do
  let fromList :: Array Int Int
      fromList = listArray (1, 10) [1..]
      frozen :: Array Int Int
      frozen = runST $ do
        arr <- arrTest :: ST s (STArray s Int Int)
        freeze arr
      stFrozen :: Array Int Int
      stFrozen = runSTArray arrTest
      unboxedFrozen :: U.UArray Int Int
      unboxedFrozen = runSTUArray arrTest

  let val = (fromList, frozen, stFrozen, unboxedFrozen)
  str <- func val

  -- check that val is still good
  assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val
  -- check the value in the compact
  assertEquals val (getCompact str)
  performMajorGC
  -- check again the value in the compact
  assertEquals val (getCompact str)

main = do
  test (compactSized 4096 True)
  test (compactSized 4096 False)


import GHC.Compact
import Data.Primitive.SmallArray

main :: IO ()
main = do
    arr <- newSmallArray 5 (Just 'a') >>= unsafeFreezeSmallArray
    arr' <- compact arr
    print $ getCompact arr'


import Control.Concurrent
import Control.Monad
import GHC.Compact
import qualified Data.Map as Map
import Data.Maybe
import System.Environment

main = do
  [n] <- map read <$> getArgs
  c <- compact ()
  as <- forM [1..(n::Int)] $ \i -> async (compactAdd c (Just i))
  bs <- forM as $ \a -> async (getCompact <$> takeMVar a)
  xs <- mapM takeMVar bs
  print (sum (catMaybes xs))

async :: IO a -> IO (MVar a)
async io = do
  m <- newEmptyMVar
  forkIO (io >>= putMVar m)
  return m


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}

{-|
Module      :  GHC.Exts.Heap
Copyright   :  (c) 2012 Joachim Breitner
License     :  BSD3
Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>

With this module, you can investigate the heap representation of Haskell
values, i.e. to investigate sharing and lazy evaluation.
-}

module GHC.Exts.Heap (
    -- * Closure types
      Closure
    , GenClosure(..)
    , ClosureType(..)
    , PrimType(..)
    , HasHeapRep(getClosureData)

    -- * Info Table types
    , StgInfoTable(..)
    , EntryFunPtr
    , HalfWord
    , ItblCodes
    , itblSize
    , peekItbl
    , pokeItbl

     -- * Closure inspection
    , getBoxedClosureData
    , allClosures

    -- * Boxes
    , Box(..)
    , asBox
    , areBoxesEqual
    ) where

import Prelude
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Constants
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils

import Control.Monad
import Data.Bits
import GHC.Arr
import GHC.Exts
import GHC.Int
import GHC.Word

#include "ghcconfig.h"

class HasHeapRep (a :: TYPE rep) where
    getClosureData :: a -> IO Closure

instance HasHeapRep (a :: TYPE 'LiftedRep) where
    getClosureData = getClosure

instance HasHeapRep (a :: TYPE 'UnliftedRep) where
    getClosureData x = getClosure (unsafeCoerce# x)

instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
    getClosureData x = return $
        IntClosure { ptipe = PInt, intVal = I# x }

instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
    getClosureData x = return $
        WordClosure { ptipe = PWord, wordVal = W# x }

instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
    getClosureData x = return $
        Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }

instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
    getClosureData x = return $
        Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }

instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
    getClosureData x = return $
        AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }

instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
    getClosureData x = return $
        FloatClosure { ptipe = PFloat, floatVal = F# x }

instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
    getClosureData x = return $
        DoubleClosure { ptipe = PDouble, doubleVal = D# x }

-- | This returns the raw representation of the given argument. The second
-- component of the triple is the raw words of the closure on the heap, and the
-- third component is those words that are actually pointers. Once back in the
-- Haskell world, the raw words that hold pointers may be outdated after a
-- garbage collector run, but the corresponding values in 'Box's will still
-- point to the correct value.
getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw x = do
    case unpackClosure# x of
-- This is a hack to cover the bootstrap compiler using the old version of
-- 'unpackClosure'. The new 'unpackClosure' return values are not merely
-- a reordering, so using the old version would not work.
#if MIN_VERSION_ghc_prim(0,5,3)
        (# iptr, dat, pointers #) -> do
#else
        (# iptr, pointers, dat #) -> do
#endif
            let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
                end = fromIntegral nelems - 1
                rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
                pelems = I# (sizeofArray# pointers)
                ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
            pure (Ptr iptr, rawWds, ptrList)

-- From compiler/ghci/RtClosureInspect.hs
amap' :: (t -> b) -> Array Int t -> [b]
amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
    where g (I# i#) = case indexArray# arr# i# of
                          (# e #) -> f e

-- | This function returns a parsed heap representation of the argument _at
-- this moment_, even if it is unevaluated or an indirection or other exotic
-- stuff.  Beware when passing something to this function, the same caveats as
-- for 'asBox' apply.
getClosure :: a -> IO Closure
getClosure x = do
    (iptr, wds, pts) <- getClosureRaw x
    itbl <- peekItbl iptr
    -- The remaining words after the header
    let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
    -- For data args in a pointers then non-pointers closure
    -- This is incorrect in non pointers-first setups
    -- not sure if that happens
        npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
    case tipe itbl of
        t | t >= CONSTR && t <= CONSTR_NOCAF -> do
            (p, m, n) <- dataConNames iptr
            if m == "ByteCodeInstr" && n == "BreakInfo"
              then pure $ UnsupportedClosure itbl
              else pure $ ConstrClosure itbl pts npts p m n

        t | t >= THUNK && t <= THUNK_STATIC -> do
            pure $ ThunkClosure itbl pts npts

        THUNK_SELECTOR -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
            pure $ SelectorClosure itbl (head pts)

        t | t >= FUN && t <= FUN_STATIC -> do
            pure $ FunClosure itbl pts npts

        AP -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to AP"
            -- We expect at least the arity, n_args, and fun fields
            unless (length rawWds >= 2) $
                fail $ "Expected at least 2 raw words to AP"
            let splitWord = rawWds !! 0
            pure $ APClosure itbl
#if defined(WORDS_BIGENDIAN)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                (fromIntegral splitWord)
#else
                (fromIntegral splitWord)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
                (head pts) (tail pts)

        PAP -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to PAP"
            -- We expect at least the arity, n_args, and fun fields
            unless (length rawWds >= 2) $
                fail "Expected at least 2 raw words to PAP"
            let splitWord = rawWds !! 0
            pure $ PAPClosure itbl
#if defined(WORDS_BIGENDIAN)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                (fromIntegral splitWord)
#else
                (fromIntegral splitWord)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
                (head pts) (tail pts)

        AP_STACK -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to AP_STACK"
            pure $ APStackClosure itbl (head pts) (tail pts)

        IND -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to IND"
            pure $ IndClosure itbl (head pts)

        IND_STATIC -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to IND_STATIC"
            pure $ IndClosure itbl (head pts)

        BLACKHOLE -> do
            unless (length pts >= 1) $
                fail "Expected at least 1 ptr argument to BLACKHOLE"
            pure $ BlackholeClosure itbl (head pts)

        BCO -> do
            unless (length pts >= 3) $
                fail $ "Expected at least 3 ptr argument to BCO, found "
                        ++ show (length pts)
            unless (length rawWds >= 4) $
                fail $ "Expected at least 4 words to BCO, found "
                        ++ show (length rawWds)
            let splitWord = rawWds !! 3
            pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
#if defined(WORDS_BIGENDIAN)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                (fromIntegral splitWord)
#else
                (fromIntegral splitWord)
                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
                (drop 4 rawWds)

        ARR_WORDS -> do
            unless (length rawWds >= 1) $
                fail $ "Expected at least 1 words to ARR_WORDS, found "
                        ++ show (length rawWds)
            pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)

        t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
            unless (length rawWds >= 2) $
                fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
                        ++ "found " ++ show (length rawWds)
            pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts

        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
            pure $ MutVarClosure itbl (head pts)

        t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
            unless (length pts >= 3) $
                fail $ "Expected at least 3 ptrs to MVAR, found "
                        ++ show (length pts)
            pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)

        BLOCKING_QUEUE ->
            pure $ OtherClosure itbl pts wds
        --    pure $ BlockingQueueClosure itbl
        --        (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)

        --  pure $ OtherClosure itbl pts wds
        --
        _ ->
            pure $ UnsupportedClosure itbl

-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a


{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}

module GHC.Exts.Heap.Closures (
    -- * Closures
      Closure
    , GenClosure(..)
    , PrimType(..)
    , allClosures

    -- * Boxes
    , Box(..)
    , areBoxesEqual
    , asBox
    ) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.Exts.Heap.Constants
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable

-- `ghc -M` currently doesn't properly account for ways when generating
-- dependencies (#15197). This import ensures correct build-ordering between
-- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197
-- is fixed.
import GHC.Exts.Heap.InfoTableProf ()
#endif

import Data.Bits
import Data.Int
import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric

------------------------------------------------------------------------
-- Boxes

foreign import prim "aToWordzh" aToWord# :: Any -> Word#

foreign import prim "reallyUnsafePtrEqualityUpToTag"
    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#

-- | An arbitrary Haskell value in a safe Box. The point is that even
-- unevaluated thunks can safely be moved around inside the Box, and when
-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
-- to evaluate the argument.
data Box = Box Any

instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
   showsPrec _ (Box a) rs =
    -- unsafePerformIO (print "â†“" >> pClosure a) `seq`
    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
     where
       ptr  = W# (aToWord# a)
       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
       addr = ptr - tag
        -- want 0s prefixed to pad it out to a fixed length.
       pad_out ls =
          '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls

-- |This takes an arbitrary value and puts it into a box.
-- Note that calls like
--
-- > asBox (head list)
--
-- will put the thunk \"head list\" into the box, /not/ the element at the head
-- of the list. For that, use careful case expressions:
--
-- > case list of x:_ -> asBox x
asBox :: a -> Box
asBox x = Box (unsafeCoerce# x)

-- | Boxes can be compared, but this is not pure, as different heap objects can,
-- after garbage collection, become the same object.
areBoxesEqual :: Box -> Box -> IO Bool
areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
    0# -> pure False
    _  -> pure True

------------------------------------------------------------------------
-- Closures

type Closure = GenClosure Box

-- | This is the representation of a Haskell value on the heap. It reflects
-- <http://ghc.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
--
-- The data type is parametrized by the type to store references in. Usually
-- this is a 'Box' with the type synonym 'Closure'.
--
-- All Heap objects have the same basic layout. A header containing a pointer
-- to the info table and a payload with various fields. The @info@ field below
-- always refers to the info table pointed to by the header. The remaining
-- fields are the payload.
--
-- See
-- <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects>
-- for more information.
data GenClosure b
  = -- | A data constructor
    ConstrClosure
        { info       :: !StgInfoTable
        , ptrArgs    :: ![b]            -- ^ Pointer arguments
        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
        , pkg        :: !String         -- ^ Package name
        , modl       :: !String         -- ^ Module name
        , name       :: !String         -- ^ Constructor name
        }

    -- | A function
  | FunClosure
        { info       :: !StgInfoTable
        , ptrArgs    :: ![b]            -- ^ Pointer arguments
        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
        }

    -- | A thunk, an expression not obviously in head normal form
  | ThunkClosure
        { info       :: !StgInfoTable
        , ptrArgs    :: ![b]            -- ^ Pointer arguments
        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
        }

    -- | A thunk which performs a simple selection operation
  | SelectorClosure
        { info       :: !StgInfoTable
        , selectee   :: !b              -- ^ Pointer to the object being
                                        --   selected from
        }

    -- | An unsaturated function application
  | PAPClosure
        { info       :: !StgInfoTable
        , arity      :: !HalfWord       -- ^ Arity of the partial application
        , n_args     :: !HalfWord       -- ^ Size of the payload in words
        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
        , payload    :: ![b]            -- ^ Sequence of already applied
                                        --   arguments
        }

    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
    -- functions fun actually find the name here.
    -- At least the other direction works via "lookupSymbol
    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
    -- | A function application
  | APClosure
        { info       :: !StgInfoTable
        , arity      :: !HalfWord       -- ^ Always 0
        , n_args     :: !HalfWord       -- ^ Size of payload in words
        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
        , payload    :: ![b]            -- ^ Sequence of already applied
                                        --   arguments
        }

    -- | A suspended thunk evaluation
  | APStackClosure
        { info       :: !StgInfoTable
        , fun        :: !b              -- ^ Function closure
        , payload    :: ![b]            -- ^ Stack right before suspension
        }

    -- | A pointer to another closure, introduced when a thunk is updated
    -- to point at its value
  | IndClosure
        { info       :: !StgInfoTable
        , indirectee :: !b              -- ^ Target closure
        }

   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
   -- interpreter (e.g. as used by GHCi)
  | BCOClosure
        { info       :: !StgInfoTable
        , instrs     :: !b              -- ^ A pointer to an ArrWords
                                        --   of instructions
        , literals   :: !b              -- ^ A pointer to an ArrWords
                                        --   of literals
        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
                                        --   of byte code objects
        , arity      :: !HalfWord       -- ^ The arity of this BCO
        , size       :: !HalfWord       -- ^ The size of this BCO in words
        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
                                        --   pointerhood of its args/free vars
        }

    -- | A thunk under evaluation by another thread
  | BlackholeClosure
        { info       :: !StgInfoTable
        , indirectee :: !b              -- ^ The target closure
        }

    -- | A @ByteArray#@
  | ArrWordsClosure
        { info       :: !StgInfoTable
        , bytes      :: !Word           -- ^ Size of array in bytes
        , arrWords   :: ![Word]         -- ^ Array payload
        }

    -- | A @MutableByteArray#@
  | MutArrClosure
        { info       :: !StgInfoTable
        , mccPtrs    :: !Word           -- ^ Number of pointers
        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
        , mccPayload :: ![b]            -- ^ Array payload
        -- Card table ignored
        }

    -- | An @MVar#@, with a queue of thread state objects blocking on them
  | MVarClosure
        { info       :: !StgInfoTable
        , queueHead  :: !b              -- ^ Pointer to head of queue
        , queueTail  :: !b              -- ^ Pointer to tail of queue
        , value      :: !b              -- ^ Pointer to closure
        }

    -- | A @MutVar#@
  | MutVarClosure
        { info       :: !StgInfoTable
        , var        :: !b              -- ^ Pointer to contents
        }

    -- | An STM blocking queue.
  | BlockingQueueClosure
        { info       :: !StgInfoTable
        , link       :: !b              -- ^ ?? Here so it looks like an IND
        , blackHole  :: !b              -- ^ The blackhole closure
        , owner      :: !b              -- ^ The owning thread state object
        , queue      :: !b              -- ^ ??
        }

    ------------------------------------------------------------
    -- Unboxed unlifted closures

    -- | Primitive Int
  | IntClosure
        { ptipe      :: PrimType
        , intVal     :: !Int }

    -- | Primitive Word
  | WordClosure
        { ptipe      :: PrimType
        , wordVal    :: !Word }

    -- | Primitive Int64
  | Int64Closure
        { ptipe      :: PrimType
        , int64Val   :: !Int64 }

    -- | Primitive Word64
  | Word64Closure
        { ptipe      :: PrimType
        , word64Val  :: !Word64 }

    -- | Primitive Addr
  | AddrClosure
        { ptipe      :: PrimType
        , addrVal    :: !Int }

    -- | Primitive Float
  | FloatClosure
        { ptipe      :: PrimType
        , floatVal   :: !Float }

    -- | Primitive Double
  | DoubleClosure
        { ptipe      :: PrimType
        , doubleVal  :: !Double }

    -----------------------------------------------------------
    -- Anything else

    -- | Another kind of closure
  | OtherClosure
        { info       :: !StgInfoTable
        , hvalues    :: ![b]
        , rawWords   :: ![Word]
        }

  | UnsupportedClosure
        { info       :: !StgInfoTable
        }
  deriving (Show, Generic, Functor, Foldable, Traversable)

data PrimType
  = PInt
  | PWord
  | PInt64
  | PWord64
  | PAddr
  | PFloat
  | PDouble
  deriving (Eq, Show, Generic)

-- | For generic code, this function returns all referenced closures.
allClosures :: GenClosure b -> [b]
allClosures (ConstrClosure {..}) = ptrArgs
allClosures (ThunkClosure {..}) = ptrArgs
allClosures (SelectorClosure {..}) = [selectee]
allClosures (IndClosure {..}) = [indirectee]
allClosures (BlackholeClosure {..}) = [indirectee]
allClosures (APClosure {..}) = fun:payload
allClosures (PAPClosure {..}) = fun:payload
allClosures (APStackClosure {..}) = fun:payload
allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
allClosures (ArrWordsClosure {}) = []
allClosures (MutArrClosure {..}) = mccPayload
allClosures (MutVarClosure {..}) = [var]
allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
allClosures (FunClosure {..}) = ptrArgs
allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (OtherClosure {..}) = hvalues
allClosures _ = []


{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}

module GHC.Exts.Heap.ClosureTypes
    ( ClosureType(..)
    , closureTypeHeaderSize
    ) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.Generics

{- ---------------------------------------------
-- Enum representing closure types
-- This is a mirror of:
-- includes/rts/storage/ClosureTypes.h
-- ---------------------------------------------}

data ClosureType
    = INVALID_OBJECT
    | CONSTR
    | CONSTR_1_0
    | CONSTR_0_1
    | CONSTR_2_0
    | CONSTR_1_1
    | CONSTR_0_2
    | CONSTR_NOCAF
    | FUN
    | FUN_1_0
    | FUN_0_1
    | FUN_2_0
    | FUN_1_1
    | FUN_0_2
    | FUN_STATIC
    | THUNK
    | THUNK_1_0
    | THUNK_0_1
    | THUNK_2_0
    | THUNK_1_1
    | THUNK_0_2
    | THUNK_STATIC
    | THUNK_SELECTOR
    | BCO
    | AP
    | PAP
    | AP_STACK
    | IND
    | IND_STATIC
    | RET_BCO
    | RET_SMALL
    | RET_BIG
    | RET_FUN
    | UPDATE_FRAME
    | CATCH_FRAME
    | UNDERFLOW_FRAME
    | STOP_FRAME
    | BLOCKING_QUEUE
    | BLACKHOLE
    | MVAR_CLEAN
    | MVAR_DIRTY
    | TVAR
    | ARR_WORDS
    | MUT_ARR_PTRS_CLEAN
    | MUT_ARR_PTRS_DIRTY
    | MUT_ARR_PTRS_FROZEN_DIRTY
    | MUT_ARR_PTRS_FROZEN_CLEAN
    | MUT_VAR_CLEAN
    | MUT_VAR_DIRTY
    | WEAK
    | PRIM
    | MUT_PRIM
    | TSO
    | STACK
    | TREC_CHUNK
    | ATOMICALLY_FRAME
    | CATCH_RETRY_FRAME
    | CATCH_STM_FRAME
    | WHITEHOLE
    | SMALL_MUT_ARR_PTRS_CLEAN
    | SMALL_MUT_ARR_PTRS_DIRTY
    | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY
    | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
    | COMPACT_NFDATA
    | N_CLOSURE_TYPES
 deriving (Enum, Eq, Ord, Show, Generic)

-- | Return the size of the closures header in words
closureTypeHeaderSize :: ClosureType -> Int
closureTypeHeaderSize closType =
    case closType of
        ct | THUNK <= ct && ct <= THUNK_0_2 -> thunkHeader
        ct | ct == THUNK_SELECTOR -> thunkHeader
        ct | ct == AP -> thunkHeader
        ct | ct == AP_STACK -> thunkHeader
        _ -> header
  where
    header = 1 + prof
    thunkHeader = 2 + prof
#if defined(PROFILING)
    prof = 2
#else
    prof = 0
#endif


-- The simplifier changes the shapes of closures that we expect.
{-# OPTIONS_GHC -O0 #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

import GHC.Exts.Heap

import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Monad
import GHC.Exts
import GHC.Int
import GHC.IO
import GHC.IORef
import GHC.MVar
import GHC.Stack
import GHC.STRef
import GHC.Word
import System.Environment
import System.Mem

exData :: (Int,Int)
exData = (1,2)

exItbl :: StgInfoTable
exItbl = StgInfoTable
    { entry = Nothing
    , ptrs = 0
    , nptrs = 0
    , tipe = toEnum 0
    , srtlen = 0
    , code = Nothing
    }

exConstrClosure :: Closure
exConstrClosure = ConstrClosure
    { info = exItbl{tipe=CONSTR_1_0, ptrs=1, nptrs=0}
    , ptrArgs = []
    , dataArgs = []
    , pkg = "base"
    , modl = "GHC.Base"
    , name = "Just"
    }

exFunClosure :: Closure
exFunClosure = FunClosure
    { info = exItbl{tipe=FUN_0_1, ptrs=0, nptrs=1}
    , ptrArgs = []
    , dataArgs = [0]
    }

exThunkClosure :: Closure
exThunkClosure = ThunkClosure
    { info = exItbl{tipe=THUNK}
    , ptrArgs = []
    , dataArgs = []
    }

exSelectClosure :: Closure
exSelectClosure = SelectorClosure
    { info = exItbl
    , selectee = asBox exData
    }

exPAPClosure :: Closure
exPAPClosure = PAPClosure
    { info = exItbl{tipe=PAP}
    , arity = 1
    , n_args = 1
    , fun = asBox id
    , payload = []
    }

exAPClosure :: Closure
exAPClosure = APClosure
    { info = exItbl{tipe=AP}
    , arity = 0
    , n_args = 0
    , fun = asBox id
    , payload = []
    }

exAPStackClosure :: Closure
exAPStackClosure = APStackClosure
    { info = exItbl{tipe=AP_STACK}
    , fun = asBox id
    , payload = []
    }

exIndClosure :: Closure
exIndClosure = IndClosure
    { info = exItbl{tipe=IND}
    , indirectee = asBox []
    }

exBCOClosure :: Closure
exBCOClosure = BCOClosure
    { info = exItbl{tipe=BCO, ptrs=4}
    , instrs = asBox []
    , literals = asBox []
    , bcoptrs = asBox []
    , arity = 0
    , size = 5
    , bitmap = []
    }

exBlackholeClosure :: Closure
exBlackholeClosure = BlackholeClosure
    { info = exItbl{tipe=BLACKHOLE}
    , indirectee = asBox []
    }

exArrWordsClosure :: Closure
exArrWordsClosure = ArrWordsClosure
    { info = exItbl{tipe=ARR_WORDS}
    , bytes = 0
    , arrWords = []
    }

exMutArrClosure :: Closure
exMutArrClosure = MutArrClosure
    { info = exItbl{tipe=MUT_ARR_PTRS_DIRTY}
    , mccPtrs = 0
    , mccSize = 0
    , mccPayload = []
    }

exMVarClosure :: Closure
exMVarClosure = MVarClosure
    { info = exItbl{tipe=MVAR_DIRTY}
    , queueHead = asBox []
    , queueTail = asBox []
    , value = asBox 0
    }

exMutVarClosure :: Closure
exMutVarClosure = MutVarClosure
    { info = exItbl{tipe=MUT_VAR_DIRTY}
    , var = asBox []
    }

exBlockingQClosure :: Closure
exBlockingQClosure = BlockingQueueClosure
    { info = exItbl{tipe=BLOCKING_QUEUE}
    , link = asBox []
    , blackHole = asBox []
    , owner = asBox []
    , queue = asBox []
    }

exIntClosure :: Closure
exIntClosure = IntClosure
    { ptipe = PInt, intVal = 42 }

exWordClosure :: Closure
exWordClosure = WordClosure
    { ptipe = PWord, wordVal = 42 }

exInt64Closure :: Closure
exInt64Closure = Int64Closure
    { ptipe = PInt64, int64Val = 42 }

exWord64Closure :: Closure
exWord64Closure = Word64Closure
    { ptipe = PWord64, word64Val = 42 }

exAddrClosure :: Closure
exAddrClosure = AddrClosure
    { ptipe = PAddr, addrVal = 42 }

exFloatClosure :: Closure
exFloatClosure = FloatClosure
    { ptipe = PFloat, floatVal = 42.0 }

exDoubleClosure :: Closure
exDoubleClosure = DoubleClosure
    { ptipe = PDouble, doubleVal = 42.0 }

exOtherClosure :: Closure
exOtherClosure = OtherClosure
    { info = exItbl
    , hvalues = []
    , rawWords = []
    }

data A = A (Array# Int)
data MA = MA (MutableArray# RealWorld Int)
data BA = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)
data B = B BCO#
data APC a = APC a

main :: IO ()
main = do

    --------------------------------------------
    -- Objects to inspect

    MA ma <- IO $ \s ->
        case newArray# 0# 0 s of
            (# s1, x #) -> (# s1, MA x #)
    A a <- IO $ \s ->
        case freezeArray# ma 0# 0# s of
            (# s1, x #) -> (# s1, A x #)
    MBA mba <- IO $ \s ->
        case newByteArray# 0# s of
            (# s1, x #) -> (# s1, MBA x #)
    BA ba <- IO $ \s ->
        case newByteArray# 0# s of
            (# s1, x #) ->
                case unsafeFreezeByteArray# x s1 of
                    (# s2, y #) -> (# s2, BA y #)
    B bco <- IO $ \s ->
        case newBCO# ba ba a 0# ba s of
            (# s1, x #) -> (# s1, B x #)
    APC apc <- IO $ \s ->
        case mkApUpd0# bco of
            (# x #) -> (# s, APC x #)

    --------------------------------------------
    -- Closures

    -- Constructor
    let !con = Just 1
    getClosureData con >>=
        assertClosuresEq exConstrClosure

    -- Function
    let !fun = \x -> x + 1
    getClosureData fun >>=
        assertClosuresEq exFunClosure

    -- Thunk
    let thunk = map (+2) [1,2,3]
    getClosureData thunk >>=
        assertClosuresEq exThunkClosure

    -- Selector
    -- FAILING: Getting THUNK not THUNK_SELECTOR
    -- let sel = case exData of (a,_) -> a
    -- getClosureData sel >>=
    --     assertClosuresEq exSelectClosure

    -- Partial application
    let !f = map (+2)
    getClosureData f >>=
        assertClosuresEq exPAPClosure

    -- Applied function
    getClosureData apc >>=
        assertClosuresEq exAPClosure

    -- Suspended thunk evaluation
    -- getClosureData (Just 1) >>=
    --     assertClosuresEq exAPStackClosure

    -- Indirection
    -- getClosureData (Just 1) >>=
    --     assertClosuresEq exIndClosure

    -- ByteCode object
    getClosureData bco >>=
        assertClosuresEq exBCOClosure

    -- Blackhole
    -- getClosureData (Just 1) >>=
    --     assertClosuresEq exBlackholeClosure

    -- Byte array
    getClosureData ba >>=
        assertClosuresEq exArrWordsClosure

    -- Mutable pointer array
    getClosureData ma >>=
        assertClosuresEq exMutArrClosure

    -- MVar
    (MVar v) <- newMVar 1
    getClosureData (unsafeCoerce# v) >>=
        assertClosuresEq exMVarClosure

    -- MutVar
    (IORef (STRef v)) <- newIORef 1
    getClosureData v >>=
        assertClosuresEq exMutVarClosure

    -- Blocking queue
    -- getClosureData (Just 1) >>=
    --    assertClosuresEq exBlockingQClosure

    -----------------------------------------------------
    -- Unboxed unlifted types

    -- Primitive Int
    let (I# v) = 42
    getClosureData v >>=
        assertClosuresEq exIntClosure

    -- Primitive Word
    let (W# v) = 42
    getClosureData v >>=
        assertClosuresEq exWordClosure

    -- Primitive Int64
    -- FAILING: On 64-bit platforms, v is a regular Int
    -- let (I64# v) = 42
    -- getClosureData v >>=
    --     assertClosuresEq exInt64Closure

    -- Primitive Word64
    -- FAILING: On 64-bit platforms, v is a regular Word
    -- let (W64# v) = 42
    -- getClosureData v >>=
    --     assertClosuresEq exWord64Closure

    -- Primitive Addr
    let v = unsafeCoerce# 42# :: Addr#
    getClosureData v >>=
        assertClosuresEq exAddrClosure

    -- Primitive Float
    let (F# v) = 42.0
    getClosureData v >>=
        assertClosuresEq exFloatClosure

    -- Primitive Double
    let (D# v) = 42.0
    getClosureData v >>=
        assertClosuresEq exDoubleClosure

    ------------------------------------------------------
    -- Catch-all type

    -- Other
    -- getClosureData (Just 1) >>=
    --    assertClosuresEq exOtherClosure

    putStrLn "Done. No errors."

-- | Attempt to compare two closures
compareClosures :: Closure -> Closure -> Bool
compareClosures expected actual =
    -- Determine which fields to compare based
    -- upon expected closure type
    let funcs = case expected of
                    ConstrClosure{}         -> [ sEq (tipe . info)
                                               , sEq (ptrs . info)
                                               , sEq (nptrs . info)
                                               , sEq dataArgs
                                               , sEq name          ]
                    FunClosure{}            -> [ sEq (tipe . info)
                                               , sEq (ptrs . info)
                                               , sEq (nptrs . info)
                                               , sEq dataArgs      ]
                    ThunkClosure{}          -> [ sEq (tipe . info)
                                               , sEq (ptrs . info)
                                               , sEq (nptrs . info)
                                               , sEq dataArgs      ]
                    SelectorClosure{}       -> [ sEq (tipe . info) ]
                    PAPClosure{}            -> [ sEq (tipe . info)
                                               , sEq arity
                                               , sEq n_args        ]
                    APClosure{}             -> [ sEq (tipe . info)
                                               , sEq arity
                                               , sEq n_args        ]
                    APStackClosure{}        -> [ sEq (tipe . info) ]
                    IndClosure{}            -> [ sEq (tipe . info) ]
                    BCOClosure{}            -> [ sEq (tipe . info)
                                               , sEq arity
                                               , sEq bitmap        ]
                    BlackholeClosure{}      -> [ sEq (tipe . info) ]
                    ArrWordsClosure{}       -> [ sEq (tipe . info)
                                               , sEq bytes
                                               , sEq arrWords      ]
                    MutArrClosure{}         -> [ sEq (tipe . info)
                                               , sEq mccPtrs
                                               , sEq mccSize       ]
                    MVarClosure{}           -> [ sEq (tipe . info) ]
                    MutVarClosure{}         -> [ sEq (tipe . info) ]
                    BlockingQueueClosure{}  -> [ sEq (tipe . info) ]
                    IntClosure{}            -> [ sEq ptipe
                                               , sEq intVal    ]
                    WordClosure{}           -> [ sEq ptipe
                                               , sEq wordVal   ]
                    Int64Closure{}          -> [ sEq ptipe
                                               , sEq int64Val  ]
                    Word64Closure{}         -> [ sEq ptipe
                                               , sEq word64Val ]
                    AddrClosure{}           -> [ sEq ptipe
                                               , sEq addrVal   ]
                    FloatClosure{}          -> [ sEq ptipe
                                               , sEq floatVal  ]
                    DoubleClosure{}         -> [ sEq ptipe
                                               , sEq doubleVal ]
                    _ -> error $ "Don't know how to compare expected closure: "
                                 ++ show expected
    in compareWith funcs expected actual
  where
    -- Take a list of closure comparisons and check all
    compareWith :: [Closure -> Closure -> Bool] -> Closure -> Closure -> Bool
    compareWith funcs c1 c2 = all (\f -> f c1 c2) funcs

    -- Create a comparison function from a selector
    sEq :: Eq a => (Closure -> a) -> Closure -> Closure -> Bool
    sEq select c1 c2 = select c1 == select c2

-- | Assert two closures are equal, checking depending on closure type
assertClosuresEq :: HasCallStack => Closure -> Closure -> IO ()
assertClosuresEq _ c@UnsupportedClosure{} =
    fail $ unlines [ "Unsupported closure returned: " ++ show c
                   , ""
                   , prettyCallStack callStack
                   ]
assertClosuresEq expected actual =
    unless (compareClosures expected actual) $ fail $ unlines
        [ "assertClosuresEq: Closures do not match"
        , "Expected: " ++ show expected
        , "Actual:   " ++ show actual
        , ""
        , prettyCallStack callStack
        ]


-- We need to do some ugly hacks here because of GHC magic

module Main (main) where

import Control.Monad
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Text
import System.Cmd
import System.FilePath
import System.Exit
import System.Directory

main :: IO ()
main = do let hooks = simpleUserHooks {
                  regHook = addPrimModule
                          $ regHook simpleUserHooks,
                  buildHook = build_primitive_sources
                            $ buildHook simpleUserHooks,
                  haddockHook = addPrimModuleForHaddock
                              $ build_primitive_sources
                              $ haddockHook simpleUserHooks }
          defaultMainWithHooks hooks

type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()

addPrimModule :: Hook a -> Hook a
addPrimModule f pd lbi uhs x =
    do let -- I'm not sure which one of these we actually need to change.
           -- It seems bad that there are two.
           pd' = addPrimModuleToPD pd
           lpd = addPrimModuleToPD (localPkgDescr lbi)
           lbi' = lbi { localPkgDescr = lpd }
       f pd' lbi' uhs x

addPrimModuleForHaddock :: Hook a -> Hook a
addPrimModuleForHaddock f pd lbi uhs x =
    do let pc = withPrograms lbi
           pc' = userSpecifyArgs "haddock" ["GHC/Prim.hs"] pc
           lbi' = lbi { withPrograms = pc' }
       f pd lbi' uhs x

addPrimModuleToPD :: PackageDescription -> PackageDescription
addPrimModuleToPD pd =
    case library pd of
    Just lib ->
        let ems = fromJust (simpleParse "GHC.Prim") : exposedModules lib
            lib' = lib { exposedModules = ems }
        in pd { library = Just lib' }
    Nothing ->
        error "Expected a library, but none found"

build_primitive_sources :: Hook a -> Hook a
build_primitive_sources f pd lbi uhs x
 = do when (compilerFlavor (compiler lbi) == GHC) $ do
          let genprimopcode = joinPath ["..", "..", "utils",
                                        "genprimopcode", "genprimopcode"]
              primops = joinPath ["..", "..", "compiler", "prelude",
                                  "primops.txt"]
              primhs = joinPath ["GHC", "Prim.hs"]
              primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
              primhs_tmp = addExtension primhs "tmp"
              primopwrappers_tmp = addExtension primopwrappers "tmp"
          maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
                           ++ primops ++ " > " ++ primhs_tmp)
          maybeUpdateFile primhs_tmp primhs
          maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
                           ++ primops ++ " > " ++ primopwrappers_tmp)
          maybeUpdateFile primopwrappers_tmp primopwrappers
      f pd lbi uhs x

-- Replace a file only if the new version is different from the old.
-- This prevents make from doing unnecessary work after we run 'setup makefile'
maybeUpdateFile :: FilePath -> FilePath -> IO ()
maybeUpdateFile source target = do
  r <- rawSystem "cmp" ["-s" {-quiet-}, source, target]
  case r of
    ExitSuccess   -> removeFile source
    ExitFailure _ -> do exists <- doesFileExist target
                        when exists $ removeFile target
                        renameFile source target


{-# LANGUAGE CPP, Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving, BangPatterns,
             KindSignatures, DataKinds, ConstraintKinds,
              MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
  -- ip :: IP x a => a  is strictly speaking ambiguous, but IP is magic
{-# LANGUAGE UndecidableSuperClasses #-}
  -- Because of the type-variable superclasses for tuples

{-# OPTIONS_GHC -Wno-unused-imports #-}
-- -Wno-unused-imports needed for the GHC.Tuple import below. Sigh.

{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-- -Wno-unused-top-binds is there (I hope) to stop Haddock complaining
-- about the constraint tuples being defined but not used

{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Classes
-- Copyright   :  (c) The University of Glasgow, 1992-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Basic classes.
--
-----------------------------------------------------------------------------

module GHC.Classes(
    -- * Implicit paramaters
    IP(..),

    -- * Equality and ordering
    Eq(..),
    Ord(..),
    -- ** Monomorphic equality operators
    -- $matching_overloaded_methods_in_rules
    eqInt, neInt,
    eqWord, neWord,
    eqChar, neChar,
    eqFloat, eqDouble,
    -- ** Monomorphic comparison operators
    gtInt, geInt, leInt, ltInt, compareInt, compareInt#,
    gtWord, geWord, leWord, ltWord, compareWord, compareWord#,

    -- * Functions over Bool
    (&&), (||), not,

    -- * Integer arithmetic
    divInt#, modInt#
 ) where

-- GHC.Magic is used in some derived instances
import GHC.Magic ()
import GHC.IntWord64
import GHC.Prim
import GHC.Tuple
import GHC.CString (unpackCString#)
import GHC.Types

#include "MachDeps.h"

infix  4  ==, /=, <, <=, >=, >
infixr 3  &&
infixr 2  ||

default ()              -- Double isn't available yet

-- | The syntax @?x :: a@ is desugared into @IP "x" a@
-- IP is declared very early, so that libraries can take
-- advantage of the implicit-call-stack feature
class IP (x :: Symbol) a | x -> a where
  ip :: a

{- $matching_overloaded_methods_in_rules

Matching on class methods (e.g. @(==)@) in rewrite rules tends to be a bit
fragile. For instance, consider this motivating example from the @bytestring@
library,

@
break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
breakByte :: Word8 -> ByteString -> (ByteString, ByteString)
\{\-\# RULES "break -> breakByte" forall a. break (== x) = breakByte x \#\-\}
@

Here we have two functions, with @breakByte@ providing an optimized
implementation of @break@ where the predicate is merely testing for equality
with a known @Word8@. As written, however, this rule will be quite fragile as
the @(==)@ class operation rule may rewrite the predicate before our @break@
rule has a chance to fire.

For this reason, most of the primitive types in @base@ have 'Eq' and 'Ord'
instances defined in terms of helper functions with inlinings delayed to phase
1. For instance, @Word8@\'s @Eq@ instance looks like,

@
instance Eq Word8 where
    (==) = eqWord8
    (/=) = neWord8

eqWord8, neWord8 :: Word8 -> Word8 -> Bool
eqWord8 (W8# x) (W8# y) = ...
neWord8 (W8# x) (W8# y) = ...
\{\-\# INLINE [1] eqWord8 \#\-\}
\{\-\# INLINE [1] neWord8 \#\-\}
@

This allows us to save our @break@ rule above by rewriting it to instead match
against @eqWord8@,

@
\{\-\# RULES "break -> breakByte" forall a. break (`eqWord8` x) = breakByte x \#\-\}
@

Currently this is only done for @('==')@, @('/=')@, @('<')@, @('<=')@, @('>')@,
and @('>=')@ for the types in "GHC.Word" and "GHC.Int".
-}

-- | The 'Eq' class defines equality ('==') and inequality ('/=').
-- All the basic datatypes exported by the "Prelude" are instances of 'Eq',
-- and 'Eq' may be derived for any datatype whose constituents are also
-- instances of 'Eq'.
--
-- The Haskell Report defines no laws for 'Eq'. However, '==' is customarily
-- expected to implement an equivalence relationship where two values comparing
-- equal are indistinguishable by "public" functions, with a "public" function
-- being one not allowing to see implementation details. For example, for a
-- type representing non-normalised natural numbers modulo 100, a "public"
-- function doesn't make the difference between 1 and 201. It is expected to
-- have the following properties:
--
-- [__Reflexivity__]: @x == x@ = 'True'
-- [__Symmetry__]: @x == y@ = @y == x@
-- [__Transitivity__]: if @x == y && y == z@ = 'True', then @x == z@ = 'True'
-- [__Substitutivity__]: if @x == y@ = 'True' and @f@ is a "public" function
-- whose return type is an instance of 'Eq', then @f x == f y@ = 'True'
-- [__Negation__]: @x /= y@ = @not (x == y)@
--
-- Minimal complete definition: either '==' or '/='.
--
class  Eq a  where
    (==), (/=)           :: a -> a -> Bool

    {-# INLINE (/=) #-}
    {-# INLINE (==) #-}
    x /= y               = not (x == y)
    x == y               = not (x /= y)
    {-# MINIMAL (==) | (/=) #-}

deriving instance Eq ()
deriving instance (Eq  a, Eq  b) => Eq  (a, b)
deriving instance (Eq  a, Eq  b, Eq  c) => Eq  (a, b, c)
deriving instance (Eq  a, Eq  b, Eq  c, Eq  d) => Eq  (a, b, c, d)
deriving instance (Eq  a, Eq  b, Eq  c, Eq  d, Eq  e) => Eq  (a, b, c, d, e)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)
               => Eq (a, b, c, d, e, f)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g)
               => Eq (a, b, c, d, e, f, g)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h)
               => Eq (a, b, c, d, e, f, g, h)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i)
               => Eq (a, b, c, d, e, f, g, h, i)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j)
               => Eq (a, b, c, d, e, f, g, h, i, j)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j, Eq k)
               => Eq (a, b, c, d, e, f, g, h, i, j, k)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j, Eq k, Eq l)
               => Eq (a, b, c, d, e, f, g, h, i, j, k, l)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m)
               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n)
               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o)
               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)

instance (Eq a) => Eq [a] where
    {-# SPECIALISE instance Eq [[Char]] #-}
    {-# SPECIALISE instance Eq [Char] #-}
    {-# SPECIALISE instance Eq [Int] #-}
    []     == []     = True
    (x:xs) == (y:ys) = x == y && xs == ys
    _xs    == _ys    = False

deriving instance Eq Module

instance Eq TrName where
    TrNameS a == TrNameS b = isTrue# (a `eqAddr#` b)
    a == b = toString a == toString b
      where
        toString (TrNameS s) = unpackCString# s
        toString (TrNameD s) = s

deriving instance Eq Bool
deriving instance Eq Ordering

instance Eq Word where
    (==) = eqWord
    (/=) = neWord

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] eqWord #-}
{-# INLINE [1] neWord #-}
eqWord, neWord :: Word -> Word -> Bool
(W# x) `eqWord` (W# y) = isTrue# (x `eqWord#` y)
(W# x) `neWord` (W# y) = isTrue# (x `neWord#` y)

-- See GHC.Classes#matching_overloaded_methods_in_rules
instance Eq Char where
    (==) = eqChar
    (/=) = neChar

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] eqChar #-}
{-# INLINE [1] neChar #-}
eqChar, neChar :: Char -> Char -> Bool
(C# x) `eqChar` (C# y) = isTrue# (x `eqChar#` y)
(C# x) `neChar` (C# y) = isTrue# (x `neChar#` y)

-- | Note that due to the presence of @NaN@, `Float`'s 'Eq' instance does not
-- satisfy reflexivity.
--
-- >>> 0/0 == (0/0 :: Float)
-- False
--
-- Also note that `Float`'s 'Eq' instance does not satisfy substitutivity:
--
-- >>> 0 == (-0 :: Float)
-- True
-- >>> recip 0 == recip (-0 :: Float)
-- False
instance Eq Float where
    (==) = eqFloat

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] eqFloat #-}
eqFloat :: Float -> Float -> Bool
(F# x) `eqFloat` (F# y) = isTrue# (x `eqFloat#` y)

-- | Note that due to the presence of @NaN@, `Double`'s 'Eq' instance does not
-- satisfy reflexivity.
--
-- >>> 0/0 == (0/0 :: Double)
-- False
--
-- Also note that `Double`'s 'Eq' instance does not satisfy substitutivity:
--
-- >>> 0 == (-0 :: Double)
-- True
-- >>> recip 0 == recip (-0 :: Double)
-- False
instance Eq Double where
    (==) = eqDouble

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] eqDouble #-}
eqDouble :: Double -> Double -> Bool
(D# x) `eqDouble` (D# y) = isTrue# (x ==## y)

instance Eq Int where
    (==) = eqInt
    (/=) = neInt

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] eqInt #-}
{-# INLINE [1] neInt #-}
eqInt, neInt :: Int -> Int -> Bool
(I# x) `eqInt` (I# y) = isTrue# (x ==# y)
(I# x) `neInt` (I# y) = isTrue# (x /=# y)

#if WORD_SIZE_IN_BITS < 64
instance Eq TyCon where
  (==) (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _)
       = isTrue# (hi1 `eqWord64#` hi2) && isTrue# (lo1 `eqWord64#` lo2)
instance Ord TyCon where
  compare (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _)
    | isTrue# (hi1 `gtWord64#` hi2) = GT
    | isTrue# (hi1 `ltWord64#` hi2) = LT
    | isTrue# (lo1 `gtWord64#` lo2) = GT
    | isTrue# (lo1 `ltWord64#` lo2) = LT
    | True                = EQ
#else
instance Eq TyCon where
  (==) (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _)
       = isTrue# (hi1 `eqWord#` hi2) && isTrue# (lo1 `eqWord#` lo2)
instance Ord TyCon where
  compare (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _)
    | isTrue# (hi1 `gtWord#` hi2) = GT
    | isTrue# (hi1 `ltWord#` hi2) = LT
    | isTrue# (lo1 `gtWord#` lo2) = GT
    | isTrue# (lo1 `ltWord#` lo2) = LT
    | True              = EQ
#endif

-- | The 'Ord' class is used for totally ordered datatypes.
--
-- Instances of 'Ord' can be derived for any user-defined datatype whose
-- constituent types are in 'Ord'. The declared order of the constructors in
-- the data declaration determines the ordering in derived 'Ord' instances. The
-- 'Ordering' datatype allows a single comparison to determine the precise
-- ordering of two objects.
--
-- The Haskell Report defines no laws for 'Ord'. However, '<=' is customarily
-- expected to implement a non-strict partial order and have the following
-- properties:
--
-- [__Transitivity__]: if @x <= y && y <= z@ = 'True', then @x <= z@ = 'True'
-- [__Reflexivity__]: @x <= x@ = 'True'
-- [__Antisymmetry__]: if @x <= y && y <= x@ = 'True', then @x == y@ = 'True'
--
-- Note that the following operator interactions are expected to hold:
--
-- 1. @x >= y@ = @y <= x@
-- 2. @x < y@ = @x <= y && x /= y@
-- 3. @x > y@ = @y < x@
-- 4. @x < y@ = @compare x y == LT@
-- 5. @x > y@ = @compare x y == GT@
-- 6. @x == y@ = @compare x y == EQ@
-- 7. @min x y == if x <= y then x else y@ = 'True'
-- 8. @max x y == if x >= y then x else y@ = 'True'
--
-- Minimal complete definition: either 'compare' or '<='.
-- Using 'compare' can be more efficient for complex types.
--
class  (Eq a) => Ord a  where
    compare              :: a -> a -> Ordering
    (<), (<=), (>), (>=) :: a -> a -> Bool
    max, min             :: a -> a -> a

    compare x y = if x == y then EQ
                  -- NB: must be '<=' not '<' to validate the
                  -- above claim about the minimal things that
                  -- can be defined for an instance of Ord:
                  else if x <= y then LT
                  else GT

    x <  y = case compare x y of { LT -> True;  _ -> False }
    x <= y = case compare x y of { GT -> False; _ -> True }
    x >  y = case compare x y of { GT -> True;  _ -> False }
    x >= y = case compare x y of { LT -> False; _ -> True }

        -- These two default methods use '<=' rather than 'compare'
        -- because the latter is often more expensive
    max x y = if x <= y then y else x
    min x y = if x <= y then x else y
    {-# MINIMAL compare | (<=) #-}

deriving instance Ord ()
deriving instance (Ord a, Ord b) => Ord (a, b)
deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c)
deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f)
               => Ord (a, b, c, d, e, f)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g)
               => Ord (a, b, c, d, e, f, g)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h)
               => Ord (a, b, c, d, e, f, g, h)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i)
               => Ord (a, b, c, d, e, f, g, h, i)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j)
               => Ord (a, b, c, d, e, f, g, h, i, j)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j, Ord k)
               => Ord (a, b, c, d, e, f, g, h, i, j, k)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j, Ord k, Ord l)
               => Ord (a, b, c, d, e, f, g, h, i, j, k, l)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m)
               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n)
               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o)
               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)

instance (Ord a) => Ord [a] where
    {-# SPECIALISE instance Ord [[Char]] #-}
    {-# SPECIALISE instance Ord [Char] #-}
    {-# SPECIALISE instance Ord [Int] #-}
    compare []     []     = EQ
    compare []     (_:_)  = LT
    compare (_:_)  []     = GT
    compare (x:xs) (y:ys) = case compare x y of
                                EQ    -> compare xs ys
                                other -> other

deriving instance Ord Bool
deriving instance Ord Ordering

-- We don't use deriving for Ord Char, because for Ord the derived
-- instance defines only compare, which takes two primops.  Then
-- '>' uses compare, and therefore takes two primops instead of one.
instance Ord Char where
    (C# c1) >  (C# c2) = isTrue# (c1 `gtChar#` c2)
    (C# c1) >= (C# c2) = isTrue# (c1 `geChar#` c2)
    (C# c1) <= (C# c2) = isTrue# (c1 `leChar#` c2)
    (C# c1) <  (C# c2) = isTrue# (c1 `ltChar#` c2)

-- | Note that due to the presence of @NaN@, `Float`'s 'Ord' instance does not
-- satisfy reflexivity.
--
-- >>> 0/0 <= (0/0 :: Float)
-- False
--
-- Also note that, due to the same, `Ord`'s operator interactions are not
-- respected by `Float`'s instance:
--
-- >>> (0/0 :: Float) > 1
-- False
-- >>> compare (0/0 :: Float) 1
-- GT
instance Ord Float where
    (F# x) `compare` (F# y)
        = if      isTrue# (x `ltFloat#` y) then LT
          else if isTrue# (x `eqFloat#` y) then EQ
          else                                  GT

    (F# x) <  (F# y) = isTrue# (x `ltFloat#` y)
    (F# x) <= (F# y) = isTrue# (x `leFloat#` y)
    (F# x) >= (F# y) = isTrue# (x `geFloat#` y)
    (F# x) >  (F# y) = isTrue# (x `gtFloat#` y)

-- | Note that due to the presence of @NaN@, `Double`'s 'Ord' instance does not
-- satisfy reflexivity.
--
-- >>> 0/0 <= (0/0 :: Double)
-- False
--
-- Also note that, due to the same, `Ord`'s operator interactions are not
-- respected by `Double`'s instance:
--
-- >>> (0/0 :: Double) > 1
-- False
-- >>> compare (0/0 :: Double) 1
-- GT
instance Ord Double where
    (D# x) `compare` (D# y)
        = if      isTrue# (x <##  y) then LT
          else if isTrue# (x ==## y) then EQ
          else                            GT

    (D# x) <  (D# y) = isTrue# (x <##  y)
    (D# x) <= (D# y) = isTrue# (x <=## y)
    (D# x) >= (D# y) = isTrue# (x >=## y)
    (D# x) >  (D# y) = isTrue# (x >##  y)

instance Ord Int where
    compare = compareInt
    (<)     = ltInt
    (<=)    = leInt
    (>=)    = geInt
    (>)     = gtInt

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] gtInt #-}
{-# INLINE [1] geInt #-}
{-# INLINE [1] ltInt #-}
{-# INLINE [1] leInt #-}
gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool
(I# x) `gtInt` (I# y) = isTrue# (x >#  y)
(I# x) `geInt` (I# y) = isTrue# (x >=# y)
(I# x) `ltInt` (I# y) = isTrue# (x <#  y)
(I# x) `leInt` (I# y) = isTrue# (x <=# y)

compareInt :: Int -> Int -> Ordering
(I# x#) `compareInt` (I# y#) = compareInt# x# y#

compareInt# :: Int# -> Int# -> Ordering
compareInt# x# y#
    | isTrue# (x# <#  y#) = LT
    | isTrue# (x# ==# y#) = EQ
    | True                = GT

instance Ord Word where
    compare = compareWord
    (<)     = ltWord
    (<=)    = leWord
    (>=)    = geWord
    (>)     = gtWord

-- See GHC.Classes#matching_overloaded_methods_in_rules
{-# INLINE [1] gtWord #-}
{-# INLINE [1] geWord #-}
{-# INLINE [1] ltWord #-}
{-# INLINE [1] leWord #-}
gtWord, geWord, ltWord, leWord :: Word -> Word -> Bool
(W# x) `gtWord` (W# y) = isTrue# (x `gtWord#` y)
(W# x) `geWord` (W# y) = isTrue# (x `geWord#` y)
(W# x) `ltWord` (W# y) = isTrue# (x `ltWord#` y)
(W# x) `leWord` (W# y) = isTrue# (x `leWord#` y)

compareWord :: Word -> Word -> Ordering
(W# x#) `compareWord` (W# y#) = compareWord# x# y#

compareWord# :: Word# -> Word# -> Ordering
compareWord# x# y#
    | isTrue# (x# `ltWord#` y#) = LT
    | isTrue# (x# `eqWord#` y#) = EQ
    | True                      = GT

-- OK, so they're technically not part of a class...:

-- Boolean functions

-- | Boolean \"and\"
(&&)                    :: Bool -> Bool -> Bool
True  && x              =  x
False && _              =  False

-- | Boolean \"or\"
(||)                    :: Bool -> Bool -> Bool
True  || _              =  True
False || x              =  x

-- | Boolean \"not\"
not                     :: Bool -> Bool
not True                =  False
not False               =  True

------------------------------------------------------------------------
-- These don't really belong here, but we don't have a better place to
-- put them

-- These functions have built-in rules.
{-# NOINLINE [0] divInt# #-}
{-# NOINLINE [0] modInt# #-}
divInt# :: Int# -> Int# -> Int#
x# `divInt#` y#
        -- Be careful NOT to overflow if we do any additional arithmetic
        -- on the arguments...  the following  previous version of this
        -- code has problems with overflow:
--    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
--    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
    =      if isTrue# (x# ># 0#) && isTrue# (y# <# 0#) then ((x# -# 1#) `quotInt#` y#) -# 1#
      else if isTrue# (x# <# 0#) && isTrue# (y# ># 0#) then ((x# +# 1#) `quotInt#` y#) -# 1#
      else x# `quotInt#` y#

modInt# :: Int# -> Int# -> Int#
x# `modInt#` y#
    = if isTrue# (x# ># 0#) && isTrue# (y# <# 0#) ||
         isTrue# (x# <# 0#) && isTrue# (y# ># 0#)
      then if isTrue# (r# /=# 0#) then r# +# y# else 0#
      else r#
    where
    !r# = x# `remInt#` y#

{- *************************************************************
*                                                              *
*               Constraint tuples                              *
*                                                              *
************************************************************* -}

class ()
class (c1, c2)     => (c1, c2)
class (c1, c2, c3) => (c1, c2, c3)
class (c1, c2, c3, c4) => (c1, c2, c3, c4)
class (c1, c2, c3, c4, c5) => (c1, c2, c3, c4, c5)
class (c1, c2, c3, c4, c5, c6) => (c1, c2, c3, c4, c5, c6)
class (c1, c2, c3, c4, c5, c6, c7) => (c1, c2, c3, c4, c5, c6, c7)
class (c1, c2, c3, c4, c5, c6, c7, c8) => (c1, c2, c3, c4, c5, c6, c7, c8)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17,c18)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60, c61)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60, c61)
class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60, c61, c62)
   => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16,
       c17, c18, c19, c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
       c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44,
       c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58,
       c59, c60, c61, c62)