{-# 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 = unsafePerformIO Counter.new

toBytePtr :: LLVM.Ptr a -> Ptr Word8
toBytePtr = castPtr . LLVM.uncheckedToPtr

format :: Marshal.C a => a -> IO String
format a =
   Marshal.with a $ \ptr ->
      fmap (concatMap (\byte ->
               (if byte<16 then ('0':) else id) (showHex byte ""))) $
      mapM peek
         (List.take (sizeOf a) $
          List.iterate (flip advancePtr 1) $
          toBytePtr ptr)

dump :: Marshal.C a => FilePath -> a -> Counter.T Dump -> IO ()
dump path a cnt =
   IO.withBinaryFile
      (path ++ Counter.format 3 cnt ++ ".dump")
      IO.WriteMode $ \h ->
   Marshal.with a $ \ptr ->
   IO.hPutBuf h (toBytePtr ptr) (sizeOf 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 a f =
   Marshal.with a $ \ptr -> do
      content <-
         mapM
            (peekByteOff $ toBytePtr ptr)
            (takeWhile (< sizeOf a)
               [0, Store.sizeOf (undefined :: ArrayElem) ..])
          :: IO [ArrayElem]
      return $
         fromMaybe (error "Debug.Storable.withConstArray: length must always be non-negative") $
         TypeNum.reifyNatural (fromIntegral (length content))
            (\n ->
               let makeArray ::
                      TypeNum.Natural n =>
                      Proxy n -> [ConstValue ArrayElem] ->
                      ConstValue (Array n ArrayElem)
                   makeArray _ = LLVM.constArray
               in  f (makeArray n (map constOf content)))


traceMalloc :: Marshal.C a => a -> Int -> Ptr a -> IO (Ptr a)
traceMalloc a size ptr = do
   when False $ putStrLn $
      showString "%addr" . shows ptr .
      showString " = call float* @malloc(i8* getelementptr (i8* null, i32 " .
      shows size .
      showString "))   ; alignment " . shows (alignment a) $
      ""
   return ptr

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

sizeOf, alignment :: (Marshal.C a) => a -> Int
sizeOf = EE.sizeOf . proxyFromData

alignment = EE.alignment . proxyFromData