Commit 41c15587 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan

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
parent f0b258bc
......@@ -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)
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment