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

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/Coercion/Opt.hs
    1 1 
     -- (c) The University of Glasgow 2006
    2 2 
     {-# LANGUAGE CPP #-}
    3 3
    4 
    -module GHC.Core.Coercion.Opt( optCoProgram )
    4 
    +module GHC.Core.Coercion.Opt( optCoProgram, optCoRefl )
    5 5 
     where
    6 6
    7 7 
     import GHC.Prelude
    ... ... @@ -11,12 +11,13 @@ import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType )
    11 11 
     import GHC.Core
    12 12 
     import GHC.Core.TyCo.Rep
    13 13 
     import GHC.Core.TyCo.Subst
    14 
    -import GHC.Core.TyCo.Compare( eqForAllVis, eqTypeIgnoringMultiplicity )
    14 
    +import GHC.Core.TyCo.Compare( eqForAllVis, eqTypeIgnoringMultiplicity, eqType )
    15 15 
     import GHC.Core.Coercion
    16 16 
     import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )
    17 17 
     import GHC.Core.TyCon
    18 18 
     import GHC.Core.Coercion.Axiom
    19 19 
     import GHC.Core.Unify
    20 
    +import GHC.Core.Map.Type
    20 21
    21 22 
     import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped )
    22 23 
     import GHC.Types.Var
    ... ... @@ -24,6 +25,7 @@ import GHC.Types.Var.Set
    24 25 
     import GHC.Types.Var.Env
    25 26
    26 27 
     import GHC.Data.Pair
    28 
    +import GHC.Data.TrieMap
    27 29
    28 30 
     import GHC.Utils.Outputable
    29 31 
     import GHC.Utils.Constants (debugIsOn)
    ... ... @@ -229,6 +231,75 @@ optCoAlt is (Alt k bs e)
    229 231 
       = Alt k bs (optCoExpr (is `extendInScopeSetList` bs) e)
    230 232
    231 233
    234 
    +{- **********************************************************************
    235 
    +%*                                                                      *
    236 
    +                    optCoercionRefls
    237 
    +%*                                                                      *
    238 
    +%********************************************************************* -}
    239 
    +
    240 
    +optCoRefl :: Coercion -> Coercion
    241 
    +optCoRefl in_co
    242 
    +  = let out_co = go in_co
    243 
    +        (Pair in_l in_r) = coercionKind in_co
    244 
    +        (Pair out_l out_r) = coercionKind out_co
    245 
    +    in if (in_l `eqType` out_l) && (in_r `eqType` out_r)
    246 
    +       then out_co
    247 
    +       else pprTrace "optReflCo" (vcat [ text "in_l:"  <+> ppr in_l
    248 
    +                                       , text "in_r:"  <+> ppr in_r
    249 
    +                                       , text "out_l:" <+> ppr out_l
    250 
    +                                       , text "out_r:" <+> ppr out_r
    251 
    +                                       , text "in_co:" <+> ppr in_co
    252 
    +                                       , text "out_co:" <+> ppr out_co ]) $
    253 
    +            out_co
    254 
    +  where
    255 
    +    go_m MRefl    = MRefl
    256 
    +    go_m (MCo co) = MCo (go co)
    257 
    +
    258 
    +    go_s cos = map go cos
    259 
    +
    260 
    +    go co@(Refl {})                  = co
    261 
    +    go co@(GRefl {})                 = co
    262 
    +    go co@(CoVarCo {})               = co
    263 
    +    go co@(HoleCo {})                = co
    264 
    +    go (SymCo co)                    = mkSymCo (go co)
    265 
    +    go (KindCo co)                   = mkKindCo (go co)
    266 
    +    go (SubCo co)                    = mkSubCo (go co)
    267 
    +    go (SelCo n co)                  = mkSelCo n (go co)
    268 
    +    go (LRCo n co)                   = mkLRCo n (go co)
    269 
    +    go (AppCo co1 co2)               = mkAppCo (go co1) (go co2)
    270 
    +    go (InstCo co1 co2)              = mkInstCo (go co1) (go co2)
    271 
    +    go (ForAllCo v vl vr mco co)     = mkForAllCo v vl vr (go_m mco) (go co)
    272 
    +    go (FunCo r afl afr com coa cor) = mkFunCo2 r afl afr (go com) (go coa) (go cor)
    273 
    +    go (TyConAppCo r tc cos)         = mkTyConAppCo r tc (go_s cos)
    274 
    +    go (UnivCo p r lt rt cos)        = mkUnivCo p (go_s cos) r lt rt
    275 
    +    go (AxiomCo ax cos)              = mkAxiomCo ax (go_s cos)
    276 
    +
    277 
    +    go (TransCo co1 co2) = gobble gs0 co1 [co2]
    278 
    +       where
    279 
    +         lk   = coercionLKind co1
    280 
    +         role = coercionRole co1
    281 
    +
    282 
    +         gs0 :: GobbleState
    283 
    +         gs0 = GS (mkReflCo role lk) (insertTM lk gs0 emptyTM)
    284 
    +
    285 
    +    gobble :: GobbleState -> Coercion -> [Coercion] -> Coercion
    286 
    +    -- gobble (GS co1 tm) co2 cos   returns a coercion equivalent to (co1;co2;cos)
    287 
    +    gobble gs (TransCo co2 co3) cos
    288 
    +       = gobble gs co2 (co3 : cos)
    289 
    +    gobble (GS co1 tm) co2 cos
    290 
    +       = case lookupTM rk tm of
    291 
    +            Just gs -> pprTrace "optCoRefl:hit eliminated" (ppr (TransCo co1 co2)) $
    292 
    +                       gobble0 gs  cos
    293 
    +            Nothing -> gobble0 gs' cos
    294 
    +       where
    295 
    +         rk = coercionRKind co2
    296 
    +         gs' = GS (co1 `mkTransCo` co2) (insertTM rk gs' tm)
    297 
    +
    298 
    +    gobble0 (GS co _) [] = co
    299 
    +    gobble0 gs (co:cos)  = gobble gs co cos
    300 
    +
    301 
    +data GobbleState = GS Coercion (TypeMap GobbleState)
    302 
    +
    232 303 
     {- **********************************************************************
    233 304 
     %*                                                                      *
    234 305 
                         optCoercion

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -26,6 +26,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind
    26 26 
     import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )
    27 27 
     import qualified GHC.Core.Make
    28 28 
     import GHC.Core.Coercion hiding ( substCo, substCoVar )
    29 
    +import GHC.Core.Coercion.Opt
    29 30 
     import GHC.Core.Reduction
    30 31 
     import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )
    31 32 
     import GHC.Core.DataCon
    ... ... @@ -721,15 +722,12 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
    721 722 
            ; let all_floats = rhs_floats1 `addLetFloats` anf_floats
    722 723 
            ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2
    723 724 
              then -- Float!
    724 
    -              simplTrace "prepareBinding:yes" (ppr all_floats $$ text "rhs" <+> ppr rhs2) $
    725 725 
                   do { tick LetFloatFromLet
    726 726 
                      ; return (all_floats, rhs2) }
    727 727
    728 728 
              else -- Abandon floating altogether; revert to original rhs
    729 729 
                   -- Since we have already built rhs1, we just need to add
    730 730 
                   -- rhs_floats1 to it
    731 
    -              simplTrace "prepareBinding:no" (vcat [ ppr all_floats
    732 
    -                                                   , text "rhs" <+> ppr rhs2 ]) $
    733 731 
                   return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }
    734 732
    735 733 
     {- Note [prepareRhs]
    ... ... @@ -1392,7 +1390,7 @@ simplCoercionF env co cont
    1392 1390
    1393 1391 
     simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
    1394 1392 
     simplCoercion env co
    1395 
    -  = do { let out_co = substCo env co
    1393 
    +  = do { let out_co = optCoRefl (substCo env co)
    1396 1394 
            ; seqCo out_co `seq` return out_co }
    1397 1395
    1398 1396 
     -----------------------------------

  • compiler/GHC/Core/Ppr.hs
    ... ... @@ -169,7 +169,9 @@ noParens pp = pp
    169 169 
     pprOptCo :: Coercion -> SDoc
    170 170 
     -- Print a coercion optionally; i.e. honouring -dsuppress-coercions
    171 171 
     pprOptCo co = sdocOption sdocSuppressCoercions $ \case
    172 
    -              True  -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type
    172 
    +              True  -> angleBrackets (text "Co:" <> int (coercionSize co)
    173 
    +                                      <+> ppr (coVarsOfCo co))
    174 
    +                       <+> dcolon <+> co_type
    173 175 
                   False -> parens $ sep [ppr co, dcolon <+> co_type]
    174 176 
         where
    175 177 
           co_type = sdocOption sdocSuppressCoercionTypes $ \case

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