LlvmM.hs

module DDC.Core.Llvm.LlvmM
        ( LlvmM
        , LlvmState(..)
        , llvmStateInit 
        , die
        , dieDoc

          -- * Uniques
        , newUnique
        , newUniqueVar
        , newUniqueNamedVar
        , newUniqueLabel

          -- * Platform Specific
        , getPrimDeclM
        , getBytesOfTypeM)
where
import DDC.Core.Salt.Platform
import DDC.Llvm.Syntax
import Data.Map                         (Map)
import qualified DDC.Core.Salt.Name     as A
import qualified DDC.Core.Module        as C
import qualified Data.Map               as Map
import Control.Monad.State.Strict
import DDC.Base.Pretty

type LlvmM = State LlvmState


-- | Called when we find a thing that cannot be converted to Llvm.
die :: String -> a
die msg = dieDoc (text msg)

dieDoc :: Doc -> a
dieDoc msg 
        = error $ renderIndent
        $    text "DDC.Core.Llvm.Convert LLVM conversion failed"
        <$$> msg



-- LlvmState ------------------------------------------------------------------
-- | State for the LLVM conversion.
data LlvmState
        = LlvmState
        { -- Unique name generator.
          llvmStateUnique       :: Int 

          -- The current platform.
        , llvmStatePlatform     :: Platform 

          -- The module being converted.
        , llvmStateModule       :: C.Module () A.Name

          -- Primitives in the global environment.
        , llvmStatePrimDecls    :: Map String FunctionDecl }


-- | Initial LLVM state.
llvmStateInit 
        :: Platform 
        -> C.Module () A.Name
        -> Map String FunctionDecl 
        -> LlvmState

llvmStateInit platform mm prims
        = LlvmState
        { llvmStateUnique       = 1 
        , llvmStatePlatform     = platform
        , llvmStateModule       = mm
        , llvmStatePrimDecls    = prims }


-- Unique ---------------------------------------------------------------------
-- | Unique name generation.
newUnique :: LlvmM Int
newUnique 
 = do   s       <- get
        let u   = llvmStateUnique s
        put     $ s { llvmStateUnique = u + 1 }
        return  $ u


-- | Generate a new unique register variable with the specified `LlvmType`.
newUniqueVar :: Type -> LlvmM Var
newUniqueVar t
 = do   u <- newUnique
        return $ Var (NameLocal ("_v" ++ show u)) t


-- | Generate a new unique named register variable with the specified `LlvmType`.
newUniqueNamedVar :: String -> Type -> LlvmM Var
newUniqueNamedVar name t
 = do   u <- newUnique 
        return $ Var (NameLocal ("_v" ++ show u ++ "." ++ name)) t


-- | Generate a new unique label.
newUniqueLabel :: String -> LlvmM Label
newUniqueLabel name
 = do   u <- newUnique
        return $ Label ("l" ++ show u ++ "." ++ name)



-- Platform Specific ----------------------------------------------------------
-- | Get the declaration of a primitive function
getPrimDeclM :: String -> LlvmM (Maybe FunctionDecl)
getPrimDeclM name
 = do   prims   <- gets llvmStatePrimDecls
        return  $ Map.lookup name prims 


-- | Get the size of a type on this platform, in bytes.
getBytesOfTypeM :: Type -> LlvmM Integer
getBytesOfTypeM tt
 = do   platform        <- gets llvmStatePlatform
        let Just bytes  = takeBytesOfType (platformAddrBytes platform) tt
        return bytes