core llvm: handle change in syntax of load and getelembyptr in LLVM 3.7

packages/ddc-build/DDC/Build/Pipeline/Llvm.hs

@@ -49,14 +49,12 @@ pipeLlvm !mm !pp
          -> {-# SCC "PipeLlvmCompile" #-}
             do  
                 -- LLVM config.
-                let llConfig    = Llvm.Config
-                                { Llvm.configLlvmVersion = Build.buildLlvmVersion builder }
+                let llConfig    = Llvm.configOfVersion
+                                $ Just $ Build.buildLlvmVersion builder
 
                 -- Pretty printer mode to use for the current LLVM version.
                 let llMode      = Llvm.prettyModeModuleOfConfig llConfig
 
-                putStrLn $ Build.buildLlvmVersion builder
-
                 -- Write out the LLVM source file.
                 let llSrc       = renderIndent $ pprModePrec llMode (0 :: Int) mm
                 writeFile llPath llSrc

packages/ddc-core-llvm/DDC/Llvm/Pretty.hs

@@ -2,7 +2,7 @@
 -- | Pretty printer instances for the Llvm syntax.
 module DDC.Llvm.Pretty 
         ( Config(..)
-        , configDefault
+        , configOfVersion
         , prettyModeModuleOfConfig)
 where
 import DDC.Llvm.Pretty.Base

packages/ddc-core-llvm/DDC/Llvm/Pretty/Base.hs

@@ -1,48 +1,83 @@
 
 module DDC.Llvm.Pretty.Base
         ( Config(..)
-        , configDefault
         , Version
-        , versionWantsMetadataAsValue)
+        , defaultConfig
+        , configOfVersion
+        , versionWantsMetadataAsValue
+        , versionWantsLoadReturnTypes)
 where
 import Data.List
+import Data.Maybe
 
 
+-------------------------------------------------------------------------------
 -- | LLVM pretty printer configuration.
 data Config
         = Config
-        { configLlvmVersion     :: Version }
-
-
--- | Default config.
-configDefault :: Config
-configDefault
-        = Config
-        { -- | 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.
-          configLlvmVersion     = "LLVM version 3.8.0" }
+        { configLlvmVersion             :: Version 
+        , configWantsMetadataAsValue    :: Bool
+        , configWantsLoadReturnTypes    :: Bool }
+        deriving Show
 
 
 -- | LLVM version descriptor.
 type Version    
         = String
 
 
--- | In LLVM versions before 3.6.1 encoded meta data as a value,
+-- | 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 version
- = case words version of
-        ["LLVM", "version",  num]
-         | isPrefixOf "3.1." num  -> Just True
-         | isPrefixOf "3.2." num  -> Just True
-         | isPrefixOf "3.3." num  -> Just True
-         | isPrefixOf "3.4." num  -> Just True
-         | isPrefixOf "3.5." num  -> Just True
-         | isPrefixOf "3."   num  -> Just False
-
-        _                         -> Nothing
+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
+
+

packages/ddc-core-llvm/DDC/Llvm/Pretty/Function.hs

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

packages/ddc-core-llvm/DDC/Llvm/Pretty/Instr.hs

@@ -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,10 +138,20 @@ instance Pretty Instr where
 
         -- 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"
@@ -126,6 +176,18 @@ instance Pretty Instr where
                 <+> 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"
@@ -149,12 +211,12 @@ instance Pretty Instr where
         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'