diff --git a/DDC/Core/Llvm/Convert.hs b/DDC/Core/Llvm/Convert.hs --- a/DDC/Core/Llvm/Convert.hs +++ b/DDC/Core/Llvm/Convert.hs @@ -4,86 +4,117 @@ , convertType , convertSuperType) where +import DDC.Core.Llvm.Metadata.Tbaa +import DDC.Core.Llvm.Convert.Exp.Case +import DDC.Core.Llvm.Convert.Exp import DDC.Core.Llvm.Convert.Super import DDC.Core.Llvm.Convert.Type -import DDC.Core.Llvm.LlvmM -import DDC.Llvm.Syntax +import DDC.Core.Llvm.Convert.Base +import DDC.Core.Llvm.Runtime import DDC.Core.Salt.Platform -import DDC.Core.Compounds -import Control.Monad.State.Strict (evalState) -import Control.Monad.State.Strict (gets) +import DDC.Core.Exp.Annot.Compounds +import DDC.Llvm.Syntax +import DDC.Control.Monad.Check +import qualified Control.Monad.State.Strict as State import Control.Monad import Data.Map (Map) -import qualified DDC.Llvm.Transform.Clean as Llvm -import qualified DDC.Llvm.Transform.LinkPhi as Llvm + +import qualified DDC.Llvm.Transform.Calls as Calls +import qualified DDC.Llvm.Transform.Flatten as Flatten +import qualified DDC.Llvm.Transform.Simpl as Simpl + import qualified DDC.Core.Salt 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.List as List -- | Convert a Salt module to LLVM. -- -- If anything goes wrong in the convertion then this function will -- just call `error`. -- -convertModule :: Platform -> C.Module () A.Name -> Module +convertModule + :: Platform + -> C.Module () A.Name + -> Either Error Module + convertModule platform mm@(C.ModuleCore{}) - = {-# SCC convertModule #-} - let - prims = primDeclsMap platform - state = llvmStateInit platform mm prims + = let + state = llvmStateInit -- Add extra Const and Distinct witnesses where possible. - -- This helps us produce better LLVM metat data. - mmElab = Simp.result - $ evalState (Simp.applySimplifier - A.profile Env.empty Env.empty - (Simp.Trans Simp.Elaborate) mm) - state + -- This helps us produce better LLVM metadata. + mmElab = Simp.result $ fst + $ flip State.runState state + $ Simp.applySimplifier + A.profile Env.empty Env.empty + (Simp.Trans Simp.Elaborate) + mm + + -- Convert to LLVM. + in case runCheck state (convertModuleM platform mmElab) of + (_state', Left err) + -> Left err - stateElab = state { llvmStateModule = mmElab } + (state', Right mmRaw) + -> let + -- Attach any top-level constants the code generator might have made. + gsLit = [ GlobalStatic var (StaticLit lit) + | (var, lit) <- Map.toList $ llvmConstants state' ] - -- Convert to LLVM. - -- The result contains ISet and INop meta instructions that need to be - -- cleaned out. We also need to fixup the labels in IPhi instructions. - mmRaw = evalState (convModuleM mmElab) stateElab + mmConst = mmRaw + { modGlobals = modGlobals mmRaw ++ gsLit } - -- Inline the ISet meta instructions and drop INops. - -- This gives us code that the LLVM compiler will accept directly. - mmClean = Llvm.clean mmRaw + -- Flatten out our extended expression language into raw LLVM instructions. + mmFlat = Flatten.flatten mmConst - -- Fixup the source labels in IPhi instructions. - -- The converter itself sets these to 'undef', so we need to find the - -- real block label of each merged variable. - mmPhi = Llvm.linkPhi mmClean + -- Clean out nops, v1 = v2 aliases and constant bindings. + mmSimpl = Simpl.simpl Simpl.configZero + { Simpl.configDropNops = True + , Simpl.configSimplAlias = True + , Simpl.configSimplConst = True + , Simpl.configSquashUndef = True } + mmFlat - in mmPhi + -- Attach calling conventions to call sites. + mmCalls = Calls.attachCallConvs mmSimpl + in Right mmCalls -convModuleM :: C.Module () A.Name -> LlvmM Module -convModuleM mm@(C.ModuleCore{}) - | ([C.LRec bxs], _) <- splitXLets $ C.moduleBody mm - = do platform <- gets llvmStatePlatform +-- | Convert a Salt module to sugared LLVM. +-- The result contains ISet and INop meta-instructions that LLVM will not accept +-- directly. It also annotates IPhi nodes with undef, and these need to be given +-- real block labels before the LLVM compiler will accept them. +-- +convertModuleM + :: Platform + -> C.Module () A.Name + -> ConvertM Module + +convertModuleM pp mm@(C.ModuleCore{}) + | ([C.LRec bxs], _) <- splitXLets $ C.moduleBody mm + = do -- Globals for the runtime -------------- - -- If this is the main module then we define the globals - -- for the runtime system at top-level. + -- If this is the main module then we define the globals for the + -- runtime system, otherwise tread them as external symbols. -- Holds the pointer to the current top of the heap. -- This is the byte _after_ the last byte used by an object. - let vHeapTop = Var (NameGlobal "_DDC__heapTop") (tAddr platform) + let vHeapTop = Var nameGlobalHeapTop (tAddr pp) -- Holds the pointer to the maximum heap. -- This is the byte _after_ the last byte avaiable in the heap. - let vHeapMax = Var (NameGlobal "_DDC__heapMax") (tAddr platform) + let vHeapMax = Var nameGlobalHeapMax (tAddr pp) let globalsRts | C.moduleName mm == C.ModuleName ["Main"] - = [ GlobalStatic vHeapTop (StaticLit (LitInt (tAddr platform) 0)) - , GlobalStatic vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ] + = [ GlobalStatic vHeapTop (StaticLit (LitInt (tAddr pp) 0)) + , GlobalStatic vHeapMax (StaticLit (LitInt (tAddr pp) 0)) ] | otherwise = [ GlobalExternal vHeapTop @@ -93,33 +124,55 @@ let kenv = C.moduleKindEnv mm let tenv = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs) - let Just importDecls + let Just msImportDecls = sequence - $ [ importedFunctionDeclOfType platform kenv + $ [ importedFunctionDeclOfType pp kenv isrc - (lookup n (C.moduleExportValues mm)) + (List.lookup n (C.moduleExportValues mm)) n - (C.typeOfImportSource isrc) + (C.typeOfImportValue isrc) | (n, isrc) <- C.moduleImportValues mm ] + importDecls <- sequence msImportDecls - -- Super-combinator definitions --------- + -- Convert super definitions --------- -- This is the code for locally defined functions. + let ctx = Context + { contextPlatform = pp + , contextModule = mm + , contextKindEnvTop = kenv + , contextTypeEnvTop = tenv + , contextSupers = C.moduleTopBinds mm + , contextImports = Set.fromList $ map fst $ C.moduleImportValues mm + , contextKindEnv = kenv + , contextTypeEnv = tenv + , contextNames = Map.empty + , contextMDSuper = MDSuper Map.empty [] + , contextSuperBinds = Map.empty + , contextPrimDecls = primDeclsMap pp + , contextConvertBody = convertBody + , contextConvertExp = convertSimple + , contextConvertCase = convertCase } + + let convertSuper' ctx' b x + = let Right x' = A.fromAnnot x + in convertSuper ctx' b x' + (functions, mdecls) <- liftM unzip - $ mapM (uncurry (convSuperM kenv tenv)) bxs - + $ mapM (uncurry (convertSuper' ctx)) bxs - -- Paste everything together ------------ + -- Stitch everything together ----------- return $ Module - { modComments = [] - , modAliases = [aObj platform] - , modGlobals = globalsRts - , modFwdDecls = primDecls platform ++ importDecls - , modFuncs = functions - , modMDecls = concat mdecls } + { modComments = [] + , modAliases = [aObj pp] + , modGlobals = globalsRts + , modFwdDecls = primDecls pp ++ importDecls + , modFuncs = functions + , modMDecls = concat mdecls } - | otherwise = die "Invalid module" + | otherwise + = throw $ ErrorInvalidModule mm -- | C library functions that are used directly by the generated code without diff --git a/DDC/Core/Llvm/Convert/Atom.hs b/DDC/Core/Llvm/Convert/Atom.hs deleted file mode 100644 --- a/DDC/Core/Llvm/Convert/Atom.hs +++ /dev/null @@ -1,106 +0,0 @@ - -module DDC.Core.Llvm.Convert.Atom - ( mconvAtom - , mconvAtoms - , takeLocalV - , takeGlobalV) -where -import DDC.Llvm.Syntax -import DDC.Core.Llvm.Convert.Type -import DDC.Core.Salt.Platform -import DDC.Base.Pretty -import Control.Monad -import DDC.Type.Env (KindEnv, TypeEnv) -import qualified DDC.Type.Env as Env -import qualified DDC.Core.Salt as A -import qualified DDC.Core.Salt.Convert as A -import qualified DDC.Core.Module as C -import qualified DDC.Core.Exp as C - - --- Atoms ---------------------------------------------------------------------- --- | Take a variable or literal from an expression. --- These can be used directly in instructions. -mconvAtom - :: Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> C.Exp a A.Name - -> Maybe Exp - -mconvAtom pp kenv tenv xx - = case xx of - - -- Variables. Their names need to be sanitized before we write - -- them to LLVM, as LLVM doesn't handle all the symbolic names - -- that Disciple Core accepts. - C.XVar _ u@(C.UName (A.NameVar n)) - | Just t <- Env.lookup u tenv - -> let n' = A.sanitizeName n - t' = convertType pp kenv t - in Just $ XVar (Var (NameLocal n') t') - - -- Literals. - C.XCon _ dc - | C.DaConPrim n t <- dc - -> case n of - A.NameLitBool b - -> let i | b = 1 - | otherwise = 0 - in Just $ XLit (LitInt (convertType pp kenv t) i) - - A.NameLitNat nat -> Just $ XLit (LitInt (convertType pp kenv t) nat) - A.NameLitInt val -> Just $ XLit (LitInt (convertType pp kenv t) val) - A.NameLitWord val _ -> Just $ XLit (LitInt (convertType pp kenv t) val) - A.NameLitTag tag -> Just $ XLit (LitInt (convertType pp kenv t) tag) - _ -> Nothing - - _ -> Nothing - - --- | Convert several atoms to core. -mconvAtoms - :: Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> [C.Exp a A.Name] - -> Maybe [Exp] - -mconvAtoms pp kenv tenv xs - = sequence $ map (mconvAtom pp kenv tenv) xs - - --- Utils ---------------------------------------------------------------------- --- | Take a variable from an expression as a local var, if any. -takeLocalV - :: Platform - -> KindEnv A.Name -> TypeEnv A.Name - -> C.Exp a A.Name -> Maybe Var - -takeLocalV pp kenv tenv xx - = case xx of - C.XVar _ u@(C.UName (A.NameVar str)) - | Just t <- Env.lookup u tenv - -> Just $ Var (NameLocal str) (convertType pp kenv t) - _ -> Nothing - - --- | Take a variable from an expression as a local var, if any. -takeGlobalV - :: Platform -> C.Module () A.Name - -> KindEnv A.Name -> TypeEnv A.Name - -> C.Exp a A.Name -> Maybe Var - -takeGlobalV pp mm kenv tenv xx - | C.XVar _ u@(C.UName nSuper) <- xx - , Just t <- Env.lookup u tenv - = let - mImport = lookup nSuper (C.moduleImportValues mm) - mExport = lookup nSuper (C.moduleExportValues mm) - Just str = liftM renderPlain $ A.seaNameOfSuper mImport mExport nSuper - - in Just $ Var (NameGlobal str) (convertType pp kenv t) - - | otherwise - = Nothing - diff --git a/DDC/Core/Llvm/Convert/Base.hs b/DDC/Core/Llvm/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Base.hs @@ -0,0 +1,79 @@ + +module DDC.Core.Llvm.Convert.Base + ( ConvertM + , LlvmState(..) + , llvmStateInit + + -- * Errors + , Error (..) + , throw + + -- * Uniques + , newUnique + , newUniqueVar + , newUniqueNamedVar + , newUniqueLabel) +where +import DDC.Core.Llvm.Convert.Error +import DDC.Llvm.Syntax +import DDC.Control.Monad.Check +import Data.Map (Map) +import qualified Data.Map as Map + + +-- ConvertM --------------------------------------------------------------------------------------- +-- | The toLLVM conversion monad. +type ConvertM = CheckM LlvmState Error + + +-- LlvmState -------------------------------------------------------------------------------------- +-- | State for the LLVM conversion. +data LlvmState + = LlvmState + { -- Unique name generator. + llvmStateUnique :: Int + + -- String and array constants collected from the code during conversion. + -- These get stored in statically allocated memory. + , llvmConstants :: Map Var Lit } + + +-- | Initial LLVM state. +llvmStateInit :: LlvmState +llvmStateInit + = LlvmState + { llvmStateUnique = 1 + , llvmConstants = Map.empty } + + +-- Unique ----------------------------------------------------------------------------------------- +-- | Unique name generation. +newUnique :: ConvertM 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 -> ConvertM 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 -> ConvertM Var +newUniqueNamedVar name t + = do u <- newUnique + return $ Var (NameLocal ("_v" ++ show u ++ "." ++ name)) t + + +-- | Generate a new unique label. +newUniqueLabel :: String -> ConvertM Label +newUniqueLabel name + = do u <- newUnique + return $ Label ("l" ++ show u ++ "." ++ name) + + diff --git a/DDC/Core/Llvm/Convert/Context.hs b/DDC/Core/Llvm/Convert/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Context.hs @@ -0,0 +1,164 @@ + +module DDC.Core.Llvm.Convert.Context + ( Context (..) + , extendKindEnv, extendsKindEnv + , extendTypeEnv, extendsTypeEnv + + , ExpContext (..) + , AltResult (..) + , takeVarOfContext + , takeNonVoidVarOfContext) +where +import DDC.Core.Salt.Platform +import DDC.Core.Llvm.Metadata.Tbaa +import DDC.Core.Llvm.Convert.Base +import DDC.Type.Exp +import DDC.Llvm.Syntax +import DDC.Type.Env (KindEnv, TypeEnv) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Map (Map) +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C +import qualified DDC.Type.Env as Env + + +--------------------------------------------------------------------------------------------------- +-- | Context of an Salt to LLVM conversion. +data Context + = Context + { -- | The platform that we're converting to, + -- this sets the pointer width. + contextPlatform :: Platform + + -- | Surrounding module. + , contextModule :: C.Module () A.Name + + -- | The top-level kind environment. + , contextKindEnvTop :: KindEnv A.Name + + -- | The top-level type environment. + , contextTypeEnvTop :: TypeEnv A.Name + + -- | Names of imported supers that are defined in external modules. + -- These are directly callable in the object code. + , contextImports :: Set A.Name + + -- | Names of local supers that are defined in the current module. + -- These are directly callable in the object code. + , contextSupers :: Set A.Name + + -- | Current kind environment. + , contextKindEnv :: KindEnv A.Name + + -- | Current type environment. + , contextTypeEnv :: TypeEnv A.Name + + -- | Map between core level variable names and LLVM names. + , contextNames :: Map A.Name Var + + -- | Super meta data + , contextMDSuper :: MDSuper + + -- | C library functions that are used directly by the generated code without + -- having an import declaration in the header of the converted module. + , contextPrimDecls :: Map String FunctionDecl + + -- | Re-bindings of top-level supers. + -- This is used to handle let-expressions like 'f = g [t]' where + -- 'g' is a top-level super. See [Note: Binding top-level supers] + -- Maps the right hand variable to the left hand one, eg g -> f, + -- along with its type arguments. + , contextSuperBinds + :: Map A.Name (A.Name, [C.Type A.Name]) + + -- Functions to convert the various parts of the AST. + -- We tie the recursive knot though this Context type so that + -- we can split the implementation into separate non-recursive modules. + , contextConvertBody + :: Context -> ExpContext + -> Seq Block -> Label + -> Seq AnnotInstr + -> A.Exp + -> ConvertM (Seq Block) + + , contextConvertExp + :: Context -> ExpContext + -> A.Exp + -> ConvertM (Seq AnnotInstr) + + , contextConvertCase + :: Context -> ExpContext + -> Label + -> Seq AnnotInstr + -> A.Exp + -> [A.Alt] + -> ConvertM (Seq Block) + } + + +-- | Holds the result of converting an alternative. +data AltResult + = AltDefault Label (Seq Block) + | AltCase Lit Label (Seq Block) + + +-- | Extend the kind environment of a context with a new binding. +extendKindEnv :: Bind A.Name -> Context -> Context +extendKindEnv b ctx + = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) } + + +-- | Extend the kind environment of a context with some new bindings. +extendsKindEnv :: [Bind A.Name] -> Context -> Context +extendsKindEnv bs ctx + = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) } + + +-- | Extend the type environment of a context with a new binding. +extendTypeEnv :: Bind A.Name -> Context -> Context +extendTypeEnv b ctx + = ctx { contextTypeEnv = Env.extend b (contextTypeEnv ctx) } + + +-- | Extend the type environment of a context with some new bindings. +extendsTypeEnv :: [Bind A.Name] -> Context -> Context +extendsTypeEnv bs ctx + = ctx { contextTypeEnv = Env.extends bs (contextTypeEnv ctx) } + + +--------------------------------------------------------------------------------------------------- +-- | What expression context we're doing this conversion in. +data ExpContext + -- | Conversion at the top-level of a function. + -- The expresison being converted must eventually pass control. + = ExpTop + + -- | In a nested context, like in the right of a let-binding. + -- The expression should produce a value that we assign to this + -- variable, then jump to the provided label to continue evaluation. + | ExpNest ExpContext Var Label + + -- | In a nested context where we need to assign the result + -- to the given variable and fall through. + | ExpAssign ExpContext Var + + +-- | Take any assignable variable from a `Context`. +takeVarOfContext :: ExpContext -> Maybe Var +takeVarOfContext context + = case context of + ExpTop -> Nothing + ExpNest _ var _ -> Just var + ExpAssign _ var -> Just var + + +-- | Take any assignable variable from a `Context`, but only if it has a non-void type. +-- In LLVM we can't assign to void variables. +takeNonVoidVarOfContext :: ExpContext -> Maybe Var +takeNonVoidVarOfContext context + = case takeVarOfContext context of + Just (Var _ TVoid) -> Nothing + mv -> mv + diff --git a/DDC/Core/Llvm/Convert/Erase.hs b/DDC/Core/Llvm/Convert/Erase.hs deleted file mode 100644 --- a/DDC/Core/Llvm/Convert/Erase.hs +++ /dev/null @@ -1,47 +0,0 @@ - -module DDC.Core.Llvm.Convert.Erase - ( eraseTypeWitArgs - , eraseXLAMs - , eraseWitTApps - , eraseWitBinds ) -where -import DDC.Type.Predicates -import DDC.Core.Exp -import DDC.Core.Transform.TransformUpX - - --- | Erase type and witness arge Slurp out only the values from a list of --- function arguments. -eraseTypeWitArgs :: [Exp a n] -> [Exp a n] -eraseTypeWitArgs [] = [] -eraseTypeWitArgs (x:xs) - = case x of - XType{} -> eraseTypeWitArgs xs - XWitness{} -> eraseTypeWitArgs xs - _ -> x : eraseTypeWitArgs xs - - --- | Erase all `XLAM` binders from an expression. -eraseXLAMs :: Ord n => Exp a n -> Exp a n -eraseXLAMs - = transformUpX' - $ \x -> case x of - XLAM _ _ x' -> x' - _ -> x - - -eraseWitTApps :: Type n -> Type n -eraseWitTApps tt - = case tt of - TApp (TApp (TCon (TyConWitness _)) _) t -> eraseWitTApps t - _ -> tt - - --- | Erase witness bindings -eraseWitBinds :: Eq n => [(Bool, Bind n)] -> [(Bool, Bind n)] -eraseWitBinds - = let isBindWit (_, b) - = case b of - BName _ t | isWitnessType t -> True - _ -> False - in filter (not . isBindWit) diff --git a/DDC/Core/Llvm/Convert/Error.hs b/DDC/Core/Llvm/Convert/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Error.hs @@ -0,0 +1,158 @@ + +module DDC.Core.Llvm.Convert.Error + (Error (..)) +where +import DDC.Core.Module +import DDC.Core.Exp +import DDC.Base.Pretty +import DDC.Core.Exp.Generic.Pretty () +import Data.Maybe +import qualified DDC.Core.Salt as A + + +-- | Things that can go wrong when converting Salt to Llvm code. +-- +-- As user should only hit most of these in the case of compiler errors, +-- or with hand-crafted Salt programs, most of these just an expression +-- and a simple compilaint. +-- +-- Some of the other errors, like for bad type promotions and truncations, +-- can be caused by source language expessions, so we include more +-- information. We leave it to the LLVM conversion to catch these because +-- the decision of whether the conversion is valid is platform dependent. +-- +-- IMPORTANT: Whether or not particular machine primitives are supported is +-- really platform dependent. Fallback implementations for unsupported +-- primitives should be implemented in a Salt-level or Source-level library, +-- and not here in the code generator. +-- +data Error + -- Generic errors that should only be possible by compiling a + -- hand-crafted Salt program. + + -- | Invalid Salt Bound. + = ErrorInvalidBound + { errorBound :: Bound A.Name + , errorDetails :: Maybe String } + + -- | Invalid Salt Bind. + | ErrorInvalidBind + { errorBind :: Bind A.Name + , errorDetails :: Maybe String } + + -- | Invalid Salt type. + | ErrorInvalidType + { errorType :: Type A.Name + , errorDetails :: Maybe String } + + -- | Invalid Salt type constructor. + | ErrorInvalidTyCon + { errorTyCon :: TyCon A.Name + , errorDetails :: Maybe String } + + -- | Invalid Salt expression. + | ErrorInvalidExp + { errorExp :: A.Exp + , errorDetails :: Maybe String } + + -- | Invalid Salt alternative. + | ErrorInvalidAlt + { errorAlt :: [A.Alt] + , errorDetails :: Maybe String } + + -- | Invalid Super + | ErrorInvalidSuper + { errorBind :: Bind A.Name + , errorExp :: A.Exp } + + -- | Invalid Module + | ErrorInvalidModule + { errorModule :: Module () A.Name } + + -- Platform specific errors that might arise in otherwise well-typed + -- source programs. + + -- | The size# primitive was applied to an invalid type. + | ErrorInvalidSizeType + { errorType :: Type A.Name } + + -- | The size2# primitive was applied to an invalid type. + | ErrorInvalidSize2Type + { errorType :: Type A.Name } + + -- | This use of convert# is not valid on this platform. + | ErrorInvalidConversion + { errorTypeFrom :: Type A.Name + , errorTypeTo :: Type A.Name } + + -- | This use of promote# is not valid on this platform. + | ErrorInvalidPromotion + { errorTypeFrom :: Type A.Name + , errorTypeTo :: Type A.Name } + + -- | This use of truncate# is not valid on this platform. + | ErrorInvalidTruncation + { errorTypeFrom :: Type A.Name + , errorTypeTo :: Type A.Name } + + -- | Arithmetic or logic primop cannot be used at this type. + | ErrorInvalidArith + { errorPrimArith :: A.PrimArith + , errorType :: Type A.Name } + deriving Show + + +instance Pretty Error where + + ppr (ErrorInvalidBound u md) + = vcat [ text "Invalid bound: " <> ppr u + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidBind b md) + = vcat [ text "Invalid bind: " <> ppr b + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidType t md) + = vcat [ text "Invalid type: " <> ppr t + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidTyCon tc md) + = vcat [ text "Invalid type constructor: " <> ppr tc + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidExp x md) + = vcat [ text "Invalid exp: " <> ppr x + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidAlt alts md) + = vcat [ text "Invalid alts: " <> ppr alts + , text $ fromMaybe "" md ] + + ppr (ErrorInvalidSuper _n _x) + = vcat [ text "Invalid super." ] + + ppr (ErrorInvalidModule _m) + = vcat [ text "Invalid module." ] + + ppr (ErrorInvalidSizeType t) + = vcat [ text "Cannot apply size# to type '" <> ppr t <> text "'" ] + + ppr (ErrorInvalidSize2Type t) + = vcat [ text "Cannot apply size2# to type '" <> ppr t <> text "'" ] + + ppr (ErrorInvalidConversion tSrc tDst) + = vcat [ text "Cannot convert# value of type '" <> ppr tSrc + <> text "' to '" <> ppr tDst <> text "'" ] + + ppr (ErrorInvalidPromotion tSrc tDst) + = vcat [ text "Cannot promote# value of type '" <> ppr tSrc + <> text "' to '" <> ppr tDst <> text "'" ] + + ppr (ErrorInvalidTruncation tSrc tDst) + = vcat [ text "Cannot truncate# value of type '" <> ppr tSrc + <> text "' to '" <> ppr tDst <> text "'" ] + + ppr (ErrorInvalidArith n t) + = vcat [ text "Cannot use " <> ppr n + <> text " at type '" <> ppr t <> text "'" ] + diff --git a/DDC/Core/Llvm/Convert/Exp.hs b/DDC/Core/Llvm/Convert/Exp.hs --- a/DDC/Core/Llvm/Convert/Exp.hs +++ b/DDC/Core/Llvm/Convert/Exp.hs @@ -1,71 +1,58 @@ module DDC.Core.Llvm.Convert.Exp - ( BodyContext (..) - , convBodyM) + ( Context (..) + , convertBody + , convertSimple + , bindLocalA, bindLocalAs) where -import DDC.Core.Llvm.Convert.Prim +import DDC.Core.Llvm.Convert.Exp.PrimCall +import DDC.Core.Llvm.Convert.Exp.PrimArith +import DDC.Core.Llvm.Convert.Exp.PrimCast +import DDC.Core.Llvm.Convert.Exp.PrimStore +import DDC.Core.Llvm.Convert.Exp.Atom +import DDC.Core.Llvm.Convert.Context 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.Core.Llvm.Convert.Base import DDC.Llvm.Syntax -import DDC.Core.Salt.Platform -import DDC.Core.Compounds -import DDC.Type.Env (KindEnv, TypeEnv) -import DDC.Base.Pretty hiding (align) -import DDC.Data.ListUtils -import Control.Monad.State.Strict (gets) -import Control.Monad -import Data.Maybe -import Data.Sequence (Seq, (<|), (|>), (><)) +import DDC.Core.Exp.Generic.Compounds +import Control.Applicative +import Data.Sequence (Seq, (|>), (><)) import qualified DDC.Core.Salt as A -import qualified DDC.Core.Salt.Convert as A import qualified DDC.Core.Exp as C import qualified DDC.Type.Env as Env import qualified Data.Sequence as Seq - - --- Body ------------------------------------------------------------------------------------------- --- | What context we're doing this conversion in. -data BodyContext - -- | Conversion at the top-level of a function. - -- The expresison being converted must eventually pass control. - = BodyTop - - -- | In a nested context, like in the right of a let-binding. - -- The expression should produce a value that we assign to this - -- variable, then jump to the provided label to continue evaluation. - | BodyNest Var Label - deriving Show +import qualified Data.Set as Set +import qualified Data.Map as Map +--------------------------------------------------------------------------------------------------- -- | Convert a function body to LLVM blocks. -convBodyM - :: BodyContext -- ^ Context of this conversion. - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper +convertBody + :: Context + -> ExpContext -> Seq Block -- ^ Previous blocks. -> Label -- ^ Id of current block. -> Seq AnnotInstr -- ^ Instrs in current block. - -> C.Exp () A.Name -- ^ Expression being converted. - -> LlvmM (Seq Block) -- ^ Final blocks of function body. + -> A.Exp -- ^ Expression being converted. + -> ConvertM (Seq Block) -- ^ Final blocks of function body. -convBodyM context kenv tenv mdsup blocks label instrs xx - = do pp <- gets llvmStatePlatform - mm <- gets llvmStateModule +convertBody ctx ectx blocks label instrs xx + = let pp = contextPlatform ctx + kenv = contextKindEnv ctx + convertCase = contextConvertCase ctx + atomsR as' = sequence $ map (mconvArg ctx) as' + in do case xx of -- Control transfer instructions ----------------- -- Void return applied to a literal void constructor. -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + A.XApp{} + | ExpTop{} <- ectx + , Just (p, as) <- takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p - , [C.XType{}, C.XCon _ dc] <- xs - , Just A.NameLitVoid <- takeNameOfDaCon dc + , [A.RType{}, A.RExp (A.XCon dc)] <- as + , Just (A.NamePrimLit A.PrimLitVoid) <- takeNameOfDaCon dc -> return $ blocks |> Block label (instrs |> (annotNil $ IReturn Nothing)) @@ -73,43 +60,45 @@ -- Void return applied to some other expression. -- We still have to eval the expression, but it returns no value. -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + A.XApp{} + | ExpTop{} <- ectx + , Just (p, as) <- takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p - , [C.XType _ t, x2] <- xs + , [A.RType t, A.RExp x2] <- as , isVoidT t - -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2 + -> do instrs2 <- convertSimple ctx ectx x2 return $ blocks |> Block label (instrs >< (instrs2 |> (annotNil $ IReturn Nothing))) -- Return a value. -- We must be at the top-level of the function. - C.XApp{} - | BodyTop <- context - , Just (A.NamePrimOp p, xs) <- takeXPrimApps xx + A.XApp{} + | ExpTop{} <- ectx + , Just (p, as) <- takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p - , [C.XType _ t, x] <- xs - -> do let t' = convertType pp kenv t + , [A.RType t, A.RExp x] <- as + -> do t' <- convertType pp kenv t vDst <- newUniqueVar t' - is <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x + is <- convertSimple ctx (ExpAssign ectx vDst) x return $ blocks |> Block label (instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst))))) -- Fail and abort the program. -- Allow this inside an expression as well as from the top level. - 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") [] [] + A.XApp{} + | Just (p, as) <- takeXPrimApps xx + , A.PrimControl A.PrimControlFail <- p + , [A.RType _tResult] <- as + -> let + iSet = case ectx of + ExpTop{} -> INop + ExpNest _ vDst _ -> ISet vDst (XUndef (typeOfVar vDst)) + ExpAssign _ vDst -> ISet vDst (XUndef (typeOfVar vDst)) - iSet = case context of - BodyTop -> INop - BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst)) + iFail = ICall Nothing CallTypeStd Nothing + TVoid (NameGlobal "abort") [] [] block = Block label $ instrs |> annotNil iSet @@ -117,387 +106,331 @@ |> annotNil IUnreachable - in return $ blocks |> block + in return $ blocks |> block -- Calls ----------------------------------------- -- Tailcall a function. -- We must be at the top-level of the function. - 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 mm kenv tenv xFun - , Just xsArgs' <- sequence $ map (mconvAtom pp kenv tenv) xsArgs - -> if isVoidT tResult - -- Tailcalled function returns void. - then do return $ blocks - |> (Block label $ instrs - |> (annotNil $ ICall Nothing CallTypeTail Nothing - (convertType pp kenv tResult) nFun xsArgs' []) - |> (annotNil $ IReturn Nothing)) + A.XApp{} + | Just (p, args) <- takeXPrimApps xx + , A.PrimCall (A.PrimCallTail arity) <- p + , _tsArgs <- take arity args + , A.RType tResult : A.RExp xFunTys : xsArgs + <- drop arity args + , (xFun, _xsTys) <- splitXApps xFunTys + , Just mFun <- takeGlobalV ctx xFun + , Just msArgs <- sequence $ map (mconvArg ctx) xsArgs + -> do + Var nFun _ <- mFun + xsArgs' <- sequence msArgs + tResult' <- convertType pp kenv tResult + if isVoidT tResult + -- Tail called function returns void. + then do + return $ blocks + |> (Block label $ instrs + |> (annotNil $ ICall Nothing CallTypeTail Nothing + tResult' nFun xsArgs' []) + |> (annotNil $ IReturn Nothing)) - -- Tailcalled function returns an actual value. - 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)))) + -- Tail called function returns an actual value. + else do + vDst <- newUniqueVar tResult' + return $ blocks + |> (Block label $ instrs + |> (annotNil $ ICall (Just vDst) CallTypeTail Nothing + tResult' nFun xsArgs' []) + |> (annotNil $ IReturn (Just (XVar vDst)))) -- Assignment ------------------------------------ + -- Read from a pointer, with integrated bounds check. + A.XLet (A.LLet (C.BName nDst _) x1) x2 + | Just (p, as) <- takeXPrimApps x1 + , A.PrimStore A.PrimStorePeekBounded <- p + , A.RType{} : A.RType tDst : args <- as + , Just [mPtr, mOffset, mLength] <- atomsR args + -> do + tDst' <- convertType pp kenv tDst + (ctx', vDst@(Var nDst' _)) + <- bindLocalV ctx nDst tDst - -- A statement of type void does not produce a value. - 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 + xPtr' <- mPtr + xOffset' <- mOffset + xLength' <- mLength + let vTest = Var (bumpName nDst' "test") (TInt 1) + let vAddr1 = Var (bumpName nDst' "addr1") (tAddr pp) + let vAddr2 = Var (bumpName nDst' "addr2") (tAddr pp) + let vPtr = Var (bumpName nDst' "ptr") (tPtr tDst') - -- A non-void let-expression. - -- In C we can just drop a computed value on the floor, - -- but the LLVM compiler needs an explicit name for it. - -- Add the required name then call ourselves again. - 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 + labelFail <- newUniqueLabel "peek-bounds" + labelOk <- newUniqueLabel "peek-ok" - convBodyM context kenv tenv mdsup blocks label instrs - (C.XLet a (C.LLet b x1) x2) + let blockEntry = Block label + $ instrs + >< (Seq.fromList $ map annotNil + [ ICmp vTest (ICond ICondUlt) xOffset' xLength' + , IBranchIf (XVar vTest) labelOk labelFail ]) - -- Variable assigment from a case-expression. - C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) - (C.XCase _ xScrut alts)) - x2 - -> do - let t' = convertType pp kenv t + let blockFail = Block labelFail + $ Seq.fromList $ map annotNil + [ case ectx of + ExpTop{} -> INop + ExpNest _ vDst' _ -> ISet vDst' (XUndef (typeOfVar vDst')) + ExpAssign _ vDst' -> ISet vDst' (XUndef (typeOfVar vDst')) - -- Assign result of case to this variable. - let n' = A.sanitizeName n - let vCont = Var (NameLocal n') t' + , ICall Nothing CallTypeStd Nothing + TVoid (NameGlobal "abort") [] [] - -- Label to jump to continue evaluating 'x1' - lCont <- newUniqueLabel "cont" + , IUnreachable] - let context' = BodyNest vCont lCont - blocksCase <- convCaseM context' pp kenv tenv mdsup - label instrs xScrut alts + let instrsCont = Seq.fromList $ map annotNil + [ IConv vAddr1 ConvPtrtoint xPtr' + , IOp vAddr2 OpAdd (XVar vAddr1) xOffset' + , IConv vPtr ConvInttoptr (XVar vAddr2) + , ILoad vDst (XVar vPtr)] - let tenv' = Env.extend b tenv - convBodyM context kenv tenv' mdsup - (blocks >< blocksCase) - lCont - Seq.empty - x2 + convertBody ctx' ectx + (blocks |> blockEntry |> blockFail) + labelOk instrsCont x2 - -- Variable assignment from an non-case expression. - 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 + -- Write to a pointer, with integrated bounds check. + A.XLet (A.LLet _ x1) x2 + | Just (p, as) <- takeXPrimApps x1 + , A.PrimStore A.PrimStorePokeBounded <- p + , A.RType{} : A.RType tVal : args <- as + , Just [mPtr, mOffset, mLength, mVal] <- atomsR args + -> do + tVal' <- convertType pp kenv tVal + xPtr' <- mPtr + xOffset' <- mOffset + xLength' <- mLength + xVal' <- mVal + vTest <- newUniqueNamedVar "test" (TInt 1) + vAddr1 <- newUniqueNamedVar "addr1" (tAddr pp) + vAddr2 <- newUniqueNamedVar "addr2" (tAddr pp) + vPtr <- newUniqueNamedVar "ptr" (tPtr tVal') - -- Letregions ------------------------------------ - C.XLet _ (C.LPrivate b _mt _) x2 - -> do let kenv' = Env.extends b kenv - convBodyM context kenv' tenv mdsup blocks label instrs x2 + labelFail <- newUniqueLabel "poke-bounds" + labelOk <- newUniqueLabel "poke-ok" - -- Case ------------------------------------------ - C.XCase _ xScrut alts - -> do blocks' <- convCaseM context pp kenv tenv mdsup - label instrs xScrut alts + let blockEntry = Block label + $ instrs + >< (Seq.fromList $ map annotNil + [ ICmp vTest (ICond ICondUlt) xOffset' xLength' + , IBranchIf (XVar vTest) labelOk labelFail ]) - return $ blocks >< blocks' + let blockFail = Block labelFail + $ Seq.fromList $ map annotNil + [ case ectx of + ExpTop{} -> INop + ExpNest _ vDst' _ -> ISet vDst' (XUndef (typeOfVar vDst')) + ExpAssign _ vDst' -> ISet vDst' (XUndef (typeOfVar vDst')) - -- Cast ------------------------------------------- - C.XCast _ _ x - -> convBodyM context kenv tenv mdsup blocks label instrs x + , ICall Nothing CallTypeStd Nothing + TVoid (NameGlobal "abort") [] [] - _ - | 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')))) + , IUnreachable] - | otherwise - -> die $ renderIndent - $ text "Invalid body statement " - <$> ppr xx - + let instrsCont = Seq.fromList $ map annotNil + [ IConv vAddr1 ConvPtrtoint xPtr' + , IOp vAddr2 OpAdd (XVar vAddr1) xOffset' + , IConv vPtr ConvInttoptr (XVar vAddr2) + , IStore (XVar vPtr) xVal' ] --- Exp -------------------------------------------------------------------------------------------- --- | What context we're doing this conversion in. -data ExpContext - -- | Conversion at the top-level of the function. - -- We don't have a variable to assign the result to, - -- so this must be a statement that transfers control - = ExpTop + convertBody ctx ectx + (blocks |> blockEntry |> blockFail) + labelOk instrsCont x2 - -- | Conversion in a context that expects a value. - -- We evaluate the expression and assign the result to this variable. - | ExpAssign Var - deriving Show + -- A let-bound expression without a name, of the void type. + A.XLet (A.LLet (C.BNone t) x1) x2 + | isVoidT t + -> do instrs' <- convertSimple ctx ectx x1 + convertBody ctx ectx blocks label + (instrs >< instrs') x2 --- | Take any assignable variable from an `ExpContext`. -varOfExpContext :: ExpContext -> Maybe Var -varOfExpContext xc - = case xc of - ExpTop -> Nothing - ExpAssign var -> Just var + -- A let-bound expression without a name, of some non-void type. + -- In C we can just drop a computed value on the floor, + -- but the LLVM compiler needs an explicit name for it. + -- Add the required name then call ourselves again. + A.XLet (A.LLet (C.BNone t) x1) x2 + | not $ isVoidT t + -> do n <- newUnique + let b = C.BName (A.NameVar ("_d" ++ show n)) t --- | Convert a simple Core expression to LLVM instructions. --- --- This only works for variables, literals, and full applications of --- primitive operators. The client should ensure the program is in this form --- before converting it. The result is just a sequence of instructions, - -- so there are no new labels to jump to. -convExpM - :: ExpContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> C.Exp () A.Name -- ^ Expression to convert. - -> LlvmM (Seq AnnotInstr) + convertBody ctx ectx blocks label instrs + (A.XLet (A.LLet b x1) x2) -convExpM context pp kenv tenv mdsup xx - = do mm <- gets llvmStateModule - 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)) + -- Variable assigment from a case-expression. + A.XLet (A.LLet (C.BName nm t) + (A.XCase xScrut alts)) + x2 + -> do + -- Bind the Salt name, allocating a new LLVM variable for it. + -- The alternatives assign their final result to this variable. + (ctx', vCont) <- bindLocalV ctx nm t - A.NameLitWord w bits - -> return $ Seq.singleton $ annotNil - $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w)) + -- Label to jump to continue evaluating 'x1' + lCont <- newUniqueLabel "cont" - _ -> die "Invalid literal" + -- Convert the alternatives. + -- As the let-binding is non-recursive, the alternatives are + -- converted in the original context, without the let-bound + -- variable (ctx). + let ectx' = ExpNest ectx vCont lCont + blocksCase <- convertCase ctx ectx' label instrs xScrut alts - C.XApp{} - -- Call to primop. - | Just (C.XVar _ (C.UPrim (A.NamePrimOp p) tPrim), args) <- takeXApps xx - -> convPrimCallM pp kenv tenv mdsup - (varOfExpContext context) - p tPrim args + -- Convert the body of the let-expression. + -- This is done in the new context, with the let-bound variable. + convertBody ctx' ectx + (blocks >< blocksCase) + lCont Seq.empty x2 - -- Call to top-level super. - | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx - , Just (Var nFun _) <- takeGlobalV pp mm 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 + -- Variable assignment from an instantiated super name. + -- We can't generate LLVM code for these bindings directly, so they are + -- stashed in the context until we find a conversion that needs them. + -- See [Note: Binding top-level supers] + A.XLet (A.LLet (C.BName nBind _) x1) x2 + | (xF, asArgs) <- splitXApps x1 + , A.XVar (C.UName nSuper) <- xF + , tsArgs <- [t | A.RType t <- asArgs] + , length tsArgs > 0 + , length asArgs == length tsArgs + , Set.member nSuper (contextSupers ctx) + || Set.member nSuper (contextImports ctx) + -> do let ctx' = ctx { contextSuperBinds + = Map.insert nBind (nSuper, tsArgs) + (contextSuperBinds ctx) } + convertBody ctx' ectx blocks label instrs x2 - _ -> die $ "Invalid expression " ++ show xx + -- Variable assignment from some other expression. + A.XLet (A.LLet (C.BName nm t) x1) x2 + -> do + -- Bind the Salt name, allocating a new LLVM variable name for it. + (ctx', vDst) <- bindLocalV ctx nm t --- Case ------------------------------------------------------------------------------------------- -convCaseM - :: BodyContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> Label -- label of current block - -> Seq AnnotInstr -- intrs to prepend to initial block. - -> C.Exp () A.Name - -> [C.Alt () A.Name] - -> LlvmM (Seq Block) + -- Convert the bound expression. + -- As the let-binding is non-recursive, the bound expression + -- is converted in the original context, without the let-bound + -- variable (ctx). + instrs' <- convertSimple ctx (ExpAssign ectx vDst) x1 + + -- Convert the body of the let-expression. + -- This is done in the new context, with the let-bound variable. + convertBody ctx' ectx blocks label (instrs >< instrs') x2 -convCaseM context pp kenv tenv mdsup label instrs xScrut alts - | Just vScrut'@Var{} <- takeLocalV pp kenv tenv xScrut - = do - -- Convert all the alternatives. - -- If we're in a nested context we'll also get a block to join the - -- results of each alternative. - (alts', blocksJoin) - <- convAlts context pp kenv tenv mdsup alts - -- Build the switch --------------- - -- Determine what default alternative to use for the instruction. - (lDefault, blocksDefault) - <- case last alts' of - AltDefault l bs -> return (l, bs) - AltCase _ l bs -> return (l, bs) - - -- Alts that aren't the default. - let Just altsTable = takeInit alts' - - -- Build the jump table of non-default 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" + -- Letregions ------------------------------------ + A.XLet (A.LPrivate bsType _mt _) x2 + -> do let ctx' = extendsKindEnv bsType ctx + convertBody ctx' ectx blocks label instrs x2 --- Alts ------------------------------------------------------------------------------------------- -convAlts - :: BodyContext - -> Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper - -> [C.Alt () A.Name] - -> LlvmM ([AltResult], Seq Block) - --- Alternatives are at top level. -convAlts BodyTop - _pp kenv tenv mdsup alts - = do - alts' <- mapM (convAltM BodyTop kenv tenv mdsup) alts - return (alts', Seq.empty) + -- Case ------------------------------------------ + A.XCase xScrut alts + -> do blocks' <- convertCase ctx ectx label instrs xScrut alts + return $ blocks >< blocks' --- If we're doing a branch inside a let-binding we need to add a join --- point to collect the results from each altenative before continuing --- on to evaluate the rest. -convAlts (BodyNest vDst lCont) - _pp kenv tenv mdsup alts - = do - let tDst' = typeOfVar vDst - - -- Label of the block that does the join. - lJoin <- newUniqueLabel "join" - - -- Convert all the alternatives, - -- assiging their results into separate vars. - (vDstAlts, alts'@(_:_)) - <- liftM unzip - $ mapM (\alt -> do - vDst' <- newUniqueNamedVar "alt" tDst' - alt' <- convAltM (BodyNest vDst' lJoin) kenv tenv mdsup alt - return (vDst', alt')) - $ alts - - -- A block to join the result from each alternative. - -- Trying to keep track of which block a variable is defined in is - -- too hard when we have nested join points. - -- Instead, we set the label here to 'unknown' and fix this up in the - -- Clean transform. - let blockJoin - = Block lJoin - $ Seq.fromList $ map annotNil - [ IPhi vDst [ (XVar vDstAlt, Label "unknown") - | vDstAlt <- vDstAlts ] - , IBranch lCont ] - - return (alts', Seq.singleton blockJoin) + -- Cast ------------------------------------------- + A.XCast _ x + -> convertBody ctx ectx blocks label instrs x + _ + | ExpNest _ vDst label' <- ectx + -> do instrs' <- convertSimple ctx (ExpAssign ectx vDst) xx + return $ blocks >< Seq.singleton (Block label + (instrs >< (instrs' |> (annotNil $ IBranch label')))) --- Alt -------------------------------------------------------------------------------------------- --- | Holds the result of converting an alternative. -data AltResult - = AltDefault Label (Seq Block) - | AltCase Lit Label (Seq Block) + | otherwise + -> throw $ ErrorInvalidExp xx + $ Just "Cannot use this as the body of a super." --- | Convert a case alternative to LLVM. +-- Exp -------------------------------------------------------------------------------------------- +-- | Convert a simple Core expression to LLVM instructions. -- --- This only works for zero-arity constructors. --- The client should extrac the fields of algebraic data objects manually. -convAltM - :: BodyContext -- ^ Context we're converting in. - -> KindEnv A.Name -- ^ Kind environment. - -> TypeEnv A.Name -- ^ Type environment. - -> MDSuper -- ^ Meta-data for the enclosing super. - -> C.Alt () A.Name -- ^ Alternative to convert. - -> 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" - - --- | Convert a constructor name from a pattern to a LLVM literal. +-- This only works for variables, literals, and full applications of +-- primitive operators. The client should ensure the program is in this form +-- before converting it. The result is just a sequence of instructions, +-- so there are no new labels to jump to. -- --- Only integral-ish types can be used as patterns, for others --- such as Floats we rely on the Lite transform to have expanded --- cases on float literals into a sequence of boolean checks. -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 +convertSimple + :: Context -> ExpContext + -> A.Exp + -> ConvertM (Seq AnnotInstr) - A.NameLitNat i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i +convertSimple ctx ectx xx + = let pp = contextPlatform ctx + tenv = contextTypeEnv ctx + kenv = contextKindEnv ctx + in do + case xx of + -- Atoms + _ | ExpAssign _ vDst <- ectx + , Just mx <- mconvAtom ctx xx + -> do x' <- mx + return $ Seq.singleton $ annotNil + $ ISet vDst x' - A.NameLitInt i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + -- Primitive operators. + A.XApp{} + | Just (p, args) <- takeXPrimApps xx + , mDst <- takeNonVoidVarOfContext ectx + , Just go <- foldl (<|>) empty + [ convPrimCall ctx mDst p args + , convPrimArith ctx mDst p args + , convPrimCast ctx mDst p args + , convPrimStore ctx mDst p args ] + -> go - A.NameLitWord i bits - | elem bits [8, 16, 32, 64] - -> Just $ LitInt (TInt $ fromIntegral bits) i + -- Call to top-level super. + | (xFun@(A.XVar u), xsArgs) <- splitXApps xx + , Just tSuper <- Env.lookup u tenv + , Just msArgs_value <- sequence $ map (mconvArg ctx) $ eraseTypeWitArgs xsArgs + , Just mFun <- takeGlobalV ctx xFun + -> do + Var nFun _ <- mFun + xsArgs_value' <- sequence $ msArgs_value + (_, tResult) <- convertSuperType pp kenv tSuper + let mv = case tResult of + TVoid -> Nothing + _ -> takeNonVoidVarOfContext ectx - A.NameLitTag i -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i + return $ Seq.singleton $ annotNil + $ ICall mv CallTypeStd Nothing + tResult nFun xsArgs_value' [] + -- Casts + A.XCast _ x + -> convertSimple ctx ectx x - _ -> Nothing + _ -> throw $ ErrorInvalidExp xx + $ Just "Was expecting a variable, primitive, or super application." --- | Take the blocks from an `AltResult`. -altResultBlocks :: AltResult -> Seq Block -altResultBlocks aa - = case aa of - AltDefault _ blocks -> blocks - AltCase _ _ blocks -> blocks +--------------------------------------------------------------------------------------------------- +-- | Erase type and witness arge Slurp out only the values from a list of +-- function arguments. +eraseTypeWitArgs :: [A.Arg] -> [A.Arg] +eraseTypeWitArgs [] = [] +eraseTypeWitArgs (x:xs) + = case x of + A.RType{} -> eraseTypeWitArgs xs + A.RWitness{} -> eraseTypeWitArgs xs + _ -> x : eraseTypeWitArgs xs --- | Take the `Lit` and `Label` from an `AltResult` -takeAltCase :: AltResult -> Maybe (Lit, Label) -takeAltCase (AltCase lit label _) = Just (lit, label) -takeAltCase _ = 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) diff --git a/DDC/Core/Llvm/Convert/Exp/Atom.hs b/DDC/Core/Llvm/Convert/Exp/Atom.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/Atom.hs @@ -0,0 +1,283 @@ + +module DDC.Core.Llvm.Convert.Exp.Atom + ( mconvArg + , mconvAtom + + , bindLocalV + , bindLocalA, bindLocalAs + , takeLocalV + , takeGlobalV) +where +import DDC.Llvm.Syntax +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Llvm.Convert.Context +import DDC.Core.Llvm.Convert.Base +import DDC.Core.Salt.Platform +import DDC.Control.Monad.Check +import DDC.Base.Pretty +import Control.Monad +import Data.Maybe +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Convert as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C +import qualified Data.Map as Map +import qualified Data.List as List + + +-- Arguments ------------------------------------------------------------------ +-- | Convert a function argument expression +-- yielding Nothing if this is a `Witness` or `Type`. +mconvArg :: Context -> A.Arg -> Maybe (ConvertM Exp) +mconvArg ctx aa + = case aa of + A.RWitness _ -> Nothing + A.RExp x -> mconvAtom ctx x + A.RType _ -> Nothing + + +-- Atoms ---------------------------------------------------------------------- +-- | Convert an atomic expression to LLVM, +-- or `Nothing` if this is not one of those. +-- +-- If the expression is an atom but is mistyped or malformed then running +-- the returned computation will throw an exception in the ConvertM monad. +-- +-- Converted atoms can be used directly as arguments to LLVM instructions. +-- +mconvAtom :: Context -> A.Exp -> Maybe (ConvertM Exp) +mconvAtom ctx xx + = let pp = contextPlatform ctx + kenv = contextKindEnv ctx + in case xx of + + -- Global names + A.XVar (C.UName _) + | Just mv <- takeGlobalV ctx xx + -> Just $ do + var <- mv + return $ XVar var + + -- Local names + A.XVar (C.UName _) + | Just mv <- takeLocalV ctx xx + -> Just $ do + var <- mv + return $ XVar var + + -- Literal unit values are represented as a null pointer. + A.XCon C.DaConUnit + -> Just $ return $ XLit (LitNull (TPointer (tObj pp))) + + -- Primitive unboxed literals. + A.XCon dc + | C.DaConPrim (A.NamePrimLit lit) t <- dc + -> do case lit of + -- Literal booleans. + A.PrimLitBool b + -> let i | b = 1 + | otherwise = 0 + in Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' i) + + -- Literal natural numbers of some width. + A.PrimLitNat nat + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' nat) + + -- Literal integers of some width. + A.PrimLitInt val + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' val) + + -- Literal size value. + A.PrimLitSize val + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' val) + + -- Literal binary word of some width. + A.PrimLitWord val _ + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' val) + + -- Literal floating point value of some width. + A.PrimLitFloat val _ + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitFloat t' val) + + -- A text literal. + A.PrimLitTextLit tx + -> Just $ do + -- Add literal text constant to the constants map for + -- the current module. These constants will be + -- allocated into static memory, and reachable by the + -- returned name. + var <- addConstant ctx $ makeLitString tx + let w = 8 * platformAddrBytes pp + + return $ XGet (TPointer (TInt 8)) + (XVar var) + [ XLit (LitInt (TInt w) 0) + , XLit (LitInt (TInt w) 0) ] + + -- Literal constructor tag. + A.PrimLitTag tag + -> Just $ do + t' <- convertType pp kenv t + return $ XLit (LitInt t' tag) + + _ -> Nothing + + _ -> Nothing + + +-- Local Variables ------------------------------------------------------------ +-- | Add a variable and its type to the context, +-- producing the corresponding LLVM variable name. +--- +-- We need to sanitize the incoming name because it may include symbols +-- that are not valid for LLVM names. We also need to uniquify them, +-- to avoid name clashes as the the variables in a single LLVM function +-- are all bound at the same level. +-- +bindLocalS :: Context -> String -> A.Type -> ConvertM (Context, Var) +bindLocalS ctx str t + = do t' <- convertType (contextPlatform ctx) (contextKindEnv ctx) t + let str' = A.sanitizeName str + v <- newUniqueNamedVar str' t' + let name = A.NameVar str + let ctx' = extendTypeEnv (C.BName name t) ctx + let ctx'' = ctx' { contextNames = Map.insert name v (contextNames ctx') } + return (ctx'', v) + + +-- | Add a variable and its type to the context, +-- producing the corresponding LLVM variable name. +--- +-- We need to sanitize the incoming name because it may include symbols +-- that are not valid for LLVM names. We also need to uniquify them, +-- to avoid name clashes as the the variables in a single LLVM function +-- are all bound at the same level. +-- +bindLocalV :: Context -> A.Name -> C.Type A.Name -> ConvertM (Context, Var) +bindLocalV ctx (A.NameVar str) t + = do bindLocalS ctx str t + +bindLocalV _ _ _ + = error "ddc-core-llvm.bindLocalV: not a regular name." + + +-- | Like `bindLocalV`, but take the binder directly. +bindLocalB :: Context -> A.Bind -> ConvertM (Context, Var) +bindLocalB ctx b + = case b of + C.BName nm t -> bindLocalV ctx nm t + C.BNone t -> bindLocalV ctx (A.NameVar "_arg") t + C.BAnon _ + -> error "ddc-core-llvm.bindLocalB: can't convert anonymous binders." + + +-- | Add the binder for a thing to the context. +bindLocalA :: Context -> A.Abs -> ConvertM (Context, Maybe Var) +bindLocalA ctx aa + = case aa of + A.ALAM b + -> return ( ctx { contextKindEnv = Env.extend b $ contextKindEnv ctx } + , Nothing) + + A.ALam b + -> do (ctx', v') <- bindLocalB ctx b + return (ctx', Just v') + + +-- | Add the binders for some things to the context. +bindLocalAs :: Context -> [A.Abs] -> ConvertM (Context, [Var]) +bindLocalAs ctx [] = return (ctx, []) +bindLocalAs ctx (a : as) + = do (ctx', mv) <- bindLocalA ctx a + (ctx'', vs) <- bindLocalAs ctx' as + return (ctx'', maybeToList mv ++ vs) + + +-- | Take a variable from an expression as a local var, if any. +takeLocalV + :: Context -> A.Exp + -> Maybe (ConvertM Var) + +takeLocalV ctx xx + = case xx of + A.XVar (C.UName nm) + | Just v <- Map.lookup nm (contextNames ctx) + -> Just (return v) + _ -> Nothing + + +-- Global Variables / Names --------------------------------------------------- +-- | Take a variable from an expression as a global var, if any. +--- +-- The seaNameOfSuper function sanitizes these, so we can use +-- them as valid LLVM names. +-- +takeGlobalV + :: Context -> A.Exp + -> Maybe (ConvertM Var) + +takeGlobalV ctx xx + = let pp = contextPlatform ctx + mm = contextModule ctx + kenv = contextKindEnvTop ctx + tenv = contextTypeEnvTop ctx + + in case xx of + A.XVar u@(C.UName nSuper) + | Just t <- Env.lookup u tenv + -> Just $ do + let mImport = lookup nSuper (C.moduleImportValues mm) + let mExport = lookup nSuper (C.moduleExportValues mm) + + -- Convert local name to sanitized LLVM name. + let Just str = liftM renderPlain + $ A.seaNameOfSuper mImport mExport nSuper + + t' <- convertType pp kenv t + return $ Var (NameGlobal str) t' + + _ -> Nothing + + +------------------------------------------------------------------------------- +-- | Add a static constant to the map, +-- assigning a new variable to refer to it. +addConstant :: Context -> Lit -> ConvertM Var +addConstant ctx lit + = do + -- This name is going into the global scope, + -- so prepend the module name to uniquify it. + let C.ModuleName parts + = C.moduleName $ contextModule ctx + let mname = List.intercalate "." parts + + -- Make a new variable to name the literal constant. + (Var (NameLocal sLit) tLit) + <- newUniqueNamedVar mname (typeOfLit lit) + + let nLit = NameGlobal sLit + let vLit = Var nLit tLit + + s <- get + put $ s { llvmConstants = Map.insert vLit lit (llvmConstants s)} + + -- Although the constant itself has type tLit, when we refer + -- to a global name in the body of the code the reference is + -- has pointer type. + let vRef = Var nLit (TPointer tLit) + return vRef + + diff --git a/DDC/Core/Llvm/Convert/Exp/Case.hs b/DDC/Core/Llvm/Convert/Exp/Case.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/Case.hs @@ -0,0 +1,206 @@ + +module DDC.Core.Llvm.Convert.Exp.Case + (convertCase) +where +import DDC.Core.Llvm.Convert.Exp.Atom +import DDC.Core.Llvm.Convert.Context +import DDC.Core.Llvm.Convert.Base +import DDC.Llvm.Syntax +import DDC.Core.Salt.Platform +import DDC.Core.Exp.Annot.Compounds +import DDC.Data.ListUtils +import Control.Monad +import Data.Maybe +import Data.Sequence (Seq, (<|), (|>), (><)) +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Exp as C +import qualified Data.Sequence as Seq + + +-- Case ------------------------------------------------------------------------------------------- +convertCase + :: Context -- ^ Context of the conversion. + -> ExpContext -- ^ Expression context. + -> Label -- ^ Label of current block + -> Seq AnnotInstr -- ^ Instructions to prepend to initial block. + -> A.Exp -- ^ Scrutinee of case expression. + -> [A.Alt] -- ^ Alternatives of case expression. + -> ConvertM (Seq Block) + +convertCase ctx ectx label instrs xScrut alts + | Just mVar <- takeLocalV ctx xScrut + = do + vScrut' <- mVar + + -- Convert all the alternatives. + -- If we're in a nested context we'll also get a block to join the + -- results of each alternative. + (alts', blocksJoin) + <- convertAlts ctx ectx alts + + -- Determine what default alternative to use for the instruction. + (lDefault, blocksDefault) + <- case last alts' of + AltDefault l bs -> return (l, bs) + AltCase _ l bs -> return (l, bs) + + -- Get the alternatives before the default one. + -- This will fail if there are no alternatives at all. + altsTable + <- case takeInit alts' of + Nothing -> throw $ ErrorInvalidExp (A.XCase xScrut alts) Nothing + Just as -> return as + + -- Build the jump table of non-default 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) + + | otherwise + = throw $ ErrorInvalidExp (A.XCase xScrut alts) Nothing + + +-- Alts ------------------------------------------------------------------------------------------- +-- | Convert some case alternatives to LLVM. +convertAlts + :: Context -> ExpContext + -> [A.Alt] + -> ConvertM ([AltResult], Seq Block) + +-- Alternatives are at top level. +convertAlts ctx ectx@ExpTop{} alts + = do + alts' <- mapM (convertAlt ctx ectx) alts + return (alts', Seq.empty) + +-- If we're doing a branch inside a let-binding we need to add a join +-- point to collect the results from each altenative before continuing +-- on to evaluate the rest. +convertAlts ctx (ExpNest ectx vDst lCont) alts + = do + -- Label of the block that does the join. + lJoin <- newUniqueLabel "join" + + -- Convert all the alternatives, + -- assiging their results into separate vars. + (vDstAlts, alts'@(_:_)) + <- liftM unzip + $ mapM (\alt -> do + vDst' <- newUniqueNamedVar "alt" (typeOfVar vDst) + alt' <- convertAlt ctx (ExpNest ectx vDst' lJoin) alt + lAlt <- return (altResultLabel alt') + return ((XVar vDst', lAlt), alt')) + $ alts + + -- A block to join the result from each alternative. + let blockJoin + = Block lJoin + $ Seq.fromList $ map annotNil + [ IPhi vDst vDstAlts + , IBranch lCont ] + + return (alts', Seq.singleton blockJoin) + +-- Cannot convert alternative in this context. +convertAlts _ ExpAssign{} alts + = throw $ ErrorInvalidAlt alts + $ Just "Cannot convert alternative in this context." + + +-- Alt -------------------------------------------------------------------------------------------- +-- | Convert a case alternative to LLVM. +-- +-- This only works for zero-arity constructors. +-- The client should extract the fields of algebraic data objects manually. +convertAlt + :: Context -> ExpContext + -> A.Alt + -> ConvertM AltResult + +convertAlt ctx ectx aa + = let pp = contextPlatform ctx + convBodyM = contextConvertBody ctx + in case aa of + A.AAlt A.PDefault x + -> do label <- newUniqueLabel "default" + blocks <- convBodyM ctx ectx Seq.empty label Seq.empty x + return $ AltDefault label blocks + + A.AAlt (A.PData C.DaConUnit []) x + -> do label <- newUniqueLabel "alt" + blocks <- convBodyM ctx ectx Seq.empty label Seq.empty x + return $ AltDefault label blocks + + A.AAlt (A.PData dc []) x + | Just n <- takeNameOfDaCon dc + , Just lit <- convPatName pp n + -> do label <- newUniqueLabel "alt" + blocks <- convBodyM ctx ectx Seq.empty label Seq.empty x + return $ AltCase lit label blocks + + _ -> throw $ ErrorInvalidAlt [aa] Nothing + + +-- | Convert a constructor name from a pattern to a LLVM literal. +-- +-- Only integral-ish types can be used as patterns, for others +-- such as Floats we rely on the Lite transform to have expanded +-- cases on float literals into a sequence of boolean checks. +convPatName :: Platform -> A.Name -> Maybe Lit +convPatName pp (A.NamePrimLit lit) + = case lit of + A.PrimLitBool True + -> Just $ LitInt (TInt 1) 1 + + A.PrimLitBool False + -> Just $ LitInt (TInt 1) 0 + + A.PrimLitNat i + -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.PrimLitInt i + -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.PrimLitWord i bits + | elem bits [8, 16, 32, 64] + -> Just $ LitInt (TInt $ fromIntegral bits) i + + A.PrimLitTag i + -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i + + _ -> Nothing + +convPatName _ _ + = Nothing + + +-- | Take the label from an `AltResult`. +altResultLabel :: AltResult -> Label +altResultLabel aa + = case aa of + AltDefault label _ -> label + AltCase _ label _ -> label + + +-- | Take the blocks from an `AltResult`. +altResultBlocks :: AltResult -> Seq Block +altResultBlocks aa + = case aa of + AltDefault _ blocks -> blocks + AltCase _ _ blocks -> blocks + + +-- | Take the `Lit` and `Label` from an `AltResult` +takeAltCase :: AltResult -> Maybe (Lit, Label) +takeAltCase ac + = case ac of + AltCase lit label _ -> Just (lit, label) + _ -> Nothing + diff --git a/DDC/Core/Llvm/Convert/Exp/PrimArith.hs b/DDC/Core/Llvm/Convert/Exp/PrimArith.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/PrimArith.hs @@ -0,0 +1,157 @@ + +module DDC.Core.Llvm.Convert.Exp.PrimArith + (convPrimArith) +where +import DDC.Llvm.Syntax +import DDC.Core.Llvm.Convert.Exp.Atom +import DDC.Core.Llvm.Convert.Context +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Llvm.Convert.Base +import Data.Sequence (Seq) +import qualified DDC.Core.Exp as C +import qualified DDC.Core.Salt as A +import qualified Data.Sequence as Seq + + +-- | Convert a primitive call to LLVM, +-- or Nothing if this doesn't look like such an operation. +convPrimArith + :: Context -- ^ Context of the conversion. + -> Maybe Var -- ^ Assign result to this var. + -> A.PrimOp -- ^ Primitive to call. + -> [A.Arg] -- ^ Arguments to primitive. + -> Maybe (ConvertM (Seq AnnotInstr)) + +convPrimArith ctx mdst p xs + = let pp = contextPlatform ctx + kenv = contextKindEnv ctx + in case p of + -- Unary operators ------------ + A.PrimArith op + | A.RType t : args <- xs + , Just dst <- mdst + , Just [mx1] <- sequence $ map (mconvArg ctx) args + -> Just $ do + x1' <- mx1 + t' <- convertType pp kenv t + let result + | A.PrimArithNeg <- op + , isIntegralT t + = return $ IOp dst OpSub (XLit $ LitInt t' 0) x1' + + | A.PrimArithNeg <- op + , isFloatingT t + = return $ IOp dst OpSub (XLit $ LitFloat t' 0) x1' + + -- Cannot use primop at this type. + | otherwise + = throw $ ErrorInvalidArith op t + + instr <- result + return $ Seq.singleton (annotNil instr) + + -- Binary operators ----------- + A.PrimArith op + | A.RType t : args <- xs + , Just dst <- mdst + , Just [mx1, mx2] <- sequence $ map (mconvArg ctx) args + -> Just $ do + x1' <- mx1 + x2' <- mx2 + let result + | Just op' <- convPrimArith2 op t + = return $ IOp dst op' x1' x2' + + | Just icond' <- convPrimICond op t + = return $ ICmp dst (ICond icond') x1' x2' + + | Just fcond' <- convPrimFCond op t + = return $ ICmp dst (FCond fcond') x1' x2' + + -- Cannot use primop at this type. + | otherwise + = throw $ ErrorInvalidArith op t + + instr <- result + return $ Seq.singleton (annotNil instr) + + -- This doesn't look like an arithmetic primop. + _ -> Nothing + + +-- | Convert a binary primop from Core Sea to LLVM form. +convPrimArith2 :: A.PrimArith -> C.Type A.Name -> Maybe Op +convPrimArith2 op t + = case op of + A.PrimArithAdd + | isIntegralT t -> Just OpAdd + | isFloatingT t -> Just OpFAdd + + A.PrimArithSub + | isIntegralT t -> Just OpSub + | isFloatingT t -> Just OpFSub + + A.PrimArithMul + | isIntegralT t -> Just OpMul + | isFloatingT t -> Just OpFMul + + A.PrimArithDiv + | isIntegralT t, isUnsignedT t -> Just OpUDiv + | isIntegralT t, isSignedT t -> Just OpSDiv + | isFloatingT t -> Just OpFDiv + + A.PrimArithRem + | isIntegralT t, isUnsignedT t -> Just OpURem + | isIntegralT t, isSignedT t -> Just OpSRem + | isFloatingT t -> Just OpFRem + + A.PrimArithShl + | isIntegralT t -> Just OpShl + + A.PrimArithShr + | isIntegralT t, isUnsignedT t -> Just OpLShr + | isIntegralT t, isSignedT t -> Just OpAShr + + A.PrimArithBAnd + | isIntegralT t -> Just OpAnd + + A.PrimArithBOr + | isIntegralT t -> Just OpOr + + A.PrimArithBXOr + | isIntegralT t -> Just OpXor + + _ -> Nothing + + +-- | Convert an integer comparison from Core Sea to LLVM form. +convPrimICond :: A.PrimArith -> C.Type A.Name -> Maybe ICond +convPrimICond op t + | isIntegralT t + = case op of + A.PrimArithEq -> Just ICondEq + A.PrimArithNeq -> Just ICondNe + A.PrimArithGt -> Just ICondUgt + A.PrimArithGe -> Just ICondUge + A.PrimArithLt -> Just ICondUlt + A.PrimArithLe -> Just ICondUle + _ -> Nothing + + | otherwise = Nothing + + +-- | Convert a floating point comparison from Core Sea to LLVM form. +convPrimFCond :: A.PrimArith -> C.Type A.Name -> Maybe FCond +convPrimFCond op t + | isIntegralT t + = case op of + A.PrimArithEq -> Just FCondOeq + A.PrimArithNeq -> Just FCondOne + A.PrimArithGt -> Just FCondOgt + A.PrimArithGe -> Just FCondOge + A.PrimArithLt -> Just FCondOlt + A.PrimArithLe -> Just FCondOle + _ -> Nothing + + | otherwise = Nothing + diff --git a/DDC/Core/Llvm/Convert/Exp/PrimCall.hs b/DDC/Core/Llvm/Convert/Exp/PrimCall.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/PrimCall.hs @@ -0,0 +1,56 @@ + +module DDC.Core.Llvm.Convert.Exp.PrimCall + (convPrimCall) +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 Data.Sequence (Seq) +import qualified DDC.Core.Salt as A +import qualified Data.Sequence as Seq + + +-- | Convert a primitive store operation to LLVM. +convPrimCall + :: 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)) + +convPrimCall ctx mDst p xs + = let pp = contextPlatform ctx + in case p of + A.PrimCall (A.PrimCallStd arity) + | Just (mFun : msArgs) <- sequence $ map (mconvArg ctx) xs + -> Just $ do + xFun' <- mFun + xsArgs' <- sequence msArgs + + vFun@(Var nFun _) + <- newUniqueNamedVar "fun" + $ TPointer $ tFunction (replicate arity (tAddr pp)) (tAddr pp) + + return $ Seq.fromList $ map annotNil + [ IConv vFun (ConvInttoptr) xFun' + , ICall mDst CallTypeStd Nothing + (tAddr pp) nFun xsArgs' []] + + _ -> Nothing + + +-- Build the type of a function with the given arguments and result type. +tFunction :: [Type] -> Type -> Type +tFunction tsArgs tResult + = TFunction + $ FunctionDecl + { declName = "anon" + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = [ Param t [] | t <- tsArgs ] + , declAlign = AlignNone } + diff --git a/DDC/Core/Llvm/Convert/Exp/PrimCast.hs b/DDC/Core/Llvm/Convert/Exp/PrimCast.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/PrimCast.hs @@ -0,0 +1,176 @@ + +module DDC.Core.Llvm.Convert.Exp.PrimCast + (convPrimCast) +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.Salt.Platform +import Data.Sequence (Seq) +import qualified DDC.Core.Exp as C +import qualified DDC.Core.Salt as A +import qualified Data.Sequence as Seq +import qualified Data.Map as Map + + +------------------------------------------------------------------------------- +-- | Convert a primitive call to LLVM, +-- or Nothing if this doesn't look like such an operation. +convPrimCast + :: Context -- ^ Context of the conversion. + -> Maybe Var -- ^ Assign result to this var. + -> A.PrimOp -- ^ Primitive to call. + -> [A.Arg] -- ^ Arguments to primitive. + -> Maybe (ConvertM (Seq AnnotInstr)) + +convPrimCast ctx mdst p as + = case p of + A.PrimCast A.PrimCastConvert + | [A.RType tDst, A.RType tSrc, xSrc] <- as + , Just vDst <- mdst + -> Just $ do + instr <- convPrimConvert ctx tDst vDst tSrc xSrc + return $ Seq.singleton (annotNil instr) + + A.PrimCast A.PrimCastPromote + | [A.RType tDst, A.RType tSrc, xSrc] <- as + , Just vDst <- mdst + , Just mSrc <- mconvArg ctx xSrc + -> Just $ do + xSrc' <- mSrc + instr <- convPrimPromote ctx tDst vDst tSrc xSrc' + return $ Seq.singleton (annotNil instr) + + A.PrimCast A.PrimCastTruncate + | [A.RType tDst, A.RType tSrc, xSrc] <- as + , Just vDst <- mdst + , Just mSrc <- mconvArg ctx xSrc + -> Just $ do + xSrc' <- mSrc + instr <- convPrimTruncate ctx tDst vDst tSrc xSrc' + return $ Seq.singleton (annotNil instr) + + _ -> Nothing + + +------------------------------------------------------------------------------- +-- | Convert a primitive conversion operator to LLVM, +-- or `Nothing` for an invalid conversion. +convPrimConvert + :: Context + -> C.Type A.Name -> Var + -> C.Type A.Name -> A.Arg + -> ConvertM Instr + +convPrimConvert ctx tDst vDst tSrc aSrc + | pp <- contextPlatform ctx + , kenv <- contextKindEnv ctx + = do + tSrc' <- convertType pp kenv tSrc + tDst' <- convertType pp kenv tDst + + case tSrc' of + + -- Produce the code pointer for a top-level super. + TPointer TFunction{} + + -- Argument is the name of the super itself. + | tDst' == TInt (8 * platformAddrBytes pp) + , Just mSrc <- mconvArg ctx aSrc + -> do xSrc' <- mSrc + return $ IConv vDst ConvPtrtoint xSrc' + + -- Argument is a variable that has been bound to an application of + -- a super variable to some type arguments. + | tDst' == TInt (8 * platformAddrBytes pp) + , A.RExp (A.XVar (C.UName nVar)) <- aSrc + , Just (nSuper, _tsArgs) <- Map.lookup nVar (contextSuperBinds ctx) + , Just mSrc <- mconvArg ctx (A.RExp (A.XVar (C.UName nSuper))) + -> do xSrc' <- mSrc + return $ IConv vDst ConvPtrtoint xSrc' + + -- Conversion is not valid on this platform. + _ -> throw $ ErrorInvalidConversion tSrc tDst + + +------------------------------------------------------------------------------- +-- | Convert a primitive promotion operator to LLVM, +-- or `Nothing` for an invalid promotion. +convPrimPromote + :: Context + -> C.Type A.Name -> Var + -> C.Type A.Name -> Exp + -> ConvertM Instr + +convPrimPromote ctx tDst vDst tSrc xSrc + = do + let pp = contextPlatform ctx + let kenv = contextKindEnv ctx + + tSrc' <- convertType pp kenv tSrc + tDst' <- convertType pp kenv tDst + + case (tDst', tSrc') of + (TInt bitsDst, TInt bitsSrc) + + -- Same sized integers + | bitsDst == bitsSrc + -> return $ ISet vDst xSrc + + -- Both Unsigned + | isUnsignedT tSrc, isUnsignedT tDst + , bitsDst > bitsSrc + -> return $ IConv vDst ConvZext xSrc + + -- Both Signed + | isSignedT tSrc, isSignedT tDst + , bitsDst > bitsSrc + -> return $ IConv vDst ConvSext xSrc + + -- Unsigned to Signed + | isUnsignedT tSrc, isSignedT tDst + , bitsDst > bitsSrc + -> return $ IConv vDst ConvZext xSrc + + -- Promotion is not valid on this platform. + _ -> throw $ ErrorInvalidPromotion tSrc tDst + + +------------------------------------------------------------------------------- +-- | Convert a primitive truncation to LLVM, +-- or `Nothing` for an invalid truncation. +convPrimTruncate + :: Context + -> C.Type A.Name -> Var + -> C.Type A.Name -> Exp + -> ConvertM Instr + +convPrimTruncate ctx tDst vDst tSrc xSrc + = do + let pp = contextPlatform ctx + let kenv = contextKindEnv ctx + + tSrc' <- convertType pp kenv tSrc + tDst' <- convertType pp kenv tDst + + case (tDst', tSrc') of + (TInt bitsDst, TInt bitsSrc) + -- Same sized integers + | bitsDst == bitsSrc + -> return $ ISet vDst xSrc + + -- Destination is smaller + | bitsDst < bitsSrc + -> return $ IConv vDst ConvTrunc xSrc + + -- Unsigned to Signed, + -- destination is larger + | bitsDst > bitsSrc + , isUnsignedT tSrc, isSignedT tDst + -> return $ IConv vDst ConvZext xSrc + + -- Truncation is not valid on this platform. + _ -> throw $ ErrorInvalidTruncation tSrc tDst + diff --git a/DDC/Core/Llvm/Convert/Exp/PrimStore.hs b/DDC/Core/Llvm/Convert/Exp/PrimStore.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Exp/PrimStore.hs @@ -0,0 +1,309 @@ + +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) + diff --git a/DDC/Core/Llvm/Convert/Prim.hs b/DDC/Core/Llvm/Convert/Prim.hs deleted file mode 100644 --- a/DDC/Core/Llvm/Convert/Prim.hs +++ /dev/null @@ -1,454 +0,0 @@ - -module DDC.Core.Llvm.Convert.Prim - (convPrimCallM) -where -import DDC.Llvm.Syntax -import DDC.Core.Llvm.Convert.Atom -import DDC.Core.Llvm.Convert.Type -import DDC.Core.Llvm.Metadata.Tbaa -import DDC.Core.Llvm.LlvmM -import DDC.Core.Salt.Platform -import DDC.Core.Compounds -import DDC.Base.Pretty -import DDC.Type.Env (KindEnv, TypeEnv) -import Data.Sequence (Seq) -import qualified DDC.Core.Exp as C -import qualified DDC.Core.Salt as A -import qualified Data.Sequence as Seq - - --- Prim call ------------------------------------------------------------------ --- | Convert a primitive call to LLVM. -convPrimCallM - :: Show a - => Platform - -> KindEnv A.Name - -> TypeEnv A.Name - -> MDSuper -- ^ Metadata for the enclosing super - -> Maybe Var -- ^ Assign result to this var. - -> A.PrimOp -- ^ Prim to call. - -> C.Type A.Name -- ^ Type of prim. - -> [C.Exp a A.Name] -- ^ Arguments to prim. - -> LlvmM (Seq AnnotInstr) - -convPrimCallM pp kenv tenv mdsup mdst p _tPrim xs - = case p of - -- Binary operations ---------- - A.PrimArith op - | C.XType _ t : args <- xs - , Just [x1', x2'] <- mconvAtoms pp kenv tenv args - , Just dst <- mdst - -> let result - | Just op' <- convPrimArith2 op t - = IOp dst op' x1' x2' - - | Just icond' <- convPrimICond op t - = IICmp dst icond' x1' x2' - - | Just fcond' <- convPrimFCond op t - = IFCmp dst fcond' x1' x2' - - | otherwise - = die $ "Invalid binary primop." - in return $ Seq.singleton (annotNil result) - - -- Cast primops --------------- - A.PrimCast A.PrimCastPromote - | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs - , Just xSrc' <- mconvAtom pp kenv tenv xSrc - , Just vDst <- mdst - , minstr <- convPrimPromote pp kenv tDst vDst tSrc xSrc' - -> case minstr of - Just instr -> return $ Seq.singleton (annotNil instr) - Nothing -> dieDoc $ vcat - [ text "Invalid promotion of numeric value." - , text " from type: " <> ppr tSrc - , text " to type: " <> ppr tDst] - - A.PrimCast A.PrimCastTruncate - | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs - , Just xSrc' <- mconvAtom pp kenv tenv xSrc - , Just vDst <- mdst - , minstr <- convPrimTruncate pp kenv tDst vDst tSrc xSrc' - -> case minstr of - Just instr -> return $ Seq.singleton (annotNil instr) - Nothing -> dieDoc $ vcat - [ text "Invalid truncation of numeric value." - , text " from type: " <> ppr tSrc - , text " to type: " <> ppr tDst ] - - -- Store primops -------------- - A.PrimStore A.PrimStoreSize - | [C.XType _ t] <- xs - , Just vDst <- mdst - -> let t' = convertType pp kenv t - size = case t' of - TPointer _ -> platformAddrBytes pp - TInt bits - | bits `rem` 8 == 0 -> bits `div` 8 - _ -> sorry - - -- Bool# is only 1 bit long. - -- Don't return a result for types that don't divide into 8 bits evenly. - sorry = dieDoc $ vcat - [ text " Invalid type applied to size#."] - - in return $ Seq.singleton - $ annotNil - $ ISet vDst (XLit (LitInt (tNat pp) size)) - - - A.PrimStore A.PrimStoreSize2 - | [C.XType _ t] <- xs - , Just vDst <- mdst - -> let t' = convertType pp kenv t - size = case t' of - TPointer _ -> platformAddrBytes pp - TInt bits - | bits `rem` 8 == 0 -> bits `div` 8 - _ -> sorry - - size2 = truncate $ (log (fromIntegral size) / log 2 :: Double) - - -- Bool# is only 1 bit long. - -- Don't return a result for types that don't divide into 8 bits evenly. - sorry = dieDoc $ vcat - [ text " Invalid type applied to size2#."] - - in return $ Seq.singleton - $ annotNil - $ ISet vDst (XLit (LitInt (tNat pp) size2)) - - - A.PrimStore A.PrimStoreCreate - | Just [xBytes'] <- mconvAtoms pp kenv tenv xs - -> do vAddr <- newUniqueNamedVar "addr" (tAddr pp) - vMax <- newUniqueNamedVar "max" (tAddr pp) - let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) - let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp)) - return $ Seq.fromList - $ map annotNil - [ ICall (Just vAddr) CallTypeStd Nothing - (tAddr pp) (NameGlobal "malloc") - [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) ] - - - A.PrimStore A.PrimStoreCheck - | Just [xBytes'] <- mconvAtoms pp kenv tenv xs - , Just vDst@(Var nDst _) <- mdst - -> do 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 = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) - let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp)) - return $ Seq.fromList - $ map annotNil - [ ILoad vTop (XVar vTopPtr) - , IOp vMin OpAdd (XVar vTop) xBytes' - , ILoad vMax (XVar vMaxPtr) - , IICmp vDst ICondUlt (XVar vMin) (XVar vMax) ] - - A.PrimStore A.PrimStoreAlloc - | Just vDst@(Var nDst _) <- mdst - , Just [xBytes'] <- mconvAtoms pp kenv tenv xs - -> do let vBump = Var (bumpName nDst "bump") (tAddr pp) - let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp)) - return $ Seq.fromList - $ map annotNil - [ ILoad vDst (XVar vTopPtr) - , IOp vBump OpAdd (XVar vDst) xBytes' - , IStore (XVar vTopPtr) (XVar vBump)] - - A.PrimStore A.PrimStoreRead - | C.XType{} : args <- xs - , Just [xAddr', xOffset'] <- mconvAtoms pp kenv tenv args - , Just vDst@(Var nDst tDst) <- mdst - -> let vOff = Var (bumpName nDst "off") (tAddr pp) - vPtr = Var (bumpName nDst "ptr") (tPtr tDst) - in return $ Seq.fromList - $ map annotNil - [ IOp vOff OpAdd xAddr' xOffset' - , IConv vPtr ConvInttoptr (XVar vOff) - , ILoad vDst (XVar vPtr) ] - - A.PrimStore A.PrimStoreWrite - | C.XType{} : args <- xs - , Just [xAddr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args - -> do 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' ] - - A.PrimStore A.PrimStorePlusAddr - | Just [xAddr', xOffset'] <- mconvAtoms pp kenv tenv xs - , Just vDst <- mdst - -> return $ Seq.singleton $ annotNil - $ IOp vDst OpAdd xAddr' xOffset' - - A.PrimStore A.PrimStoreMinusAddr - | Just [xAddr', xOffset'] <- mconvAtoms pp kenv tenv xs - , Just vDst <- mdst - -> return $ Seq.singleton $ annotNil - $ IOp vDst OpSub xAddr' xOffset' - - A.PrimStore A.PrimStorePeek - | C.XType{} : C.XType _ tDst : args <- xs - , Just [xPtr', xOffset'] <- mconvAtoms pp kenv tenv args - , Just vDst@(Var nDst _) <- mdst - , tDst' <- convertType pp kenv tDst - -> let vAddr1 = Var (bumpName nDst "addr1") (tAddr pp) - vAddr2 = Var (bumpName nDst "addr2") (tAddr pp) - vPtr = Var (bumpName nDst "ptr") (tPtr tDst') - in return $ Seq.fromList - $ (map annotNil - [ IConv vAddr1 ConvPtrtoint xPtr' - , IOp vAddr2 OpAdd (XVar vAddr1) xOffset' - , IConv vPtr ConvInttoptr (XVar vAddr2) ]) - ++ [(annot kenv mdsup xs - ( ILoad vDst (XVar vPtr)))] - - A.PrimStore A.PrimStorePoke - | C.XType{} : C.XType _ tDst : args <- xs - , Just [xPtr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args - , tDst' <- convertType pp kenv tDst - -> do 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 xs - ( IStore (XVar vPtr) xVal' ))] - - A.PrimStore A.PrimStorePlusPtr - | _xRgn : _xType : args <- xs - , Just [xPtr', xOffset'] <- mconvAtoms pp kenv tenv args - , Just vDst <- mdst - -> do 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) ] - - A.PrimStore A.PrimStoreMinusPtr - | _xRgn : _xType : args <- xs - , Just [xPtr', xOffset'] <- mconvAtoms pp kenv tenv args - , Just vDst <- mdst - -> do 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) ] - - A.PrimStore A.PrimStoreMakePtr - | [C.XType{}, C.XType{}, xAddr] <- xs - , Just xAddr' <- mconvAtom pp kenv tenv xAddr - , Just vDst <- mdst - -> return $ Seq.singleton $ annotNil - $ IConv vDst ConvInttoptr xAddr' - - A.PrimStore A.PrimStoreTakePtr - | [C.XType{}, C.XType{}, xPtr] <- xs - , Just xPtr' <- mconvAtom pp kenv tenv xPtr - , Just vDst <- mdst - -> return $ Seq.singleton $ annotNil - $ IConv vDst ConvPtrtoint xPtr' - - A.PrimStore A.PrimStoreCastPtr - | [C.XType{}, C.XType{}, C.XType{}, xPtr] <- xs - , Just xPtr' <- mconvAtom pp kenv tenv xPtr - , Just vDst <- mdst - -> return $ Seq.singleton $ annotNil - $ IConv vDst ConvBitcast xPtr' - - _ -> die $ unlines - [ "Invalid prim call." - , show (p, xs) ] - - -bumpName :: Name -> String -> Name -bumpName nn s - = case nn of - NameLocal str -> NameLocal (str ++ "." ++ s) - NameGlobal str -> NameGlobal (str ++ "." ++ s) - - --- Op ------------------------------------------------------------------------- --- | Convert a binary primop from Core Sea to LLVM form. -convPrimArith2 :: A.PrimArith -> C.Type A.Name -> Maybe Op -convPrimArith2 op t - = case op of - A.PrimArithAdd - | isIntegralT t -> Just OpAdd - | isFloatingT t -> Just OpFAdd - - A.PrimArithSub - | isIntegralT t -> Just OpSub - | isFloatingT t -> Just OpFSub - - A.PrimArithMul - | isIntegralT t -> Just OpMul - | isFloatingT t -> Just OpFMul - - A.PrimArithDiv - | isIntegralT t, isUnsignedT t -> Just OpUDiv - | isIntegralT t, isSignedT t -> Just OpSDiv - | isFloatingT t -> Just OpFDiv - - A.PrimArithRem - | isIntegralT t, isUnsignedT t -> Just OpURem - | isIntegralT t, isSignedT t -> Just OpSRem - | isFloatingT t -> Just OpFRem - - A.PrimArithShl - | isIntegralT t -> Just OpShl - - A.PrimArithShr - | isIntegralT t, isUnsignedT t -> Just OpLShr - | isIntegralT t, isSignedT t -> Just OpAShr - - A.PrimArithBAnd - | isIntegralT t -> Just OpAnd - - A.PrimArithBOr - | isIntegralT t -> Just OpOr - - A.PrimArithBXOr - | isIntegralT t -> Just OpXor - - _ -> Nothing - - --- Cast ----------------------------------------------------------------------- --- | Convert a primitive promotion to LLVM, --- or `Nothing` for an invalid promotion. -convPrimPromote - :: Platform - -> KindEnv A.Name - -> C.Type A.Name -> Var - -> C.Type A.Name -> Exp - -> Maybe Instr - -convPrimPromote pp kenv tDst vDst tSrc xSrc - | tSrc' <- convertType pp kenv tSrc - , tDst' <- convertType pp kenv tDst - , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc - , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst - , A.primCastPromoteIsValid pp tcSrc tcDst - = case (tDst', tSrc') of - (TInt bitsDst, TInt bitsSrc) - - -- Same sized integers - | bitsDst == bitsSrc - -> Just $ ISet vDst xSrc - - -- Both Unsigned - | isUnsignedT tSrc - , isUnsignedT tDst - , bitsDst > bitsSrc - -> Just $ IConv vDst ConvZext xSrc - - -- Both Signed - | isSignedT tSrc - , isSignedT tDst - , bitsDst > bitsSrc - -> Just $ IConv vDst ConvSext xSrc - - -- Unsigned to Signed - | isUnsignedT tSrc - , isSignedT tDst - , bitsDst > bitsSrc - -> Just $ IConv vDst ConvZext xSrc - - _ -> Nothing - - | otherwise - = Nothing - - --- | Convert a primitive truncation to LLVM, --- or `Nothing` for an invalid truncation. -convPrimTruncate - :: Platform - -> KindEnv A.Name - -> C.Type A.Name -> Var - -> C.Type A.Name -> Exp - -> Maybe Instr - -convPrimTruncate pp kenv tDst vDst tSrc xSrc - | tSrc' <- convertType pp kenv tSrc - , tDst' <- convertType pp kenv tDst - , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc - , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst - , A.primCastTruncateIsValid pp tcSrc tcDst - = case (tDst', tSrc') of - (TInt bitsDst, TInt bitsSrc) - -- Same sized integers - | bitsDst == bitsSrc - -> Just $ ISet vDst xSrc - - -- Destination is smaller - | bitsDst < bitsSrc - -> Just $ IConv vDst ConvTrunc xSrc - - -- Unsigned to Signed, - -- destination is larger - | bitsDst > bitsSrc - , isUnsignedT tSrc - , isSignedT tDst - -> Just $ IConv vDst ConvZext xSrc - - _ -> Nothing - - | otherwise - = Nothing - - --- Cond ----------------------------------------------------------------------- --- | Convert an integer comparison from Core Sea to LLVM form. -convPrimICond :: A.PrimArith -> C.Type A.Name -> Maybe ICond -convPrimICond op t - | isIntegralT t - = case op of - A.PrimArithEq -> Just ICondEq - A.PrimArithNeq -> Just ICondNe - A.PrimArithGt -> Just ICondUgt - A.PrimArithGe -> Just ICondUge - A.PrimArithLt -> Just ICondUlt - A.PrimArithLe -> Just ICondUle - _ -> Nothing - - | otherwise = Nothing - - --- | Convert a floating point comparison from Core Sea to LLVM form. -convPrimFCond :: A.PrimArith -> C.Type A.Name -> Maybe FCond -convPrimFCond op t - | isIntegralT t - = case op of - A.PrimArithEq -> Just FCondOeq - A.PrimArithNeq -> Just FCondOne - A.PrimArithGt -> Just FCondOgt - A.PrimArithGe -> Just FCondOge - A.PrimArithLt -> Just FCondOlt - A.PrimArithLe -> Just FCondOle - _ -> Nothing - - | otherwise = Nothing - diff --git a/DDC/Core/Llvm/Convert/Super.hs b/DDC/Core/Llvm/Convert/Super.hs --- a/DDC/Core/Llvm/Convert/Super.hs +++ b/DDC/Core/Llvm/Convert/Super.hs @@ -1,23 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} module DDC.Core.Llvm.Convert.Super - (convSuperM) + (convertSuper) where import DDC.Core.Llvm.Convert.Exp import DDC.Core.Llvm.Convert.Type -import DDC.Core.Llvm.Convert.Erase -import DDC.Core.Llvm.LlvmM +import DDC.Core.Llvm.Convert.Context +import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax import DDC.Core.Salt.Platform -import DDC.Core.Compounds +import DDC.Type.Predicates import DDC.Base.Pretty hiding (align) -import DDC.Type.Env (KindEnv, TypeEnv) -import Control.Monad.State.Strict (gets) import qualified DDC.Core.Llvm.Metadata.Tbaa as Tbaa import qualified DDC.Core.Salt as A import qualified DDC.Core.Salt.Convert as A +import qualified DDC.Core.Exp.Generic.Compounds 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 Data.Set as Set import qualified Data.Sequence as Seq import qualified Data.Foldable as Seq @@ -25,20 +24,21 @@ -- | Convert a top-level supercombinator to a LLVM function. -- Region variables are completely stripped out. -convSuperM - :: KindEnv A.Name - -> TypeEnv A.Name - -> C.Bind A.Name -- ^ Bind of the top-level super. - -> C.Exp () A.Name -- ^ Super body. - -> LlvmM (Function, [MDecl]) +convertSuper + :: Context + -> A.Bind -- ^ Bind of the top-level super. + -> A.Exp -- ^ Super body. + -> ConvertM (Function, [MDecl]) -convSuperM kenv tenv bSuper@(C.BName nSuper tSuper) x - | Just (bfsParam, xBody) <- takeXLamFlags x +convertSuper ctx (C.BName nSuper tSuper) x + | Just (asParam, xBody) <- A.takeXAbs x = do - platform <- gets llvmStatePlatform - mm <- gets llvmStateModule + let pp = contextPlatform ctx + let mm = contextModule ctx + let kenv = contextKindEnv ctx - let nsExports = Set.fromList $ map fst $ C.moduleExportValues mm + -- Collect names of exported values. + let nsExports = Set.fromList $ map fst $ C.moduleExportValues mm -- Sanitise the super name so we can use it as a symbol -- in the object code. @@ -47,21 +47,24 @@ (lookup nSuper (C.moduleExportValues mm)) nSuper - -- Add parameters to environments. - let bfsParam' = eraseWitBinds bfsParam - let bsParamType = [b | (True, b) <- bfsParam'] - let bsParamValue = [b | (False, b) <- bfsParam'] + -- Add super parameters to the context. + (ctx', vsParamValue') + <- bindLocalAs ctx $ eraseWitBinds $ asParam - let kenv' = Env.extends bsParamType kenv - let tenv' = Env.extends (bSuper : bsParamValue) tenv - mdsup <- Tbaa.deriveMD (renderPlain nSuper') x + -- Add super meta-data to the context. + mdsup <- Tbaa.deriveMD (renderPlain nSuper') x + let ctx'' = ctx' { contextMDSuper = mdsup } + -- Convert function body to basic blocks. + label <- newUniqueLabel "entry" + blocks <- convertBody ctx'' ExpTop Seq.empty label Seq.empty xBody + -- Split off the argument and result types of the super. - let (tsParam, tResult) - = convertSuperType platform kenv tSuper + (tsParam, tResult) + <- convertSuperType pp kenv tSuper -- Make parameter binders. - let align = AlignBytes (platformAlignBytes platform) + let align = AlignBytes (platformAlignBytes pp) -- Declaration of the super. let decl @@ -86,41 +89,42 @@ then CC_Ccc else CC_Fastcc - , declReturnType = tResult - , declParamListType = FixedArgs - , declParams = [Param t [] | t <- tsParam] - , declAlign = align } + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = [Param t [] | t <- tsParam] + , declAlign = align } - -- Convert function body to basic blocks. - label <- newUniqueLabel "entry" - blocks <- convBodyM BodyTop kenv' tenv' mdsup Seq.empty label Seq.empty xBody + let Just ssParamValues + = sequence + $ map (\v -> case v of + (Var (NameLocal s) _) -> Just s + _ -> Nothing) + $ vsParamValue' + -- Build the function. - return $ ( Function - { funDecl = decl - , funParams = [nameOfParam i b - | i <- [0..] - | b <- bsParamValue] - , funAttrs = [] - , funSection = SectionAuto - , funBlocks = Seq.toList blocks } - , Tbaa.decls mdsup ) - + return ( Function + { funDecl = decl + , funParams = ssParamValues + , funAttrs = [] + , funSection = SectionAuto + , funBlocks = Seq.toList blocks } + , Tbaa.decls mdsup ) -convSuperM _ _ _ _ - = die "Invalid super" +convertSuper _ b x + = throw $ ErrorInvalidSuper b x --- | Take the string name to use for a function parameter. -nameOfParam :: Int -> C.Bind A.Name -> String -nameOfParam i bb - = case bb of - C.BName (A.NameVar n) _ - -> A.sanitizeName n - - C.BNone _ - -> "_arg" ++ show i - - _ -> die $ "Invalid parameter name: " ++ show bb +--------------------------------------------------------------------------------------------------- +-- | Erase witness bindings +eraseWitBinds :: [A.GAbs A.Name] -> [A.GAbs A.Name] +eraseWitBinds + = let + isBindWit (A.ALAM _) = False + isBindWit (A.ALam b) + = case b of + C.BName _ t | isWitnessType t -> True + _ -> False + in filter (not . isBindWit) diff --git a/DDC/Core/Llvm/Convert/Type.hs b/DDC/Core/Llvm/Convert/Type.hs --- a/DDC/Core/Llvm/Convert/Type.hs +++ b/DDC/Core/Llvm/Convert/Type.hs @@ -20,18 +20,17 @@ , isIntegralT , isFloatingT) where +import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax.Type import DDC.Llvm.Syntax.Attr -import DDC.Core.Llvm.LlvmM import DDC.Core.Salt.Platform -import DDC.Core.Llvm.Convert.Erase import DDC.Type.Env import DDC.Type.Compounds import DDC.Type.Predicates import DDC.Base.Pretty -import DDC.Core.Salt as A -import DDC.Core.Salt.Name as A -import DDC.Core.Salt.Convert as A +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Salt.Convert as A import qualified DDC.Core.Module as C import qualified DDC.Core.Exp as C import qualified DDC.Type.Env as Env @@ -40,7 +39,7 @@ -- Type ----------------------------------------------------------------------- -- | Convert a Salt type to an LlvmType. -convertType :: Platform -> KindEnv Name -> C.Type Name -> Type +convertType :: Platform -> KindEnv A.Name -> C.Type A.Name -> ConvertM Type convertType pp kenv tt = case tt of -- A polymorphic type, @@ -48,42 +47,50 @@ C.TVar u -> case Env.lookup u kenv of Nothing - -> die $ "Type variable not in kind environment." ++ show u + -> throw $ ErrorInvalidBound u + $ Just "Type variable not in kind environment." Just k - | isDataKind k -> TPointer (tObj pp) - | otherwise -> die "Invalid type variable." + | isDataKind k + -> return $ TPointer (tObj pp) + | otherwise + -> throw $ ErrorInvalidBound u + $ Just "Bound type variable does not have kind Data." + -- A primitive type. C.TCon tc -> convTyCon pp tc -- A pointer to a primitive type. C.TApp{} - | Just (NamePrimTyCon PrimTyConPtr, [_r, t2]) + | Just (A.NamePrimTyCon A.PrimTyConPtr, [_r, t2]) <- takePrimTyConApps tt - -> TPointer (convertType pp kenv t2) + -> do t2' <- convertType pp kenv t2 + return $ TPointer t2' -- Function types become pointers to functions. C.TApp{} - | (tsArgs, tResult) <- convertSuperType pp kenv tt - -> TPointer $ TFunction - $ FunctionDecl - { declName = "dummy.function.name" - , declLinkage = Internal - , declCallConv = CC_Ccc - , declReturnType = tResult - , declParamListType = FixedArgs - , declParams = [Param t [] | t <- tsArgs] - , declAlign = AlignBytes (platformAlignBytes pp) } + -> do (tsArgs, tResult) <- convertSuperType pp kenv tt + return + $ TPointer $ TFunction + $ FunctionDecl + { declName = "dummy.function.name" + , declLinkage = Internal + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = [Param t [] | t <- tsArgs] + , declAlign = AlignBytes (platformAlignBytes pp) } C.TForall b t -> let kenv' = Env.extend b kenv in convertType pp kenv' t - _ -> die ("Invalid Type " ++ show tt) - + _ -> throw $ ErrorInvalidType tt + $ Just "Cannot convert type." + -- Super Type ----------------------------------------------------------------- -- | Split the parameter and result types from a supercombinator type and -- and convert them to LLVM form. @@ -92,66 +99,70 @@ -- to decend into any quantifiers that wrap the body type. convertSuperType :: Platform - -> KindEnv Name - -> C.Type Name - -> ([Type], Type) + -> KindEnv A.Name + -> C.Type A.Name + -> ConvertM ([Type], Type) convertSuperType pp kenv tt - = let tt' = eraseWitTApps tt - in case tt' of - C.TApp{} - | (tsArgs, tResult) <- takeTFunArgResult tt' - , not $ null tsArgs - -> let tsArgs' = map (convertType pp kenv) tsArgs - tResult' = convertType pp kenv tResult - in (tsArgs', tResult') + = case tt of + C.TApp{} + | (_, tsArgs, tResult) <- takeTFunWitArgResult tt + , not $ null tsArgs + -> do tsArgs' <- mapM (convertType pp kenv) tsArgs + tResult' <- convertType pp kenv tResult + return (tsArgs', tResult') - C.TForall b t - -> let kenv' = Env.extend b kenv - in convertSuperType pp kenv' t + C.TForall b t + -> let kenv' = Env.extend b kenv + in convertSuperType pp kenv' t - _ -> die ("Invalid super type" ++ show tt') + _ -> throw $ ErrorInvalidType tt + $ Just $ "Cannot use this as the type of a super." + ++ show (takeTFunArgResult tt) -- Imports -------------------------------------------------------------------- -- | Convert an imported function type to a LLVM declaration. importedFunctionDeclOfType :: Platform - -> KindEnv Name - -> C.ImportSource Name - -> Maybe (C.ExportSource Name) - -> Name - -> C.Type Name - -> Maybe FunctionDecl + -> KindEnv A.Name + -> C.ImportValue A.Name + -> Maybe (C.ExportSource A.Name) + -> A.Name + -> C.Type A.Name + -> Maybe (ConvertM FunctionDecl) importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt - | C.ImportSourceModule{} <- isrc - = let Just strName = liftM renderPlain - $ seaNameOfSuper (Just isrc) mesrc nSuper + | C.ImportValueModule{} <- isrc + = Just $ do + let Just strName + = liftM renderPlain + $ A.seaNameOfSuper (Just isrc) mesrc nSuper - (tsArgs, tResult) = convertSuperType pp kenv tt - mkParam t = Param t [] - in Just $ FunctionDecl - { declName = A.sanitizeName strName - , declLinkage = External - , declCallConv = CC_Ccc - , declReturnType = tResult - , declParamListType = FixedArgs - , declParams = map mkParam tsArgs - , declAlign = AlignBytes (platformAlignBytes pp) } + (tsArgs, tResult) <- convertSuperType pp kenv tt + let mkParam t = Param t [] + return $ FunctionDecl + { declName = A.sanitizeName strName + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = map mkParam tsArgs + , declAlign = AlignBytes (platformAlignBytes pp) } - | C.ImportSourceSea strName _ <- isrc - = let (tsArgs, tResult) = convertSuperType pp kenv tt - mkParam t = Param t [] - in Just $ FunctionDecl - { declName = A.sanitizeName strName - , declLinkage = External - , declCallConv = CC_Ccc - , declReturnType = tResult - , declParamListType = FixedArgs - , declParams = map mkParam tsArgs - , declAlign = AlignBytes (platformAlignBytes pp) } + | C.ImportValueSea strName _ <- isrc + = Just $ do + (tsArgs, tResult) <- convertSuperType pp kenv tt + let mkParam t = Param t [] + return $ FunctionDecl + { declName = A.sanitizeName strName + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = map mkParam tsArgs + , declAlign = AlignBytes (platformAlignBytes pp) } importedFunctionDeclOfType _ _ _ _ _ _ = Nothing @@ -159,37 +170,43 @@ -- TyCon ---------------------------------------------------------------------- -- | Convert a Sea TyCon to a LlvmType. -convTyCon :: Platform -> C.TyCon Name -> Type +convTyCon :: Platform -> C.TyCon A.Name -> ConvertM Type convTyCon platform tycon = case tycon of C.TyConSpec C.TcConUnit - -> tObj platform + -> return $ TPointer (tObj platform) - C.TyConBound (C.UPrim NameObjTyCon _) _ - -> tObj platform + C.TyConBound (C.UPrim A.NameObjTyCon _) _ + -> return $ tObj platform - C.TyConBound (C.UPrim (NamePrimTyCon tc) _) _ + C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _ -> case tc of - PrimTyConVoid -> TVoid - PrimTyConBool -> TInt 1 - PrimTyConNat -> TInt (8 * platformAddrBytes platform) - PrimTyConInt -> TInt (8 * platformAddrBytes platform) - PrimTyConWord bits -> TInt (fromIntegral bits) - PrimTyConTag -> TInt (8 * platformTagBytes platform) - PrimTyConAddr -> TInt (8 * platformAddrBytes platform) - PrimTyConString -> TPointer (TInt 8) + A.PrimTyConVoid -> return $ TVoid + A.PrimTyConBool -> return $ TInt 1 + A.PrimTyConNat -> return $ TInt (8 * platformAddrBytes platform) + A.PrimTyConInt -> return $ TInt (8 * platformAddrBytes platform) + A.PrimTyConWord bits -> return $ TInt (fromIntegral bits) + A.PrimTyConTag -> return $ TInt (8 * platformTagBytes platform) + A.PrimTyConAddr -> return $ TInt (8 * platformAddrBytes platform) - PrimTyConFloat bits - -> case bits of - 32 -> TFloat - 64 -> TDouble - 80 -> TFloat80 - 128 -> TFloat128 - _ -> die "Invalid width for float type constructor." + A.PrimTyConFloat bits + -> case bits of + 32 -> return TFloat + 64 -> return TDouble + 80 -> return TFloat80 + 128 -> return TFloat128 - _ -> die "Invalid primitive type constructor." + _ -> throw $ ErrorInvalidTyCon tycon + $ Just "Float has a non-standard width." - _ -> die $ "Invalid type constructor '" ++ show tycon ++ "'" + -- Text literals are represented as pointers to the static text data. + A.PrimTyConTextLit -> return $ tPtr (TInt 8) + + _ -> throw $ ErrorInvalidTyCon tycon + $ Just "Not a primitive type constructor." + + _ -> throw $ ErrorInvalidTyCon tycon + $ Just "Cannot convert type constructor." -- | Type of Heap objects. diff --git a/DDC/Core/Llvm/LlvmM.hs b/DDC/Core/Llvm/LlvmM.hs deleted file mode 100644 --- a/DDC/Core/Llvm/LlvmM.hs +++ /dev/null @@ -1,121 +0,0 @@ - -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 - diff --git a/DDC/Core/Llvm/Metadata/Graph.hs b/DDC/Core/Llvm/Metadata/Graph.hs --- a/DDC/Core/Llvm/Metadata/Graph.hs +++ b/DDC/Core/Llvm/Metadata/Graph.hs @@ -89,7 +89,8 @@ nonSingleton _ = True --- | Use lexicographic breadth-first search on an undirected graph to produce an ordering of the vertices +-- | Use lexicographic breadth-first search on an undirected graph to produce an ordering +-- of the vertices -- lexBFS :: (Show a, Ord a) => UG a -> Class a lexBFS (UG (vertices, f)) = refine [] [vertices] @@ -112,14 +113,14 @@ -- | Transitively orient an undireted graph -- --- Using the algorithm from --- "Lex-BFS and partition refinement, with applications to transitive orientation, interval --- graph recognition and consecutive ones testing", R. McConnell et al 2000 +-- Using the algorithm from +-- "Lex-BFS and partition refinement, with applications to transitive orientation, interval +-- graph recognition and consecutive ones testing", R. McConnell et al 2000 -- --- In the case where the transitive orientation does not exist, it simply gives some orientation +-- In the case where the transitive orientation does not exist, it simply gives some orientation -- --- note: gave up on modular decomposition, this approach has very slightly worse time --- complexity but much simpler +-- note: gave up on modular decomposition, this approach has very slightly worse time +-- complexity but much simpler -- transOrient :: (Show a, Ord a) => UG a -> DG a transOrient g@(UG (vertices, f)) @@ -145,8 +146,10 @@ , all (not . null) [neighbours, nonneighbours] = let lastused = snd cl in if isBefore - then (nonneighbours, lastused) : (neighbours, lastused) : (split isBefore classes vertex) - else (neighbours, lastused) : (nonneighbours, lastused) : (split isBefore classes vertex) + then (nonneighbours, lastused) : (neighbours, lastused) + : (split isBefore classes vertex) + else (neighbours, lastused) : (nonneighbours, lastused) + : (split isBefore classes vertex) | otherwise = cl:classes -- Split the largest class by the last vertex in the class found by lexBFS diff --git a/DDC/Core/Llvm/Metadata/Tbaa.hs b/DDC/Core/Llvm/Metadata/Tbaa.hs --- a/DDC/Core/Llvm/Metadata/Tbaa.hs +++ b/DDC/Core/Llvm/Metadata/Tbaa.hs @@ -11,9 +11,8 @@ import DDC.Type.Predicates import DDC.Type.Collect import DDC.Type.Env (KindEnv) -import DDC.Core.Exp import DDC.Core.Llvm.Metadata.Graph -import DDC.Core.Llvm.LlvmM +import DDC.Core.Llvm.Convert.Base import DDC.Base.Pretty hiding (empty) import qualified DDC.Type.Env as Env import qualified DDC.Core.Salt as A @@ -72,10 +71,10 @@ -- | Generate tbaa metadata for a top-level Salt supercombinator. deriveMD - :: (BindStruct (Exp ())) - => String -- ^ Sanitized name of super - -> Exp () A.Name -- ^ Super to derive from - -> LlvmM (MDSuper) -- ^ Metadata encoding witness information + :: (BindStruct A.Exp A.Name) + => String -- ^ Sanitized name of super + -> A.Exp -- ^ Super to derive from + -> ConvertM MDSuper -- ^ Metadata encoding witness information deriveMD nTop xx = let @@ -88,13 +87,13 @@ in foldM (buildMDTree nTop) (MDSuper emptyDict []) mdTrees -buildMDTree :: String -> MDSuper -> Tree ANode -> LlvmM MDSuper +buildMDTree :: String -> MDSuper -> Tree ANode -> ConvertM MDSuper buildMDTree nTop sup tree = let tree' = anchor ARoot tree in bfBuild nTop tree' Nothing sup ARoot -bfBuild :: String -> Tree ANode -> Maybe MRef -> MDSuper -> ANode -> LlvmM MDSuper +bfBuild :: String -> Tree ANode -> Maybe MRef -> MDSuper -> ANode -> ConvertM MDSuper bfBuild nTop tree parent sup node = case parent of Nothing -> do name <- freshRootName nTop @@ -114,16 +113,19 @@ , decls = decl:(decls s) } -freshNodeName :: String -> Bound A.Name -> LlvmM String -freshNodeName q (UName (A.NameVar n)) = return $ q ++ "_" ++ n -freshNodeName q _ = liftA (\i -> q ++ "_" ++ (show i)) newUnique +freshNodeName :: String -> Bound A.Name -> ConvertM String +freshNodeName q (UName nm) + | Just n <- A.takeNameVar nm + = return $ q ++ "_" ++ n +freshNodeName q _ + = liftA (\i -> q ++ "_" ++ (show i)) newUnique -freshRootName :: String -> LlvmM String +freshRootName :: String -> ConvertM String freshRootName qualify = liftA (\i -> qualify ++ "_ROOT_" ++ (show i)) newUnique -- | Attach relevant metadata to instructions -annot :: (BindStruct c, Show (c A.Name)) +annot :: (BindStruct (c A.Name) A.Name, Show (c A.Name)) => KindEnv A.Name -> MDSuper -- ^ Metadata -> [c A.Name] -- ^ Things to lookup for Meta data. @@ -209,7 +211,7 @@ -- | Collect region bounds -collectRegsU :: (BindStruct c) => KindEnv A.Name -> c A.Name -> [RegBound] +collectRegsU :: (BindStruct (c A.Name) A.Name) => KindEnv A.Name -> c A.Name -> [RegBound] collectRegsU kenv cc = let isReg u = case Env.lookup u kenv of Just t | isRegionKind t -> True @@ -218,7 +220,7 @@ -- | Collect region bindings -collectRegsB :: (BindStruct c) => c A.Name -> [RegBound] +collectRegsB :: (BindStruct (c A.Name) A.Name) => c A.Name -> [RegBound] collectRegsB cc = let isBindReg b = case b of @@ -229,7 +231,7 @@ -- | Collect witness bindings together with their types (for convinience) -collectWitsB :: (BindStruct c) => c A.Name -> [WitType] +collectWitsB :: (BindStruct (c A.Name) A.Name) => c A.Name -> [WitType] collectWitsB cc = let isBindWit b = let t = typeOfBind b diff --git a/DDC/Core/Llvm/Runtime.hs b/DDC/Core/Llvm/Runtime.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Runtime.hs @@ -0,0 +1,34 @@ + +module DDC.Core.Llvm.Runtime + ( nameGlobalHeapTop, varGlobalHeapTop + , nameGlobalHeapMax, varGlobalHeapMax + , nameGlobalMalloc) +where +import DDC.Llvm.Syntax +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Salt.Platform + + +-- | Name of the global variable that points to the next byte that can +-- be allocated. +nameGlobalHeapTop :: Name +nameGlobalHeapTop = NameGlobal "_DDC__heapTop" + +-- | Make the variable that points to the next byte that can be allocated. +varGlobalHeapTop :: Platform -> Var +varGlobalHeapTop pp = Var nameGlobalHeapTop (TPointer (tAddr pp)) + + +-- | Name of the global variable that points to the highest +-- byte that can be allocated. +nameGlobalHeapMax :: Name +nameGlobalHeapMax = NameGlobal "_DDC__heapMax" + +-- | Make the variable that points to the highest byte that can be allocated. +varGlobalHeapMax :: Platform -> Var +varGlobalHeapMax pp = Var nameGlobalHeapMax (TPointer (tAddr pp)) + + +-- | Name of the malloc function that is used to allocate the heap. +nameGlobalMalloc :: Name +nameGlobalMalloc = NameGlobal "malloc" diff --git a/DDC/Llvm/Analysis/Defs.hs b/DDC/Llvm/Analysis/Defs.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Analysis/Defs.hs @@ -0,0 +1,97 @@ + +module DDC.Llvm.Analysis.Defs + ( Def (..) + , takeDefOfInstr + , defsOfBlock) +where +import DDC.Llvm.Syntax +import Data.Map (Map) +import qualified Data.Foldable as Seq +import qualified Data.Map as Map + + +-- | How a variable is defined. +data Def + -- | Variable is given a non-constant value. + = DefVar + + -- | Variable is an alias of another variable. + | DefAlias Var + + -- | Variable binds some closed, constant expression. + | DefClosedConstant Exp + deriving Show + + +-- | Collect information about how all the local variables in this block +-- are defined. +defsOfBlock :: Block -> Map Var (Label, Def) +defsOfBlock block + = Map.fromList + $ [ (v, (blockLabel block, def)) + | Just (v, def) <- map (takeDefOfInstr . annotInstr) + $ Seq.toList $ blockInstrs block ] + + +-- | If this instruction defines a variable, +-- then collect some information about it. +takeDefOfInstr :: Instr -> Maybe (Var, Def) +takeDefOfInstr instr + = case instr of + -- Comments + IComment{} + -> Nothing + + -- Set meta instruction. + ISet v1 x2 + | XVar v2 <- x2 + -> Just (v1, DefAlias v2) + + | isClosedConstantExp x2 + -> Just (v1, DefClosedConstant x2) + + | otherwise + -> Just (v1, DefVar) + + -- No operation. + INop -> Nothing + + -- Phi nodes + -- Even if both branches are constant, + -- we can't form an expression to represent this, + -- so the result gets marked as non-constant. + IPhi v _ -> Just (v, DefVar) + + -- Terminator Instructions + IReturn{} -> Nothing + IBranch{} -> Nothing + IBranchIf{} -> Nothing + ISwitch{} -> Nothing + IUnreachable{} -> Nothing + + -- Binary Operators + IOp v _ _ _ -> Just (v, DefVar) + + -- Conversion Operators + IConv v _ _ -> Just (v, DefVar) + + -- Get element pointer + IGet v _ _ -> Just (v, DefVar) + + -- Load a value from memory. + ILoad v _ -> Just (v, DefVar) + + -- Store a value to memory. + IStore{} -> Nothing + + -- Comparisons + ICmp v _ _ _ -> Just (v, DefVar) + + -- Function calls + ICall mv _ _ _ _ _ _ + -> case mv of + Just v -> Just (v, DefVar) + _ -> Nothing + + + diff --git a/DDC/Llvm/Pretty/Exp.hs b/DDC/Llvm/Pretty/Exp.hs --- a/DDC/Llvm/Pretty/Exp.hs +++ b/DDC/Llvm/Pretty/Exp.hs @@ -4,49 +4,62 @@ , pprPlainL) where import DDC.Llvm.Syntax.Exp -import DDC.Llvm.Pretty.Type () +import DDC.Llvm.Pretty.Type () import DDC.Base.Pretty +import Data.Text (Text) +import qualified Data.Text as T --- Exp ------------------------------------------------------------------------ instance Pretty Exp where ppr xx = case xx of - XVar v -> ppr v - XLit l -> ppr l - XUndef _ -> text "undef" + XVar v -> ppr v + XLit l -> ppr l + XUndef _ -> text "undef" + XConv _ c x -> parens $ ppr c <> ppr x + XGet _ x is + -> parens $ text "getelementptr" + <+> hcat (punctuate (text ", ") (ppr x : map (text . show) is)) + -- | Pretty print an expression without its type. pprPlainX :: Exp -> Doc pprPlainX xx = case xx of - XVar v -> ppr $ nameOfVar v - XLit l -> pprPlainL l - XUndef _ -> text "undef" + XVar v -> ppr $ nameOfVar v + XLit l -> pprPlainL l + XUndef _ -> text "undef" + XConv _ c x -> parens $ ppr c <> ppr x + XGet _ x is + -> parens $ text "getelementptr" + <+> hcat (punctuate (text ", ") (ppr x : map (text . show) is)) --- Var ------------------------------------------------------------------------ + instance Pretty Var where ppr (Var n t) = ppr t <+> ppr n --- Name ----------------------------------------------------------------------- instance Pretty Name where ppr (NameGlobal str) = text "@" <> text str ppr (NameLocal str) = text "%" <> text str --- Lit ------------------------------------------------------------------------ instance Pretty Lit where ppr ll = case ll of LitInt t i -> ppr t <+> integer i LitFloat{} -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet" - LitNull _ -> text "null" + LitNull t -> ppr t <+> text "null" LitUndef _ -> text "undef" + LitString _ txEnc _ + -> ppr (typeOfLit ll) + <+> text "c" <> pprString txEnc + + -- | Pretty print a literal without its type. pprPlainL :: Lit -> Doc pprPlainL ll @@ -55,4 +68,15 @@ LitFloat{} -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet" LitNull _ -> text "null" LitUndef _ -> text "undef" + + LitString _ txEnc _ + -> text "c" <> pprString txEnc + + +pprString :: Text -> Doc +pprString tx + = text "\"" <> text (T.unpack tx) <> text "\"" + + + diff --git a/DDC/Llvm/Pretty/Function.hs b/DDC/Llvm/Pretty/Function.hs --- a/DDC/Llvm/Pretty/Function.hs +++ b/DDC/Llvm/Pretty/Function.hs @@ -7,6 +7,7 @@ import DDC.Llvm.Pretty.Attr () import DDC.Llvm.Pretty.Instr () import DDC.Base.Pretty +import Prelude hiding ((<$>)) instance Pretty Function where diff --git a/DDC/Llvm/Pretty/Instr.hs b/DDC/Llvm/Pretty/Instr.hs --- a/DDC/Llvm/Pretty/Instr.hs +++ b/DDC/Llvm/Pretty/Instr.hs @@ -1,9 +1,10 @@ module DDC.Llvm.Pretty.Instr where -import DDC.Llvm.Syntax.Instr +import DDC.Llvm.Syntax.Attr import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Instr import DDC.Llvm.Syntax.Metadata -import DDC.Llvm.Syntax.Attr +import DDC.Llvm.Syntax.Prim import DDC.Llvm.Pretty.Exp import DDC.Llvm.Pretty.Prim () import DDC.Llvm.Pretty.Metadata () @@ -77,9 +78,9 @@ IBranchIf cond labelTrue labelFalse -> hsep [ text "br" - , ppr cond, comma - , ppr labelTrue, comma - , ppr labelFalse ] + , ppr cond, comma + , text "label %" <> ppr labelTrue, comma + , text "label %" <> ppr labelFalse ] ISwitch x1 lDefault alts -> text "switch" @@ -124,15 +125,22 @@ <+> text "to" <+> ppr (typeOfVar vDst) + IGet vDst xSrc os + -> padVar vDst + <+> equals + <+> text "getelementptr" + <+> (hcat $ punctuate (text ", ") $ (ppr xSrc : map ppr os)) + + -- Other operations ------------------------------- - IICmp vDst icond x1 x2 + ICmp vDst (ICond icond) x1 x2 -> padVar vDst <+> equals <+> text "icmp" <+> ppr icond <+> ppr (typeOfExp x1) <+> pprPlainX x1 <> comma <+> pprPlainX x2 - IFCmp vDst fcond x1 x2 + ICmp vDst (FCond fcond) x1 x2 -> padVar vDst <+> equals <+> text "fcmp" <+> ppr fcond <+> ppr (typeOfExp x1) diff --git a/DDC/Llvm/Pretty/Prim.hs b/DDC/Llvm/Pretty/Prim.hs --- a/DDC/Llvm/Pretty/Prim.hs +++ b/DDC/Llvm/Pretty/Prim.hs @@ -78,8 +78,3 @@ ConvInttoptr -> text "inttoptr" ConvBitcast -> text "bitcast" - - - - - diff --git a/DDC/Llvm/Pretty/Type.hs b/DDC/Llvm/Pretty/Type.hs --- a/DDC/Llvm/Pretty/Type.hs +++ b/DDC/Llvm/Pretty/Type.hs @@ -66,7 +66,7 @@ -- by default we don't print param attributes args = hcat $ punctuate comma $ map ppr params - in ppr r <> brackets (args <> varg') + in ppr r <> parens (args <> varg') diff --git a/DDC/Llvm/Syntax.hs b/DDC/Llvm/Syntax.hs --- a/DDC/Llvm/Syntax.hs +++ b/DDC/Llvm/Syntax.hs @@ -58,6 +58,8 @@ -- * Expressions , Exp (..) , typeOfExp + , isXVar, isXLit, isXUndef + , isClosedConstantExp -- * Variables , Var (..) @@ -70,9 +72,11 @@ -- * Literals , Lit (..) , typeOfLit + , makeLitString -- * Primitive operators , Op (..) + , Cond (..) , ICond (..) , FCond (..) , Conv (..) diff --git a/DDC/Llvm/Syntax/Exp.hs b/DDC/Llvm/Syntax/Exp.hs --- a/DDC/Llvm/Syntax/Exp.hs +++ b/DDC/Llvm/Syntax/Exp.hs @@ -3,6 +3,8 @@ ( -- * Expressions Exp (..) , typeOfExp + , isXVar, isXLit, isXUndef + , isClosedConstantExp -- * Variables , Var (..) @@ -14,12 +16,28 @@ -- * Literals , Lit (..) - , typeOfLit) + , typeOfLit + , makeLitString) where import DDC.Llvm.Syntax.Type +import DDC.Llvm.Syntax.Prim +import DDC.Llvm.Pretty.Prim () +import Data.Text (Text) +import Data.Char +import Numeric +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as BS -- Exp ------------------------------------------------------------------------ +-- | Expressions can be used directly as arguments to instructions. +-- +-- The expressions marked (synthetic) are safe conversions that do not +-- branch or access memory. In the real LLVM syntax we cannot represent +-- them as expressions, but they are flattened out to instructions by the +-- Clean transform. +-- data Exp -- | Use of a variable. = XVar Var @@ -29,6 +47,12 @@ -- | An undefined value. | XUndef Type + + -- | (synthetic) Cast an expression to the given type. + | XConv Type Conv Exp + + -- | (synthetic) Get a pointer to an element of the expression. + | XGet Type Exp [Exp] deriving (Eq, Show) @@ -40,7 +64,46 @@ XLit lit -> typeOfLit lit XUndef t -> t + XConv t _ _ -> t + XGet t _ _ -> t + +-- | Check if this expression is an `XVar`. +isXVar :: Exp -> Bool +isXVar xx + = case xx of + XVar{} -> True + _ -> False + + +-- | Check if this expression is an `XLit`. +isXLit :: Exp -> Bool +isXLit xx + = case xx of + XLit{} -> True + _ -> False + + +-- | Check if this expression is an `XUndef`. +isXUndef :: Exp -> Bool +isXUndef xx + = case xx of + XUndef{} -> True + _ -> False + + +-- | Check whether this expression is closed, +-- meaning it doesn't contain any variables that refer to the context. +isClosedConstantExp :: Exp -> Bool +isClosedConstantExp xx + = case xx of + XVar{} -> False + XLit{} -> True + XUndef{} -> True + XConv _ _ x -> isClosedConstantExp x + XGet _ x1 xs -> isClosedConstantExp x1 && all isClosedConstantExp xs + + -- Var ------------------------------------------------------------------------ -- | A variable that can be assigned to. data Var @@ -80,6 +143,16 @@ -- | A floating-point literal. | LitFloat Type Double + -- | A string literal. + -- In LLVM these have the same type as array literals, but have a + -- special syntax. The first component is the literal source text, + -- while the second its the pretty printed hex encoding that + -- the LLVM frontend accepts. + | LitString + { litSource :: Text + , litHexEncoded :: Text + , litEncodingLength :: Int } + -- | A null pointer literal. -- Only applicable to pointer types | LitNull Type @@ -97,3 +170,50 @@ LitFloat t _ -> t LitNull t -> t LitUndef t -> t + + LitString _ _ encLen + -> TArray (fromIntegral encLen) (TInt 8) + + + +-- | Make a literal string from some text. +makeLitString :: Text -> Lit +makeLitString tx + = let (txEnc, nEncLen) = encodeText (tx `T.append` (T.pack [chr 0])) + in LitString tx txEnc nEncLen + + +-- | Hex encode non-printable characters in this string. +-- The LLVM frontend doesn't appear to be unicode-clean, so only unoffensive +-- ASCII characters are printed verbatim. Everything is hex-encoded as UTF-8. +encodeText :: Text -> (Text, Int) +encodeText tx + = go [] 0 tx + where + go accStr accLen xx + = case T.uncons xx of + Nothing + -> (T.concat $ reverse accStr, accLen) + + Just (x, xs) + -> let (str, len) = encodeChar x + in go (str : accStr) (accLen + len) xs + + encodeChar c + | c == ' ' + || (isAscii c && isAlphaNum c) + || (isAscii c && isPunctuation c && c /= '"') + = (T.pack [c], 1) + + | otherwise + = let bs = TE.encodeUtf8 $ T.pack [c] + len = BS.length bs + in ( T.pack $ concatMap (\b -> "\\" ++ (padL $ showHex b "")) + $ BS.unpack bs + , len) + + padL x + | length x == 0 = "00" + | length x == 1 = "0" ++ x + | otherwise = x + diff --git a/DDC/Llvm/Syntax/Instr.hs b/DDC/Llvm/Syntax/Instr.hs --- a/DDC/Llvm/Syntax/Instr.hs +++ b/DDC/Llvm/Syntax/Instr.hs @@ -81,11 +81,9 @@ -- INop instructions are erased by the 'Clean' transform. | INop - -- Phi nodes -------------------------------------- | IPhi Var [(Exp, Label)] - -- Terminator Instructions ------------------------ -- | Return a result. | IReturn (Maybe Exp) @@ -104,16 +102,16 @@ -- | Informs the optimizer that instructions after this point are unreachable. | IUnreachable - -- Binary Operations ------------------------------ | IOp Var Op Exp Exp - -- Conversion Operations -------------------------- -- | Cast the variable from to the to type. This is an abstraction of three -- cast operators in Llvm, inttoptr, prttoint and bitcast. | IConv Var Conv Exp + -- | Get element pointer. + | IGet Var Exp [Exp] -- Memory Access and Addressing ------------------- -- | Load a value from memory. @@ -123,13 +121,9 @@ -- First expression gives the destination pointer. | IStore Exp Exp - -- Other Operations ------------------------------- - -- | Integer comparison. - | IICmp Var ICond Exp Exp - - -- | Floating-point comparison. - | IFCmp Var FCond Exp Exp + -- | Comparisons + | ICmp Var Cond Exp Exp -- | Call a function. -- Only NoReturn, NoUnwind and ReadNone attributes are valid. @@ -170,10 +164,10 @@ IUnreachable{} -> Nothing IOp var _ _ _ -> Just var IConv var _ _ -> Just var + IGet var _ _ -> Just var ILoad var _ -> Just var IStore{} -> Nothing - IICmp var _ _ _ -> Just var - IFCmp var _ _ _ -> Just var + ICmp var _ _ _ -> Just var ICall mvar _ _ _ _ _ _ -> mvar diff --git a/DDC/Llvm/Syntax/Prim.hs b/DDC/Llvm/Syntax/Prim.hs --- a/DDC/Llvm/Syntax/Prim.hs +++ b/DDC/Llvm/Syntax/Prim.hs @@ -1,8 +1,7 @@ module DDC.Llvm.Syntax.Prim ( Op (..) - , ICond (..) - , FCond (..) + , Cond (..), ICond (..), FCond (..) , Conv (..)) where @@ -35,7 +34,14 @@ deriving (Eq, Show) --- | Integer comparison. +-- | Conditions. +data Cond + = ICond ICond + | FCond FCond + deriving (Eq, Show) + + +-- | Integer conditions. data ICond = ICondEq -- ^ Equal (Signed and Unsigned) | ICondNe -- ^ Not equal (Signed and Unsigned) @@ -50,7 +56,7 @@ deriving (Eq, Show) --- | Floating point comparison. +-- | Floating point conditions. data FCond = FCondFalse -- ^ Always yields false, regardless of operands. | FCondOeq -- ^ Both operands are not a QNAN and op1 is equal to op2. diff --git a/DDC/Llvm/Transform/Calls.hs b/DDC/Llvm/Transform/Calls.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Transform/Calls.hs @@ -0,0 +1,74 @@ + +-- | Attach calling conventions to ICall instructions. +module DDC.Llvm.Transform.Calls + (attachCallConvs) +where +import DDC.Llvm.Syntax + + +-- | Attach calling conventions to call instructions. +attachCallConvs :: Module -> Module +attachCallConvs mm + = let funcs' = map (callsFunction mm) $ modFuncs mm + in mm { modFuncs = funcs' } + + +-- | Attach calling conventions to call instructions in a function. +callsFunction :: Module -> Function -> Function +callsFunction mm fun + = let blocks' = map (callsBlock mm) $ funBlocks fun + in fun { funBlocks = blocks' } + + +-- | Attach calling conventions to call instructions in a block. +callsBlock :: Module -> Block -> Block +callsBlock mm block + = let instrs' = fmap (callsInstr mm) $ blockInstrs block + in block { blockInstrs = instrs' } + + +-- | Attach calling conventions to call instructions, +-- leaving other instructions unharmed. +callsInstr :: Module -> AnnotInstr -> AnnotInstr +callsInstr mm ai@(AnnotInstr i annots) + = case i of + ICall mv ct mcc t n xs ats + -> let Just cc2 = callConvOfName mm n + cc' = mergeCallConvs mcc cc2 + in AnnotInstr (ICall mv ct (Just cc') t n xs ats) + annots + + _ -> ai + + +-- | Lookup the calling convention for the given name. +callConvOfName :: Module -> Name -> Maybe CallConv +callConvOfName mm name + -- Functions defined at top level can have different calling + -- conventions. + | NameGlobal str <- name + , Just cc2 <- lookupCallConv str mm + = Just cc2 + + -- Unknown functions bound to variables are assumed to have + -- the standard calling convention. + | NameLocal _ <- name + = Just CC_Ccc + + | otherwise = Nothing + + +-- | If there is a calling convention attached directly to an ICall +-- instruction then it must match any we get from the environment. +mergeCallConvs :: Maybe CallConv -> CallConv -> CallConv +mergeCallConvs mc cc + = case mc of + Nothing -> cc + + Just cc' + | cc == cc' -> cc + | otherwise + -> error $ unlines + [ "DDC.LLVM.Transform.Clean" + , " Not overriding exising calling convention." ] + diff --git a/DDC/Llvm/Transform/Clean.hs b/DDC/Llvm/Transform/Clean.hs deleted file mode 100644 --- a/DDC/Llvm/Transform/Clean.hs +++ /dev/null @@ -1,192 +0,0 @@ - --- | Inline `ISet` meta-instructions, drop `INop` meta-instructions, --- and propagate calling conventions from declarations to call sites. --- This should all be part of the LLVM language itself, but it isn't. -module DDC.Llvm.Transform.Clean - (clean) -where -import DDC.Llvm.Syntax -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Foldable as Seq -import qualified Data.Sequence as Seq - - --- | Clean a module. -clean :: Module -> Module -clean mm - = let binds = Map.empty - in mm { modFuncs = map (cleanFunction mm binds) - $ modFuncs mm } - - --- | Clean a function. -cleanFunction - :: Module - -> Map Var Exp -- ^ Map of variables to their values. - -> Function -> Function - -cleanFunction mm binds fun - = fun { funBlocks = cleanBlocks mm binds Map.empty [] - $ funBlocks fun } - - --- | Clean set instructions in some blocks. -cleanBlocks - :: Module - -> Map Var Exp -- ^ Map of variables to their values. - -> Map Var Label -- ^ Map of variables to the label - -- of the block they were defined in. - -> [Block] - -> [Block] - -> [Block] - -cleanBlocks _mm _binds _defs acc [] - = reverse acc - -cleanBlocks mm binds defs acc (Block label instrs : bs) - = let (binds', defs', instrs2) - = cleanInstrs mm label binds defs [] - $ Seq.toList instrs - - instrs' = Seq.fromList instrs2 - block' = Block label instrs' - - in cleanBlocks mm binds' defs' (block' : acc) bs - - --- | Clean set instructions in some instructions. -cleanInstrs - :: Module - -> Label -- ^ Label of the current block. - -> Map Var Exp -- ^ Map of variables to their values. - -> Map Var Label -- ^ Map of variables to the label - -- of the block they were defined in. - -> [AnnotInstr] - -> [AnnotInstr] - -> (Map Var Exp, Map Var Label, [AnnotInstr]) - -cleanInstrs _mm _label binds defs acc [] - = (binds, defs, reverse acc) - -cleanInstrs mm label binds defs acc (ins@(AnnotInstr i annots) : instrs) - = let next binds' defs' acc' - = cleanInstrs mm label binds' defs' acc' instrs - - reAnnot i' = annotWith i' annots - - sub xx - = case xx of - XVar v - | Just x' <- Map.lookup v binds - -> sub x' - _ -> xx - - in case i of - IComment{} - -> next binds defs (ins : acc) - - -- The LLVM compiler doesn't support ISet instructions, - -- so we inline them into their use sites. - ISet v x - -> let binds' = Map.insert v x binds - in next binds' defs acc - - -- The LLVM compiler doesn't support INop instructions, - -- so we drop them out. - INop - -> next binds defs acc - - -- At phi nodes, drop out joins of the 'undef' value. - -- The converter adds these in rigtht before calling 'abort', - -- so we can never arrive from one of those blocks. - IPhi v xls - -> let - -- Don't merge undef expressions in phi nodes. - keepPair (XUndef _) = False - keepPair _ = True - - i' = IPhi v [(sub x, l) - | (x, l) <- xls - , keepPair (sub x) ] - - defs' = Map.insert v label defs - in next binds defs' $ (reAnnot i') : acc - - - IReturn Nothing - -> next binds defs $ ins : acc - - IReturn (Just x) - -> next binds defs $ (reAnnot $ IReturn (Just (sub x))) : acc - - IBranch{} - -> next binds defs $ ins : acc - - IBranchIf x l1 l2 - -> next binds defs $ (reAnnot $ IBranchIf (sub x) l1 l2) : acc - - ISwitch x def alts - -> next binds defs $ (reAnnot $ ISwitch (sub x) def alts) : acc - - IUnreachable - -> next binds defs $ ins : acc - - IOp v op x1 x2 - | defs' <- Map.insert v label defs - -> next binds defs' $ (reAnnot $ IOp v op (sub x1) (sub x2)) : acc - - IConv v c x - | defs' <- Map.insert v label defs - -> next binds defs' $ (reAnnot $ IConv v c (sub x)) : acc - - ILoad v x - | defs' <- Map.insert v label defs - -> next binds defs' $ (reAnnot $ ILoad v (sub x)) : acc - - IStore x1 x2 - -> next binds defs $ (reAnnot $ IStore (sub x1) (sub x2)) : acc - - IICmp v c x1 x2 - | defs' <- Map.insert v label defs - -> next binds defs' $ (reAnnot $ IICmp v c (sub x1) (sub x2)) : acc - - IFCmp v c x1 x2 - | defs' <- Map.insert v label defs - -> next binds defs' $ (reAnnot $ IFCmp v c (sub x1) (sub x2)) : acc - - ICall (Just v) ct mcc t n xs ats - | defs' <- Map.insert v label defs - -> let NameGlobal str = n - cc2 = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str) - $ lookupCallConv str mm - cc' = mergeCallConvs mcc cc2 - - in next binds defs' - $ (reAnnot $ ICall (Just v) ct (Just cc') t n (map sub xs) ats) - : acc - - ICall Nothing ct mcc t n xs ats - -> let NameGlobal str = n - cc2 = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str) - $ lookupCallConv str mm - cc' = mergeCallConvs mcc cc2 - in next binds defs - $ (reAnnot $ ICall Nothing ct (Just cc') t n (map sub xs) ats) - : acc - - --- | If there is a calling convention attached directly to an ICall --- instruction then it must match any we get from the environment. -mergeCallConvs :: Maybe CallConv -> CallConv -> CallConv -mergeCallConvs mc cc - = case mc of - Nothing -> cc - Just cc' - | cc == cc' -> cc - | otherwise - -> error $ unlines - [ "DDC.LLVM.Transform.Clean" - , " Not overriding exising calling convention." ] - diff --git a/DDC/Llvm/Transform/Flatten.hs b/DDC/Llvm/Transform/Flatten.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Transform/Flatten.hs @@ -0,0 +1,180 @@ + +-- | Flatten out the extended operators in our expression type to instructions +-- that the LLVM compiler will accept directly. +-- +-- The LLVM expresion language is anemic by design. During code generation +-- we use a fatter language, but now need to flatten out the extra operators +-- into plain LLVM instructions. +-- +-- This transform is kept separate from the 'Simpl' as it the input and +-- output programs are in different (sub) languages. +-- +module DDC.Llvm.Transform.Flatten + (flatten) +where +import DDC.Llvm.Syntax +import DDC.Control.Monad.Check +import Data.Sequence (Seq, (|>), (><)) +import Control.Monad +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Seq + + +-- | Flatten expressions in a module. +flatten :: Module -> Module +flatten mm + = let Right funcs' + = evalCheck 0 + $ mapM flattenFunction $ modFuncs mm + in mm { modFuncs = funcs' } + + +-- | Flatten expressions in a function. +flattenFunction :: Function -> FlattenM Function +flattenFunction fun + = do blocks' <- mapM flattenBlock $ funBlocks fun + return $ fun { funBlocks = blocks' } + + +-- | Flatten expressions in a single block. +flattenBlock :: Block -> FlattenM Block +flattenBlock block + = do instrs' <- flattenInstrs Seq.empty + $ Seq.toList $ blockInstrs block + return $ block { blockInstrs = Seq.fromList instrs' } + + +-- | Flatten a list of instructions. +flattenInstrs + :: Seq AnnotInstr -- ^ Accumulated instructions of result. + -> [AnnotInstr] -- ^ Instructions still to flatten. + -> FlattenM [AnnotInstr] + +flattenInstrs acc [] + = return $ Seq.toList acc + +flattenInstrs acc (AnnotInstr i annots : is) + = let + next acc' + = flattenInstrs acc' is + + reannot i' + = annotWith i' annots + + in case i of + + -- Comments + IComment{} + -> next $ acc |> reannot i + + -- Set meta-instructions. + ISet v x1 + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ ISet v x1') + + -- Preserve nops, for the sake of just doing one thing at a time. + -- These can be eliminated with the LLVM simplifier. + INop + -> next $ acc |> reannot i + + -- Phi nodes + IPhi{} + -> next $ acc |> reannot i + + -- Terminator instructions + IReturn{} + -> next $ acc |> reannot i + + IBranch{} + -> next $ acc |> reannot i + + IBranchIf x1 l1 l2 + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ IBranchIf x1' l1 l2) + + ISwitch x1 def alts + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ ISwitch x1' def alts) + + IUnreachable + -> next (acc |> (reannot i)) + + -- Operators + IOp v op x1 x2 + -> do (is1, x1') <- flattenX x1 + (is2, x2') <- flattenX x2 + next $ (acc >< is1 >< is2) |> (reannot $ IOp v op x1' x2') + + -- Conversions + IConv v c x1 + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ IConv v c x1') + + -- Get pointer + IGet v x1 os + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ IGet v x1' os) + + -- Memory access + ILoad v x1 + -> do (is1, x1') <- flattenX x1 + next $ (acc >< is1) |> (reannot $ ILoad v x1') + + IStore x1 x2 + -> do (is1, x1') <- flattenX x1 + (is2, x2') <- flattenX x2 + next $ (acc >< is1 >< is2) |> (reannot $ IStore x1' x2') + + -- Comparisons + ICmp v c x1 x2 + -> do (is1, x1') <- flattenX x1 + (is2, x2') <- flattenX x2 + next $ (acc >< is1 >< is2) |> (reannot $ ICmp v c x1' x2') + + -- Function calls + ICall mv ct mcc t n xs ats + -> do (iss, xs') <- fmap unzip $ mapM flattenX xs + let is' = join $ Seq.fromList iss + next $ (acc >< is') + |> (reannot $ ICall mv ct mcc t n xs' ats) + + +--------------------------------------------------------------------------------------------------- +-- | Given an extended LLVM expression, strip off our extended XConv and XGet +-- operators and turn them into new instructions. The LLVM compiler itself +-- doesn't accept XConv or XGet in an expression position. +flattenX :: Exp -> FlattenM (Seq AnnotInstr, Exp) +flattenX xx + = case xx of + XConv t c x + -> do (is', x') <- flattenX x + v <- newUniqueVar t + return (is' |> (annotNil $ IConv v c x'), XVar v) + + XGet t x os + -> do (is', x') <- flattenX x + v <- newUniqueVar t + return (is' |> (annotNil $ IGet v x' os), XVar v) + + _ -> return (Seq.empty, xx) + + + +-- teh monads ------------------------------------------------------------------------------------- +type FlattenM a = CheckM Int String a + + +-- | Unique name generation. +newUnique :: FlattenM Int +newUnique + = do s <- get + put $ s + 1 + return $ s + + +-- | Generate a new unique register variable with the specified `LlvmType`. +newUniqueVar :: Type -> FlattenM Var +newUniqueVar t + = do u <- newUnique + return $ Var (NameLocal ("_c" ++ show u)) t + diff --git a/DDC/Llvm/Transform/LinkPhi.hs b/DDC/Llvm/Transform/LinkPhi.hs deleted file mode 100644 --- a/DDC/Llvm/Transform/LinkPhi.hs +++ /dev/null @@ -1,88 +0,0 @@ - -module DDC.Llvm.Transform.LinkPhi - (linkPhi) -where -import DDC.Llvm.Analysis.Parents -import DDC.Llvm.Syntax -import DDC.Llvm.Graph -import qualified Data.Sequence as Seq - - --- | Link Phi instructions in a module. --- --- For Phi instructions, the Salt->Llvm converter just fills in the source --- block label of each variable to be merged with 'undef'. We need to add --- the real block label of the in-edge that defines each variable. --- --- We build a graph of each block, work out the in-edges due to branches, --- and fill in the real block labels by back tracing the in-edges until we --- find the node that defines each variable. --- -linkPhi :: Module -> Module -linkPhi mm - = mm { modFuncs = map (linkPhiFunction) $ modFuncs mm } - - --- | Link Phi instructions in a function. -linkPhiFunction :: Function -> Function -linkPhiFunction fun - = fun { funBlocks - = let Just graph = graphOfBlocks () (funBlocks fun) - in blocksOfGraph - $ linkPhiGraph graph } - - --- | Link Phi instructions in a block graph. -linkPhiGraph :: Graph () -> Graph Parents -linkPhiGraph graph - = let graph' = mapAnnotsOfGraph snd - $ annotParentsOfGraph graph - in mapNodesOfGraph (linkPhiNode graph') graph' - - --- | Link Phi instructions in a node. -linkPhiNode :: Graph Parents -> Node Parents -> Node Parents -linkPhiNode graph node@(Node label instrs parents) - | (Seq.viewl -> instr Seq.:< rest) <- instrs - = case instr of - -- If a block has a Phi instruction then it always comes first. - AnnotInstr IPhi{} _ - -> let Just instr' = linkPhiInstr graph label instr - in Node label (instr' Seq.<| rest) parents - - _ -> node - - | otherwise - = node - - --- | Link the block labels in this Phi instruction. -linkPhiInstr - :: Graph Parents -- ^ Block graph of the whole function body. - -> Label -- ^ Label of the block this instruction is in. - -> AnnotInstr -- ^ The Phi instruction to link. - -> Maybe AnnotInstr - -linkPhiInstr graph lNode (AnnotInstr (IPhi vDst xls) meta) - = Just $ AnnotInstr (IPhi vDst xls') meta - where - -- Link all the labels in the Phi instruction. - xls' = [(x, linkLabel x lMerge) | (x, lMerge) <- xls] - - -- Find the in-edge that defines this variable. - -- We use 'lineageOfVar' to get the list of in-edges all the - -- way back to the use-site. The parent node of the current one - -- is then second in the list. - linkLabel (XVar var) lMerge - = case lineageOfVar graph var lNode of - Just (_ : lParent : _) -> lParent - _ -> lMerge - - -- If we can't find the definition then just return the - -- original label. - linkLabel _ lMerge = lMerge - - -linkPhiInstr _graph _ _ - = Nothing - diff --git a/DDC/Llvm/Transform/Simpl.hs b/DDC/Llvm/Transform/Simpl.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Transform/Simpl.hs @@ -0,0 +1,263 @@ + +-- | LLVM program simplifier. +-- +-- The LLVM compiler itself already contains a metric crapton of transforms +-- that we don't want to re-implement here. However, these simple things +-- are useful when normalising the code emitted by the code generator, +-- so that the LLVM compiler will actually accept it. +-- +module DDC.Llvm.Transform.Simpl + ( simpl + , Config (..) + , configZero) +where +import DDC.Llvm.Syntax +import DDC.Llvm.Analysis.Defs +import DDC.Control.Monad.Check +import Data.Sequence (Seq, (|>)) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Foldable as Seq +import qualified Data.Sequence as Seq + + +--------------------------------------------------------------------------------------------------- +-- | Simplifier config. +data Config + = Config + { -- | Drop NOP instructions. + configDropNops :: Bool + + -- | Inline simple v1 v2 bindings. + , configSimplAlias :: Bool + + -- | Inline simple v1 const bindings. + -- + -- NOTE: Inlining constants into phi nodes before the 'from' labels for + -- each in-edge are filled will lose information and render the + -- program uncompilable. + , configSimplConst :: Bool + + -- Squash out joins of 'undef' values in phi nodes. + -- The code generator uses 'undef' as the result of an expression + -- that calls 'abort', but we don't want that propagated into + -- phi nodes. + , configSquashUndef :: Bool } + + +-- | Config with all transforms disabled. +configZero :: Config +configZero + = Config + { configDropNops = False + , configSimplAlias = False + , configSimplConst = False + , configSquashUndef = False } + + +--------------------------------------------------------------------------------------------------- +-- | Simplify a module. +simpl :: Config -> Module -> Module +simpl config mm + = let Right funcs' + = evalCheck () + $ mapM (simplFunction config) $ modFuncs mm + in mm { modFuncs = funcs' } + + +-- | Simplify the body of a function. +simplFunction :: Config -> Function -> SimplM Function +simplFunction config fun + = do + -- Build a map of how all the variables in this function are defined. + let defs = Map.unions + $ map defsOfBlock $ funBlocks fun + + -- Simplify each block in turn. + blocks' <- mapM (simplBlock config defs) + $ funBlocks fun + + return $ fun { funBlocks = blocks' } + + +-- | Simplify a single block. +simplBlock + :: Config -- ^ Simplifier configuration. + -> Map Var (Label, Def) -- ^ How each variable in the function is defined. + -> Block -- ^ Block to simplify. + -> SimplM Block + +simplBlock config defs block + = do instrs' <- simplInstrs config defs Seq.empty + $ Seq.toList $ blockInstrs block + return $ block { blockInstrs = Seq.fromList instrs' } + + +-- | Simplify a list of instructions. +simplInstrs + :: Config -- ^ Simplifier configuration. + -> Map Var (Label, Def) -- ^ How each variable in the function is defined. + -> Seq AnnotInstr -- ^ Accumulated instructions of result. + -> [AnnotInstr] -- ^ Instructions still to simplify. + -> SimplM [AnnotInstr] + +simplInstrs _config _defs acc [] + = return $ Seq.toList acc + +simplInstrs config defs acc (AnnotInstr i annots : is) + = let + -- Move to the next instruction in the sequence. + next acc' + = simplInstrs config defs acc' is + + -- Attach the annotation back to this instruction. + reannot i' + = annotWith i' annots + + -- Use the defs map to try to substitue this variable for + -- something even better. + subst xx0 + = go (0 :: Int) xx0 + where + go !n _xx + -- Bail out to avoid diverging when there is a loop in the definitions. + -- This should never happen in a sane, well formed program. + | n > 1000000 + = throw ErrorSimplAliasLoop + + go !n xx + = case xx of + XVar v + -> case Map.lookup v defs of + Just (_, DefAlias v') + | configSimplAlias config + -> go (n + 1) (XVar v') + + Just (_, DefClosedConstant xx') + | configSimplConst config + -> return xx' + + _ -> return xx + _ -> return xx + + in case i of + + -- Comments + IComment{} + -> next $ acc |> reannot i + + -- Set meta-instructions. + ISet v1 x2 + -- Simple aliases being substituted out. + | XVar _v2 <- x2 + , configSimplAlias config + -> next acc + + -- Closed constants being substituted out. + | isClosedConstantExp x2 + , configSimplConst config + -> next acc + + | otherwise + -> do x2' <- subst x2 + next $ acc |> reannot (ISet v1 x2') + + -- Drop nops if we were asked to. + INop + | configDropNops config + -> next acc + + | otherwise + -> next $ acc |> reannot i + + -- Phi nodes. + IPhi v xls + -> do + -- Substitute into expressions. + xs_subst <- mapM subst $ map fst xls + let ls_subst = map snd xls + + -- Squash out joins of 'undef' values in phi nodes. + -- The code generator uses 'undef' as the result of an expression + -- that calls 'abort', but we don't want that propagated into + -- phi nodes. + let xls_squash + | configSquashUndef config + = [ (x, l) | (x, l) <- zip xs_subst ls_subst + , not $ isXUndef x] + + | otherwise + = zip xs_subst ls_subst + + next $ acc |> reannot (IPhi v xls_squash) + + -- Terminator instructions + IReturn mx + -> do mx' <- case mx of + Nothing -> return Nothing + Just x -> fmap Just $ subst x + + next $ acc |> reannot (IReturn mx') + + IBranch{} + -> next $ acc |> reannot i + + IBranchIf x1 l2 l3 + -> do x1' <- subst x1 + next $ acc |> reannot (IBranchIf x1' l2 l3) + + ISwitch x1 def alts + -> do x1' <- subst x1 + next $ acc |> reannot (ISwitch x1' def alts) + + IUnreachable + -> next $ acc |> reannot i + + -- Operators + IOp v op x1 x2 + -> do x1' <- subst x1 + x2' <- subst x2 + next $ acc |> reannot (IOp v op x1' x2') + + -- Conversions + IConv v c x1 + -> do x1' <- subst x1 + next $ acc |> reannot (IConv v c x1') + + -- Get pointer + IGet v x1 os + -> do x1' <- subst x1 + next $ acc |> reannot (IGet v x1' os) + + -- Memory instructions + ILoad v x1 + -> do x1' <- subst x1 + next $ acc |> reannot (ILoad v x1') + + IStore x1 x2 + -> do x1' <- subst x1 + x2' <- subst x2 + next $ acc |> reannot (IStore x1' x2') + + -- Comparisons + ICmp v c x1 x2 + -> do x1' <- subst x1 + x2' <- subst x2 + next $ acc |> reannot (ICmp v c x1' x2') + + -- Calls + ICall mv cc mcc t n xs ats + -> do xs' <- mapM subst xs + next $ acc |> reannot (ICall mv cc mcc t n xs' ats) + + +-- teh monads ------------------------------------------------------------------------------------- +type SimplM a = CheckM () ErrorSimpl a + + +-- | Things that can go wrong during simplification. +data ErrorSimpl + -- | Substitution for v1 = v2 didn't complete after a sane + -- number of iterations. There might be a loop in the definitions. + = ErrorSimplAliasLoop + diff --git a/ddc-core-llvm.cabal b/ddc-core-llvm.cabal --- a/ddc-core-llvm.cabal +++ b/ddc-core-llvm.cabal @@ -1,5 +1,5 @@ Name: ddc-core-llvm -Version: 0.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,39 +14,50 @@ Library Build-Depends: - base >= 4.6 && < 4.8, - array >= 0.4 && < 0.6, + base >= 4.6 && < 4.9, + array >= 0.4 && < 0.6, + bytestring >= 0.10 && < 0.11, containers == 0.5.*, + text >= 1.0 && < 1.3, transformers == 0.4.*, - mtl == 2.2.*, - ddc-base == 0.4.1.*, - ddc-core == 0.4.1.*, - ddc-core-simpl == 0.4.1.*, - ddc-core-salt == 0.4.1.* + mtl == 2.2.1.*, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.* Exposed-modules: DDC.Core.Llvm.Metadata.Graph DDC.Core.Llvm.Metadata.Tbaa DDC.Core.Llvm.Convert - + DDC.Core.Llvm.Runtime + DDC.Llvm.Analysis.Children + DDC.Llvm.Analysis.Defs DDC.Llvm.Analysis.Parents - DDC.Llvm.Transform.Clean - DDC.Llvm.Transform.LinkPhi + DDC.Llvm.Transform.Calls + DDC.Llvm.Transform.Flatten + DDC.Llvm.Transform.Simpl + DDC.Llvm.Graph DDC.Llvm.Pretty DDC.Llvm.Syntax - DDC.Llvm.Graph Other-modules: - DDC.Core.Llvm.Convert.Atom - DDC.Core.Llvm.Convert.Erase + DDC.Core.Llvm.Convert.Exp.Atom + DDC.Core.Llvm.Convert.Exp.Case + DDC.Core.Llvm.Convert.Exp.PrimArith + DDC.Core.Llvm.Convert.Exp.PrimCall + DDC.Core.Llvm.Convert.Exp.PrimCast + DDC.Core.Llvm.Convert.Exp.PrimStore + + DDC.Core.Llvm.Convert.Base + DDC.Core.Llvm.Convert.Context + DDC.Core.Llvm.Convert.Error DDC.Core.Llvm.Convert.Exp - DDC.Core.Llvm.Convert.Prim DDC.Core.Llvm.Convert.Super DDC.Core.Llvm.Convert.Type - DDC.Core.Llvm.LlvmM DDC.Llvm.Pretty.Attr DDC.Llvm.Pretty.Exp @@ -83,5 +94,4 @@ FlexibleContexts ViewPatterns TupleSections - - + BangPatterns