Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -719,7 +719,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
    719 719 
           , let no_tvs   = null tvs
    720 720 
                 no_theta = null theta
    721 721 
           , not (no_tvs && no_theta)
    722 
    -      = do { (_inst_tvs, wrap, fun_rho) <-
    722 
    +      = do { (wrap, fun_rho) <-
    723 723 
                     -- addHeadCtxt: important for the class constraints
    724 724 
                     -- that may be emitted from instantiating fun_sigma
    725 725 
                     addHeadCtxt fun_ctxt $
    ... ... @@ -786,7 +786,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
    786 786 
             --     not defer in any way, because this is a QL instantiation variable.
    787 787 
             -- It's easier just to do the job directly here.
    788 788 
             do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..]
    789 
    -           ; res_ty  <- newOpenFlexiTyVarTy
    789 
    +           ; rr_ty   <- newFlexiTyVarTyQL do_ql runtimeRepTy
    790 
    +           ; res_ty  <- newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty)
    790 791 
                ; let fun_ty' = mkScaledFunTys arg_tys res_ty
    791 792
    792 793 
                -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu
    ... ... @@ -831,7 +832,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
    831 832 
                    -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc],
    832 833 
                    -- thereby ensuring that the arguments have concrete runtime representations
    833 834
    834 
    -           ; mult_ty <- newFlexiTyVarTy multiplicityTy
    835 
    +           ; mult_ty <- newFlexiTyVarTyQL do_ql multiplicityTy
    835 836 
                    -- mult_ty: e need variables for argument multiplicities (#18731)
    836 837 
                    -- Otherwise, 'undefined x' wouldn't be linear in x
    837 838
    ... ... @@ -912,6 +913,96 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
    912 913 
                       addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
    913 914 
                       thing_inside }
    914 915
    916 
    +{- *********************************************************************
    917 
    +*                                                                      *
    918 
    +              Instantiating fresh type variables
    919 
    +*                                                                      *
    920 
    +********************************************************************* -}
    921 
    +
    922 
    +getTcLevelQL :: DoQL -> TcM TcLevel
    923 
    +getTcLevelQL DoQL = return QLInstVar
    924 
    +getTcLevelQL NoQL = getTcLevel
    925 
    +
    926 
    +newFlexiTyVarTyQL :: DoQL -> TcKind -> TcM TcType
    927 
    +newFlexiTyVarTyQL do_ql kind
    928 
    +  = do { lvl <- getTcLevelQL do_ql
    929 
    +       ; newMetaTyVarTyAtLevel lvl kind }
    930 
    +
    931 
    +{-
    932 
    +newArgTyVarQL do_ql frr_ctxt
    933 
    +  = do { th_lvl <- getThLevel
    934 
    +       ; rr_ty <- case th_lvl of
    935 
    +                    TypedBrack {} -> newFlexiTyVarTyQL do_ql runtimeRepTy
    936 
    +                    _ -> mdo {
    937 
    +       ; rr_ty <-
    938 
    +       ; newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) }
    939 
    +-}
    940 
    +
    941 
    +instantiateSigma :: CtOrigin
    942 
    +                 -> QLFlag
    943 
    +                 -> ConcreteTyVars -- ^ concreteness information
    944 
    +                 -> [TyVar]
    945 
    +                 -> TcThetaType -> TcSigmaType
    946 
    +                 -> TcM (HsWrapper, TcSigmaType)
    947 
    +-- (instantiate orig tvs theta ty)
    948 
    +-- instantiates the type variables tvs, emits the (instantiated)
    949 
    +-- constraints theta, and returns the (instantiated) type ty
    950 
    +instantiateSigma orig do_ql concs tvs theta body_ty
    951 
    +  = do { tv_lvl <- getTcLevelQL do_ql
    952 
    +       ; rec (subst, inst_tvs) <- mapAccumLM (new_meta tv_lvl subst) empty_subst tvs
    953 
    +       ; let inst_theta  = substTheta subst theta
    954 
    +             inst_body   = substTy subst body_ty
    955 
    +
    956 
    +       ; wrap <- instCall orig (mkTyVarTys inst_tvs) inst_theta
    957 
    +       ; traceTc "Instantiating"
    958 
    +                 (vcat [ text "origin" <+> pprCtOrigin orig
    959 
    +                       , text "tvs"   <+> ppr tvs
    960 
    +                       , text "theta" <+> ppr theta
    961 
    +                       , text "type" <+> debugPprType body_ty
    962 
    +                       , text "with" <+> vcat (map debugPprType inst_tv_tys)
    963 
    +                       , text "theta:" <+> ppr inst_theta ])
    964 
    +
    965 
    +      ; return (wrap, inst_body) }
    966 
    +  where
    967 
    +    in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty))
    968 
    +               -- mkSpecSigmaTy: Inferred vs Specified is not important here;
    969 
    +               --                We just want an accurate free-var set
    970 
    +    empty_subst = mkEmptySubst in_scope
    971 
    +
    972 
    +    new_meta :: TcLevel -> Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar)
    973 
    +    new_meta tv_lvl final_subst subst tv
    974 
    +      = do { name <- cloneMetaTyVarName (tyVarName tv)
    975 
    +           ; ref  <- newMutVar Flexi
    976 
    +           ; info <- get_info tv
    977 
    +           ; let details = MetaTv { mtv_info  = info
    978 
    +                                  , mtv_ref   = ref
    979 
    +                                  , mtv_tclvl = tv_lvl }
    980 
    +           ; let substd_kind = substTy subst (tyVarKind tv)
    981 
    +                 new_tv      = mkTcTyVar name substd_kind details
    982 
    +                 new_subst   = extendTvSubstWithClone subst tv new_tv
    983 
    +           ; return (new_subst, new_tv) }
    984 
    +
    985 
    +    get_info :: Subst -> TyVar -> TcM MetaInfo
    986 
    +    get_info concs final_subst tv
    987 
    +      -- Is this a type variable that must be instantiated to a concrete type?
    988 
    +      -- If so, create a ConcreteTv metavariable instead of a plain TauTv.
    989 
    +      -- See Note [Representation-polymorphism checking built-ins]
    990 
    +      --     in GHC.Tc.Utils.Concrete.
    991 
    +      --
    992 
    +      -- But check TH level: see [Wrinkle: Typed Template Haskell]
    993 
    +      -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
    994 
    +      | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv)
    995 
    +      , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0
    996 
    +                        -- See Note [substConcreteTvOrigin].
    997 
    +      = do { th_lvl <- getThLevel
    998 
    +           ; case th_lvl of
    999 
    +              TypedBrack {} -> return TauTv
    1000 
    +              _             -> return (ConcreteTv conc) }
    1001 
    +
    1002 
    +      -- The vastly common case
    1003 
    +      | otherwise
    1004 
    +      = return TauTv
    1005 
    +
    915 1006 
     {- *********************************************************************
    916 1007 
     *                                                                      *
    917 1008 
                   Visible type application

  • compiler/GHC/Tc/Solver/Monad.hs
    ... ... @@ -1799,12 +1799,20 @@ reportCoarseGrainUnifications (TcS thing_inside)
    1799 1799 
                   ; unless (inner_ul `deeperThanOrSame` outer_ul) $
    1800 1800 
                     TcM.writeTcRef outer_ul_ref inner_ul
    1801 1801 
                   ; let unif_happened = ambient_lvl `deeperThanOrSame` inner_ul
    1802 
    +              ; TcM.traceTc "reportCoarse(Coarse)" $
    1803 
    +                vcat [ text "ambient" <+> ppr ambient_lvl
    1804 
    +                     , text "outer_ul" <+> ppr outer_ul
    1805 
    +                     , text "inner_ul" <+> ppr inner_ul
    1806 
    +                     , text "unif_happened" <+> ppr unif_happened ]
    1802 1807 
                   ; return (unif_happened, res) }
    1803 1808 
           WU_Fine outer_tvs_ref
    1804 1809 
             -> do { (unif_tvs,res) <- report_fine_grain_unifs env thing_inside
    1805 1810 
                   ; let unif_happened = not (isEmptyVarSet unif_tvs)
    1806 1811 
                   ; when unif_happened $
    1807 1812 
                     TcM.updTcRef outer_tvs_ref (`unionVarSet` unif_tvs)
    1813 
    +              ; TcM.traceTc "reportCoarse(Fine)" $
    1814 
    +                vcat [ text "unif_tvs" <+> ppr unif_tvs
    1815 
    +                     , text "unif_happened" <+> ppr unif_happened ]
    1808 1816 
                   ; return (unif_happened, res) }
    1809 1817
    1810 1818 
     report_fine_grain_unifs :: TcSEnv -> (TcSEnv -> TcM a) -> TcM (TcTyVarSet, a)

  • compiler/GHC/Tc/Solver/Solve.hs
    ... ... @@ -359,7 +359,7 @@ solveNestedImplications :: Bag Implication
    359 359 
     -- to be converted to givens before we go inside a nested implication.
    360 360 
     solveNestedImplications implics
    361 361 
       | isEmptyBag implics
    362 
    -  = return (emptyBag)
    362 
    +  = return emptyBag
    363 363 
       | otherwise
    364 364 
       = do { traceTcS "solveNestedImplications starting {" empty
    365 365 
            ; unsolved_implics <- mapBagM solveImplication implics

  • compiler/GHC/Tc/Utils/Instantiate.hs
    ... ... @@ -13,7 +13,6 @@
    13 13 
     module GHC.Tc.Utils.Instantiate (
    14 14 
          topSkolemise, skolemiseRequired,
    15 15 
          topInstantiate,
    16 
    -     instantiateSigma,
    17 16 
          instCall, instDFunType, instStupidTheta, instTyVarsWith,
    18 17 
          newWanted, newWanteds,
    19 18
    ... ... @@ -283,38 +282,24 @@ topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
    283 282 
     -- NB: returns a type with no (=>),
    284 283 
     --     and no invisible forall at the top
    285 284 
     topInstantiate orig sigma
    286 
    -  | (tvs,   body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma
    287 
    -  , (theta, body2) <- tcSplitPhiTy body1
    285 
    +  | (tvs,   phi_ty)  <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma
    286 
    +  , (theta, body_ty) <- tcSplitPhiTy phi_ty
    288 287 
       , not (null tvs && null theta)
    289 
    -  = do { (_, wrap1, body3) <- instantiateSigma orig noConcreteTyVars tvs theta body2
    290 
    -           -- Why 'noConcreteTyVars' here?
    288 
    +  = do { (subst, inst_tvs) <- newMetaTyVarsX empty_subst tvs
    289 
    +           -- No need to worry about concrete tyvars here (c.f. instantiateSigma)
    291 290 
                -- See Note [Representation-polymorphism checking built-ins]
    292 291 
                -- in GHC.Tc.Utils.Concrete.
    293 292
    293 
    +       ; let inst_theta = substTheta subst theta
    294 
    +             inst_body  = substTy subst body_ty
    295 
    +
    296 
    +       ; wrap1 <- instCall orig (mkTyVarTys inst_tvs) inst_theta
    297 
    +
    294 298 
            -- Loop, to account for types like
    295 299 
            --       forall a. Num a => forall b. Ord b => ...
    296 
    -       ; (wrap2, body4) <- topInstantiate orig body3
    297 
    -
    298 
    -       ; return (wrap2 <.> wrap1, body4) }
    299 
    -
    300 
    -  | otherwise = return (idHsWrapper, sigma)
    301 
    -
    302 
    -instantiateSigma :: CtOrigin
    303 
    -                 -> ConcreteTyVars -- ^ concreteness information
    304 
    -                 -> [TyVar]
    305 
    -                 -> TcThetaType -> TcSigmaType
    306 
    -                 -> TcM ([TcTyVar], HsWrapper, TcSigmaType)
    307 
    --- (instantiate orig tvs theta ty)
    308 
    --- instantiates the type variables tvs, emits the (instantiated)
    309 
    --- constraints theta, and returns the (instantiated) type ty
    310 
    -instantiateSigma orig concs tvs theta body_ty
    311 
    -  = do { rec (subst, inst_tvs) <- mapAccumLM (new_meta subst) empty_subst tvs
    312 
    -       ; let inst_theta  = substTheta subst theta
    313 
    -             inst_body   = substTy subst body_ty
    314 
    -             inst_tv_tys = mkTyVarTys inst_tvs
    315 
    -
    316 
    -       ; wrap <- instCall orig inst_tv_tys inst_theta
    317 
    -       ; traceTc "Instantiating"
    300 
    +       ; (wrap2, inner_body) <- topInstantiate orig inst_body
    301 
    +
    302 
    +       ; traceTc "topInstantiate"
    318 303 
                      (vcat [ text "origin" <+> pprCtOrigin orig
    319 304 
                            , text "tvs"   <+> ppr tvs
    320 305 
                            , text "theta" <+> ppr theta
    ... ... @@ -322,23 +307,14 @@ instantiateSigma orig concs tvs theta body_ty
    322 307 
                            , text "with" <+> vcat (map debugPprType inst_tv_tys)
    323 308 
                            , text "theta:" <+> ppr inst_theta ])
    324 309
    325 
    -      ; return (inst_tvs, wrap, inst_body) }
    310 
    +      ; return (wrap2 <.> wrap1, inner_body) }
    311 
    +
    312 
    +  | otherwise
    313 
    +  = return (idHsWrapper, sigma)
    314 
    +
    326 315 
       where
    327 
    -    in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty))
    328 
    -               -- mkSpecSigmaTy: Inferred vs Specified is not important here;
    329 
    -               --                We just want an accurate free-var set
    330 
    -    empty_subst = mkEmptySubst in_scope
    331 
    -    new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar)
    332 
    -    new_meta final_subst subst tv
    333 
    -      -- Is this a type variable that must be instantiated to a concrete type?
    334 
    -      -- If so, create a ConcreteTv metavariable instead of a plain TauTv.
    335 
    -      -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.
    336 
    -      | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv)
    337 
    -      , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0
    338 
    -      -- See Note [substConcreteTvOrigin].
    339 
    -      = newConcreteTyVarX conc_orig subst tv
    340 
    -      | otherwise
    341 
    -      = newMetaTyVarX subst tv
    316 
    +    empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma))
    317 
    +
    342 318
    343 319 
     instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst
    344 320 
     -- Use this when you want to instantiate (forall a b c. ty) with

  • compiler/GHC/Tc/Utils/TcMType.hs
    ... ... @@ -1032,18 +1032,6 @@ newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar)
    1032 1032 
     -- an existing TyVar. We substitute kind variables in the kind.
    1033 1033 
     newMetaTyVarX = new_meta_tv_x TauTv
    1034 1034
    1035 
    --- | Like 'newMetaTyVarX', but for concrete type variables.
    1036 
    -newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar)
    1037 
    -newConcreteTyVarX conc subst tv
    1038 
    -  = do { th_lvl <- getThLevel
    1039 
    -       ; if
    1040 
    -          -- See [Wrinkle: Typed Template Haskell]
    1041 
    -          -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
    1042 
    -          | TypedBrack _  <- th_lvl
    1043 
    -          -> new_meta_tv_x TauTv subst tv
    1044 
    -          | otherwise
    1045 
    -          -> new_meta_tv_x (ConcreteTv conc) subst tv }
    1046 
    -
    1047 1035 
     newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar)
    1048 1036 
     -- Just like newMetaTyVarX, but make a TyVarTv
    1049 1037 
     newMetaTyVarTyVarX subst tv = new_meta_tv_x TyVarTv subst tv

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help