module DDC.Core.Llvm.Convert
( convertModule
, convertType
, convertSuperType)
where
import DDC.Core.Llvm.Convert.Prim
import DDC.Core.Llvm.Convert.Type
import DDC.Core.Llvm.Convert.Atom
import DDC.Core.Llvm.Convert.Erase
import DDC.Core.Llvm.Metadata.Tbaa
import DDC.Core.Llvm.LlvmM
import DDC.Llvm.Syntax
import DDC.Core.Salt.Platform
import DDC.Core.Compounds
import DDC.Type.Env (KindEnv, TypeEnv)
import DDC.Type.Predicates
import DDC.Base.Pretty hiding (align)
import DDC.Data.ListUtils
import Control.Monad.State.Strict (evalState)
import Control.Monad.State.Strict (gets)
import Control.Monad
import Data.Maybe
import Data.Sequence (Seq, (<|), (|>), (><))
import Data.Map (Map)
import Data.Set (Set)
import qualified DDC.Llvm.Transform.Clean as Llvm
import qualified DDC.Llvm.Transform.LinkPhi as Llvm
import qualified DDC.Core.Salt as A
import qualified DDC.Core.Salt.Name as A
import qualified DDC.Core.Module as C
import qualified DDC.Core.Exp as C
import qualified DDC.Type.Env as Env
import qualified DDC.Core.Simplifier as Simp
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Seq
convertModule :: Platform -> C.Module () A.Name -> Module
convertModule platform mm@(C.ModuleCore{})
=
let
prims = primDeclsMap platform
state = llvmStateInit platform prims
mmElab = evalState (Simp.applySimplifier
A.profile Env.empty Env.empty
(Simp.Trans Simp.Elaborate) mm)
state
mmRaw = evalState (convModuleM mmElab) state
mmClean = Llvm.clean mmRaw
mmPhi = Llvm.linkPhi mmClean
in mmPhi
convModuleM :: C.Module () A.Name -> LlvmM Module
convModuleM mm@(C.ModuleCore{})
| ([C.LRec bxs], _) <- splitXLets $ C.moduleBody mm
= do platform <- gets llvmStatePlatform
let kenv = C.moduleKindEnv mm
let tenv = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs)
let nsExports = Set.fromList $ Map.keys $ C.moduleExportTypes mm
let Just importDecls
= sequence
$ [ importedFunctionDeclOfType platform kenv External n t
| (n, t) <- Map.elems $ C.moduleImportTypes mm ]
let isMainModule
= C.moduleName mm == C.ModuleName ["Main"]
let vHeapTop = Var (NameGlobal "_DDC_Runtime_heapTop") (tAddr platform)
let vHeapMax = Var (NameGlobal "_DDC_Runtime_heapMax") (tAddr platform)
let rtsGlobals
| isMainModule
= [ GlobalStatic vHeapTop (StaticLit (LitInt (tAddr platform) 0))
, GlobalStatic vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ]
| otherwise
= [ GlobalExternal vHeapTop
, GlobalExternal vHeapMax ]
(functions, mdecls)
<- liftM unzip
$ mapM (uncurry (convSuperM nsExports kenv tenv)) bxs
return $ Module
{ modComments = []
, modAliases = [aObj platform]
, modGlobals = rtsGlobals
, modFwdDecls = primDecls platform ++ importDecls
, modFuncs = functions
, modMDecls = concat mdecls }
| otherwise = die "Invalid module"
primDeclsMap :: Platform -> Map String FunctionDecl
primDeclsMap pp
= Map.fromList
$ [ (declName decl, decl) | decl <- primDecls pp ]
primDecls :: Platform -> [FunctionDecl]
primDecls pp
= [ FunctionDecl
{ declName = "malloc"
, declLinkage = External
, declCallConv = CC_Ccc
, declReturnType = tAddr pp
, declParamListType = FixedArgs
, declParams = [Param (tNat pp) []]
, declAlign = AlignBytes (platformAlignBytes pp) }
, FunctionDecl
{ declName = "abort"
, declLinkage = External
, declCallConv = CC_Ccc
, declReturnType = TVoid
, declParamListType = FixedArgs
, declParams = []
, declAlign = AlignBytes (platformAlignBytes pp) } ]
convSuperM
:: Set A.Name
-> KindEnv A.Name
-> TypeEnv A.Name
-> C.Bind A.Name
-> C.Exp () A.Name
-> LlvmM (Function, [MDecl])
convSuperM nsExports kenv tenv bSuper@(C.BName nTop@(A.NameVar strTop) tSuper) x
| Just (bfsParam, xBody) <- takeXLamFlags x
= do
platform <- gets llvmStatePlatform
let nTop' = A.sanitizeGlobal strTop
let bfsParam' = eraseWitBinds bfsParam
let bsParamType = [b | (True, b) <- bfsParam']
let bsParamValue = [b | (False, b) <- bfsParam']
let kenv' = Env.extends bsParamType kenv
let tenv' = Env.extends (bSuper : bsParamValue) tenv
mdsup <- deriveMD nTop' x
let (tsParam, tResult)
= convertSuperType platform kenv tSuper
let align = AlignBytes (platformAlignBytes platform)
let decl
= FunctionDecl
{ declName = nTop'
, declLinkage
= if Set.member nTop nsExports
then External
else Internal
, declCallConv
= if Set.member nTop nsExports
then CC_Ccc
else CC_Fastcc
, declReturnType = tResult
, declParamListType = FixedArgs
, declParams = [Param t [] | t <- tsParam]
, declAlign = align }
label <- newUniqueLabel "entry"
blocks <- convBodyM BodyTop kenv' tenv' mdsup Seq.empty label Seq.empty xBody
return $ ( Function
{ funDecl = decl
, funParams = map nameOfParam $ filter (not . isBNone) bsParamValue
, funAttrs = []
, funSection = SectionAuto
, funBlocks = Seq.toList blocks }
, decls mdsup )
convSuperM _ _ _ _ _
= die "Invalid super"
nameOfParam :: C.Bind A.Name -> String
nameOfParam bb
= case bb of
C.BName (A.NameVar n) _
-> A.sanitizeName n
_ -> die $ "Invalid parameter name: " ++ show bb
data BodyContext
= BodyTop
| BodyNest Var Label
deriving Show
convBodyM
:: BodyContext
-> KindEnv A.Name
-> TypeEnv A.Name
-> MDSuper
-> Seq Block
-> Label
-> Seq AnnotInstr
-> C.Exp () A.Name
-> LlvmM (Seq Block)
convBodyM context kenv tenv mdsup blocks label instrs xx
= do pp <- gets llvmStatePlatform
case xx of
C.XApp{}
| BodyTop <- context
, Just (A.NamePrimOp p, xs) <- takeXPrimApps xx
, A.PrimControl A.PrimControlReturn <- p
, [C.XType _, C.XCon _ dc] <- xs
, Just A.NameLitVoid <- takeNameOfDaCon dc
-> return $ blocks
|> Block label
(instrs |> (annotNil $ IReturn Nothing))
C.XApp{}
| BodyTop <- context
, Just (A.NamePrimOp p, xs) <- takeXPrimApps xx
, A.PrimControl A.PrimControlReturn <- p
, [C.XType t, x2] <- xs
, isVoidT t
-> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2
return $ blocks
|> Block label
(instrs >< (instrs2 |> (annotNil $ IReturn Nothing)))
C.XApp{}
| BodyTop <- context
, Just (A.NamePrimOp p, xs) <- takeXPrimApps xx
, A.PrimControl A.PrimControlReturn <- p
, [C.XType t, x] <- xs
-> do let t' = convertType pp kenv t
vDst <- newUniqueVar t'
is <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x
return $ blocks
|> Block label
(instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst)))))
C.XApp{}
| Just (A.NamePrimOp p, xs) <- takeXPrimApps xx
, A.PrimControl A.PrimControlFail <- p
, [C.XType _tResult] <- xs
-> let iFail = ICall Nothing CallTypeStd Nothing
TVoid (NameGlobal "abort") [] []
iSet = case context of
BodyTop -> INop
BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst))
block = Block label
$ instrs |> annotNil iSet
|> annotNil iFail
|> annotNil IUnreachable
in return $ blocks |> block
C.XApp{}
| Just (A.NamePrimOp p, args) <- takeXPrimApps xx
, A.PrimCall (A.PrimCallTail arity) <- p
, _tsArgs <- take arity args
, C.XType tResult : xFunTys : xsArgs <- drop arity args
, Just (xFun, _xsTys) <- takeXApps xFunTys
, Just (Var nFun _) <- takeGlobalV pp kenv tenv xFun
, Just xsArgs' <- sequence $ map (mconvAtom pp kenv tenv) xsArgs
-> if isVoidT tResult
then do return $ blocks
|> (Block label $ instrs
|> (annotNil $ ICall Nothing CallTypeTail Nothing
(convertType pp kenv tResult) nFun xsArgs' [])
|> (annotNil $ IReturn Nothing))
else do let tResult' = convertType pp kenv tResult
vDst <- newUniqueVar tResult'
return $ blocks
|> (Block label $ instrs
|> (annotNil $ ICall (Just vDst) CallTypeTail Nothing
(convertType pp kenv tResult) nFun xsArgs' [])
|> (annotNil $ IReturn (Just (XVar vDst))))
C.XLet _ (C.LLet (C.BNone t) x1) x2
| isVoidT t
-> do instrs' <- convExpM ExpTop pp kenv tenv mdsup x1
convBodyM context kenv tenv mdsup blocks label
(instrs >< instrs') x2
C.XLet a (C.LLet (C.BNone t) x1) x2
| not $ isVoidT t
-> do
n <- newUnique
let b = C.BName (A.NameVar ("_dummy" ++ show n)) t
convBodyM context kenv tenv mdsup blocks label instrs
(C.XLet a (C.LLet b x1) x2)
C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t)
(C.XCase _ xScrut alts))
x2
-> do
let t' = convertType pp kenv t
let n' = A.sanitizeName n
let vCont = Var (NameLocal n') t'
lCont <- newUniqueLabel "cont"
let context' = BodyNest vCont lCont
blocksCase <- convCaseM context' pp kenv tenv mdsup
label instrs xScrut alts
let tenv' = Env.extend b tenv
convBodyM context kenv tenv' mdsup
(blocks >< blocksCase)
lCont
Seq.empty
x2
C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) x1) x2
-> do let tenv' = Env.extend b tenv
let n' = A.sanitizeName n
let t' = convertType pp kenv t
let dst = Var (NameLocal n') t'
instrs' <- convExpM (ExpAssign dst) pp kenv tenv mdsup x1
convBodyM context kenv tenv' mdsup blocks label (instrs >< instrs') x2
C.XLet _ (C.LLetRegions b _) x2
-> do let kenv' = Env.extends b kenv
convBodyM context kenv' tenv mdsup blocks label instrs x2
C.XCase _ xScrut alts
-> do blocks' <- convCaseM context pp kenv tenv mdsup
label instrs xScrut alts
return $ blocks >< blocks'
C.XCast _ _ x
-> convBodyM context kenv tenv mdsup blocks label instrs x
_
| BodyNest vDst label' <- context
-> do instrs' <- convExpM (ExpAssign vDst) pp kenv tenv mdsup xx
return $ blocks >< Seq.singleton (Block label
(instrs >< (instrs' |> (annotNil $ IBranch label'))))
| otherwise
-> die $ renderIndent
$ text "Invalid body statement "
<$> ppr xx
data ExpContext
= ExpTop
| ExpAssign Var
deriving Show
varOfExpContext :: ExpContext -> Maybe Var
varOfExpContext xc
= case xc of
ExpTop -> Nothing
ExpAssign var -> Just var
convExpM
:: ExpContext
-> Platform
-> KindEnv A.Name
-> TypeEnv A.Name
-> MDSuper
-> C.Exp () A.Name
-> LlvmM (Seq AnnotInstr)
convExpM context pp kenv tenv mdsup xx
= case xx of
C.XVar _ u@(C.UName (A.NameVar n))
| Just t <- Env.lookup u tenv
, ExpAssign vDst <- context
-> do let n' = A.sanitizeName n
let t' = convertType pp kenv t
return $ Seq.singleton $ annotNil
$ ISet vDst (XVar (Var (NameLocal n') t'))
C.XCon _ dc
| Just n <- takeNameOfDaCon dc
, ExpAssign vDst <- context
-> case n of
A.NameLitNat i
-> return $ Seq.singleton $ annotNil
$ ISet vDst (XLit (LitInt (tNat pp) i))
A.NameLitInt i
-> return $ Seq.singleton $ annotNil
$ ISet vDst (XLit (LitInt (tInt pp) i))
A.NameLitWord w bits
-> return $ Seq.singleton $ annotNil
$ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w))
_ -> die "Invalid literal"
C.XApp{}
| Just (C.XVar _ (C.UPrim (A.NamePrimOp p) tPrim), args) <- takeXApps xx
-> convPrimCallM pp kenv tenv mdsup
(varOfExpContext context)
p tPrim args
| Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx
, Just (Var nFun _) <- takeGlobalV pp kenv tenv xFun
, Just xsArgs_value' <- sequence $ map (mconvAtom pp kenv tenv)
$ eraseTypeWitArgs xsArgs
, Just tSuper <- Env.lookup u tenv
-> let (_, tResult) = convertSuperType pp kenv tSuper
in return $ Seq.singleton $ annotNil
$ ICall (varOfExpContext context) CallTypeStd Nothing
tResult nFun xsArgs_value' []
C.XCast _ _ x
-> convExpM context pp kenv tenv mdsup x
_ -> die $ "Invalid expression " ++ show xx
convCaseM
:: BodyContext
-> Platform
-> KindEnv A.Name
-> TypeEnv A.Name
-> MDSuper
-> Label
-> Seq AnnotInstr
-> C.Exp () A.Name
-> [C.Alt () A.Name]
-> LlvmM (Seq Block)
convCaseM context pp kenv tenv mdsup label instrs xScrut alts
| Just vScrut'@Var{} <- takeLocalV pp kenv tenv xScrut
= do
(alts', blocksJoin)
<- convAlts context pp kenv tenv mdsup alts
(lDefault, blocksDefault)
<- case last alts' of
AltDefault l bs -> return (l, bs)
AltCase _ l bs -> return (l, bs)
let Just altsTable = takeInit alts'
let table = mapMaybe takeAltCase altsTable
let blocksTable = join $ fmap altResultBlocks $ Seq.fromList altsTable
let switchBlock
= Block label
$ instrs
|> (annotNil $ ISwitch (XVar vScrut') lDefault table)
return $ switchBlock
<| (blocksTable >< blocksDefault >< blocksJoin)
convCaseM _ _ _ _ _ _ _ _ _
= die "Invalid case expression"
convAlts
:: BodyContext
-> Platform
-> KindEnv A.Name
-> TypeEnv A.Name
-> MDSuper
-> [C.Alt () A.Name]
-> LlvmM ([AltResult], Seq Block)
convAlts BodyTop
_pp kenv tenv mdsup alts
= do
alts' <- mapM (convAltM BodyTop kenv tenv mdsup) alts
return (alts', Seq.empty)
convAlts (BodyNest vDst lCont)
_pp kenv tenv mdsup alts
= do
let tDst' = typeOfVar vDst
lJoin <- newUniqueLabel "join"
(vDstAlts, alts'@(_:_))
<- liftM unzip
$ mapM (\alt -> do
vDst' <- newUniqueNamedVar "alt" tDst'
alt' <- convAltM (BodyNest vDst' lJoin) kenv tenv mdsup alt
return (vDst', alt'))
$ alts
let blockJoin
= Block lJoin
$ Seq.fromList $ map annotNil
[ IPhi vDst [ (XVar vDstAlt, Label "unknown")
| vDstAlt <- vDstAlts ]
, IBranch lCont ]
return (alts', Seq.singleton blockJoin)
data AltResult
= AltDefault Label (Seq Block)
| AltCase Lit Label (Seq Block)
convAltM
:: BodyContext
-> KindEnv A.Name
-> TypeEnv A.Name
-> MDSuper
-> C.Alt () A.Name
-> LlvmM AltResult
convAltM context kenv tenv mdsup aa
= do pp <- gets llvmStatePlatform
case aa of
C.AAlt C.PDefault x
-> do label <- newUniqueLabel "default"
blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x
return $ AltDefault label blocks
C.AAlt (C.PData dc []) x
| Just n <- takeNameOfDaCon dc
, Just lit <- convPatName pp n
-> do label <- newUniqueLabel "alt"
blocks <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x
return $ AltCase lit label blocks
_ -> die "Invalid alternative"
convPatName :: Platform -> A.Name -> Maybe Lit
convPatName pp name
= case name of
A.NameLitBool True -> Just $ LitInt (TInt 1) 1
A.NameLitBool False -> Just $ LitInt (TInt 1) 0
A.NameLitNat i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i
A.NameLitInt i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i
A.NameLitWord i bits
| elem bits [8, 16, 32, 64]
-> Just $ LitInt (TInt $ fromIntegral bits) i
A.NameLitTag i -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i
_ -> Nothing
altResultBlocks :: AltResult -> Seq Block
altResultBlocks aa
= case aa of
AltDefault _ blocks -> blocks
AltCase _ _ blocks -> blocks
takeAltCase :: AltResult -> Maybe (Lit, Label)
takeAltCase (AltCase lit label _) = Just (lit, label)
takeAltCase _ = Nothing