llvm-pretty 0.3.1.1 → 0.4.0.0

raw patch · 4 files changed

+91/−48 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• llvm-pretty.cabal +1/−1
• src/Text/LLVM.hs +32/−21
• src/Text/LLVM/AST.hs +57/−26
• src/Text/LLVM/Labels.hs +1/−0

@@ -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

@@ -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

@@ -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"

@@ -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