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.

5 files changed, 631 insertions, 63 deletions

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'])