diff options
-rw-r--r-- | compiler/specialise/Specialise.hs | 413 | ||||
-rw-r--r-- | testsuite/tests/deriving/perf/all.T | 4 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T13429.hs | 114 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429.hs | 63 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429_2.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429_2.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429_2a.hs | 37 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T13429a.hs | 343 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 2 |
11 files changed, 700 insertions, 289 deletions
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 66301a5290..a1ee94c59e 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -17,18 +17,21 @@ import Coercion( Coercion ) import CoreMonad import qualified CoreSubst import CoreUnfold +import Var ( isLocalVar ) import VarSet import VarEnv import CoreSyn import Rules import CoreOpt ( collectBindersPushingCo ) import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) -import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList ) +import CoreFVs +import FV ( InterestingVarFun ) import CoreArity ( etaExpandToJoinPointRule ) import UniqSupply import Name import MkId ( voidArgId, voidPrimId ) import Maybes ( catMaybes, isJust ) +import MonadUtils ( foldlM ) import BasicTypes import HscTypes import Bag @@ -38,7 +41,6 @@ import Outputable import FastString import State import UniqDFM -import TrieMap import Control.Monad #if __GLASGOW_HASKELL__ > 710 @@ -585,16 +587,11 @@ specProgram guts@(ModGuts { mg_module = this_mod ; hpt_rules <- getRuleBase ; let rule_base = extendRuleBaseList hpt_rules local_rules ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet - [] rule_base (ud_calls uds) - - -- Don't forget to wrap the specialized bindings with bindings - -- for the needed dictionaries. - -- See Note [Wrap bindings returned by specImports] - ; let spec_binds' = wrapDictBinds (ud_binds uds) spec_binds + [] rule_base uds ; let final_binds - | null spec_binds' = binds' - | otherwise = Rec (flattenBinds spec_binds') : binds' + | null spec_binds = binds' + | otherwise = Rec (flattenBinds spec_binds) : binds' -- Note [Glom the bindings if imported functions are specialised] ; return (guts { mg_binds = final_binds @@ -644,26 +641,41 @@ specImports :: DynFlags -> [Id] -- Stack of imported functions being specialised -> RuleBase -- Rules from this module and the home package -- (but not external packages, which can change) - -> CallDetails -- Calls for imported things, and floating bindings + -> UsageDetails -- Calls for imported things, and floating bindings -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -- See Note [Wrapping bindings returned by specImports] -specImports dflags this_mod top_env done callers rule_base cds +specImports dflags this_mod top_env done callers rule_base + (MkUD { ud_binds = dict_binds, ud_calls = calls }) -- See Note [Disabling cross-module specialisation] - | not $ gopt Opt_CrossModuleSpecialise dflags = - return ([], []) + | not $ gopt Opt_CrossModuleSpecialise dflags + = return ([], []) - | otherwise = - do { let import_calls = dVarEnvElts cds + | otherwise + = do { let import_calls = dVarEnvElts calls ; (rules, spec_binds) <- go rule_base import_calls - ; return (rules, spec_binds) } + + -- Don't forget to wrap the specialized bindings with + -- bindings for the needed dictionaries. + -- See Note [Wrap bindings returned by specImports] + ; let spec_binds' = wrapDictBinds dict_binds spec_binds + + ; return (rules, spec_binds') } where go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) go _ [] = return ([], []) - go rb (cis@(CIS fn _calls_for_fn) : other_calls) - = do { (rules1, spec_binds1) <- specImport dflags this_mod top_env - done callers rb fn $ - ciSetToList cis + go rb (cis@(CIS fn _) : other_calls) + = do { let ok_calls = filterCalls cis dict_binds + -- Drop calls that (directly or indirectly) refer to fn + -- See Note [Avoiding loops] +-- ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn +-- , text "calls" <+> ppr cis +-- , text "ud_binds =" <+> ppr dict_binds +-- , text "dump set =" <+> ppr dump_set +-- , text "filtered calls =" <+> ppr ok_calls ]) + ; (rules1, spec_binds1) <- specImport dflags this_mod top_env + done callers rb fn ok_calls + ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } @@ -698,9 +710,10 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn ; let full_rb = unionRuleBase rb (eps_rule_base eps) rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn - ; (rules1, spec_pairs, uds) <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $ - runSpecM dflags this_mod $ - specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs + ; (rules1, spec_pairs, uds) + <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $ + runSpecM dflags this_mod $ + specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later @@ -712,13 +725,9 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn (extendVarSet done fn) (fn:callers) (extendRuleBaseList rb rules1) - (ud_calls uds) + uds - -- Don't forget to wrap the specialized bindings with bindings - -- for the needed dictionaries - -- See Note [Wrap bindings returned by specImports] - ; let final_binds = wrapDictBinds (ud_binds uds) - (spec_binds2 ++ spec_binds1) + ; let final_binds = spec_binds2 ++ spec_binds1 ; return (rules2 ++ rules1, final_binds) } @@ -1043,24 +1052,24 @@ specBind rhs_env (NonRec fn rhs) body_uds -- so put the latter first combined_uds = body_uds1 `plusUDs` rhs_uds - -- This way round a call in rhs_uds of a function f - -- at type T will override a call of f at T in body_uds1; and - -- that is good because it'll tend to keep "earlier" calls - -- See Note [Specialisation of dictionary functions] (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - -- See Note [From non-recursive to recursive] final_binds :: [DictBind] + -- See Note [From non-recursive to recursive] final_binds - | isEmptyBag dump_dbs = [mkDB $ NonRec b r | (b,r) <- pairs] - | otherwise = [flattenDictBinds dump_dbs pairs] + | not (isEmptyBag dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ bagToList dump_dbs - ; if float_all then + ; if float_all then -- Rather than discard the calls mentioning the bound variables - -- we float this binding along with the others + -- we float this (dictionary) binding along with the others return ([], free_uds `snocDictBinds` final_binds) - else + else -- No call in final_uds mentions bound variables, -- so we can just leave the binding here return (map fst final_binds, free_uds) } @@ -1084,13 +1093,13 @@ specBind rhs_env (Rec pairs) body_uds ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 - bind = flattenDictBinds dumped_dbs - (spec_defns3 ++ zip bndrs3 rhss') + final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') + dumped_dbs ; if float_all then - return ([], final_uds `snocDictBind` bind) - else - return ([fst bind], final_uds) } + return ([], final_uds `snocDictBind` final_bind) + else + return ([fst final_bind], final_uds) } --------------------------- @@ -1141,18 +1150,20 @@ specDefn env body_uds fn rhs specCalls :: Maybe Module -- Just this_mod => specialising imported fn -- Nothing => specialising local fn -> SpecEnv - -> [CoreRule] -- Existing RULES for the fn + -> [CoreRule] -- Existing RULES for the fn -> [CallInfo] -> OutId -> InExpr - -> SpecM ([CoreRule], -- New RULES for the fn - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- New usage details from the specialised RHSs + -> SpecM SpecInfo -- New rules, specialised bindings, and usage details -- This function checks existing rules, and does not create -- duplicate ones. So the caller does not need to do this filtering. -- See 'already_covered' -specCalls mb_mod env rules_for_me calls_for_me fn rhs +type SpecInfo = ( [CoreRule] -- Specialisation rules + , [(Id,CoreExpr)] -- Specialised definition + , UsageDetails ) -- Usage details from specialised RHSs + +specCalls mb_mod env existing_rules calls_for_me fn rhs -- The first case is the interesting one | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args @@ -1165,10 +1176,8 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs -- See Note [Inline specialisation] for why we do not -- switch off specialisation for inline functions - = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $ - do { stuff <- mapM spec_call calls_for_me - ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) - ; return (spec_rules, spec_defns, plusUDList spec_uds) } + = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ + foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, @@ -1202,12 +1211,15 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs body = mkLams rhs_bndrs2 rhs_body -- Glue back on the non-dict lambdas - already_covered :: DynFlags -> [CoreExpr] -> Bool - already_covered dflags args -- Note [Specialisations already covered] - = isJust (lookupRule dflags - (CoreSubst.substInScope (se_subst env), realIdUnfolding) - (const True) - fn args rules_for_me) + in_scope = CoreSubst.substInScope (se_subst env) + + already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool + already_covered dflags new_rules args -- Note [Specialisations already covered] + = isJust (lookupRule dflags (in_scope, realIdUnfolding) + (const True) fn args + (new_rules ++ existing_rules)) + -- NB: we look both in the new_rules (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] mk_ty_args [] poly_tvs @@ -1220,11 +1232,11 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: CallInfo -- Call instance - -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - CoreRule)) -- Info for the Id's SpecEnv - spec_call (CI { ci_key = CallKey call_ts, ci_args = call_ds }) + spec_call :: SpecInfo -- Accumulating parameter + -> CallInfo -- Call instance + -> SpecM SpecInfo + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) + (CI { ci_key = CallKey call_ts, ci_args = call_ds }) = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs @@ -1263,8 +1275,8 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs rule_bndrs = poly_tyvars ++ ev_bndrs ; dflags <- getDynFlags - ; if already_covered dflags rule_args then - return Nothing + ; if already_covered dflags rules_acc rule_args + then return spec_acc else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids -- , text "rhs_env2" <+> ppr (se_subst rhs_env2) -- , ppr dx_binds ]) $ @@ -1313,14 +1325,14 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs rule_args (mkVarApps (Var spec_f) app_args) - spec_env_rule + spec_rule = case isJoinId_maybe fn of Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta Nothing -> rule_wout_eta -- Add the { d1' = dx1; d2' = dx2 } usage stuff - final_uds = foldr consDictBind rhs_uds dx_binds + spec_uds = foldr consDictBind rhs_uds dx_binds -------------------------------------- -- Add a suitable unfolding if the spec_inl_prag says so @@ -1350,7 +1362,10 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs `setIdUnfolding` spec_unf `asJoinId_maybe` spec_join_arity - ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } + ; return ( spec_rule : rules_acc + , (spec_f_w_arity, spec_rhs) : pairs_acc + , spec_uds `plusUDs` uds_acc + ) } } {- Note [Account for casts in binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1462,27 +1477,42 @@ Even in the non-recursive case, if any dict-binds depend on 'fn' we might have built a recursive knot f a d x = <blah> - MkUD { ud_binds = d7 = MkD ..f.. + MkUD { ud_binds = NonRec d7 (MkD ..f..) , ud_calls = ...(f T d7)... } The we generate - Rec { fs x = <blah>[T/a, d7/d] - f a d x = <blah> + Rec { fs x = <blah>[T/a, d7/d] + f a d x = <blah> RULE f T _ = fs - d7 = ...f... } + d7 = ...f... } Here the recursion is only through the RULE. +However we definitely should /not/ make the Rec in this wildly common +case: + d = ... + MkUD { ud_binds = NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +Here we want simply to add d to the floats, giving + MkUD { ud_binds = NonRec d (...) + NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +In general, we need only make this Rec if + - there are some specialisations (spec_binds non-empty) + - there are some dict_binds that depend on f (dump_dbs non-empty) -Note [Specialisation of dictionary functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a nasty example that bit us badly: see Trac #3591 +Note [Avoiding loops] +~~~~~~~~~~~~~~~~~~~~~ +When specialising /dictionary functions/ we must be very careful to +avoid building loops. Here is an example that bit us badly: Trac #3591 class Eq a => C a instance Eq [a] => C [a] ---------------- +This translates to dfun :: Eq [a] -> C [a] dfun a d = MkD a d (meth d) @@ -1511,7 +1541,53 @@ placed below 'dfun', and thus unavailable to it when specialising discarded. On the other hand, the call (dfun T d4) is fine, assuming d4 doesn't mention dfun. -But look at this: +Solution: + Discard all calls that mention dictionaries that depend + (directly or indirectly) on the dfun we are specialising. + This is done by 'filterCalls' + +-------------- +Here's another example, this time for an imported dfun, so the call +to filterCalls is in specImports (Trac #13429). Suppose we have + class Monoid v => C v a where ... + +We start with a call + f @ [Integer] @ Integer $fC[]Integer + +Specialising call to 'f' gives dict bindings + $dMonoid_1 :: Monoid [Integer] + $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer + + $dC_1 :: C [Integer] (Node [Integer] Integer) + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + +...plus a recursive call to + f @ [Integer] @ (Node [Integer] Integer) $dC_1 + +Specialising that call gives + $dMonoid_2 :: Monoid [Integer] + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + + $dC_2 :: C [Integer] (Node [Integer] Integer) + $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 + +Now we have two calls to the imported function + M.$fCvNode :: Monoid v => C v a + M.$fCvNode @v @a m = C m some_fun + +But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) +for specialisation, else we get: + + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + $s$fCvNode = C $dMonoid_2 ... + RULE M.$fCvNode [Integer] _ _ = $s$fCvNode + +Now use the rule to rewrite the call in the RHS of $dC_1 +and we get a loop! + +-------------- +Here's yet another example class C a where { foo,bar :: [a] -> [a] } @@ -1547,11 +1623,6 @@ Note that, because of its RULE, r_bar joins the recursive group. (In this case it'll unravel a short moment later.) -Conclusion: we catch the nasty case using filter_dfuns in -callsForMe. To be honest I'm not 100% certain that this is 100% -right, but it works. Sigh. - - Note [Specialising a recursive group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1745,29 +1816,56 @@ INLINABLE. See Trac #4874. data UsageDetails = MkUD { - ud_binds :: !(Bag DictBind), - -- Floated dictionary bindings - -- The order is important; - -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) + ud_binds :: !(Bag DictBind), + -- See Note [Floated dictionary bindings] + -- The order is important; + -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 + -- (Remember, Bags preserve order in GHC.) - ud_calls :: !CallDetails + ud_calls :: !CallDetails - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', - -- but there should be no calls *for* bs + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs } +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries) +type DictBind = (CoreBind, VarSet) + +{- Note [Floated dictionary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out dictionary bindings for the reasons described under +"Dictionary floating" above. But not /just/ dictionary bindings. +Consider + + f :: Eq a => blah + f a d = rhs + + $c== :: T -> T -> Bool + $c== x y = ... + + $df :: Eq T + $df = Eq $c== ... + + gurgle = ...(f @T $df)... + +We gather the call info for (f @T $df), and we don't want to drop it +when we come across the binding for $df. So we add $df to the floats +and continue. But then we have to add $c== to the floats, and so on. +These all float above the binding for 'f', and and now we can +successfullly specialise 'f'. + +So the DictBinds in (ud_binds :: Bag DictBind) may contain +non-dictionary bindings too. +-} + instance Outputable UsageDetails where ppr (MkUD { ud_binds = dbs, ud_calls = calls }) = text "MkUD" <+> braces (sep (punctuate comma [text "binds" <+> equals <+> ppr dbs, text "calls" <+> equals <+> ppr calls])) --- | A 'DictBind' is a binding along with a cached set containing its free --- variables (both type variables and dictionaries) -type DictBind = (CoreBind, VarSet) - emptyUDs :: UsageDetails emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } @@ -1780,6 +1878,8 @@ type CallDetails = DIdEnv CallInfoSet data CallInfoSet = CIS Id (Bag CallInfo) -- The list of types and dictionaries is guaranteed to -- match the type of f + -- The Bag may contain duplicate calls (i.e. f @T and another f @T) + -- These dups are eliminated by already_covered in specCalls data CallInfo = CI { ci_key :: CallKey -- Type arguments @@ -1794,58 +1894,6 @@ newtype CallKey = CallKey [Maybe Type] type DictExpr = CoreExpr - -{- -Note [CallInfoSet determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CallInfoSet holds a Bag of (CallKey, [DictExpr], VarSet) triplets for a given -Id. They represent the types that the function is instantiated at along with -the dictionaries and free variables. - -We use this information to generate specialized versions of a given function. -CallInfoSet used to be defined as: - - data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) - -Unfortunately this was not deterministic. The Ord instance of CallKey was -defined in terms of nonDetCmpType which is not deterministic. -See Note [nonDetCmpType nondeterminism]. -The end result was that if the function had multiple specializations they would -be generated in arbitrary order. - -We need a container that: -a) when turned into a list has only one element per each CallKey and the list -has deterministic order -b) supports union -c) supports singleton -d) supports filter - -We can't use UniqDFM here because there's no one Unique that we can key on. - -The current approach is to implement the set as a Bag with duplicates. -This makes b), c), d) trivial and pushes a) towards the end. The deduplication -is done by using a TrieMap for membership tests on CallKey. This lets us delete -the nondeterministic Ord CallKey instance. - -An alternative approach would be to augment the Map the same way that UniqDFM -is augmented, by keeping track of insertion order and using it to order the -resulting lists. It would mean keeping the nondeterministic Ord CallKey -instance making it easy to reintroduce nondeterminism in the future. --} - -ciSetToList :: CallInfoSet -> [CallInfo] -ciSetToList (CIS _ b) = snd $ foldrBag combine (emptyTM, []) b - where - -- This is where we eliminate duplicates, recording the CallKeys we've - -- already seen in the TrieMap. See Note [CallInfoSet determinism]. - combine :: CallInfo -> (CallKeySet, [CallInfo]) -> (CallKeySet, [CallInfo]) - combine ci@(CI { ci_key = CallKey key }) (set, acc) - | Just _ <- lookupTM key set = (set, acc) - | otherwise = (insertTM key () set, ci:acc) - -type CallKeySet = ListMap (MaybeMap TypeMap) () - -- We only use it in ciSetToList to check for membership - ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet ciSetFilter p (CIS id a) = CIS id (filterBag p a) @@ -2036,9 +2084,6 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) = MkUD { ud_binds = db1 `unionBags` db2 , ud_calls = calls1 `unionCalls` calls2 } -plusUDList :: [UsageDetails] -> UsageDetails -plusUDList = foldr plusUDs emptyUDs - ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id] _dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs @@ -2056,17 +2101,28 @@ bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs rhs_fvs = unionVarSets (map pair_fvs prs) pair_fvs :: (Id, CoreExpr) -> VarSet -pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr - -- Don't forget variables mentioned in the - -- rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear in the RHS +pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs + `unionVarSet` idFreeVars bndr + -- idFreeVars: don't forget variables mentioned in + -- the rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear + -- in the RHS -- type T a = Int -- x :: T a = 3 - --- | Flatten a set of 'DictBind's and some other binding pairs into a single --- recursive binding, including some additional bindings. -flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> DictBind -flattenDictBinds dbs pairs + where + interesting :: InterestingVarFun + interesting v = isLocalVar v || (isId v && isDFunId v) + -- Very important: include DFunIds /even/ if it is imported + -- Reason: See Note [Avoiding loops], the second exmaple + -- involving an imported dfun. We must know whether + -- a dictionary binding depends on an imported dfun, + -- in case we try to specialise that imported dfun + -- Trac #13429 illustrates + +-- | Flatten a set of "dumped" 'DictBind's, and some other binding +-- pairs, into a single recursive binding. +recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind +recWithDumpedDicts pairs dbs = (Rec bindings, fvs) where (bindings, fvs) = foldrBag add @@ -2080,8 +2136,7 @@ flattenDictBinds dbs pairs snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` - foldr consBag emptyBag dbs } + = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } consDictBind :: DictBind -> UsageDetails -> UsageDetails consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } @@ -2120,7 +2175,11 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) -- no calls for any of the dicts in dump_dbs dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) --- Used at a lambda or case binder; just dump anything mentioning the binder +-- Used at a let(rec) binding. +-- We return a boolean indicating whether the binding itself is mentioned +-- is mentioned, directly or indirectly, by any of the ud_calls; in that +-- case we want to float the binding itself; +-- See Note [Floated dictionary bindings] dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ (free_uds, dump_dbs, float_all) @@ -2145,18 +2204,26 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) , ud_calls = delDVarEnv orig_calls fn } calls_for_me = case lookupDVarEnv orig_calls fn of Nothing -> [] - Just cis -> filter_dfuns (ciSetToList cis) + Just cis -> filterCalls cis orig_dbs + -- filterCalls: drop calls that (directly or indirectly) + -- refer to fn. See Note [Avoiding loops] - dep_set = foldlBag go (unitVarSet fn) orig_dbs - go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set - = extendVarSetList dep_set (bindersOf db) - | otherwise = dep_set +---------------------- +filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] +-- See Note [Avoiding loops] +filterCalls (CIS fn call_bag) dbs + = filter ok_call (bagToList call_bag) + where + dump_set = foldlBag go (unitVarSet fn) dbs + -- This dump-set could also be computed by splitDictBinds + -- (_,_,dump_set) = splitDictBinds dbs {fn} + -- But this variant is shorter - -- Note [Specialisation of dictionary functions] - filter_dfuns | isDFunId fn = filter ok_call - | otherwise = \cs -> cs + go so_far (db,fvs) | fvs `intersectsVarSet` so_far + = extendVarSetList so_far (bindersOf db) + | otherwise = so_far - ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dep_set) + ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) ---------------------- splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) diff --git a/testsuite/tests/deriving/perf/all.T b/testsuite/tests/deriving/perf/all.T index a711a50855..240571b4a2 100644 --- a/testsuite/tests/deriving/perf/all.T +++ b/testsuite/tests/deriving/perf/all.T @@ -1,11 +1,13 @@ test('T10858', [compiler_stats_num_field('bytes allocated', - [(wordsize(64), 241242968, 8) ]), + [(wordsize(64), 221895064, 8) ]), # Initial: 222312440 # 2016-12-19 247768192 Join points (#19288) # 2017-02-12 304094944 Type-indexed Typeable # 2017-02-25 275357824 Early inline patch # 2017-03-28 241242968 Run Core Lint less + # 2017-06-07 221895064 Apparently been reducing for some time + # Today it crossed the boundary; good only_ways(['normal'])], compile, ['-O']) diff --git a/testsuite/tests/simplCore/should_compile/T13429.hs b/testsuite/tests/simplCore/should_compile/T13429.hs deleted file mode 100644 index cc9b4d20e9..0000000000 --- a/testsuite/tests/simplCore/should_compile/T13429.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Loop (Array(..), Image(..), X, promote, correlate) where -import Data.Maybe (fromMaybe) - -data Kernel e = Kernel Int Int !(Vector (Int, Int, e)) deriving (Show) - - -toKernel :: Array X e => Image X e -> Kernel e -toKernel img = - Kernel m2 n2 $ filter (\(_, _, x) -> x /= 0) $ imap addIx $ toVector img - where - (m, n) = dims img - (m2, n2) = (m `div` 2, n `div` 2) - addIx k (PixelX x) = - let (i, j) = toIx n k - in (i - m2, j - n2, x) - -correlate :: Array cs e => Image X e -> Image cs e -> Image cs e -correlate kernelImg imgM = makeImage (dims imgM) stencil - where - !(Kernel kM2 kN2 kernelV) = toKernel kernelImg - kLen = length kernelV - stencil (i, j) = - loop 0 (promote 0) $ \ k acc -> - let (iDelta, jDelta, x) = kernelV !! k - imgPx = index imgM (i + iDelta, j + jDelta) - in liftPx2 (+) acc (liftPx (x *) imgPx) - loop init' initAcc f = go init' initAcc - where - go step acc = - if step < kLen - then go (step + 1) (f step acc) - else acc -{-# INLINE correlate #-} - - - --- | A Pixel family with a color space and a precision of elements. -data family Pixel cs e :: * - - -class (Eq e, Num e) => ColorSpace cs e where - promote :: e -> Pixel cs e - liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e - liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e - - - -data family Image cs e :: * - -class ColorSpace cs e => Array cs e where - dims :: Image cs e -> (Int, Int) - makeImage :: (Int, Int) -> ((Int, Int) -> Pixel cs e) -> Image cs e - toVector :: Image cs e -> Vector (Pixel cs e) - index :: Image cs e -> (Int, Int) -> Pixel cs e - -fromIx :: Int -> (Int, Int) -> Int -fromIx n (i, j) = n * i + j - -toIx :: Int -> Int -> (Int, Int) -toIx n k = divMod k n - -instance (Show (Pixel cs e), ColorSpace cs e, Array cs e) => - Show (Image cs e) where - show img = - let (m, n) = dims img - in "<Image " ++ show m ++ "x" ++ show n ++ ">: " ++ show (toVector img) - - -data X = X - -newtype instance Pixel X e = PixelX e - -instance Show e => Show (Pixel X e) where - show (PixelX e) = "Pixel: " ++ show e - - -instance (Eq e, Num e) => ColorSpace X e where - promote = PixelX - liftPx f (PixelX g) = PixelX (f g) - liftPx2 f (PixelX g1) (PixelX g2) = PixelX (f g1 g2) - - -data instance Image X e = VImage Int Int (Vector (Pixel X e)) - -instance ColorSpace X e => Array X e where - dims (VImage m n _) = (m, n) - makeImage (m, n) f = VImage m n $ generate (m * n) (f . toIx n) - toVector (VImage _ _ v) = v - index (VImage _ n v) ix = fromMaybe (promote 0) (v !? (fromIx n ix)) - - --- Vector emulation - -type Vector a = [a] - -imap :: (Num a, Enum a) => (a -> b -> c) -> [b] -> [c] -imap f = zipWith f [0..] - -(!?) :: [a] -> Int -> Maybe a -(!?) ls i - | i < 0 || i >= length ls = Nothing - | otherwise = Just (ls !! i) - -generate :: (Ord t, Num t) => t -> (t -> a) -> [a] -generate n f = go (n-1) [] where - go i acc | i < 0 = acc - | otherwise = go (i-1) (f i : acc) - diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index f4f22b9dc5..b7c8b04c5c 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -253,7 +253,6 @@ test('T13338', only_ways(['optasm']), compile, ['-dcore-lint']) test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367']) test('T13417', normal, compile, ['-O']) test('T13413', normal, compile, ['']) -test('T13429', normal, compile, ['']) test('T13410', normal, compile, ['-O2']) test('T13468', normal, diff --git a/testsuite/tests/simplCore/should_run/T13429.hs b/testsuite/tests/simplCore/should_run/T13429.hs new file mode 100644 index 0000000000..de918da03f --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import T13429a + +import Data.Foldable (Foldable(..)) +import Data.Monoid (Monoid(..)) + +main :: IO () +main = print $ prop_mappend z z + where + z :: Seq Integer + z = deep (Four 1 2 3 4) Empty (Four 1 2 3 4) + +infix 4 ~= + +(~=) :: Eq a => Maybe a -> a -> Bool +(~=) = maybe (const False) (==) + +-- Partial conversion of an output sequence to a list. +toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a] +toList' xs + | valid xs = Just (toList xs) + | otherwise = Nothing + +prop_mappend :: Seq Integer -> Seq Integer -> Bool +prop_mappend xs ys = + toList' (mappend xs ys) ~= toList xs ++ toList ys + +------------------------------------------------------------------------ +-- Valid trees +------------------------------------------------------------------------ + +class Valid a where + valid :: a -> Bool + +instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where + valid Empty = True + valid (Single x) = valid x + valid (Deep s pr m sf) = + s == measure pr `mappend` measure m `mappend` measure sf && + valid pr && valid m && valid sf + +instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where + valid node = measure node == foldMap measure node && all valid node + +instance Valid a => Valid (Digit a) where + valid = all valid + +instance Valid Integer where + valid = const True + +------------------------------------------------------------------------ +-- Use list of elements as the measure +------------------------------------------------------------------------ + +type Seq a = FingerTree [a] a + +instance Measured [Integer] Integer where + measure x = [x] diff --git a/testsuite/tests/simplCore/should_run/T13429.stdout b/testsuite/tests/simplCore/should_run/T13429.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/simplCore/should_run/T13429_2.hs b/testsuite/tests/simplCore/should_run/T13429_2.hs new file mode 100644 index 0000000000..45b3e9c34d --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429_2.hs @@ -0,0 +1,10 @@ +-- This one come from lehins, between comment:22 and 23 of Trac #13429 +module Main where + +import T13429_2a as Array + +arr2 :: Array D Int Int -> Array D Int Int +arr2 arr = Array.map (*2) arr + +main :: IO () +main = print $ arr2 $ makeArray 1600 id diff --git a/testsuite/tests/simplCore/should_run/T13429_2.stdout b/testsuite/tests/simplCore/should_run/T13429_2.stdout new file mode 100644 index 0000000000..7bc74aee9e --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429_2.stdout @@ -0,0 +1 @@ +<Array 1600> diff --git a/testsuite/tests/simplCore/should_run/T13429_2a.hs b/testsuite/tests/simplCore/should_run/T13429_2a.hs new file mode 100644 index 0000000000..1accc337c2 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429_2a.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module T13429_2a where + +data D + +data Array r ix e = Array { _size :: ix + , _index :: ix -> e } + +class Show ix => Index ix + +instance Index Int + +class Index ix => Massiv r ix e where + size :: Array r ix e -> ix + makeArray :: ix -> (ix -> e) -> Array r ix e + index :: Array r ix e -> ix -> e + + +instance Massiv r ix e => Show (Array r ix e) where + show arr = "<Array " ++ show (size arr) ++ ">" + + +instance Index ix => Massiv D ix e where + size = _size + makeArray = Array + index = _index + + +-- | Map a function over an array (restricted return type) +map :: Massiv r' ix e' => (e' -> e) -> Array r' ix e' -> Array D ix e +map = mapG +{-# INLINE map #-} + +-- | Map a function over an array (general) +mapG :: (Massiv r' ix e', Massiv r ix e) => (e' -> e) -> Array r' ix e' -> Array r ix e +mapG f arr = makeArray (size arr) (f . index arr) diff --git a/testsuite/tests/simplCore/should_run/T13429a.hs b/testsuite/tests/simplCore/should_run/T13429a.hs new file mode 100644 index 0000000000..6a838cb79c --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T13429a.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module T13429a where -- Orignally FingerTree.hs from the ticket + +class (Monoid v) => Measured v a | a -> v where + measure :: a -> v + +instance (Measured v a) => Measured v (Digit a) where + measure = foldMap measure + +instance (Monoid v) => Measured v (Node v a) where + measure (Node2 v _ _) = v + measure (Node3 v _ _ _) = v + +instance (Measured v a) => Measured v (FingerTree v a) where + measure Empty = mempty + measure (Single x) = measure x + measure (Deep v _ _ _) = v + +data FingerTree v a + = Empty + | Single a + | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) + deriving Show + +instance Foldable (FingerTree v) where + foldMap _ Empty = mempty + foldMap f (Single x) = f x + foldMap f (Deep _ pr m sf) = + foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf + +instance Measured v a => Monoid (FingerTree v a) where + mempty = empty + mappend = (><) + +empty :: Measured v a => FingerTree v a +empty = Empty + +infixr 5 >< +infixr 5 <| +infixl 5 |> + +(<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a +a <| Empty = Single a +a <| Single b = deep (One a) Empty (One b) +a <| Deep v (Four b c d e) m sf = m `seq` + Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf +a <| Deep v pr m sf = + Deep (measure a `mappend` v) (consDigit a pr) m sf + +consDigit :: a -> Digit a -> Digit a +consDigit a (One b) = Two a b +consDigit a (Two b c) = Three a b c +consDigit a (Three b c d) = Four a b c d +consDigit _ (Four _ _ _ _) = illegal_argument "consDigit" + +(|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a +Empty |> a = Single a +Single a |> b = deep (One a) Empty (One b) +Deep v pr m (Four a b c d) |> e = m `seq` + Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e) +Deep v pr m sf |> x = + Deep (v `mappend` measure x) pr m (snocDigit sf x) + +snocDigit :: Digit a -> a -> Digit a +snocDigit (One a) b = Two a b +snocDigit (Two a b) c = Three a b c +snocDigit (Three a b c) d = Four a b c d +snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit" + +(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +(><) = appendTree0 + +appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +appendTree0 Empty xs = + xs +appendTree0 xs Empty = + xs +appendTree0 (Single x) xs = + x <| xs +appendTree0 xs (Single x) = + xs |> x +appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 + +addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits0 m1 (One a) (One b) m2 = + appendTree1 m1 (node2 a b) m2 +addDigits0 m1 (One a) (Two b c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits0 m1 (One a) (Three b c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (One a) (Four b c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Two a b) (One c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits0 m1 (Two a b) (Two c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (Two a b) (Three c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Two a b) (Four c d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Three a b c) (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (Three a b c) (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Three a b c) (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Three a b c) (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits0 m1 (Four a b c d) (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Four a b c d) (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Four a b c d) (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits0 m1 (Four a b c d) (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + +appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a +appendTree1 Empty a xs = + a <| xs +appendTree1 xs a Empty = + xs |> a +appendTree1 (Single x) a xs = + x <| a <| xs +appendTree1 xs a (Single x) = + xs |> a |> x +appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 + +addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits1 m1 (One a) b (One c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits1 m1 (One a) b (Two c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits1 m1 (One a) b (Three c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (One a) b (Four c d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Two a b) c (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits1 m1 (Two a b) c (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (Two a b) c (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Two a b) c (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Three a b c) d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (Three a b c) d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Three a b c) d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Three a b c) d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits1 m1 (Four a b c d) e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Four a b c d) e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Four a b c d) e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits1 m1 (Four a b c d) e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + +appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree2 Empty a b xs = + a <| b <| xs +appendTree2 xs a b Empty = + xs |> a |> b +appendTree2 (Single x) a b xs = + x <| a <| b <| xs +appendTree2 xs a b (Single x) = + xs |> a |> b |> x +appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 + +addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits2 m1 (One a) b c (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits2 m1 (One a) b c (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits2 m1 (One a) b c (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (One a) b c (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Two a b) c d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits2 m1 (Two a b) c d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (Two a b) c d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Two a b) c d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Three a b c) d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (Three a b c) d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Three a b c) d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Three a b c) d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits2 m1 (Four a b c d) e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Four a b c d) e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Four a b c d) e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + +appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree3 Empty a b c xs = + a <| b <| c <| xs +appendTree3 xs a b c Empty = + xs |> a |> b |> c +appendTree3 (Single x) a b c xs = + x <| a <| b <| c <| xs +appendTree3 xs a b c (Single x) = + xs |> a |> b |> c |> x +appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 + +addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits3 m1 (One a) b c d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits3 m1 (One a) b c d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits3 m1 (One a) b c d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (One a) b c d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Two a b) c d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits3 m1 (Two a b) c d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (Two a b) c d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Two a b) c d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Three a b c) d e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (Three a b c) d e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Three a b c) d e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits3 m1 (Four a b c d) e f g (One h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Four a b c d) e f g (Two h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 + +appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree4 Empty a b c d xs = + a <| b <| c <| d <| xs +appendTree4 xs a b c d Empty = + xs |> a |> b |> c |> d +appendTree4 (Single x) a b c d xs = + x <| a <| b <| c <| d <| xs +appendTree4 xs a b c d (Single x) = + xs |> a |> b |> c |> d |> x +appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 + +addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits4 m1 (One a) b c d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits4 m1 (One a) b c d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits4 m1 (One a) b c d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (One a) b c d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Two a b) c d e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits4 m1 (Two a b) c d e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (Two a b) c d e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Three a b c) d e f g (One h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (Three a b c) d e f g (Two h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 +addDigits4 m1 (Four a b c d) e f g h (One i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 +addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 + +deep :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf + +data Digit a + = One a + | Two a a + | Three a a a + | Four a a a a + deriving Show + +instance Foldable Digit where + foldMap f (One a) = f a + foldMap f (Two a b) = f a `mappend` f b + foldMap f (Three a b c) = f a `mappend` f b `mappend` f c + foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d + +data Node v a = Node2 !v a a | Node3 !v a a a + deriving Show + +instance Foldable (Node v) where + foldMap f (Node2 _ a b) = f a `mappend` f b + foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c + +node2 :: (Measured v a) => a -> a -> Node v a +node2 a b = Node2 (measure a `mappend` measure b) a b + +node3 :: (Measured v a) => a -> a -> a -> Node v a +node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c + +mappendVal :: (Measured v a) => v -> FingerTree v a -> v +mappendVal v Empty = v +mappendVal v t = v `mappend` measure t + +illegal_argument :: String -> a +illegal_argument name = + error $ "Logic error: " ++ name ++ " called with illegal argument" diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 1ff71d8171..bf9686e9a4 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -74,3 +74,5 @@ test('T12689a', normal, compile_and_run, ['']) test('T13172', only_ways(['optasm']), compile_and_run, ['-dcore-lint']) test('T13227', normal, compile_and_run, ['']) test('T13733', expect_broken(13733), compile_and_run, ['']) +test('T13429', normal, compile_and_run, ['']) +test('T13429_2', normal, compile_and_run, ['']) |