ddc-core-llvm (empty) → 0.3.1.1
raw patch · 34 files changed
+4605/−0 lines, 34 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl, mtl, transformers
Files
- DDC/Core/Llvm/Convert.hs +730/−0
- DDC/Core/Llvm/Convert/Atom.hs +101/−0
- DDC/Core/Llvm/Convert/Erase.hs +47/−0
- DDC/Core/Llvm/Convert/Prim.hs +454/−0
- DDC/Core/Llvm/Convert/Type.hs +240/−0
- DDC/Core/Llvm/LlvmM.hs +114/−0
- DDC/Core/Llvm/Metadata/Graph.hs +253/−0
- DDC/Core/Llvm/Metadata/Tbaa.hs +239/−0
- DDC/Llvm/Analysis/Children.hs +35/−0
- DDC/Llvm/Analysis/Parents.hs +81/−0
- DDC/Llvm/Graph.hs +146/−0
- DDC/Llvm/Pretty.hs +11/−0
- DDC/Llvm/Pretty/Attr.hs +69/−0
- DDC/Llvm/Pretty/Exp.hs +58/−0
- DDC/Llvm/Pretty/Function.hs +59/−0
- DDC/Llvm/Pretty/Instr.hs +161/−0
- DDC/Llvm/Pretty/Metadata.hs +47/−0
- DDC/Llvm/Pretty/Module.hs +80/−0
- DDC/Llvm/Pretty/Prim.hs +85/−0
- DDC/Llvm/Pretty/Type.hs +73/−0
- DDC/Llvm/Syntax.hs +94/−0
- DDC/Llvm/Syntax/Attr.hs +234/−0
- DDC/Llvm/Syntax/Exp.hs +99/−0
- DDC/Llvm/Syntax/Function.hs +39/−0
- DDC/Llvm/Syntax/Instr.hs +186/−0
- DDC/Llvm/Syntax/Metadata.hs +83/−0
- DDC/Llvm/Syntax/Module.hs +137/−0
- DDC/Llvm/Syntax/Prim.hs +89/−0
- DDC/Llvm/Syntax/Type.hs +167/−0
- DDC/Llvm/Transform/Clean.hs +189/−0
- DDC/Llvm/Transform/LinkPhi.hs +88/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ddc-core-llvm.cabal +85/−0
+ DDC/Core/Llvm/Convert.hs view
@@ -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+
+ DDC/Core/Llvm/Convert/Atom.hs view
@@ -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+
+ DDC/Core/Llvm/Convert/Erase.hs view
@@ -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)
+ DDC/Core/Llvm/Convert/Prim.hs view
@@ -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+
+ DDC/Core/Llvm/Convert/Type.hs view
@@ -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+
+ DDC/Core/Llvm/LlvmM.hs view
@@ -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+
+ DDC/Core/Llvm/Metadata/Graph.hs view
@@ -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)
+ DDC/Core/Llvm/Metadata/Tbaa.hs view
@@ -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+
+ DDC/Llvm/Analysis/Children.hs view
@@ -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)+
+ DDC/Llvm/Analysis/Parents.hs view
@@ -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
+ DDC/Llvm/Graph.hs view
@@ -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+
+ DDC/Llvm/Pretty.hs view
@@ -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 ()
+ DDC/Llvm/Pretty/Attr.hs view
@@ -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"
+ DDC/Llvm/Pretty/Exp.hs view
@@ -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"+
+ DDC/Llvm/Pretty/Function.hs view
@@ -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'
+ DDC/Llvm/Pretty/Instr.hs view
@@ -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 ]+
+ DDC/Llvm/Pretty/Metadata.hs view
@@ -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 ++
+ DDC/Llvm/Pretty/Module.hs view
@@ -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!"+
+ DDC/Llvm/Pretty/Prim.hs view
@@ -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"++++++
+ DDC/Llvm/Pretty/Type.hs view
@@ -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')++++
+ DDC/Llvm/Syntax.hs view
@@ -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
+ DDC/Llvm/Syntax/Attr.hs view
@@ -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 <http://llvm.org/docs/LangRef.html#fnattrs>+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 <http://www.llvm.org/docs/LangRef.html#linkage>, 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)++
+ DDC/Llvm/Syntax/Exp.hs view
@@ -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
+ DDC/Llvm/Syntax/Function.hs view
@@ -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)+
+ DDC/Llvm/Syntax/Instr.hs view
@@ -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+
+ DDC/Llvm/Syntax/Metadata.hs view
@@ -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 ]+
+ DDC/Llvm/Syntax/Module.hs view
@@ -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++
+ DDC/Llvm/Syntax/Prim.hs view
@@ -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)+
+ DDC/Llvm/Syntax/Type.hs view
@@ -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
+ DDC/Llvm/Transform/Clean.hs view
@@ -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." ]+
+ DDC/Llvm/Transform/LinkPhi.hs view
@@ -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+
+ LICENSE view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-core-llvm.cabal view
@@ -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 <benl@ouroborus.net>+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++