{-# LINE 1 "GHC/Exts/Heap/Utils.hsc" #-}
{-# LANGUAGE CPP, MagicHash #-}

module GHC.Exts.Heap.Utils (
    dataConNames
    ) where



import Prelude -- See note [Why do we import Prelude here?]
import GHC.Exts.Heap.Constants
import GHC.Exts.Heap.InfoTable

import Data.Char
import Data.List
import Foreign
import GHC.CString
import GHC.Exts

{- To find the string in the constructor's info table we need to consider
      the layout of info tables relative to the entry code for a closure.

      An info table can be next to the entry code for the closure, or it can
      be separate. The former (faster) is used in registerised versions of ghc,
      and the latter (portable) is for non-registerised versions.

      The diagrams below show where the string is to be found relative to
      the normal info table of the closure.

      1) Tables next to code:

         --------------
         |            |   <- pointer to the start of the string
         --------------
         |            |   <- the (start of the) info table structure
         |            |
         |            |
         --------------
         | entry code |
         |    ....    |

         In this case the pointer to the start of the string can be found in
         the memory location _one word before_ the first entry in the normal info
         table.

      2) Tables NOT next to code:

                                 --------------
         info table structure -> |     *------------------> --------------
                                 |            |             | entry code |
                                 |            |             |    ....    |
                                 --------------
         ptr to start of str ->  |            |
                                 --------------

         In this case the pointer to the start of the string can be found
         in the memory location: info_table_ptr + info_table_size
-}

-- Given a ptr to an 'StgInfoTable' for a data constructor
-- return (Package, Module, Name)
dataConNames :: Ptr StgInfoTable -> IO (String, String, String)
dataConNames :: Ptr StgInfoTable -> IO (String, String, String)
dataConNames Ptr StgInfoTable
ptr = do
    Ptr Word8
conDescAddress <- IO (Ptr Word8)
getConDescAddress
    (String, String, String) -> IO (String, String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, String, String) -> IO (String, String, String))
-> (String, String, String) -> IO (String, String, String)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> (String, String, String)
parse Ptr Word8
conDescAddress
  where
    -- Retrieve the con_desc field address pointing to
    -- 'Package:Module.Name' string
    getConDescAddress :: IO (Ptr Word8)
    getConDescAddress :: IO (Ptr Word8)
getConDescAddress

{-# LINE 71 "GHC/Exts/Heap/Utils.hsc" #-}
      = do
        offsetToString <- peek (ptr `plusPtr` negate wORD_SIZE)
        pure $ (ptr `plusPtr` stdInfoTableSizeB)
                    `plusPtr` fromIntegral (offsetToString :: Int32)

{-# LINE 78 "GHC/Exts/Heap/Utils.hsc" #-}

    stdInfoTableSizeW :: Int
    -- The size of a standard info table varies with profiling/ticky etc,
    -- so we can't get it from Constants
    -- It must vary in sync with mkStdInfoTable
    stdInfoTableSizeW :: Int
stdInfoTableSizeW
      = Int
size_fixed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_prof
      where
        size_fixed :: Int
size_fixed = Int
2  -- layout, type
#if defined(PROFILING)
        size_prof = 2
#else
        size_prof :: Int
size_prof = Int
0
#endif

    stdInfoTableSizeB :: Int
    stdInfoTableSizeB :: Int
stdInfoTableSizeB = Int
stdInfoTableSizeW Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
wORD_SIZE

-- parsing names is a little bit fiddly because we have a string in the form:
-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
-- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
-- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
-- this is not the conventional way of writing Haskell names. We stick with
-- convention, even though it makes the parsing code more troublesome.
-- Warning: this code assumes that the string is well formed.
parse :: Ptr Word8 -> (String, String, String)
parse :: Ptr Word8 -> (String, String, String)
parse (Ptr Addr#
addr) = if Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) ([Int] -> Bool) -> ([String] -> [Int]) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> [String] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [String
p,String
m,String
occ]
                     then ([], [], String
input)
                     else (String
p, String
m, String
occ)
  where
    input :: String
input = Addr# -> String
unpackCStringUtf8# Addr#
addr
    (String
p, String
rest1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
input
    (String
m, String
occ)
        = (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
modWords, String
occWord)
        where
        ([String]
modWords, String
occWord) =
            if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rest1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 --  XXXXXXXXx YUKX
                --then error "getConDescAddress:parse:length rest1 < 1"
                then [String] -> String -> ([String], String)
parseModOcc [] []
                else [String] -> String -> ([String], String)
parseModOcc [] (String -> String
forall a. [a] -> [a]
tail String
rest1)
    -- We only look for dots if str could start with a module name,
    -- i.e. if it starts with an upper case character.
    -- Otherwise we might think that "X.:->" is the module name in
    -- "X.:->.+", whereas actually "X" is the module name and
    -- ":->.+" is a constructor name.
    parseModOcc :: [String] -> String -> ([String], String)
    parseModOcc :: [String] -> String -> ([String], String)
parseModOcc [String]
acc str :: String
str@(Char
c : String
_)
        | Char -> Bool
isUpper Char
c =
            case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
str of
                (String
top, []) -> ([String]
acc, String
top)
                (String
top, Char
_:String
bot) -> [String] -> String -> ([String], String)
parseModOcc (String
top String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc) String
bot
    parseModOcc [String]
acc String
str = ([String]
acc, String
str)