Skip to content

GitLab

GHC
GHC
Commit 8a9b57f6 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari
Browse files
Options

Kill off the remaining Rec [] 

The desugarer was producing an empty Rec group, which is never
supposed to happen.  This small patch stops that happening.

Next up: Lint should check.
parent 2d5be63d
Hide whitespace changes
Inline Side-by-side
Showing with 39 additions and 34 deletions
compiler/coreSyn/CoreSyn.hs
View file @ 8a9b57f6
......@@ -20,7 +20,7 @@ module CoreSyn (
OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,
-- ** 'Expr' construction
mkLets, mkLams,
mkLet, mkLets, mkLams,
mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg,
mkIntLit, mkIntLitInt,
......@@ -1848,8 +1848,13 @@ mkLets :: [Bind b] -> Expr b -> Expr b
mkLams :: [b] -> Expr b -> Expr b
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
mkLets binds body = foldr mkLet body binds
mkLet :: Bind b -> Expr b -> Expr b
-- The desugarer sometimes generates an empty Rec group
-- which Lint rejects, so we kill it off right away
mkLet (Rec []) body = body
mkLet bind body = Let bind body
-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
-- this can only be used to bind something in a non-recursive @let@ expression
......
compiler/deSugar/DsBinds.hs
View file @ 8a9b57f6
......@@ -193,7 +193,7 @@ dsHsBind dflags
; let rhs = core_wrap $
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
mkLet core_bind $
Var local
; (spec_binds, rules) <- dsSpecs rhs prags
......@@ -242,7 +242,7 @@ dsHsBind dflags
; ds_binds <- dsTcEvBinds_s ev_binds
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
mkLet core_bind $
tup_expr
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
......
testsuite/tests/callarity/unittest/CallArity1.hs
View file @ 8a9b57f6
......@@ -43,17 +43,17 @@ exprs :: [(String, CoreExpr)]
exprs =
[ ("go2",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
go `mkLApps` [0, 0]
, ("nested_go2",) $
mkRFun go [x]
(mkLet n (mkACase (Var go `mkVarApps` [x])
(mkNrLet n (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)) $
mkACase (Var n) $
mkFun go2 [y]
(mkLet d
(mkNrLet d
(mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y) ) $
mkLams [z] $ Var d `mkVarApps` [x] )$
......@@ -61,40 +61,40 @@ exprs =
go `mkLApps` [0, 0]
, ("d0 (go 2 would be bad)",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $
mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
go `mkLApps` [0, 0]
, ("go2 (in case crut)",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
Case (go `mkLApps` [0, 0]) z intTy
[(DEFAULT, [], Var f `mkVarApps` [z,z])]
, ("go2 (in function call)",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
f `mkLApps` [0] `mkApps` [go `mkLApps` [0, 0]]
, ("go2 (using surrounding interesting let)",) $
mkLet n (f `mkLApps` [0]) $
mkNrLet n (f `mkLApps` [0]) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
Var f `mkApps` [n `mkLApps` [0], go `mkLApps` [0, 0]]
, ("go2 (using surrounding boring let)",) $
mkLet z (mkLit 0) $
mkNrLet z (mkLit 0) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkNrLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
Var f `mkApps` [Var z, go `mkLApps` [0, 0]]
, ("two calls, one from let and from body (d 1 would be bad)",) $
mkLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
mkFun go [x,y] (mkVarApps (Var d) [x]) $
mkApps (Var d) [mkLApps go [1,2]]
, ("a thunk in a recursion (d 1 would be bad)",) $
......@@ -102,19 +102,19 @@ exprs =
mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
Var n `mkApps` [d `mkLApps` [0]]
, ("two thunks, one called multiple times (both arity 1 would be bad!)",) $
mkLet n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
mkLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
mkNrLet n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
, ("two functions, not thunks",) $
mkLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
mkLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
mkNrLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
mkNrLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
, ("a thunk, called multiple times via a forking recursion (d 1 would be bad!)",) $
mkLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (Var d))) $
go2 `mkLApps` [0,1]
, ("a function, one called multiple times via a forking recursion",) $
mkLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
mkNrLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (go `mkLApps` [0]))) $
go2 `mkLApps` [0,1]
, ("two functions (recursive)",) $
......@@ -130,36 +130,36 @@ exprs =
, (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
, ("mutual recursion (functions), one boring (d 1 would be bad)",) $
mkLet d (f `mkLApps` [0]) $
mkNrLet d (f `mkLApps` [0]) $
Let (Rec [ (go, mkLams [x, y] (Var d `mkApps` [go2 `mkLApps` [1,2]]))
, (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
Var d `mkApps` [go2 `mkLApps` [0,1]]
, ("a thunk (non-function-type), called twice, still calls once",) $
mkLet d (f `mkLApps` [0]) $
mkLet x (d `mkLApps` [1]) $
mkNrLet d (f `mkLApps` [0]) $
mkNrLet x (d `mkLApps` [1]) $
Var f `mkVarApps` [x, x]
, ("a thunk (function type), called multiple times, still calls once",) $
mkLet d (f `mkLApps` [0]) $
mkLet n (Var f `mkApps` [d `mkLApps` [1]]) $
mkNrLet d (f `mkLApps` [0]) $
mkNrLet n (Var f `mkApps` [d `mkLApps` [1]]) $
mkLams [x] $ Var n `mkVarApps` [x]
, ("a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good)",) $
mkLet d (f `mkLApps` [0]) $
mkNrLet d (f `mkLApps` [0]) $
Let (Rec [ (x, Var d `mkApps` [go `mkLApps` [1,2]])
, (go, mkLams [x] $ mkACase (mkLams [z] $ Var x) (Var go `mkVarApps` [x]) ) ]) $
Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
, ("a thunk (non-function-type), in mutual recursion, causes many calls (d 1 would be bad)",) $
mkLet d (f `mkLApps` [0]) $
mkNrLet d (f `mkLApps` [0]) $
Let (Rec [ (x, Var go `mkApps` [go `mkLApps` [1,2], go `mkLApps` [1,2]])
, (go, mkLams [x] $ mkACase (Var d) (Var go `mkVarApps` [x]) ) ]) $
Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
, ("a thunk (function type), in mutual recursion, still calls once (d 1 would be good)",) $
mkLet d (f `mkLApps` [0]) $
mkNrLet d (f `mkLApps` [0]) $
Let (Rec [ (n, Var go `mkApps` [d `mkLApps` [1]])
, (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
, ("a thunk (non-function-type) co-calls with the body (d 1 would be bad)",) $
mkLet d (f `mkLApps` [0]) $
mkLet x (d `mkLApps` [1]) $
mkNrLet d (f `mkLApps` [0]) $
mkNrLet x (d `mkLApps` [1]) $
Var d `mkVarApps` [x]
]
......@@ -193,14 +193,14 @@ mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty
mkTestIds :: [String] -> [Type] -> [Id]
mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys
mkLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
mkLet v rhs body = Let (NonRec v rhs) body
mkNrLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
mkNrLet v rhs body = Let (NonRec v rhs) body
mkRLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
mkRLet v rhs body = Let (Rec [(v, rhs)]) body
mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
mkFun v xs rhs body = mkLet v (mkLams xs rhs) body
mkFun v xs rhs body = mkNrLet v (mkLams xs rhs) body
mkRFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
mkRFun v xs rhs body = mkRLet v (mkLams xs rhs) body
......
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