ddc-core-llvm-0.4.2.1: DDC/Core/Llvm/Convert/Exp/PrimStore.hs
module DDC.Core.Llvm.Convert.Exp.PrimStore
(convPrimStore)
where
import DDC.Llvm.Syntax
import DDC.Core.Llvm.Convert.Exp.Atom
import DDC.Core.Llvm.Convert.Type
import DDC.Core.Llvm.Convert.Context
import DDC.Core.Llvm.Convert.Base
import DDC.Core.Llvm.Metadata.Tbaa
import DDC.Core.Llvm.Runtime
import DDC.Core.Salt.Platform
import DDC.Core.Exp.Generic.BindStruct ()
import Data.Sequence (Seq)
import qualified DDC.Core.Salt as A
import qualified Data.Sequence as Seq
-- | Convert a primitive store operation to LLVM,
-- or Nothing if this does not look like such an operation.
convPrimStore
:: Context -- ^ Context of the conversion.
-> Maybe Var -- ^ Assign result to this var.
-> A.PrimOp -- ^ Prim to call.
-> [A.Arg] -- ^ Arguments to prim.
-> Maybe (ConvertM (Seq AnnotInstr))
convPrimStore ctx mdst p as
= let pp = contextPlatform ctx
mdsup = contextMDSuper ctx
kenv = contextKindEnv ctx
atom = mconvAtom ctx
atomsR as' = sequence $ map (mconvArg ctx) as'
in case p of
-- Get the size in bytes of some primitive type.
A.PrimStore A.PrimStoreSize
| [A.RType t] <- as
, Just vDst <- mdst
-> Just $ do
t' <- convertType pp kenv t
-- Bool# is only 1 bit long.
-- Don't return a result for types that don't divide into 8 bits evenly.
size
<- case t' of
TPointer _ -> return $ platformAddrBytes pp
TInt bits
| bits `rem` 8 == 0 -> return $ bits `div` 8
_ -> throw $ ErrorInvalidSizeType t
return $ Seq.singleton
$ annotNil
$ ISet vDst (XLit (LitInt (tNat pp) size))
-- Get the log2 size in bytes of some primtive type.
A.PrimStore A.PrimStoreSize2
| [A.RType t] <- as
, Just vDst <- mdst
-> Just $ do
t' <- convertType pp kenv t
-- Bool# is only 1 bit long.
-- Don't return a result for types that don't divide into 8 bits evenly.
size
<- case t' of
TPointer _ -> return $ platformAddrBytes pp
TInt bits
| bits `rem` 8 == 0 -> return $ bits `div` 8
_ -> throw $ ErrorInvalidSize2Type t
let size2
= truncate $ (log (fromIntegral size) / log 2 :: Double)
return $ Seq.singleton
$ annotNil
$ ISet vDst (XLit (LitInt (tNat pp) size2))
-- Create the initial heap.
-- This is called once when the program starts.
A.PrimStore A.PrimStoreCreate
| Just [mBytes] <- atomsR as
-> Just $ do
xBytes' <- mBytes
vAddr <- newUniqueNamedVar "addr" (tAddr pp)
vMax <- newUniqueNamedVar "max" (tAddr pp)
let vTopPtr = varGlobalHeapTop pp
let vMaxPtr = varGlobalHeapMax pp
return $ Seq.fromList
$ map annotNil
[ ICall (Just vAddr) CallTypeStd Nothing
(tAddr pp) nameGlobalMalloc
[xBytes'] []
-- Store the top-of-heap pointer
, IStore (XVar vTopPtr) (XVar vAddr)
-- Store the maximum heap pointer
, IOp vMax OpAdd (XVar vAddr) xBytes'
, IStore (XVar vMaxPtr) (XVar vMax) ]
-- Check that there is enough space to allocate a new heap object
-- of the given number of bytes in length.
A.PrimStore A.PrimStoreCheck
| Just vDst@(Var nDst _) <- mdst
, Just [mBytes] <- atomsR as
-> Just $ do
xBytes' <- mBytes
let vTop = Var (bumpName nDst "top") (tAddr pp)
let vMin = Var (bumpName nDst "min") (tAddr pp)
let vMax = Var (bumpName nDst "max") (tAddr pp)
let vTopPtr = varGlobalHeapTop pp
let vMaxPtr = varGlobalHeapMax pp
return $ Seq.fromList $ map annotNil
[ ILoad vTop (XVar vTopPtr)
, IOp vMin OpAdd (XVar vTop) xBytes'
, ILoad vMax (XVar vMaxPtr)
, ICmp vDst (ICond ICondUlt) (XVar vMin) (XVar vMax) ]
-- Allocate a new heap object with the given number of bytes in length.
A.PrimStore A.PrimStoreAlloc
| Just vDst@(Var nDst _) <- mdst
, Just [mBytes] <- atomsR as
-> Just $ do
xBytes' <- mBytes
let vBump = Var (bumpName nDst "bump") (tAddr pp)
let vTopPtr = varGlobalHeapTop pp
return $ Seq.fromList $ map annotNil
[ ILoad vDst (XVar vTopPtr)
, IOp vBump OpAdd (XVar vDst) xBytes'
, IStore (XVar vTopPtr) (XVar vBump)]
-- Read a value via a pointer.
A.PrimStore A.PrimStoreRead
| A.RType{} : args <- as
, Just vDst@(Var nDst tDst) <- mdst
, Just [mAddr, mOffset] <- atomsR args
-> Just $ do
xAddr' <- mAddr
xOffset' <- mOffset
let vOff = Var (bumpName nDst "off") (tAddr pp)
let vPtr = Var (bumpName nDst "ptr") (tPtr tDst)
return $ Seq.fromList $ map annotNil
[ IOp vOff OpAdd xAddr' xOffset'
, IConv vPtr ConvInttoptr (XVar vOff)
, ILoad vDst (XVar vPtr) ]
-- Write a value via a pointer.
A.PrimStore A.PrimStoreWrite
| A.RType{} : args <- as
, Just [mAddr, mOffset, mVal] <- atomsR args
-> Just $ do
xAddr' <- mAddr
xOffset' <- mOffset
xVal' <- mVal
vOff <- newUniqueNamedVar "off" (tAddr pp)
vPtr <- newUniqueNamedVar "ptr" (tPtr $ typeOfExp xVal')
return $ Seq.fromList $ map annotNil
[ IOp vOff OpAdd xAddr' xOffset'
, IConv vPtr ConvInttoptr (XVar vOff)
, IStore (XVar vPtr) xVal' ]
-- Add an offset in bytes to a pointer.
A.PrimStore A.PrimStorePlusAddr
| Just vDst <- mdst
, Just [mAddr, mOffset] <- atomsR as
-> Just $ do
xAddr' <- mAddr
xOffset' <- mOffset
return $ Seq.singleton $ annotNil
$ IOp vDst OpAdd xAddr' xOffset'
-- Subtract an offset in bytes from a pointer.
A.PrimStore A.PrimStoreMinusAddr
| Just vDst <- mdst
, Just [mAddr, mOffset] <- atomsR as
-> Just $ do
xAddr' <- mAddr
xOffset' <- mOffset
return $ Seq.singleton $ annotNil
$ IOp vDst OpSub xAddr' xOffset'
-- Read from a raw address.
A.PrimStore A.PrimStorePeek
| A.RType{} : A.RType tDst : args <- as
, Just vDst@(Var nDst _) <- mdst
, Just [mPtr, mOffset] <- atomsR args
-> Just $ do
tDst' <- convertType pp kenv tDst
xPtr' <- mPtr
xOffset' <- mOffset
let vAddr1 = Var (bumpName nDst "addr1") (tAddr pp)
let vAddr2 = Var (bumpName nDst "addr2") (tAddr pp)
let vPtr = Var (bumpName nDst "ptr") (tPtr tDst')
return $ Seq.fromList
$ (map annotNil
[ IConv vAddr1 ConvPtrtoint xPtr'
, IOp vAddr2 OpAdd (XVar vAddr1) xOffset'
, IConv vPtr ConvInttoptr (XVar vAddr2) ])
++ [(annot kenv mdsup as
( ILoad vDst (XVar vPtr)))]
-- Write to a raw address.
A.PrimStore A.PrimStorePoke
| A.RType{} : A.RType tDst : args <- as
, Just [mPtr, mOffset, mVal] <- atomsR args
-> Just $ do
tDst' <- convertType pp kenv tDst
xPtr' <- mPtr
xOffset' <- mOffset
xVal' <- mVal
vAddr1 <- newUniqueNamedVar "addr1" (tAddr pp)
vAddr2 <- newUniqueNamedVar "addr2" (tAddr pp)
vPtr <- newUniqueNamedVar "ptr" (tPtr tDst')
return $ Seq.fromList
$ (map annotNil
[ IConv vAddr1 ConvPtrtoint xPtr'
, IOp vAddr2 OpAdd (XVar vAddr1) xOffset'
, IConv vPtr ConvInttoptr (XVar vAddr2) ])
++ [(annot kenv mdsup as
( IStore (XVar vPtr) xVal' ))]
-- Add an offset to a raw address.
A.PrimStore A.PrimStorePlusPtr
| _xRgn : _xType : args <- as
, Just vDst <- mdst
, Just [mPtr, mOffset] <- atomsR args
-> Just $ do
xPtr' <- mPtr
xOffset' <- mOffset
vAddr <- newUniqueNamedVar "addr" (tAddr pp)
vAddr2 <- newUniqueNamedVar "addr2" (tAddr pp)
return $ Seq.fromList $ map annotNil
[ IConv vAddr ConvPtrtoint xPtr'
, IOp vAddr2 OpAdd (XVar vAddr) xOffset'
, IConv vDst ConvInttoptr (XVar vAddr2) ]
-- Subtrace an offset from a raw address.
A.PrimStore A.PrimStoreMinusPtr
| _xRgn : _xType : args <- as
, Just vDst <- mdst
, Just [mPtr, mOffset] <- atomsR args
-> Just $ do
xPtr' <- mPtr
xOffset' <- mOffset
vAddr <- newUniqueNamedVar "addr" (tAddr pp)
vAddr2 <- newUniqueNamedVar "addr2" (tAddr pp)
return $ Seq.fromList $ map annotNil
[ IConv vAddr ConvPtrtoint xPtr'
, IOp vAddr2 OpSub (XVar vAddr) xOffset'
, IConv vDst ConvInttoptr (XVar vAddr2) ]
-- Construct a pointer from an address.
A.PrimStore A.PrimStoreMakePtr
| [A.RType{}, A.RType{}, A.RExp xAddr] <- as
, Just vDst <- mdst
, Just mAddr <- atom xAddr
-> Just $ do
xAddr' <- mAddr
return $ Seq.singleton $ annotNil
$ IConv vDst ConvInttoptr xAddr'
-- Take an address from a pointer.
A.PrimStore A.PrimStoreTakePtr
| [A.RType{}, A.RType{}, A.RExp xPtr] <- as
, Just vDst <- mdst
, Just mPtr <- atom xPtr
-> Just $ do
xPtr' <- mPtr
return $ Seq.singleton $ annotNil
$ IConv vDst ConvPtrtoint xPtr'
-- Case a pointer from one type to another.
A.PrimStore A.PrimStoreCastPtr
| [A.RType{}, A.RType{}, A.RType{}, A.RExp xPtr] <- as
, Just vDst <- mdst
, Just mPtr <- atom xPtr
-> Just $ do
xPtr' <- mPtr
return $ Seq.singleton $ annotNil
$ IConv vDst ConvBitcast xPtr'
_ -> Nothing
-- | Append the given string to a name.
bumpName :: Name -> String -> Name
bumpName nn s
= case nn of
NameLocal str -> NameLocal (str ++ "." ++ s)
NameGlobal str -> NameGlobal (str ++ "." ++ s)