{-# LANGUAGE Rank2Types #-}
module LLVM.DSL.Debug.Marshal where

import qualified LLVM.DSL.Debug.Counter as Counter

import qualified Type.Data.Num.Decimal as TypeNum
import Type.Base.Proxy (Proxy)

import qualified LLVM.Extra.Marshal as Marshal
import qualified LLVM.ExecutionEngine as EE
import qualified LLVM.Util.Proxy as LP
import qualified LLVM.Core as LLVM
import LLVM.Core (Array, ConstValue, constOf)

import qualified System.IO as IO
import Numeric (showHex)

import qualified Data.IORef as IORef
import qualified Data.List as List

import qualified Foreign.Storable as Store
import Foreign.Marshal.Array (advancePtr)
import Foreign.Storable (peek, peekByteOff)
import Foreign.Ptr (Ptr, castPtr)
import Data.Word (Word8, Word32)
import System.IO.Unsafe (unsafePerformIO)

import Control.Monad (when)
import Data.Maybe (fromMaybe)


data Dump = Dump

dumpCounter :: IORef.IORef (Counter.T Dump)
dumpCounter :: IORef (T Dump)
dumpCounter = IO (IORef (T Dump)) -> IORef (T Dump)
forall a. IO a -> a
unsafePerformIO IO (IORef (T Dump))
forall ident. IO (IORef (T ident))
Counter.new

toBytePtr :: LLVM.Ptr a -> Ptr Word8
toBytePtr :: forall a. Ptr a -> Ptr Word8
toBytePtr = Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Ptr Word8) -> (Ptr a -> Ptr a) -> Ptr a -> Ptr Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Ptr a
forall a. Ptr a -> Ptr a
LLVM.uncheckedToPtr

format :: Marshal.C a => a -> IO String
format :: forall a. C a => a -> IO String
format a
a =
   a -> (Ptr (Struct a) -> IO String) -> IO String
forall a b. C a => a -> (Ptr (Struct a) -> IO b) -> IO b
Marshal.with a
a ((Ptr (Struct a) -> IO String) -> IO String)
-> (Ptr (Struct a) -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Ptr (Struct a)
ptr ->
      ([Word8] -> String) -> IO [Word8] -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word8 -> String) -> [Word8] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Word8
byte ->
               (if Word8
byteWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<Word8
16 then (Char
'0'Char -> String -> String
forall a. a -> [a] -> [a]
:) else String -> String
forall a. a -> a
id) (Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
byte String
""))) (IO [Word8] -> IO String) -> IO [Word8] -> IO String
forall a b. (a -> b) -> a -> b
$
      (Ptr Word8 -> IO Word8) -> [Ptr Word8] -> IO [Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek
         (Int -> [Ptr Word8] -> [Ptr Word8]
forall a. Int -> [a] -> [a]
List.take (a -> Int
forall a. C a => a -> Int
sizeOf a
a) ([Ptr Word8] -> [Ptr Word8]) -> [Ptr Word8] -> [Ptr Word8]
forall a b. (a -> b) -> a -> b
$
          (Ptr Word8 -> Ptr Word8) -> Ptr Word8 -> [Ptr Word8]
forall a. (a -> a) -> a -> [a]
List.iterate ((Ptr Word8 -> Int -> Ptr Word8) -> Int -> Ptr Word8 -> Ptr Word8
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Int -> Ptr Word8
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Int
1) (Ptr Word8 -> [Ptr Word8]) -> Ptr Word8 -> [Ptr Word8]
forall a b. (a -> b) -> a -> b
$
          Ptr (Struct a) -> Ptr Word8
forall a. Ptr a -> Ptr Word8
toBytePtr Ptr (Struct a)
ptr)

dump :: Marshal.C a => FilePath -> a -> Counter.T Dump -> IO ()
dump :: forall a. C a => String -> a -> T Dump -> IO ()
dump String
path a
a T Dump
cnt =
   String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withBinaryFile
      (String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> T Dump -> String
forall ident. Int -> T ident -> String
Counter.format Int
3 T Dump
cnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dump")
      IOMode
IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
   a -> (Ptr (Struct a) -> IO ()) -> IO ()
forall a b. C a => a -> (Ptr (Struct a) -> IO b) -> IO b
Marshal.with a
a ((Ptr (Struct a) -> IO ()) -> IO ())
-> (Ptr (Struct a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Struct a)
ptr ->
   Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
IO.hPutBuf Handle
h (Ptr (Struct a) -> Ptr Word8
forall a. Ptr a -> Ptr Word8
toBytePtr Ptr (Struct a)
ptr) (a -> Int
forall a. C a => a -> Int
sizeOf a
a)


type ArrayElem = Word32

{-
Unfortunately, you cannot 'alloca' or 'malloc' the constructed array,
because an IsSized instance is missing.
We may employ a specialised reifyIntegral for this purpose.
-}
withConstArray ::
   Marshal.C a =>
   a ->
   (forall n. TypeNum.Natural n => ConstValue (Array n ArrayElem) -> b) ->
   IO b
withConstArray :: forall a b.
C a =>
a
-> (forall n. Natural n => ConstValue (Array n ArrayElem) -> b)
-> IO b
withConstArray a
a forall n. Natural n => ConstValue (Array n ArrayElem) -> b
f =
   a -> (Ptr (Struct a) -> IO b) -> IO b
forall a b. C a => a -> (Ptr (Struct a) -> IO b) -> IO b
Marshal.with a
a ((Ptr (Struct a) -> IO b) -> IO b)
-> (Ptr (Struct a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (Struct a)
ptr -> do
      [ArrayElem]
content <-
         (Int -> IO ArrayElem) -> [Int] -> IO [ArrayElem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
            (Ptr Word8 -> Int -> IO ArrayElem
forall b. Ptr b -> Int -> IO ArrayElem
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (Ptr Word8 -> Int -> IO ArrayElem)
-> Ptr Word8 -> Int -> IO ArrayElem
forall a b. (a -> b) -> a -> b
$ Ptr (Struct a) -> Ptr Word8
forall a. Ptr a -> Ptr Word8
toBytePtr Ptr (Struct a)
ptr)
            ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. C a => a -> Int
sizeOf a
a)
               [Int
0, ArrayElem -> Int
forall a. Storable a => a -> Int
Store.sizeOf (ArrayElem
forall a. HasCallStack => a
undefined :: ArrayElem) ..])
          :: IO [ArrayElem]
      b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$
         b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe (String -> b
forall a. HasCallStack => String -> a
error String
"Debug.Storable.withConstArray: length must always be non-negative") (Maybe b -> b) -> Maybe b -> b
forall a b. (a -> b) -> a -> b
$
         Integer -> (forall s. Natural s => Proxy s -> b) -> Maybe b
forall a.
Integer -> (forall s. Natural s => Proxy s -> a) -> Maybe a
TypeNum.reifyNatural (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ArrayElem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArrayElem]
content))
            (\Proxy s
n ->
               let makeArray ::
                      TypeNum.Natural n =>
                      Proxy n -> [ConstValue ArrayElem] ->
                      ConstValue (Array n ArrayElem)
                   makeArray :: forall n.
Natural n =>
Proxy n -> [ConstValue ArrayElem] -> ConstValue (Array n ArrayElem)
makeArray Proxy n
_ = [ConstValue ArrayElem] -> ConstValue (Array n ArrayElem)
forall a n.
(IsSized a, Natural n) =>
[ConstValue a] -> ConstValue (Array n a)
LLVM.constArray
               in  ConstValue (Array s ArrayElem) -> b
forall n. Natural n => ConstValue (Array n ArrayElem) -> b
f (Proxy s -> [ConstValue ArrayElem] -> ConstValue (Array s ArrayElem)
forall n.
Natural n =>
Proxy n -> [ConstValue ArrayElem] -> ConstValue (Array n ArrayElem)
makeArray Proxy s
n ((ArrayElem -> ConstValue ArrayElem)
-> [ArrayElem] -> [ConstValue ArrayElem]
forall a b. (a -> b) -> [a] -> [b]
map ArrayElem -> ConstValue ArrayElem
forall a. IsConst a => a -> ConstValue a
constOf [ArrayElem]
content)))


traceMalloc :: Marshal.C a => a -> Int -> Ptr a -> IO (Ptr a)
traceMalloc :: forall a. C a => a -> Int -> Ptr a -> IO (Ptr a)
traceMalloc a
a Int
size Ptr a
ptr = do
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
False (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> String
showString String
"%addr" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> String -> String
forall a. Show a => a -> String -> String
shows Ptr a
ptr (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      String -> String -> String
showString String
" = call float* @malloc(i8* getelementptr (i8* null, i32 " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
size (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      String -> String -> String
showString String
"))   ; alignment " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows (a -> Int
forall a. C a => a -> Int
alignment a
a) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      String
""
   Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

proxyFromData :: a -> LP.Proxy (Marshal.Struct a)
proxyFromData :: forall a. a -> Proxy (Struct a)
proxyFromData a
_ = Proxy (Struct (ValueOf a))
forall a. Proxy a
LP.Proxy

sizeOf, alignment :: (Marshal.C a) => a -> Int
sizeOf :: forall a. C a => a -> Int
sizeOf = Proxy (Struct (ValueOf a)) -> Int
forall a. IsType a => Proxy a -> Int
EE.sizeOf (Proxy (Struct (ValueOf a)) -> Int)
-> (a -> Proxy (Struct (ValueOf a))) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Proxy (Struct (ValueOf a))
forall a. a -> Proxy (Struct a)
proxyFromData

alignment :: forall a. C a => a -> Int
alignment = Proxy (Struct (ValueOf a)) -> Int
forall a. IsType a => Proxy a -> Int
EE.alignment (Proxy (Struct (ValueOf a)) -> Int)
-> (a -> Proxy (Struct (ValueOf a))) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Proxy (Struct (ValueOf a))
forall a. a -> Proxy (Struct a)
proxyFromData