[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: ghc-heap: Fix decoding of TSO closures

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Thu Aug 18 10:53:44 UTC 2022



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
a99f83de by Matthew Pickering at 2022-08-18T06:53:22-04:00
ghc-heap: Fix decoding of TSO closures

An extra field was added to the TSO structure in 6d1700b6 but the
decoding logic in ghc-heap was not updated for this new field.

Fixes #22046

- - - - -
e73cdf2e by Matthew Pickering at 2022-08-18T06:53:22-04:00
driver: Honour -x option

The -x option is used to manually specify which phase a file should be
started to be compiled from (even if it lacks the correct extension). I
just failed to implement this when refactoring the driver.

In particular Cabal calls GHC with `-E -cpp -x hs Foo.cpphs` to
preprocess source files using GHC.

I added a test to exercise this case.

Fixes #22044

- - - - -
8d2a1257 by Simon Peyton Jones at 2022-08-18T06:53:24-04:00
Be more careful in chooseInferredQuantifiers

This fixes #22065. We were failing to retain a quantifier that
was mentioned in the kind of another retained quantifier.

Easy to fix.

- - - - -


14 changed files:

- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Monad.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/Var.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T22044.bazoo
- testsuite/tests/driver/all.T
- + testsuite/tests/partial-sigs/should_compile/T16152.hs
- + testsuite/tests/partial-sigs/should_compile/T16152.stderr
- + testsuite/tests/partial-sigs/should_compile/T22065.hs
- + testsuite/tests/partial-sigs/should_compile/T22065.stderr
- testsuite/tests/partial-sigs/should_compile/all.T


Changes:

=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -171,7 +171,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
         -> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
       _ -> Nothing
 
-    pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession)
+    pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession)
     mkInputFn  =
       case mb_input_buf of
         Just input_buf -> do
@@ -237,7 +237,7 @@ compileOne' mHscMessage
                  [ml_obj_file $ ms_location summary]
 
    plugin_hsc_env <- initializePlugins hsc_env
-   let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput
+   let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput
    status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
                 mb_old_iface mb_old_linkable (mod_index, nmods)
    let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
@@ -512,7 +512,7 @@ oneShot hsc_env stop_phase srcs = do
     NoStop -> doLink hsc_env o_files
 
 compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
-compileFile hsc_env stop_phase (src, _mb_phase) = do
+compileFile hsc_env stop_phase (src, mb_phase) = do
    exists <- doesFileExist src
    when (not exists) $
         throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
@@ -533,8 +533,8 @@ compileFile hsc_env stop_phase (src, _mb_phase) = do
          | isJust mb_o_file = SpecificFile
                 -- -o foo applies to the file we are compiling now
          | otherwise = Persistent
-        pipe_env = mkPipeEnv stop_phase src output
-        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src
+        pipe_env = mkPipeEnv stop_phase src mb_phase output
+        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase
    runPipeline (hsc_hooks hsc_env) pipeline
 
 
@@ -583,7 +583,7 @@ compileForeign hsc_env lang stub_c = do
 #if __GLASGOW_HASKELL__ < 811
               RawObject  -> panic "compileForeign: should be unreachable"
 #endif
-            pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession)
+            pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession)
         res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
         case res of
           -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
@@ -607,7 +607,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
   let home_unit = hsc_home_unit hsc_env
       src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
   writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
-  let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}
+  let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
       pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
   _ <- runPipeline (hsc_hooks hsc_env) pipeline
   return ()
@@ -617,15 +617,17 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
 
 mkPipeEnv :: StopPhase -- End phase
           -> FilePath -- input fn
+          -> Maybe Phase
           -> PipelineOutput -- Output
           -> PipeEnv
-mkPipeEnv stop_phase  input_fn output =
+mkPipeEnv stop_phase  input_fn start_phase output =
   let (basename, suffix) = splitExtension input_fn
       suffix' = drop 1 suffix -- strip off the .
       env = PipeEnv{ stop_phase,
                      src_filename = input_fn,
                      src_basename = basename,
                      src_suffix = suffix',
+                     start_phase = fromMaybe (startPhase suffix') start_phase,
                      output_spec = output }
   in env
 
@@ -695,8 +697,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do
   where platform = targetPlatform (hsc_dflags hsc_env)
         runAfter :: P p => Phase
                   -> a -> p a -> p a
-        runAfter = phaseIfAfter platform start_phase
-        start_phase = startPhase (src_suffix pipe_env)
+        runAfter = phaseIfAfter platform (start_phase pipe_env)
         runAfterFlag :: P p
                   => HscEnv
                   -> Phase
@@ -829,9 +830,9 @@ applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
 
 
 -- Pipeline from a given suffix
-pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
-pipelineStart pipe_env hsc_env input_fn =
-  fromSuffix (src_suffix pipe_env)
+pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
+pipelineStart pipe_env hsc_env input_fn mb_phase =
+  fromPhase (fromMaybe (startPhase $ src_suffix pipe_env)  mb_phase)
   where
    stop_after = stop_phase pipe_env
    frontend :: P m => HscSource -> m (Maybe FilePath)
@@ -863,33 +864,24 @@ pipelineStart pipe_env hsc_env input_fn =
    objFromLinkable _ = Nothing
 
 
-   fromSuffix :: P m => String -> m (Maybe FilePath)
-   fromSuffix "lhs"      = frontend HsSrcFile
-   fromSuffix "lhs-boot" = frontend HsBootFile
-   fromSuffix "lhsig"    = frontend HsigFile
-   fromSuffix "hs"       = frontend HsSrcFile
-   fromSuffix "hs-boot"  = frontend HsBootFile
-   fromSuffix "hsig"     = frontend HsigFile
-   fromSuffix "hscpp"    = frontend HsSrcFile
-   fromSuffix "hspp"     = frontend HsSrcFile
-   fromSuffix "hc"       = c HCc
-   fromSuffix "c"        = c Cc
-   fromSuffix "cpp"      = c Ccxx
-   fromSuffix "C"        = c Cc
-   fromSuffix "m"        = c Cobjc
-   fromSuffix "M"        = c Cobjcxx
-   fromSuffix "mm"       = c Cobjcxx
-   fromSuffix "cc"       = c Ccxx
-   fromSuffix "cxx"      = c Ccxx
-   fromSuffix "s"        = as False
-   fromSuffix "S"        = as True
-   fromSuffix "ll"       = llvmPipeline pipe_env hsc_env Nothing input_fn
-   fromSuffix "bc"       = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
-   fromSuffix "lm_s"     = llvmManglePipeline pipe_env hsc_env Nothing input_fn
-   fromSuffix "o"        = return (Just input_fn)
-   fromSuffix "cmm"      = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
-   fromSuffix "cmmcpp"   = Just <$> cmmPipeline pipe_env hsc_env input_fn
-   fromSuffix _          = return (Just input_fn)
+   fromPhase :: P m => Phase -> m (Maybe FilePath)
+   fromPhase (Unlit p)  = frontend p
+   fromPhase (Cpp p)    = frontend p
+   fromPhase (HsPp p)   = frontend p
+   fromPhase (Hsc p)    = frontend p
+   fromPhase HCc        = c HCc
+   fromPhase Cc         = c Cc
+   fromPhase Ccxx       = c Ccxx
+   fromPhase Cobjc      = c Cobjc
+   fromPhase Cobjcxx    = c Cobjcxx
+   fromPhase (As p)     = as p
+   fromPhase LlvmOpt    = llvmPipeline pipe_env hsc_env Nothing input_fn
+   fromPhase LlvmLlc    = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
+   fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn
+   fromPhase StopLn     = return (Just input_fn)
+   fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
+   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn
+   fromPhase MergeForeign = panic "fromPhase: MergeForeign"
 
 {-
 Note [The Pipeline Monad]


=====================================
compiler/GHC/Driver/Pipeline/Monad.hs
=====================================
@@ -29,6 +29,7 @@ data PipeEnv = PipeEnv {
        src_filename :: String,      -- ^ basename of original input source
        src_basename :: String,      -- ^ basename of original input source
        src_suffix   :: String,      -- ^ its extension
+       start_phase  :: Phase,
        output_spec  :: PipelineOutput -- ^ says where to put the pipeline output
   }
 


=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Tc.Solver
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Types.Constraint
 import GHC.Core.Predicate
+import GHC.Core.TyCo.Ppr( pprTyVars )
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Gen.Pat
 import GHC.Tc.Utils.TcMType
@@ -59,7 +60,7 @@ import GHC.Types.SourceText
 import GHC.Types.Id
 import GHC.Types.Var as Var
 import GHC.Types.Var.Set
-import GHC.Types.Var.Env( TidyEnv )
+import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv )
 import GHC.Unit.Module
 import GHC.Types.Name
 import GHC.Types.Name.Set
@@ -934,7 +935,8 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
        ; let psig_qtvs    = map binderVar psig_qtv_bndrs
              psig_qtv_set = mkVarSet psig_qtvs
              psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs
-
+             psig_bndr_map :: TyVarEnv InvisTVBinder
+             psig_bndr_map = mkVarEnv [ (binderVar tvb, tvb) | tvb <- psig_qtv_bndrs ]
 
             -- Check whether the quantified variables of the
             -- partial signature have been unified together
@@ -950,32 +952,35 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
 
        ; annotated_theta      <- zonkTcTypes annotated_theta
        ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
+                                 -- NB: free_tvs includes tau_tvs
+
+       ; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs
+                              -- Pulling from qtvs maintains original order
+                              -- NB: qtvs is already in dependency order
 
-       ; let keep_me    = free_tvs `unionVarSet` psig_qtv_set
-             final_qtvs = [ mkTyVarBinder vis tv
-                          | tv <- qtvs -- Pulling from qtvs maintains original order
-                          , tv `elemVarSet` keep_me
-                          , let vis = case lookupVarBndr tv psig_qtv_bndrs of
-                                  Just spec -> spec
-                                  Nothing   -> InferredSpec ]
+       ; traceTc "chooseInferredQuantifiers" $
+         vcat [ text "qtvs" <+> pprTyVars qtvs
+              , text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs
+              , text "free_tvs" <+> ppr free_tvs
+              , text "final_tvs" <+> ppr final_qtvs ]
 
        ; return (final_qtvs, my_theta) }
   where
-    report_dup_tyvar_tv_err (n1,n2)
-      = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
-
-    report_mono_sig_tv_err (n,tv)
-      = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
-      where
-        m_unif_ty = listToMaybe
-                      [ rhs
-                      -- recall that residuals are always implications
-                      | residual_implic <- bagToList $ wc_impl residual
-                      , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)
-                      , let residual_pred = ctPred residual_ct
-                      , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]
-                      , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]
-                      , lhs_tv == tv ]
+    choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar
+             -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder])
+    -- Pick which of the original qtvs should be retained
+    -- Keep it if (a) it is mentioned in the body of the type (free_tvs)
+    --            (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs)
+    --            (c) it is mentioned in the kind of a retained qtv (#22065)
+    choose_qtv psig_bndr_map tv (free_tvs, qtvs)
+       | Just psig_bndr <- lookupVarEnv psig_bndr_map tv
+       = (free_tvs', psig_bndr : qtvs)
+       | tv `elemVarSet` free_tvs
+       = (free_tvs', mkTyVarBinder InferredSpec tv : qtvs)
+       | otherwise  -- Do not pick it
+       = (free_tvs, qtvs)
+       where
+         free_tvs' = free_tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv)
 
     choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
                         -> TcM (VarSet, TcThetaType)
@@ -1019,6 +1024,22 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
              -- Return (annotated_theta ++ diff_theta)
              -- See Note [Extra-constraints wildcards]
 
+    report_dup_tyvar_tv_err (n1,n2)
+      = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
+
+    report_mono_sig_tv_err (n,tv)
+      = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
+      where
+        m_unif_ty = listToMaybe
+                      [ rhs
+                      -- recall that residuals are always implications
+                      | residual_implic <- bagToList $ wc_impl residual
+                      , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)
+                      , let residual_pred = ctPred residual_ct
+                      , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]
+                      , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]
+                      , lhs_tv == tv ]
+
     mk_ctuple preds = mkBoxedTupleTy preds
        -- Hack alert!  See GHC.Tc.Gen.HsType:
        -- Note [Extra-constraint holes in partial type signatures]


=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -79,7 +79,7 @@ module GHC.Types.Var (
         mkTyVarBinder, mkTyVarBinders,
         isTyVarBinder,
         tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,
-        mapVarBndr, mapVarBndrs, lookupVarBndr,
+        mapVarBndr, mapVarBndrs,
 
         -- ** Constructing TyVar's
         mkTyVar, mkTcTyVar,
@@ -696,11 +696,6 @@ mapVarBndr f (Bndr v fl) = Bndr (f v) fl
 mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
 mapVarBndrs f = map (mapVarBndr f)
 
-lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag
-lookupVarBndr var bndrs = lookup var zipped_bndrs
-  where
-    zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs
-
 instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
   ppr (Bndr v Required)  = ppr v
   ppr (Bndr v Specified) = char '@' <> ppr v


=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -350,7 +350,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
                            [p] -> Just p
                            _   -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
                 }
-        TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
+        TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other)  <- pts
                 -> withArray rawHeapWords (\ptr -> do
                     fields <- FFIClosures.peekTSOFields decodeCCS ptr
                     pure $ TSOClosure
@@ -361,6 +361,10 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
                         , trec = u_trec
                         , blocked_exceptions = u_blk_ex
                         , bq = u_bq
+                        , thread_label = case other of
+                                          [tl] -> Just tl
+                                          [] -> Nothing
+                                          _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
                         , what_next = FFIClosures.tso_what_next fields
                         , why_blocked = FFIClosures.tso_why_blocked fields
                         , flags = FFIClosures.tso_flags fields
@@ -372,7 +376,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
                         , prof = FFIClosures.tso_prof fields
                         })
             | otherwise
-                -> fail $ "Expected 6 ptr arguments to TSO, found "
+                -> fail $ "Expected at least 6 ptr arguments to TSO, found "
                         ++ show (length pts)
         STACK
             | [] <- pts


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -280,6 +280,7 @@ data GenClosure b
       , trec                :: !b
       , blocked_exceptions  :: !b
       , bq                  :: !b
+      , thread_label        :: !(Maybe b)
       -- values
       , what_next           :: !WhatNext
       , why_blocked         :: !WhyBlocked


=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -779,3 +779,11 @@ T21869:
 	"$(TEST_HC)" $(TEST_HC_OPTS) -v0 T21869.hs -S
 	[ -f T21869.s ] || (echo "assembly file does not exist" && exit 2)
 	[ ! -f T21869.o ] || (echo "object file exists" && exit 2)
+
+.PHONY: T22044
+T22044:
+	"$(TEST_HC)" $(TEST_HC_OPTS) -v0 -E -cpp -x hs T22044.bazoo -o T22044.hs -DBAZOO=1
+	# Test the file exists and is preprocessed
+	"$(TEST_HC)" $(TEST_HC_OPTS) -v0 T22044.hs
+
+


=====================================
testsuite/tests/driver/T22044.bazoo
=====================================
@@ -0,0 +1,3 @@
+module T22044 where
+
+bazoo = BAZOO


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -311,3 +311,4 @@ test('T20569', extra_files(["T20569/"]), makefile_test, [])
 test('T21866', normal, multimod_compile, ['T21866','-no-link'])
 test('T21349', extra_files(['T21349']), makefile_test, [])
 test('T21869', [normal, when(unregisterised(), skip)], makefile_test, [])
+test('T22044', normal, makefile_test, [])


=====================================
testsuite/tests/partial-sigs/should_compile/T16152.hs
=====================================
@@ -0,0 +1,8 @@
+{-# Language PartialTypeSignatures #-}
+{-# Language PolyKinds             #-}
+{-# Language ScopedTypeVariables   #-}
+
+module T16152 where
+
+top :: forall f. _
+top = undefined


=====================================
testsuite/tests/partial-sigs/should_compile/T16152.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T16152.hs:7:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’ standing for ‘w’
+      Where: ‘w’ is a rigid type variable bound by
+               the inferred type of top :: w
+               at T16152.hs:8:1-15
+    • In the type signature: top :: forall f. _


=====================================
testsuite/tests/partial-sigs/should_compile/T22065.hs
=====================================
@@ -0,0 +1,30 @@
+{-# Options_GHC -dcore-lint #-}
+{-# Language PartialTypeSignatures #-}
+
+module T22065 where
+
+data Foo where
+  Apply :: (x -> Int) -> x -> Foo
+
+foo :: Foo
+foo = Apply f x :: forall a. _ where
+
+  f :: [_] -> Int
+  f = length @[] @_
+
+  x :: [_]
+  x = mempty @[_]
+
+{-
+Smaller version I used when debuggging
+
+apply :: (x->Int) -> x -> Bool
+apply = apply
+
+foo :: Bool
+foo = apply f x :: forall a. _
+    where
+      f = length @[]
+      x = mempty
+
+-}


=====================================
testsuite/tests/partial-sigs/should_compile/T22065.stderr
=====================================
@@ -0,0 +1,53 @@
+
+T22065.hs:10:30: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’ standing for ‘Foo’
+    • In an expression type signature: forall a. _
+      In the expression: Apply f x :: forall a. _
+      In an equation for ‘foo’:
+          foo
+            = Apply f x :: forall a. _
+            where
+                f :: [_] -> Int
+                f = length @[] @_
+                x :: [_]
+                x = mempty @[_]
+    • Relevant bindings include
+        f :: forall {w}. [w] -> Int (bound at T22065.hs:13:3)
+        x :: forall {w}. [w] (bound at T22065.hs:16:3)
+        foo :: Foo (bound at T22065.hs:10:1)
+
+T22065.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’ standing for ‘w’
+      Where: ‘w’ is a rigid type variable bound by
+               the inferred type of f :: [w] -> Int
+               at T22065.hs:13:3-19
+    • In the type ‘[_] -> Int’
+      In the type signature: f :: [_] -> Int
+      In an equation for ‘foo’:
+          foo
+            = Apply f x :: forall a. _
+            where
+                f :: [_] -> Int
+                f = length @[] @_
+                x :: [_]
+                x = mempty @[_]
+    • Relevant bindings include
+        x :: forall {w}. [w] (bound at T22065.hs:16:3)
+        foo :: Foo (bound at T22065.hs:10:1)
+
+T22065.hs:15:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’ standing for ‘w’
+      Where: ‘w’ is a rigid type variable bound by
+               the inferred type of x :: [w]
+               at T22065.hs:16:3-17
+    • In the type ‘[_]’
+      In the type signature: x :: [_]
+      In an equation for ‘foo’:
+          foo
+            = Apply f x :: forall a. _
+            where
+                f :: [_] -> Int
+                f = length @[] @_
+                x :: [_]
+                x = mempty @[_]
+    • Relevant bindings include foo :: Foo (bound at T22065.hs:10:1)


=====================================
testsuite/tests/partial-sigs/should_compile/all.T
=====================================
@@ -105,3 +105,5 @@ test('T20921', normal, compile, [''])
 test('T21719', normal, compile, [''])
 test('InstanceGivenOverlap3', expect_broken(20076), compile, [''])
 test('T21667', normal, compile, [''])
+test('T22065', normal, compile, [''])
+test('T16152', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36926cef23cc3daa756868488e39e0c386216f76...8d2a1257ad73f2aa8b80e21303738d84e6b9c8b5

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36926cef23cc3daa756868488e39e0c386216f76...8d2a1257ad73f2aa8b80e21303738d84e6b9c8b5
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220818/8107c1a2/attachment-0001.html>


More information about the ghc-commits mailing list