compiler/basicTypes/UniqSupply.hs

@@ -37,7 +37,7 @@ module UniqSupply (
 import GhcPrelude
 
 import Unique
-import Panic (panic)
+import PlainPanic (panic)
 
 import GHC.IO
 

compiler/deSugar/ExtractDocs.hs

@@ -191,11 +191,22 @@ subordinates instMap decl = case decl of
                   , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
                   , (dL->L _ n) <- ns ]
         derivs  = [ (instName, [unLoc doc], M.empty)
-                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }
-                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $
-                           unLoc $ dd_derivs dd
+                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
+                                concatMap (unLoc . deriv_clause_tys . unLoc) $
+                                unLoc $ dd_derivs dd
                   , Just instName <- [M.lookup l instMap] ]
 
+        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
+        extract_deriv_ty ty =
+          case dL ty of
+            -- deriving (forall a. C a {- ^ Doc comment -})
+            L l (HsForAllTy{ hst_fvf = ForallInvis
+                           , hst_body = dL->L _ (HsDocTy _ _ doc) })
+                                  -> Just (l, doc)
+            -- deriving (C a {- ^ Doc comment -})
+            L l (HsDocTy _ _ doc) -> Just (l, doc)
+            _                     -> Nothing
+
 -- | Extract constructor argument docs from inside constructor decls.
 conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
 conArgDocs con = case getConArgs con of

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/parser/Parser.y

@@ -2086,9 +2086,9 @@ inst_type :: { LHsSigType GhcPs }
         : sigtype                       { mkLHsSigType $1 }
 
 deriv_types :: { [LHsSigType GhcPs] }
-        : typedoc                       { [mkLHsSigType $1] }
+        : ktypedoc                      { [mkLHsSigType $1] }
 
-        | typedoc ',' deriv_types       {% addAnnotation (gl $1) AnnComma (gl $2)
+        | ktypedoc ',' deriv_types      {% addAnnotation (gl $1) AnnComma (gl $2)
                                            >> return (mkLHsSigType $1 : $3) }
 
 comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty

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

+{-# 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' )

hadrian/bindist/Makefile

+MAKEFLAGS += --no-builtin-rules
+.SUFFIXES:
+
+include mk/install.mk
+include mk/config.mk
+
+.PHONY: default
+default:
+	@echo 'Run "make install" to install'
+	@false
+
+#-----------------------------------------------------------------------
+# INSTALL RULES
+
+# Hacky function to check equality of two strings
+# TODO : find if a better function exists
+eq=$(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))
+
+define installscript
+# $1 = package name
+# $2 = wrapper path
+# $3 = bindir
+# $4 = ghcbindir
+# $5 = Executable binary path
+# $6 = Library Directory
+# $7 = Docs Directory
+# $8 = Includes Directory
+# We are installing wrappers to programs by searching corresponding
+# wrappers. If wrapper is not found, we are attaching the common wrapper
+# to it. This implementation is a bit hacky and depends on consistency
+# of program names. For hadrian build this will work as programs have a
+# consistent naming procedure.
+	rm -f '$2'
+	$(CREATE_SCRIPT) '$2'
+	@echo "#!$(SHELL)" >>  '$2'
+	@echo "exedir=\"$4\"" >> '$2'
+	@echo "exeprog=\"$1\"" >> '$2'
+	@echo "executablename=\"$5\"" >> '$2'
+	@echo "bindir=\"$3\"" >> '$2'
+	@echo "libdir=\"$6\"" >> '$2'
+	@echo "docdir=\"$7\"" >> '$2'
+	@echo "includedir=\"$8\"" >> '$2'
+	@echo "" >> '$2'
+	cat wrappers/$1 >> '$2'
+	$(EXECUTABLE_FILE) '$2' ;
+endef
+
+# Hacky function to patch up the 'haddock-interfaces' and 'haddock-html'
+# fields in the package .conf files
+define patchpackageconf
+#
+# $1 = package name (ex: 'bytestring')
+# $2 = path to .conf file
+# $3 = Docs Directory
+# $4 = (relative) path from $${pkgroot} to docs directory ($3)
+#
+# We fix the paths to haddock files by using the relative path from the pkgroot
+# to the doc files.
+	cat '$2' | sed 's|haddock-interfaces.*|haddock-interfaces: "$${pkgroot}/$4/html/libraries/$1/$1.haddock"|' \
+	         | sed 's|haddock-html.*|haddock-html: "$${pkgroot}/$4/html/libraries/$1"|' \
+		 | sed 's|    $${pkgroot}/../../docs/html/.*||' \
+	       > '$2.copy'
+# The rts package doesn't actually supply haddocks, so we stop advertising them
+# altogether.
+	((echo "$1" | grep rts) && (cat '$2.copy' | sed 's|haddock-.*||' > '$2.copy.copy')) || (cat '$2.copy' > '$2.copy.copy')
+# We finally replace the original file.
+	mv '$2.copy.copy' '$2'
+endef
+
+# QUESTION : should we use shell commands?
+
+
+.PHONY: install
+install: install_lib install_bin install_includes
+install: install_docs install_wrappers install_ghci
+install: install_mingw update_package_db
+
+ActualBinsDir=${ghclibdir}/bin
+ActualLibsDir=${ghclibdir}/lib
+WrapperBinsDir=${bindir}
+
+# We need to install binaries relative to libraries.
+BINARIES = $(wildcard ./bin/*)
+install_bin:
+	@echo "Copying binaries to $(ActualBinsDir)"
+	$(INSTALL_DIR) "$(ActualBinsDir)"
+	for i in $(BINARIES); do \
+		cp -R $$i "$(ActualBinsDir)"; \
+	done
+
+install_ghci:
+	@echo "Copying and installing ghci"
+	$(CREATE_SCRIPT) '$(WrapperBinsDir)/ghci'
+	@echo "#!$(SHELL)" >>  '$(WrapperBinsDir)/ghci'
+	cat wrappers/ghci-script >> '$(WrapperBinsDir)/ghci'
+	$(EXECUTABLE_FILE) '$(WrapperBinsDir)/ghci'
+
+LIBRARIES = $(wildcard ./lib/*)
+install_lib:
+	@echo "Copying libraries to $(ActualLibsDir)"
+	$(INSTALL_DIR) "$(ActualLibsDir)"
+	for i in $(LIBRARIES); do \
+		cp -R $$i "$(ActualLibsDir)/"; \
+	done
+
+INCLUDES = $(wildcard ./include/*)
+install_includes:
+	@echo "Copying libraries to $(includedir)"
+	$(INSTALL_DIR) "$(includedir)"
+	for i in $(INCLUDES); do \
+		cp -R $$i "$(includedir)/"; \
+	done
+
+DOCS = $(wildcard ./docs/*)
+install_docs:
+	@echo "Copying libraries to $(docdir)"
+	$(INSTALL_DIR) "$(docdir)"
+	for i in $(DOCS); do \
+		cp -R $$i "$(docdir)/"; \
+	done
+
+BINARY_NAMES=$(shell ls ./wrappers/)
+install_wrappers:
+	@echo "Installing Wrapper scripts"
+	$(INSTALL_DIR) "$(WrapperBinsDir)"
+	$(foreach p, $(BINARY_NAMES),\
+		$(call installscript,$p,$(WrapperBinsDir)/$p,$(WrapperBinsDir),$(ActualBinsDir),$(ActualBinsDir)/$p,$(ActualLibsDir),$(docdir),$(includedir)))
+
+PKG_CONFS = $(shell find "$(ActualLibsDir)/package.conf.d" -name '*.conf' | sed 's:   :xxx:g')
+update_package_db:
+	@echo "$(PKG_CONFS)"
+	@echo "Updating the package DB"
+	$(foreach p, $(PKG_CONFS),\
+		$(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-\([0-9]*[0-9]\.\)*conf//g'),$(shell echo "$p" | sed 's:xxx:   :g'),$(docdir),$(shell realpath --relative-to="$(libdir)" "$(docdir)")))
+	'$(WrapperBinsDir)/ghc-pkg' recache
+
+# The 'foreach' that copies the mingw directory will only trigger a copy
+# when the wildcard matches, therefore only on Windows.
+MINGW = $(wildcard ./mingw)
+install_mingw:
+	@echo "Installing MingGW"
+	$(INSTALL_DIR) "$(prefix)/mingw"
+	$(foreach d, $(MINGW),\
+		cp -R ./mingw "$(prefix)")
+# END INSTALL
+# ----------------------------------------------------------------------

hadrian/src/CommandLine.hs

@@ -146,7 +146,7 @@ readTestConfig config =
 
 readTestConfigFile :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readTestConfigFile filepath =
-    maybe (Left "Cannot parse test-speed") (Right . set) filepath
+    maybe (Left "Cannot parse test-config-file") (Right . set) filepath
   where
     set filepath flags =  flags { testArgs = (testArgs flags) { testConfigFile = filepath } }
 

hadrian/src/Rules/BinaryDist.hs

@@ -101,6 +101,7 @@ bindistRules = do
         -- We 'need' all binaries and libraries
         targets <- mapM pkgTarget =<< stagePackages Stage1
         need targets
+        needIservBins
 
         version        <- setting ProjectVersion
         targetPlatform <- setting TargetPlatformFull
@@ -180,8 +181,9 @@ bindistRules = do
         moveFile (ghcRoot -/- "distrib" -/- "configure") configurePath
 
     -- Generate the Makefile that enables the "make install" part
-    root -/- "bindist" -/- "ghc-*" -/- "Makefile" %> \makefilePath ->
-        writeFile' makefilePath bindistMakefile
+    root -/- "bindist" -/- "ghc-*" -/- "Makefile" %> \makefilePath -> do
+        top <- topDirectory
+        copyFile (top -/- "hadrian" -/- "bindist" -/- "Makefile") makefilePath
 
     root -/- "bindist" -/- "ghc-*" -/- "wrappers/*" %> \wrapperPath ->
         writeFile' wrapperPath $ wrapper (takeFileName wrapperPath)
@@ -216,153 +218,6 @@ pkgTarget pkg
     | isLibrary pkg = pkgConfFile (vanillaContext Stage1 pkg)
     | otherwise     = programPath =<< programContext Stage1 pkg
 
--- TODO: Augment this Makefile to match the various parameters that the current
--- bindist scripts support.
--- | A trivial Makefile that only takes @$prefix@ into account, and not e.g
--- @$datadir@ (for docs) and other variables, yet.
-bindistMakefile :: String
-bindistMakefile = unlines
-    [ "MAKEFLAGS += --no-builtin-rules"
-    , ".SUFFIXES:"
-    , ""
-    , "include mk/install.mk"
-    , "include mk/config.mk"
-    , ""
-    , ".PHONY: default"
-    , "default:"
-    , "\t@echo 'Run \"make install\" to install'"
-    , "\t@false"
-    , ""
-    , "#-----------------------------------------------------------------------"
-    , "# INSTALL RULES"
-    , ""
-    , "# Hacky function to check equality of two strings"
-    , "# TODO : find if a better function exists"
-    , "eq=$(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))"
-    , ""
-    , "define installscript"
-    , "# $1 = package name"
-    , "# $2 = wrapper path"
-    , "# $3 = bindir"
-    , "# $4 = ghcbindir"
-    , "# $5 = Executable binary path"
-    , "# $6 = Library Directory"
-    , "# $7 = Docs Directory"
-    , "# $8 = Includes Directory"
-    , "# We are installing wrappers to programs by searching corresponding"
-    , "# wrappers. If wrapper is not found, we are attaching the common wrapper"
-    , "# to it. This implementation is a bit hacky and depends on consistency"
-    , "# of program names. For hadrian build this will work as programs have a"
-    , "# consistent naming procedure."
-    , "\trm -f '$2'"
-    , "\t$(CREATE_SCRIPT) '$2'"
-    , "\t@echo \"#!$(SHELL)\" >>  '$2'"
-    , "\t@echo \"exedir=\\\"$4\\\"\" >> '$2'"
-    , "\t@echo \"exeprog=\\\"$1\\\"\" >> '$2'"
-    , "\t@echo \"executablename=\\\"$5\\\"\" >> '$2'"
-    , "\t@echo \"bindir=\\\"$3\\\"\" >> '$2'"
-    , "\t@echo \"libdir=\\\"$6\\\"\" >> '$2'"
-    , "\t@echo \"docdir=\\\"$7\\\"\" >> '$2'"
-    , "\t@echo \"includedir=\\\"$8\\\"\" >> '$2'"
-    , "\t@echo \"\" >> '$2'"
-    , "\tcat wrappers/$1 >> '$2'"
-    , "\t$(EXECUTABLE_FILE) '$2' ;"
-    , "endef"
-    , ""
-    , "# Hacky function to patch up the 'haddock-interfaces' and 'haddock-html'"
-    , "# fields in the package .conf files"
-    , "define patchpackageconf"
-    , "# $1 = package name (ex: 'bytestring')"
-    , "# $2 = path to .conf file"
-    , "# $3 = Docs Directory"
-    , "\tcat '$2' | sed 's|haddock-interfaces.*|haddock-interfaces: $3/html/libraries/$1/$1.haddock|' \\"
-    , "\t         | sed 's|haddock-html.*|haddock-html: $3/html/libraries/$1|' \\"
-    , "\t       > '$2.copy'"
-    , "\tmv '$2.copy' '$2'"
-    , "endef"
-    , ""
-    , "# QUESTION : should we use shell commands?"
-    , ""
-    , ""
-    , ".PHONY: install"
-    , "install: install_lib install_bin install_includes"
-    , "install: install_docs install_wrappers install_ghci"
-    , "install: install_mingw update_package_db"
-    , ""
-    , "ActualBinsDir=${ghclibdir}/bin"
-    , "ActualLibsDir=${ghclibdir}/lib"
-    , "WrapperBinsDir=${bindir}"
-    , ""
-    , "# We need to install binaries relative to libraries."
-    , "BINARIES = $(wildcard ./bin/*)"
-    , "install_bin:"
-    , "\t@echo \"Copying binaries to $(ActualBinsDir)\""
-    , "\t$(INSTALL_DIR) \"$(ActualBinsDir)\""
-    , "\tfor i in $(BINARIES); do \\"
-    , "\t\tcp -R $$i \"$(ActualBinsDir)\"; \\"
-    , "\tdone"
-    , ""
-    , "install_ghci:"
-    , "\t@echo \"Installing ghci wrapper\""
-    , "\t@echo \"#!$(SHELL)\" >  '$(WrapperBinsDir)/ghci'"
-    , "\tcat wrappers/ghci-script >> '$(WrapperBinsDir)/ghci'"
-    , "\t$(EXECUTABLE_FILE) '$(WrapperBinsDir)/ghci'"
-    , ""
-    , "LIBRARIES = $(wildcard ./lib/*)"
-    , "install_lib:"
-    , "\t@echo \"Copying libraries to $(ActualLibsDir)\""
-    , "\t$(INSTALL_DIR) \"$(ActualLibsDir)\""
-    , "\tfor i in $(LIBRARIES); do \\"
-    , "\t\tcp -R $$i \"$(ActualLibsDir)/\"; \\"
-    , "\tdone"
-    , ""
-    , "INCLUDES = $(wildcard ./include/*)"
-    , "install_includes:"
-    , "\t@echo \"Copying libraries to $(includedir)\""
-    , "\t$(INSTALL_DIR) \"$(includedir)\""
-    , "\tfor i in $(INCLUDES); do \\"
-    , "\t\tcp -R $$i \"$(includedir)/\"; \\"
-    , "\tdone"
-    , ""
-    , "DOCS = $(wildcard ./docs/*)"
-    , "install_docs:"
-    , "\t@echo \"Copying libraries to $(docdir)\""
-    , "\t$(INSTALL_DIR) \"$(docdir)\""
-    , "\tfor i in $(DOCS); do \\"
-    , "\t\tcp -R $$i \"$(docdir)/\"; \\"
-    , "\tdone"
-    , ""
-    , "BINARY_NAMES=$(shell ls ./wrappers/)"
-    , "install_wrappers:"
-    , "\t@echo \"Installing Wrapper scripts\""
-    , "\t$(INSTALL_DIR) \"$(WrapperBinsDir)\""
-    , "\t$(foreach p, $(BINARY_NAMES),\\"
-    , "\t\t$(call installscript,$p,$(WrapperBinsDir)/$p," ++
-      "$(WrapperBinsDir),$(ActualBinsDir),$(ActualBinsDir)/$p," ++
-      "$(ActualLibsDir),$(docdir),$(includedir)))"
-    , "\trm -f '$(WrapperBinsDir)/ghci-script'" -- FIXME: we shouldn't generate it in the first place
-    , ""
-    , "PKG_CONFS = $(wildcard $(ActualLibsDir)/package.conf.d/*)"
-    , "update_package_db:"
-    , "\t@echo \"Updating the package DB\""
-    , "\t$(foreach p, $(PKG_CONFS),\\"
-    , "\t\t$(call patchpackageconf," ++
-      "$(shell echo $(notdir $p) | sed 's/-\\([0-9]*[0-9]\\.\\)*conf//g')," ++
-      "$p,$(docdir)))"
-    , "\t'$(WrapperBinsDir)/ghc-pkg' recache"
-    , ""
-    , "# The 'foreach' that copies the mingw directory will only trigger a copy"
-    , "# when the wildcard matches, therefore only on Windows."
-    , "MINGW = $(wildcard ./mingw)"
-    , "install_mingw:"
-    , "\t@echo \"Installing MingGW\""
-    , "\t$(INSTALL_DIR) \"$(prefix)/mingw\""
-    , "\t$(foreach d, $(MINGW),\\"
-    , "\t\tcp -R ./mingw \"$(prefix)\")"
-    , "# END INSTALL"
-    , "# ----------------------------------------------------------------------"
-    ]
-
 wrapper :: FilePath -> String
 wrapper "ghc"         = ghcWrapper
 wrapper "ghc-pkg"     = ghcPkgWrapper

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.

hadrian/src/Rules/Library.hs

@@ -106,7 +106,7 @@ buildGhciLibO root ghcilibPath = do
 
 -- | Return all Haskell and non-Haskell object files for the given 'Context'.
 allObjects :: Context -> Action [FilePath]
-allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
+allObjects context = (++) <$> hsObjects context <*> nonHsObjects context
 
 -- | Return all the non-Haskell object files for the given library context
 -- (object files built from C, C-- and sometimes other things).
@@ -139,10 +139,10 @@ extraObjects context
 -- the given 'Context'.
 libraryObjects :: Context -> Action [FilePath]
 libraryObjects context@Context{..} = do
-    hsObjs   <- hsObjects    context
     noHsObjs <- nonHsObjects context
-    need $ noHsObjs ++ hsObjs
-    return (noHsObjs ++ hsObjs)
+    hsObjs   <- hsObjects    context
+    need $ hsObjs ++ noHsObjs
+    return (hsObjs ++ noHsObjs)
 
 -- | Return extra library targets.
 extraTargets :: Context -> Action [FilePath]

hadrian/src/Settings/Builders/Ghc.hs

@@ -97,13 +97,24 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             , arg ("-l" ++ libffiName')
             ]
 
+        -- This is the -rpath argument that is required for the bindist scenario
+        -- to work. Indeed, when you install a bindist, the actual executables
+        -- end up nested somewhere under $libdir, with the wrapper scripts
+        -- taking their place in $bindir, and 'rpath' therefore doesn't seem
+        -- to give us the right paths for such a case.
+        -- TODO: Could we get away with just one rpath...?
+        bindistRpath = "$ORIGIN" -/- ".." -/- ".." -/- originToLibsDir
+
     mconcat [ dynamic ? mconcat
                 [ arg "-dynamic"
                 -- TODO what about windows?
                 , isLibrary pkg ? pure [ "-shared", "-dynload", "deploy" ]
-                , hostSupportsRPaths ? arg ("-optl-Wl,-rpath," ++ rpath)
-                -- The darwin linker doesn't support/require the -zorigin option
-                , hostSupportsRPaths ? not darwin ? arg "-optl-Wl,-zorigin"
+                , hostSupportsRPaths ? mconcat
+                      [ arg ("-optl-Wl,-rpath," ++ rpath)
+                      , isProgram pkg ? arg ("-optl-Wl,-rpath," ++ bindistRpath)
+                      -- The darwin linker doesn't support/require the -zorigin option
+                      , not darwin ? arg "-optl-Wl,-zorigin"
+                      ]
                 ]
             , arg "-no-auto-link-packages"
             ,      nonHsMainPackage pkg  ? arg "-no-hs-main"

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