#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