Re: [GHC] #11764: ghc internal error building llvm-general-3.5.1.2

28 Jun 2018

      #11764: ghc internal error building llvm-general-3.5.1.2
-------------------------------------+-------------------------------------
        Reporter:  andrew.wja        |                Owner:  (none)
            Type:  bug               |               Status:  infoneeded
        Priority:  high              |            Milestone:  8.6.1
       Component:  Compiler          |              Version:  7.10.3
      Resolution:                    |             Keywords:
Operating System:  Linux             |         Architecture:  x86_64
                                     |  (amd64)
 Type of failure:  None/Unknown      |            Test Case:  cabal install
                                     |  llvm-general
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by RyanGlScott):

 So I checked out `llvm-general` from https://github.com/bscarlet/llvm-
 general (commit 26dac5d35d304f43ffd20fadcbb5175a81ec3f24, which
 corresponds to `llvm-general-3.5.1.2`) and applied the following patch to
 allow it to build on GHC 8.4.3:

 {{{#!diff
 diff --git a/llvm-general-pure/src/LLVM/General/Internal/PrettyPrint.hs b
 /llvm-general-pure/src/LLVM/General/Internal/PrettyPrint.hs
 index 5dae66e..13a79d9 100644
 --- a/llvm-general-pure/src/LLVM/General/Internal/PrettyPrint.hs
 +++ b/llvm-general-pure/src/LLVM/General/Internal/PrettyPrint.hs
 @@ -1,4 +1,5 @@
  {-# LANGUAGE
 +  CPP,
    TemplateHaskell,
    QuasiQuotes,
    ViewPatterns,
 @@ -8,7 +9,7 @@ module LLVM.General.Internal.PrettyPrint where

  import LLVM.General.Prelude

 -import LLVM.General.TH
 +import LLVM.General.TH
  import Language.Haskell.TH.Quote

  import Data.Monoid
 @@ -42,7 +43,7 @@ defaultPrettyShowEnv = PrettyShowEnv {
      precedence = 0
    }

 -type Qual a = Reader PrettyShowEnv a
 +type Qual a = Reader PrettyShowEnv a

  prec :: Int -> Qual a -> Qual a
  prec p = local (\env -> env { precedence = p })
 @@ -58,6 +59,9 @@ indentGroup = fmap (return . IndentGroup)
  instance IsString QTree where
    fromString = return . return . Fixed

 +instance Semigroup QTree where
 +  (<>) = mappend
 +
  instance Monoid QTree where
    mempty = return mempty
    mappend a b = mappend <$> a <*> b
 @@ -71,11 +75,11 @@ renderEx threshold indent env ts =
        where
          bit (Fixed s) = (length s, s, s)
          bit (Variable t f) = (length f, f, concat [ s:(if s == '\n' then
 ind i else "") | s <- t ])
 -        bit (IndentGroup tree) =
 +        bit (IndentGroup tree) =
            let (l, t, f) = fit (i+1) tree
            in (l, t, if (l < threshold) then t else "\n" ++ ind (i+1) ++ f
 ++ "\n" ++ ind i)
          (ls, ts, fs) = unzip3 . map bit $ branches
 -
 +
  render = renderEx 80 "  " defaultPrettyShowEnv

  comma = "," <> variable "\n" " "
 @@ -161,10 +165,15 @@ simpleName n = do
  makePrettyShowInstance :: Name -> DecsQ
  makePrettyShowInstance n = do
    info <- reify n
 -  let (tvb, cons) =
 +  let (tvb, cons) =
          case info of
 +#if __GLASGOW_HASKELL__ >= 800
 +          TyConI (DataD _ _ tvb _ cons _) -> (tvb, cons)
 +          TyConI (NewtypeD _ _ tvb _ con _) -> (tvb, [con])
 +#else
            TyConI (DataD _ _ tvb cons _) -> (tvb, cons)
            TyConI (NewtypeD _ _ tvb con _) -> (tvb, [con])
 +#endif
            x -> error $ "unexpected info: " ++ show x
    cs <- mapM (const $ newName "a") tvb
    let cvs = map varT cs
 @@ -177,19 +186,24 @@ makePrettyShowInstance n = do
                 RecC conName (unzip3 -> (ns, _, _)) -> do
                   pvs <- mapM (const $ newName "f") ns
                   let ss = [| record $(simpleName conName) $(listE
 [[|($(simpleName n), prettyShow $(varE pv))|] | (n, pv) <- zip ns pvs]) |]
 -                 match
 +                 match
                     (conP conName (map varP pvs))
                     (normalB ss)
                     []
                 NormalC conName fs -> do
                   pvs <- mapM (const $ newName "f") fs
                   let ss = [| ctor $(simpleName conName) $(listE [[|
 prettyShow $(varE pv)|] | pv <- pvs]) |]
 -                 match
 +                 match
                     (conP conName (map varP pvs))
                     (normalB ss)
                     []
                 InfixC (_, n0) conName (_, n1) -> do
 +#if __GLASGOW_HASKELL__ >= 800
 +                 justFixity <- reifyFixity conName
 +                 let Fixity prec _ = fromMaybe defaultFixity justFixity
 +#else
                   DataConI _ _ _ (Fixity prec _) <- reify conName
 +#endif
                   let ns = [n0, n1]
                   [p0,p1] <- mapM (const $ newName "f") ns
                   let ss = [| parensIfNeeded prec (prettyShow $(varE p0)
 <+> $(simpleName conName) <+> prettyShow $(varE p1)) |]
 @@ -203,5 +217,5 @@ makePrettyShowInstance n = do
       ]
     ]

 -
 +

 diff --git a/llvm-general-pure/src/LLVM/General/PrettyPrint.hs b/llvm-
 general-pure/src/LLVM/General/PrettyPrint.hs
 index 9f26fff..f8b5148 100644
 --- a/llvm-general-pure/src/LLVM/General/PrettyPrint.hs
 +++ b/llvm-general-pure/src/LLVM/General/PrettyPrint.hs
 @@ -11,7 +11,7 @@ module LLVM.General.PrettyPrint (
    shortPrefixScheme,
    longPrefixScheme,
    defaultPrefixScheme,
 -  basePrefixScheme,
 +  basePrefixScheme,
    shortASTPrefixScheme,
    longASTPrefixScheme,
    imports
 @@ -32,7 +32,7 @@ import qualified LLVM.General.AST.Float as A
  import qualified LLVM.General.AST.FloatingPointPredicate as A
  import qualified LLVM.General.AST.IntegerPredicate as A
  import qualified LLVM.General.AST.FunctionAttribute as A
 -import qualified LLVM.General.AST.ParameterAttribute as A
 +import qualified LLVM.General.AST.ParameterAttribute as A
  import qualified LLVM.General.AST.CallingConvention as A
  import qualified LLVM.General.AST.Visibility as A
  import qualified LLVM.General.AST.DLL as A.DLL
 @@ -107,7 +107,7 @@ showPrettyEx width indent (PrefixScheme ps) = renderEx
 width indent (defaultPret
  -- | A 'PrefixScheme' is a mapping between haskell module names and
  -- the prefixes with which they should be rendered when printing code.
  newtype PrefixScheme = PrefixScheme (Map String (Maybe String))
 -  deriving (Eq, Ord, Read, Show, Monoid)
 +  deriving (Eq, Ord, Read, Show, Monoid, Semigroup)

  -- | a 'PrefixScheme' for types not of llvm-general, but nevertheless
 used
  -- in the AST. Useful for building other 'PrefixScheme's.
 diff --git a/llvm-general/Setup.hs b/llvm-general/Setup.hs
 index 4a833ae..d9cb25d 100644
 --- a/llvm-general/Setup.hs
 +++ b/llvm-general/Setup.hs
 @@ -17,16 +17,17 @@ import Distribution.Version
  import System.Environment
  import System.SetEnv
  import Distribution.System
 +import Distribution.Types.CondTree

  -- define these selectively in C files (where _not_ using HsFFI.h),
  -- rather than universally in the ccOptions, because HsFFI.h currently
 defines them
  -- without checking they're already defined and so causes warnings.
  uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"]

 -llvmVersion = Version [3,5] []
 +llvmVersion = mkVersion [3,5]

  llvmConfigNames = [
 -  "llvm-config-" ++ (intercalate "." . map show . versionBranch $
 llvmVersion),
 +  "llvm-config-" ++ (intercalate "." . map show . versionNumbers $
 llvmVersion),
    "llvm-config"
   ]

 @@ -67,7 +68,7 @@ instance OldHookable (Args -> PackageDescription ->
 LocalBuildInfo -> UserHooks
  llvmProgram :: Program
  llvmProgram = (simpleProgram "llvm-config") {
    programFindLocation = programSearch (programFindLocation .
 simpleProgram),
 -  programFindVersion =
 +  programFindVersion =
      let
        stripSuffix suf str = let r = reverse in liftM r (stripPrefix (r
 suf) (r str))
        svnToTag v = maybe v (++"-svn") (stripSuffix "svn" v)
 @@ -98,10 +99,10 @@ addLLVMToLdLibraryPath configFlags = do
    llvmConfig <- getLLVMConfig configFlags
    [libDir] <- liftM lines $ llvmConfig "--libdir"
    addToLdLibraryPath libDir
 -
 +
  main = do
    let origUserHooks = simpleUserHooks
 -
 +
    defaultMainWithHooks origUserHooks {
      hookedPrograms = [ llvmProgram ],

 @@ -128,12 +129,12 @@ main = do
                      libBuildInfo = mempty { ccOptions = llvmCppFlags }
                    },
                  condTreeComponents = condTreeComponents libraryCondTree
 ++ [
 -                  (
 -                    Var (Flag (FlagName "shared-llvm")),
 -                    CondNode (mempty { libBuildInfo = mempty { extraLibs
 = [sharedLib] ++ systemLibs } }) [] [],
 -                    Just (CondNode (mempty { libBuildInfo = mempty {
 extraLibs = staticLibs ++ systemLibs } }) [] [])
 -                  )
 -                ]
 +                  CondBranch {
 +                    condBranchCondition = Var (Flag (mkFlagName "shared-
 llvm")),
 +                    condBranchIfTrue    = CondNode (mempty { libBuildInfo
 = mempty { extraLibs = [sharedLib] ++ systemLibs } }) [] [],
 +                    condBranchIfFalse   = Just (CondNode (mempty {
 libBuildInfo = mempty { extraLibs = staticLibs ++ systemLibs } }) [] [])
 +                  }
 +                ]
                }
             }
            configFlags' = configFlags {
 diff --git a/llvm-general/llvm-general.cabal b/llvm-general/llvm-
 general.cabal
 index 05d7554..251c333 100644
 --- a/llvm-general/llvm-general.cabal
 +++ b/llvm-general/llvm-general.cabal
 @@ -53,6 +53,9 @@ flag debug
    description: compile C(++) shims with debug info for ease of
 troubleshooting
    default: False

 +custom-setup
 +  setup-depends: base, Cabal, containers, setenv
 +
  library
    build-tools: llvm-config
    ghc-options: -fwarn-unused-imports
 diff --git a/llvm-general/src/Control/Monad/Exceptable.hs b/llvm-
 general/src/Control/Monad/Exceptable.hs
 index 258797d..b12f2df 100644
 --- a/llvm-general/src/Control/Monad/Exceptable.hs
 +++ b/llvm-general/src/Control/Monad/Exceptable.hs
 @@ -150,8 +150,10 @@ instance (Read e, Read1 m, Read a) => Read
 (ExceptableT e m a) where
  instance (Show e, Show1 m, Show a) => Show (ExceptableT e m a) where
      showsPrec d (ExceptableT m) = showsUnary1 "ExceptableT" d m

 +{-
  instance (Read e, Read1 m) => Read1 (ExceptableT e m) where readsPrec1 =
 readsPrec
  instance (Show e, Show1 m) => Show1 (ExceptableT e m) where showsPrec1 =
 showsPrec
 +-}

  runExceptableT :: ExceptableT e m a -> m (Either e a)
  runExceptableT =  Except.runExceptT . unExceptableT
 diff --git a/llvm-general/src/LLVM/General/Internal/FFI/PassManager.hs b
 /llvm-general/src/LLVM/General/Internal/FFI/PassManager.hs
 index 3aaaad5..df4da78 100644
 --- a/llvm-general/src/LLVM/General/Internal/FFI/PassManager.hs
 +++ b/llvm-general/src/LLVM/General/Internal/FFI/PassManager.hs
 @@ -75,15 +75,15 @@ $(do
                              | h == ''FilePath -> [t| NothingAsEmptyString
 CString |]
                    _ -> typeMapping t
                _ -> typeMapping t
 -        foreignDecl
 +        foreignDecl
            (cName n)
            ("add" ++ n ++ "Pass")
 -          ([[t| Ptr PassManager |]]
 +          ([[t| Ptr PassManager |]]
             ++ [[t| Ptr TargetMachine |] | needsTargetMachine n]
             ++ map passTypeMapping extraParams)
            (TH.tupleT 0)

 -  TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''G.Pass
 +  TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''G.Pass
    liftM concat $ forM cons $ \con -> case con of
      TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ]
      TH.NormalC n [] -> declareForeign n []
 @@ -93,37 +93,37 @@ $(do
  data PassManagerBuilder

  foreign import ccall unsafe "LLVMPassManagerBuilderCreate"
 passManagerBuilderCreate ::
 -    IO (Ptr PassManagerBuilder)
 +    IO (Ptr PassManagerBuilder)

  foreign import ccall unsafe "LLVMPassManagerBuilderDispose"
 passManagerBuilderDispose ::
      Ptr PassManagerBuilder -> IO ()

  foreign import ccall unsafe "LLVMPassManagerBuilderSetOptLevel"
 passManagerBuilderSetOptLevel ::
 -    Ptr PassManagerBuilder -> CUInt -> IO ()
 +    Ptr PassManagerBuilder -> CUInt -> IO ()

  foreign import ccall unsafe "LLVMPassManagerBuilderSetSizeLevel"
 passManagerBuilderSetSizeLevel ::
      Ptr PassManagerBuilder -> CUInt -> IO ()

  foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnitAtATime"
 passManagerBuilderSetDisableUnitAtATime ::
 -    Ptr PassManagerBuilder -> LLVMBool -> IO ()
 +    Ptr PassManagerBuilder -> LLVMBool -> IO ()

  foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnrollLoops"
 passManagerBuilderSetDisableUnrollLoops ::
      Ptr PassManagerBuilder -> CUInt -> IO ()

  foreign import ccall unsafe
 "LLVMPassManagerBuilderSetDisableSimplifyLibCalls"
 passManagerBuilderSetDisableSimplifyLibCalls ::
 -    Ptr PassManagerBuilder -> LLVMBool -> IO ()
 +    Ptr PassManagerBuilder -> LLVMBool -> IO ()

  foreign import ccall unsafe
 "LLVMPassManagerBuilderUseInlinerWithThreshold"
 passManagerBuilderUseInlinerWithThreshold ::
      Ptr PassManagerBuilder -> CUInt -> IO ()

  foreign import ccall unsafe
 "LLVMPassManagerBuilderPopulateFunctionPassManager"
 passManagerBuilderPopulateFunctionPassManager ::
 -    Ptr PassManagerBuilder -> Ptr PassManager -> IO ()
 +    Ptr PassManagerBuilder -> Ptr PassManager -> IO ()

  foreign import ccall unsafe
 "LLVMPassManagerBuilderPopulateModulePassManager"
 passManagerBuilderPopulateModulePassManager ::
      Ptr PassManagerBuilder -> Ptr PassManager -> IO ()

  foreign import ccall unsafe
 "LLVMPassManagerBuilderPopulateLTOPassManager"
 passManagerBuilderPopulateLTOPassManager ::
 -    Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO
 ()
 +    Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO
 ()

  foreign import ccall unsafe
 "LLVM_General_PassManagerBuilderSetLibraryInfo"
 passManagerBuilderSetLibraryInfo ::
      Ptr PassManagerBuilder -> Ptr TargetLibraryInfo -> IO ()
 diff --git a/llvm-general/src/LLVM/General/Internal/InstructionDefs.hs b
 /llvm-general/src/LLVM/General/Internal/InstructionDefs.hs
 index bf19a90..253fcb7 100644
 --- a/llvm-general/src/LLVM/General/Internal/InstructionDefs.hs
 +++ b/llvm-general/src/LLVM/General/Internal/InstructionDefs.hs
 @@ -27,10 +27,10 @@ import qualified LLVM.General.AST.Constant as A.C

  $(do
     let ctorRecs t = do
 -         TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify t
 +         TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify t
           TH.dataToExpQ (const Nothing) $ [ (TH.nameBase n, rec) |
 rec@(TH.RecC n _) <- cons ]

 -   [d|
 +   [d|
        astInstructionRecs = Map.fromList $(ctorRecs ''A.Instruction)
        astConstantRecs = Map.fromList $(ctorRecs ''A.C.Constant)
      |]
 @@ -53,7 +53,7 @@ outerJoin xs ys = Map.unionWith combine
        combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
        combine _ _ = error "outerJoin: the impossible happened"

 -instrP = TH.QuasiQuoter {
 +instrP = TH.QuasiQuoter {
    TH.quoteExp = undefined,
    TH.quotePat = let m = Map.fromList [ (ID.cAPIName i, ID.cppOpcode i) |
 i <- ID.instructionDefs ]
               in TH.dataToPatQ (const Nothing) . (m Map.!),
 diff --git a/llvm-general/src/LLVM/General/Internal/PassManager.hs b/llvm-
 general/src/LLVM/General/Internal/PassManager.hs
 index fec64f9..ecd3c15 100644
 --- a/llvm-general/src/LLVM/General/Internal/PassManager.hs
 +++ b/llvm-general/src/LLVM/General/Internal/PassManager.hs
 @@ -88,14 +88,14 @@ instance (Monad m, MonadAnyCont IO m) => EncodeM m
 GCOVVersion CString where
  createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager)
  createPassManager pss = flip runAnyContT return $ do
    pm <- liftIO $ FFI.createPassManager
 -  forM_ (dataLayout pss) $ \dl -> liftIO $ withFFIDataLayout dl $
 FFI.addDataLayoutPass pm
 +  forM_ (dataLayout pss) $ \dl -> liftIO $ withFFIDataLayout dl $
 FFI.addDataLayoutPass pm
    forM_ (targetLibraryInfo pss) $ \(TargetLibraryInfo tli) -> do
      liftIO $ FFI.addTargetLibraryInfoPass pm tli
    forM_ (targetMachine pss) $ \(TargetMachine tm) -> liftIO $
 FFI.addAnalysisPasses tm pm
    case pss of
      s@CuratedPassSetSpec {} -> liftIO $ do
        bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose
 $ \b -> do
 -        let handleOption g m = forM_ (m s) (g b <=< encodeM)
 +        let handleOption g m = forM_ (m s) (g b <=< encodeM)
          handleOption FFI.passManagerBuilderSetOptLevel optLevel
          handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel
          handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM
 not . unitAtATime)
 @@ -108,13 +108,13 @@ createPassManager pss = flip runAnyContT return $ do
        let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm'
        forM_ ps $ \p -> $(
          do
 -          TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass
 +          TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''Pass
            TH.caseE [| p |] $ flip map cons $ \con -> do
              let
                (n, fns) = case con of
                              TH.RecC n fs -> (n, [ TH.nameBase fn | (fn,
 _, _) <- fs ])
                              TH.NormalC n [] -> (n, [])
 -              actions =
 +              actions =
                  [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn
 fn) |] | fn <- fns ]
                  ++ [
                   TH.noBindS [|
 }}}

 After doing this, I was able to `cabal new-build` the entirety of `llvm-
 general` without experiencing any sort of panic.

 In light of this, I'm inclined to close this issue. Does everyone agree?

-- 
Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/11764#comment:8
GHC http://www.haskell.org/ghc/
The Glasgow Haskell Compiler