diff --git a/llvm-pretty.cabal b/llvm-pretty.cabal --- a/llvm-pretty.cabal +++ b/llvm-pretty.cabal @@ -1,5 +1,5 @@ Name: llvm-pretty -Version: 0.3.1.1 +Version: 0.4.0.0 License: BSD3 License-file: LICENSE Author: Trevor Elliott diff --git a/src/Text/LLVM.hs b/src/Text/LLVM.hs --- a/src/Text/LLVM.hs +++ b/src/Text/LLVM.hs @@ -155,14 +155,20 @@ emitTypeDecl :: TypeDecl -> LLVM () emitTypeDecl td = LLVM (put emptyModule { modTypes = [td] }) -emitGlobal :: Global -> LLVM () -emitGlobal g = LLVM (put emptyModule { modGlobals = [g] }) +emitGlobal :: Global -> LLVM (Typed Value) +emitGlobal g = + do LLVM (put emptyModule { modGlobals = [g] }) + return (ptrT (globalType g) -: globalSym g) -emitDefine :: Define -> LLVM () -emitDefine d = LLVM (put emptyModule { modDefines = [d] }) +emitDefine :: Define -> LLVM (Typed Value) +emitDefine d = + do LLVM (put emptyModule { modDefines = [d] }) + return (defFunType d -: defName d) -emitDeclare :: Declare -> LLVM () -emitDeclare d = LLVM (put emptyModule { modDeclares = [d] }) +emitDeclare :: Declare -> LLVM (Typed Value) +emitDeclare d = + do LLVM (put emptyModule { modDeclares = [d] }) + return (decFunType d -: decName d) alias :: Ident -> Type -> LLVM () alias i ty = emitTypeDecl (TypeDecl i ty) @@ -171,7 +177,7 @@ freshSymbol = Symbol `fmap` freshNameLLVM "f" -- | Emit a declaration. -declare :: Type -> Symbol -> [Type] -> Bool -> LLVM () +declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value) declare rty sym tys va = emitDeclare Declare { decRetType = rty , decName = sym @@ -180,24 +186,24 @@ } -- | Emit a global declaration. -global :: Symbol -> Typed Value -> LLVM () -global sym val = emitGlobal Global +global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value) +global attrs sym ty mbVal = emitGlobal Global { globalSym = sym - , globalType = typedType val - , globalValue = typedValue val - , globalAttrs = GlobalAttrs - { gaLinkage = Nothing - , gaConstant = False - } + , globalType = ty + , globalValue = toValue `fmap` mbVal + , globalAttrs = attrs , globalAlign = Nothing } -- | Output a somewhat clunky representation for a string global, that deals -- well with escaping in the haskell-source string. -string :: Symbol -> String -> LLVM () -string sym str = global sym (array (iT 8) bytes) +string :: Symbol -> String -> LLVM (Typed Value) +string sym str = + global emptyGlobalAttrs { gaConstant = True } sym (typedType val) + (Just (typedValue val)) where bytes = [ int (fromIntegral (ord c)) | c <- str ] + val = array (iT 8) bytes -- Function Definition --------------------------------------------------------- @@ -250,8 +256,6 @@ , defBody = body , defSection = Nothing } - let fnty = PtrTo (FunTy rty (map typedType args) False) - return (Typed fnty (ValSymbol fun)) -- | A combination of define and @freshSymbol@. defineFresh :: DefineArgs sig k => FunAttrs -> Type -> sig -> k @@ -276,8 +280,6 @@ , defBody = snd (runBB (k (map (fmap toValue) args))) , defSection = Nothing } - let fnty = PtrTo (FunTy rty sig False) - return (Typed fnty (ValSymbol sym)) -- Basic Block Monad ----------------------------------------------------------- @@ -403,6 +405,9 @@ instance IsValue a => IsValue (Typed a) where toValue = toValue . typedValue +instance IsValue Bool where + toValue = ValBool + instance IsValue Integer where toValue = ValInteger @@ -420,6 +425,12 @@ instance IsValue Int64 where toValue = ValInteger . toInteger + +instance IsValue Float where + toValue = ValFloat + +instance IsValue Double where + toValue = ValDouble instance IsValue Ident where toValue = ValIdent diff --git a/src/Text/LLVM/AST.hs b/src/Text/LLVM/AST.hs --- a/src/Text/LLVM/AST.hs +++ b/src/Text/LLVM/AST.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} module Text.LLVM.AST where @@ -114,20 +115,25 @@ } deriving (Show) ppNamedMd :: NamedMd -> Doc -ppNamedMd nm = ppMetadata (text (nmName nm)) <+> char '=' - <+> ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) +ppNamedMd nm = + sep [ ppMetadata (text (nmName nm)) <+> char '=' + , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] -- Unnamed Metadata ------------------------------------------------------------ data UnnamedMd = UnnamedMd { umIndex :: !Int - , umValues :: [Typed Value] + , umValues :: [Maybe ValMd] + , umDistinct :: Bool } deriving (Show) ppUnnamedMd :: UnnamedMd -> Doc -ppUnnamedMd um = ppMetadata (int (umIndex um)) - <+> char '=' <+> text "metadata" - <+> ppMetadataNode (umValues um) +ppUnnamedMd um = + sep [ ppMetadata (int (umIndex um)) <+> char '=' + , distinct <+> ppMetadataNode (umValues um) ] + where + distinct | umDistinct um = text "distinct" + | otherwise = empty -- Aliases --------------------------------------------------------------------- @@ -305,7 +311,8 @@ ppPrimType Metadata = text "metadata" data FloatType - = Float + = Half + | Float | Double | Fp128 | X86_fp80 @@ -313,6 +320,7 @@ deriving (Eq, Ord, Show) ppFloatType :: FloatType -> Doc +ppFloatType Half = text "half" ppFloatType Float = text "float" ppFloatType Double = text "double" ppFloatType Fp128 = text "fp128" @@ -483,14 +491,14 @@ { globalSym :: Symbol , globalAttrs :: GlobalAttrs , globalType :: Type - , globalValue :: Value + , globalValue :: Maybe Value , globalAlign :: Maybe Align } deriving Show ppGlobal :: Global -> Doc ppGlobal g = ppSymbol (globalSym g) <+> char '=' <+> ppGlobalAttrs (globalAttrs g) - <+> ppType (globalType g) <+> ppValue (globalValue g) + <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) <> ppAlign (globalAlign g) addGlobal :: Global -> Module -> Module @@ -501,6 +509,12 @@ , gaConstant :: Bool } deriving (Show) +emptyGlobalAttrs :: GlobalAttrs +emptyGlobalAttrs = GlobalAttrs + { gaLinkage = Nothing + , gaConstant = False + } + ppGlobalAttrs :: GlobalAttrs -> Doc ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant where @@ -516,6 +530,10 @@ , decVarArgs :: Bool } deriving (Show) +-- | The function type of this declaration +decFunType :: Declare -> Type +decFunType Declare { .. } = PtrTo (FunTy decRetType decArgs decVarArgs) + ppDeclare :: Declare -> Doc ppDeclare d = text "declare" <+> ppType (decRetType d) @@ -534,6 +552,10 @@ , defBody :: [BasicBlock] } deriving (Show) +defFunType :: Define -> Type +defFunType Define { .. } = + PtrTo (FunTy defRetType (map typedType defArgs) defVarArgs) + ppDefine :: Define -> Doc ppDefine d = text "define" <+> ppMaybe ppLinkage (funLinkage (defAttrs d)) @@ -581,23 +603,24 @@ -- Basic Blocks ---------------------------------------------------------------- data BasicBlock' lab = BasicBlock - { bbLabel :: lab - , bbStmts :: [Stmt] + { bbLabel :: Maybe lab + , bbStmts :: [Stmt' lab] } deriving (Show) -type BasicBlock = BasicBlock' (Maybe BlockLabel) +type BasicBlock = BasicBlock' BlockLabel ppBasicBlock :: BasicBlock -> Doc ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb) $+$ nest 2 (vcat (map ppStmt (bbStmts bb))) --- TODO: Consider making this function have type BasicBlock' lab -> [lab] -brTargets :: BasicBlock' lab -> [BlockLabel] -brTargets (BasicBlock _ (stmtInstr . last -> termInst)) = - case termInst of +brTargets :: BasicBlock' lab -> [lab] +brTargets (BasicBlock _ stmts) = + case stmtInstr (last stmts) of Br _ t1 t2 -> [t1, t2] Invoke _ _ _ to uw -> [to, uw] Jump t -> [t] + Switch _ l ls -> l : map snd ls + IndirectBr _ ls -> ls _ -> [] -- Attributes ------------------------------------------------------------------ @@ -1024,8 +1047,9 @@ data ValMd' lab = ValMdString String - | ValMdNode [Typed (Value' lab)] + | ValMdValue (Typed (Value' lab)) | ValMdRef Int + | ValMdNode [Maybe (ValMd' lab)] | ValMdLoc (DebugLoc' lab) deriving (Show,Functor) @@ -1077,26 +1101,33 @@ ppValMd :: ValMd -> Doc ppValMd m = case m of ValMdString str -> ppMetadata (ppStringLiteral str) - ValMdNode vs -> ppMetadataNode vs + ValMdValue tv -> ppTyped ppValue tv ValMdRef i -> ppMetadata (int i) + ValMdNode vs -> ppMetadataNode vs ValMdLoc l -> ppDebugLoc l ppDebugLoc :: DebugLoc -> Doc -ppDebugLoc dl = ppMetadata $ structBraces $ commas - [ ppType (PrimType (Integer 32)) <+> int32 (dlLine dl) - , ppType (PrimType (Integer 32)) <+> int32 (dlCol dl) - , ppTypedValMd (dlScope dl) - , maybe (text "null") ppTypedValMd (dlIA dl) - ] +ppDebugLoc dl = text "!MDLocation" + <> parens (commas [ text "line:" <+> int32 (dlLine dl) + , text "column:" <+> int32 (dlCol dl) + , text "scope:" <+> ppValMd (dlScope dl) + ] <+> mbIA) + where + mbIA = case dlIA dl of + Just md -> comma <+> text "inlinedAt:" <+> ppValMd md + Nothing -> empty + ppTypedValMd :: ValMd -> Doc ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata) ppMetadata :: Doc -> Doc ppMetadata body = char '!' <> body -ppMetadataNode :: [Typed Value] -> Doc -ppMetadataNode vs = ppMetadata (braces (commas (map (ppTyped ppValue) vs))) +ppMetadataNode :: [Maybe ValMd] -> Doc +ppMetadataNode vs = ppMetadata (braces (commas (map arg vs))) + where + arg = maybe (text "null") ppValMd ppBool :: Bool -> Doc ppBool b | b = text "true" diff --git a/src/Text/LLVM/Labels.hs b/src/Text/LLVM/Labels.hs --- a/src/Text/LLVM/Labels.hs +++ b/src/Text/LLVM/Labels.hs @@ -131,6 +131,7 @@ instance HasLabel ValMd' where relabel f md = case md of ValMdString str -> pure (ValMdString str) + ValMdValue tv -> ValMdValue <$> T.mapM (relabel f) tv ValMdRef i -> pure (ValMdRef i) ValMdNode es -> ValMdNode <$> T.mapM (T.mapM (relabel f)) es ValMdLoc dl -> ValMdLoc <$> relabel f dl