X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvm%2FPpLlvm.hs;h=82c6bfa65e8c64cfe4a9d6e8b690d570f377a32c;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hp=8d36511a47897ca7b2689fad172928b8926cd5ce;hpb=49a8e5c021009430d373d6224b29004c7d18c408;p=ghc-hetmet.git diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 8d36511..82c6bfa 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -8,16 +8,16 @@ module Llvm.PpLlvm ( ppLlvmModule, ppLlvmComments, ppLlvmComment, - ppLlvmConstants, - ppLlvmConstant, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmType, - ppLlvmTypes, + ppLlvmAlias, + ppLlvmAliases, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, + + -- * Utility functions llvmSDoc ) where @@ -29,7 +29,7 @@ import Llvm.Types import Data.List ( intersperse ) import Pretty -import qualified Outputable as Outp +import qualified Outputable as Out import Unique -------------------------------------------------------------------------------- @@ -38,10 +38,11 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments constants globals decls funcs) +ppLlvmModule (LlvmModule comments aliases globals decls funcs) = ppLlvmComments comments $+$ empty - $+$ ppLlvmConstants constants + $+$ ppLlvmAliases aliases + $+$ empty $+$ ppLlvmGlobals globals $+$ empty $+$ ppLlvmFunctionDecls decls @@ -54,7 +55,7 @@ ppLlvmComments comments = vcat $ map ppLlvmComment comments -- | Print out a comment, can be inside a function or on its own ppLlvmComment :: LMString -> Doc -ppLlvmComment com = semi <+> (ftext com) +ppLlvmComment com = semi <+> ftext com -- | Print out a list of global mutable variable definitions @@ -63,42 +64,33 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls -- | Print out a global mutable variable definition ppLlvmGlobal :: LMGlobal -> Doc -ppLlvmGlobal (var@(LMGlobalVar _ _ link), Nothing) = - ppAssignment var $ text (show link) <+> text "global" <+> - (text $ show (pLower $ getVarType var)) +ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = + let sect = case x of + Just x' -> text ", section" <+> doubleQuotes (ftext x') + Nothing -> empty -ppLlvmGlobal (var@(LMGlobalVar _ _ link), (Just stat)) = - ppAssignment var $ text (show link) <+> text "global" <+> text (show stat) - -ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth + align = case a of + Just a' -> text ", align" <+> int a' + Nothing -> empty + rhs = case dat of + Just stat -> texts stat + Nothing -> texts (pLower $ getVarType var) --- | Print out a list global constant variable -ppLlvmConstants :: [LMConstant] -> Doc -ppLlvmConstants cons = vcat $ map ppLlvmConstant cons + const' = if c then text "constant" else text "global" --- | Print out a global constant variable -ppLlvmConstant :: LMConstant -> Doc -ppLlvmConstant (dst@(LMGlobalVar _ _ link), src) = - ppAssignment dst $ text (show link) <+> text "constant" <+> text (show src) + in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align -ppLlvmConstant c = error $ "Non global var as constant! " ++ show c +ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth -- | Print out a list of LLVM type aliases. -ppLlvmTypes :: [LlvmType] -> Doc -ppLlvmTypes tys = vcat $ map ppLlvmType tys +ppLlvmAliases :: [LlvmAlias] -> Doc +ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. -ppLlvmType :: LlvmType -> Doc - -ppLlvmType al@(LMAlias _ t) - = (text $ show al) <+> equals <+> (text "type") <+> (text $ show t) - -ppLlvmType (LMFunction t) - = ppLlvmFunctionDecl t - -ppLlvmType _ = empty +ppLlvmAlias :: LlvmAlias -> Doc +ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty -- | Print out a list of function definitions. @@ -107,14 +99,30 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs -- | Print out a function definition. ppLlvmFunction :: LlvmFunction -> Doc -ppLlvmFunction (LlvmFunction dec attrs body) = +ppLlvmFunction (LlvmFunction dec args attrs sec body) = let attrDoc = ppSpaceJoin attrs - in (text "define") <+> (ppLlvmFuncDecSig dec) - <+> attrDoc + secDoc = case sec of + Just s' -> text "section" <+> (doubleQuotes $ ftext s') + Nothing -> empty + in text "define" <+> ppLlvmFunctionHeader dec args + <+> attrDoc <+> secDoc $+$ lbrace $+$ ppLlvmBlocks body $+$ rbrace +-- | Print out a function defenition header. +ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc +ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args + = let varg' = if varg == VarArgs then text ", ..." else empty + align = case a of + Just a' -> space <> text "align" <+> texts a' + Nothing -> empty + args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" + <> ftext n) + (zip p args) + in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> + (hcat $ intersperse comma args') <> varg' <> rparen <> align + -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc @@ -124,22 +132,7 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs -- Declarations define the function type but don't define the actual body of -- the function. ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc -ppLlvmFunctionDecl dec = (text "declare") <+> ppLlvmFuncDecSig dec - --- | Print out a functions type signature. --- This differs from [ppLlvmFunctionDecl] in that it is used for both function --- declarations and defined functions to print out the type. -ppLlvmFuncDecSig :: LlvmFunctionDecl -> Doc -ppLlvmFuncDecSig (LlvmFunctionDecl name link cc retTy argTy params) - = let linkTxt = show link - linkDoc | linkTxt == "" = empty - | otherwise = (text linkTxt) <> space - ppParams = either ppCommaJoin ppCommaJoin params <> - (case argTy of - VarArgs -> (text ", ...") - FixedArgs -> empty) - in linkDoc <> (text $ show cc) <+> (text $ show retTy) - <+> atsym <> (ftext name) <> lparen <+> ppParams <+> rparen +ppLlvmFunctionDecl dec = text "declare" <+> texts dec -- | Print out a list of LLVM blocks. @@ -151,7 +144,7 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks ppLlvmBlock :: LlvmBlock -> Doc ppLlvmBlock (LlvmBlock blockId stmts) = ppLlvmStatement (MkLabel blockId) - $+$ nest 4 (vcat $ map ppLlvmStatement stmts) + $+$ nest 4 (vcat $ map ppLlvmStatement stmts) -- | Print out an LLVM statement. @@ -168,6 +161,7 @@ ppLlvmStatement stmt Return result -> ppReturn result Expr expr -> ppLlvmExpression expr Unreachable -> text "unreachable" + Nop -> empty -- | Print out an LLVM expression. @@ -179,10 +173,11 @@ ppLlvmExpression expr Call tp fp args attrs -> ppCall tp fp args attrs Cast op from to -> ppCast op from to Compare op left right -> ppCmpOp op left right - GetElemPtr ptr indexes -> ppGetElementPtr ptr indexes + GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes Load ptr -> ppLoad ptr 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 -------------------------------------------------------------------------------- @@ -198,7 +193,7 @@ ppCall ct fptr vals attrs = case fptr of LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d -- should be function type otherwise - LMGlobalVar _ (LMFunction d) _ -> ppCall' d + LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d -- not pointer or function, so error _other -> error $ "ppCall called with non LMFunction type!\nMust be " @@ -206,23 +201,24 @@ ppCall ct fptr vals attrs = case fptr of ++ "local var of pointer function type." where - ppCall' (LlvmFunctionDecl _ _ cc ret argTy params) = + ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCommaJoin vals - ppArgTy = either ppCommaJoin (\x -> ppCommaJoin $ map getVarType x) params <> + ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params + ppArgTy = (hcat $ intersperse comma ppParams) <> (case argTy of - VarArgs -> (text ", ...") + VarArgs -> text ", ..." FixedArgs -> empty) - fnty = space <> lparen <> ppArgTy <> rparen <> (text "*") + fnty = space <> lparen <> ppArgTy <> rparen <> text "*" attrDoc = ppSpaceJoin attrs - in tc <> (text "call") <+> (text $ show cc) <+> (text $ show ret) + in tc <> text "call" <+> texts cc <+> texts ret <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues <+> rparen <+> attrDoc ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc ppMachOp op left right = - (text $ show op) <+> (text $ show (getVarType left)) <+> (text $ getName left) + (texts op) <+> (texts (getVarType left)) <+> (text $ getName left) <> comma <+> (text $ getName right) @@ -231,10 +227,13 @@ ppCmpOp op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = text "icmp" -- Just continue as its much easier to debug + {- | otherwise = error ("can't compare different types, left = " ++ (show $ getVarType left) ++ ", right = " ++ (show $ getVarType right)) - in cmpOp <+> (text $ show op) <+> (text $ show (getVarType left)) + -} + in cmpOp <+> texts op <+> texts (getVarType left) <+> (text $ getName left) <> comma <+> (text $ getName right) @@ -243,83 +242,92 @@ ppAssignment var expr = (text $ getName var) <+> equals <+> expr ppLoad :: LlvmVar -> Doc -ppLoad var = (text "load") <+> (text $ show var) +ppLoad var = text "load" <+> texts var ppStore :: LlvmVar -> LlvmVar -> Doc -ppStore val dst = - (text "store") <+> (text $ show val) <> comma <+> (text $ show dst) +ppStore val dst = text "store" <+> texts val <> comma <+> texts dst ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc -ppCast op from to = - let castOp = text $ show op - in castOp <+> (text $ show from) <+> (text "to") <+> (text $ show to) +ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to ppMalloc :: LlvmType -> Int -> Doc ppMalloc tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in (text "malloc") <+> (text $ show tp) <> comma <+> (text $ show amount') + in text "malloc" <+> texts tp <> comma <+> texts amount' ppAlloca :: LlvmType -> Int -> Doc ppAlloca tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in (text "alloca") <+> (text $ show tp) <> comma <+> (text $ show amount') + in text "alloca" <+> texts tp <> comma <+> texts amount' -ppGetElementPtr :: LlvmVar -> [Int] -> Doc -ppGetElementPtr ptr idx = - let indexes = hcat $ map ((comma <+> (text $ show i32) <+>) . text . show) idx - in (text "getelementptr") <+> (text $ show ptr) <> indexes +ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc +ppGetElementPtr inb ptr idx = + let indexes = comma <+> ppCommaJoin idx + inbound = if inb then text "inbounds" else empty + in text "getelementptr" <+> inbound <+> texts ptr <> indexes ppReturn :: Maybe LlvmVar -> Doc -ppReturn (Just var) = (text "ret") <+> (text $ show var) -ppReturn Nothing = (text "ret") <+> (text $ show LMVoid) +ppReturn (Just var) = text "ret" <+> texts var +ppReturn Nothing = text "ret" <+> texts LMVoid ppBranch :: LlvmVar -> Doc -ppBranch var = (text "br") <+> (text $ show var) +ppBranch var = text "br" <+> texts var ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc ppBranchIf cond trueT falseT - = (text "br") <+> (text $ show cond) <> comma <+> (text $ show trueT) <> comma - <+> (text $ show falseT) + = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc ppPhi tp preds = let ppPreds (val, label) = brackets $ (text $ getName val) <> comma <+> (text $ getName label) - in (text "phi") <+> (text $ show tp) - <+> (hcat $ intersperse comma (map ppPreds preds)) + in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds) ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc ppSwitch scrut dflt targets = - let ppTarget (val, lab) = (text $ show val) <> comma <+> (text $ show lab) + let ppTarget (val, lab) = texts val <> comma <+> texts lab ppTargets xs = brackets $ vcat (map ppTarget xs) - in (text "switch") <+> (text $ show scrut) <> comma <+> (text $ show dflt) - <+> (ppTargets targets) + in text "switch" <+> texts scrut <> comma <+> texts dflt + <+> ppTargets targets + + +ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc +ppAsm asm constraints rty vars sideeffect alignstack = + let asm' = doubleQuotes $ ftext asm + cons = doubleQuotes $ ftext constraints + rty' = texts rty + vars' = lparen <+> ppCommaJoin vars <+> rparen + side = if sideeffect then text "sideeffect" else empty + align = if alignstack then text "alignstack" else empty + in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma + <+> cons <> vars' -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- -atsym :: Doc -atsym = text "@" - ppCommaJoin :: (Show a) => [a] -> Doc -ppCommaJoin strs = hcat $ intersperse comma (map (text . show) strs) +ppCommaJoin strs = hcat $ intersperse comma (map texts strs) ppSpaceJoin :: (Show a) => [a] -> Doc -ppSpaceJoin strs = hcat $ intersperse space (map (text . show) strs) +ppSpaceJoin strs = hcat $ intersperse space (map texts strs) -- | Convert SDoc to Doc -llvmSDoc :: Outp.SDoc -> Doc +llvmSDoc :: Out.SDoc -> Doc llvmSDoc d - = Outp.withPprStyleDoc (Outp.mkCodeStyle Outp.CStyle) d + = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d + +-- | Showable to Doc +texts :: (Show a) => a -> Doc +texts = (text . show)