module DDC.Core.Salt.Convert
( Error (..)
, seaOfSaltModule)
where
import DDC.Core.Salt.Convert.Prim
import DDC.Core.Salt.Convert.Base
import DDC.Core.Salt.Convert.Type
import DDC.Core.Salt.Name
import DDC.Core.Salt.Platform
import DDC.Core.Collect
import DDC.Core.Predicates
import DDC.Core.Compounds
import DDC.Core.Module as C
import DDC.Core.Exp
import DDC.Type.Env (KindEnv, TypeEnv)
import DDC.Base.Pretty
import DDC.Control.Monad.Check (throw, result)
import qualified DDC.Type.Env as Env
import qualified Data.Map as Map
import Control.Monad
import Data.Maybe
seaOfSaltModule
:: Show a
=> Bool
-> Platform
-> Module a Name
-> Either (Error a) Doc
seaOfSaltModule withPrelude pp mm
=
result $ convModuleM withPrelude pp mm
convModuleM :: Show a => Bool -> Platform -> Module a Name -> ConvertM a Doc
convModuleM withPrelude pp mm@(ModuleCore{})
| ([LRec bxs], _) <- splitXLets $ moduleBody mm
= do
let cIncludes
| not withPrelude
= []
| otherwise
= [ text "#include \"Runtime.h\""
, text "#include \"Primitive.h\""
, empty ]
let nts = Map.elems $ C.moduleImportTypes mm
docs <- mapM (uncurry $ convFunctionTypeM Env.empty) nts
let cExterns
| not withPrelude
= []
| otherwise
= [ text "extern " <> doc <> semi | doc <- docs ]
let cGlobals
| not withPrelude
= []
| isMainModule mm
= [ text "addr_t _DDC_Runtime_heapTop = 0;"
, text "addr_t _DDC_Runtime_heapMax = 0;"
, empty ]
| otherwise
= [ text "extern addr_t _DDC_Runtime_heapTop;"
, text "extern addr_t _DDC_Runtime_heapMax;"
, empty ]
let kenv = Env.fromTypeMap $ Map.map snd $ moduleImportKinds mm
let tenv = Env.fromTypeMap $ Map.map snd $ moduleImportTypes mm
cSupers <- mapM (uncurry (convSuperM pp kenv tenv)) bxs
return $ vcat
$ cIncludes
++ cExterns
++ cGlobals
++ cSupers
| otherwise
= throw $ ErrorNoTopLevelLetrec mm
convSuperM
:: Show a
=> Platform
-> KindEnv Name
-> TypeEnv Name
-> Bind Name
-> Exp a Name
-> ConvertM a Doc
convSuperM pp kenv0 tenv0 bTop xx
= convSuperM' pp kenv0 tenv0 bTop [] xx
convSuperM' pp kenv tenv bTop bsParam xx
| XLAM _ b x <- xx
= convSuperM' pp (Env.extend b kenv) tenv bTop bsParam x
| XLam _ b x <- xx
= convSuperM' pp kenv (Env.extend b tenv) bTop (bsParam ++ [b]) x
| BName (NameVar nTop) tTop <- bTop
= do
let nTop' = text $ sanitizeGlobal nTop
let (_, tResult) = takeTFunArgResult $ eraseTForalls tTop
bsParam' <- mapM (convBind kenv tenv) $ filter keepBind bsParam
tResult' <- convTypeM kenv $ eraseWitArg tResult
let (_, bsVal) = collectBinds xx
dsVal <- liftM catMaybes $ mapM (makeVarDecl kenv)
$ filter keepBind bsVal
xBody' <- convBlockM ContextTop pp kenv tenv xx
return $ vcat
[ tResult'
<+> nTop'
<+> parenss bsParam'
, lbrace
, indent 8 $ vcat dsVal
, empty
, indent 8 xBody'
, rbrace
, empty]
| otherwise
= throw $ ErrorFunctionInvalid xx
makeVarDecl :: KindEnv Name -> Bind Name -> ConvertM a (Maybe Doc)
makeVarDecl kenv bb
= case bb of
BNone{}
-> return Nothing
BName (NameVar n) t
-> do t' <- convTypeM kenv t
let n' = text $ sanitizeLocal n
return $ Just (t' <+> n' <+> equals <+> text "0" <> semi)
_ -> throw $ ErrorParameterInvalid bb
eraseWitArg :: Type Name -> Type Name
eraseWitArg tt
= case tt of
TApp _ t2
| Just (NamePrimTyCon PrimTyConPtr, _) <- takePrimTyConApps tt -> tt
| otherwise -> eraseWitArg t2
_ -> tt
keepBind :: Bind Name -> Bool
keepBind bb
= case bb of
BName _ t
| tc : _ <- takeTApps t
, isWitnessType tc
-> False
BNone{} -> False
_ -> True
convBind :: KindEnv Name -> TypeEnv Name -> Bind Name -> ConvertM a Doc
convBind kenv _tenv b
= case b of
BName (NameVar str) t
-> do t' <- convTypeM kenv t
return $ t' <+> (text $ sanitizeLocal str)
_ -> throw $ ErrorParameterInvalid b
data Context
= ContextTop
| ContextNest (Bind Name)
deriving Show
isContextNest :: Context -> Bool
isContextNest cc
= case cc of
ContextNest{} -> True
_ -> False
convBlockM
:: Show a
=> Context
-> Platform
-> KindEnv Name
-> TypeEnv Name
-> Exp a Name
-> ConvertM a Doc
convBlockM context pp kenv tenv xx
= case xx of
XApp{}
| ContextTop <- context
-> case takeXPrimApps xx of
Just (NamePrimOp p, xs)
| isControlPrim p || isCallPrim p
-> do x1 <- convPrimCallM pp kenv tenv p xs
return $ x1 <> semi
_ -> throw $ ErrorBodyMustPassControl xx
| ContextNest{} <- context
, Just (NamePrimOp p, xs) <- takeXPrimApps xx
, isControlPrim p || isCallPrim p
-> do x1 <- convPrimCallM pp kenv tenv p xs
return $ x1 <> semi
_
| isRValue xx
, ContextNest (BName n _) <- context
-> do xx' <- convRValueM pp kenv tenv xx
let n' = text $ sanitizeLocal (renderPlain $ ppr n)
return $ vcat
[ fill 12 n' <+> equals <+> xx' <> semi ]
| isRValue xx
, ContextNest (BNone _) <- context
-> do xx' <- convRValueM pp kenv tenv xx
return $ vcat
[ xx' <> semi ]
XLet _ (LLet b x1@XCase{}) x2
-> do
x1' <- convBlockM (ContextNest b) pp kenv tenv x1
let tenv' = Env.extend b tenv
x2' <- convBlockM context pp kenv tenv' x2
return $ vcat
[ x1'
, x2' ]
XLet _ (LLet b x1) x2
-> do x1' <- convRValueM pp kenv tenv x1
x2' <- convBlockM context pp kenv tenv x2
let dst = case b of
BName (NameVar n) _
-> fill 12 (text $ sanitizeLocal n) <+> equals <> space
_ -> empty
return $ vcat
[ dst <> x1' <> semi
, x2' ]
XLet _ (LLetRegions bs ws) x
-> let kenv' = Env.extends bs kenv
tenv' = Env.extends ws tenv
in convBlockM context pp kenv' tenv' x
XCase _ x [ AAlt (PData dc []) x1
, AAlt PDefault xFail]
| isFailX xFail
, Just n <- takeNameOfDaCon dc
, Just n' <- convDaConName n
-> do
x' <- convRValueM pp kenv tenv x
x1' <- convBlockM context pp kenv tenv x1
xFail' <- convBlockM context pp kenv tenv xFail
return $ vcat
[ text "if"
<+> parens (x' <+> text "!=" <+> n')
<+> xFail'
, x1' ]
XCase _ x [ AAlt (PData dc1 []) x1
, AAlt (PData dc2 []) x2 ]
| Just (NameLitBool True) <- takeNameOfDaCon dc1
, Just (NameLitBool False) <- takeNameOfDaCon dc2
-> do x' <- convRValueM pp kenv tenv x
x1' <- convBlockM context pp kenv tenv x1
x2' <- convBlockM context pp kenv tenv x2
return $ vcat
[ text "if" <> parens x'
, lbrace <> indent 7 x1' <> line <> rbrace
, text "else"
, lbrace <> indent 7 x2' <> line <> rbrace ]
XCase _ x alts
-> do x' <- convRValueM pp kenv tenv x
alts' <- mapM (convAltM context pp kenv tenv) alts
return $ vcat
[ text "switch" <+> parens x'
, lbrace <> indent 1 (vcat alts')
, rbrace ]
XCast _ _ x
-> convBlockM context pp kenv tenv x
_ -> throw $ ErrorBodyInvalid xx
isControlPrim :: PrimOp -> Bool
isControlPrim pp
= case pp of
PrimControl{} -> True
_ -> False
isCallPrim :: PrimOp -> Bool
isCallPrim pp
= case pp of
PrimCall{} -> True
_ -> False
isFailX :: Exp a Name -> Bool
isFailX (XApp _ (XVar _ (UPrim (NamePrimOp (PrimControl PrimControlFail)) _)) _)
= True
isFailX _ = False
convAltM
:: Show a
=> Context
-> Platform
-> KindEnv Name
-> TypeEnv Name
-> Alt a Name
-> ConvertM a Doc
convAltM context pp kenv tenv aa
= let end
| isContextNest context = line <> text "break;"
| otherwise = empty
in case aa of
AAlt PDefault x1
-> do x1' <- convBlockM context pp kenv tenv x1
return $ vcat
[ text "default:"
, lbrace <> indent 5 (x1' <> end)
<> line
<> rbrace]
AAlt (PData dc []) x1
| Just n <- takeNameOfDaCon dc
, Just n' <- convDaConName n
-> do x1' <- convBlockM context pp kenv tenv x1
return $ vcat
[ text "case" <+> n' <> colon
, lbrace <> indent 5 (x1' <> end)
<> line
<> rbrace]
AAlt{} -> throw $ ErrorAltInvalid aa
convDaConName :: Name -> Maybe Doc
convDaConName nn
= case nn of
NameLitBool True -> Just $ int 1
NameLitBool False -> Just $ int 0
NameLitNat i -> Just $ integer i
NameLitInt i -> Just $ integer i
NameLitWord i bits
| elem bits [8, 16, 32, 64]
-> Just $ integer i
NameLitTag i -> Just $ integer i
_ -> Nothing
convRValueM
:: Show a
=> Platform
-> KindEnv Name
-> TypeEnv Name
-> Exp a Name
-> ConvertM a Doc
convRValueM pp kenv tenv xx
= case xx of
XVar _ (UName n)
| NameVar str <- n
-> return $ text $ sanitizeLocal str
XCon _ dc
| DaConNamed n <- daConName dc
-> case n of
NameLitBool b
| b -> return $ integer 1
| otherwise -> return $ integer 0
NameLitNat i -> return $ integer i
NameLitInt i -> return $ integer i
NameLitWord i _ -> return $ integer i
NameLitTag i -> return $ integer i
NameLitVoid -> return $ text "void"
_ -> throw $ ErrorRValueInvalid xx
XApp{}
| Just (NamePrimOp p, args) <- takeXPrimApps xx
-> convPrimCallM pp kenv tenv p args
XApp{}
| Just (XVar _ (UName n), args) <- takeXApps xx
, NameVar nTop <- n
-> do let nTop' = sanitizeGlobal nTop
args' <- mapM (convRValueM pp kenv tenv)
$ filter keepFunArgX args
return $ text nTop' <> parenss args'
XType t
-> do t' <- convTypeM kenv t
return $ t'
XCast _ _ x
-> convRValueM pp kenv tenv x
_ -> throw $ ErrorRValueInvalid xx
isRValue :: Exp a Name -> Bool
isRValue xx
= case xx of
XVar{} -> True
XCon{} -> True
XApp{} -> True
XCast _ _ x -> isRValue x
_ -> False
keepFunArgX :: Exp a n -> Bool
keepFunArgX xx
= case xx of
XType{} -> False
XWitness{} -> False
_ -> True
convPrimCallM
:: Show a
=> Platform
-> KindEnv Name
-> TypeEnv Name
-> PrimOp
-> [Exp a Name] -> ConvertM a Doc
convPrimCallM pp kenv tenv p xs
= case p of
PrimArith op
| [XType _t, x1, x2] <- xs
, Just op' <- convPrimArith2 op
-> do x1' <- convRValueM pp kenv tenv x1
x2' <- convRValueM pp kenv tenv x2
return $ parens (x1' <+> op' <+> x2')
PrimCast PrimCastPromote
| [XType tDst, XType tSrc, x1] <- xs
, Just (NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc
, Just (NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst
, primCastPromoteIsValid pp tcSrc tcDst
-> do tDst' <- convTypeM kenv tDst
x1' <- convRValueM pp kenv tenv x1
return $ parens tDst' <> parens x1'
PrimCast PrimCastTruncate
| [XType tDst, XType tSrc, x1] <- xs
, Just (NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc
, Just (NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst
, primCastTruncateIsValid pp tcSrc tcDst
-> do tDst' <- convTypeM kenv tDst
x1' <- convRValueM pp kenv tenv x1
return $ parens tDst' <> parens x1'
PrimControl PrimControlReturn
| [XType _t, x1] <- xs
-> do x1' <- convRValueM pp kenv tenv x1
return $ text "return" <+> x1'
PrimControl PrimControlFail
| [XType _t] <- xs
-> do return $ text "_FAIL()"
PrimCall (PrimCallTail arity)
| xFunTys : xsArgs <- drop (arity + 1) xs
, Just (xFun, _) <- takeXApps xFunTys
, XVar _ (UName n) <- xFun
, NameVar nTop <- n
-> do let nFun' = text $ sanitizeGlobal nTop
xsArgs' <- mapM (convRValueM pp kenv tenv) xsArgs
return $ text "return" <+> nFun' <> parenss xsArgs'
PrimStore op
-> do let op' = convPrimStore op
xs' <- mapM (convRValueM pp kenv tenv)
$ filter (keepPrimArgX kenv) xs
return $ op' <> parenss xs'
_ -> throw $ ErrorPrimCallInvalid p xs
keepPrimArgX :: KindEnv Name -> Exp a Name -> Bool
keepPrimArgX kenv xx
= case xx of
XType (TVar u)
| Just k <- Env.lookup u kenv
-> isDataKind k
XWitness{} -> False
_ -> True
parenss :: [Doc] -> Doc
parenss xs = encloseSep lparen rparen (comma <> space) xs