[GHC] #11764: ghc internal error building llvm-general-3.5.1.2
GHC
ghc-devs at haskell.org
Thu Jun 28 14:09:28 UTC 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 at 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
More information about the ghc-tickets
mailing list