diff options
Diffstat (limited to 'compiler/llvmGen')
| -rw-r--r-- | compiler/llvmGen/Llvm.hs | 6 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/AbsSyn.hs | 15 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/PpLlvm.hs | 88 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/Types.hs | 39 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 57 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Ppr.hs | 16 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Regs.hs | 45 |
7 files changed, 212 insertions, 54 deletions
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index aec492e151..b15b6f261d 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -34,6 +34,9 @@ module Llvm ( -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + -- ** Metadata types + LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, @@ -42,7 +45,8 @@ module Llvm ( -- * Pretty Printing ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 93bc62c91f..a28734b152 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -31,6 +31,9 @@ data LlvmModule = LlvmModule { -- | LLVM Alias type definitions. modAliases :: [LlvmAlias], + -- | LLVM meta data. + modMeta :: [LlvmMeta], + -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -138,8 +141,15 @@ data LlvmStatement -} | Nop + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaData] LlvmStatement + deriving (Show, Eq) +type MetaData = (LMString, LlvmMetaUnamed) + -- | Llvm Expressions data LlvmExpression @@ -229,5 +239,10 @@ data LlvmExpression -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + {- | + A LLVM expression with metadata attached to it. + -} + | MetaExpr [MetaData] LlvmExpression + deriving (Show, Eq) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index b5c3ba8f7e..2945777f96 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -10,8 +10,10 @@ module Llvm.PpLlvm ( ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmAlias, ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, @@ -38,9 +40,10 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) = ppLlvmComments comments $+$ newLine $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine $+$ ppLlvmGlobals globals $+$ newLine $+$ ppLlvmFunctionDecls decls $+$ newLine $+$ ppLlvmFunctions funcs @@ -88,7 +91,32 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> Doc ppLlvmAlias (name, ty) - = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty $+$ newLine + = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) + = exclamation <> int u <> text " = metadata !{" <> + hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" + +ppLlvmMeta (MetaNamed n metas) + = exclamation <> ftext n <> text " = !{" <> + hcat (intersperse comma $ map pprNode munq) <> text "}" + where + munq = map (\(LMMetaUnamed u) -> u) metas + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaVal (MetaVar v) = texts v +ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) + = text "metadata !" <> int u -- | Print out a list of function definitions. @@ -168,29 +196,33 @@ ppLlvmBlock (LlvmBlock blockId stmts) Just id2' -> go id2' rest Nothing -> empty in ppLlvmBlockLabel id - $+$ nest 4 (vcat $ map ppLlvmStatement block) + $+$ (vcat $ map ppLlvmStatement block) $+$ newLine $+$ ppRest +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> Doc +ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon + + -- | Print out an LLVM statement. ppLlvmStatement :: LlvmStatement -> Doc -ppLlvmStatement stmt - = case stmt of - Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) - Branch target -> ppBranch target - BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF - Comment comments -> ppLlvmComments comments +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments MkLabel label -> ppLlvmBlockLabel label - Store value ptr -> ppStore value ptr - Switch scrut def tgs -> ppSwitch scrut def tgs - Return result -> ppReturn result - Expr expr -> ppLlvmExpression expr - Unreachable -> text "unreachable" + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s --- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> Doc -ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM expression. ppLlvmExpression :: LlvmExpression -> Doc @@ -206,6 +238,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MetaExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -341,6 +374,21 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' +ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + + +ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta + + +ppMetas :: [MetaData] -> Doc +ppMetas meta = hcat $ map ppMeta meta + where + ppMeta (name, (LMMetaUnamed n)) + = comma <+> exclamation <> ftext name <+> exclamation <> int n + + -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- @@ -362,3 +410,7 @@ texts = (text . show) newLine :: Doc newLine = text "" +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 101342606d..07e53fb731 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -70,12 +70,49 @@ instance Show LlvmType where show (LMAlias (s,_)) = "%" ++ unpackFS s +-- | LLVM metadata values. Used for representing debug and optimization +-- information. +data LlvmMetaVal + -- | Metadata string + = MetaStr LMString + -- | Metadata node + | MetaNode LlvmMetaUnamed + -- | Normal value type as metadata + | MetaVar LlvmVar + deriving (Eq) + +-- | LLVM metadata nodes. +data LlvmMeta + -- | Unamed metadata + = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] + -- | Named metadata + | MetaNamed LMString [LlvmMetaUnamed] + deriving (Eq) + +-- | Unamed metadata variable. +newtype LlvmMetaUnamed = LMMetaUnamed Int + +instance Eq LlvmMetaUnamed where + (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m + +instance Show LlvmMetaVal where + show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n) = "metadata " ++ show n + show (MetaVar v) = show v + +instance Show LlvmMetaUnamed where + show (LMMetaUnamed u) = "!" ++ show u + +instance Show LlvmMeta where + show (MetaUnamed m _) = show m + show (MetaNamed m _) = "!" ++ unpackFS m + -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int type LMConst = Bool -- ^ is a variable constant or not --- | Llvm Variables +-- | LLVM Variables data LlvmVar -- | Variables with a global scope. = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 07ccbb1348..4309dcdae1 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -550,7 +550,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [ = genStore_fast env addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val +genStore env addr val = genStore_slow env addr val [top] -- | CmmStore operation -- This is a special case for storing to a global register pointer @@ -558,8 +558,9 @@ genStore env addr val = genStore_slow env addr val genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -570,7 +571,7 @@ genStore_fast env addr r n val case pLower grt == getVarType vval of -- were fine True -> do - let s3 = Store vval ptr + let s3 = MetaStmt meta $ Store vval ptr return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -578,19 +579,19 @@ genStore_fast env addr r n val False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = Store vval ptr' + let s4 = MetaStmt meta $ Store vval ptr' return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val + False -> genStore_slow env addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData -genStore_slow env addr val = do +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData +genStore_slow env addr val meta = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val @@ -599,17 +600,17 @@ genStore_slow env addr val = do -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vaddr + let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = Store vval vaddr + let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = Store vval vptr + let s2 = MetaStmt meta $ Store vval vptr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -841,8 +842,8 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1031,7 +1032,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [ = genLoad_fast env e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty +genLoad env e ty = genLoad_slow env e ty [top] -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer @@ -1039,9 +1040,10 @@ genLoad env e ty = genLoad_slow env e ty genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty + let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr + ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1051,7 +1053,7 @@ genLoad_fast env e r n ty = case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' $ Load ptr + (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) @@ -1059,29 +1061,31 @@ genLoad_fast env e r n ty = False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' $ Load ptr' + (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty + False -> genLoad_slow env e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genLoad_slow env e ty = do +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData +genLoad_slow env e ty meta = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load ptr) return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" @@ -1099,7 +1103,6 @@ genLoad_slow env e ty = do getCmmReg :: LlvmEnv -> CmmReg -> ExprData getCmmReg env r@(CmmLocal (LocalReg un _)) = let exists = varLookup un env - (newv, stmts) = allocReg r nenv = varInsert un (pLower $ getVarType newv) env in case exists of @@ -1204,7 +1207,7 @@ funEpilogue Nothing = do return (vars, concatOL stmts) where loadExpr r = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1214,7 +1217,7 @@ funEpilogue (Just live) = do return (vars, concatOL stmts) where loadExpr r | r `elem` alwaysLive || r `elem` live = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) loadExpr r = do diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index e0cebe5f21..187d1ecf03 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,6 +11,7 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data +import LlvmCodeGen.Regs import CLabel import OldCmm @@ -25,6 +26,16 @@ import Unique -- * Top level -- +-- | Header code for LLVM modules +pprLlvmHeader :: Doc +pprLlvmHeader = + moduleLayout + $+$ text "" + $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmMetas stgTBAA + $+$ text "" + + -- | LLVM module layout description for the host target moduleLayout :: Doc moduleLayout = @@ -64,11 +75,6 @@ moduleLayout = #endif --- | Header code for LLVM modules -pprLlvmHeader :: Doc -pprLlvmHeader = - moduleLayout $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) - -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> Doc pprLlvmData (globals, types) = diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index ecce7a317b..55b2e0db80 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -3,7 +3,8 @@ -- module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar, alwaysLive + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA ) where #include "HsVersions.h" @@ -11,8 +12,8 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr -import Outputable ( panic ) import FastString +import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar @@ -49,6 +50,8 @@ lmGlobalReg suf reg DoubleReg 2 -> doubleGlobal $ "D2" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where wordGlobal name = LMNLocalVar (fsLit name) llvmWord ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr @@ -59,3 +62,41 @@ lmGlobalReg suf reg alwaysLive :: [GlobalReg] alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] +-- | STG Type Based Alias Analysis metadata +stgTBAA :: [LlvmMeta] +stgTBAA + = [ MetaUnamed topN [MetaStr (fsLit "top")] + , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] + , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] + , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] + , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + ] + +-- | Id values +topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed +topN = LMMetaUnamed 0 +stackN = LMMetaUnamed 1 +heapN = LMMetaUnamed 2 +rxN = LMMetaUnamed 3 +baseN = LMMetaUnamed 4 + +-- | The various TBAA types +top, heap, stack, rx, base :: MetaData +top = (tbaa, topN) +heap = (tbaa, heapN) +stack = (tbaa, stackN) +rx = (tbaa, rxN) +base = (tbaa, baseN) + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> MetaData +getTBAA BaseReg = base +getTBAA Sp = stack +getTBAA Hp = heap +getTBAA (VanillaReg _ _) = rx +getTBAA _ = top + |