From 83d9b3805d271dc361d48187957498b3138ae62a Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Fri, 30 Mar 2012 17:21:45 +0100 Subject: Attempt to detect loops through imported function RULEs This is motivated by the fact that before this change marking e.g. GHC.List.filter as INLINABLE caused the compiler to diverge when you tried to make use of the function. The response is to say that a RULE on an imported function introduces a dependency edge between the FVs of its LHS and RHS for the purposes of computing loop breakers. This will not perfectly prevent all those potential inlinings that could cause the compiler to non-terminate, but it works well enough for the particular case we are interested in. --- compiler/simplCore/OccurAnal.lhs | 111 +++++++++++++++++++++++++++++++++++---- 1 file changed, 102 insertions(+), 9 deletions(-) diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 8056c0eceb..56525b97fa 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -79,6 +79,14 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) -- The RULES and VECTORISE declarations keep things alive! + -- Note [Preventing loops due to imported functions rules] + imp_rules_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] = (initial_uds, []) @@ -86,7 +94,7 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds = (final_usage, bind' ++ binds') where (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env env bind bs_usage + (final_usage, bind') = occAnalBind env env imp_rules_edges bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned @@ -110,12 +118,13 @@ Bindings \begin{code} occAnalBind :: OccEnv -- The incoming OccEnv -> OccEnv -- Same, but trimmed by (binderOf bind) + -> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [CoreBind]) -occAnalBind env _ (NonRec binder rhs) body_usage +occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) @@ -123,15 +132,17 @@ occAnalBind env _ (NonRec binder rhs) body_usage = (body_usage, []) | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) + = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder + -- See Note [Preventing loops due to imported functions rules] -occAnalBind _ env (Rec pairs) body_usage +occAnalBind _ env imp_rules_edges (Rec pairs) body_usage = foldr occAnalRec (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs @@ -144,7 +155,7 @@ occAnalBind _ env (Rec pairs) body_usage sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes nodes :: [Node Details] - nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env bndr_set) pairs + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs \end{code} Note [Dead code] @@ -404,6 +415,86 @@ It's up the programmer not to write silly rules like RULE f x = f x and the example above is just a more complicated version. +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE Rank2Types #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add dependency edges between +the FVS of the rule LHS and the FVS of the rule RHS. We don't do anything special for +RULES on local functions because the standard occurrence analysis stuff is pretty good +at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + Note [Specialising imported functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT for *automatically-generated* rules, the programmer can't be @@ -566,8 +657,8 @@ instance Outputable Details where , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) ]) -makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details -makeNode env bndr_set (bndr, rhs) +makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env imp_rules_edges bndr_set (bndr, rhs) = (details, varUnique bndr, keysUFM node_fvs) where details = ND { nd_bndr = bndr @@ -591,7 +682,9 @@ makeNode env bndr_set (bndr, rhs) is_active = occ_rule_act env :: Activation -> Bool rules = filterOut isBuiltinRule (idCoreRules bndr) rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_fvs = [ (ru_act rule, fvs) + rules_w_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rules_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, fvs) | rule <- rules , let fvs = exprFreeVars (ru_rhs rule) `delVarSetList` ru_bndrs rule @@ -1191,7 +1284,7 @@ occAnal env (Case scrut bndr ty alts) occAnal env (Let bind body) = case occAnal env_body body of { (body_usage, body') -> - case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) -> + case occAnalBind env env_body emptyVarEnv bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} where env_body = trimOccEnv env (bindersOf bind) -- cgit v1.2.1 From a39a19254003f593e49fa0b29c8a10444cc204c2 Mon Sep 17 00:00:00 2001 From: Patrick Palka Date: Fri, 30 Mar 2012 23:03:23 -0400 Subject: Respect package qualifier when validating imports in GHCi (#5979) Signed-off-by: Paolo Capriotti --- ghc/InteractiveUI.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 045c6a6af4..4525942296 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1688,7 +1688,8 @@ checkAdd ii = do IIDecl d -> do let modname = unLoc (ideclName d) - m <- lookupModuleName modname + pkgqual = ideclPkgQual d + m <- GHC.lookupModule modname pkgqual when safe $ do t <- GHC.isModuleTrusted m when (not t) $ -- cgit v1.2.1 From 853c1c3e97dd8bc251c6b56000d7a85a2ca79715 Mon Sep 17 00:00:00 2001 From: "Iavor S. Diatchki" Date: Sat, 31 Mar 2012 12:14:49 -0700 Subject: Add some missing equations for type-literals. --- compiler/types/Unify.lhs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 68a61fd860..50a0fcf39a 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -199,6 +199,8 @@ match menv subst (AppTy ty1a ty1b) ty2 = do { subst' <- match menv subst ty1a ty2a ; match menv subst' ty1b ty2b } +match _ subst (LitTy x) (LitTy y) | x == y = return subst + match _ _ _ _ = Nothing @@ -339,6 +341,8 @@ typesCantMatch prs = any (\(s,t) -> cant_match s t) prs | Just (f1, a1) <- repSplitAppTy_maybe ty1 = cant_match f1 f2 || cant_match a1 a2 + cant_match (LitTy x) (LitTy y) = x /= y + cant_match _ _ = False -- Safe! -- Things we could add; @@ -453,6 +457,8 @@ unify subst ty1 (AppTy ty2a ty2b) = do { subst' <- unify subst ty1a ty2a ; unify subst' ty1b ty2b } +unify subst (LitTy x) (LitTy y) | x == y = return subst + unify _ ty1 ty2 = failWith (misMatch ty1 ty2) -- ForAlls?? -- cgit v1.2.1 From d402d8a61ee729287d417c3355be72c61bb35b78 Mon Sep 17 00:00:00 2001 From: "Iavor S. Diatchki" Date: Sat, 31 Mar 2012 12:15:23 -0700 Subject: Add an entry for -XExplicitNamespaces to the manual. --- docs/users_guide/flags.xml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 73f9414ecc..169dd9d440 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -980,6 +980,12 @@ dynamic + + + Enable using the keyword type to specify the namespace of entries in imports and exports. + dynamic + + Enable recursive do notation. -- cgit v1.2.1 From 05710922ae4c9aa071711051a050f7e8dccf8cc2 Mon Sep 17 00:00:00 2001 From: "Iavor S. Diatchki" Date: Sat, 31 Mar 2012 12:47:25 -0700 Subject: Add a section about promoted literals to the manual. --- docs/users_guide/glasgow_exts.xml | 46 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 53dff29cf1..14d0630145 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -5371,6 +5371,52 @@ Note that this requires . + + + + -- cgit v1.2.1 From 027f282584409008ccae6e1d68d22d649b42ad9e Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 1 Apr 2012 01:35:46 +0100 Subject: Tidy up compiler/ghc.cabal.in We now always have base4, and don't need a workaround for GHC 6.4.2. --- compiler/ghc.cabal.in | 36 ++++++++++-------------------------- 1 file changed, 10 insertions(+), 26 deletions(-) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 20a2e47a6b..4f22f8548f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -20,12 +20,6 @@ Category: Development Build-Type: Simple Cabal-Version: >= 1.2.3 -Flag base4 - Description: Choose the even newer, even smaller, split-up base package. - -Flag base3 - Description: Choose the new smaller, split-up base package. - Flag dynlibs Description: Dynamic library support Default: False @@ -54,26 +48,20 @@ Flag stage3 Library Exposed: False - if flag(base4) - Build-Depends: base >= 4 && < 5 - if flag(base3) - Build-Depends: base >= 3 && < 4 - if !flag(base3) && !flag(base4) - Build-Depends: base < 3 + Build-Depends: base >= 4 && < 5, + directory >= 1 && < 1.2, + process >= 1 && < 1.2, + bytestring >= 0.9 && < 0.11, + time < 1.5, + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5, + filepath >= 1 && < 1.4, + Cabal, + hpc if flag(stage1) && impl(ghc < 7.5) Build-Depends: old-time >= 1 && < 1.2 - if flag(base3) || flag(base4) - Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.2, - bytestring >= 0.9 && < 0.11, - time < 1.5, - containers >= 0.1 && < 0.6, - array >= 0.1 && < 0.5 - - Build-Depends: filepath >= 1 && < 1.4 - Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 else @@ -89,10 +77,6 @@ Library Build-Depends: bin-package-db Build-Depends: hoopl - -- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be - -- able to find WCsubst.h - Include-Dirs: ../libraries/base/cbits, ../libraries/base/include - Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards, ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, MultiParamTypeClasses, -- cgit v1.2.1 From 270b7ce52c22e6daf3c1d6a7c0665350720ac4b1 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 1 Apr 2012 11:55:56 +0100 Subject: Whitespace only in main/Packages.lhs --- compiler/main/Packages.lhs | 327 ++++++++++++++++++++++----------------------- 1 file changed, 160 insertions(+), 167 deletions(-) diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 1d6ad4a472..aa5a432762 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,51 +2,44 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Package manipulation module Packages ( - module PackageConfig, - - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, - - -- * Reading the package config, and processing cmdline args - PackageState(..), - initPackages, - getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPreloadPackagesAnd, + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageState(..), + initPackages, + getPackageDetails, + lookupModuleInAllPackages, lookupModuleWithSuggestions, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - -- * Utils - isDllName + -- * Utils + isDllName ) where #include "HsVersions.h" -import PackageConfig +import PackageConfig import DynFlags import StaticFlags -import Config ( cProjectVersion ) -import Name ( Name, nameModule_maybe ) +import Config ( cProjectVersion ) +import Name ( Name, nameModule_maybe ) import UniqFM import Module import Util @@ -81,12 +74,12 @@ import qualified Data.Set as Set -- -- The package state is computed by 'initPackages', and kept in DynFlags. -- --- * @-package @ causes @@ to become exposed, and all other packages --- with the same name to become hidden. --- +-- * @-package @ causes @@ to become exposed, and all other packages +-- with the same name to become hidden. +-- -- * @-hide-package @ causes @@ to become hidden. --- --- * Let @exposedPackages@ be the set of packages thus exposed. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- @@ -107,28 +100,28 @@ import qualified Data.Set as Set -- Notes on DLLs -- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- The exposed flags are adjusted according to -package and + -- -hide-package flags, and -ignore-package removes packages. preloadPackages :: [PackageId], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. + -- The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping + -- Derived from pkgIdMap. + -- Maps Module to (pkgconf,exposed), where pkgconf is the + -- PackageConfig for the package containing the module, and + -- exposed is True if the package exposes that module. installedPackageIdMap :: InstalledPackageIdMap } @@ -149,7 +142,7 @@ lookupPackage = lookupUFM extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs +extendPackageConfigMap pkg_map new_pkgs = foldl add pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p @@ -175,14 +168,14 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PackageId]) -initPackages dflags = do +initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags Just db -> return $ setBatchPackageFlags dflags db - (pkg_state, preload, this_pkg) + (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, + pkgState = pkg_state, thisPackage = this_pkg }, preload) @@ -195,13 +188,13 @@ readPackageConfigs dflags = do system_pkgconfs <- getSystemPackageConfigs dflags let pkgconfs = case e_pkg_path of - Left _ -> system_pkgconfs - Right path - | last cs == "" -> init cs ++ system_pkgconfs - | otherwise -> cs - where cs = parseSearchPath path - -- if the path ends in a separator (eg. "/foo/bar:") - -- the we tack on the system paths. + Left _ -> system_pkgconfs + Right path + | last cs == "" -> init cs ++ system_pkgconfs + | otherwise -> cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- the we tack on the system paths. pkgs <- mapM (readPackageConfig dflags) (pkgconfs ++ reverse (extraPkgConfs dflags)) @@ -214,16 +207,16 @@ readPackageConfigs dflags = do getSystemPackageConfigs :: DynFlags -> IO [FilePath] getSystemPackageConfigs dflags = do - -- System one always comes first + -- System one always comes first let system_pkgconf = systemPackageConfig dflags - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) - -- unless the -no-user-package-conf flag was given. + -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) + -- unless the -no-user-package-conf flag was given. user_pkgconf <- do if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do appdir <- getAppUserDataDirectory "ghc" - let - dir = appdir (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + let + dir = appdir (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) pkgconf = dir "package.conf.d" -- exist <- doesDirectoryExist pkgconf @@ -236,17 +229,17 @@ readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do isdir <- doesDirectoryExist conf_file - proto_pkg_configs <- + proto_pkg_configs <- if isdir then do let filename = conf_file "package.cache" debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) conf <- readBinPackageDB filename return (map installedPackageInfoToPackageConfig conf) - else do + else do isfile <- doesFileExist conf_file when (not isfile) $ - ghcError $ InstallationError $ + ghcError $ InstallationError $ "can't find a package database at " ++ conf_file debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) str <- readFile conf_file @@ -293,7 +286,7 @@ mungePackagePaths top_dir pkgroot pkg = haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) } - where + where munge_paths = map munge_path munge_urls = map munge_url @@ -340,23 +333,23 @@ applyPackageFlag unusable pkgs flag = case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" ExposePackageId str -> case selectPackages (matchingId str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + where hide p = p {exposed=False} -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted @@ -364,21 +357,21 @@ applyPackageFlag unusable pkgs flag = case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} + where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} + where distrust p = p {trusted=False} _ -> panic "applyPackageFlag" where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p + -- When a package is requested to be exposed, we hide all other + -- packages with the same name. + hideAll name ps = map maybe_hide ps + where maybe_hide p | pkgName (sourcePackageId p) == name = p {exposed=False} | otherwise = p @@ -401,8 +394,8 @@ selectPackages matches pkgs unusable -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool matchingStr str p - = str == display (sourcePackageId p) - || str == display (pkgName (sourcePackageId p)) + = str == display (sourcePackageId p) + || str == display (pkgName (sourcePackageId p)) matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p @@ -424,9 +417,9 @@ packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" `isPrefixOf` pkg - + packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ text "(use -v for more information)") @@ -452,20 +445,20 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] hideOldPackages dflags pkgs = mapM maybe_hide pkgs where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] + | not (exposed p) = return p + | (p' : _) <- later_versions = do + debugTraceMsg dflags 2 $ + (ptext (sLit "hiding package") <+> pprSPkg p <+> + ptext (sLit "to avoid conflict with later version") <+> + pprSPkg p') + return (p {exposed=False}) + | otherwise = return p + where myname = pkgName (sourcePackageId p) + myversion = pkgVersion (sourcePackageId p) + later_versions = [ p | p <- pkgs, exposed p, + let pkg = sourcePackageId p, + pkgName pkg == myname, + pkgVersion pkg > myversion ] -- ----------------------------------------------------------------------------- -- Wired-in packages @@ -494,43 +487,43 @@ findWiredInPackages dflags pkgs = do matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. -- -- When choosing which package to map to a wired-in package -- name, we prefer exposed packages, and pick the latest -- version. To override the default choice, -hide-package -- could be used to hide newer versions. -- - findWiredInPackage :: [PackageConfig] -> String - -> IO (Maybe InstalledPackageId) - findWiredInPackage pkgs wired_pkg = + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe InstalledPackageId) + findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in - case all_ps of - [] -> notfound - many -> pick (head (sortByVersion many)) + case all_ps of + [] -> notfound + many -> pick (head (sortByVersion many)) where notfound = do - debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " not found.") - return Nothing - pick :: InstalledPackageInfo_ ModuleName + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " not found.") + return Nothing + pick :: InstalledPackageInfo_ ModuleName -> IO (Maybe InstalledPackageId) pick pkg = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " mapped to ") - <> pprIPkg pkg - return (Just (installedPackageId pkg)) + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " mapped to ") + <> pprIPkg pkg + return (Just (installedPackageId pkg)) mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let + let wired_in_ids = catMaybes mb_wired_in_ids -- this is old: we used to assume that if there were @@ -541,13 +534,13 @@ findWiredInPackages dflags pkgs = do -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids && package p `notElem` map fst wired_in_ids -} - updateWiredInDependencies pkgs = map upd_pkg pkgs - where upd_pkg p + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg p | installedPackageId p `elem` wired_in_ids = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } | otherwise @@ -650,9 +643,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) case partition (matchingStr str) pkgs of (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- @@ -665,7 +658,7 @@ depClosure index ipids = closure Map.empty ipids closure set [] = Map.keys set closure set (ipid : ipids) | ipid `Map.member` set = closure set ipids - | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) (depends p ++ ipids) | otherwise = closure set ipids @@ -688,7 +681,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do {- Plan. - 1. P = transitive closure of packages selected by -package-id + 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same sourcePackageId, @@ -746,7 +739,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_selected = depClosure ipid_map [ InstalledPackageId i | ExposePackageId i <- flags ] - + (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False @@ -808,7 +801,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload @@ -820,7 +813,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -831,15 +824,15 @@ mkModuleMap mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids where pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg + + extend_modmap pkgid modmap = + addListToUFM_C (++) modmap + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprSPkg :: PackageConfig -> SDoc pprSPkg p = text (display (sourcePackageId p)) @@ -863,7 +856,7 @@ getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs -collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages @@ -876,14 +869,14 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] -getPackageLinkOpts dflags pkgs = +getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] collectLinkOpts dflags ps = concat (map all_opts ps) where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p + libs p = packageHsLibs dflags p ++ extraLibraries p + all_opts p = map ("-l" ++) (libs p) ++ ldOptions p packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) @@ -895,7 +888,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 + ways2 | WayDebug `elem` map wayName ways1 = filter ((/= WayEventLog) . wayName) ways1 | otherwise = ways1 @@ -903,14 +896,14 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id - | otherwise = (++ ("-ghc" ++ cProjectVersion)) + mkDynName | opt_Static = id + | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" - | otherwise = '_':t + | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] @@ -933,7 +926,7 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns +-- | Takes a 'Module', and if the module is in a package returns -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] @@ -968,7 +961,7 @@ lookupModuleWithSuggestions dflags m -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = - let + let state = pkgState dflags pkg_map = pkgIdMap state ipid_map = installedPackageIdMap state @@ -988,8 +981,8 @@ closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) throwErr :: MaybeErr MsgDoc a -> IO a throwErr m = case m of - Failed e -> ghcError (CmdLineError (showSDoc e)) - Succeeded r -> return r + Failed e -> ghcError (CmdLineError (showSDoc e)) + Succeeded r -> return r closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId @@ -998,21 +991,21 @@ closeDepsErr :: PackageConfigMap closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package + | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + Nothing -> Failed (missingPackageMsg (packageIdString p) <> missingDependencyMsg mb_parent) Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_package_ipid ps (depends pkg) - return (p : ps') + -- Add the package's dependents also + ps' <- foldM add_package_ipid ps (depends pkg) + return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map @@ -1049,9 +1042,9 @@ isDllName this_pkg name -- | Show package info on console, if verbosity is >= 3 dumpPackages :: DynFlags -> IO () dumpPackages dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ - vcat (map (text . showInstalledPackageInfo - . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + = do let pkg_map = pkgIdMap (pkgState dflags) + putMsg dflags $ + vcat (map (text . showInstalledPackageInfo + . packageConfigToInstalledPackageInfo) + (eltsUFM pkg_map)) \end{code} -- cgit v1.2.1 From 50e5a06b3d673266a472810a6c5fd3646450ec54 Mon Sep 17 00:00:00 2001 From: Mikhail Vorozhtsov Date: Mon, 2 Apr 2012 18:03:48 +0700 Subject: Fixed typo in b857c8ad which caused NewtypeD to be interpreted as DataD. Signed-off-by: Paolo Capriotti --- compiler/hsSyn/Convert.lhs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 90deaa7edf..7a15120567 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -183,7 +183,7 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = TyData { td_ND = DataType, td_cType = Nothing + ; let defn = TyData { td_ND = NewType, td_cType = Nothing , td_ctxt = ctxt' , td_kindSig = Nothing , td_cons = [con'], td_derivs = derivs' } -- cgit v1.2.1 From dc2f65f6e7c1763d848557708a980df35b755954 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 2 Apr 2012 13:09:10 +0100 Subject: Support qualified identifiers in quasi-quotes (#5555). --- compiler/parser/Lexer.x | 25 ++++++++++++++++++++++++- compiler/parser/Parser.y.pp | 5 +++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 94b2019e9e..378a25c8e1 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -321,6 +321,10 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } "[" @varid "|" / { ifExtension qqEnabled } { lex_quasiquote_tok } + + -- qualified quasi-quote (#5555) + "[" @qual @varid "|" / { ifExtension qqEnabled } + { lex_qquasiquote_tok } } <0> { @@ -562,7 +566,14 @@ data Token | ITidEscape FastString -- $x | ITparenEscape -- $( | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] -- Arrow notation extension | ITproc @@ -1423,6 +1434,18 @@ getCharOrFail i = do -- ----------------------------------------------------------------------------- -- QuasiQuote +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6424dea79f..9774c245e7 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -350,6 +350,7 @@ TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } +TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } @@ -1360,6 +1361,10 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + | TH_QQUASIQUOTE { let { loc = getLoc $1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } -- cgit v1.2.1 From e7e5e277eb58a5ef6207200174e7982fdb9780bb Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 30 Mar 2012 12:30:28 +0100 Subject: Prevent nested TH exceptions from bubbling up to the top level (#5976) --- compiler/typecheck/TcSplice.lhs | 29 ++++++++++++++++++++++++----- compiler/utils/Panic.lhs | 14 +++++++++++++- 2 files changed, 37 insertions(+), 6 deletions(-) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index a345da507f..e535f24d59 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -831,7 +831,7 @@ runMeta show_code run_and_convert expr ; either_hval <- tryM $ liftIO $ HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { - Left exn -> failWithTc (mk_msg "compile and link" exn) ; + Left exn -> fail_with_exn "compile and link" exn ; Right hval -> do { -- Coerce it to Q t, and run it @@ -859,12 +859,16 @@ runMeta show_code run_and_convert expr Right v -> return v Left se -> case fromException se of Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> failWithTc (mk_msg "run" se) -- Exception + _ -> fail_with_exn "run" se -- Exception }}} where - mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", - nest 2 (text (Panic.showException exn)), - if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + -- see Note [Concealed TH exceptions] + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + failWithTc msg \end{code} Note [Exceptions in TH] @@ -896,6 +900,21 @@ like that. Here's how it's processed: - other errors, we add an error to the bag and then fail +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + To call runQ in the Tc monad, we need to make TcM an instance of Quasi: diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index cc3603baeb..0fb206ca77 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -22,7 +22,7 @@ module Panic ( panic, sorry, panicFastInt, assertPanic, trace, - Exception.Exception(..), showException, try, tryMost, throwTo, + Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -113,6 +113,18 @@ short_usage = "Usage: For basic information, try the `--help' option." showException :: Exception e => e -> String showException = show +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. showGhcException :: GhcException -> String -> String -- cgit v1.2.1 From 88d61ccd9450ed41b99136269a97b2c118462fa4 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 3 Apr 2012 10:41:52 +0100 Subject: Improved checks for "dynamic" and "wrapper" foreign declarations (#5664) --- compiler/typecheck/TcForeign.lhs | 6 +++--- compiler/typecheck/TcType.lhs | 43 ++++++++++++++++++++++++++++++---------- 2 files changed, 35 insertions(+), 14 deletions(-) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 7bda323f5b..ab86f36c37 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -219,8 +219,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty - -- ToDo: Why are res1_ty and res_ty not equal? + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) @@ -235,7 +234,8 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta check False (illegalForeignTyErr empty sig_ty) (arg1_ty:arg_tys) -> do dflags <- getDynFlags - check (isFFIDynArgumentTy arg1_ty) + let curried_res_ty = foldr FunTy res_ty arg_tys + check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index e9af2015ba..2c252e0bf2 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -102,8 +102,7 @@ module TcType ( isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool isFFIExternalTy, -- :: Type -> Bool - isFFIDynArgumentTy, -- :: Type -> Bool - isFFIDynResultTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool @@ -1338,15 +1337,22 @@ isFFIImportResultTy dflags ty isFFIExportResultTy :: Type -> Bool isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty -isFFIDynArgumentTy :: Type -> Bool --- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] - -isFFIDynResultTy :: Type -> Bool --- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIDynTy :: Type -> Type -> Bool +-- The type in a foreign import dynamic must be Ptr, FunPtr, Addr, +-- or a newtype of either, and the wrapped function type must be equal +-- to the given type. +-- We assume that all types have been run through normalizeFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = True + | otherwise + = False isFFILabelTy :: Type -> Bool -- The type of a foreign label must be Ptr, FunPtr, Addr, @@ -1401,6 +1407,21 @@ checkRepTyConKey keys = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) \end{code} +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + ---------------------------------------------- These chaps do the work; they are not exported ---------------------------------------------- -- cgit v1.2.1 From 30eee19678455308f6b00a58d8ee4c9790e49502 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 4 Apr 2012 13:38:07 +0100 Subject: Update comments about Addr in foreign declarations. --- compiler/typecheck/TcForeign.lhs | 9 ++++----- compiler/typecheck/TcType.lhs | 8 +++----- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index ab86f36c37..ae8ac26918 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -210,10 +210,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a - -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well - -- as ft -> IO Addr is accepted, too. The use of the latter two forms - -- is DEPRECATED, though. + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of @@ -229,7 +228,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr + case arg_tys of -- The first arg must be Ptr or FunPtr [] -> do check False (illegalForeignTyErr empty sig_ty) (arg1_ty:arg_tys) -> do diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 2c252e0bf2..fc08bad1d1 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1338,9 +1338,8 @@ isFFIExportResultTy :: Type -> Bool isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty isFFIDynTy :: Type -> Type -> Bool --- The type in a foreign import dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either, and the wrapped function type must be equal --- to the given type. +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normalizeFfiType, so we don't -- need to worry about expanding newtypes here. isFFIDynTy expected ty @@ -1355,8 +1354,7 @@ isFFIDynTy expected ty = False isFFILabelTy :: Type -> Bool --- The type of a foreign label must be Ptr, FunPtr, Addr, --- or a newtype of either. +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFIPrimArgumentTy :: DynFlags -> Type -> Bool -- cgit v1.2.1