Storable.hs

{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Debug.Storable where

import qualified Synthesizer.LLVM.Debug.Counter as Counter

import qualified Types.Data.Num as TypeNum
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.Marshal.Utils as Marshal
import Foreign.Marshal.Array (advancePtr, )
import Foreign.Storable (Storable, peek, peekByteOff, sizeOf, alignment, )
import Foreign.Ptr (Ptr, castPtr, )
import Data.Word (Word8, Word32, )
import qualified System.Unsafe as Unsafe

import qualified Control.Monad.Trans.Reader as R
import Control.Monad (when, )
import Data.Maybe (fromMaybe, )


data Dump = Dump

dumpCounter :: IORef.IORef (Counter.T Dump)
dumpCounter =
   Unsafe.performIO $ Counter.new

format :: Storable 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) $
          (castPtr ptr :: Ptr Word8))

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


traceMalloc :: Storable 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