Commit b47a6c3a authored by alexvieth's avatar alexvieth Committed by Richard Eisenberg

Fix performance of flattener patch (#12919)

This patch, authored by alexvieth and reviewed at D4451,
makes performance improvements by critically optimizing parts
of the flattener.

Summary:
T3064, T5321FD, T5321Fun, T9872a, T9872b, T9872c all pass.
T9872a and T9872c show improvements beyond the -5% threshold.
T9872d fails at 10.9% increased allocations.
parent e3dbb44f
This diff is collapsed.
......@@ -7,7 +7,7 @@
-- and newtypes
module CoAxiom (
BranchFlag, Branched, Unbranched, BranchIndex, Branches,
BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),
manyBranches, unbranched,
fromBranches, numBranches,
mapAccumBranches,
......
......@@ -1666,7 +1666,6 @@ coercionType co = case coercionKindRole co of
coercionKind :: Coercion -> Pair Type
coercionKind co =
{-# SCC "coercionKind" #-}
go co
where
go (Refl _ ty) = Pair ty ty
......
......@@ -2,7 +2,7 @@
--
-- FamInstEnv: Type checked family instance declarations
{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-}
{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns #-}
module FamInstEnv (
FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
......@@ -63,6 +63,7 @@ import FastString
import MonadUtils
import Control.Monad
import Data.List( mapAccumL )
import Data.Array( Array, assocs )
{-
************************************************************************
......@@ -974,7 +975,6 @@ lookup_fam_inst_env' match_fun ie fam match_tys
-- No match => try next
| otherwise
= find rest
where
(rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys
......@@ -1121,21 +1121,25 @@ chooseBranch axiom tys
(target_tys, extra_tys) = splitAt num_pats tys
branches = coAxiomBranches axiom
; (ind, inst_tys, inst_cos)
<- findBranch (fromBranches branches) target_tys
<- findBranch (unMkBranches branches) target_tys
; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }
-- The axiom must *not* be oversaturated
findBranch :: [CoAxBranch] -- branches to check
-> [Type] -- target types
findBranch :: Array BranchIndex CoAxBranch
-> [Type]
-> Maybe (BranchIndex, [Type], [Coercion])
-- coercions relate requested types to returned axiom LHS at role N
findBranch branches target_tys
= go 0 branches
= foldr go Nothing (assocs branches)
where
go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs
, cab_lhs = tpl_lhs
, cab_incomps = incomps }) : rest)
= let in_scope = mkInScopeSet (unionVarSets $
go :: (BranchIndex, CoAxBranch)
-> Maybe (BranchIndex, [Type], [Coercion])
-> Maybe (BranchIndex, [Type], [Coercion])
go (index, branch) other
= let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs
, cab_lhs = tpl_lhs
, cab_incomps = incomps }) = branch
in_scope = mkInScopeSet (unionVarSets $
map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
-- See Note [Flattening] below
flattened_target = flattenTys in_scope target_tys
......@@ -1145,13 +1149,10 @@ findBranch branches target_tys
-> -- matching worked & we're apart from all incompatible branches.
-- success
ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )
Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
-- failure. keep looking
_ -> go (ind+1) rest
-- fail if no branches left
go _ [] = Nothing
_ -> other
-- | Do an apartness check, as described in the "Closed Type Families" paper
-- (POPL '14). This should be used when determining if an equation
......
......@@ -1307,8 +1307,9 @@ splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type)
splitForAllTyVarBndrs ty = split ty ty []
where
split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
split _ (ForAllTy b res) bs = split res res (b:bs)
split orig_ty _ bs = (reverse bs, orig_ty)
split _ (ForAllTy b res) bs = split res res (b:bs)
split orig_ty _ bs = (reverse bs, orig_ty)
{-# INLINE splitForAllTyVarBndrs #-}
-- | Checks whether this is a proper forall (with a named binder)
isForAllTy :: Type -> Bool
......@@ -1365,12 +1366,14 @@ splitPiTy ty
-- | Split off all TyBinders to a type, splitting both proper foralls
-- and functions
splitPiTys :: Type -> ([TyBinder], Type)
splitPiTys ty = split ty ty []
splitPiTys ty = split ty ty
where
split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
split _ (ForAllTy b res) bs = split res res (Named b : bs)
split _ (FunTy arg res) bs = split res res (Anon arg : bs)
split orig_ty _ bs = (reverse bs, orig_ty)
split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
split _ (ForAllTy b res) = let (bs, ty) = split res res
in (Named b : bs, ty)
split _ (FunTy arg res) = let (bs, ty) = split res res
in (Anon arg : bs, ty)
split orig_ty _ = ([], orig_ty)
-- Like splitPiTys, but returns only *invisible* binders, including constraints
-- Stops at the first visible binder
......
......@@ -816,7 +816,7 @@ test('T9675',
test('T9872a',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 3005891848, 5),
[(wordsize(64), 2729927408, 5),
# 2014-12-10 5521332656 Initally created
# 2014-12-16 5848657456 Flattener parameterized over roles
# 2014-12-18 2680733672 Reduce type families even more eagerly
......@@ -825,6 +825,7 @@ test('T9872a',
# 2016-10-19 3134866040 Refactor traceRn interface (#12617)
# 2017-02-17 3298422648 Type-indexed Typeable
# 2017-02-25 3005891848 Early inlining patch
# 2018-03-26 2729927408 Flattener update with optimizations (#12919)
(wordsize(32), 1493198244, 5)
# was 1325592896
......@@ -859,7 +860,7 @@ test('T9872b',
test('T9872c',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 3404346032, 5),
[(wordsize(64), 3096670112, 5),
# 2014-12-10 5495850096 Initally created
# 2014-12-16 5842024784 Flattener parameterized over roles
# 2014-12-18 2963554096 Reduce type families even more eagerly
......@@ -868,6 +869,7 @@ test('T9872c',
# 2016-04-06: 4306667256 Refactoring of CSE #11781
# 2016-09-15: 3702580928 Fixing #12422
# 2017-02-14 3404346032 Early inlining: 5% improvement
# 2018-03-25 3096670112 Flattener patch with optimizations (#12919)
(wordsize(32), 1727582260, 5)
# was 1500000000
......@@ -880,7 +882,7 @@ test('T9872c',
test('T9872d',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 462817352, 5),
[(wordsize(64), 526485920, 5),
# 2014-12-18 796071864 Initally created
# 2014-12-18 739189056 Reduce type families even more eagerly
# 2015-01-07 687562440 TrieMap leaf compression
......@@ -893,6 +895,7 @@ test('T9872d',
# 2017-02-17 535565128 Type-indexed Typeable
# 2017-02-25 498855104 Early inlining
# 2017-03-03 462817352 Share Typeable KindReps
# 2018-03-25 526485920 Flattener patch does more work (#12919)
(wordsize(32), 232954000, 5)
# some date 328810212
......
T14846.hs:38:8: error:
• Couldn't match kind ‘cls1’ with ‘cls0
cls1’ is a rigid type variable bound by
• Couldn't match type ‘ríki1’ with ‘Hom ríki
ríki1’ is a rigid type variable bound by
the type signature for:
i :: forall k5 (cls1 :: k5
-> Constraint) k6 (xx :: k6) (a :: Struct cls1) (ríki1 :: Struct
......@@ -12,9 +12,6 @@ T14846.hs:38:8: error:
StructI xx a =>
ríki1 a a
at T14846.hs:38:8-48
When matching types
a0 :: Struct cls0
a :: Struct cls1
Expected type: ríki1 a a
Actual type: Hom ríki a0 a0
• When checking that instance signature for ‘i’
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment