compiler/GHC/Core/Opt/Arity.hs

@@ -175,13 +175,10 @@ exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
 -- and gives them a suitable strictness signatures.  It's used during
 -- float-out
 exprBotStrictness_maybe e
-  = case getBotArity (arityType env e) of
+  = case getBotArity (arityType botStrictnessArityEnv e) of
         Nothing -> Nothing
         Just ar -> Just (ar, sig ar)
   where
-    env    = AE { ae_ped_bot = True
-                , ae_cheap_fn = \ _ _ -> False
-                , ae_joins = emptyVarSet }
     sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv
 
 {-
@@ -353,14 +350,7 @@ this transformation.  So we try to limit it as much as possible:
        case undefined of { (a,b) -> \y -> e }
      This showed up in #5557
 
- (2) Do NOT move a lambda outside a case if all the branches of
-     the case are known to return bottom.
-        case x of { (a,b) -> \y -> error "urk" }
-     This case is less important, but the idea is that if the fn is
-     going to diverge eventually anyway then getting the best arity
-     isn't an issue, so we might as well play safe
-
- (3) Do NOT move a lambda outside a case unless
+ (2) Do NOT move a lambda outside a case unless
      (a) The scrutinee is ok-for-speculation, or
      (b) more liberally: the scrutinee is cheap (e.g. a variable), and
          -fpedantic-bottoms is not enforced (see #2915 for an example)
@@ -552,34 +542,18 @@ maxWithArity at@(ATop oss) ar
 vanillaArityType :: ArityType
 vanillaArityType = ATop []      -- Totally uninformative
 
--- ^ The Arity returned is the number of value args the
+-- | The Arity returned is the number of value args the
 -- expression can be applied to without doing much work
 exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
 -- exprEtaExpandArity is used when eta expanding
 --      e  ==>  \xy -> e x y
-exprEtaExpandArity dflags e
-  = arityType env e
-  where
-    env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp
-             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags
-             , ae_joins    = emptyVarSet }
+exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e
 
 getBotArity :: ArityType -> Maybe Arity
 -- Arity of a divergent function
 getBotArity (ABot n) = Just n
 getBotArity _        = Nothing
 
-mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun
-mk_cheap_fn dflags cheap_app
-  | not (gopt Opt_DictsCheap dflags)
-  = \e _     -> exprIsCheapX cheap_app e
-  | otherwise
-  = \e mb_ty -> exprIsCheapX cheap_app e
-             || case mb_ty of
-                  Nothing -> False
-                  Just ty -> isDictTy ty
-
-
 ----------------------
 findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
 -- This implements the fixpoint loop for arity analysis
@@ -589,20 +563,16 @@ findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
 --      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)
 --  (b) if is_bot=True, then e applied to n args is guaranteed bottom
 findRhsArity dflags bndr rhs old_arity
-  = go (get_arity init_cheap_app)
-       -- We always call exprEtaExpandArity once, but usually
-       -- that produces a result equal to old_arity, and then
-       -- we stop right away (since arities should not decrease)
-       -- Result: the common case is that there is just one iteration
+  = go (step botArityType)
+      -- We always do one step, but usually that produces a result equal to
+      -- old_arity, and then we stop right away (since arities should not
+      -- decrease)
+      -- Result: the common case is that there is just one iteration
   where
-    init_cheap_app :: CheapAppFun
-    init_cheap_app fn n_val_args
-      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
-      | otherwise  = isCheapApp fn n_val_args
-
     go :: ArityType -> ArityType
+    go cur_atype@(ATop oss)
+      | length oss <= old_arity = cur_atype
     go cur_atype
-      | cur_arity <= old_arity = cur_atype
       | new_atype == cur_atype = cur_atype
       | otherwise =
 #if defined(DEBUG)
@@ -612,20 +582,13 @@ findRhsArity dflags bndr rhs old_arity
 #endif
                     go new_atype
       where
-        new_atype = get_arity cheap_app
+        new_atype = step cur_atype
 
-        cur_arity = arityTypeArity cur_atype
-        cheap_app :: CheapAppFun
-        cheap_app fn n_val_args
-          | fn == bndr = n_val_args < cur_arity
-          | otherwise  = isCheapApp fn n_val_args
-
-    get_arity :: CheapAppFun -> ArityType
-    get_arity cheap_app = arityType env rhs
+    step :: ArityType -> ArityType
+    step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $
+              arityType env rhs
       where
-         env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
-                  , ae_ped_bot  = gopt Opt_PedanticBottoms dflags
-                  , ae_joins    = emptyVarSet }
+        env = extendSigEnv (findRhsArityEnv dflags) bndr at
 
 {-
 Note [Arity analysis]
@@ -643,17 +606,29 @@ This example happens a lot; it first showed up in Andy Gill's thesis,
 fifteen years ago!  It also shows up in the code for 'rnf' on lists
 in #4138.
 
-The analysis is easy to achieve because exprEtaExpandArity takes an
-argument
-     type CheapFun = CoreExpr -> Maybe Type -> Bool
-used to decide if an expression is cheap enough to push inside a
-lambda.  And exprIsCheapX in turn takes an argument
-     type CheapAppFun = Id -> Int -> Bool
-which tells when an application is cheap. This makes it easy to
-write the analysis loop.
+We do the neccessary, quite simple fixed-point iteration in 'findRhsArity',
+which assumes for a single binding @botArityType@ on the first run and iterates
+until it finds a stable arity type. Two wrinkles
+
+* We often have to ask (see the Case or Let case of 'arityType') whether some
+  expression is cheap. In the case of an application, that depends on the arity
+  of the application head! That's why we have our own version of 'exprIsCheap',
+  'myExprIsCheap', that will integrate the optimistic arity types we have on
+  f and g into the cheapness check.
+
+* Consider this (#18793)
 
-The analysis is cheap-and-cheerful because it doesn't deal with
-mutual recursion.  But the self-recursive case is the important one.
+    go = \ds. case ds of
+           []     -> id
+           (x:ys) -> let acc = go ys in
+                     case blah of
+                       True  -> acc
+                       False -> \ x1 -> acc (negate x1)
+
+  We must propagate go's optimistically large arity to @acc@, so that the
+  tail call to @acc@ in the True branch has sufficient arity.  This is done
+  by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case
+  of 'arityType'.
 
 Note [Eta expanding through dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -757,22 +732,115 @@ encountered a cast, but that is far too conservative: see #5475
 -}
 
 ---------------------------
-type CheapFun = CoreExpr -> Maybe Type -> Bool
-        -- How to decide if an expression is cheap
-        -- If the Maybe is Just, the type is the type
-        -- of the expression; Nothing means "don't know"
+
+-- | Each of the entry-points of the analyser ('arityType') has different
+-- requirements. The entry-points are
+--
+--   1. 'exprBotStrictness_maybe'
+--   2. 'exprEtaExpandArity'
+--   3. 'findRhsArity'
+--
+-- For each of the entry-points, there is a separate mode that governs
+--
+--   1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'.
+--   2. Whether we store arity signatures for non-recursive let-bindings,
+--      accessed in 'extendSigEnv'/'lookupSigEnv'.
+--      See Note [Arity analysis] why that's important.
+--   3. Which expressions we consider cheap to float inside a lambda,
+--      in 'myExprIsCheap'.
+data AnalysisMode
+  = BotStrictness
+  -- ^ Used during 'exprBotStrictness_maybe'.
+  | EtaExpandArity { am_ped_bot :: !Bool
+                   , am_dicts_cheap :: !Bool }
+  -- ^ Used for finding an expression's eta-expanding arity quickly, without
+  -- fixed-point iteration ('exprEtaExpandArity').
+  | FindRhsArity { am_ped_bot :: !Bool
+                 , am_dicts_cheap :: !Bool
+                 , am_sigs :: !(IdEnv ArityType) }
+  -- ^ Used for regular, fixed-point arity analysis ('findRhsArity').
+  --   See Note [Arity analysis] for details about fixed-point iteration.
 
 data ArityEnv
-  = AE { ae_cheap_fn :: CheapFun
-       , ae_ped_bot  :: Bool       -- True <=> be pedantic about bottoms
-       , ae_joins    :: IdSet      -- In-scope join points
-                                   -- See Note [Eta-expansion and join points]
+  = AE
+  { ae_mode   :: !AnalysisMode
+  -- ^ The analysis mode. See 'AnalysisMode'.
+  , ae_joins  :: !IdSet
+  -- ^ In-scope join points. See Note [Eta-expansion and join points]
   }
 
+-- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms
+-- and no application is ever considered cheap.
+botStrictnessArityEnv :: ArityEnv
+botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }
+
+-- | The @ArityEnv@ used by 'exprEtaExpandArity'.
+etaExpandArityEnv :: DynFlags -> ArityEnv
+etaExpandArityEnv dflags
+  = AE { ae_mode  = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags
+                                   , am_dicts_cheap = gopt Opt_DictsCheap dflags }
+       , ae_joins = emptyVarSet }
+
+-- | The @ArityEnv@ used by 'findRhsArity'.
+findRhsArityEnv :: DynFlags -> ArityEnv
+findRhsArityEnv dflags
+  = AE { ae_mode  = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags
+                                 , am_dicts_cheap = gopt Opt_DictsCheap dflags
+                                 , am_sigs = emptyVarEnv }
+       , ae_joins = emptyVarSet }
+
 extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv
 extendJoinEnv env@(AE { ae_joins = joins }) join_ids
   = env { ae_joins = joins `extendVarSetList` join_ids }
 
+extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv
+extendSigEnv env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } id ar_ty =
+  env { ae_mode = am { am_sigs = extendVarEnv sigs id ar_ty } }
+extendSigEnv env _ _ = env
+
+lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType
+lookupSigEnv AE{ ae_mode = mode } id = case mode of
+  BotStrictness                  -> Nothing
+  EtaExpandArity{}               -> Nothing
+  FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id
+
+-- | Whether the analysis should be pedantic about bottoms.
+-- 'exprBotStrictness_maybe' always is.
+pedanticBottoms :: ArityEnv -> Bool
+pedanticBottoms AE{ ae_mode = mode } = case mode of
+  BotStrictness                          -> True
+  EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot
+  FindRhsArity{ am_ped_bot = ped_bot }   -> ped_bot
+
+-- | A version of 'exprIsCheap' that considers results from arity analysis
+-- and optionally the expression's type.
+-- Under 'exprBotStrictness_maybe', no expressions are cheap.
+myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool
+myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of
+  BotStrictness -> False
+  _             -> cheap_dict || cheap_fun e
+    where
+      cheap_dict = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True
+      cheap_fun e = case mode of
+#if __GLASGOW_HASKELL__ <= 900
+        BotStrictness                -> panic "impossible"
+#endif
+        EtaExpandArity{}             -> exprIsCheap e
+        FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e
+
+-- | A version of 'isCheapApp' that considers results from arity analysis.
+-- See Note [Arity analysis] for what's in the signature environment and why
+-- it's important.
+myIsCheapApp :: IdEnv ArityType -> CheapAppFun
+myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of
+  -- Nothing means not a local function, fall back to regular
+  -- 'GHC.Core.Utils.isCheapApp'
+  Nothing         -> isCheapApp fn n_val_args
+  -- @Just at@ means local function with @at@ as current ArityType.
+  -- Roughly approximate what 'isCheapApp' is doing.
+  Just (ABot _)   -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils
+  Just (ATop oss) -> n_val_args < length oss -- Essentially isWorkFreeApp
+
 ----------------
 arityType :: ArityEnv -> CoreExpr -> ArityType
 
@@ -793,6 +861,8 @@ arityType env (Cast e co)
 arityType env (Var v)
   | v `elemVarSet` ae_joins env
   = botArityType  -- See Note [Eta-expansion and join points]
+  | Just at <- lookupSigEnv env v -- Local binding
+  = at
   | otherwise
   = idArityType v
 
@@ -805,7 +875,7 @@ arityType env (Lam x e)
 arityType env (App fun (Type _))
    = arityType env fun
 arityType env (App fun arg )
-   = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)
+   = arityApp (arityType env fun) (myExprIsCheap env arg Nothing)
 
         -- Case/Let; keep arity if either the expression is cheap
         -- or it's a 1-shot lambda
@@ -815,20 +885,20 @@ arityType env (App fun arg )
         --      f x y = case x of { (a,b) -> e }
         -- The difference is observable using 'seq'
         --
-arityType env (Case scrut _ _ alts)
+arityType env (Case scrut bndr _ alts)
   | exprIsDeadEnd scrut || null alts
   = botArityType    -- Do not eta expand
                     -- See Note [Dealing with bottom (1)]
-  | otherwise
-  = case alts_type of
-     ABot n  | n>0       -> ATop []       -- Don't eta expand
-             | otherwise -> botArityType  -- if RHS is bottomming
-                                          -- See Note [Dealing with bottom (2)]
-
-     ATop as | not (ae_ped_bot env)    -- See Note [Dealing with bottom (3)]
-             , ae_cheap_fn env scrut Nothing -> ATop as
-             | exprOkForSpeculation scrut    -> ATop as
-             | otherwise                     -> ATop (takeWhile isOneShotInfo as)
+  | not (pedanticBottoms env)  -- See Note [Dealing with bottom (2)]
+  , myExprIsCheap env scrut (Just (idType bndr))
+  = alts_type
+  | exprOkForSpeculation scrut
+  = alts_type
+
+  | otherwise               -- In the remaining cases we may not push
+  = case alts_type of       -- evaluation of the scrutinee in
+     ATop as -> ATop (takeWhile isOneShotInfo as)
+     ABot _  -> ATop []
   where
     alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
 
@@ -854,12 +924,16 @@ arityType env (Let (Rec pairs) body)
       | otherwise
       = pprPanic "arityType:joinrec" (ppr pairs)
 
-arityType env (Let b e)
-  = floatIn (cheap_bind b) (arityType env e)
+arityType env (Let (NonRec b r) e)
+  = floatIn cheap_rhs (arityType env' e)
   where
-    cheap_bind (NonRec b e) = is_cheap (b,e)
-    cheap_bind (Rec prs)    = all is_cheap prs
-    is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))
+    cheap_rhs = myExprIsCheap env r (Just (idType b))
+    env'      = extendSigEnv env b (arityType env r)
+
+arityType env (Let (Rec prs) e)
+  = floatIn (all is_cheap prs) (arityType env e)
+  where
+    is_cheap (b,e) = myExprIsCheap env e (Just (idType b))
 
 arityType env (Tick t e)
   | not (tickishIsCode t)     = arityType env e
@@ -1743,4 +1817,3 @@ freshEtaId n subst ty
                   -- "OrCoVar" since this can be used to eta-expand
                   -- coercion abstractions
         subst'  = extendTCvInScope subst eta_id'
-

compiler/GHC/Driver/Session.hs

@@ -131,8 +131,6 @@ module GHC.Driver.Session (
         sGhcWithSMP,
         sGhcRTSWays,
         sLibFFI,
-        sGhcThreaded,
-        sGhcDebugged,
         sGhcRtsWithLibdw,
         GhcNameVersion(..),
         FileSettings(..),

compiler/GHC/Hs/Type.hs

@@ -931,22 +931,23 @@ isUnrestricted _ = False
 
 -- | Denotes the type of arrows in the surface language
 data HsArrow pass
-  = HsUnrestrictedArrow
-    -- ^ a -> b
-  | HsLinearArrow
-    -- ^ a %1 -> b
-  | HsExplicitMult (LHsType pass)
-    -- ^ a %m -> b (very much including `a %Many -> b`! This is how the
-    -- programmer wrote it). It is stored as an `HsType` so as to preserve the
-    -- syntax as written in the program.
+  = HsUnrestrictedArrow IsUnicodeSyntax
+    -- ^ a -> b or a → b
+  | HsLinearArrow IsUnicodeSyntax
+    -- ^ a %1 -> b or a %1 → b, or a ⊸ b
+  | HsExplicitMult IsUnicodeSyntax (LHsType pass)
+    -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!
+    -- This is how the programmer wrote it). It is stored as an
+    -- `HsType` so as to preserve the syntax as written in the
+    -- program.
 
 -- | Convert an arrow into its corresponding multiplicity. In essence this
 -- erases the information of whether the programmer wrote an explicit
 -- multiplicity or a shorthand.
 arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn
-arrowToHsType HsUnrestrictedArrow = noLoc manyDataConHsTy
-arrowToHsType HsLinearArrow = noLoc oneDataConHsTy
-arrowToHsType (HsExplicitMult p) = p
+arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy
+arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy
+arrowToHsType (HsExplicitMult _ p) = p
 
 -- | This is used in the syntax. In constructor declaration. It must keep the
 -- arrow representation.
@@ -961,20 +962,23 @@ hsScaledThing (HsScaled _ t) = t
 -- | When creating syntax we use the shorthands. It's better for printing, also,
 -- the shorthands work trivially at each pass.
 hsUnrestricted, hsLinear :: a -> HsScaled pass a
-hsUnrestricted = HsScaled HsUnrestrictedArrow
-hsLinear = HsScaled HsLinearArrow
+hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)
+hsLinear = HsScaled (HsLinearArrow NormalSyntax)
 
 instance Outputable a => Outputable (HsScaled pass a) where
    ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t
-                          ppr t
+                            ppr t
 
 instance
       (OutputableBndrId pass) =>
       Outputable (HsArrow (GhcPass pass)) where
-  ppr HsUnrestrictedArrow = parens arrow
-  ppr HsLinearArrow = parens lollipop
-  ppr (HsExplicitMult p) = parens (mulArrow (ppr p))
+  ppr arr = parens (pprHsArrow arr)
 
+-- See #18846
+pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc
+pprHsArrow (HsUnrestrictedArrow _) = arrow
+pprHsArrow (HsLinearArrow _) = lollipop
+pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p))
 
 {-
 Note [Unit tuples]
@@ -1959,10 +1963,7 @@ ppr_fun_ty :: (OutputableBndrId p)
 ppr_fun_ty mult ty1 ty2
   = let p1 = ppr_mono_lty ty1
         p2 = ppr_mono_lty ty2
-        arr = case mult of
-          HsLinearArrow -> lollipop
-          HsUnrestrictedArrow -> arrow
-          HsExplicitMult p -> mulArrow (ppr p)
+        arr = pprHsArrow mult
     in
     sep [p1, arr <+> p2]
 

compiler/GHC/Hs/Utils.hs

@@ -133,6 +133,7 @@ import GHC.Types.SrcLoc
 import GHC.Data.FastString
 import GHC.Data.Bag
 import GHC.Settings.Constants
+import GHC.Parser.Annotation
 
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
@@ -537,12 +538,12 @@ nlList exprs          = noLoc (ExplicitList noExtField Nothing exprs)
 
 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
 nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)
-nlHsFunTy :: HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
 nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
 
 nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t))
 nlHsTyVar x   = noLoc (HsTyVar noExtField NotPromoted (noLoc x))
-nlHsFunTy mult a b = noLoc (HsFunTy noExtField mult (parenthesizeHsType funPrec a) b)
+nlHsFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b)
 nlHsParTy t   = noLoc (HsParTy noExtField t)
 
 nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)

compiler/GHC/HsToCore/Foreign/Decl.hs

@@ -415,7 +415,7 @@ f_helper(StablePtr s, HsBool b, HsInt i)
 {
         Capability *cap;
         cap = rts_lock();
-        rts_evalIO(&cap,
+        rts_inCall(&cap,
                    rts_apply(rts_apply(deRefStablePtr(s),
                                        rts_mkBool(b)), rts_mkInt(i)));
         rts_unlock(cap);
@@ -630,7 +630,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
     | otherwise
       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 
-  -- the target which will form the root of what we ask rts_evalIO to run
+  -- the target which will form the root of what we ask rts_inCall to run
   the_cfun
      = case maybe_target of
           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
@@ -638,7 +638,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   cap = text "cap" <> comma
 
-  -- the expression we give to rts_evalIO
+  -- the expression we give to rts_inCall
   expr_to_run
      = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
        where
@@ -674,7 +674,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      ,   declareCResult
      ,   text "cap = rts_lock();"
           -- create the application + perform it.
-     ,   text "rts_evalIO" <> parens (
+     ,   text "rts_inCall" <> parens (
                 char '&' <> cap <>
                 text "rts_apply" <> parens (
                     cap <>

compiler/GHC/Parser.y

@@ -2051,22 +2051,22 @@ is connected to the first type too.
 type :: { LHsType GhcPs }
         -- See Note [%shift: type -> btype]
         : btype %shift                 { $1 }
-        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
+        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations]
+                                       >> ams (sLL $1 $> $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode $2)) $1 $3)
                                               [mu AnnRarrow $2] }
 
         | btype mult '->' ctype        {% hintLinear (getLoc $2)
-                                       >> ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4)
-                                              [mu AnnRarrow $3] }
+                                       >> ams $1 [mj AnnMult $2,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
+                                       >> ams (sLL $1 $> $ HsFunTy noExtField ((unLoc $2) (toUnicode $3)) $1 $4)
+                                              [mj AnnMult $2,mu AnnRarrow $3] }
 
         | btype '->.' ctype            {% hintLinear (getLoc $2)
-                                       >> ams $1 [mu AnnLollyU $2] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+                                       >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]
+                                       >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)
                                               [mu AnnLollyU $2] }
 
-mult :: { Located (HsArrow GhcPs) }
-        : PREFIX_PERCENT atype          { sLL $1 $> (mkMultTy $2) }
+mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
+        : PREFIX_PERCENT atype          { sLL $1 $> (\u -> mkMultTy u $2) }
 
 btype :: { LHsType GhcPs }
         : infixtype                     {% runPV $1 }
@@ -3999,6 +3999,9 @@ mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l
 toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
 toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
 
+toUnicode :: Located Token -> IsUnicodeSyntax
+toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax
+
 gl :: Located a -> SrcSpan
 gl = getLoc
 

compiler/GHC/Parser/Annotation.hs

@@ -301,6 +301,7 @@ data AnnKeywordId
     | AnnMdo
     | AnnMinus -- ^ '-'
     | AnnModule
+    | AnnMult -- ^ '%1'
     | AnnNewtype
     | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf

compiler/GHC/Parser/PostProcess.hs

@@ -2617,9 +2617,9 @@ mkLHsOpTy x op y =
   let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
   in L loc (mkHsOpTy x op y)
 
-mkMultTy :: LHsType GhcPs -> HsArrow GhcPs
-mkMultTy (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow
-mkMultTy t = HsExplicitMult t
+mkMultTy :: IsUnicodeSyntax -> LHsType GhcPs -> HsArrow GhcPs
+mkMultTy u (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow u
+mkMultTy u t = HsExplicitMult u t
 
 -----------------------------------------------------------------------------
 -- Token symbols

compiler/GHC/Parser/PostProcess/Haddock.hs

@@ -980,10 +980,10 @@ instance HasHaddock (Located (HsType GhcPs)) where
         pure $ L l (HsQualTy noExtField lhs rhs')
 
       -- arg -> res
-      HsFunTy _ mult lhs rhs -> do
+      HsFunTy u mult lhs rhs -> do
         lhs' <- addHaddock lhs
         rhs' <- addHaddock rhs
-        pure $ L l (HsFunTy noExtField mult lhs' rhs')
+        pure $ L l (HsFunTy u mult lhs' rhs')
 
       -- other types
       _ -> liftHdkA $ do

compiler/GHC/Platform.hs

@@ -209,8 +209,6 @@ data PlatformMisc = PlatformMisc
   , platformMisc_ghcWithSMP           :: Bool
   , platformMisc_ghcRTSWays           :: String
   , platformMisc_libFFI               :: Bool
-  , platformMisc_ghcThreaded          :: Bool
-  , platformMisc_ghcDebugged          :: Bool
   , platformMisc_ghcRtsWithLibdw      :: Bool
   , platformMisc_llvmTarget           :: String
   }

compiler/GHC/Rename/HsType.hs

@@ -624,11 +624,11 @@ rnHsTyKi env ty@(HsRecTy _ flds)
                                    2 (ppr ty))
            ; return [] }
 
-rnHsTyKi env (HsFunTy _ mult ty1 ty2)
+rnHsTyKi env (HsFunTy u mult ty1 ty2)
   = do { (ty1', fvs1) <- rnLHsTyKi env ty1
        ; (ty2', fvs2) <- rnLHsTyKi env ty2
        ; (mult', w_fvs) <- rnHsArrow env mult
-       ; return (HsFunTy noExtField mult' ty1' ty2'
+       ; return (HsFunTy u mult' ty1' ty2'
                 , plusFVs [fvs1, fvs2, w_fvs]) }
 
 rnHsTyKi env listTy@(HsListTy _ ty)
@@ -721,10 +721,10 @@ rnHsTyKi env (HsWildCardTy _)
        ; return (HsWildCardTy noExtField, emptyFVs) }
 
 rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
-rnHsArrow _env HsUnrestrictedArrow = return (HsUnrestrictedArrow, emptyFVs)
-rnHsArrow _env HsLinearArrow = return (HsLinearArrow, emptyFVs)
-rnHsArrow env (HsExplicitMult p)
-  = (\(mult, fvs) -> (HsExplicitMult mult, fvs)) <$> rnLHsTyKi env p
+rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)
+rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs)
+rnHsArrow env (HsExplicitMult u p)
+  = (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p
 
 --------------
 rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
@@ -1847,7 +1847,7 @@ extract_lty (L _ ty) acc
 
 extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
                    FreeKiTyVars
-extract_hs_arrow (HsExplicitMult p) acc = extract_lty p acc
+extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc
 extract_hs_arrow _ acc = acc
 
 extract_hs_for_all_telescope :: HsForAllTelescope GhcPs

compiler/GHC/Settings.hs

@@ -61,8 +61,6 @@ module GHC.Settings
   , sGhcWithSMP
   , sGhcRTSWays
   , sLibFFI
-  , sGhcThreaded
-  , sGhcDebugged
   , sGhcRtsWithLibdw
   ) where
 
@@ -276,9 +274,5 @@ sGhcRTSWays :: Settings -> String
 sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc
 sLibFFI :: Settings -> Bool
 sLibFFI = platformMisc_libFFI . sPlatformMisc
-sGhcThreaded :: Settings -> Bool
-sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc
-sGhcDebugged :: Settings -> Bool
-sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc
 sGhcRtsWithLibdw :: Settings -> Bool
 sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc

compiler/GHC/Settings/IO.hs

@@ -155,8 +155,6 @@ initSettings top_dir = do
   ghcWithSMP <- getBooleanSetting "Support SMP"
   ghcRTSWays <- getSetting "RTS ways"
   useLibFFI <- getBooleanSetting "Use LibFFI"
-  ghcThreaded <- getBooleanSetting "Use Threads"
-  ghcDebugged <- getBooleanSetting "Use Debugging"
   ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"
 
   return $ Settings
@@ -225,8 +223,6 @@ initSettings top_dir = do
       , platformMisc_ghcWithSMP = ghcWithSMP
       , platformMisc_ghcRTSWays = ghcRTSWays
       , platformMisc_libFFI = useLibFFI
-      , platformMisc_ghcThreaded = ghcThreaded
-      , platformMisc_ghcDebugged = ghcDebugged
       , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw
       , platformMisc_llvmTarget = llvmTarget
       }

compiler/GHC/SysTools.hs

@@ -244,15 +244,11 @@ linkDynLib dflags0 o_files dep_packages
         -- against libHSrts, then both end up getting loaded,
         -- and things go wrong. We therefore link the libraries
         -- with the same RTS flags that we link GHC with.
-        dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0
-          then addWay' WayThreaded dflags0
-          else                     dflags0
-        win_dflags = if platformMisc_ghcDebugged $ platformMisc dflags1
-          then addWay' WayDebug dflags1
-          else                  dflags1
-
-        dflags | OSMinGW32 <- os = win_dflags
-               | otherwise       = dflags0
+        dflags | OSMinGW32 <- os
+               , hostWays `hasWay` WayDyn
+               = dflags0 { ways = hostWays }
+               | otherwise
+               = dflags0
 
         verbFlags = getVerbFlags dflags
         o_file = outputFile dflags

compiler/GHC/Tc/Gen/HsType.hs

@@ -116,6 +116,7 @@ import GHC.Data.FastString
 import GHC.Builtin.Names hiding ( wildCardName )
 import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Parser.Annotation
 
 import GHC.Data.Maybe
 import GHC.Data.Bag( unitBag )
@@ -1046,7 +1047,7 @@ tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind
 
 tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
   | op `hasKey` funTyConKey
-  = tc_fun_type mode HsUnrestrictedArrow ty1 ty2 exp_kind
+  = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind
 
 --------- Foralls
 tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind

compiler/GHC/Tc/Module.hs

@@ -2453,7 +2453,7 @@ getGhciStepIO = do
                      { hst_tele = mkHsForAllInvisTele
                                   [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]
                      , hst_xforall = noExtField
-                     , hst_body  = nlHsFunTy HsUnrestrictedArrow ghciM ioM }
+                     , hst_body  = nlHsFunTy ghciM ioM }
 
         stepTy :: LHsSigWcType GhcRn
         stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)

compiler/GHC/Tc/TyCl.hs

@@ -3416,7 +3416,7 @@ tcConArg exp_kind (HsScaled w bty)
         ; return (Scaled w' arg_ty, getBangStrictness bty) }
 
 tcDataConMult :: HsArrow GhcRn -> TcM Mult
-tcDataConMult arr@HsUnrestrictedArrow = do
+tcDataConMult arr@(HsUnrestrictedArrow _) = do
   -- See Note [Function arrows in GADT constructors]
   linearEnabled <- xoptM LangExt.LinearTypes
   if linearEnabled then tcMult arr else return oneDataConTy

compiler/GHC/Tc/TyCl/Class.hs

@@ -550,8 +550,10 @@ warnMissingAT name
   = do { warn <- woptM Opt_WarnMissingMethods
        ; traceTc "warn" (ppr name <+> ppr warn)
        ; hsc_src <- fmap tcg_src getGblEnv
-       -- Warn only if -Wmissing-methods AND not a signature
-       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
+       -- hs-boot and signatures never need to provide complete "definitions"
+       -- of any sort, as they aren't really defining anything, but just
+       -- constraining items which are defined elsewhere.
+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)
                 (text "No explicit" <+> text "associated type"
                     <+> text "or default declaration for"
                     <+> quotes (ppr name)) }

compiler/GHC/Tc/TyCl/Instance.hs

@@ -512,9 +512,18 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
 
                       -- Check for missing associated types and build them
                       -- from their defaults (if available)
+                    ; is_boot <- tcIsHsBootOrSig
+                    ; let atItems = classATItems clas
                     ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
-                                        (classATItems clas)
-
+                                        (if is_boot then [] else atItems)
+                      -- Don't default type family instances, but rather omit, in hsig/hs-boot.
+                      -- Since hsig/hs-boot files are essentially large binders we want omission
+                      -- of the definition to result in no restriction, rather than for example
+                      -- attempting to "pattern match" with the invisible defaults and generate
+                      -- equalities. Without further handling, this would just result in a panic
+                      -- anyway.
+                      -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for
+                      -- additional discussion.
                     ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
 
 
@@ -539,8 +548,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
               all_insts                      = tyfam_insts ++ datafam_insts
 
          -- In hs-boot files there should be no bindings
-        ; is_boot <- tcIsHsBootOrSig
         ; let no_binds = isEmptyLHsBinds binds && null uprags
+        ; is_boot <- tcIsHsBootOrSig
         ; failIfTc (is_boot && not no_binds) badBootDeclErr
 
         ; return ( [inst_info], all_insts, deriv_infos ) }

compiler/GHC/ThToHs.hs

@@ -51,6 +51,7 @@ import GHC.Utils.Misc
 import GHC.Data.FastString
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
+import GHC.Parser.Annotation
 
 import qualified Data.ByteString as BS
 import Control.Monad( unless, ap )
@@ -1471,7 +1472,7 @@ cvtTypeKind ty_str ty
                           _            -> return $
                                           parenthesizeHsType sigPrec x'
                  let y'' = parenthesizeHsType sigPrec y'
-                 returnL (HsFunTy noExtField HsUnrestrictedArrow x'' y'')
+                 returnL (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'')
              | otherwise
              -> mk_apps
                 (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))
@@ -1623,9 +1624,9 @@ cvtTypeKind ty_str ty
 hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
 hsTypeToArrow w = case unLoc w of
                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))
-                        | n == oneDataConName -> HsLinearArrow
-                        | n == manyDataConName -> HsUnrestrictedArrow
-                     _ -> HsExplicitMult w
+                        | n == oneDataConName -> HsLinearArrow NormalSyntax
+                        | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax
+                     _ -> HsExplicitMult NormalSyntax w
 
 -- ConT/InfixT can contain both data constructor (i.e., promoted) names and
 -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only