diff --git a/DDC/Core/Llvm/Convert.hs b/DDC/Core/Llvm/Convert.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert.hs @@ -0,0 +1,730 @@ + +module DDC.Core.Llvm.Convert + ( convertModule + , convertType + , convertSuperType) +where +import DDC.Core.Llvm.Convert.Prim +import DDC.Core.Llvm.Convert.Type +import DDC.Core.Llvm.Convert.Atom +import DDC.Core.Llvm.Convert.Erase +import DDC.Core.Llvm.Metadata.Tbaa +import DDC.Core.Llvm.LlvmM +import DDC.Llvm.Syntax +import DDC.Core.Salt.Platform +import DDC.Core.Compounds +import DDC.Type.Env (KindEnv, TypeEnv) +import DDC.Type.Predicates +import DDC.Base.Pretty hiding (align) +import DDC.Data.ListUtils +import Control.Monad.State.Strict (evalState) +import Control.Monad.State.Strict (gets) +import Control.Monad +import Data.Maybe +import Data.Sequence (Seq, (<|), (|>), (><)) +import Data.Map (Map) +import Data.Set (Set) +import qualified DDC.Llvm.Transform.Clean as Llvm +import qualified DDC.Llvm.Transform.LinkPhi as Llvm +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Name as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C +import qualified DDC.Core.DaCon as C +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Simplifier as Simp +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Seq + + +-- Module --------------------------------------------------------------------- +-- | 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 mm@(C.ModuleCore{}) + = {-# SCC convertModule #-} + let + prims = primDeclsMap platform + state = llvmStateInit platform prims + + -- Add extra Const and Distinct witnesses where possible. + -- This helps us produce better LLVM metat data. + mmElab = evalState (Simp.applySimplifier + A.profile Env.empty Env.empty + (Simp.Trans Simp.Elaborate) mm) + 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) state + + -- Inline the ISet meta instructions and drop INops. + -- This gives us code that the LLVM compiler will accept directly. + mmClean = Llvm.clean mmRaw + + -- 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 + + in mmPhi + + +convModuleM :: C.Module () A.Name -> LlvmM Module +convModuleM mm@(C.ModuleCore{}) + | ([C.LRec bxs], _) <- splitXLets $ C.moduleBody mm + = do platform <- gets llvmStatePlatform + + -- The initial environments due to imported names. + let kenv = C.moduleKindEnv mm + let tenv = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs) + + -- Names of exported functions. + -- We use a different linkage for exported functions. + let nsExports = Set.fromList $ Map.keys $ C.moduleExportTypes mm + + -- Forward declarations for imported functions. + let Just importDecls + = sequence + $ [ importedFunctionDeclOfType platform kenv External n t + | (n, t) <- Map.elems $ C.moduleImportTypes mm ] + + -- Add RTS def ------------------------------------------------- + -- If this is the main module then we need to declare + -- the global RTS state. + let isMainModule + = C.moduleName mm == C.ModuleName ["Main"] + + -- 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_Runtime_heapTop") (tAddr platform) + + -- Holds the pointer to the maximum heap. + -- This is the byte _after_ the last byte avaiable in the heap. + let vHeapMax = Var (NameGlobal "_DDC_Runtime_heapMax") (tAddr platform) + + let rtsGlobals + | isMainModule + = [ GlobalStatic vHeapTop (StaticLit (LitInt (tAddr platform) 0)) + , GlobalStatic vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ] + + | otherwise + = [ GlobalExternal vHeapTop + , GlobalExternal vHeapMax ] + + --------------------------------------------------------------- + (functions, mdecls) + <- liftM unzip + $ mapM (uncurry (convSuperM nsExports kenv tenv)) bxs + + return $ Module + { modComments = [] + , modAliases = [aObj platform] + , modGlobals = rtsGlobals + , modFwdDecls = primDecls platform ++ importDecls + , modFuncs = functions + , modMDecls = concat mdecls } + + | otherwise = die "Invalid module" + + +-- | Global variables used directly by the converted code. +primDeclsMap :: Platform -> Map String FunctionDecl +primDeclsMap pp + = Map.fromList + $ [ (declName decl, decl) | decl <- primDecls pp ] + +primDecls :: Platform -> [FunctionDecl] +primDecls pp + = [ FunctionDecl + { declName = "malloc" + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = tAddr pp + , declParamListType = FixedArgs + , declParams = [Param (tNat pp) []] + , declAlign = AlignBytes (platformAlignBytes pp) } + + , FunctionDecl + { declName = "abort" + , declLinkage = External + , declCallConv = CC_Ccc + , declReturnType = TVoid + , declParamListType = FixedArgs + , declParams = [] + , declAlign = AlignBytes (platformAlignBytes pp) } ] + + +-- Super ---------------------------------------------------------------------- +-- | Convert a top-level supercombinator to a LLVM function. +-- Region variables are completely stripped out. +convSuperM + :: Set A.Name -- ^ Names exported from this module. + -> 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]) + +convSuperM nsExports kenv tenv bSuper@(C.BName nTop@(A.NameVar strTop) tSuper) x + | Just (bfsParam, xBody) <- takeXLamFlags x + = do + platform <- gets llvmStatePlatform + + -- Sanitise the super name so we can use it as a symbol + -- in the object code. + let nTop' = A.sanitizeGlobal strTop + + -- Add parameters to environments. + let bfsParam' = eraseWitBinds bfsParam + let bsParamType = [b | (True, b) <- bfsParam'] + let bsParamValue = [b | (False, b) <- bfsParam'] + + let kenv' = Env.extends bsParamType kenv + let tenv' = Env.extends (bSuper : bsParamValue) tenv + mdsup <- deriveMD nTop' x + + -- Split off the argument and result types of the super. + let (tsParam, tResult) + = convertSuperType platform kenv tSuper + + -- Make parameter binders. + let align = AlignBytes (platformAlignBytes platform) + + -- Declaration of the super. + let decl + = FunctionDecl + { declName = nTop' + + -- Set internal linkage for non-exported functions so that they + -- they won't conflict with functions of the same name that + -- might be defined in other modules. + , declLinkage + = if Set.member nTop nsExports + then External + else Internal + + -- ISSUE #266: Tailcall optimisation doesn't work for exported functions. + -- Using fast calls for non-exported functions enables the + -- LLVM tailcall optimisation. We can't enable this for exported + -- functions as well because we don't distinguish between DDC + -- generated functions and functions from the C libararies in + -- our import specifications. We need a proper FFI system so that + -- we can get tailcalls for exported functions as well. + , declCallConv + = if Set.member nTop nsExports + then CC_Ccc + else CC_Fastcc + + , 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 + + -- Build the function. + return $ ( Function + { funDecl = decl + , funParams = map nameOfParam $ filter (not . isBNone) bsParamValue + , funAttrs = [] + , funSection = SectionAuto + , funBlocks = Seq.toList blocks } + , decls mdsup ) + + +convSuperM _ _ _ _ _ + = die "Invalid super" + + +-- | Take the string name to use for a function parameter. +nameOfParam :: C.Bind A.Name -> String +nameOfParam bb + = case bb of + C.BName (A.NameVar n) _ + -> A.sanitizeName n + + _ -> die $ "Invalid parameter name: " ++ show bb + + +-- 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 + + +-- | Convert a function body to LLVM blocks. +convBodyM + :: BodyContext -- ^ Context of this conversion. + -> KindEnv A.Name + -> TypeEnv A.Name + -> MDSuper + -> 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. + +convBodyM context kenv tenv mdsup blocks label instrs xx + = do pp <- gets llvmStatePlatform + 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.PrimControl A.PrimControlReturn <- p + , [C.XType _, C.XCon _ dc] <- xs + , Just A.NameLitVoid <- C.takeNameOfDaCon dc + -> return $ blocks + |> Block label + (instrs |> (annotNil $ IReturn Nothing)) + + -- 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.PrimControl A.PrimControlReturn <- p + , [C.XType t, x2] <- xs + , isVoidT t + -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2 + return $ blocks + |> Block label + (instrs >< (instrs2 |> (annotNil $ IReturn Nothing))) + + -- 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.PrimControl A.PrimControlReturn <- p + , [C.XType t, x] <- xs + -> do let t' = convertType pp kenv t + vDst <- newUniqueVar t' + is <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x + return $ blocks + |> Block label + (instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst))))) + + -- 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") [] [] + + iSet = case context of + BodyTop -> INop + BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst)) + + block = Block label + $ instrs |> annotNil iSet + |> annotNil iFail + |> annotNil IUnreachable + + + in return $ blocks |> block + + + -- 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 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)) + + -- 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)))) + + + -- Assignment ------------------------------------ + + -- A statement of type void does not produce a value. + C.XLet _ (C.LLet C.LetStrict (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 + + -- 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.LetStrict (C.BNone t) x1) x2 + | not $ isVoidT t + -> do + n <- newUnique + let b = C.BName (A.NameVar ("_dummy" ++ show n)) t + + convBodyM context kenv tenv mdsup blocks label instrs + (C.XLet a (C.LLet C.LetStrict b x1) x2) + + -- Variable assigment from a case-expression. + C.XLet _ (C.LLet C.LetStrict b@(C.BName (A.NameVar n) t) + (C.XCase _ xScrut alts)) + x2 + -> do + let t' = convertType pp kenv t + + -- Assign result of case to this variable. + let n' = A.sanitizeName n + let vCont = Var (NameLocal n') t' + + -- Label to jump to continue evaluating 'x1' + lCont <- newUniqueLabel "cont" + + let context' = BodyNest vCont lCont + blocksCase <- convCaseM context' pp kenv tenv mdsup + label instrs xScrut alts + + let tenv' = Env.extend b tenv + convBodyM context kenv tenv' mdsup + (blocks >< blocksCase) + lCont + Seq.empty + x2 + + -- Variable assignment from an non-case expression. + C.XLet _ (C.LLet C.LetStrict 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 + + + -- Letregions ------------------------------------ + C.XLet _ (C.LLetRegions b _) x2 + -> do let kenv' = Env.extends b kenv + convBodyM context kenv' tenv mdsup blocks label instrs x2 + + -- Case ------------------------------------------ + C.XCase _ xScrut alts + -> do blocks' <- convCaseM context pp kenv tenv mdsup + label instrs xScrut alts + + return $ blocks >< blocks' + + -- Cast ------------------------------------------- + C.XCast _ _ x + -> convBodyM context kenv tenv mdsup blocks label instrs x + + _ + | BodyNest vDst label' <- context + -> do instrs' <- convExpM (ExpAssign vDst) pp kenv tenv mdsup xx + return $ blocks >< Seq.singleton (Block label + (instrs >< (instrs' |> (annotNil $ IBranch label')))) + + | otherwise + -> die $ renderIndent + $ text "Invalid body statement " + <$> ppr xx + + +-- 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 + + -- | Conversion in a context that expects a value. + -- We evaluate the expression and assign the result to this variable. + | ExpAssign Var + deriving Show + + +-- | Take any assignable variable from an `ExpContext`. +varOfExpContext :: ExpContext -> Maybe Var +varOfExpContext xc + = case xc of + ExpTop -> Nothing + ExpAssign var -> Just var + + +-- | 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) + +convExpM context pp kenv tenv mdsup xx + = case xx of + C.XVar _ u@(C.UName (A.NameVar n)) + | Just t <- Env.lookup u tenv + , ExpAssign vDst <- context + -> do let n' = A.sanitizeName n + let t' = convertType pp kenv t + return $ Seq.singleton $ annotNil + $ ISet vDst (XVar (Var (NameLocal n') t')) + + C.XCon _ dc + | Just n <- C.takeNameOfDaCon dc + , ExpAssign vDst <- context + -> case n of + A.NameLitNat i + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (tNat pp) i)) + + A.NameLitInt i + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (tInt pp) i)) + + A.NameLitWord w bits + -> return $ Seq.singleton $ annotNil + $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w)) + + _ -> die "Invalid literal" + + C.XApp{} + -- 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 + + -- Call to top-level super. + | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx + , Just (Var nFun _) <- takeGlobalV pp kenv tenv xFun + , Just xsArgs_value' <- sequence $ map (mconvAtom pp kenv tenv) + $ eraseTypeWitArgs xsArgs + , Just tSuper <- Env.lookup u tenv + -> let (_, tResult) = convertSuperType pp kenv tSuper + in return $ Seq.singleton $ annotNil + $ ICall (varOfExpContext context) CallTypeStd Nothing + tResult nFun xsArgs_value' [] + + C.XCast _ _ x + -> convExpM context pp kenv tenv mdsup x + + _ -> die $ "Invalid expression " ++ show xx + + +-- 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) + +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" + + +-- 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) + + +-- 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) + + +-- Alt ------------------------------------------------------------------------ +-- | Holds the result of converting an alternative. +data AltResult + = AltDefault Label (Seq Block) + | AltCase Lit Label (Seq Block) + + +-- | Convert a case alternative to LLVM. +-- +-- 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 <- C.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. +-- +-- 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 + + A.NameLitNat i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.NameLitInt i -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i + + A.NameLitWord i bits + | elem bits [8, 16, 32, 64] + -> Just $ LitInt (TInt $ fromIntegral bits) i + + A.NameLitTag i -> Just $ LitInt (TInt (8 * platformTagBytes pp)) i + + _ -> Nothing + + +-- | 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 (AltCase lit label _) = Just (lit, label) +takeAltCase _ = Nothing + diff --git a/DDC/Core/Llvm/Convert/Atom.hs b/DDC/Core/Llvm/Convert/Atom.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Atom.hs @@ -0,0 +1,101 @@ +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.Type.Env (KindEnv, TypeEnv) +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Salt as A +import qualified DDC.Core.Salt.Name as A +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.DaConNamed n <- C.daConName dc + , t <- C.daConType dc + -> case n of + A.NameLitBool bool + -> let i | bool = 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 + -> KindEnv A.Name + -> TypeEnv A.Name + -> C.Exp a A.Name + -> Maybe Var + +takeGlobalV pp kenv tenv xx + = case xx of + C.XVar _ u@(C.UName (A.NameVar str)) + | Just t <- Env.lookup u tenv + -> Just $ Var (NameGlobal str) (convertType pp kenv t) + _ -> Nothing + diff --git a/DDC/Core/Llvm/Convert/Erase.hs b/DDC/Core/Llvm/Convert/Erase.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Erase.hs @@ -0,0 +1,47 @@ + +module DDC.Core.Llvm.Convert.Erase + ( eraseTypeWitArgs + , eraseXLAMs + , eraseWitTApps + , eraseWitBinds ) +where +import DDC.Type.Predicates +import DDC.Core.Exp +import DDC.Core.Transform.TransformX + + +-- | 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/Prim.hs b/DDC/Core/Llvm/Convert/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Prim.hs @@ -0,0 +1,454 @@ + +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 `mod` 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 `mod` 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_Runtime_heapTop") (TPointer (tAddr pp)) + let vMaxPtr = Var (NameGlobal "_DDC_Runtime_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_Runtime_heapTop") (TPointer (tAddr pp)) + let vMaxPtr = Var (NameGlobal "_DDC_Runtime_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_Runtime_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 _t : 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 _t : 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 _r : 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 _r : 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 _r, C.XType _t, 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 _r, C.XType _t, 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 _r, C.XType _tSrc, C.XType _tDst, 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/Type.hs b/DDC/Core/Llvm/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Convert/Type.hs @@ -0,0 +1,240 @@ + +-- | Convert Salt types to LLVM types. +module DDC.Core.Llvm.Convert.Type + ( -- * Type conversion. + convertType + , convertSuperType + , importedFunctionDeclOfType + + -- * Builtin Types + , tObj, sObj, aObj + , tPtr, tAddr, tNat, tInt, tTag + + -- * Type Constructors + , convTyCon + + -- * Predicates + , isVoidT + , isSignedT + , isUnsignedT + , isIntegralT + , isFloatingT) +where +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.Core.Salt as A +import DDC.Core.Salt.Name as A +import qualified DDC.Core.Module as C +import qualified DDC.Core.Exp as C +import qualified DDC.Type.Env as Env + + +-- Type ----------------------------------------------------------------------- +-- | Convert a Salt type to an LlvmType. +convertType :: Platform -> KindEnv Name -> C.Type Name -> Type +convertType pp kenv tt + = case tt of + -- A polymorphic type, + -- represented as a generic boxed object. + C.TVar u + -> case Env.lookup u kenv of + Nothing -> die $ "Type variable not in kind environment." ++ show u + Just k + | isDataKind k -> TPointer (tObj pp) + | otherwise -> die "Invalid type variable." + + -- A primitive type. + C.TCon tc + -> convTyCon pp tc + + -- A pointer to a primitive type. + C.TApp{} + | Just (NamePrimTyCon PrimTyConPtr, [_r, t2]) + <- takePrimTyConApps tt + -> TPointer (convertType pp kenv 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) } + + C.TForall b t + -> let kenv' = Env.extend b kenv + in convertType pp kenv' t + + _ -> die ("Invalid Type " ++ show tt) + + +-- Super Type ----------------------------------------------------------------- +-- | Split the parameter and result types from a supercombinator type and +-- and convert them to LLVM form. +-- +-- We can't split the type first and just call 'convertType' above as we need +-- to decend into any quantifiers that wrap the body type. +convertSuperType + :: Platform + -> KindEnv Name + -> C.Type Name + -> ([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') + + C.TForall b t + -> let kenv' = Env.extend b kenv + in convertSuperType pp kenv' t + + _ -> die ("Invalid super type" ++ show tt') + + +-- Imports -------------------------------------------------------------------- +-- | Convert an imported function type to a LLVM declaration. +importedFunctionDeclOfType + :: Platform + -> KindEnv Name + -> Linkage + -> C.QualName Name + -> C.Type Name + -> Maybe FunctionDecl + +importedFunctionDeclOfType pp kenv linkage (C.QualName _ (NameVar n)) tt + = let (tsArgs, tResult) = convertSuperType pp kenv tt + mkParam t = Param t [] + in Just $ FunctionDecl + { declName = A.sanitizeGlobal n + , declLinkage = linkage + , declCallConv = CC_Ccc + , declReturnType = tResult + , declParamListType = FixedArgs + , declParams = map mkParam tsArgs + , declAlign = AlignBytes (platformAlignBytes pp) } + +importedFunctionDeclOfType _ _ _ _ _ + = Nothing + + +-- TyCon ---------------------------------------------------------------------- +-- | Convert a Sea TyCon to a LlvmType. +convTyCon :: Platform -> C.TyCon Name -> Type +convTyCon platform tycon + = case tycon of + C.TyConBound (C.UPrim NameObjTyCon _) _ + -> tObj platform + + C.TyConBound (C.UPrim (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) + + PrimTyConFloat bits + -> case bits of + 32 -> TFloat + 64 -> TDouble + 80 -> TFloat80 + 128 -> TFloat128 + _ -> die "Invalid width for float type constructor." + + _ -> die "Invalid primitive type constructor." + + _ -> die "Invalid type constructor." + + +-- | Type of Heap objects. +sObj, tObj :: Platform -> Type +sObj platform = TStruct [TInt (8 * platformObjBytes platform)] +tObj platform = TAlias (aObj platform) + +aObj :: Platform -> TypeAlias +aObj platform = TypeAlias "s.Obj" (sObj platform) + + +-- | Alias for pointer type. +tPtr :: Type -> Type +tPtr t = TPointer t + +-- | Alias for address type. +tAddr :: Platform -> Type +tAddr pp = TInt (8 * platformAddrBytes pp) + +-- | Alias for natural numner type. +tNat :: Platform -> Type +tNat pp = TInt (8 * platformAddrBytes pp) + +-- | Alias for machine integer type. +tInt :: Platform -> Type +tInt pp = TInt (8 * platformAddrBytes pp) + +-- | Alias for address type. +tTag :: Platform -> Type +tTag pp = TInt (8 * platformTagBytes pp) + + +-- Predicates ----------------------------------------------------------------- +-- | Check whether this is the Void# type. +isVoidT :: C.Type A.Name -> Bool +isVoidT (C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon A.PrimTyConVoid) _) _)) = True +isVoidT _ = False + + +-- | Check whether some type is signed: IntN or FloatN. +isSignedT :: C.Type A.Name -> Bool +isSignedT tt + = case tt of + C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _) + -> A.primTyConIsSigned tc + _ -> False + + +-- | Check whether some type is unsigned: NatN or WordN +isUnsignedT :: C.Type A.Name -> Bool +isUnsignedT tt + = case tt of + C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _) + -> A.primTyConIsUnsigned tc + _ -> False + + +-- | Check whether some type is an integral type. Nat, Int, WordN or Addr +isIntegralT :: C.Type A.Name -> Bool +isIntegralT tt + = case tt of + C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _) + -> A.primTyConIsIntegral tc + _ -> False + + +-- | Check whether some type is an integral type. Nat, IntN or WordN. +isFloatingT :: C.Type A.Name -> Bool +isFloatingT tt + = case tt of + C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _) + -> A.primTyConIsFloating tc + _ -> False + diff --git a/DDC/Core/Llvm/LlvmM.hs b/DDC/Core/Llvm/LlvmM.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/LlvmM.hs @@ -0,0 +1,114 @@ + +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 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 + + -- Primitives in the global environment. + , llvmStatePrimDecls :: Map String FunctionDecl } + + +-- | Initial LLVM state. +llvmStateInit + :: Platform + -> Map String FunctionDecl + -> LlvmState + +llvmStateInit platform prims + = LlvmState + { llvmStateUnique = 1 + , llvmStatePlatform = platform + , 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 new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Metadata/Graph.hs @@ -0,0 +1,253 @@ +-- Manipulate graphs for metadata generation +-- WARNING: everything in here is REALLY SLOW +module DDC.Core.Llvm.Metadata.Graph + ( -- * Graphs and Trees for TBAA metadata + UG(..), DG(..) + , minOrientation, partitionDG + , Tree(..) + , sources, anchor + + -- * Quickcheck Testing ONLY + , Dom, Rel + , fromList, toList + , allR, differenceR, unionR, composeR, transitiveR + , transClosure, transReduction + , aliasMeasure, isTree + , orientation, orientations + , bruteforceMinOrientation + , transOrientation + , smallOrientation + , partitionings + , minimumCompletion ) +where +import Data.List hiding (partition) +import Data.Ord +import Data.Tuple +import Data.Maybe +import Control.Monad + + +-- Binary relations ----------------------------------------------------------- +-- | A binary relation. +type Rel a = a -> a -> Bool +type Dom a = [a] + + +-- | Convert a relation. +toList :: Dom a -> Rel a -> [(a, a)] +toList dom r = [ (x, y) | x <- dom, y <- dom, r x y ] + + +-- | Convert a list to a relation. +fromList :: Eq a => [(a, a)] -> Rel a +fromList s = \x y -> (x,y) `elem` s + + +-- | Get the size of a a relation. +size :: Dom a -> Rel a -> Int +size d r = length $ toList d r + + +-- | The universal negative relation. +-- All members of the domain are not related. +allR :: Eq a => Rel a +allR = (/=) + + +-- | Fifference of two relations. +differenceR :: Rel a -> Rel a -> Rel a +differenceR f g = \x y -> f x y && not (g x y) + + +-- | Union two relations. +unionR :: Rel a -> Rel a -> Rel a +unionR f g = \x y -> f x y || g x y + + +-- | Compose two relations. +composeR :: Dom a -> Rel a -> Rel a -> Rel a +composeR dom f g = \x y -> or [ f x z && g z y | z <- dom ] + + +-- | Check whether a relation is transitive. +transitiveR :: Dom a -> Rel a -> Bool +transitiveR dom r + = and [ not (r x y && r y z && not (r x z)) + | x <- dom, y <- dom, z <- dom ] + + +-- | Find the transitive closure of a binary relation +-- using Floyd-Warshall algorithm +transClosure :: (Eq a) => Dom a -> Rel a -> Rel a +transClosure dom r = fromList $ step dom $ toList dom r + where step [] es = es + step (_:xs) es = step xs + $ nub (es ++ [(a, d) + | (a, b) <- es + , (c, d) <- es + , b == c]) + + +-- | Get the size of the transitive closure of a relation. +transCloSize :: (Eq a) => Dom a -> Rel a -> Int +transCloSize d r = size d $ transClosure d r + +transReduction :: Eq a => Dom a -> Rel a -> Rel a +transReduction dom rel + = let composeR' = composeR dom + in rel `differenceR` (rel `composeR'` transClosure dom rel) + + +-- Graphs --------------------------------------------------------------------- +-- | An undirected graph. +newtype UG a = UG (Dom a, Rel a) + +-- | A directed graph. +newtype DG a = DG (Dom a, Rel a) + +instance Show a => Show (UG a) where + show (UG (d,r)) = "UG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")" + +instance Show a => Show (DG a) where + show (DG (d,r)) = "DG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")" + +instance Show a => Eq (DG a) where + a == b = show a == show b + + +-- | Find the transitive orientation of an undirected graph if one exists +--- +-- ISSUE #297: Taking the transitive orientation of an aliasing graph +-- takes exponential(?) time. We should implement the O(n+m) algorithm +-- or detect when this is taking too long and bail out. +-- +transOrientation :: Eq a => UG a -> Maybe (DG a) +transOrientation ug@(UG (d,_)) + = liftM DG + $ liftM (d,) + $ find (transitiveR d) + $ orientations ug + +orientations :: Eq a => UG a -> [Rel a] +orientations (UG (d,g)) + = case toList d g of + [] -> [g] + edges -> let combo k = filter ((k==) . length) $ subsequences edges + choices = concatMap combo [0..length d] + choose c = g `differenceR` fromList c + `unionR` fromList (map swap c) + in map choose choices + + +-- | Find the orientation with the smallest transitive closure +-- +minOrientation :: (Show a, Eq a) => UG a -> DG a +minOrientation ug = fromMaybe (bruteforceMinOrientation ug) (transOrientation ug) + +bruteforceMinOrientation :: (Show a, Eq a) => UG a -> DG a +bruteforceMinOrientation ug@(UG (d, _)) + = let minTransClo : _ = sortBy (comparing $ transCloSize d) + $ orientations ug + in DG (d, minTransClo) + + +-- | Find the orientation with a `small enough' transitive closure +-- +smallOrientation :: (Show a, Eq a) => UG a -> DG a +smallOrientation ug = fromMaybe (orientation ug) (transOrientation ug) + +orientation :: Eq a => UG a -> DG a +orientation (UG (d,g)) = DG (d,g) + + +-- | Add a minimum number of edges to an undirected graph such that +-- it has a transitive orientation +-- +minimumCompletion :: (Show a, Eq a) => UG a -> UG a +minimumCompletion (UG (d,g)) + = let + -- Let U be the set of all possible fill edges. For all subsets + -- S of U, add S to G and see if the result is trans-orientable. + u = toList d $ allR `differenceR` g + combo k = filter ((k==) . length) $ subsequences u + choices = concatMap combo [0..length u] + choose c = g `unionR` fromList c + + -- There always exists a comparability completion for an undirected graph + -- in the worst case it's the complete version of the graph. + -- the result is minimum thanks to how `subsequences` and + -- list comprehensions work. + in fromMaybe (error "minimumCompletion: no completion found!") + $ liftM UG + $ find (isJust . transOrientation . UG) $ map ((d,) . choose) choices + + +-- Trees ---------------------------------------------------------------------- +-- | An inverted tree (with edges going from child to parent) +newtype Tree a = Tree (Dom a, Rel a) + +instance Show a => Show (Tree a) where + show (Tree (d,r)) = "tree (" ++ (show d) ++ ", " ++ (show $ toList d r) ++ ")" + + +-- | A relation is an (inverted) tree if each node has at most one outgoing arc +isTree :: Dom a -> Rel a -> Bool +isTree dom r + = let neighbours x = filter (r x) dom + in all ((<=1) . length . neighbours) dom + + +-- | Get the sources of a tree. +sources :: Eq a => a -> Tree a -> [a] +sources x (Tree (d, r)) = [y | y <- d, r y x] + + +-- | Partition a DG into the minimum set of (directed) trees +-- +partitionDG :: Eq a => DG a -> [Tree a] +partitionDG (DG (d,g)) + = let mkGraph g' nodes = (nodes, fromList [ (x,y) | x <- nodes, y <- nodes, g' x y ]) + in map Tree $ fromMaybe (error "partitionDG: no partition found!") + $ find (all $ uncurry isTree) + $ map (map (mkGraph g)) + $ sortBy (comparing (aliasMeasure g)) + $ partitionings d + + +-- | A partitioning of a tree. +type Partitioning a = [SubList a] +type SubList a = [a] + + +-- | Calculate the aliasing induced by a set of trees this includes aliasing +-- within each of the trees and aliasing among trees. +--- +-- ISSUE #298: Need a more efficient way to compute the +-- aliasing measure. What is the complexity of this current version? +-- +aliasMeasure :: Eq a => Rel a -> Partitioning a -> Int +aliasMeasure g p + = (outerAliasing $ map length p) + (sum $ map innerAliasing p) + where innerAliasing t = length $ toList t $ transClosure t g + outerAliasing (l:ls) = l * (sum ls) + outerAliasing ls + outerAliasing [] = 0 + + +-- | Generate all possible partitions of a list +-- by nondeterministically decide which sublist to add an element to. +partitionings :: Eq a => [a] -> [Partitioning a] +partitionings [] = [[]] +partitionings (x:xs) = concatMap (nondetPut x) $ partitionings xs + where nondetPut :: a -> Partitioning a -> [Partitioning a] + nondetPut y [] = [ [[y]] ] + nondetPut y (l:ls) = let putHere = (y:l):ls + putLater = map (l:) $ nondetPut y ls + in putHere:putLater + + +-- | Enroot a tree with the given root. +anchor :: Eq a => a -> Tree a -> Tree a +anchor root (Tree (d,g)) + = let leaves = filter (null . flip filter d . g) d + arcs = map (, root) leaves + in Tree (root:d, g `unionR` fromList arcs) diff --git a/DDC/Core/Llvm/Metadata/Tbaa.hs b/DDC/Core/Llvm/Metadata/Tbaa.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Llvm/Metadata/Tbaa.hs @@ -0,0 +1,239 @@ +module DDC.Core.Llvm.Metadata.Tbaa + ( MDSuper(..) + , deriveMD + , annot + , lookup, lookups ) +where +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Pretty.Metadata () +import DDC.Type.Exp +import DDC.Type.Compounds +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.Base.Pretty hiding (empty) +import qualified DDC.Type.Env as Env +import qualified DDC.Core.Salt as A +import qualified DDC.Llvm.Syntax as V + +import Prelude hiding (lookup) +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.Map (Map) +import Data.List hiding (lookup) +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- Metadata management -------------------------------------------------------- +-- | Metadata for a supercombinator. +data MDSuper + = MDSuper + { -- Map bound regions to metadata nodes for attaching metadata + -- to relevant instructions. + nameMap :: MDEnv + + -- Metadata nodes, to be pretty-printed with the module as + -- declarations. e.g. "1 = !{ metadata "id", !parent, !i11} + , decls :: [MDecl] + } deriving Show + +instance Pretty (MDSuper) where + ppr (MDSuper _ metadata) + = vcat $ map ppr metadata + + +-- | Map region variables to relevant metadata +-- need the whole declaration for tags, e.g "!tbaa", "!debug" +type MDEnv = Map (Bound A.Name) [MDecl] + +emptyDict :: MDEnv +emptyDict = Map.empty + +extendDict :: (Bound A.Name, MDecl) -> MDEnv -> MDEnv +extendDict (u, n) e | Map.member u e = Map.adjust (n:) u e + | otherwise = Map.insert u [n] e + + +-- | Lookup the metadata for a name, from the metadata tree attached +-- to a supecombinator. +lookup :: Bound A.Name -> MDSuper -> Maybe [MDecl] +lookup u mdsup = Map.lookup u (nameMap mdsup) + + +-- | Like `lookup` but lookup metadata for several names at once. +lookups :: [Bound A.Name] -> MDSuper -> [Maybe [MDecl]] +lookups us mdsup = map (flip lookup mdsup) us + + +-- | 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 + +deriveMD nTop xx + = let + regs = collectRegsB xx + (constwits, diswits) = partitionWits $ collectWitsB xx + arel = constructARel diswits + domain = constructANodes regs constwits + mdDG = minOrientation $ UG (domain, arel) + mdTrees = partitionDG mdDG + in foldM (buildMDTree nTop) (MDSuper emptyDict []) mdTrees + + +buildMDTree :: String -> MDSuper -> Tree ANode -> LlvmM 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 nTop tree parent sup node + = case parent of + Nothing -> do name <- freshRootName nTop + bf Nothing $ tbaaRoot name + + Just parentRef -> do name <- freshNodeName nTop (regionU node) + bf (Just $ regionU node) $ tbaaNode name parentRef (isConst node) + where bf u md + = do ref <- liftM MRef $ newUnique + let sup' = declare u ref md sup + let children = sources node tree + foldM (bfBuild nTop tree (Just ref)) sup' children + declare u r m s + = let decl = MDecl r m + in case u of Nothing -> s { decls = decl:(decls s) } + Just u' -> s { nameMap = extendDict (u',decl) $ nameMap s + , 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 + +freshRootName :: String -> LlvmM String +freshRootName qualify = liftA (\i -> qualify ++ "_ROOT_" ++ (show i)) newUnique + + +-- | Attach relevant metadata to instructions +annot :: (BindStruct c, Show (c A.Name)) + => KindEnv A.Name + -> MDSuper -- ^ Metadata + -> [c A.Name] -- ^ Things to lookup for Meta data. + -> V.Instr -- ^ Instruction to annotate + -> V.AnnotInstr + +annot kenv mdsup xs ins + = let regions = concatMap (collectRegsU kenv) xs + mdecls = concat $ catMaybes $ lookups regions mdsup + annotate' ms is + = case is of + V.ILoad{} -> V.AnnotInstr is ms + V.IStore{} -> V.AnnotInstr is ms + _ -> V.AnnotInstr is [] + in annotate' mdecls ins + + +-- Alias relation ------------------------------------------------------------- +-- | A node in the alias graphs, representing a region +data ANode = ANode { regionU :: RegBound + , isConst :: Bool } + | ARoot + deriving (Show, Eq) + + +-- | Make nodes from regions +constructANodes :: [RegBound] -> [WitType] -> [ANode] +constructANodes regs constwits + = let isConstR r = or $ map (flip isConstWFor r) constwits + mkANode r = ANode r (isConstR r) + in map mkANode regs + + +-- | Encode the `alias` relation defined on the set regions +-- * reflexitivity is taken as implicit +-- (important for generating DAG, and safe since LLVM already assumes +-- reflexitivity) +-- * symmetry is made explicit +-- note that `alias` is non-transitive. +-- +constructARel :: [WitType] -> Rel ANode +constructARel diswits = alias + where alias n1 n2 + | n1 == n2 = False + | otherwise = not $ or + $ map (flip isDistinctWFor (regionU n1, regionU n2)) diswits + + +-- Collecting bounds ---------------------------------------------------------- +type RegBound = Bound A.Name +type WitType = Type A.Name + + +isConstW :: WitType -> Bool +isConstW t = isConstWitType t + + +isConstWFor :: WitType -> RegBound -> Bool +isConstWFor t r + | _ : args <- takeTApps t + = and [isConstWitType t, elem (TVar r) args] + | otherwise = False + + +isDistinctW :: WitType-> Bool +isDistinctW tw + | tc : _ <- takeTApps tw = isDistinctWitType tc + | otherwise = False + + +isDistinctWFor :: WitType -> (RegBound, RegBound) -> Bool +isDistinctWFor t (r1,r2) + | tc : args <- takeTApps t + = and [isDistinctWitType tc, (TVar r1) `elem` args, (TVar r2) `elem` args] + | otherwise = False + + +-- | Divide a set of witnesses to a set of Const wits and a set of Distinct wits +partitionWits :: [WitType] -> ([WitType], [WitType]) +partitionWits ws + = partition isConstW + $ filter (liftA2 (||) isConstW isDistinctW) ws + + +-- | Collect region bounds +collectRegsU :: (BindStruct c) => KindEnv A.Name -> c A.Name -> [RegBound] +collectRegsU kenv cc + = let isReg u = case Env.lookup u kenv of + Just t | isRegionKind t -> True + _ -> False + in filter isReg $ Set.toList (collectBound cc) + + +-- | Collect region bindings +collectRegsB :: (BindStruct c) => c A.Name -> [RegBound] +collectRegsB cc + = let isBindReg b + = case b of + BName n t | isRegionKind t -> Just (UName n) + _ -> Nothing + bindRegs = map (isBindReg) $ fst (collectBinds cc) + in catMaybes bindRegs + + +-- | Collect witness bindings together with their types (for convinience) +collectWitsB :: (BindStruct c) => c A.Name -> [WitType] +collectWitsB cc + = let isBindWit b + = let t = typeOfBind b + in if isWitnessType t then Just t else Nothing + bindWits = map (isBindWit) $ snd (collectBinds cc) + in catMaybes bindWits + diff --git a/DDC/Llvm/Analysis/Children.hs b/DDC/Llvm/Analysis/Children.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Analysis/Children.hs @@ -0,0 +1,35 @@ + +module DDC.Llvm.Analysis.Children + ( Children (..) + , annotChildrenOfGraph + , annotChildrenOfNode + , childrenOfNode) +where +import DDC.Llvm.Syntax +import DDC.Llvm.Graph +import Data.Set (Set) +import qualified Data.Map as Map + + +-- | The children of a node are the other nodes this one might branch to. +data Children + = Children (Set Label) + + +-- | Annotate a graph with the children of each node. +annotChildrenOfGraph + :: Graph a -> Graph (a, Children) + +annotChildrenOfGraph (Graph entry nodes) + = Graph entry + $ Map.map annotChildrenOfNode nodes + + +-- | Annotate a node with its children. +annotChildrenOfNode + :: Node a -> Node (a, Children) + +annotChildrenOfNode node@(Node label instrs annot) + = Node label instrs + $ (annot, Children $ childrenOfNode node) + diff --git a/DDC/Llvm/Analysis/Parents.hs b/DDC/Llvm/Analysis/Parents.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Analysis/Parents.hs @@ -0,0 +1,81 @@ + +module DDC.Llvm.Analysis.Parents + ( Parents (..) + , annotParentsOfGraph + , lineageOfVar) +where +import DDC.Llvm.Graph +import DDC.Llvm.Syntax +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Maybe + + +-- | The parents of a node are the other nodes that might branch +-- to this one. +data Parents + = Parents (Set Label) + + +-- | Annotate a graph with the parents of each node. +annotParentsOfGraph + :: Graph a -> Graph (a, Parents) + +annotParentsOfGraph graph0 + = go (zeroParents graph0) + $ labelsOfGraph graph0 + where + go graph [] + = graph + + go graph (label : rest) + = go (pushParents label graph) rest + + -- Add this node as a parent of its children. + pushParents label graph + = let Just node = Map.lookup label $ graphNodes graph + lsChildren = childrenOfNode node + in foldr (addParent label) graph $ Set.toList lsChildren + + -- Add a parent to a child node + addParent labelParent labelChild graph + = flip (modifyNodeOfGraph labelChild) graph $ \node + -> let (a, Parents ls) = nodeAnnot node + annot' = (a, Parents (Set.insert labelParent ls)) + in node { nodeAnnot = annot' } + + -- Add empty parent sets to all the nodes in a graph. + zeroParents graph + = flip mapNodesOfGraph graph + $ \node -> node { nodeAnnot = (nodeAnnot node, Parents Set.empty) } + + +-- | Get a list of parents tracing back to the node that defines the given +-- variable, or `Nothing` if the definition site can not be found. +lineageOfVar + :: Graph Parents + -> Var -- Variable we want the definition for. + -> Label -- Label of starting node. + -> Maybe [Label] + +lineageOfVar graph target start + = go start + where go label + | Just node <- lookupNodeOfGraph graph label + , defs <- defVarsOfBlock $ blockOfNode node + = if Set.member target defs + -- We found the defining node. + then Just [nodeLabel node] + + -- We haven't found the definining node yet, + -- so check the parents. + else let Parents parents = nodeAnnot node + psLines = map (lineageOfVar graph target) + $ Set.toList parents + in case catMaybes psLines of + line : _ -> Just (nodeLabel node : line) + _ -> Nothing + + | otherwise + = Nothing diff --git a/DDC/Llvm/Graph.hs b/DDC/Llvm/Graph.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Graph.hs @@ -0,0 +1,146 @@ + +module DDC.Llvm.Graph + ( -- * Block Graphs + Graph (..) + , Node (..) + + -- * Graph Utils + , graphOfBlocks + , blocksOfGraph + , labelsOfGraph + , lookupNodeOfGraph + , modifyNodeOfGraph + , mapNodesOfGraph + , mapAnnotsOfGraph + + -- * Node Utils + , blockOfNode + , childrenOfNode) +where +import DDC.Llvm.Syntax +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import Data.Sequence (Seq) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + + +-- | Llvm block graph. +-- We use this form for transformations, +-- as it makes it easy to find blocks and attach annotations to them. +data Graph a + = Graph + { -- | The entry node for the block graph. + graphEntry :: Label + + -- | Internal nodes. + , graphNodes :: Map Label (Node a) } + deriving Show + + +-- | A block of instructions, and an optional annotation. +data Node a + = Node + { -- | Block label for the node. + nodeLabel :: Label + + -- | Statements in this node, with meta-data annotations. + , nodeInstrs :: Seq AnnotInstr + + -- | Optional annotation on the node. + , nodeAnnot :: a } + deriving Show + + +-- Graph Utils ---------------------------------------------------------------- +-- | Convert a list of blocks to a block graph. +graphOfBlocks :: a -> [Block] -> Maybe (Graph a) +graphOfBlocks _ [] = Nothing +graphOfBlocks a blocks@(first : _) + = let entry = blockLabel first + nodes = Map.fromList + $ [ (label, Node label stmts a) + | Block label stmts <- blocks ] + in Just $ Graph entry nodes + + +-- | Flatten a graph back into a list of blocks. +blocksOfGraph :: Graph a -> [Block] +blocksOfGraph (Graph entry nodes) + = go Set.empty [entry] + where + -- The 'done' set records which nodes we've already visited. + -- We need this to handle join points, where there are multiple + -- in-edges to the node. + go _ [] = [] + go done (label : more) + = let Just node = Map.lookup label nodes + children = childrenOfNode node + + -- Remember that we've already visited this node. + done' = Set.insert label done + + -- Add the children of this node to the set still to visit. + more' = Set.toList $ (Set.union (Set.fromList more) children) + `Set.difference` done' + + in Block label (nodeInstrs node) : go done' more' + + +-- | Get the set of all block labels in a graph. +labelsOfGraph :: Graph a -> [Label] +labelsOfGraph graph + = map blockLabel $ blocksOfGraph graph + + +-- | Lookup a node from the graph, or `Nothing` if it can't be found. +lookupNodeOfGraph :: Graph a -> Label -> Maybe (Node a) +lookupNodeOfGraph (Graph _ nodes) label + = Map.lookup label nodes + + +-- | Apply a function to a single node in the graoh. +modifyNodeOfGraph + :: Label -- ^ Label of node to modify. + -> (Node a -> Node a) -- ^ Function to apply to the node. + -> Graph a -> Graph a + +modifyNodeOfGraph label modify graph@(Graph entry nodes) + = case Map.lookup label nodes of + Nothing -> graph + Just node -> Graph entry (Map.insert label (modify node) nodes) + + +-- | Apply a function to every node in the graph. +mapNodesOfGraph :: (Node a -> Node b) -> Graph a -> Graph b +mapNodesOfGraph f (Graph entry nodes) + = Graph entry $ Map.map f nodes + + +-- | Apply a function to every node annotation in the graph. +mapAnnotsOfGraph :: (a -> b) -> Graph a -> Graph b +mapAnnotsOfGraph f graph + = let modifyNode (Node label nodes annot) = Node label nodes (f annot) + in mapNodesOfGraph modifyNode graph + + +-- Node Utils ----------------------------------------------------------------- +-- | Convert a `Node` to `Block` form, dropping any annotation. +blockOfNode :: Node a -> Block +blockOfNode (Node label instrs _) + = Block label instrs + + +-- | Get the children of a node. +childrenOfNode :: Node a -> Set Label +childrenOfNode node + = case Seq.viewr $ nodeInstrs node of + Seq.EmptyR + -> Set.empty + + _ Seq.:> instr + -> fromMaybe Set.empty + $ branchTargetsOfInstr $ annotInstr instr + diff --git a/DDC/Llvm/Pretty.hs b/DDC/Llvm/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty.hs @@ -0,0 +1,11 @@ + +-- | Pretty printer instances for the Llvm syntax. +module DDC.Llvm.Pretty where +import DDC.Llvm.Pretty.Attr () +import DDC.Llvm.Pretty.Exp () +import DDC.Llvm.Pretty.Function () +import DDC.Llvm.Pretty.Instr () +import DDC.Llvm.Pretty.Metadata () +import DDC.Llvm.Pretty.Module () +import DDC.Llvm.Pretty.Prim () +import DDC.Llvm.Pretty.Type () diff --git a/DDC/Llvm/Pretty/Attr.hs b/DDC/Llvm/Pretty/Attr.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Attr.hs @@ -0,0 +1,69 @@ + +-- | Attributes for functions and parameters. +module DDC.Llvm.Pretty.Attr where +import DDC.Llvm.Syntax.Attr +import DDC.Base.Pretty + + +instance Pretty FuncAttr where + ppr attr + = case attr of + AlwaysInline -> text "alwaysinline" + InlineHint -> text "inlinehint" + NoInline -> text "noinline" + OptSize -> text "optsize" + NoReturn -> text "noreturn" + NoUnwind -> text "nounwind" + ReadNone -> text "readnon" + ReadOnly -> text "readonly" + Ssp -> text "ssp" + SspReq -> text "ssqreq" + NoRedZone -> text "noredzone" + NoImplicitFloat -> text "noimplicitfloat" + Naked -> text "naked" + + +instance Pretty ParamAttr where + ppr attr + = case attr of + ZeroExt -> text "zeroext" + SignExt -> text "signext" + InReg -> text "inreg" + ByVal -> text "byval" + SRet -> text "sret" + NoAlias -> text "noalias" + NoCapture -> text "nocapture" + Nest -> text "nest" + + +instance Pretty CallConv where + ppr cc + = case cc of + CC_Ccc -> text "ccc" + CC_Fastcc -> text "fastcc" + CC_Coldcc -> text "coldcc" + CC_Ncc i -> text "cc " <> int i + CC_X86_Stdcc -> text "x86_stdcallcc" + + +instance Pretty Linkage where + ppr lt + = case lt of + Internal -> text "internal" + LinkOnce -> text "linkonce" + Weak -> text "weak" + Appending -> text "appending" + ExternWeak -> text "extern_weak" + + -- ExternallyVisible does not have a textual representation, it is + -- the linkage type a function resolves to if no other is specified + -- in Llvm. + ExternallyVisible -> empty + + External -> text "external" + +instance Pretty CallType where + ppr ct + = case ct of + CallTypeStd -> empty + CallTypeTail -> text "tail" diff --git a/DDC/Llvm/Pretty/Exp.hs b/DDC/Llvm/Pretty/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Exp.hs @@ -0,0 +1,58 @@ + +module DDC.Llvm.Pretty.Exp + ( pprPlainX + , pprPlainL) +where +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Pretty.Type () +import DDC.Base.Pretty + + +-- Exp ------------------------------------------------------------------------ +instance Pretty Exp where + ppr xx + = case xx of + XVar v -> ppr v + XLit l -> ppr l + XUndef _ -> text "undef" + + +-- | 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" + + +-- 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 "ppr[Lit]: floats aren't handled yet" + LitNull _ -> text "null" + LitUndef _ -> text "undef" + + +-- | Pretty print a literal without its type. +pprPlainL :: Lit -> Doc +pprPlainL ll + = case ll of + LitInt _ i -> integer i + LitFloat{} -> error "ppr[Lit]: floats aren't handled yet" + LitNull _ -> text "null" + LitUndef _ -> text "undef" + diff --git a/DDC/Llvm/Pretty/Function.hs b/DDC/Llvm/Pretty/Function.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Function.hs @@ -0,0 +1,59 @@ + +module DDC.Llvm.Pretty.Function + ( pprFunctionHeader) +where +import DDC.Llvm.Syntax.Function +import DDC.Llvm.Syntax.Type +import DDC.Llvm.Pretty.Attr () +import DDC.Llvm.Pretty.Instr () +import DDC.Base.Pretty + + +instance Pretty Function where + ppr (Function decl paramNames attrs sec body) + = let attrDoc = hsep $ map ppr attrs + secDoc = case sec of + SectionAuto -> empty + SectionSpecific s -> text "section" <+> (dquotes $ text s) + + in text "define" + <+> pprFunctionHeader decl (Just paramNames) + <+> attrDoc <+> secDoc + <$> lbrace + <$> vcat (map ppr body) + <$> rbrace + + +-- | Print out a function defenition header. +pprFunctionHeader :: FunctionDecl -> Maybe [String] -> Doc +pprFunctionHeader + (FunctionDecl name linkage callConv tReturn varg params alignment) + mnsParams + = let varg' = case varg of + VarArgs | null params -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + + align' = case alignment of + AlignNone -> empty + AlignBytes b -> text " align" <+> ppr b + + args' + = case mnsParams of + Just nsParams + -> [ ppr ty <+> hsep (map ppr attrs) <+> text "%" <> text nParam + | Param ty attrs <- params + | nParam <- nsParams ] + + Nothing + -> [ ppr ty <+> hsep (map ppr attrs) + | Param ty attrs <- params ] + + in ppr linkage + <+> ppr callConv + <+> ppr tReturn + <+> text "@" <> text name + <> lparen + <> (hcat $ punctuate (comma <> space) args') <> varg' + <> rparen + <> align' diff --git a/DDC/Llvm/Pretty/Instr.hs b/DDC/Llvm/Pretty/Instr.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Instr.hs @@ -0,0 +1,161 @@ + +module DDC.Llvm.Pretty.Instr where +import DDC.Llvm.Syntax.Instr +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Syntax.Attr +import DDC.Llvm.Pretty.Exp +import DDC.Llvm.Pretty.Prim () +import DDC.Llvm.Pretty.Metadata () +import Data.List +import qualified Data.Foldable as Seq +import DDC.Base.Pretty + + +instance Pretty Label where + ppr (Label str) = text str + + +instance Pretty Block where + ppr (Block label instrs) + = ppr label <> colon + <$$> indent 8 (vcat $ map ppr $ Seq.toList instrs) + + +instance Pretty AnnotInstr where + ppr (AnnotInstr instr []) = ppr instr + ppr (AnnotInstr instr mds) + = let pprWithTag (MDecl ref Tbaa{}) = text "!tbaa" <> space <> ppr ref + pprWithTag (MDecl ref Debug) = text "!debug" <> space <> ppr ref + in ppr instr + <> comma <> (hcat $ replicate 4 space) + <> (hcat $ punctuate (comma <> space) (map pprWithTag mds)) + + +instance Pretty Instr where + ppr ii + = let -- Pad binding occurrence of variable. + padVar var + = fill 12 (ppr $ nameOfVar var) + + in case ii of + -- Meta-instructions ------------------------------- + IComment strs + -> vcat $ map (semi <+>) $ map text strs + + ISet dst val + -> hsep [ fill 12 (ppr $ nameOfVar dst) + , equals + , ppr val ] + + INop + -> text "nop" + + -- Phi nodes -------------------------------------- + IPhi vDst expLabels + -> padVar vDst + <+> equals + <+> text "phi" + <+> ppr (typeOfVar vDst) + <+> hcat + (intersperse (comma <> space) + [ brackets + ( pprPlainX xSrc + <> comma + <+> text "%" <> ppr label) + | (xSrc, label) <- expLabels ]) + + -- Terminator Instructions ------------------------ + IReturn Nothing + -> text "ret void" + + IReturn (Just value) + -> text "ret" <+> ppr value + + IBranch label + -> text "br label %" <> ppr label + + IBranchIf cond labelTrue labelFalse + -> hsep [ text "br" + , ppr cond, comma + , ppr labelTrue, comma + , ppr labelFalse ] + + ISwitch x1 lDefault alts + -> text "switch" + <+> ppr x1 <> comma + <+> text "label %" <> ppr lDefault + <+> lbracket + <+> (hsep [ ppr discrim + <> comma + <> text "label %" <> ppr dest + | (discrim, dest) <- alts ]) + <+> rbracket + + IUnreachable + -> text "unreachable" + + -- Memory Operations ------------------------------ + ILoad vDst x1 + -> padVar vDst + <+> equals + <+> text "load" + <+> ppr x1 + + IStore xDst xSrc + -> text "store" + <+> ppr xSrc <> comma + <+> ppr xDst + + -- Binary Operations ------------------------------ + IOp vDst op x1 x2 + -> padVar vDst + <+> equals + <+> ppr op <+> ppr (typeOfExp x1) + <+> pprPlainX x1 <> comma + <+> pprPlainX x2 + + -- Conversion operations -------------------------- + IConv vDst conv xSrc + -> padVar vDst + <+> equals + <+> ppr conv + <+> ppr xSrc + <+> text "to" + <+> ppr (typeOfVar vDst) + + -- Other operations ------------------------------- + IICmp vDst icond x1 x2 + -> padVar vDst + <+> equals + <+> text "icmp" <+> ppr icond <+> ppr (typeOfExp x1) + <+> pprPlainX x1 <> comma + <+> pprPlainX x2 + + IFCmp vDst fcond x1 x2 + -> padVar vDst + <+> equals + <+> text "fcmp" <+> ppr fcond <+> ppr (typeOfExp x1) + <+> pprPlainX x1 <> comma + <+> pprPlainX x2 + + ICall mdst callType callConv tResult name xsArgs attrs + -> let call' + = case callType of + CallTypeTail -> text "tail call" + _ -> text "call" + dst' + = case mdst of + Nothing -> empty + Just dst -> fill 12 (ppr $ nameOfVar dst) <+> equals <> space + + in dst' + <> hsep [ call' + , case callConv of + Nothing -> empty + Just cc -> ppr cc + , ppr tResult + , ppr name + , encloseSep lparen rparen (comma <> space) (map ppr xsArgs) + , hsep $ map ppr attrs ] + diff --git a/DDC/Llvm/Pretty/Metadata.hs b/DDC/Llvm/Pretty/Metadata.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Metadata.hs @@ -0,0 +1,47 @@ + +module DDC.Llvm.Pretty.Metadata where +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Pretty.Type () +import DDC.Base.Pretty + + +instance Pretty Metadata where + ppr mt + = case mt of + Tbaa (MDNode ops) + -> text "!" <> encloseSep lbrace rbrace + (comma <> space) (map ppr ops) + + Debug + -> text "DEBUGMD" + + +instance Pretty MDecl where + ppr (MDecl ref m) = ppr ref + <> space <> equals <> space + <> text "metadata" <> space + <> ppr m + +instance Pretty (MRef) where + ppr (MRef i) = text ("!" ++ show i) + + +instance Pretty MDString where + ppr (MDString s) = text "!" <> (dquotes $ text s) + + +instance Pretty MDNode where + ppr (MDNode ns) = text "!" <> braces (ppr ns) + + +instance Pretty MDNodeOp where + ppr elt + = case elt of + OpNull -> text "null" + OpMDString ms -> text "metadata" <> space <> ppr ms + OpMDNode ns -> text "metadata" <> space <> ppr ns + OpMDRef r -> text "metadata" <> space <> ppr r + OpBool b -> text "i32" <> space <> text (if b then "1" else "0") + OpType t -> ppr t + + diff --git a/DDC/Llvm/Pretty/Module.hs b/DDC/Llvm/Pretty/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Module.hs @@ -0,0 +1,80 @@ + +module DDC.Llvm.Pretty.Module where +import DDC.Llvm.Syntax.Module +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Type +import DDC.Llvm.Pretty.Function +import DDC.Llvm.Pretty.Exp () +import DDC.Base.Pretty + + +-- | Print out a whole LLVM module. +instance Pretty Module where + ppr (Module _comments aliases globals decls funcs mdecls) + = (vcat $ map ppr aliases) + <$$> (vcat $ map ppr globals) + <$$> (vcat $ map (\decl -> text "declare" + <+> pprFunctionHeader decl Nothing) decls) + <$$> empty + <$$> (vcat $ punctuate line + $ map ppr funcs) + <$$> line + <$$> empty + <$$> (vcat $ map ppr mdecls) + <$$> empty + + +instance Pretty Global where + ppr gg + = case gg of + GlobalStatic (Var name _) static + -> ppr name <+> text "= global" <+> ppr static + + GlobalExternal (Var name t) + -> ppr name <+> text "= external global " <+> ppr t + + +instance Pretty Static where + ppr ss + = case ss of + StaticComment s + -> text "; " <> text s + + StaticLit l + -> ppr l + + StaticUninitType t + -> ppr t <> text " undef" + + StaticStr s t + -> ppr t <> text " c\"" <> text s <> text "\\00\"" + + StaticArray d t + -> ppr t <> text " [" <> hcat (punctuate comma $ map ppr d) <> text "]" + + StaticStruct d t + -> ppr t <> text "<{" <> hcat (punctuate comma $ map ppr d) <> text "}>" + + StaticPointer (Var n t) + -> ppr t <> text "*" <+> ppr n + + StaticBitc v t + -> ppr t <> text " bitcast" <+> parens (ppr v <> text " to " <> ppr t) + + StaticPtoI v t + -> ppr t <> text " ptrtoint" <+> parens (ppr v <> text " to " <> ppr t) + + StaticAdd s1 s2 + -> let ty1 = typeOfStatic s1 + op = if isFloat ty1 then text " fadd (" else text " add (" + in if ty1 == typeOfStatic s2 + then ppr ty1 <> op <> ppr s1 <> comma <> ppr s2 <> text ")" + else error $ "ddc-core-llvm: LMAdd with different types!" + + StaticSub s1 s2 + -> let ty1 = typeOfStatic s1 + op = if isFloat ty1 then text " fsub (" else text " sub (" + in if ty1 == typeOfStatic s2 + then ppr ty1 <> op <> ppr s1 <> comma <> ppr s2 <> text ")" + else error $ "ddc-core-llvm: LMSub with different types!" + diff --git a/DDC/Llvm/Pretty/Prim.hs b/DDC/Llvm/Pretty/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Prim.hs @@ -0,0 +1,85 @@ + +module DDC.Llvm.Pretty.Prim where +import DDC.Llvm.Syntax.Prim +import DDC.Base.Pretty + +instance Pretty Op where + ppr op + = case op of + OpAdd -> text "add" + OpSub -> text "sub" + OpMul -> text "mul" + OpUDiv -> text "udiv" + OpSDiv -> text "sdiv" + OpURem -> text "urem" + OpSRem -> text "srem" + OpFAdd -> text "fadd" + OpFSub -> text "fsub" + OpFMul -> text "fmul" + OpFDiv -> text "fdiv" + OpFRem -> text "frem" + OpShl -> text "shl" + OpLShr -> text "lshr" + OpAShr -> text "ashr" + OpAnd -> text "and" + OpOr -> text "or" + OpXor -> text "xor" + + +instance Pretty ICond where + ppr pp + = case pp of + ICondEq -> text "eq" + ICondNe -> text "ne" + ICondUgt -> text "ugt" + ICondUge -> text "uge" + ICondUlt -> text "ult" + ICondUle -> text "ule" + ICondSgt -> text "sgt" + ICondSge -> text "sge" + ICondSlt -> text "slt" + ICondSle -> text "sle" + + +instance Pretty FCond where + ppr pp + = case pp of + FCondFalse -> text "false" + FCondOeq -> text "oeq" + FCondOgt -> text "ogt" + FCondOge -> text "oge" + FCondOlt -> text "olt" + FCondOle -> text "ole" + FCondOne -> text "one" + FCondOrd -> text "ord" + FCondUeq -> text "ueq" + FCondUgt -> text "ugt" + FCondUge -> text "uge" + FCondUlt -> text "ult" + FCondUle -> text "ule" + FCondUne -> text "une" + FCondUno -> text "uno" + FCondTrue -> text "true" + + +instance Pretty Conv where + ppr pp + = case pp of + ConvTrunc -> text "trunc" + ConvZext -> text "zext" + ConvSext -> text "sext" + ConvFptrunc -> text "fptrunc" + ConvFpext -> text "fpext" + ConvFptoui -> text "fptoui" + ConvFptosi -> text "fptosi" + ConvUintofp -> text "uintofp" + ConvSintofp -> text "sintofp" + ConvPtrtoint -> text "ptrtoint" + ConvInttoptr -> text "inttoptr" + ConvBitcast -> text "bitcast" + + + + + + diff --git a/DDC/Llvm/Pretty/Type.hs b/DDC/Llvm/Pretty/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Pretty/Type.hs @@ -0,0 +1,73 @@ + +module DDC.Llvm.Pretty.Type where +import DDC.Llvm.Syntax.Type +import DDC.Llvm.Pretty.Attr () +import DDC.Base.Pretty + + +instance Pretty Param where + -- By default we don't print the attrs. + ppr (Param t _attrs) + = ppr t + + +instance Pretty FunctionDecl where + ppr (FunctionDecl n l c r varg params a) + = let varg' = case varg of + VarArgs | null params -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + + align' = case a of + AlignNone -> empty + AlignBytes a' -> text " align " <+> ppr a' + + args' = hcat $ punctuate comma $ map ppr params + + in ppr l <+> ppr c + <+> ppr r + <+> text " @" + <> ppr n <> brackets (args' <> varg') + <> align' + + +instance Pretty TypeAlias where + ppr (TypeAlias name ty) + = text "%" <> text name <+> equals <+> text "type" <+> ppr ty + + +instance Pretty Type where + ppr lt + = case lt of + TVoid -> text "void" + TInt size -> text "i" <> integer size + TFloat -> text "float" + TDouble -> text "double" + TFloat80 -> text "x86_fp80" + TFloat128 -> text "fp128" + TLabel -> text "label" + TPointer x -> ppr x <> text "*" + + TStruct tys + -> text "<{" <> (hcat $ punctuate comma (map ppr tys)) <> text "}>" + + TArray nr tp + -> brackets (integer nr <> text " x " <> ppr tp) + + TAlias (TypeAlias s _) + -> text "%" <> text s + + TFunction (FunctionDecl _ _ _ r varg params _) + -> let varg' = case varg of + VarArgs | null params -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + + -- by default we don't print param attributes + args = hcat $ punctuate comma $ map ppr params + + in ppr r <> brackets (args <> varg') + + + + diff --git a/DDC/Llvm/Syntax.hs b/DDC/Llvm/Syntax.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax.hs @@ -0,0 +1,94 @@ + +module DDC.Llvm.Syntax + ( -- * Modules + Module (..) + , lookupCallConv + + -- * Global variables + , Global (..) + , typeOfGlobal + , varOfGlobal + + -- * Static data + , Static (..) + , typeOfStatic + + -- * Function declarations + , FunctionDecl (..) + , ParamListType (..) + , Param (..) + , Align (..) + + -- * Functions + , Function (..) + , Section (..) + + -- * Blocks + , Block (..) + , defVarsOfBlock + + -- * Block labels + , Label (..) + + -- * Annotated Instructions + , AnnotInstr (..) + , annotNil + , annotWith + + -- * Instructions + , Instr (..) + , branchTargetsOfInstr + , defVarOfInstr + + -- * Metadata + , Metadata (..) + , MDecl (..) + , MRef (..) + , rval + , tbaaNode + + -- * Expression types + , Type (..) + , TypeAlias (..) + , isInt + , isFloat + , isPointer + , takeBytesOfType + + -- * Expressions + , Exp (..) + , typeOfExp + + -- * Variables + , Var (..) + , nameOfVar + , typeOfVar + + -- * Names + , Name (..) + + -- * Literals + , Lit (..) + , typeOfLit + + -- * Primitive operators + , Op (..) + , ICond (..) + , FCond (..) + , Conv (..) + + -- * Attributes + , FuncAttr (..) + , ParamAttr (..) + , CallConv (..) + , CallType (..) + , Linkage (..)) +where +import DDC.Llvm.Syntax.Attr +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Function +import DDC.Llvm.Syntax.Instr +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Syntax.Module +import DDC.Llvm.Syntax.Prim +import DDC.Llvm.Syntax.Type diff --git a/DDC/Llvm/Syntax/Attr.hs b/DDC/Llvm/Syntax/Attr.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Attr.hs @@ -0,0 +1,234 @@ + +module DDC.Llvm.Syntax.Attr + ( FuncAttr (..) + , ParamAttr (..) + , CallConv (..) + , Linkage (..) + , CallType (..)) +where + + +-- FuncAttr --------------------------------------------------------------------------------------- +-- | Function attributes are set to communicate additional information about a +-- function. Function attributes are considered to be part of the function, +-- not of the function type, so functions with different parameter attributes +-- can have the same function type. Functions can have multiple attributes. +-- +-- Descriptions taken from +data FuncAttr + -- | The inliner should attempt to inline this function into callers + -- whenever possible, ignoring any active inlining size threshold for + -- this caller. + = AlwaysInline + + -- | The source code contained a hint that inlining this function is + -- desirable (such as the \"inline\" keyword in C/C++). + -- It is just a hint; it imposes no requirements on the inliner. + | InlineHint + + -- | The inliner should never inline this function in any situation. + -- This attribute may not be used together with the alwaysinline attribute. + | NoInline + + -- | Suggests that optimization passes and code generator passes make choices + -- that keep the code size of this function low, and otherwise do + -- optimizations specifically to reduce code size. + | OptSize + + -- | The function never returns normally. + -- This produces undefined behavior at runtime if the function ever does + -- dynamically return. + | NoReturn + + -- | The function never returns with an unwind or exceptional control flow. + -- If the function does unwind, its runtime behavior is undefined. + | NoUnwind + + -- | The function computes its result (or decides to unwind an exception) + -- based strictly on its arguments, without + -- dereferencing any pointer arguments or otherwise accessing any mutable + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It does not write through any pointer arguments (including byval + -- arguments) and never changes any state visible to callers. This means + -- that it cannot unwind exceptions by calling the C++ exception throwing + -- methods, but could use the unwind instruction. + | ReadNone + + -- | The function does not write through any + -- pointer arguments (including byval arguments) or otherwise modify any + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It may dereference pointer arguments and read state that may be set in + -- the caller. A readonly function always returns the same value (or unwinds + -- an exception identically) when called with the same set of arguments and + -- global state. It cannot unwind an exception by calling the C++ exception + -- throwing methods, but may use the unwind instruction. + | ReadOnly + + -- | The function should emit a stack smashing protector. + -- It is in the form of a \"canary\"—a random value placed on the + -- stack before the local variables that's checked upon return from the + -- function to see if it has been overwritten. A heuristic is used to + -- determine if a function needs stack protectors or not. + -- If a function that has an ssp attribute is inlined into a function that + -- doesn't have an ssp attribute, then the resulting function will have an + -- ssp attribute. + | Ssp + + -- | The function should always emit a stack smashing protector. + -- This overrides the ssp function attribute. + -- If a function that has an sspreq attribute is inlined into a function + -- that doesn't have an sspreq attribute or which has an ssp attribute, + -- then the resulting function will have an sspreq attribute. + | SspReq + + -- | The code generator should not use a red zone, even if the + -- target-specific ABI normally permits it. + | NoRedZone + + -- | Disables implicit floating point instructions. + | NoImplicitFloat + + -- | Disables prologue / epilogue emission for the function. + -- This can have very system-specific consequences. + | Naked + deriving (Eq, Show) + + +-- ParamAttr -------------------------------------------------------------------------------------- +-- | Parameter attributes are used to communicate additional information about +-- the result or parameters of a function +data ParamAttr + -- | That the parameter or return value should be zero-extended to a 32-bit value + -- by the caller (for a parameter) or the callee (for a return value). + = ZeroExt + + -- | The parameter or return value should be sign-extended to a 32-bit value + -- by the caller (for a parameter) or the callee (for a return value). + | SignExt + + -- | The parameter or return value should be treated in a special target-dependent + -- fashion during while emitting code for a function call or return (usually, + -- by putting it in a register as opposed to memory). + | InReg + + -- | The pointer parameter should really be passed by value to the function. + | ByVal + + -- | The pointer parameter specifies the address of a structure that is the + -- return value of the function in the source program. + | SRet + + -- | The pointer does not alias any global or any other parameter. + | NoAlias + + -- | The callee does not make any copies of the pointer that outlive the callee itself. + | NoCapture + + -- | The pointer parameter can be excised using the trampoline intrinsics. + | Nest + deriving (Eq, Show) + + +-- CallConvention --------------------------------------------------------------------------------- +-- | Different calling conventions a function can use. +data CallConv + -- | The C calling convention. + -- This calling convention (the default if no other calling convention is + -- specified) matches the target C calling conventions. This calling + -- convention supports varargs function calls and tolerates some mismatch in + -- the declared prototype and implemented declaration of the function (as + -- does normal C). + = CC_Ccc + + -- | This calling convention attempts to make calls as fast as possible + -- (e.g. by passing things in registers). This calling convention allows + -- the target to use whatever tricks it wants to produce fast code for the + -- target, without having to conform to an externally specified ABI + -- (Application Binary Interface). Implementations of this convention should + -- allow arbitrary tail call optimization to be supported. This calling + -- convention does not support varargs and requires the prototype of al + -- callees to exactly match the prototype of the function definition. + | CC_Fastcc + + -- | This calling convention attempts to make code in the caller as efficient + -- as possible under the assumption that the call is not commonly executed. + -- As such, these calls often preserve all registers so that the call does + -- not break any live ranges in the caller side. This calling convention + -- does not support varargs and requires the prototype of all callees to + -- exactly match the prototype of the function definition. + | CC_Coldcc + + -- | Any calling convention may be specified by number, allowing + -- target-specific calling conventions to be used. Target specific calling + -- conventions start at 64. + | CC_Ncc Int + + -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it + -- rather than just using CC_Ncc. + | CC_X86_Stdcc + deriving (Eq, Show) + + +-- LlvmLinkageType -------------------------------------------------------------------------------- +-- | Linkage type of a symbol. +-- +-- The description of the constructors is copied from the Llvm Assembly Language +-- Reference Manual , because +-- they correspond to the Llvm linkage types. +data Linkage + -- | Global values with internal linkage are only directly accessible by + -- objects in the current module. In particular, linking code into a module + -- with an internal global value may cause the internal to be renamed as + -- necessary to avoid collisions. Because the symbol is internal to the + -- module, all references can be updated. This corresponds to the notion + -- of the @static@ keyword in C. + = Internal + + -- | Globals with @linkonce@ linkage are merged with other globals of the + -- same name when linkage occurs. This is typically used to implement + -- inline functions, templates, or other code which must be generated + -- in each translation unit that uses it. Unreferenced linkonce globals are + -- allowed to be discarded. + | LinkOnce + + -- | @weak@ linkage is exactly the same as linkonce linkage, except that + -- unreferenced weak globals may not be discarded. This is used for globals + -- that may be emitted in multiple translation units, but that are not + -- guaranteed to be emitted into every translation unit that uses them. One + -- example of this are common globals in C, such as @int X;@ at global + -- scope. + | Weak + + -- | @appending@ linkage may only be applied to global variables of pointer + -- to array type. When two global variables with appending linkage are + -- linked together, the two global arrays are appended together. This is + -- the Llvm, typesafe, equivalent of having the system linker append + -- together @sections@ with identical names when .o files are linked. + | Appending + + -- | The semantics of this linkage follow the ELF model: the symbol is weak + -- until linked, if not linked, the symbol becomes null instead of being an + -- undefined reference. + | ExternWeak + + -- | The symbol participates in linkage and can be used to resolve external + -- symbol references. + | ExternallyVisible + + -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM + -- assembly. + | External + deriving (Eq, Show) + + +-- CallType ------------------------------------------------------------------- +-- | Different ways to call a function. +data CallType + -- | Normal call, allocate a new stack frame. + = CallTypeStd + + -- | Tail call, perform the call in the current stack frame. + | CallTypeTail + deriving (Eq, Show) + + diff --git a/DDC/Llvm/Syntax/Exp.hs b/DDC/Llvm/Syntax/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Exp.hs @@ -0,0 +1,99 @@ + +module DDC.Llvm.Syntax.Exp + ( -- * Expressions + Exp (..) + , typeOfExp + + -- * Variables + , Var (..) + , nameOfVar + , typeOfVar + + -- * Names + , Name (..) + + -- * Literals + , Lit (..) + , typeOfLit) +where +import DDC.Llvm.Syntax.Type + + +-- Exp ------------------------------------------------------------------------ +data Exp + -- | Use of a variable. + = XVar Var + + -- | A literal. + | XLit Lit + + -- | An undefined value. + | XUndef Type + deriving (Eq, Show) + + +-- | Take the type of an expression. +typeOfExp :: Exp -> Type +typeOfExp xx + = case xx of + XVar var -> typeOfVar var + XLit lit -> typeOfLit lit + XUndef t -> t + + +-- Var ------------------------------------------------------------------------ +-- | A variable that can be assigned to. +data Var + = Var Name Type + deriving (Eq, Show) + + +-- | Yield the name of a var. +nameOfVar :: Var -> Name +nameOfVar (Var n _) = n + + +-- | Yield the type of a var. +typeOfVar :: Var -> Type +typeOfVar (Var _ t) = t + + +instance Ord Var where + compare (Var n1 _) (Var n2 _) + = compare n1 n2 + + +-- Name ----------------------------------------------------------------------- +-- | Names of variables. +data Name + = NameGlobal String + | NameLocal String + deriving (Show, Eq, Ord) + + +-- Lit ------------------------------------------------------------------------ +-- | Literal data. +data Lit + -- | An integer literal + = LitInt Type Integer + + -- | A floating-point literal. + | LitFloat Type Double + + -- | A null pointer literal. + -- Only applicable to pointer types + | LitNull Type + + -- | A completely undefined value. + | LitUndef Type + deriving (Eq, Show) + + +-- | Yield the `Type` of a `Lit`. +typeOfLit :: Lit -> Type +typeOfLit ll + = case ll of + LitInt t _ -> t + LitFloat t _ -> t + LitNull t -> t + LitUndef t -> t diff --git a/DDC/Llvm/Syntax/Function.hs b/DDC/Llvm/Syntax/Function.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Function.hs @@ -0,0 +1,39 @@ + +module DDC.Llvm.Syntax.Function + ( Section (..) + , Function (..)) +where +import DDC.Llvm.Syntax.Instr +import DDC.Llvm.Syntax.Type +import DDC.Llvm.Syntax.Attr + + +-- | A LLVM Function +data Function + = Function + { -- | The signature of this declared function. + funDecl :: FunctionDecl + + -- | The function parameter names. + , funParams :: [String] + + -- | The function attributes. + , funAttrs :: [FuncAttr] + + -- | The section to put the function into, + , funSection :: Section + + -- | The body of the functions. + , funBlocks :: [Block] + } + + +-- | The section name to put the function in. +data Section + -- | Let the LLVM decide what section to put this in. + = SectionAuto + + -- | Put it in this specific section. + | SectionSpecific String + deriving (Eq, Show) + diff --git a/DDC/Llvm/Syntax/Instr.hs b/DDC/Llvm/Syntax/Instr.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Instr.hs @@ -0,0 +1,186 @@ + +module DDC.Llvm.Syntax.Instr + ( -- * Blocks + Block (..) + , Label (..) + + -- * Annotated instructions + , AnnotInstr (..) + , annotNil + , annotWith + + -- * Instructions + , Instr (..) + , branchTargetsOfInstr + , defVarOfInstr + , defVarsOfBlock) +where +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Prim +import DDC.Llvm.Syntax.Attr +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Syntax.Type +import Data.Maybe +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Foldable as Seq + + +-- Block ---------------------------------------------------------------------- +-- | Block labels. +data Label + = Label String + deriving (Eq, Ord, Show) + + +-- | A block of LLVM code with an optional annotation. +data Block + = Block + { -- | The code label for this block + blockLabel :: Label + + -- | A list of LlvmStatement's representing the code for this block. + -- This list must end with a control flow statement. + , blockInstrs :: Seq AnnotInstr + } + + +-- Instructions --------------------------------------------------------------- +-- | Instructions annotated with metadata. +data AnnotInstr + = AnnotInstr + { annotInstr :: Instr + , annotMDecl :: [MDecl] } + deriving Show + + +-- | Construct an annotated instruction with no annotations. +annotNil :: Instr -> AnnotInstr +annotNil ins = AnnotInstr ins [] + + +-- | Annotate an instruction with some metadata. +annotWith :: Instr -> [MDecl] -> AnnotInstr +annotWith ins mds = AnnotInstr ins mds + + +------------------------------------------------------------------------------- +-- | Instructions +data Instr + -- | Comment meta-instruction. + = IComment [String] + + -- | Set meta instruction v1 = value. + -- This isn't accepted by the real LLVM compiler. + -- ISet instructions are erased by the 'Clean' transform. + | ISet Var Exp + + -- | No operation. + -- This isn't accepted by the real LLVM compiler. + -- INop instructions are erased by the 'Clean' transform. + | INop + + + -- Phi nodes -------------------------------------- + | IPhi Var [(Exp, Label)] + + + -- Terminator Instructions ------------------------ + -- | Return a result. + | IReturn (Maybe Exp) + + -- | Unconditional branch to the target label. + | IBranch Label + + -- | Conditional branch. + | IBranchIf Exp Label Label + + -- | Mutliway branch. + -- If scruitniee matches one of the literals in the list then jump + -- to the corresponding label, otherwise jump to the default. + | ISwitch Exp Label [(Lit, Label)] + + -- | 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 + + + -- Memory Access and Addressing ------------------- + -- | Load a value from memory. + | ILoad Var Exp + + -- | Store a value to memory. + -- 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 + + -- | Call a function. + -- Only NoReturn, NoUnwind and ReadNone attributes are valid. + | ICall (Maybe Var) CallType (Maybe CallConv) + Type Name [Exp] [FuncAttr] + deriving (Show, Eq) + + +-- | If this instruction can branch to a label then return the possible targets. +branchTargetsOfInstr :: Instr -> Maybe (Set Label) +branchTargetsOfInstr instr + = case instr of + IBranch l + -> Just $ Set.singleton l + + IBranchIf _ l1 l2 + -> Just $ Set.fromList [l1, l2] + + ISwitch _ lDef ls + -> Just $ Set.fromList (lDef : map snd ls) + + _ -> Nothing + + +-- | Get the LLVM variable that this instruction assigns to, +-- or `Nothing` if there isn't one. +defVarOfInstr :: Instr -> Maybe Var +defVarOfInstr instr + = case instr of + IComment{} -> Nothing + ISet var _ -> Just var + INop -> Nothing + IPhi var _ -> Just var + IReturn{} -> Nothing + IBranch{} -> Nothing + IBranchIf{} -> Nothing + ISwitch{} -> Nothing + IUnreachable{} -> Nothing + IOp var _ _ _ -> Just var + IConv var _ _ -> Just var + ILoad var _ -> Just var + IStore{} -> Nothing + IICmp var _ _ _ -> Just var + IFCmp var _ _ _ -> Just var + ICall mvar _ _ _ _ _ _ -> mvar + + +-- | Get the set of LLVM variables that this block defines. +defVarsOfBlock :: Block -> Set Var +defVarsOfBlock (Block _ instrs) + = Set.fromList + $ mapMaybe (defVarOfInstr . annotInstr) + $ Seq.toList instrs + diff --git a/DDC/Llvm/Syntax/Metadata.hs b/DDC/Llvm/Syntax/Metadata.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Metadata.hs @@ -0,0 +1,83 @@ + +module DDC.Llvm.Syntax.Metadata + ( Metadata (..) + , tbaaNode + , tbaaRoot + , MDecl (..) + , MRef (..) + , MDString (..) + , MDNode (..) + , MDNodeOp (..) + , rval ) +where +import DDC.Llvm.Syntax.Type + + +-- Metadata types ------------------------------------------------------------- +-- | Different types of metadata used in LLVM IR +-- e.g. 'debug', 'tbaa', 'range', etc. +data Metadata + -- Metadata used for type-based alias analysis. + = Tbaa MDNode + -- Metadata for debugging, here as an example only. + | Debug + deriving (Eq, Show) + + +-- | Maps matadata references to metadata nodes +-- e.g. !2 = !{ metadata "id", !0, !i11} +data MDecl + = MDecl MRef Metadata + deriving Show + + +data MRef + = MRef Int + deriving (Show, Eq) + + +rval :: MDecl -> Metadata +rval (MDecl _ m) = m + + +-- Metadata internal----------------------------------------------------------- +-- | Primitive types of LLVM metadata +data MDString + = MDString String + deriving (Eq, Show) + + +data MDNode + = MDNode [MDNodeOp] + deriving (Eq, Show) + + +-- Operands to metadata nodes +-- Note: no type parameter to avoid using existentials +data MDNodeOp = OpNull + | OpMDString MDString + | OpMDNode MDNode + | OpMDRef MRef + | OpBool Bool + | OpType Type + deriving (Eq, Show) + + +-- TBAA metadata -------------------------------------------------------------- +-- | Construct a single tbaa node +tbaaNode + :: String -- ^ A unique identifier for the node + -> MRef -- ^ The parent node + -> Bool -- ^ Whether this node represents a const region + -> Metadata +tbaaNode n pr c + = Tbaa $ MDNode [ OpMDString (MDString n) + , OpMDRef pr + , OpBool c ] + +tbaaRoot :: String -> Metadata +tbaaRoot n + = Tbaa $ MDNode [ OpMDString (MDString n) + , OpNull + , OpBool True ] + diff --git a/DDC/Llvm/Syntax/Module.hs b/DDC/Llvm/Syntax/Module.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Module.hs @@ -0,0 +1,137 @@ + +module DDC.Llvm.Syntax.Module + ( -- * Modules + Module (..) + , lookupCallConv + + , Global (..) + , typeOfGlobal + , varOfGlobal + + -- * Static data. + , Static (..) + , typeOfStatic) +where +import DDC.Llvm.Syntax.Function +import DDC.Llvm.Syntax.Exp +import DDC.Llvm.Syntax.Metadata +import DDC.Llvm.Syntax.Type +import DDC.Llvm.Syntax.Attr +import Data.List +import Control.Monad + + +-- Module --------------------------------------------------------------------- +-- | This is a top level container in LLVM. +data Module + = Module + { -- | Comments to include at the start of the module. + modComments :: [String] + + -- | Alias type definitions. + , modAliases :: [TypeAlias] + + -- | Global variables to include in the module. + , modGlobals :: [Global] + + -- | Functions used in this module but defined in other modules. + , modFwdDecls :: [FunctionDecl] + + -- | Functions defined in this module. + , modFuncs :: [Function] + + -- | Metdata for alias analysis + , modMDecls :: [MDecl] + } + + +-- | Lookup the calling convention for this function, +-- using the forward declarations as well as the function definitions. +lookupCallConv :: String -> Module -> Maybe CallConv +lookupCallConv name mm + = liftM declCallConv + $ find isFunctionDecl $ modFwdDecls mm ++ (map funDecl $ modFuncs mm) + where isFunctionDecl decl + = declName decl == name + + +-- Global --------------------------------------------------------------------- +-- | A global mutable variable. Maybe defined or external +data Global + = GlobalStatic Var Static + | GlobalExternal Var + + +-- | Return the 'LlvmType' of the 'LMGlobal' +typeOfGlobal :: Global -> Type +typeOfGlobal gg + = case gg of + GlobalStatic v _ -> typeOfVar v + GlobalExternal v -> typeOfVar v + + +-- | Return the 'LlvmVar' part of a 'LMGlobal' +varOfGlobal :: Global -> Var +varOfGlobal gg + = case gg of + GlobalStatic v _ -> v + GlobalExternal v -> v + + +-- Static --------------------------------------------------------------------- +-- | Llvm Static Data. +-- These represent the possible global level variables and constants. +data Static + -- | A comment in a static section. + = StaticComment String + + -- | A static variant of a literal value. + | StaticLit Lit + + -- | For uninitialised data. + | StaticUninitType Type + + -- | Defines a static 'LMString'. + | StaticStr String Type + + -- | A static array. + | StaticArray [Static] Type + + -- | A static structure type. + | StaticStruct [Static] Type + + -- | A pointer to other data. + | StaticPointer Var + + -- Static expressions. + -- | Pointer to Pointer conversion. + | StaticBitc Static Type + + -- | Pointer to Integer conversion. + | StaticPtoI Static Type + + -- | Constant addition operation. + | StaticAdd Static Static + + -- | Constant subtraction operation. + | StaticSub Static Static + deriving (Show) + + +-- | Return the 'LlvmType' of the 'LlvmStatic'. +typeOfStatic :: Static -> Type +typeOfStatic ss + = case ss of + StaticComment{} -> error "Can't call getStatType on LMComment!" + StaticLit l -> typeOfLit l + StaticUninitType t -> t + StaticStr _ t -> t + StaticArray _ t -> t + StaticStruct _ t -> t + StaticPointer v -> typeOfVar v + StaticBitc _ t -> t + StaticPtoI _ t -> t + StaticAdd t _ -> typeOfStatic t + StaticSub t _ -> typeOfStatic t + + diff --git a/DDC/Llvm/Syntax/Prim.hs b/DDC/Llvm/Syntax/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Prim.hs @@ -0,0 +1,89 @@ + +module DDC.Llvm.Syntax.Prim + ( Op (..) + , ICond (..) + , FCond (..) + , Conv (..)) +where + + +-- | Binary arithmetic operators. +data Op + = OpAdd -- ^ add two integers, floating point or vector values. + | OpSub -- ^ subtract two ... + | OpMul -- ^ multiply .. + | OpUDiv -- ^ unsigned integer or vector division. + | OpSDiv -- ^ signed integer .. + | OpURem -- ^ unsigned integer or vector remainder + | OpSRem -- ^ signed ... + + | OpFAdd -- ^ add two floating point or vector values. + | OpFSub -- ^ subtract two ... + | OpFMul -- ^ multiply ... + | OpFDiv -- ^ divide ... + | OpFRem -- ^ remainder ... + + | OpShl -- ^ Left shift. + | OpLShr -- ^ Logical shift right + | OpAShr -- ^ Arithmetic shift right. + -- The most significant bits of the result will be equal to the + -- sign bit of the left operand. + + | OpAnd -- ^ AND bitwise logical operation. + | OpOr -- ^ OR bitwise logical operation. + | OpXor -- ^ XOR bitwise logical operation. + deriving (Eq, Show) + + +-- | Integer comparison. +data ICond + = ICondEq -- ^ Equal (Signed and Unsigned) + | ICondNe -- ^ Not equal (Signed and Unsigned) + | ICondUgt -- ^ Unsigned greater than + | ICondUge -- ^ Unsigned greater than or equal + | ICondUlt -- ^ Unsigned less than + | ICondUle -- ^ Unsigned less than or equal + | ICondSgt -- ^ Signed greater than + | ICondSge -- ^ Signed greater than or equal + | ICondSlt -- ^ Signed less than + | ICondSle -- ^ Signed less than or equal + deriving (Eq, Show) + + +-- | Floating point comparison. +data FCond + = FCondFalse -- ^ Always yields false, regardless of operands. + | FCondOeq -- ^ Both operands are not a QNAN and op1 is equal to op2. + | FCondOgt -- ^ Both operands are not a QNAN and op1 is greater than op2. + | FCondOge -- ^ Both operands are not a QNAN and op1 is greater than or equal to op2. + | FCondOlt -- ^ Both operands are not a QNAN and op1 is less than op2. + | FCondOle -- ^ Both operands are not a QNAN and op1 is less than or equal to op2. + | FCondOne -- ^ Both operands are not a QNAN and op1 is not equal to op2. + | FCondOrd -- ^ Both operands are not a QNAN. + | FCondUeq -- ^ Either operand is a QNAN or op1 is equal to op2. + | FCondUgt -- ^ Either operand is a QNAN or op1 is greater than op2. + | FCondUge -- ^ Either operand is a QNAN or op1 is greater than or equal to op2. + | FCondUlt -- ^ Either operand is a QNAN or op1 is less than op2. + | FCondUle -- ^ Either operand is a QNAN or op1 is less than or equal to op2. + | FCondUne -- ^ Either operand is a QNAN or op1 is not equal to op2. + | FCondUno -- ^ Either operand is a QNAN. + | FCondTrue -- ^ Always yields true, regardless of operands. + deriving (Eq, Show) + + +-- | Conversion Operations +data Conv + = ConvTrunc -- ^ Integer truncate + | ConvZext -- ^ Integer extend (zero fill) + | ConvSext -- ^ Integer extend (sign fill) + | ConvFptrunc -- ^ Float truncate + | ConvFpext -- ^ Float extend + | ConvFptoui -- ^ Float to unsigned Integer + | ConvFptosi -- ^ Float to signed Integer + | ConvUintofp -- ^ Unsigned Integer to Float + | ConvSintofp -- ^ Signed Int to Float + | ConvPtrtoint -- ^ Pointer to Integer + | ConvInttoptr -- ^ Integer to Pointer + | ConvBitcast -- ^ Cast between types where no bit manipulation is needed + deriving (Eq, Show) + diff --git a/DDC/Llvm/Syntax/Type.hs b/DDC/Llvm/Syntax/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Syntax/Type.hs @@ -0,0 +1,167 @@ + +module DDC.Llvm.Syntax.Type + ( -- * Function Declarations. + FunctionDecl (..) + , ParamListType (..) + , Param (..) + , Align (..) + + -- * Types + , Type (..) + , TypeAlias (..) + + , isInt + , isFloat + , isPointer + , takeBytesOfType) +where +import DDC.Llvm.Syntax.Attr +import Control.Monad + + +-- | An LLVM Function +data FunctionDecl + = FunctionDecl + { -- | Unique identifier of the function + declName :: String + + -- | LinkageType of the function + , declLinkage :: Linkage + + -- | The calling convention of the function + , declCallConv :: CallConv + + -- | Type of the returned value + , declReturnType :: Type + + -- | Indicates if this function uses varargs + , declParamListType :: ParamListType + + -- | Parameter types and attributes + , declParams :: [Param] + + -- | Function align value, must be power of 2 + , declAlign :: Align } + deriving (Eq, Show) + + +-- | Functions can have a fixed amount of parameters, or a variable amount. +data ParamListType + = FixedArgs -- ^ Fixed amount of arguments. + | VarArgs -- ^ Variable amount of arguments. + deriving (Eq,Show) + + +-- | Describes a function parameter. +data Param + = Param + { paramType :: Type + , paramAttrs :: [ParamAttr] } + deriving (Show, Eq) + + +-- | Alignment. +data Align + = AlignNone + | AlignBytes Integer + deriving (Show, Eq) + + +-- | A type alias. +data TypeAlias + = TypeAlias String Type + deriving (Eq, Show) + + +-- | Llvm Types. +data Type + -- | Void type + = TVoid + + -- | An integer with a given width in bits. + | TInt Integer + + -- | 32-bit floating point + | TFloat + + -- | 64-bit floating point + | TDouble + + -- | 80 bit (x86 only) floating point + | TFloat80 + + -- | 128 bit floating point + | TFloat128 + + -- | A block label. + | TLabel + + -- | A pointer to another type of thing. + | TPointer Type + + -- | An array of things. + | TArray Integer Type + + -- | A structure type. + | TStruct [Type] + + -- | A type alias. + | TAlias TypeAlias + + -- | Function type, used to create pointers to functions. + | TFunction FunctionDecl + deriving (Eq, Show) + + +-- | Test if the given 'LlvmType' is an integer +isInt :: Type -> Bool +isInt tt + = case tt of + TInt _ -> True + _ -> False + + +-- | Test if the given 'LlvmType' is a floating point type +isFloat :: Type -> Bool +isFloat tt + = case tt of + TFloat -> True + TDouble -> True + TFloat80 -> True + TFloat128 -> True + _ -> False + + +-- | Test if the given 'LlvmType' is an 'LMPointer' construct +isPointer :: Type -> Bool +isPointer tt + = case tt of + TPointer _ -> True + _ -> False + + +-- | Calculate the size in bytes of a Type, given the size of pointers. +takeBytesOfType :: Integer -> Type -> Maybe Integer +takeBytesOfType bytesPtr tt + = case tt of + TInt bits -> Just $ fromIntegral $ div bits 8 + TFloat -> Just 4 + TDouble -> Just 8 + TFloat80 -> Just 10 + TFloat128 -> Just 16 + TPointer{} -> Just bytesPtr + + TArray n t + | Just s <- takeBytesOfType bytesPtr t + -> Just (n * s) + + TLabel{} -> Nothing + TVoid{} -> Nothing + + TStruct tys + -> liftM sum $ sequence $ map (takeBytesOfType bytesPtr) tys + + TAlias (TypeAlias _ t) + -> takeBytesOfType bytesPtr t + + _ -> Nothing diff --git a/DDC/Llvm/Transform/Clean.hs b/DDC/Llvm/Transform/Clean.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Transform/Clean.hs @@ -0,0 +1,189 @@ + +-- | 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.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 + Just cc2 = 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 + Just cc2 = 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/LinkPhi.hs b/DDC/Llvm/Transform/LinkPhi.hs new file mode 100644 --- /dev/null +++ b/DDC/Llvm/Transform/LinkPhi.hs @@ -0,0 +1,88 @@ + +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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +The Disciplined Disciple Compiler License (MIT style) + +Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +All rights reversed. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +------------------------------------------------------------------------------- +Under Australian law copyright is free and automatic. +By contributing to DDC authors grant all rights they have regarding their +contributions to the other members of the Disciplined Disciple Compiler Strike +Force, past, present and future, as well as placing their contributions under +the above license. + +Use "darcs show authors" to get a list of Strike Force members. + +-------------------------------------------------------------------------------- +Redistributions of libraries in ./external are governed by their own licenses: + + - TinyPTC GNU Lesser General Public License + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ddc-core-llvm.cabal b/ddc-core-llvm.cabal new file mode 100644 --- /dev/null +++ b/ddc-core-llvm.cabal @@ -0,0 +1,85 @@ +Name: ddc-core-llvm +Version: 0.3.1.1 +License: MIT +License-file: LICENSE +Author: The Disciplined Disciple Compiler Strike Force +Maintainer: Ben Lippmeier +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: experimental +Category: Compilers/Interpreters +Homepage: http://disciple.ouroborus.net +Bug-reports: disciple@ouroborus.net +Synopsis: Disciplined Disciple Compiler LLVM code generator. +Description: Disciplined Disciple Compiler LLVM code generator. + +Library + Build-Depends: + base == 4.6.*, + containers == 0.5.*, + array == 0.4.*, + transformers == 0.3.*, + mtl == 2.1.*, + ddc-base == 0.3.1.*, + ddc-core == 0.3.1.*, + ddc-core-simpl == 0.3.1.*, + ddc-core-salt == 0.3.1.* + + Exposed-modules: + DDC.Core.Llvm.Metadata.Graph + DDC.Core.Llvm.Metadata.Tbaa + DDC.Core.Llvm.Convert + + DDC.Llvm.Analysis.Children + DDC.Llvm.Analysis.Parents + + DDC.Llvm.Transform.Clean + DDC.Llvm.Transform.LinkPhi + + 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.Prim + DDC.Core.Llvm.Convert.Type + DDC.Core.Llvm.LlvmM + + DDC.Llvm.Pretty.Attr + DDC.Llvm.Pretty.Exp + DDC.Llvm.Pretty.Function + DDC.Llvm.Pretty.Instr + DDC.Llvm.Pretty.Metadata + DDC.Llvm.Pretty.Module + DDC.Llvm.Pretty.Prim + DDC.Llvm.Pretty.Type + + DDC.Llvm.Syntax.Attr + DDC.Llvm.Syntax.Exp + DDC.Llvm.Syntax.Function + DDC.Llvm.Syntax.Instr + DDC.Llvm.Syntax.Metadata + DDC.Llvm.Syntax.Module + DDC.Llvm.Syntax.Prim + DDC.Llvm.Syntax.Type + + GHC-options: + -Wall + -fno-warn-orphans + -fno-warn-missing-signatures + -fno-warn-unused-do-bind + + Extensions: + KindSignatures + NoMonomorphismRestriction + ScopedTypeVariables + StandaloneDeriving + PatternGuards + ParallelListComp + FlexibleContexts + ViewPatterns + TupleSections + +