ddc-core-llvm 0.4.2.1 → 0.4.2.2

raw patch · 10 files changed

+337/−87 lines, 10 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• DDC/Llvm/Pretty.hs +7/−2
• DDC/Llvm/Pretty/Base.hs +83/−0
• DDC/Llvm/Pretty/Exp.hs +1/−3
• DDC/Llvm/Pretty/Function.hs +21/−9
• DDC/Llvm/Pretty/Instr.hs +81/−20
• DDC/Llvm/Pretty/Metadata.hs +81/−20
• DDC/Llvm/Pretty/Module.hs +56/−25
• DDC/Llvm/Pretty/Prim.hs +1/−0
• DDC/Llvm/Pretty/Type.hs +4/−7
• ddc-core-llvm.cabal +2/−1

@@ -1,11 +1,16 @@  -- | Pretty printer instances for the Llvm syntax.-module DDC.Llvm.Pretty where+module DDC.Llvm.Pretty +        ( Config(..)+        , configOfVersion+        , prettyModeModuleOfConfig)+where+import DDC.Llvm.Pretty.Base 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.Module import DDC.Llvm.Pretty.Prim             () import DDC.Llvm.Pretty.Type             ()

@@ -0,0 +1,83 @@++module DDC.Llvm.Pretty.Base+        ( Config(..)+        , Version+        , defaultConfig+        , configOfVersion+        , versionWantsMetadataAsValue+        , versionWantsLoadReturnTypes)+where+import Data.List+import Data.Maybe+++-------------------------------------------------------------------------------+-- | LLVM pretty printer configuration.+data Config+        = Config+        { configLlvmVersion             :: Version +        , configWantsMetadataAsValue    :: Bool+        , configWantsLoadReturnTypes    :: Bool }+        deriving Show+++-- | LLVM version descriptor.+type Version    +        = String+++-- | Default config that can be used for debugging.+defaultConfig :: Config+defaultConfig =  configOfVersion Nothing+++-- | Produce a default pretty printer config for the given version.+--+--   Assume LLVM 3.8 as the default version unless told otherwise.+--   This default should only be used during debugging,+--   when compiling real modules the version will be set explicitly+--   by the compilation driver.+--+--   LLVM version 3.8.0 was current as of March 2016.+--+configOfVersion :: Maybe Version -> Config+configOfVersion mVersion+ = let  version = fromMaybe "3.8.0" mVersion+   in   Config+        { configLlvmVersion             = version++        , configWantsMetadataAsValue    +                = fromMaybe False  $ versionWantsMetadataAsValue version++        , configWantsLoadReturnTypes    +                = fromMaybe True   $ versionWantsLoadReturnTypes version }+++-- | LLVM versions before 3.6.1 encoded meta data as a value,+--   while after that it is typeless.+versionWantsMetadataAsValue :: Version -> Maybe Bool+versionWantsMetadataAsValue v+        | isPrefixOf "3.1." v   = Just True+        | isPrefixOf "3.2." v   = Just True+        | isPrefixOf "3.3." v   = Just True+        | isPrefixOf "3.4." v   = Just True+        | isPrefixOf "3.5." v   = Just True+        | isPrefixOf "3."   v   = Just False+        | otherwise             = Nothing+++-- | LLVM versions before 3.7.0 did not use a result type+--   on load and getelembyptr operations, while after they+--   did.+versionWantsLoadReturnTypes :: Version -> Maybe Bool+versionWantsLoadReturnTypes v+        | isPrefixOf "3.1." v   = Just False+        | isPrefixOf "3.2." v   = Just False+        | isPrefixOf "3.3." v   = Just False+        | isPrefixOf "3.4." v   = Just False+        | isPrefixOf "3.5." v   = Just False+        | isPrefixOf "3.6." v   = Just False+        | isPrefixOf "3." v     = Just True+        | otherwise             = Nothing++

@@ -73,10 +73,8 @@          -> text "c" <> pprString txEnc  +-- | Pretty print an LLVM string. pprString :: Text -> Doc pprString tx  = text "\"" <> text (T.unpack tx) <> text "\""--- 

@@ -1,27 +1,39 @@--module DDC.Llvm.Pretty.Function-        ( pprFunctionHeader)-where+{-# LANGUAGE TypeFamilies #-}+module DDC.Llvm.Pretty.Function where import DDC.Llvm.Syntax.Function import DDC.Llvm.Syntax.Type import DDC.Llvm.Pretty.Attr             ()-import DDC.Llvm.Pretty.Instr            ()+import DDC.Llvm.Pretty.Instr+import DDC.Llvm.Pretty.Base import DDC.Base.Pretty import Prelude                          hiding ((<$>))   instance Pretty Function where- ppr (Function decl paramNames attrs sec body) -  = let attrDoc = hsep $ map ppr attrs-        secDoc  = case sec of+ data PrettyMode Function+        = PrettyModeFunction+        { modeFunctionConfig :: Config }++ pprDefaultMode+        = PrettyModeFunction+        { modeFunctionConfig = defaultConfig }++ pprModePrec (PrettyModeFunction config) prec+        (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) +        pprBlock = pprModePrec (PrettyModeBlock config) prec+     in text "define"          <+> pprFunctionHeader decl (Just paramNames)                 <+> attrDoc <+> secDoc         <$> lbrace-        <$> vcat (map ppr body)+        <$> vcat (map pprBlock body)         <$> rbrace  

@@ -1,41 +1,81 @@-+{-# LANGUAGE TypeFamilies #-} module DDC.Llvm.Pretty.Instr where import DDC.Llvm.Syntax.Attr import DDC.Llvm.Syntax.Exp import DDC.Llvm.Syntax.Instr import DDC.Llvm.Syntax.Metadata import DDC.Llvm.Syntax.Prim+import DDC.Llvm.Syntax.Type import DDC.Llvm.Pretty.Exp import DDC.Llvm.Pretty.Prim     () import DDC.Llvm.Pretty.Metadata ()+import DDC.Llvm.Pretty.Base 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)+ data PrettyMode Block+        = PrettyModeBlock+        { modeBlockConfig :: Config } + pprDefaultMode+        = PrettyModeBlock+        { modeBlockConfig = defaultConfig } + pprModePrec +        (PrettyModeBlock config) prec +        (Block label instrs)+  = let downAnnotInstr+         = pprModePrec (PrettyModeAnnotInstr config) prec++    in    ppr label <>  colon +     <$$> indent 8 (vcat $ map downAnnotInstr $ 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))+ data PrettyMode AnnotInstr+        = PrettyModeAnnotInstr+        { modeAnnotInstrConfig :: Config } + pprDefaultMode+        = PrettyModeAnnotInstr+        { modeAnnotInstrConfig = defaultConfig } + pprModePrec (PrettyModeAnnotInstr config) prec ainstr+  = case ainstr of+        AnnotInstr instr []+         -> pprModePrec (PrettyModeInstr config) prec instr++        AnnotInstr instr mds+         -> let pprWithTag (MDecl ref Tbaa{}) = text "!tbaa"  <> space <> ppr ref+                pprWithTag (MDecl ref Debug)  = text "!debug" <> space <> ppr ref+            in  pprModePrec (PrettyModeInstr config) prec 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.+ data PrettyMode Instr+        = PrettyModeInstr+        { modeInstrConfig :: Config }++ pprDefaultMode +        = PrettyModeInstr+        { modeInstrConfig = defaultConfig }++ pprModePrec (PrettyModeInstr config) _prec ii+  = let +        -- Pad binding occurrence of variable.         padVar  var          = fill 12 (ppr $ nameOfVar var) @@ -98,11 +138,21 @@          -- Memory Operations ------------------------------         ILoad vDst x1+         -- From LLVM 3.7 we need to give the type of the source pointer+         -- as well as the type of the result of the load.+         |  configWantsLoadReturnTypes config          -> padVar vDst-                <+> equals-                <+> text "load"-                <+> ppr x1+                <+> equals +                <+> text "load" +                <+> ppr (typeOfVar vDst) <> comma       -- Type of result.+                <+> ppr x1                              -- Pointer type of source. +         -- Before LLVM 3.7 we only needed to give the type of the source pointer.+         |  otherwise+         -> padVar vDst +                <+> equals +                <+> text "load" <+> ppr x1+         IStore xDst xSrc          -> text "store"                 <+> ppr xSrc  <> comma@@ -126,11 +176,22 @@                 <+> ppr (typeOfVar vDst)          IGet vDst xSrc os+         -- From LLVM 3.7 we need to give the type of the source pointer+         -- as well as the type of the result of the load.      +         |  configWantsLoadReturnTypes config+         ,  XVar (Var _ (TPointer t)) <- xSrc          -> padVar vDst                 <+> equals                 <+> text "getelementptr"+                <+> ppr t <> comma              -- Type of result                 <+> (hcat $ punctuate (text ", ") $ (ppr xSrc : map ppr os)) +         -- Before LLVM 3.7 we only needed to give the type of the source pointer.+         |  otherwise+         -> padVar vDst+                <+> equals+                <+> text "getelementptr"+                <+> (hcat $ punctuate (text ", ") $ (ppr xSrc : map ppr os))          -- Other operations -------------------------------         ICmp vDst (ICond icond) x1 x2@@ -150,12 +211,12 @@         ICall mdst callType callConv tResult name xsArgs attrs          -> let call'                  = case callType of-                        CallTypeTail    -> text "tail call"-                        _               -> text "call"+                        CallTypeTail -> text "tail call"+                        _            -> text "call"                 dst'                  = case mdst of-                        Nothing         -> empty-                        Just dst        -> fill 12 (ppr $ nameOfVar dst) <+> equals <> space+                        Nothing      -> empty+                        Just dst     -> fill 12 (ppr $ nameOfVar dst) <+> equals <> space              in dst'                  <> hsep  [ call'

@@ -1,47 +1,108 @@-+{-# LANGUAGE TypeFamilies #-} module DDC.Llvm.Pretty.Metadata where import DDC.Llvm.Syntax.Metadata import DDC.Llvm.Pretty.Type             ()+import DDC.Llvm.Pretty.Base import DDC.Base.Pretty  +------------------------------------------------------------------------------- instance Pretty Metadata where- ppr mt-  = case mt of+ data PrettyMode Metadata+        = PrettyModeMetadata+        { modeMetadataConfig    :: Config }++ pprDefaultMode+        = PrettyModeMetadata+        { modeMetadataConfig    = defaultConfig  }++ pprModePrec    mode prec md+  = pprMetaData mode prec md++pprMetaData (PrettyModeMetadata config) _ mt+  = let downMDNodeOp = pprMDNodeOp +                        (PrettyModeMDNodeOp config) +                        (0 :: Int)+    in case mt of          Tbaa (MDNode ops)            -> text "!" <> encloseSep lbrace rbrace -                                   (comma <> space) (map ppr ops)-+                                (comma <> space) +                                (map downMDNodeOp ops)          Debug             -> text "DEBUGMD"  +------------------------------------------------------------------------------- instance Pretty MDecl where-  ppr (MDecl ref m) =  ppr ref -                    <> space <> equals <> space -                    <> text "metadata" <> space-                    <> ppr m+ data PrettyMode MDecl+        = PrettyModeMDecl+        { modeMDeclConfig       :: Config } + pprDefaultMode+        = PrettyModeMDecl+        { modeMDeclConfig       = defaultConfig }++ pprModePrec mode prec md+  = pprMDecl mode prec md++pprMDecl (PrettyModeMDecl config) _ (MDecl ref m) + | configWantsMetadataAsValue config+ = ppr ref <> space <> equals <> space +           <> text "metadata" <> space+           <> pprMetaData (PrettyModeMetadata config) (0 :: Int) m++ | otherwise+ = ppr ref <> space <> equals <> space +           <> pprMetaData (PrettyModeMetadata config) (0 :: Int) m+++------------------------------------------------------------------------------- instance Pretty (MRef) where-  ppr (MRef i) = text ("!" ++ show i)+ ppr (MRef i) +  = text ("!" ++ show i)  +------------------------------------------------------------------------------- instance Pretty MDString where-  ppr (MDString s) = text "!" <> (dquotes $ text s)+ ppr (MDString s)+  = text "!" <> (dquotes $ text s)    +------------------------------------------------------------------------------- instance Pretty MDNode where-  ppr (MDNode ns) = text "!" <> braces (ppr ns)+ 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 + data PrettyMode MDNodeOp+        = PrettyModeMDNodeOp+        { modeMDNodeOpConfig   :: Config } + pprDefaultMode+        = PrettyModeMDNodeOp+        { modeMDNodeOpConfig   = defaultConfig }++ pprModePrec    mode prec elt+  = pprMDNodeOp mode prec elt++pprMDNodeOp (PrettyModeMDNodeOp config) _prec elt+ | configWantsMetadataAsValue config+ = 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 ++ | otherwise+ = case elt of+        OpNull        -> text "null"+        OpMDString ms -> ppr ms+        OpMDNode   ns -> ppr ns+        OpMDRef    r  -> space <> ppr r +        OpBool     b  -> text "i32" <> space <> text (if b then "1" else "0")+        OpType     t  -> ppr t  

@@ -1,29 +1,55 @@-+{-# LANGUAGE TypeFamilies #-} 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.Llvm.Pretty.Metadata+import DDC.Llvm.Pretty.Base import DDC.Base.Pretty  +-------------------------------------------------------------------------------+-- | Produce a default pretty printer mode from an LLVM config.+prettyModeModuleOfConfig :: Config -> PrettyMode Module+prettyModeModuleOfConfig config+        = PrettyModeModule+        { modeModuleConfig      = config }+++------------------------------------------------------------------------------- -- | 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+ data PrettyMode Module+        = PrettyModeModule+        { modeModuleConfig      :: Config } + pprDefaultMode +        = PrettyModeModule+        { modeModuleConfig      = defaultConfig }    + pprModePrec +        (PrettyModeModule config) prec+        (Module _comments aliases globals decls funcs mdecls)+  = let +        pprFunction' = pprModePrec (PrettyModeFunction config) prec+        pprMDecl'    = pprModePrec (PrettyModeMDecl    config) prec++    in   (vcat $ map ppr aliases)+    <$$> (vcat $ map ppr globals)+    <$$> (vcat $ map (\decl -> text "declare" +                          <+> pprFunctionHeader decl Nothing) decls)+    <$$>  empty+    <$$>  (vcat $ punctuate line +                $ map pprFunction' funcs)+    <$$>  line+    <$$>  empty+    <$$>  (vcat $ map pprMDecl' mdecls)+    <$$>  empty+++------------------------------------------------------------------------------- instance Pretty Global where  ppr gg   = case gg of@@ -34,35 +60,40 @@          -> ppr name <+> text "= external global " <+> ppr t   +------------------------------------------------------------------------------- instance Pretty Static where   ppr ss    = case ss of-        StaticComment       s    +        StaticComment s          -> text "; " <> text s -        StaticLit     l +        StaticLit l           -> ppr l -        StaticUninitType    t+        StaticUninitType t          -> ppr t <> text " undef" -        StaticStr     s t+        StaticStr   s t          -> ppr t <> text " c\"" <> text s <> text "\\00\"" -        StaticArray   d t-         -> ppr t <> text " [" <> hcat (punctuate comma $ map ppr d) <> text "]"+        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 "}>"+         -> ppr t +         <> text "<{" <> hcat (punctuate comma $ map ppr d) <> text "}>"          StaticPointer (Var n t)-         -> ppr t <> text "*" <+> ppr n+         -> ppr t     <> text "*" <+> ppr n -        StaticBitc    v t-         -> ppr t <> text " bitcast"  <+> parens (ppr v <> text " to " <> ppr t)+        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)+        StaticPtoI v t+         -> ppr t +         <> text " ptrtoint" <+> parens (ppr v <> text " to " <> ppr t)          StaticAdd s1 s2          -> let ty1 = typeOfStatic s1

@@ -3,6 +3,7 @@ import DDC.Llvm.Syntax.Prim import DDC.Base.Pretty + instance Pretty Op where  ppr op   = case op of

@@ -27,8 +27,8 @@     in  ppr l   <+> ppr c                  <+> ppr r                  <+> text " @" -                <> ppr n <> brackets (args' <> varg') -                <> align'+                <>  ppr n <> brackets (args' <> varg') +                <>  align'   instance Pretty TypeAlias where@@ -52,10 +52,10 @@          -> text "<{" <> (hcat $ punctuate comma (map ppr tys)) <> text "}>"          TArray nr tp-         -> brackets (integer nr <> text " x " <> ppr tp)+         -> brackets  $ integer nr <> text " x " <> ppr tp          TAlias (TypeAlias s _)  -         -> text "%" <> text s+         -> text "%"  <> text s          TFunction (FunctionDecl _ _ _ r varg params _)          -> let varg' = case varg of@@ -67,7 +67,4 @@                 args    = hcat $ punctuate comma $ map ppr params              in ppr r <> parens (args <> varg')--- 

@@ -1,5 +1,5 @@ Name:           ddc-core-llvm-Version:        0.4.2.1+Version:        0.4.2.2 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -60,6 +60,7 @@         DDC.Core.Llvm.Convert.Type          DDC.Llvm.Pretty.Attr+        DDC.Llvm.Pretty.Base         DDC.Llvm.Pretty.Exp         DDC.Llvm.Pretty.Function         DDC.Llvm.Pretty.Instr