[commit: ghc] master: Make it evident in types that StgLam can't have empty args (41c1558)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/41c155876c9e8137ff9b9f9f9a12c4a78a44bc70/ghc

>---------------------------------------------------------------

commit 41c155876c9e8137ff9b9f9f9a12c4a78a44bc70
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date:   Mon Mar 26 23:15:32 2018 +0300

    Make it evident in types that StgLam can't have empty args
    
    StgLam can't have empty arguments. Reflect this in types. An assertion
    can now be deleted.
    
    Reviewers: bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie, carter
    
    Differential Revision: https://phabricator.haskell.org/D4484


>---------------------------------------------------------------

41c155876c9e8137ff9b9f9f9a12c4a78a44bc70
 compiler/stgSyn/CoreToStg.hs | 13 +++++++------
 compiler/stgSyn/StgSyn.hs    |  6 ++++--
 2 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index cb4e7f6..3ee3ba5 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -49,6 +49,7 @@ import PrimOp           ( PrimCall(..) )
 import UniqFM
 import SrcLoc           ( mkGeneralSrcSpan )
 
+import Data.List.NonEmpty (nonEmpty, toList)
 import Data.Maybe    (isJust, fromMaybe)
 import Control.Monad (liftM, ap)
 
@@ -418,9 +419,10 @@ coreToStgExpr expr@(Lam _ _)
     extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
     (body, body_fvs) <- coreToStgExpr body
     let
-        fvs             = args' `minusFVBinders` body_fvs
-        result_expr | null args' = body
-                    | otherwise  = StgLam args' body
+        fvs         = args' `minusFVBinders` body_fvs
+        result_expr = case nonEmpty args' of
+          Nothing     -> body
+          Just args'' -> StgLam args'' body
 
     return (result_expr, fvs)
 
@@ -771,11 +773,10 @@ mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
 mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
   | StgLam bndrs body <- rhs
   = -- StgLam can't have empty arguments, so not CAF
-    ASSERT(not (null bndrs))
     ( StgRhsClosure dontCareCCS binder_info
                     (getFVs rhs_fvs)
                     ReEntrant
-                    bndrs body
+                    (toList bndrs) body
     , ccs )
 
   | StgConApp con args _ <- unticked_rhs
@@ -825,7 +826,7 @@ mkStgRhs rhs_fvs bndr binder_info rhs
   = StgRhsClosure currentCCS binder_info
                   (getFVs rhs_fvs)
                   ReEntrant
-                  bndrs body
+                  (toList bndrs) body
 
   | isJoinId bndr -- must be a nullary join point
   = ASSERT(idJoinArity bndr == 0)
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 29d5441..608a028 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -70,6 +70,8 @@ import RepType     ( typePrimRep1 )
 import Unique      ( Unique )
 import Util
 
+import Data.List.NonEmpty ( NonEmpty, toList )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -221,7 +223,7 @@ finished it encodes (\x -> e) as (let f = \x -> e in f)
 -}
 
   | StgLam
-        [bndr]
+        (NonEmpty bndr)
         StgExpr    -- Body of lambda
 
 {-
@@ -721,7 +723,7 @@ pprStgExpr (StgOpApp op args _)
   = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam bndrs body)
-  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
             <+> text "->",
          pprStgExpr body ]
   where ppr_list = brackets . fsep . punctuate comma