Memory.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module LLVM.Extra.Memory (
   C(load, store, decompose, compose), modify, castStorablePtr,
   Record, Element, element,
   loadRecord, storeRecord, decomposeRecord, composeRecord,
   loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,
   ) where

import LLVM.Extra.Class (MakeValueTuple, Undefined, )

import qualified LLVM.Core as LLVM
import LLVM.Core
   (Struct, getElementPtr0,
    extractvalue, insertvalue,
    Value, -- valueOf, Vector,
    IsType, IsSized,
    CodeGenFunction, )
import LLVM.Util.Loop (Phi, )

-- import qualified Data.TypeLevel.Num as TypeNum
import Data.TypeLevel.Num (d0, d1, d2, )

import Foreign.Ptr (Ptr, castPtr, )

import Control.Monad (ap, )
import Control.Applicative (pure, liftA2, liftA3, )
import qualified Control.Applicative as App

import Data.Tuple.HT (fst3, snd3, thd3, )


{- |
An implementation of both 'MakeValueTuple' and 'Memory.C'
must ensure that @haskellValue@ is compatible with @llvmStruct@.
That is, writing and reading @llvmStruct@ by LLVM
must be the same as accessing @haskellValue@ by 'Storable' methods.
ToDo: In future we may also require Storable constraint for llvmStruct.

We use a functional dependency in order to let type inference work nicely.
-}
class (Phi llvmValue, Undefined llvmValue, IsType llvmStruct) =>
      C llvmValue llvmStruct | llvmValue -> llvmStruct where
   load :: Value (Ptr llvmStruct) -> CodeGenFunction r llvmValue
   load ptr  =  decompose =<< LLVM.load ptr
   store :: llvmValue -> Value (Ptr llvmStruct) -> CodeGenFunction r ()
   store r ptr  =  flip LLVM.store ptr =<< compose r
   decompose :: Value llvmStruct -> CodeGenFunction r llvmValue
   compose :: llvmValue -> CodeGenFunction r (Value llvmStruct)

modify ::
   (C llvmValue llvmStruct) =>
   (llvmValue -> CodeGenFunction r llvmValue) ->
   Value (Ptr llvmStruct) -> CodeGenFunction r ()
modify f ptr =
   flip store ptr =<< f =<< load ptr


type Record r o v = Element r o v v

data Element r o v x =
   Element {
      loadElement :: Value (Ptr o) -> CodeGenFunction r x,
      storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (),
      extractElement :: Value o -> CodeGenFunction r x,
      insertElement :: v -> Value o -> CodeGenFunction r (Value o)
         -- State.Monoid
   }

element ::
   (C x llvmStruct,
    LLVM.GetValue o n llvmStruct,
    LLVM.GetElementPtr o (n, ()) llvmStruct) =>
   (v -> x) -> n -> Element r o v x
element field n =
   Element {
      loadElement = \ptr -> load =<< getElementPtr0 ptr (n, ()),
      storeElement = \ptr v -> store (field v) =<< getElementPtr0 ptr (n, ()),
      extractElement = \o -> decompose =<< extractvalue o n,
      insertElement = \v o -> flip (insertvalue o) n =<< compose (field v)
   }

instance Functor (Element r o v) where
   fmap f m =
      Element {
         loadElement = fmap f . loadElement m,
         storeElement = storeElement m,
         extractElement = fmap f . extractElement m,
         insertElement = insertElement m
      }

instance App.Applicative (Element r o v) where
   pure x =
      Element {
         loadElement = \ _ptr -> return x,
         storeElement = \ _ptr _v -> return (),
         extractElement = \ _o -> return x,
         insertElement = \ _v o -> return o
      }
   f <*> x =
      Element {
         loadElement = \ptr -> loadElement f ptr `ap` loadElement x ptr,
         storeElement = \ptr y -> storeElement f ptr y >> storeElement x ptr y,
         extractElement = \o -> extractElement f o `ap` extractElement x o,
         insertElement = \y o -> insertElement f y o >>= insertElement x y
      }


loadRecord ::
   Record r o llvmValue ->
   Value (Ptr o) -> CodeGenFunction r llvmValue
loadRecord = loadElement

storeRecord ::
   Record r o llvmValue ->
   llvmValue -> Value (Ptr o) -> CodeGenFunction r ()
storeRecord m y ptr = storeElement m ptr y

decomposeRecord ::
   Record r o llvmValue ->
   Value o -> CodeGenFunction r llvmValue
decomposeRecord m =
   extractElement m

composeRecord ::
   (IsType o) =>
   Record r o llvmValue ->
   llvmValue -> CodeGenFunction r (Value o)
composeRecord m v =
   insertElement m v (LLVM.value LLVM.undef)



pair ::
   (C al as, C bl bs,
    IsSized as sas, IsSized bs sbs) =>
   Record r (Struct (as, (bs, ()))) (al, bl)
pair =
   liftA2 (,)
      (element fst d0)
      (element snd d1)

instance
      (C al as, C bl bs,
       IsSized as sas, IsSized bs sbs) =>
      C (al, bl) (Struct (as, (bs, ()))) where
   load = loadRecord pair
   store = storeRecord pair
   decompose = decomposeRecord pair
   compose = composeRecord pair


triple ::
   (C al as, C bl bs, C cl cs,
    IsSized as sas, IsSized bs sbs, IsSized cs scs) =>
   Record r (Struct (as, (bs, (cs, ())))) (al, bl, cl)
triple =
   liftA3 (,,)
      (element fst3 d0)
      (element snd3 d1)
      (element thd3 d2)

instance
      (C al as, C bl bs, C cl cs,
       IsSized as sas, IsSized bs sbs, IsSized cs scs) =>
      C (al, bl, cl) (Struct (as, (bs, (cs, ())))) where
   load = loadRecord triple
   store = storeRecord triple
   decompose = decomposeRecord triple
   compose = composeRecord triple


{- |
ToDo:
This is dangerous because LLVM uses one bit for Bool representation,
and I think one byte in memory,
whereas Storable uses 4 byte and 4 byte alignment.
We should define a sub-class of IsFirstClass for all compatible types,
and make this a super-class of this instance.
-}
instance (LLVM.IsFirstClass a) => C (Value a) a where
   load = LLVM.load
   store = LLVM.store
   decompose = return
   compose = return

instance C () (Struct ()) where
   load _ = return ()
   store _ _ = return ()
   decompose _ = return ()
   compose _ = return (LLVM.value LLVM.undef)

castStorablePtr ::
   (MakeValueTuple haskellValue llvmValue, C llvmValue llvmStruct) =>
   Ptr haskellValue -> Ptr llvmStruct
castStorablePtr = castPtr



loadNewtype ::
   (C a o) =>
   (a -> llvmValue) ->
   Value (Ptr o) -> CodeGenFunction r llvmValue
loadNewtype wrap ptr =
   fmap wrap $ load ptr

storeNewtype ::
   (C a o) =>
   (llvmValue -> a) ->
   llvmValue -> Value (Ptr o) -> CodeGenFunction r ()
storeNewtype unwrap y ptr =
   store (unwrap y) ptr

decomposeNewtype ::
   (C a o) =>
   (a -> llvmValue) ->
   Value o -> CodeGenFunction r llvmValue
decomposeNewtype wrap y =
   fmap wrap $ decompose y

composeNewtype ::
   (C a o) =>
   (llvmValue -> a) ->
   llvmValue -> CodeGenFunction r (Value o)
composeNewtype unwrap y =
   compose (unwrap y)