Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/CoreToIface.hs
    ... ... @@ -223,9 +223,6 @@ toIfaceTypeX fr (TyConApp tc tys)
    223 223 
     toIfaceTyVar :: TyVar -> IfLclName
    224 224 
     toIfaceTyVar = mkIfLclName . occNameFS . getOccName
    225 225
    226 
    -toIfaceCoVar :: CoVar -> IfLclName
    227 
    -toIfaceCoVar = mkIfLclName . occNameFS . getOccName
    228 
    -
    229 226 
     ----------------
    230 227 
     toIfaceTyCon :: TyCon -> IfaceTyCon
    231 228 
     toIfaceTyCon tc
    ... ... @@ -287,7 +284,11 @@ toIfaceCoercionX fr co
    287 284 
         go (CoVarCo cv)
    288 285 
           -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type
    289 286 
           | cv `elemVarSet` fr = IfaceFreeCoVar cv
    290 
    -      | otherwise          = IfaceCoVarCo (toIfaceCoVar cv)
    287 
    +      | isExternalName nm  = IfaceExtCoVar nm
    288 
    +      | otherwise          = IfaceCoVarCo (mkIfLclName $ occNameFS $ nameOccName nm)
    289 
    +      where
    290 
    +        nm = idName cv
    291 
    +
    291 292 
         go (HoleCo h)          = IfaceHoleCo  (coHoleCoVar h)
    292 293
    293 294 
         go (AppCo co1 co2)     = IfaceAppCo  (go co1) (go co2)
    ... ... @@ -454,6 +455,7 @@ toIfaceTopBndr id
    454 455 
     toIfaceIdDetails :: IdDetails -> IfaceIdDetails
    455 456 
     toIfaceIdDetails VanillaId                      = IfVanillaId
    456 457 
     toIfaceIdDetails (WorkerLikeId dmds)            = IfWorkerLikeId dmds
    458 
    +toIfaceIdDetails CoVarId                        = IfCoVarId
    457 459 
     toIfaceIdDetails (DFunId {})                    = IfDFunId
    458 460 
     toIfaceIdDetails (RecSelId { sel_naughty = n
    459 461 
                                , sel_tycon = tc

  • compiler/GHC/Iface/Rename.hs
    ... ... @@ -886,13 +886,14 @@ rnIfaceMCo IfaceMRefl = pure IfaceMRefl
    886 886 
     rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
    887 887
    888 888 
     rnIfaceCo :: Rename IfaceCoercion
    889 
    +rnIfaceCo co@(IfaceExtCoVar {})         = pure co
    890 
    +rnIfaceCo co@(IfaceFreeCoVar {})        = pure co
    891 
    +rnIfaceCo co@(IfaceCoVarCo {})          = pure co
    889 892 
     rnIfaceCo (IfaceReflCo ty)              = IfaceReflCo <$> rnIfaceType ty
    890 893 
     rnIfaceCo (IfaceGReflCo role ty mco)    = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
    891 894 
     rnIfaceCo (IfaceFunCo role w co1 co2)   = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2
    892 895 
     rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
    893 896 
     rnIfaceCo (IfaceAppCo co1 co2)          = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
    894 
    -rnIfaceCo (IfaceFreeCoVar c)            = pure (IfaceFreeCoVar c)
    895 
    -rnIfaceCo (IfaceCoVarCo lcl)            = IfaceCoVarCo <$> pure lcl
    896 897 
     rnIfaceCo (IfaceHoleCo lcl)             = IfaceHoleCo  <$> pure lcl
    897 898 
     rnIfaceCo (IfaceSymCo c)                = IfaceSymCo <$> rnIfaceCo c
    898 899 
     rnIfaceCo (IfaceTransCo c1 c2)          = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2

  • compiler/GHC/Iface/Syntax.hs
    ... ... @@ -490,6 +490,7 @@ data IfGuidance
    490 490
    491 491 
     data IfaceIdDetails
    492 492 
       = IfVanillaId
    493 
    +  | IfCoVarId
    493 494 
       | IfWorkerLikeId [CbvMark]
    494 495 
       | IfRecSelId
    495 496 
         { ifRecSelIdParent     :: Either IfaceTyCon IfaceDecl
    ... ... @@ -1877,6 +1878,7 @@ instance Outputable IfaceIdDetails where
    1877 1878 
                                       then text "<naughty>"
    1878 1879 
                                       else Outputable.empty
    1879 1880 
       ppr IfDFunId          = text "DFunId"
    1881 
    +  ppr IfCoVarId         = text "CoVarId"
    1880 1882
    1881 1883 
     instance Outputable IfaceInfoItem where
    1882 1884 
       ppr (HsUnfold lb unf)     = text "Unfolding"
    ... ... @@ -1994,6 +1996,7 @@ freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) =
    1994 1996 
     freeNamesIfIdDetails IfVanillaId         = emptyNameSet
    1995 1997 
     freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet
    1996 1998 
     freeNamesIfIdDetails IfDFunId            = emptyNameSet
    1999 
    +freeNamesIfIdDetails IfCoVarId           = emptyNameSet
    1997 2000
    1998 2001 
     -- All other changes are handled via the version info on the tycon
    1999 2002 
     freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
    ... ... @@ -2086,6 +2089,7 @@ freeNamesIfCoercion (IfaceAppCo c1 c2)
    2086 2089 
     freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co)
    2087 2090 
       = freeNamesIfMCoercion kind_co &&& freeNamesIfCoercion co
    2088 2091 
     freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
    2092 
    +freeNamesIfCoercion (IfaceExtCoVar n)  = unitNameSet n
    2089 2093 
     freeNamesIfCoercion (IfaceCoVarCo _)   = emptyNameSet
    2090 2094 
     freeNamesIfCoercion (IfaceHoleCo _)    = emptyNameSet
    2091 2095 
     freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos)
    ... ... @@ -2718,6 +2722,7 @@ instance Binary IfaceIdDetails where
    2718 2722 
                                            ; put_ bh d }
    2719 2723 
         put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds
    2720 2724 
         put_ bh IfDFunId              = putByte bh 3
    2725 
    +    put_ bh IfCoVarId             = putByte bh 4
    2721 2726 
         get bh = do
    2722 2727 
             h <- getByte bh
    2723 2728 
             case h of
    ... ... @@ -2729,7 +2734,8 @@ instance Binary IfaceIdDetails where
    2729 2734 
                         ; return (IfRecSelId a b c d) }
    2730 2735 
                 2 -> do { dmds <- get bh
    2731 2736 
                         ; return (IfWorkerLikeId dmds) }
    2732 
    -            _ -> return IfDFunId
    2737 
    +            3 -> return IfDFunId
    2738 
    +            _ -> return IfCoVarId
    2733 2739
    2734 2740 
     instance Binary IfaceInfoItem where
    2735 2741 
         put_ bh (HsArity aa)          = putByte bh 0 >> put_ bh aa
    ... ... @@ -3167,7 +3173,8 @@ instance NFData IfaceIdDetails where
    3167 3173 
         IfWorkerLikeId dmds -> rnf dmds `seq` ()
    3168 3174 
         IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d
    3169 3175 
         IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d
    3170 
    -    IfDFunId -> ()
    3176 
    +    IfDFunId  -> ()
    3177 
    +    IfCoVarId -> ()
    3171 3178
    3172 3179 
     instance NFData IfaceInfoItem where
    3173 3180 
       rnf = \case

  • compiler/GHC/Iface/Type.hs
    ... ... @@ -475,13 +475,15 @@ data IfaceMCoercion
    475 475 
       | IfaceMCo IfaceCoercion deriving (Eq, Ord)
    476 476
    477 477 
     data IfaceCoercion
    478 
    -  = IfaceReflCo       IfaceType
    478 
    +  = IfaceFreeCoVar    CoVar       -- ^ See Note [Free TyVars and CoVars in IfaceType]
    479 
    +  | IfaceExtCoVar     IfExtName   -- Imported or top-level external coercion var
    480 
    +  | IfaceCoVarCo      IfLclName   -- Regular, locally-bound coercion var
    481 
    +  | IfaceReflCo       IfaceType
    479 482 
       | IfaceGReflCo      Role IfaceType (IfaceMCoercion)
    480 483 
       | IfaceFunCo        Role IfaceCoercion IfaceCoercion IfaceCoercion
    481 484 
       | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]
    482 485 
       | IfaceAppCo        IfaceCoercion IfaceCoercion
    483 486 
       | IfaceForAllCo     IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceMCoercion IfaceCoercion
    484 
    -  | IfaceCoVarCo      IfLclName
    485 487 
       | IfaceAxiomCo      IfaceAxiomRule [IfaceCoercion]
    486 488 
            -- ^ There are only a fixed number of CoAxiomRules, so it suffices
    487 489 
            -- to use an IfaceLclName to distinguish them.
    ... ... @@ -494,7 +496,6 @@ data IfaceCoercion
    494 496 
       | IfaceInstCo       IfaceCoercion IfaceCoercion
    495 497 
       | IfaceKindCo       IfaceCoercion
    496 498 
       | IfaceSubCo        IfaceCoercion
    497 
    -  | IfaceFreeCoVar    CoVar    -- ^ See Note [Free TyVars and CoVars in IfaceType]
    498 499 
       | IfaceHoleCo       CoVar    -- ^ See Note [Holes in IfaceCoercion]
    499 500 
       deriving (Eq, Ord)
    500 501 
       -- Why Ord?  See Note [Ord instance of IfaceType]
    ... ... @@ -779,9 +780,10 @@ substIfaceType env ty
    779 780 
         go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
    780 781 
         go_co (IfaceAppCo c1 c2)         = IfaceAppCo (go_co c1) (go_co c2)
    781 782 
         go_co (IfaceForAllCo {})         = pprPanic "substIfaceCoercion" (ppr ty)
    782 
    -    go_co (IfaceFreeCoVar cv)        = IfaceFreeCoVar cv
    783 
    -    go_co (IfaceCoVarCo cv)          = IfaceCoVarCo cv
    784 
    -    go_co (IfaceHoleCo cv)           = IfaceHoleCo cv
    783 
    +    go_co co@(IfaceFreeCoVar {})     = co
    784 
    +    go_co co@(IfaceExtCoVar {})      = co
    785 
    +    go_co co@(IfaceCoVarCo {})       = co
    786 
    +    go_co co@(IfaceHoleCo {})        = co
    785 787 
         go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds)
    786 788 
         go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)
    787 789 
         go_co (IfaceTransCo co1 co2)     = IfaceTransCo (go_co co1) (go_co co2)
    ... ... @@ -2076,8 +2078,9 @@ ppr_co ctxt_prec co@(IfaceForAllCo {})
    2076 2078 
           = let (tvs, co'') = split_co co' in ((bndr,kind_co,visL,visR):tvs,co'')
    2077 2079 
         split_co co' = ([], co')
    2078 2080
    2079 
    --- Why these three? See Note [Free TyVars and CoVars in IfaceType]
    2081 
    +-- Why these four? See Note [Free TyVars and CoVars in IfaceType]
    2080 2082 
     ppr_co _ (IfaceFreeCoVar covar) = ppr covar
    2083 
    +ppr_co _ (IfaceExtCoVar covar)  = ppr covar
    2081 2084 
     ppr_co _ (IfaceCoVarCo covar)   = ppr covar
    2082 2085 
     ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar)
    2083 2086
    ... ... @@ -2457,6 +2460,9 @@ instance Binary IfaceCoercion where
    2457 2460 
       put_ bh (IfaceCoVarCo a) = do
    2458 2461 
               putByte bh 7
    2459 2462 
               put_ bh a
    2463 
    +  put_ bh (IfaceExtCoVar a) = do
    2464 
    +          putByte bh 8
    2465 
    +          put_ bh a
    2460 2466 
       put_ bh (IfaceUnivCo a b c d deps) = do
    2461 2467 
               putByte bh 9
    2462 2468 
               put_ bh a
    ... ... @@ -2530,6 +2536,8 @@ instance Binary IfaceCoercion where
    2530 2536 
                        return $ IfaceForAllCo a visL visR b c
    2531 2537 
                7 -> do a <- get bh
    2532 2538 
                        return $ IfaceCoVarCo a
    2539 
    +           8 -> do a <- get bh
    2540 
    +                   return $ IfaceExtCoVar a
    2533 2541 
                9 -> do a <- get bh
    2534 2542 
                        b <- get bh
    2535 2543 
                        c <- get bh
    ... ... @@ -2605,13 +2613,14 @@ instance NFData IfaceTyLit where
    2605 2613
    2606 2614 
     instance NFData IfaceCoercion where
    2607 2615 
       rnf = \case
    2616 
    +    IfaceExtCoVar f1 -> rnf f1
    2617 
    +    IfaceCoVarCo f1 -> rnf f1
    2608 2618 
         IfaceReflCo f1 -> rnf f1
    2609 2619 
         IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
    2610 2620 
         IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
    2611 2621 
         IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
    2612 2622 
         IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2
    2613 2623 
         IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5
    2614 
    -    IfaceCoVarCo f1 -> rnf f1
    2615 2624 
         IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2
    2616 2625 
         IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps
    2617 2626 
         IfaceSymCo f1 -> rnf f1

  • compiler/GHC/IfaceToCore.hs
    ... ... @@ -1582,41 +1582,35 @@ tcIfaceCo = go
    1582 1582 
         go_mco IfaceMRefl    = pure MRefl
    1583 1583 
         go_mco (IfaceMCo co) = MCo <$> (go co)
    1584 1584
    1585 
    +    go (IfaceExtCoVar n)         = CoVarCo <$> tcIfaceExtId n
    1586 
    +    go (IfaceCoVarCo n)          = CoVarCo <$> tcIfaceLclId n
    1585 1587 
         go (IfaceReflCo t)           = Refl <$> tcIfaceType t
    1586 1588 
         go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco
    1587 1589 
         go (IfaceFunCo r w c1 c2)    = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2
    1588 1590 
         go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
    1589 1591 
         go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2
    1592 
    +    go (IfaceSymCo c)            = SymCo     <$> go c
    1593 
    +    go (IfaceTransCo c1 c2)      = TransCo   <$> go c1 <*> go c2
    1594 
    +    go (IfaceInstCo c1 t2)       = InstCo    <$> go c1 <*> go t2
    1595 
    +    go (IfaceSelCo d c)          = mkSelCo d <$> go c
    1596 
    +    go (IfaceLRCo lr c)          = LRCo lr   <$> go c
    1597 
    +    go (IfaceKindCo c)           = KindCo    <$> go c
    1598 
    +    go (IfaceSubCo c)            = SubCo     <$> go c
    1590 1599 
         go (IfaceForAllCo tcv visL visR k co)
    1591 1600 
           = do { k' <- go_mco k
    1592 1601 
                ; bindIfaceBndr tcv $ \ tv' ->
    1593 1602 
             do { co' <- go co
    1594 1603 
                ; return (ForAllCo { fco_tcv = tv', fco_visL = visL, fco_visR = visR
    1595 1604 
                                   , fco_kind = k', fco_body = co' }) } }
    1596 
    -    go (IfaceCoVarCo n)           = CoVarCo <$> go_var n
    1597 1605 
         go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2
    1598 1606 
                                            ; ds' <- mapM go ds
    1599 1607 
                                            ; return (UnivCo { uco_prov = p, uco_role = r
    1600 1608 
                                                             , uco_lty = t1', uco_rty = t2'
    1601 1609 
                                                             , uco_deps = ds' }) }
    1602 
    -    go (IfaceSymCo c)            = SymCo    <$> go c
    1603 
    -    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1
    1604 
    -                                            <*> go c2
    1605 
    -    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
    1606 
    -                                            <*> go t2
    1607 
    -    go (IfaceSelCo d c)          = do { c' <- go c
    1608 
    -                                      ; return $ mkSelCo d c' }
    1609 
    -    go (IfaceLRCo lr c)          = LRCo lr  <$> go c
    1610 
    -    go (IfaceKindCo c)           = KindCo   <$> go c
    1611 
    -    go (IfaceSubCo c)            = SubCo    <$> go c
    1612 
    -    go (IfaceAxiomCo ax cos)     = AxiomCo <$> tcIfaceAxiomRule ax
    1613 
    -                                           <*> mapM go cos
    1610 
    +    go (IfaceAxiomCo ax cos)     = AxiomCo <$> tcIfaceAxiomRule ax <*> mapM go cos
    1614 1611 
         go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
    1615 1612 
         go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
    1616 1613
    1617 
    -    go_var :: IfLclName -> IfL CoVar
    1618 
    -    go_var = tcIfaceLclId
    1619 
    -
    1620 1614 
     {-
    1621 1615 
     ************************************************************************
    1622 1616 
     *                                                                      *
    ... ... @@ -1801,6 +1795,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs
    1801 1795
    1802 1796 
     tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails
    1803 1797 
     tcIdDetails _ _  IfVanillaId           = return VanillaId
    1798 
    +tcIdDetails _ _  IfCoVarId             = return CoVarId
    1804 1799 
     tcIdDetails _ _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds
    1805 1800 
     tcIdDetails _ ty IfDFunId              = return (DFunId (isUnaryClass cls))
    1806 1801 
       where

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