[Git][ghc/ghc][wip/angerman/lowercase-win32] 6 commits: Allow metric change after reverting "Add Generic tuple instances up to 15-tuple" #16688
Moritz Angermann
gitlab at gitlab.haskell.org
Mon May 27 05:19:57 UTC 2019
Moritz Angermann pushed to branch wip/angerman/lowercase-win32 at Glasgow Haskell Compiler / GHC
Commits:
c931f256 by David Eichmann at 2019-05-24T10:22:29Z
Allow metric change after reverting "Add Generic tuple instances up to 15-tuple" #16688
Metrics increased on commit 5eb9445444c4099fc9ee0803ba45db390900a80f and
decreased on revert commit 535a26c90f458801aeb1e941a3f541200d171e8f.
Metric Decrease:
T9630
haddock.base
- - - - -
d9dfbde3 by Michael Sloan at 2019-05-24T15:55:07Z
Add PlainPanic for throwing exceptions without depending on pprint
This commit splits out a subset of GhcException which do not depend on
pretty printing (SDoc), as a new datatype called
PlainGhcException. These exceptions can be caught as GhcException,
because 'fromException' will convert them.
The motivation for this change is that that the Panic module
transitively depends on many modules, primarily due to pretty printing
code. It's on the order of about 130 modules. This large set of
dependencies has a few implications:
1. To avoid cycles / use of boot files, these dependencies cannot
throw GhcException.
2. There are some utility modules that use UnboxedTuples and also use
`panic`. This means that when loading GHC into GHCi, about 130
additional modules would need to be compiled instead of
interpreted. Splitting the non-pprint exception throwing into a new
module resolves this issue. See #13101
- - - - -
70c24471 by Moritz Angermann at 2019-05-25T21:51:30Z
Add `keepCAFs` to RtsSymbols
- - - - -
9be1749d by David Eichmann at 2019-05-25T21:55:05Z
Hadrian: Add Mising Libffi Dependencies #16653
Libffi is ultimately built from a single archive file (e.g.
libffi-tarballs/libffi-3.99999+git20171002+77e130c.tar.gz).
The file can be seen as the shallow dependency for the whole
libffi build. Hence, in all libffi rules, the archive is
`need`ed and the build directory is `trackAllow`ed.
- - - - -
2d0cf625 by Sandy Maguire at 2019-05-26T12:57:20Z
Let the specialiser work on dicts under lambdas
Following the discussion under #16473, this change allows the
specializer to work on any dicts in a lambda, not just those that occur
at the beginning.
For example, if you use data types which contain dictionaries and
higher-rank functions then once these are erased by the optimiser you
end up with functions such as:
```
go_s4K9
Int#
-> forall (m :: * -> *).
Monad m =>
(forall x. Union '[State (Sum Int)] x -> m x) -> m ()
```
The dictionary argument is after the Int# value argument, this patch
allows `go` to be specialised.
- - - - -
4b228768 by Moritz Angermann at 2019-05-27T05:19:49Z
Lowercase windows imports
While windows and macOS are currently on case-insensitive file
systems, this poses no issue on those. When cross compiling from
linux with a case sensitive file system and mingw providing only
lowercase headers, this in fact produces an issue. As such we just
lowercase the import headers, which should still work fine on a
case insensitive file system and also enable mingw's headers to
be usable porperly.
- - - - -
22 changed files:
- compiler/basicTypes/UniqSupply.hs
- compiler/ghc.cabal.in
- compiler/iface/BinFingerprint.hs
- compiler/specialise/Specialise.hs
- compiler/utils/Binary.hs
- compiler/utils/FastString.hs
- compiler/utils/Panic.hs
- + compiler/utils/PlainPanic.hs
- compiler/utils/Pretty.hs
- compiler/utils/StringBuffer.hs
- compiler/utils/Util.hs
- driver/utils/dynwrapper.c
- hadrian/src/Rules/Libffi.hs
- includes/CodeGen.Platform.hs
- rts/RtsSymbols.c
- rules/build-prog.mk
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/T16473.hs
- + testsuite/tests/perf/compiler/T16473.stdout
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/simplCore/should_compile/T7785.stderr
- testsuite/tests/warnings/should_compile/T16282/T16282.stderr
Changes:
=====================================
compiler/basicTypes/UniqSupply.hs
=====================================
@@ -37,7 +37,7 @@ module UniqSupply (
import GhcPrelude
import Unique
-import Panic (panic)
+import PlainPanic (panic)
import GHC.IO
=====================================
compiler/ghc.cabal.in
=====================================
@@ -558,6 +558,7 @@ Library
Outputable
Pair
Panic
+ PlainPanic
PprColour
Pretty
State
=====================================
compiler/iface/BinFingerprint.hs
=====================================
@@ -15,7 +15,7 @@ import GhcPrelude
import Fingerprint
import Binary
import Name
-import Panic
+import PlainPanic
import Util
fingerprintBinMem :: BinHandle -> IO Fingerprint
=====================================
compiler/specialise/Specialise.hs
=====================================
@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
module Specialise ( specProgram, specUnfolding ) where
#include "HsVersions.h"
@@ -25,13 +26,13 @@ import VarEnv
import CoreSyn
import Rules
import CoreOpt ( collectBindersPushingCo )
-import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast )
+import CoreUtils ( exprIsTrivial, mkCast, exprType )
import CoreFVs
import CoreArity ( etaExpandToJoinPointRule )
import UniqSupply
import Name
import MkId ( voidArgId, voidPrimId )
-import Maybes ( catMaybes, isJust )
+import Maybes ( mapMaybe, isJust )
import MonadUtils ( foldlM )
import BasicTypes
import HscTypes
@@ -42,6 +43,7 @@ import Outputable
import FastString
import State
import UniqDFM
+import TyCoRep (TyCoBinder (..))
import Control.Monad
import qualified Control.Monad.Fail as MonadFail
@@ -631,6 +633,190 @@ bitten by such instances to revert to the pre-7.10 behavior.
See #10491
-}
+-- | An argument that we might want to specialise.
+-- See Note [Specialising Calls] for the nitty gritty details.
+data SpecArg
+ =
+ -- | Type arguments that should be specialised, due to appearing
+ -- free in the type of a 'SpecDict'.
+ SpecType Type
+ -- | Type arguments that should remain polymorphic.
+ | UnspecType
+ -- | Dictionaries that should be specialised.
+ | SpecDict DictExpr
+ -- | Value arguments that should not be specialised.
+ | UnspecArg
+
+instance Outputable SpecArg where
+ ppr (SpecType t) = text "SpecType" <+> ppr t
+ ppr UnspecType = text "UnspecType"
+ ppr (SpecDict d) = text "SpecDict" <+> ppr d
+ ppr UnspecArg = text "UnspecArg"
+
+getSpecDicts :: [SpecArg] -> [DictExpr]
+getSpecDicts = mapMaybe go
+ where
+ go (SpecDict d) = Just d
+ go _ = Nothing
+
+getSpecTypes :: [SpecArg] -> [Type]
+getSpecTypes = mapMaybe go
+ where
+ go (SpecType t) = Just t
+ go _ = Nothing
+
+isUnspecArg :: SpecArg -> Bool
+isUnspecArg UnspecArg = True
+isUnspecArg UnspecType = True
+isUnspecArg _ = False
+
+isValueArg :: SpecArg -> Bool
+isValueArg UnspecArg = True
+isValueArg (SpecDict _) = True
+isValueArg _ = False
+
+-- | Given binders from an original function 'f', and the 'SpecArg's
+-- corresponding to its usage, compute everything necessary to build
+-- a specialisation.
+--
+-- We will use a running example. Consider the function
+--
+-- foo :: forall a b. Eq a => Int -> blah
+-- foo @a @b dEqA i = blah
+--
+-- which is called with the 'CallInfo'
+--
+-- [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]
+--
+-- We'd eventually like to build the RULE
+--
+-- RULE "SPEC foo @T1 _"
+-- forall @a @b (dEqA' :: Eq a).
+-- foo @T1 @b dEqA' = $sfoo @b
+--
+-- and the specialisation '$sfoo'
+--
+-- $sfoo :: forall b. Int -> blah
+-- $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah
+--
+-- The cases for 'specHeader' below are presented in the same order as this
+-- running example. The result of 'specHeader' for this example is as follows:
+--
+-- ( -- Returned arguments
+-- env + [a -> T1, deqA -> dEqA']
+-- , []
+--
+-- -- RULE helpers
+-- , [b, dx', i]
+-- , [T1, b, dx', i]
+--
+-- -- Specialised function helpers
+-- , [b, i]
+-- , [dx]
+-- , [T1, b, dx_spec, i]
+-- )
+specHeader
+ :: SpecEnv
+ -> [CoreBndr] -- The binders from the original function 'f'
+ -> [SpecArg] -- From the CallInfo
+ -> SpecM ( -- Returned arguments
+ SpecEnv -- Substitution to apply to the body of 'f'
+ , [CoreBndr] -- All the remaining unspecialised args from the original function 'f'
+
+ -- RULE helpers
+ , [CoreBndr] -- Binders for the RULE
+ , [CoreArg] -- Args for the LHS of the rule
+
+ -- Specialised function helpers
+ , [CoreBndr] -- Binders for $sf
+ , [DictBind] -- Auxiliary dictionary bindings
+ , [CoreExpr] -- Specialised arguments for unfolding
+ )
+
+-- We want to specialise on type 'T1', and so we must construct a substitution
+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
+-- details.
+specHeader env (bndr : bndrs) (SpecType t : args)
+ = do { let env' = extendTvSubstList env [(bndr, t)]
+ ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( env''
+ , unused_bndrs
+ , rule_bs
+ , Type t : rule_es
+ , bs'
+ , dx
+ , Type t : spec_args
+ )
+ }
+
+-- Next we have a type that we don't want to specialise. We need to perform
+-- a substitution on it (in case the type refers to 'a'). Additionally, we need
+-- to produce a binder, LHS argument and RHS argument for the resulting rule,
+-- /and/ a binder for the specialised body.
+specHeader env (bndr : bndrs) (UnspecType : args)
+ = do { let (env', bndr') = substBndr env bndr
+ ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( env''
+ , unused_bndrs
+ , bndr' : rule_bs
+ , varToCoreExpr bndr' : rule_es
+ , bndr' : bs'
+ , dx
+ , varToCoreExpr bndr' : spec_args
+ )
+ }
+
+-- Next we want to specialise the 'Eq a' dict away. We need to construct
+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
+-- the nitty-gritty), as a LHS rule and unfolding details.
+specHeader env (bndr : bndrs) (SpecDict d : args)
+ = do { inst_dict_id <- newDictBndr env bndr
+ ; let (rhs_env2, dx_binds, spec_dict_args')
+ = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]
+ ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader rhs_env2 bndrs args
+ ; pure ( env'
+ , unused_bndrs
+ -- See Note [Evidence foralls]
+ , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs
+ , varToCoreExpr inst_dict_id : rule_es
+ , bs'
+ , dx_binds ++ dx
+ , spec_dict_args' ++ spec_args
+ )
+ }
+
+-- Finally, we have the unspecialised argument 'i'. We need to produce
+-- a binder, LHS and RHS argument for the RULE, and a binder for the
+-- specialised body.
+--
+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is
+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that
+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
+-- this case must be here.
+specHeader env (bndr : bndrs) (UnspecArg : args)
+ = do { let (env', bndr') = substBndr env bndr
+ ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( env''
+ , unused_bndrs
+ , bndr' : rule_bs
+ , varToCoreExpr bndr' : rule_es
+ , bndr' : bs'
+ , dx
+ , varToCoreExpr bndr' : spec_args
+ )
+ }
+
+-- Return all remaining binders from the original function. These have the
+-- invariant that they should all correspond to unspecialised arguments, so
+-- it's safe to stop processing at this point.
+specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])
+specHeader env [] _ = pure (env, [], [], [], [], [], [])
+
+
-- | Specialise a set of calls to imported bindings
specImports :: DynFlags
-> Module
@@ -1171,8 +1357,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
specCalls mb_mod env existing_rules calls_for_me fn rhs
-- The first case is the interesting one
- | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
- && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args
+ | callSpecArity pis <= fn_arity -- See Note [Specialisation Must Preserve Sharing]
&& notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
-- Don't specialise NOINLINE things
@@ -1193,15 +1378,14 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
where
- _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
- , ppr rhs_bndrs, ppr n_dicts
+ _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs
, ppr (idInlineActivation fn) ]
fn_type = idType fn
fn_arity = idArity fn
fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here
- (tyvars, theta, _) = tcSplitSigmaTy fn_type
- n_tyvars = length tyvars
+ pis = fst $ splitPiTys fn_type
+ theta = getTheta pis
n_dicts = length theta
inl_prag = idInlinePragma fn
inl_act = inlinePragmaActivation inl_prag
@@ -1212,10 +1396,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
- (rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs
- (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1
- body = mkLams rhs_bndrs2 rhs_body
- -- Glue back on the non-dict lambdas
+ rhs_tyvars = filter isTyVar rhs_bndrs
in_scope = CoreSubst.substInScope (se_subst env)
@@ -1227,59 +1408,19 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- NB: we look both in the new_rules (generated by this invocation
-- of specCalls), and in existing_rules (passed in to specCalls)
- mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
- mk_ty_args [] poly_tvs
- = ASSERT( null poly_tvs ) []
- mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
- = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
- mk_ty_args (Just ty : call_ts) poly_tvs
- = Type ty : mk_ty_args call_ts poly_tvs
- mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
-
----------------------------------------------------------
-- Specialise to one particular call pattern
spec_call :: SpecInfo -- Accumulating parameter
-> CallInfo -- Call instance
-> SpecM SpecInfo
spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)
- (CI { ci_key = CallKey call_ts, ci_args = call_ds })
- = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
-
- -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs
- -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
-
- -- Construct the new binding
- -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
- -- PLUS the rule
- -- RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b
- -- In the rule, d1' and d2' are just wildcards, not used in the RHS
- -- PLUS the usage-details
- -- { d1' = dx1; d2' = dx2 }
- -- where d1', d2' are cloned versions of d1,d2, with the type substitution
- -- applied. These auxiliary bindings just avoid duplication of dx1, dx2
- --
- -- Note that the substitution is applied to the whole thing.
- -- This is convenient, but just slightly fragile. Notably:
- -- * There had better be no name clashes in a/b/c
- do { let
- -- poly_tyvars = [b] in the example above
- -- spec_tyvars = [a,c]
- -- ty_args = [t1,b,t3]
- spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
- env1 = extendTvSubstList env spec_tv_binds
- (rhs_env, poly_tyvars) = substBndrs env1
- [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
-
- -- Clone rhs_dicts, including instantiating their types
- ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids
- ; let (rhs_env2, dx_binds, spec_dict_args)
- = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids
- ty_args = mk_ty_args call_ts poly_tyvars
- ev_args = map varToCoreExpr inst_dict_ids -- ev_args, ev_bndrs:
- ev_bndrs = exprsFreeIdsList ev_args -- See Note [Evidence foralls]
- rule_args = ty_args ++ ev_args
- rule_bndrs = poly_tyvars ++ ev_bndrs
+ (CI { ci_key = call_args, ci_arity = call_arity })
+ = ASSERT(call_arity <= fn_arity)
+ -- See Note [Specialising Calls]
+ do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)
+ <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args
+ ; let rhs_body' = mkLams unused_bndrs rhs_body
; dflags <- getDynFlags
; if already_covered dflags rules_acc rule_args
then return spec_acc
@@ -1288,25 +1429,28 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- , ppr dx_binds ]) $
do
{ -- Figure out the type of the specialised function
- let body_ty = applyTypeToArgs rhs fn_type rule_args
- (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted
+ let body = mkLams unspec_bndrs rhs_body'
+ body_ty = substTy rhs_env2 $ exprType body
+ (lam_extra_args, app_args) -- See Note [Specialisations Must Be Lifted]
| isUnliftedType body_ty -- C.f. WwLib.mkWorkerArgs
, not (isJoinId fn)
- = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
- | otherwise = (poly_tyvars, poly_tyvars)
- spec_id_ty = mkLamTypes lam_args body_ty
+ = ([voidArgId], unspec_bndrs ++ [voidPrimId])
+ | otherwise = ([], unspec_bndrs)
join_arity_change = length app_args - length rule_args
spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
= Just (orig_join_arity + join_arity_change)
| otherwise
= Nothing
+ ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)
+ ; let spec_id_ty = exprType spec_rhs
; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity
- ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
; this_mod <- getModule
; let
-- The rule to put in the function's specialisation is:
- -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b
+ -- forall x @b d1' d2'.
+ -- f x @T1 @b @T2 d1' d2' = f1 x @b
+ -- See Note [Specialising Calls]
herald = case mb_mod of
Nothing -- Specialising local fn
-> text "SPEC"
@@ -1315,7 +1459,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
rule_name = mkFastString $ showSDoc dflags $
herald <+> ftext (occNameFS (getOccName fn))
- <+> hsep (map ppr_call_key_ty call_ts)
+ <+> hsep (mapMaybe ppr_call_key_ty call_args)
-- This name ends up in interface files, so use occNameString.
-- Otherwise uniques end up there, making builds
-- less deterministic (See #4012 comment:61 ff)
@@ -1338,6 +1482,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
Nothing -> rule_wout_eta
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ -- See Note [Specialising Calls]
spec_uds = foldr consDictBind rhs_uds dx_binds
--------------------------------------
@@ -1352,11 +1497,9 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
- = (inl_prag, specUnfolding dflags poly_tyvars spec_app
- arity_decrease fn_unf)
+ = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf)
- arity_decrease = length spec_dict_args
- spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args
+ spec_app e = e `mkApps` spec_args
--------------------------------------
-- Adding arity information just propagates it a bit faster
@@ -1368,13 +1511,116 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
`setIdUnfolding` spec_unf
`asJoinId_maybe` spec_join_arity
- ; return ( spec_rule : rules_acc
+ _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty
+ , ppr rhs_bndrs, ppr call_args
+ , ppr spec_rule
+ ]
+
+ ; -- pprTrace "spec_call: rule" _rule_trace_doc
+ return ( spec_rule : rules_acc
, (spec_f_w_arity, spec_rhs) : pairs_acc
, spec_uds `plusUDs` uds_acc
) } }
-{- Note [Account for casts in binding]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Specialisation Must Preserve Sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a function:
+
+ f :: forall a. Eq a => a -> blah
+ f =
+ if expensive
+ then f1
+ else f2
+
+As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'
+at 'Int', eg:
+
+ $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)
+
+ RULE "SPEC f"
+ forall (d :: Eq Int).
+ f Int _ = $sfIntf
+
+We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!
+
+To avoid this, we only generate specialisations for functions whose arity is
+enough to bind all of the arguments we need to specialise. This ensures our
+specialised functions don't do any work before receiving all of their dicts,
+and thus avoids the 'f' case above.
+
+Note [Specialisations Must Be Lifted]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a function 'f':
+
+ f = forall a. Eq a => Array# a
+
+used like
+
+ case x of
+ True -> ...f @Int dEqInt...
+ False -> 0
+
+Naively, we might generate an (expensive) specialisation
+
+ $sfInt :: Array# Int
+
+even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to
+the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to
+preserve laziness.
+
+Note [Specialising Calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a function:
+
+ f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux
+ f = \x -> /\ a b c -> \d1 d2 bar -> rhs
+
+and suppose it is called at:
+
+ f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar
+
+This call is described as a 'CallInfo' whose 'ci_key' is
+
+ [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1
+ , SpecDict dFooT3, UnspecArg ]
+
+Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?
+Because we must specialise the function on type variables that appear
+free in its *dictionary* arguments; but not on type variables that do not
+appear in any dictionaries, i.e. are fully polymorphic.
+
+Because this call has dictionaries applied, we'd like to specialise
+the call on any type argument that appears free in those dictionaries.
+In this case, those are (a ~ T1, c ~ T3).
+
+As a result, we'd like to generate a function:
+
+ $sf :: Int -> forall b. Bar -> Qux
+ $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)
+
+Note that the substitution is applied to the whole thing. This is
+convenient, but just slightly fragile. Notably:
+ * There had better be no name clashes in a/b/c
+
+We must construct a rewrite rule:
+
+ RULE "SPEC f @T1 _ @T3"
+ forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).
+ f x @T1 @b @T3 d1' d2' = $sf x @b
+
+In the rule, d1' and d2' are just wildcards, not used in the RHS. Note
+additionally that 'bar' isn't captured by this rule --- we bind only
+enough etas in order to capture all of the *specialised* arguments.
+
+Finally, we must also construct the usage-details
+
+ { d1' = dx1; d2' = dx2 }
+
+where d1', d2' are cloned versions of d1,d2, with the type substitution
+applied. These auxiliary bindings just avoid duplication of dx1, dx2.
+
+Note [Account for casts in binding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f :: Eq a => a -> IO ()
{-# INLINABLE f
@@ -1888,16 +2134,14 @@ data CallInfoSet = CIS Id (Bag CallInfo)
-- These dups are eliminated by already_covered in specCalls
data CallInfo
- = CI { ci_key :: CallKey -- Type arguments
- , ci_args :: [DictExpr] -- Dictionary arguments
- , ci_fvs :: VarSet -- Free vars of the ci_key and ci_args
+ = CI { ci_key :: [SpecArg] -- All arguments
+ , ci_arity :: Int -- The number of variables necessary to bind
+ -- all of the specialised arguments
+ , ci_fvs :: VarSet -- Free vars of the ci_key
-- call (including tyvars)
-- [*not* include the main id itself, of course]
}
-newtype CallKey = CallKey [Maybe Type]
- -- Nothing => unconstrained type argument
-
type DictExpr = CoreExpr
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
@@ -1911,16 +2155,15 @@ pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo fn (CI { ci_key = key })
= ppr fn <+> ppr key
-ppr_call_key_ty :: Maybe Type -> SDoc
-ppr_call_key_ty Nothing = char '_'
-ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
-
-instance Outputable CallKey where
- ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))
+ppr_call_key_ty :: SpecArg -> Maybe SDoc
+ppr_call_key_ty (SpecType ty) = Just $ char '@' <+> pprParendType ty
+ppr_call_key_ty UnspecType = Just $ char '_'
+ppr_call_key_ty (SpecDict _) = Nothing
+ppr_call_key_ty UnspecArg = Nothing
instance Outputable CallInfo where
- ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })
- = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])
+ ppr (CI { ci_key = key, ci_fvs = fvs })
+ = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ])
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
@@ -1939,17 +2182,29 @@ callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS _ call_info) =
foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
+computeArity :: [SpecArg] -> Int
+computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg
+
+callSpecArity :: [TyCoBinder] -> Int
+callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder
+
+getTheta :: [TyCoBinder] -> [PredType]
+getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)
+
+
------------------------------------------------------------
-singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
-singleCall id tys dicts
+singleCall :: Id -> [SpecArg] -> UsageDetails
+singleCall id args
= MkUD {ud_binds = emptyBag,
ud_calls = unitDVarEnv id $ CIS id $
- unitBag (CI { ci_key = CallKey tys
- , ci_args = dicts
+ unitBag (CI { ci_key = args -- used to be tys
+ , ci_arity = computeArity args
, ci_fvs = call_fvs }) }
where
+ tys = getSpecTypes args
+ dicts = getSpecDicts args
call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
- tys_fvs = tyCoVarsOfTypes (catMaybes tys)
+ tys_fvs = tyCoVarsOfTypes tys
-- The type args (tys) are guaranteed to be part of the dictionary
-- types, because they are just the constrained types,
-- and the dictionary is therefore sure to be bound
@@ -1973,8 +2228,8 @@ mkCallUDs' env f args
= emptyUDs
| not (all type_determines_value theta)
- || not (spec_tys `lengthIs` n_tyvars)
- || not ( dicts `lengthIs` n_dicts)
+ || not (computeArity ci_key <= idArity f)
+ || not (length dicts == length theta)
|| not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments]
-- See also Note [Specialisations already covered]
= -- pprTrace "mkCallUDs: discarding" _trace_doc
@@ -1982,27 +2237,28 @@ mkCallUDs' env f args
| otherwise
= -- pprTrace "mkCallUDs: keeping" _trace_doc
- singleCall f spec_tys dicts
+ singleCall f ci_key
where
- _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
- , ppr (map (interestingDict env) dicts)]
- (tyvars, theta, _) = tcSplitSigmaTy (idType f)
- constrained_tyvars = tyCoVarsOfTypes theta
- n_tyvars = length tyvars
- n_dicts = length theta
-
- spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]
- dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
-
- -- ignores Coercion arguments
- type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]
- type_zip tvs (Coercion _ : args) = type_zip tvs args
- type_zip (tv:tvs) (Type ty : args) = (tv, ty) : type_zip tvs args
- type_zip _ _ = []
-
- mk_spec_ty tyvar ty
- | tyvar `elemVarSet` constrained_tyvars = Just ty
- | otherwise = Nothing
+ _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]
+ pis = fst $ splitPiTys $ idType f
+ theta = getTheta pis
+ constrained_tyvars = tyCoVarsOfTypes theta
+
+ ci_key :: [SpecArg]
+ ci_key = fmap (\(t, a) ->
+ case t of
+ Named (binderVar -> tyVar)
+ | tyVar `elemVarSet` constrained_tyvars
+ -> case a of
+ Type ty -> SpecType ty
+ _ -> pprPanic "ci_key" $ ppr a
+ | otherwise
+ -> UnspecType
+ Anon InvisArg _ -> SpecDict a
+ Anon VisArg _ -> UnspecArg
+ ) $ zip pis args
+
+ dicts = getSpecDicts ci_key
want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))
-- For imported things, we gather call instances if
=====================================
compiler/utils/Binary.hs
=====================================
@@ -64,7 +64,7 @@ import GhcPrelude
import {-# SOURCE #-} Name (Name)
import FastString
-import Panic
+import PlainPanic
import UniqFM
import FastMutInt
import Fingerprint
=====================================
compiler/utils/FastString.hs
=====================================
@@ -101,7 +101,7 @@ import GhcPrelude as Prelude
import Encoding
import FastFunctions
-import Panic
+import PlainPanic
import Util
import Control.Concurrent.MVar
=====================================
compiler/utils/Panic.hs
=====================================
@@ -14,7 +14,7 @@ module Panic (
GhcException(..), showGhcException,
throwGhcException, throwGhcExceptionIO,
handleGhcException,
- progName,
+ PlainPanic.progName,
pgmError,
panic, sorry, assertPanic, trace,
@@ -27,20 +27,19 @@ module Panic (
withSignalHandlers,
) where
-#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
+import PlainPanic
-import Config
import Exception
import Control.Monad.IO.Class
import Control.Concurrent
+import Data.Typeable ( cast )
import Debug.Trace ( trace )
import System.IO.Unsafe
-import System.Environment
#if !defined(mingw32_HOST_OS)
import System.Posix.Signals as S
@@ -50,7 +49,6 @@ import System.Posix.Signals as S
import GHC.ConsoleHandler as S
#endif
-import GHC.Stack
import System.Mem.Weak ( deRefWeak )
-- | GHC's own exception type
@@ -91,25 +89,25 @@ data GhcException
| ProgramError String
| PprProgramError String SDoc
-instance Exception GhcException
+instance Exception GhcException where
+ fromException (SomeException e)
+ | Just ge <- cast e = Just ge
+ | Just pge <- cast e = Just $
+ case pge of
+ PlainSignal n -> Signal n
+ PlainUsageError str -> UsageError str
+ PlainCmdLineError str -> CmdLineError str
+ PlainPanic str -> Panic str
+ PlainSorry str -> Sorry str
+ PlainInstallationError str -> InstallationError str
+ PlainProgramError str -> ProgramError str
+ | otherwise = Nothing
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
-
--- | The name of this GHC.
-progName :: String
-progName = unsafePerformIO (getProgName)
-{-# NOINLINE progName #-}
-
-
--- | Short usage information to display when we are given the wrong cmd line arguments.
-short_usage :: String
-short_usage = "Usage: For basic information, try the `--help' option."
-
-
-- | Show an exception as a string.
showException :: Exception e => e -> String
showException = show
@@ -134,42 +132,21 @@ safeShowException e = do
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
showGhcException :: GhcException -> ShowS
-showGhcException exception
- = case exception of
- UsageError str
- -> showString str . showChar '\n' . showString short_usage
-
- CmdLineError str -> showString str
- PprProgramError str sdoc ->
- showString str . showString "\n\n" .
- showString (showSDocUnsafe sdoc)
- ProgramError str -> showString str
- InstallationError str -> showString str
- Signal n -> showString "signal: " . shows n
-
- PprPanic s sdoc ->
- panicMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Panic s -> panicMsg (showString s)
-
- PprSorry s sdoc ->
- sorryMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Sorry s -> sorryMsg (showString s)
- where
- sorryMsg :: ShowS -> ShowS
- sorryMsg s =
- showString "sorry! (unimplemented feature or known bug)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
- . s . showString "\n"
-
- panicMsg :: ShowS -> ShowS
- panicMsg s =
- showString "panic! (the 'impossible' happened)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
- . s . showString "\n\n"
- . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-
+showGhcException = showPlainGhcException . \case
+ Signal n -> PlainSignal n
+ UsageError str -> PlainUsageError str
+ CmdLineError str -> PlainCmdLineError str
+ Panic str -> PlainPanic str
+ Sorry str -> PlainSorry str
+ InstallationError str -> PlainInstallationError str
+ ProgramError str -> PlainProgramError str
+
+ PprPanic str sdoc -> PlainPanic $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprSorry str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprProgramError str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
@@ -180,42 +157,11 @@ throwGhcExceptionIO = Exception.throwIO
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
-
--- | Panics and asserts.
-panic, sorry, pgmError :: String -> a
-panic x = unsafeDupablePerformIO $ do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (Panic x)
- else throwGhcException (Panic (x ++ '\n' : renderStack stack))
-
-sorry x = throwGhcException (Sorry x)
-pgmError x = throwGhcException (ProgramError x)
-
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc x doc = throwGhcException (PprPanic x doc)
sorryDoc x doc = throwGhcException (PprSorry x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
-cmdLineError :: String -> a
-cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
-
-cmdLineErrorIO :: String -> IO a
-cmdLineErrorIO x = do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (CmdLineError x)
- else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack))
-
-
-
--- | Throw a failed assertion exception for a given filename and line number.
-assertPanic :: String -> Int -> a
-assertPanic file line =
- Exception.throw (Exception.AssertionFailed
- ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
-
-
-- | Like try, but pass through UserInterrupt and Panic exceptions.
-- Used when we want soft failures when reading interface files, for example.
-- TODO: I'm not entirely sure if this is catching what we really want to catch
=====================================
compiler/utils/PlainPanic.hs
=====================================
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
+
+-- | Defines a simple exception type and utilities to throw it. The
+-- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
+-- type. It omits the exception constructors that involve
+-- pretty-printing via 'Outputable.SDoc'.
+--
+-- There are two reasons for this:
+--
+-- 1. To avoid import cycles / use of boot files. "Outputable" has
+-- many transitive dependencies. To throw exceptions from these
+-- modules, the functions here can be used without introducing import
+-- cycles.
+--
+-- 2. To reduce the number of modules that need to be compiled to
+-- object code when loading GHC into GHCi. See #13101
+module PlainPanic
+ ( PlainGhcException(..)
+ , showPlainGhcException
+
+ , panic, sorry, pgmError
+ , cmdLineError, cmdLineErrorIO
+ , assertPanic
+
+ , progName
+ ) where
+
+#include "HsVersions.h"
+
+import Config
+import Exception
+import GHC.Stack
+import GhcPrelude
+import System.Environment
+import System.IO.Unsafe
+
+-- | This type is very similar to 'Panic.GhcException', but it omits
+-- the constructors that involve pretty-printing via
+-- 'Outputable.SDoc'. Due to the implementation of 'fromException'
+-- for 'Panic.GhcException', this type can be caught as a
+-- 'Panic.GhcException'.
+--
+-- Note that this should only be used for throwing exceptions, not for
+-- catching, as 'Panic.GhcException' will not be converted to this
+-- type when catching.
+data PlainGhcException
+ -- | Some other fatal signal (SIGHUP,SIGTERM)
+ = PlainSignal Int
+
+ -- | Prints the short usage msg after the error
+ | PlainUsageError String
+
+ -- | A problem with the command line arguments, but don't print usage.
+ | PlainCmdLineError String
+
+ -- | The 'impossible' happened.
+ | PlainPanic String
+
+ -- | The user tickled something that's known not to work yet,
+ -- but we're not counting it as a bug.
+ | PlainSorry String
+
+ -- | An installation problem.
+ | PlainInstallationError String
+
+ -- | An error in the user's code, probably.
+ | PlainProgramError String
+
+instance Exception PlainGhcException
+
+instance Show PlainGhcException where
+ showsPrec _ e@(PlainProgramError _) = showPlainGhcException e
+ showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
+ showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
+
+-- | The name of this GHC.
+progName :: String
+progName = unsafePerformIO (getProgName)
+{-# NOINLINE progName #-}
+
+-- | Short usage information to display when we are given the wrong cmd line arguments.
+short_usage :: String
+short_usage = "Usage: For basic information, try the `--help' option."
+
+-- | Append a description of the given exception to this string.
+showPlainGhcException :: PlainGhcException -> ShowS
+showPlainGhcException =
+ \case
+ PlainSignal n -> showString "signal: " . shows n
+ PlainUsageError str -> showString str . showChar '\n' . showString short_usage
+ PlainCmdLineError str -> showString str
+ PlainPanic s -> panicMsg (showString s)
+ PlainSorry s -> sorryMsg (showString s)
+ PlainInstallationError str -> showString str
+ PlainProgramError str -> showString str
+ where
+ sorryMsg :: ShowS -> ShowS
+ sorryMsg s =
+ showString "sorry! (unimplemented feature or known bug)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . s . showString "\n"
+
+ panicMsg :: ShowS -> ShowS
+ panicMsg s =
+ showString "panic! (the 'impossible' happened)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . s . showString "\n\n"
+ . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
+
+throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException = Exception.throw
+
+-- | Panics and asserts.
+panic, sorry, pgmError :: String -> a
+panic x = unsafeDupablePerformIO $ do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainPanic x)
+ else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
+
+sorry x = throwPlainGhcException (PlainSorry x)
+pgmError x = throwPlainGhcException (PlainProgramError x)
+
+cmdLineError :: String -> a
+cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
+
+cmdLineErrorIO :: String -> IO a
+cmdLineErrorIO x = do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainCmdLineError x)
+ else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
+
+-- | Throw a failed assertion exception for a given filename and line number.
+assertPanic :: String -> Int -> a
+assertPanic file line =
+ Exception.throw (Exception.AssertionFailed
+ ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
=====================================
compiler/utils/Pretty.hs
=====================================
@@ -115,7 +115,7 @@ import GhcPrelude hiding (error)
import BufWrite
import FastString
-import Panic
+import PlainPanic
import System.IO
import Numeric (showHex)
@@ -123,9 +123,6 @@ import Numeric (showHex)
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr ( Ptr(..) )
--- Don't import Util( assertPanic ) because it makes a loop in the module structure
-
-
-- ---------------------------------------------------------------------------
-- The Doc calculus
=====================================
compiler/utils/StringBuffer.hs
=====================================
@@ -50,7 +50,7 @@ import GhcPrelude
import Encoding
import FastString
import FastFunctions
-import Outputable
+import PlainPanic
import Util
import Data.Maybe
=====================================
compiler/utils/Util.hs
=====================================
@@ -134,7 +134,7 @@ module Util (
import GhcPrelude
import Exception
-import Panic
+import PlainPanic
import Data.Data
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
=====================================
driver/utils/dynwrapper.c
=====================================
@@ -9,8 +9,8 @@ int rtsOpts;
#include <stdarg.h>
#include <stdio.h>
-#include <Windows.h>
-#include <Shlwapi.h>
+#include <windows.h>
+#include <shlwapi.h>
#include "Rts.h"
=====================================
hadrian/src/Rules/Libffi.hs
=====================================
@@ -24,6 +24,7 @@ askLibffilDynLibs stage = askOracle (LibffiDynLibs stage)
-- | The path to the dynamic library manifest file. The file contains all file
-- paths to libffi dynamic library file paths.
+-- The path is calculated but not `need`ed.
dynLibManifest' :: Monad m => m FilePath -> Stage -> m FilePath
dynLibManifest' getRoot stage = do
root <- getRoot
@@ -103,6 +104,24 @@ configureEnvironment stage = do
, return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w"
, return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
+-- Need the libffi archive and `trackAllow` all files in the build directory.
+-- As all libffi build files are derived from this archive, we can safely
+-- `trackAllow` the libffi build dir. I.e the archive file can be seen as a
+-- shallow dependency of the libffi build. This is much simpler than working out
+-- the dependencies of each rule (within the build dir).
+-- This means changing the archive file forces a clean build of libffi. This
+-- seems like a performance issue, but is justified as building libffi is fast
+-- and the archive file is rarely changed.
+needLibfffiArchive :: FilePath -> Action FilePath
+needLibfffiArchive buildPath = do
+ top <- topDirectory
+ tarball <- unifyPath
+ . fromSingleton "Exactly one LibFFI tarball is expected"
+ <$> getDirectoryFiles top ["libffi-tarballs/libffi*.tar.gz"]
+ need [top -/- tarball]
+ trackAllow [buildPath -/- "//*"]
+ return tarball
+
libffiRules :: Rules ()
libffiRules = do
_ <- addOracleCache $ \ (LibffiDynLibs stage)
@@ -119,6 +138,7 @@ libffiRules = do
, dynLibMan
]
priority 2 $ topLevelTargets &%> \_ -> do
+ _ <- needLibfffiArchive libffiPath
context <- libffiContext stage
-- Note this build needs the Makefile, triggering the rules bellow.
@@ -149,11 +169,7 @@ libffiRules = do
-- Extract libffi tar file
context <- libffiContext stage
removeDirectory libffiPath
- top <- topDirectory
- tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
- <$> getDirectoryFiles top ["libffi-tarballs/libffi*.tar.gz"]
-
- need [top -/- tarball]
+ tarball <- needLibfffiArchive libffiPath
-- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
let libname = takeWhile (/= '+') $ takeFileName tarball
@@ -166,12 +182,14 @@ libffiRules = do
-- And finally:
removeFiles (path) [libname <//> "*"]
+ top <- topDirectory
fixFile mkIn (fixLibffiMakefile top)
files <- liftIO $ getDirectoryFilesIO "." [libffiPath <//> "*"]
produces files
fmap (libffiPath -/-) ["Makefile", "config.guess", "config.sub"] &%> \[mk, _, _] -> do
+ _ <- needLibfffiArchive libffiPath
context <- libffiContext stage
-- This need rule extracts the libffi tar file to libffiPath.
=====================================
includes/CodeGen.Platform.hs
=====================================
@@ -2,7 +2,7 @@
import CmmExpr
#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
|| defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
-import Panic
+import PlainPanic
#endif
import Reg
=====================================
rts/RtsSymbols.c
=====================================
@@ -934,6 +934,7 @@
SymI_HasProto(load_load_barrier) \
SymI_HasProto(cas) \
SymI_HasProto(_assertFail) \
+ SymI_HasProto(keepCAFs) \
RTS_USER_SIGNALS_SYMBOLS \
RTS_INTCHAR_SYMBOLS
=====================================
rules/build-prog.mk
=====================================
@@ -230,7 +230,7 @@ endif
$1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $$$$@)/.
$$(call removeFiles,$$@)
- echo '#include <Windows.h>' >> $$@
+ echo '#include <windows.h>' >> $$@
echo '#include "Rts.h"' >> $$@
echo 'LPTSTR path_dirs[] = {' >> $$@
$$(foreach d,$$($1_$2_DEP_LIB_REL_DIRS),$$(call make-command,echo ' TEXT("/../../$$d")$$(comma)' >> $$@))
@@ -243,7 +243,7 @@ $1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c: driver/utils/dynwrapper.c | $$
$1/$2/build/tmp/$$($1_$2_PROG)-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $$$$@)/.
$$(call removeFiles,$$@)
- echo '#include <Windows.h>' >> $$@
+ echo '#include <windows.h>' >> $$@
echo '#include "Rts.h"' >> $$@
echo 'LPTSTR path_dirs[] = {' >> $$@
$$(foreach p,$$($1_$2_TRANSITIVE_DEP_COMPONENT_IDS),$$(call make-command,echo ' TEXT("/../lib/$$p")$$(comma)' >> $$@))
=====================================
testsuite/tests/perf/compiler/Makefile
=====================================
@@ -2,8 +2,12 @@ TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
-.PHONY: T4007
+.PHONY: T4007 T16473
T4007:
$(RM) -f T4007.hi T4007.o
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-rule-firings T4007.hs
+T16473:
+ $(RM) -f T16473.hi T16473.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-rule-firings T16473.hs
+
=====================================
testsuite/tests/perf/compiler/T16473.hs
=====================================
@@ -0,0 +1,102 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+{-# OPTIONS_GHC -flate-specialise -O2 #-}
+
+module Main (main) where
+
+import qualified Control.Monad.State.Strict as S
+import Data.Foldable
+import Data.Functor.Identity
+import Data.Kind
+import Data.Monoid
+import Data.Tuple
+
+main :: IO ()
+main = print $ badCore 100
+
+badCore :: Int -> Int
+badCore n = getSum $ fst $ run $ runState mempty $ for_ [0..n] $ \i -> modify (<> Sum i)
+
+data Union (r :: [Type -> Type]) a where
+ Union :: e a -> Union '[e] a
+
+decomp :: Union (e ': r) a -> e a
+decomp (Union a) = a
+{-# INLINE decomp #-}
+
+absurdU :: Union '[] a -> b
+absurdU = absurdU
+
+newtype Semantic r a = Semantic
+ { runSemantic
+ :: forall m
+ . Monad m
+ => (forall x. Union r x -> m x)
+ -> m a
+ }
+
+instance Functor (Semantic f) where
+ fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k
+ {-# INLINE fmap #-}
+
+instance Applicative (Semantic f) where
+ pure a = Semantic $ const $ pure a
+ {-# INLINE pure #-}
+ Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k
+ {-# INLINE (<*>) #-}
+
+instance Monad (Semantic f) where
+ return = pure
+ {-# INLINE return #-}
+ Semantic ma >>= f = Semantic $ \k -> do
+ z <- ma k
+ runSemantic (f z) k
+ {-# INLINE (>>=) #-}
+
+data State s a
+ = Get (s -> a)
+ | Put s a
+ deriving Functor
+
+get :: Semantic '[State s] s
+get = Semantic $ \k -> k $ Union $ Get id
+{-# INLINE get #-}
+
+put :: s -> Semantic '[State s] ()
+put !s = Semantic $ \k -> k $ Union $! Put s ()
+{-# INLINE put #-}
+
+modify :: (s -> s) -> Semantic '[State s] ()
+modify f = do
+ !s <- get
+ put $! f s
+{-# INLINE modify #-}
+
+runState :: s -> Semantic (State s ': r) a -> Semantic r (s, a)
+runState = interpretInStateT $ \case
+ Get k -> fmap k S.get
+ Put s k -> S.put s >> pure k
+{-# INLINE[3] runState #-}
+
+run :: Semantic '[] a -> a
+run (Semantic m) = runIdentity $ m absurdU
+{-# INLINE run #-}
+
+interpretInStateT
+ :: (forall x. e x -> S.StateT s (Semantic r) x)
+ -> s
+ -> Semantic (e ': r) a
+ -> Semantic r (s, a)
+interpretInStateT f s (Semantic m) = Semantic $ \k ->
+ fmap swap $ flip S.runStateT s $ m $ \u ->
+ S.mapStateT (\z -> runSemantic z k) $ f $ decomp u
+{-# INLINE interpretInStateT #-}
+
=====================================
testsuite/tests/perf/compiler/T16473.stdout
=====================================
@@ -0,0 +1,139 @@
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op liftA2 (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op <*> (BUILTIN)
+Rule fired: Class op <$ (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op <*> (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op get (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op >> (BUILTIN)
+Rule fired: Class op put (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op get (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op >> (BUILTIN)
+Rule fired: Class op put (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op show (BUILTIN)
+Rule fired: Class op mempty (BUILTIN)
+Rule fired: Class op fromInteger (BUILTIN)
+Rule fired: integerToInt (BUILTIN)
+Rule fired: Class op <> (BUILTIN)
+Rule fired: Class op + (BUILTIN)
+Rule fired: Class op enumFromTo (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op *> (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: fold/build (GHC.Base)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: ># (BUILTIN)
+Rule fired: ==# (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>>= @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>> @ Identity _ (Main)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>>= @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>> @ Identity _ (Main)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op return (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT @ Identity _ (Main)
+Rule fired:
+ SPEC/Main $fApplicativeStateT_$cpure @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @ Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fApplicativeStateT_$c*> @ Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT @ Identity _ (Main)
+Rule fired:
+ SPEC/Main $fApplicativeStateT_$cpure @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c*> @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT @ Identity _ (Main)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op <*> (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op <*> (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op >>= (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC go @ (StateT (Sum Int) Identity) (Main)
+Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op pure (BUILTIN)
+Rule fired: SPEC/Main $fMonadStateT @ Identity _ (Main)
+Rule fired: SPEC go @ (StateT (Sum Int) Identity) (Main)
+Rule fired: Class op fmap (BUILTIN)
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -404,3 +404,5 @@ test('T16190',
collect_stats(),
multimod_compile,
['T16190.hs', '-v0'])
+
+test('T16473', normal, makefile_test, ['T16473'])
=====================================
testsuite/tests/simplCore/should_compile/T7785.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core rules ====================
"SPEC shared @ []"
- forall (irred :: Domain [] Int) ($dMyFunctor :: MyFunctor []).
+ forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int).
shared @ [] $dMyFunctor irred
= bar_$sshared
=====================================
testsuite/tests/warnings/should_compile/T16282/T16282.stderr
=====================================
@@ -1,5 +1,10 @@
-
-T16282.hs: warning: [-Wall-missed-specialisations]
- Could not specialise imported function ‘Data.Map.Internal.$w$cshowsPrec’
- when specialising ‘Data.Map.Internal.$fShowMap_$cshowsPrec’
- Probable fix: add INLINABLE pragma on ‘Data.Map.Internal.$w$cshowsPrec’
+
+T16282.hs: warning: [-Wall-missed-specialisations]
+ Could not specialise imported function ‘Data.Foldable.$wmapM_’
+ when specialising ‘mapM_’
+ Probable fix: add INLINABLE pragma on ‘Data.Foldable.$wmapM_’
+
+T16282.hs: warning: [-Wall-missed-specialisations]
+ Could not specialise imported function ‘Data.Map.Internal.$w$cshowsPrec’
+ when specialising ‘Data.Map.Internal.$fShowMap_$cshowsPrec’
+ Probable fix: add INLINABLE pragma on ‘Data.Map.Internal.$w$cshowsPrec’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/491ded1bcc606eb96ea011cf6eba6798719cb108...4b2287681e1610ad9fdc665c50f4f1476d856060
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/491ded1bcc606eb96ea011cf6eba6798719cb108...4b2287681e1610ad9fdc665c50f4f1476d856060
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190527/52e927b4/attachment-0001.html>
More information about the ghc-commits
mailing list