From f2ce86c2edc0840f5e731d5286a2a5e484263e3f Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Sun, 20 May 2018 21:43:45 +0100 Subject: Do better sharing in the short-cut solver Trac #15164 showed that it sometimes really matters to share sub-proofs when solving constraints. Without it, we can get exponentialy bad behaviour. Fortunately, it's easily solved. Note [Shortcut try_solve_from_instance] explains. I did some minor assocaited refactoring. --- compiler/typecheck/TcEvidence.hs | 6 +- compiler/typecheck/TcInteract.hs | 159 ++++++---- compiler/typecheck/TcSMonad.hs | 18 +- testsuite/tests/perf/compiler/T15164.hs | 501 ++++++++++++++++++++++++++++++++ testsuite/tests/perf/compiler/all.T | 10 + 5 files changed, 631 insertions(+), 63 deletions(-) create mode 100644 testsuite/tests/perf/compiler/T15164.hs diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 2aa2f161b6..8abfc90f04 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -16,7 +16,7 @@ module TcEvidence ( lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, isEmptyEvBindMap, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, - sccEvBinds, evBindVar, + sccEvBinds, evBindVar, isNoEvBindsVar, -- EvTerm (already a CoreExpr) EvTerm(..), EvExpr, @@ -429,6 +429,10 @@ evidence bindings are allowed. Notebly (): - When unifying forall-types -} +isNoEvBindsVar :: EvBindsVar -> Bool +isNoEvBindsVar (NoEvBindsVar {}) = True +isNoEvBindsVar (EvBindsVar {}) = False + ----------------- newtype EvBindMap = EvBindMap { diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 7f85d6b055..ab94ad21bd 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -53,7 +53,7 @@ import Outputable import TcRnTypes import TcSMonad import Bag -import MonadUtils ( concatMapM ) +import MonadUtils ( concatMapM, foldlM ) import Data.List( partition, foldl', deleteFirstsBy ) import SrcLoc @@ -1008,6 +1008,39 @@ on whether we apply this optimization when IncoherentInstances is in effect: The output of `main` if we avoid the optimization under the effect of IncoherentInstances is `1`. If we were to do the optimization, the output of `main` would be `2`. + +Note [Shortcut try_solve_from_instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The workhorse of the short-cut solver is + try_solve_from_instance :: CtLoc + -> (EvBindMap, DictMap CtEvidence) + -> CtEvidence -- Solve this + -> MaybeT TcS (EvBindMap, DictMap CtEvidence) +Note that: + +* The CtEvidence is teh goal to be solved + +* The MaybeT anages early failure if we find a subgoal that + cannot be solved from instances. + +* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional + state that allows try_solve_from_instance to augmennt the evidence + bindings and inert_solved_dicts as it goes. + + If it succeeds, we commit all these bindings and solved dicts to the + main TcS InertSet. If not, we abandon it all entirely. + +Passing along the solved_dicts important for two reasons: + +* We need to be able to handle recursive super classes. The + solved_dicts state ensures that we remember what we have already + tried to solve to avoid looping. + +* As Trac #15164 showed, it can be important to exploit sharing between + goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; + and to solve G2 we may need H. If we don't spot this sharing we may + solve H twice; and if this pattern repeats we may get exponentially bad + behaviour. -} interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) @@ -1017,24 +1050,21 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs do { -- First to try to solve it /completely/ from top level instances -- See Note [Shortcut solving] dflags <- getDynFlags - ; try_inst_res <- shortCutSolver dflags ev_w ev_i - ; case try_inst_res of - Just evs -> do { flip mapM_ evs $ \ (ev_t, ct_ev, cls, typ) -> - do { setWantedEvBind (ctEvEvId ct_ev) ev_t - ; addSolvedDict ct_ev cls typ } - ; stopWith ev_w "interactDict/solved from instance" } - - -- We were unable to solve the [W] constraint from in-scope instances - -- so we solve it from the matching inert we found - Nothing -> do - { what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvExpr ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvExpr ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith workItem } } } + ; short_cut_worked <- shortCutSolver dflags ev_w ev_i + ; if short_cut_worked + then stopWith ev_w "interactDict/solved from instance" + else + + do { -- We were unable to solve the [W] constraint from in-scope + -- instances so we solve it from the matching inert we found + what_next <- solveOneFromTheOther ev_i ev_w + ; traceTcS "lookupInertDict" (ppr what_next) + ; case what_next of + KeepInert -> do { setEvBindIfWanted ev_w (ctEvExpr ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } + KeepWork -> do { setEvBindIfWanted ev_i (ctEvExpr ev_w) + ; updInertDicts $ \ ds -> delDict ds cls tys + ; continueWith workItem } } } | cls `hasKey` ipClassKey , isGiven ev_w @@ -1050,9 +1080,7 @@ interactDict _ wi = pprPanic "interactDict" (ppr wi) shortCutSolver :: DynFlags -> CtEvidence -- Work item -> CtEvidence -- Inert we want to try to replace - -> TcS (Maybe [(EvTerm, CtEvidence, Class, [TcPredType])]) - -- Everything we need to bind a solution for the work item - -- and add the solved Dict to the cache in the main solver. + -> TcS Bool -- True <=> success shortCutSolver dflags ev_w ev_i | isWanted ev_w && isGiven ev_i @@ -1070,65 +1098,78 @@ shortCutSolver dflags ev_w ev_i && gopt Opt_SolveConstantDicts dflags -- Enabled by the -fsolve-constant-dicts flag - = runMaybeT $ try_solve_from_instance loc_w emptyDictMap ev_w + = do { ev_binds_var <- getTcEvBindsVar + ; ev_binds <- ASSERT2( not (isNoEvBindsVar ev_binds_var ), ppr ev_w ) + getTcEvBindsMap ev_binds_var + ; solved_dicts <- getSolvedDicts - | otherwise = return Nothing + ; mb_stuff <- runMaybeT $ try_solve_from_instance loc_w + (ev_binds, solved_dicts) ev_w + + ; case mb_stuff of + Nothing -> return False + Just (ev_binds', solved_dicts') + -> do { setTcEvBindsMap ev_binds_var ev_binds' + ; setSolvedDicts solved_dicts' + ; return True } } + + | otherwise + = return False where -- This `CtLoc` is used only to check the well-staged condition of any -- candidate DFun. Our subgoals all have the same stage as our root -- [W] constraint so it is safe to use this while solving them. loc_w = ctEvLoc ev_w - -- Use a local cache of solved dicts while emitting EvVars for new work - -- We bail out of the entire computation if we need to emit an EvVar for - -- a subgoal that isn't a ClassPred. - new_wanted_cached :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache loc_w cls tys of - Just ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc_w pty - | otherwise = mzero - - -- MaybeT manages early failure if we find a subgoal that cannot be solved - -- from instances. - -- Why do we need a local cache here? - -- 1. We can't use the global cache because it contains givens that - -- we specifically don't want to use to solve. - -- 2. We need to be able to handle recursive super classes. The - -- cache ensures that we remember what we have already tried to - -- solve to avoid looping. - try_solve_from_instance - :: CtLoc -> DictMap CtEvidence -> CtEvidence - -> MaybeT TcS [(EvTerm, CtEvidence, Class, [TcPredType])] - try_solve_from_instance loc cache ev + try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] + :: CtLoc -> (EvBindMap, DictMap CtEvidence) -> CtEvidence + -> MaybeT TcS (EvBindMap, DictMap CtEvidence) + try_solve_from_instance loc (ev_binds, solved_dicts) ev | let pred = ctEvPred ev , ClassPred cls tys <- classifyPredType pred - -- It is important that we add our goal to the cache before we solve! - -- Otherwise we may end up in a loop while solving recursive dictionaries. - = do { let cache' = addDict cache cls tys ev - loc' = bumpCtLocDepth loc - ; inst_res <- lift $ match_class_inst dflags True cls tys loc_w + = do { inst_res <- lift $ match_class_inst dflags True cls tys loc_w ; case inst_res of GenInst { lir_new_theta = preds , lir_mk_ev = mk_ev , lir_safe_over = safeOverlap } | safeOverlap , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { lift $ traceTcS "shortCutSolver: found instance" (ppr preds) + -> do { let solved_dicts' = addDict solved_dicts cls tys ev + loc' = bumpCtLocDepth loc + -- solved_dicts': it is important that we add our goal + -- to the cache before we solve! Otherwise we may end + -- up in a loop while solving recursive dictionaries. + + ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) ; lift $ checkReductionDepth loc' pred - ; evc_vs <- mapM (new_wanted_cached cache') preds + + ; evc_vs <- mapM (new_wanted_cached solved_dicts') preds -- Emit work for subgoals but use our local cache -- so we can solve recursive dictionaries. - ; subgoalBinds <- mapM (try_solve_from_instance loc' cache') - (freshGoals evc_vs) - ; return $ (mk_ev (map getEvExpr evc_vs), ev, cls, preds) - : concat subgoalBinds } - | otherwise -> mzero + ; let ev_tm = mk_ev (map getEvExpr evc_vs) + ev_binds' = extendEvBinds ev_binds $ + mkWantedEvBind (ctEvEvId ev) ev_tm + + ; foldlM (try_solve_from_instance loc') + (ev_binds', solved_dicts') + (freshGoals evc_vs) } + _ -> mzero } | otherwise = mzero + + -- Use a local cache of solved dicts while emitting EvVars for new work + -- We bail out of the entire computation if we need to emit an EvVar for + -- a subgoal that isn't a ClassPred. + new_wanted_cached :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew + new_wanted_cached cache pty + | ClassPred cls tys <- classifyPredType pty + = lift $ case findDict cache loc_w cls tys of + Just ctev -> return $ Cached (ctEvExpr ctev) + Nothing -> Fresh <$> newWantedNC loc_w pty + | otherwise = mzero + addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () -- Add derived constraints from type-class functional dependencies. addFunDepWork inerts work_ev cls diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 150f9be671..580a33cd9d 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -38,6 +38,7 @@ module TcSMonad ( newEvVar, newGivenEvVar, newGivenEvVars, emitNewDeriveds, emitNewDerivedEq, checkReductionDepth, + getSolvedDicts, setSolvedDicts, getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getLclEnv, @@ -421,7 +422,7 @@ data InertSet -- NB: An ExactFunEqMap -- this doesn't match via loose types! , inert_solved_dicts :: DictMap CtEvidence - -- Of form ev :: C t1 .. tn + -- All Wanteds, of form ev :: C t1 .. tn -- See Note [Solved dictionaries] -- and Note [Do not add superclasses of solved dictionaries] } @@ -474,8 +475,10 @@ Other notes about solved dictionaries * See also Note [Do not add superclasses of solved dictionaries] -* The inert_solved_dicts field is not rewritten by equalities, so it may - get out of date. +* The inert_solved_dicts field is not rewritten by equalities, + so it may get out of date. + +* THe inert_solved_dicts are all Wanteds, never givens Note [Do not add superclasses of solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1779,6 +1782,15 @@ addSolvedDict item cls tys ; updInertTcS $ \ ics -> ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } +getSolvedDicts :: TcS (DictMap CtEvidence) +getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } + +setSolvedDicts :: DictMap CtEvidence -> TcS () +setSolvedDicts solved_dicts + = updInertTcS $ \ ics -> + ics { inert_solved_dicts = solved_dicts } + + {- ********************************************************************* * * Other inert-set operations diff --git a/testsuite/tests/perf/compiler/T15164.hs b/testsuite/tests/perf/compiler/T15164.hs new file mode 100644 index 0000000000..0f29623228 --- /dev/null +++ b/testsuite/tests/perf/compiler/T15164.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module T15164 () where + +data Version = VHDL1993 +data T +data NT a + +class Rule f a where + get :: Decorator f => f a + +class Monad f => Decorator f where + n :: [Version] -> f a -> f (NT a) -- n stands for both NT as well as Node (in grammar tree) + chr :: Char -> [Version] -> f T + txt :: String -> [Version] -> f T -- token OPTIONALLY followed by spaces + + -- combinators + m :: f a -> f [a] + c :: [f a] -> f a -- c stands for choose + o :: f a -> f (Maybe a) -- o stands for optional + trace :: String -> f a -> f a + + -- helper functions in the grammar + n93 :: Rule f a => f (NT a) + n93 = n [VHDL1993] get + + + parenOpen :: f T + parenOpen = chr '(' [VHDL1993] + + parenClose :: f T + parenClose = chr ')' [VHDL1993] + + comma :: f T + comma = chr ',' [VHDL1993] + + moreComma :: Rule f a => f [(T, NT a)] + moreComma = m $ do + cc <- comma + cont <- n93 + return (cc, cont) + +type P_MaybeActualParameterPart = (Maybe (T, (NT ActualParameterPart), T)) +maybeActualParameterPart :: Decorator f => f (Maybe (T, NT ActualParameterPart, T)) +maybeActualParameterPart = o $ do + po <- parenOpen + app <- (n93 :: Decorator f => f (NT ActualParameterPart)) + pc <- parenClose + return (po, app, pc) +-- helper function used with FormalPart and ActualPart +-- dcon '(' actual_designator ')' +mkNameOrTypeMark :: (Decorator m, Rule m a1, Rule m a) => (NT a -> T -> NT a1 -> T -> b) -> m b +mkNameOrTypeMark dcon = do + name_typemark <- n93 -- either Name OR TypeMark depending on dcon !! + po <- parenOpen + fd <- n93 + pc <- parenClose + return $ dcon name_typemark po fd pc + +-- actual_designator +-- ::= expression +-- | name +-- | 'OPEN' +data ActualDesignator = AD1 (NT Expression) | AD2 (NT Name) | AD3 T +instance Rule f ActualDesignator where + get = trace "ActualDesignator" $ {-# SCC "get_ActualDesignator" #-} c + [ AD3 <$> (txt "open" [VHDL1993]) -- order matters here + , AD2 <$> n93 -- try a simple name first + , AD1 <$> n93 + -- [ AD3 <$> txt "open" [VHDL1993] -- order matters here + -- , AD2 <$> (n93 :: f (NT Name)) -- try a simple name first + -- , AD1 <$> (n93 :: f (NT Expression)) + ] + +-- actual_parameter_part +-- ::= association_list +newtype ActualParameterPart = APP (NT AssociationList) +instance Rule f AssociationList => Rule f ActualParameterPart where + get = APP <$> n93 + +-- actual_part +-- ::= actual_designator +-- | ( name | type_mark ) '(' actual_designator ')' +data ActualPart = AP1 (NT ActualDesignator) | APName (NT Name) T (NT ActualDesignator) T | APTypeMark (NT TypeMark) T (NT ActualDesignator) T +instance (Rule f ActualDesignator, Rule f Name, Rule f TypeMark) => Rule f ActualPart where + get = trace "ActualPart" $ {-# SCC "get_ActualPart" #-} c + [ AP1 <$> n93 + , mkNameOrTypeMark APName + , mkNameOrTypeMark APTypeMark + ] + +-- aggregate +-- ::= '(' element_association ( ',' element_association )* ')' +data Aggregate = MkAggregate T (NT ElementAssociation) [(T, (NT ElementAssociation))] T +instance Rule f ElementAssociation => Rule f Aggregate where + get = do + po <- parenOpen + ea <- n93 + rest <- moreComma + pc <- parenClose + return $ MkAggregate po ea rest pc + +-- allocator +-- ::= 'NEW' ( subtype_indication | qualified_expression ) +data Allocator = A1 T (NT SubtypeIndication) | A2 T (NT QualifiedExpression) +instance (Rule f SubtypeIndication, Rule f QualifiedExpression) => Rule f Allocator where + get = c + [ A1 <$> (txt "new" [VHDL1993]) <*> n93 + , A2 <$> (txt "new" [VHDL1993]) <*> n93 + ] + +-- association_element +-- ::= ( formal_part '=>' )? actual_part +data AssociationElement = AE (Maybe (NT FormalPart, T)) (NT ActualPart) +instance (Rule f FormalPart, Rule f ActualPart) => Rule f AssociationElement where + get = do + fp <- o $ do + f <- n93 + a <- txt "=>" [VHDL1993] + return (f, a) + ap <- n93 + return $ AE fp ap + +-- association_list +-- ::= association_element ( ',' association_element )* +data AssociationList = AL (NT AssociationElement) [(T, NT AssociationElement)] +instance Rule f AssociationElement => Rule f AssociationList where + get = do + ae <- n93 + rest <- moreComma + return $ AL ae rest + +-- attribute_name +-- ::= prefix signature? "'" attribute_designator ( '(' expression ')' )? +data AttributeName = AN (NT Prefix) (Maybe (NT TypeMark)) T (Maybe (T, (NT Expression), T)) +instance (Rule f Prefix, Rule f TypeMark, Rule f Expression) => Rule f AttributeName where + get = do + pp <- n93 + ss <- o n93 + cc <- chr '\'' [VHDL1993] + -- ad <- n93 + ee <- o $ do + po <- parenOpen + e <- n93 + pc <- parenClose + return (po, e, pc) + return $ AN pp ss cc ee + +-- choice ::= simple_expression +-- | discrete_range +-- | simple_name +-- | 'OTHERS' +data Choice = + CSmimpleExpression (NT SimpleExpression) + | CDiscreteRange (NT DiscreteRange) + -- | CSimpleName (NT SimpleName) + | COthers T + +instance (Rule f SimpleExpression, Rule f DiscreteRange) => Rule f Choice where + get = c + [ CSmimpleExpression <$> n93 + , CDiscreteRange <$> n93 + -- , CSimpleName <$> n93 + , COthers <$> txt "others" [VHDL1993] + ] + +-- constraint +-- ::= range_constraint +-- | index_constraint +data Constraint = CRange (NT RangeConstraint) | CIndex (NT DiscreteRange) +instance (Rule f RangeConstraint, Rule f DiscreteRange) => Rule f Constraint where + get = c + [ CRange <$> n93 + , CIndex <$> n93 + ] + +-- discrete_range +-- ::= subtype_indication +-- | range +data DiscreteRange = DRSubtypeIndication (NT SubtypeIndication) | DRRange (NT Range) +instance (Rule f SubtypeIndication, Rule f Range) => Rule f DiscreteRange where + get = c + [ DRSubtypeIndication <$> n93 + , DRRange <$> n93 + ] + +-- element_association +-- ::= ( choices '=>' )? expression +data ElementAssociation = EA (Maybe (NT Choice, T)) (NT Expression) +instance (Rule f Choice, Rule f Expression) => Rule f ElementAssociation where + get = do + c <- o $ do + c <- n93 + a <- txt "=>" [VHDL1993] + return (c, a) + e <- n93 + return $ EA c e + +-- expression +-- ::= relation ( ( 'AND' relation )* | ( 'OR' relation )* | ( 'XOR' relation )* | ( 'NAND' | 'NOR' ) relation | ( 'XNOR' relation )* ) +data Expression = + And (NT SimpleExpression) [(T, (NT SimpleExpression))] + | Or (NT SimpleExpression) [(T, (NT SimpleExpression))] + | Xor (NT SimpleExpression) [(T, (NT SimpleExpression))] + | Nand (NT SimpleExpression) (T, (NT SimpleExpression)) + | Nor (NT SimpleExpression) (T, (NT SimpleExpression)) + | Xnor (NT SimpleExpression) [(T, (NT SimpleExpression))] + +instance Rule f SimpleExpression => Rule f Expression where + get = {-# SCC "get_IndexedName" #-} c + [ And <$> n93 <*> emore "and" + , Or <$> n93 <*> emore "or" + , Xor <$> n93 <*> emore "xor" + , Nand <$> n93 <*> etwo "nand" + , Nor <$> n93 <*> etwo "nor" + , Xnor <$> n93 <*> emore "xnor" + ] + where etwo tok = do + n1 <- txt tok [VHDL1993] + n2 <- n93 + return (n1, n2) + emore tok = do + m $ do + n2 <- txt tok [VHDL1993] + n3 <- n93 + return (n2, n3) + +-- factor ::= ( primary '**' | 'ABS' | 'NOT' )? primary +data Factor = FPower (NT Primary) (Maybe (T, (NT Primary))) | FAbs T (NT Primary) | FNot T (NT Primary) +instance Rule f Primary => Rule f Factor where + get = trace "Factor" $ {-# SCC "get_Factor" #-} c -- c + [ do + p <- n93 + rest <- o $ do + p <- txt "**" [VHDL1993] + p2 <- n93 + return (p, p2) + return $ FPower p rest + , FAbs <$> (txt "abs" [VHDL1993]) <*> n93 + , FNot <$> (txt "not" [VHDL1993]) <*> n93 + ] + +-- formal_designator +-- ::= name +newtype FormalDesignator = MkFormalDesignator (NT Name) +instance Rule f Name => Rule f FormalDesignator where + get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} MkFormalDesignator <$> n93 + +-- formal_part +-- ::= formal_designator +-- | ( name | type_mark ) '(' formal_designator ')' +data FormalPart = FP1 (NT FormalDesignator) | FPName (NT Name) T (NT FormalDesignator) T | FPTypeMark (NT TypeMark) T (NT FormalDesignator) T +instance (Rule f FormalDesignator, Rule f Name, Rule f TypeMark) => Rule f FormalPart where + get = trace "FormalPart" $ {-# SCC "get_FormalPart" #-} c + [ FP1 <$> n93 + , mkNameOrTypeMark FPName + , mkNameOrTypeMark FPTypeMark + ] + +-- function_call +-- ::= name ( '(' actual_parameter_part ')' )? +data FunctionCall = FC (NT Name) P_MaybeActualParameterPart +-- redundant: Rule f ActualParameterPart +instance Rule f Name => Rule f FunctionCall where + get = trace "FunctionCall" $ {-# SCC "get_FunctionCall" #-} do + nn <- n93 + app <- maybeActualParameterPart + return $ FC nn app + +-- index_constraint +-- ::= '(' discrete_range ( ',' discrete_range )* ')' +data IndexConstraint = IC T (NT DiscreteRange) [(T, NT DiscreteRange)] T +instance Rule f DiscreteRange => Rule f IndexConstraint where + get = do + po <- parenOpen + dr <- n93 + rest <- moreComma + pc <- parenClose + return $ IC po dr rest pc + +-- indexed_name +-- ::= prefix '(' expression ( ',' expression )* ')' +data IndexedName = IN (NT Prefix) T (NT Expression) [(T, NT Expression)] T +instance (Rule f Prefix, Rule f Expression) => Rule f IndexedName where + get = {-# SCC "get_IndexedName" #-} do + pp <- n93 + po <- parenOpen + ee <- n93 + ee2 <- moreComma + pc <- parenClose + return $ IN pp po ee ee2 pc + +-- literal ::= numeric_literal +-- | enumeration_literal +-- | string_literal +-- | bit_string_literal +-- | 'NULL' +data Literal = + LNumericLiteral (NT Name) + -- | LEnumerationLiteral (NT EnumerationLiteral) + -- | LStringLiteral (NT StringLiteral) + -- | LBitStringLiteral (NT BitStringLiteral) + | LNull T + +instance (Rule f Name) => Rule f Literal where + get = c + [ LNumericLiteral <$> n93 + -- , LEnumerationLiteral <$> n93 + -- , LStringLiteral <$> n93 + -- , LBitStringLiteral <$> n93 + , LNull <$> txt "null" [VHDL1993] + ] + +-- name ::= simple_name +-- | operator_symbol +-- | selected_name +-- | indexed_name +-- | slice_name +-- | attribute_name +data Name = N3 (NT Prefix) | N4 (NT IndexedName) | N6 (NT AttributeName) +instance (Rule f Prefix, Rule f IndexedName, Rule f AttributeName) => Rule f Name where + get = trace "Name" $ {-# SCC "get_Name" #-} c + [ N3 <$> n93 + , N4 <$> n93 + -- , N5 <$> n93 + , N6 <$> n93 + ] + +-- prefix ::= name +-- | function_call +data Prefix = PrefixName (NT Name) | PrefixFunctionCall (NT FunctionCall) +instance (Rule f Name, Rule f FunctionCall) => Rule f Prefix where + get = trace "Prefix" $ {-# SCC "get_Prefix" #-} c + [ PrefixName <$> n93 + , PrefixFunctionCall <$> n93 + ] + +-- primary ::= name +-- | literal +-- | aggregate +-- | function_call +-- | qualified_expression +-- | type_conversion +-- | allocator +-- | '(' expression ')' +data Primary = + PName (NT Name) + -- | PLiteral (NT Literal) + | PAggregate (NT Aggregate) + | PFunctionCall (NT FunctionCall) + | PQualifiedExpression (NT QualifiedExpression) + | PTypeConversion (NT TypeConversion) + | PAllocator (NT Allocator) + | PExpression T (NT Expression) T + +--get_levels: instance (Rule f Name, Rule f Aggregate, Rule f FunctionCall, Rule f QualifiedExpression, Rule f TypeConversion, Rule f Allocator, Rule f Expression) => Rule f Primary where +instance (Rule f Name, Rule f Aggregate, Rule f FunctionCall, Rule f QualifiedExpression + , Rule f TypeConversion, Rule f Allocator, Rule f Expression) => Rule f Primary where + get = trace "Primary" $ {-# SCC "get_Primary" #-} c + [ PName <$> n93 + -- , PLiteral <$> n93 + , PAggregate <$> n93 + , PFunctionCall <$> n93 + , PQualifiedExpression <$> n93 + , PTypeConversion <$> n93 + , PAllocator <$> n93 + , exp + -- [ PName <$> (n93 :: f (NT Name)) + -- , PLiteral <$> (n93 :: f (NT Literal)) + -- , PAggregate <$> (n93 :: f (NT Aggregate)) + -- , PFunctionCall <$> (n93 :: f (NT FunctionCall)) + -- , PQualifiedExpression <$> (n93 :: f (NT QualifiedExpression)) + -- , PTypeConversion <$> (n93 :: f (NT TypeConversion)) + -- , PAllocator <$> (n93 :: f (NT Allocator)) + -- , PExpression <$> parenOpen <*> (n93 :: f (NT Expression)) <*> parenClose + -- , exp + ] + where exp = do + po <- parenOpen + ee <- n93 + pc <- parenClose + return $ PExpression po ee pc + +-- qualified_expression +-- ::= type_mark "'" ( '(' expression ')' | aggregate ) +data QualifiedExpression = QEExpression (NT TypeMark) T T (NT Expression) T | EQAggregate (NT TypeMark) T +instance (Rule f TypeMark, Rule f Expression) => Rule f QualifiedExpression where + get = c [qexp, qagg] + where qexp = do + tm <- n93 + q <- chr '\'' [VHDL1993] + po <- parenOpen + ee <- n93 + pc <- parenClose + return $ QEExpression tm q po ee pc + qagg = do + tm <- n93 + q <- chr '\'' [VHDL1993] + -- a <- n93 + return $ EQAggregate tm q + +-- range ::= attribute_name +-- | simple_expression direction simple_expression +data Range = R1 (NT AttributeName) | R2 (NT SimpleExpression) (NT SimpleExpression) +instance (Rule f AttributeName, Rule f SimpleExpression) => Rule f Range where + get = c + [ R1 <$> n93 + , R2 <$> n93<*> n93 + ] + +-- range_constraint +-- ::= 'range' range +data RangeConstraint = RC T (NT Range) +instance Rule f Range => Rule f RangeConstraint where + get = do + r1 <- txt "range" [VHDL1993] + r2 <- n93 + return $ RC r1 r2 + +-- relation +-- ::= shift_expression ( relational_operator shift_expression )? +data Relation = R (NT SimpleExpression) (Maybe ((NT SimpleExpression))) +instance (Rule f SimpleExpression) => Rule f Relation where + get = do + se <- n93 + rest <- o $ do + -- ro <- n93 + se <- n93 + return se + return $ R se rest + +-- shift_expression +-- ::= simple_expression ( shift_operator simple_expression )? +data ShiftExpression = ShiftE (NT SimpleExpression) (Maybe ((NT SimpleExpression))) +instance (Rule f SimpleExpression) => Rule f ShiftExpression where + get = do + se <- n93 + rest <- o $ do + -- so <- n93 + se <- n93 + return se + return $ ShiftE se rest + +-- simple_expression +-- ::= sign? term ( adding_operator term )* +data SimpleExpression = SimpleE (NT Primary) [(NT Primary)] +-- data SimpleExpression = SimpleE T +instance (Rule f Primary) => Rule f SimpleExpression where + -- get = SimpleE <$> txt "bla" [VHDL1993] + get = do + -- ss <- o n93 + tt <- n93 + rest <- m $ do + -- ao <- n93 + tt2 <- n93 + return tt2 + return $ SimpleE tt rest + +-- slice_name +-- ::= prefix '(' discrete_range ')' +data SliceName = SliceNPrefix (NT DiscreteRange) +instance Rule f DiscreteRange => Rule f SliceName where + get = SliceNPrefix <$> n93 + +-- subtype_indication +-- ::= name? type_mark constraint? +data SubtypeIndication = SI (Maybe (NT Name)) (NT TypeMark) (Maybe (NT Constraint)) +instance (Rule f Name, Rule f TypeMark, Rule f Constraint) => Rule f SubtypeIndication where + get = trace "SubtypeIndication" $ {-# SCC "get_SubtypeIndication" #-} do + nn <- o n93 + tm <- n93 + cc <- o n93 + return $ SI nn tm cc + +-- type_conversion +-- ::= type_mark '(' expression ')' +data TypeConversion = MkTypeConversion (NT TypeMark) T (NT Expression) T +instance (Rule f TypeMark, Rule f Expression) => Rule f TypeConversion where + get = do + tm <- n93 + po <- parenOpen + e <- n93 + pc <- parenClose + return $ MkTypeConversion tm po e pc + +-- type_mark +-- ::= type_name | subtype_name +data TypeMark = TM1 (NT Name) | TM2 (NT Name) +instance Rule f Name => Rule f TypeMark where + get = trace "TypeMark" $ {-# SCC "get_TypeMark" #-} c + [ TM1 <$> n93 + , TM2 <$> n93 + ] diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 654f2d1700..7b90ebfe56 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -1284,3 +1284,13 @@ test ('T9630', ], multimod_compile, ['T9630', '-v0 -O']) + +test ('T15164', + [ compiler_stats_num_field('bytes allocated', + [(platform('x86_64-unknown-mingw32'), 3424183288, 10), + + (wordsize(64), 6824183288, 10) + ]) + ], + compile, + ['-v0 -O']) -- cgit v1.2.1