{-# 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
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