Treat banged bindings as FunBinds
authorBen Gamari <bgamari.foss@gmail.com>
Tue, 27 Jun 2017 14:30:20 +0000 (10:30 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 27 Jun 2017 17:34:05 +0000 (13:34 -0400)
This is another attempt at resolving #13594 by treating strict variable
binds as FunBinds instead of PatBinds (as suggested in comment:1).

Test Plan: Validate

Reviewers: austin, alanz

Subscribers: rwbarton, thomie, mpickering

GHC Trac Issues: #13594

Differential Revision: https://phabricator.haskell.org/D3670

18 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/typecheck/TcMatches.hs
testsuite/tests/ghc-api/annotations/T10358.stdout
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/perf/compiler/all.T
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_run/all.T

index 19bdba6..cb9837e 100644 (file)
@@ -1740,9 +1740,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs (L _ fun) _ -> (pprMatchContext kind,
-                                    \ pp -> ppr fun <+> pp)
-             _                  -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs (L _ fun) _ -> (pprMatchContext kind,
+                                      \ pp -> ppr fun <+> pp)
+             _                    -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
 ppr_pats kind pats
index 2a0abca..f03f586 100644 (file)
@@ -140,8 +140,8 @@ dsHsBind dflags
         ; return (force_var, [core_bind]) }
 
 dsHsBind dflags
-         (FunBind { fun_id = L _ fun, fun_matches = matches
-                  , fun_co_fn = co_fn, fun_tick = tick })
+         b@(FunBind { fun_id = L _ fun, fun_matches = matches
+                    , fun_co_fn = co_fn, fun_tick = tick })
  = do   { (args, body) <- matchWrapper
                            (mkPrefixFunRhs (noLoc $ idName fun))
                            Nothing matches
@@ -149,12 +149,16 @@ dsHsBind dflags
         ; let body' = mkOptTickBox tick body
               rhs   = core_wrap (mkLams args body')
               core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
-              force_var =
-                if xopt LangExt.Strict dflags
-                   && matchGroupArity matches == 0 -- no need to force lambdas
-                then [id]
-                else []
-        ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
+              force_var
+                  -- Bindings are strict when -XStrict is enabled
+                | xopt LangExt.Strict dflags
+                , matchGroupArity matches == 0 -- no need to force lambdas
+                = [id]
+                | isBangedBind b
+                = [id]
+                | otherwise
+                = []
+        ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $
            return (force_var, [core_binds]) }
 
 dsHsBind dflags
@@ -182,11 +186,11 @@ dsHsBind dflags
   | ABE { abe_wrap = wrap, abe_poly = global
         , abe_mono = local, abe_prags = prags } <- export
   , not (xopt LangExt.Strict dflags)             -- Handle strict binds
-  , not (anyBag (isBangedPatBind . unLoc) binds) --        in the next case
+  , not (anyBag (isBangedBind . unLoc) binds)    --        in the next case
   = -- See Note [AbsBinds wrappers] in HsBinds
     addDictsDs (toTcTypeBag (listToBag dicts)) $
          -- addDictsDs: push type constraints deeper for pattern match check
-    do { (_, bind_prs) <- dsLHsBinds binds
+    do { (force_vars, bind_prs) <- dsLHsBinds binds
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; core_wrap <- dsHsWrapper wrap -- Usually the identity
 
@@ -201,7 +205,8 @@ dsHsBind dflags
                main_bind = makeCorePair dflags global' (isDefaultMethod prags)
                                         (dictArity dicts) rhs
 
-       ; return ([], main_bind : fromOL spec_binds) }
+       ; ASSERT(null force_vars)
+         return ([], main_bind : fromOL spec_binds) }
 
         -- Another common case: no tyvars, no dicts
         -- In this case we can have a much simpler desugaring
@@ -343,6 +348,8 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
                | xopt LangExt.Strict dflags
                , matchGroupArity matches == 0 -- no need to force lambdas
                = [global]
+               | isBangedBind (unLoc bind)
+               = [global]
                | otherwise
                = []
 
index 4ef279f..a1f3a14 100644 (file)
@@ -35,7 +35,7 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
     ) where
 
 #include "HsVersions.h"
@@ -995,3 +995,15 @@ decideBangHood dflags lpat
            LazyPat lp' -> lp'
            BangPat _   -> lp
            _           -> L l (BangPat lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat id -- ^ Original pattern
+        -> LPat id -- ^ Banged pattern
+addBang = go
+  where
+    go lp@(L l p)
+      = case p of
+           ParPat p    -> L l (ParPat (go p))
+           LazyPat lp' -> L l (BangPat lp')
+           BangPat _   -> lp
+           _           -> L l (BangPat lp)
index 19f7036..a870c6f 100644 (file)
@@ -749,9 +749,14 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info vars (L _ (Match _ pats _ grhss))
+    mk_eqn_info vars (L _ (Match ctx pats _ grhss))
       = do { dflags <- getDynFlags
-           ; let upats = map (unLoc . decideBangHood dflags) pats
+           ; let add_bang
+                   | FunRhs {mc_strictness=SrcStrict} <- ctx
+                   = pprTrace "addBang" empty addBang
+                   | otherwise
+                   = decideBangHood dflags
+                 upats = map (unLoc . add_bang) pats
                  dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
            ; tm_cs <- genCaseTmCs2 mb_scr upats vars
            ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
index d0c345a..f08a6af 100644 (file)
@@ -129,12 +129,41 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
 -- | Located Haskell Binding with separate Left and Right identifier types
 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 
+{- Note [Varieties of binding pattern matches]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The distinction between FunBind and PatBind is a bit subtle. FunBind covers
+patterns which resemble function bindings and simple variable bindings.
+
+    f x = e
+    f !x = e
+    f = e
+    !x = e          -- FunRhs has SrcStrict
+    x `f` y = e     -- FunRhs has Infix
+
+The actual patterns and RHSs of a FunBind are encoding in fun_matches.
+The m_ctxt field of Match will be FunRhs and carries two bits of information
+about the match,
+
+  * the mc_strictness field describes whether the match is decorated with a bang
+    (e.g. `!x = e`)
+  * the mc_fixity field describes the fixity of the function binder
+
+By contrast, PatBind represents data constructor patterns, as well as a few
+other interesting cases. Namely,
+
+    Just x = e
+    (x) = e
+    x :: Ty = e
+-}
+
 -- | Haskell Binding with separate Left and Right id's
 data HsBindLR idL idR
-  = -- | Function Binding
+  = -- | Function-like Binding
     --
     -- FunBind is used for both functions     @f x = e@
     -- and variables                          @f = \x -> e@
+    -- and strict variables                   @!x = x + 1@
     --
     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
     --
@@ -145,6 +174,10 @@ data HsBindLR idL idR
     -- parses as a pattern binding, just like
     --                                        @(f :: a -> a) = ... @
     --
+    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
+    -- 'MatchContext'. See Note [Varieties of binding pattern matches] for
+    -- details about the relationship between FunBind and PatBind.
+    --
     --  'ApiAnnotation.AnnKeywordId's
     --
     --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
@@ -185,7 +218,10 @@ data HsBindLR idL idR
   -- | Pattern Binding
   --
   -- The pattern is never a simple variable;
-  -- That case is done by FunBind
+  -- That case is done by FunBind.
+  -- See Note [Varieties of binding pattern matches] for details about the
+  -- relationship between FunBind and PatBind.
+
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
   --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
index cfc9d17..016b02f 100644 (file)
@@ -1461,8 +1461,8 @@ Example infix function definition requiring individual API Annotations
 
 isInfixMatch :: Match id body -> Bool
 isInfixMatch match = case m_ctxt match of
-  FunRhs _ Infix -> True
-  _              -> False
+  FunRhs {mc_fixity = Infix} -> True
+  _                          -> False
 
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
@@ -1543,7 +1543,10 @@ pprMatch match
     ctxt = m_ctxt match
     (herald, other_pats)
         = case ctxt of
-            FunRhs (L _ fun) fixity
+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
+                | strictness == SrcStrict -> ASSERT(null $ m_pats match)
+                                             (char '!'<>pprPrefixOcc fun, m_pats match)
+                        -- a strict variable binding
                 | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
                         -- f x y z = e
                         -- Not pprBndr; the AbsBinds will
@@ -2353,9 +2356,17 @@ pp_dotdot = text " .. "
 
 -- | Haskell Match Context
 --
--- Context of a Match
+-- Context of a pattern match. This is more subtle than it would seem. See Note
+-- [Varieties of pattern matches].
 data HsMatchContext id -- Not an extensible tag
-  = FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity
+  = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
+           , mc_fixity :: LexicalFixity -- ^ fixing of @f@
+           , mc_strictness :: SrcStrictness
+             -- ^ was the pattern banged? See
+             -- Note [Varieties of binding pattern matches]
+           }
+                                -- ^A pattern matching on an argument of a
+                                -- function binding
   | LambdaExpr                  -- ^Patterns of a lambda
   | CaseAlt                     -- ^Patterns and guards on a case alternative
   | IfAlt                       -- ^Guards of a multi-way if alternative
@@ -2376,7 +2387,7 @@ data HsMatchContext id -- Not an extensible tag
 deriving instance (Data id) => Data (HsMatchContext id)
 
 instance OutputableBndr id => Outputable (HsMatchContext id) where
-  ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix
+  ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
   ppr LambdaExpr            = text "LambdaExpr"
   ppr CaseAlt               = text "CaseAlt"
   ppr IfAlt                 = text "IfAlt"
@@ -2462,7 +2473,8 @@ pprMatchContext ctxt
 
 pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
                     => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for"
+pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
+                                    = text "equation for"
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = text "case alternative"
 pprMatchContextNoun IfAlt           = text "multi-way if alternative"
@@ -2522,7 +2534,7 @@ instance (Outputable p, Outputable (NameOrRdrName p))
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id
                       => HsMatchContext id -> SDoc
-matchContextErrString (FunRhs (L _ fun) _)       = text "function" <+> ppr fun
+matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun
 matchContextErrString CaseAlt                    = text "case"
 matchContextErrString IfAlt                      = text "multi-way if"
 matchContextErrString PatBindRhs                 = text "pattern binding"
index c1a9a2f..ba001ea 100644 (file)
@@ -72,7 +72,7 @@ module HsUtils(
   noRebindableInfo,
 
   -- Collecting binders
-  isUnliftedHsBind,
+  isUnliftedHsBind, isBangedBind,
 
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   collectHsIdBinders,
@@ -756,9 +756,9 @@ mk_easy_FunBind loc fun pats expr
               [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
--- | Make a prefix 'FunRhs' 'HsMatchContext'
+-- | Make a prefix, non-strict function 'HsMatchContext'
 mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix
+mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
 
 ------------
 mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
@@ -859,6 +859,15 @@ isUnliftedHsBind bind
           -- would get type forall a. Num a => (# a, Bool #)
           -- and we want to reject that.  See Trac #9140
 
+-- | Is a binding a strict variable bind (e.g. @!x = ...@)?
+isBangedBind :: HsBind GhcTc -> Bool
+isBangedBind b | isBangedPatBind b = True
+isBangedBind (FunBind {fun_matches = matches})
+  | [L _ match] <- unLoc $ mg_alts matches
+  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+  = True
+isBangedBind _ = False
+
 collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                          -- No pattern synonyms here
index 02aeb86..6e4b774 100644 (file)
@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
-                                        pat <- checkPattern empty e;
-                                        _ <- ams (sLL $1 $> ())
-                                               (fst $ unLoc $3);
-                                        return $ sLL $1 $> $ ValD $
-                                            PatBind pat (snd $ unLoc $3)
-                                                    placeHolderType
-                                                    placeHolderNames
-                                                    ([],[]) } }
-                                -- Turn it all into an expression so that
-                                -- checkPattern can check that bangs are enabled
-
-        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
+        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
+                                              -- Turn it all into an expression so that
+                                              -- checkPattern can check that bangs are enabled
+                                            ; l = comb2 $1 $> };
+                                        (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+                                        -- Depending upon what the pattern looks like we might get either
+                                        -- a FunBind or PatBind back from checkValDef. See Note
+                                        -- [Varieties of binding pattern matches]
+                                        case r of {
+                                          (FunBind n _ _ _ _) ->
+                                                ams (L l ()) [mj AnnFunId n] >> return () ;
+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                                ams (L lh ()) [] >> return () } ;
+
+                                        _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
+                                        return $! (sL l $ ValD r) } }
+
+        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
+                                        -- Depending upon what the pattern looks like we might get either
+                                        -- a FunBind or PatBind back from checkValDef. See Note
+                                        -- [Varieties of binding pattern matches]
                                         case r of {
                                           (FunBind n _ _ _ _) ->
                                                 ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
index eb78073..f2c8b33 100644 (file)
@@ -515,9 +515,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix) pats Nothing rhs
+                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
                InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
+                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -925,25 +925,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
 -- Check Equation Syntax
 
 checkValDef :: SDoc
+            -> SrcStrictness
             -> LHsExpr GhcPs
             -> Maybe (LHsType GhcPs)
             -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
 
-checkValDef msg lhs (Just sig) grhss
+checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
                         (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
 
-checkValDef msg lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
-              checkFunBind msg ann (getLoc lhs)
+              checkFunBind msg strictness ann (getLoc lhs)
                            fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
+             -> SrcStrictness
              -> [AddAnn]
              -> SrcSpan
              -> Located RdrName
@@ -952,13 +954,13 @@ checkFunBind :: SDoc
              -> Maybe (LHsType GhcPs)
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
         return (ann, makeFunBind fun
-                  [L match_span (Match { m_ctxt = FunRhs fun is_infix
+                  [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
                                        , m_pats = ps
                                        , m_type = opt_sig
                                        , m_grhss = grhss })])
@@ -1072,6 +1074,12 @@ isFunLhs e = go e [] []
    go (L _ (HsApp f e)) es       ann = go f (e:es) ann
    go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
+        -- Things of the form `!x` are also FunBinds
+        -- See Note [Varieties of binding pattern matches]
+   go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+        | bang == bang_RDR
+        , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))
+
         -- For infix function defns, there should be only one infix *function*
         -- (though there may be infix *datacons* involved too).  So we don't
         -- need fixity info to figure out which function is being defined.
index 5d6d037..e18068b 100644 (file)
@@ -1168,8 +1168,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
         ; let mf' = case (ctxt,mf) of
-                      (FunRhs (L _ funid) _,FunRhs (L lf _) _)
-                                            -> FunRhs (L lf funid) fixity
+                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict)
+                                            -> FunRhs (L lf funid) fixity strict
                       _                     -> ctxt
         ; return (Match { m_ctxt = mf', m_pats = pats'
                         , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
index c228b53..8207169 100644 (file)
@@ -22,6 +22,7 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
+import BasicTypes (LexicalFixity(..))
 import HsSyn
 import TcRnMonad
 import TcEnv
@@ -98,7 +99,13 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
     arity = matchGroupArity matches
     herald = text "The equation(s) for"
              <+> quotes (ppr fun_name) <+> text "have"
-    match_ctxt = MC { mc_what = mkPrefixFunRhs fn, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody }
+    strictness
+      | [L _ match] <- unLoc $ mg_alts matches
+      , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+      = SrcStrict
+      | otherwise
+      = NoSrcStrict
 
 {-
 @tcMatchesCase@ doesn't do the argument-count check because the
index ae1ec85..1854b2d 100644 (file)
 ((Test10358.hs:(4,1)-(8,6),AnnSemi), [Test10358.hs:9:1]),
 ((Test10358.hs:(5,3)-(8,6),AnnIn), [Test10358.hs:8:3-4]),
 ((Test10358.hs:(5,3)-(8,6),AnnLet), [Test10358.hs:5:3-5]),
-((Test10358.hs:5:7-10,AnnBang), [Test10358.hs:5:7]),
+((Test10358.hs:5:7-16,AnnBang), [Test10358.hs:5:7]),
 ((Test10358.hs:5:7-16,AnnEqual), [Test10358.hs:5:12]),
+((Test10358.hs:5:7-16,AnnFunId), [Test10358.hs:5:8-10]),
 ((Test10358.hs:5:7-16,AnnSemi), [Test10358.hs:5:17]),
 ((Test10358.hs:5:14-16,AnnVal), [Test10358.hs:5:15]),
-((Test10358.hs:5:19-22,AnnBang), [Test10358.hs:5:19]),
+((Test10358.hs:5:19-32,AnnBang), [Test10358.hs:5:19]),
 ((Test10358.hs:5:19-32,AnnEqual), [Test10358.hs:5:24]),
+((Test10358.hs:5:19-32,AnnFunId), [Test10358.hs:5:20-22]),
 ((Test10358.hs:5:19-32,AnnSemi), [Test10358.hs:6:7]),
 ((Test10358.hs:5:26-32,AnnVal), [Test10358.hs:5:29]),
 ((Test10358.hs:6:7-16,AnnEqual), [Test10358.hs:6:10]),
index 9f9cf65..ad3680e 100644 (file)
            (FunRhs 
             ({ DumpParsedAst.hs:11:1-4 }
              (Unqual {OccName: main})) 
-            (Prefix)) 
+            (Prefix) 
+            (NoSrcStrict)) 
            [] 
            (Nothing) 
            (GRHSs 
index d0b456a..c873ee1 100644 (file)
@@ -17,7 +17,8 @@
            (Match 
             (FunRhs 
              ({ DumpRenamedAst.hs:11:1-4 }{Name: main:DumpRenamedAst.main{v}}) 
-             (Prefix)) 
+             (Prefix) 
+             (NoSrcStrict)) 
             [] 
             (Nothing) 
             (GRHSs 
index 4b10222..663a7d7 100644 (file)
           (Match 
            (FunRhs 
             ({ DumpTypecheckedAst.hs:11:1-4 }{Name: main:DumpTypecheckedAst.main{v}}) 
-            (Prefix)) 
+            (Prefix) 
+            (NoSrcStrict)) 
            [] 
            (Nothing) 
            (GRHSs 
index 9c88cdc..f53a84c 100644 (file)
@@ -1131,7 +1131,9 @@ test('MultiLayerModules',
 test('T13701',
      [ compiler_stats_num_field('bytes allocated',
           [(platform('x86_64-apple-darwin'), 2217187888, 10),
-           (wordsize(64), 2511285600, 10),
+           (wordsize(64), 2188045288, 10),
+           # initial:     2511285600
+           # 2017-06-23:  2188045288    treat banged variable bindings as FunBinds
           ]),
        pre_cmd('./genT13701'),
        extra_files(['genT13701']),
index 72d33c1..dc7bd7b 100644 (file)
@@ -556,7 +556,7 @@ test('T13474', normal, compile, [''])
 test('T13524', normal, compile, [''])
 test('T13509', normal, compile, [''])
 test('T13526', normal, compile, [''])
-test('T13594', expect_broken(13594), compile, [''])
+test('T13594', normal, compile, [''])
 test('T13603', normal, compile, [''])
 test('T13333', normal, compile, [''])
 test('T13585', [extra_files(['T13585.hs', 'T13585a.hs', 'T13585b.hs'])], run_command, ['$MAKE -s --no-print-directory T13585'])
index ab5ab42..346c312 100755 (executable)
@@ -122,4 +122,4 @@ test('Typeable1', normal, compile_fail, [''])
 test('TypeableEq', normal, compile_and_run, [''])
 test('T13435', normal, compile_and_run, [''])
 test('T11715', exit_code(1), compile_and_run, [''])
-test('T13594a', expect_broken(13594), ghci_script, ['T13594a.script'])
+test('T13594a', normal, ghci_script, ['T13594a.script'])