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)