diff options
| -rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 12 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/callarity/unittest/CallArity1.hs | 61 |
3 files changed, 41 insertions, 35 deletions
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 385ea4ecd6..a51ec697be 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -20,7 +20,7 @@ module CoreSyn ( OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, -- ** 'Expr' construction - mkLet, mkLets, mkLams, + mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, mkIntLit, mkIntLitInt, @@ -1863,6 +1863,16 @@ mkLet :: Bind b -> Expr b -> Expr b mkLet (Rec []) body = body mkLet bind body = Let bind body +-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. +mkLetNonRec :: b -> Expr b -> Expr b -> Expr b +mkLetNonRec b rhs body = Let (NonRec b rhs) body + +-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of +-- @binds@ if binds is non-empty. +mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b +mkLetRec [] body = body +mkLetRec bs body = Let (Rec bs) 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 mkTyBind :: TyVar -> Type -> CoreBind diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 0d96692a5d..42a28c962a 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -186,14 +186,13 @@ dsHsBind dflags addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check do { (_, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec bind_prs ; ds_binds <- dsTcEvBinds_s ev_binds ; core_wrap <- dsHsWrapper wrap -- Usually the identity ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ mkCoreLets ds_binds $ - mkLet core_bind $ + mkLetRec bind_prs $ Var local ; (spec_binds, rules) <- dsSpecs rhs prags diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 6b9591e6a1..8fd8feb548 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -43,17 +43,17 @@ exprs :: [(String, CoreExpr)] exprs = [ ("go2",) $ mkRFun go [x] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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] - (mkNrLet n (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec n (mkACase (Var go `mkVarApps` [x]) (mkLams [y] $ Var y)) $ mkACase (Var n) $ mkFun go2 [y] - (mkNrLet d + (mkLetNonRec 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] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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)",) $ - mkNrLet n (f `mkLApps` [0]) $ + mkLetNonRec n (f `mkLApps` [0]) $ mkRFun go [x] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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)",) $ - mkNrLet z (mkLit 0) $ + mkLetNonRec z (mkLit 0) $ mkRFun go [x] - (mkNrLet d (mkACase (Var go `mkVarApps` [x]) + (mkLetNonRec 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)",) $ - mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $ + mkLetNonRec 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!)",) $ - mkNrLet n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $ - mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $ + mkLetNonRec n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $ + mkLetNonRec d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $ Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]] , ("two functions, not thunks",) $ - 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]))) $ + mkLetNonRec go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $ + mkLetNonRec 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!)",) $ - mkNrLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $ + mkLetNonRec 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",) $ - mkNrLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $ + mkLetNonRec 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)",) $ - mkNrLet d (f `mkLApps` [0]) $ + mkLetNonRec 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",) $ - mkNrLet d (f `mkLApps` [0]) $ - mkNrLet x (d `mkLApps` [1]) $ + mkLetNonRec d (f `mkLApps` [0]) $ + mkLetNonRec x (d `mkLApps` [1]) $ Var f `mkVarApps` [x, x] , ("a thunk (function type), called multiple times, still calls once",) $ - mkNrLet d (f `mkLApps` [0]) $ - mkNrLet n (Var f `mkApps` [d `mkLApps` [1]]) $ + mkLetNonRec d (f `mkLApps` [0]) $ + mkLetNonRec 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)",) $ - mkNrLet d (f `mkLApps` [0]) $ + mkLetNonRec 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)",) $ - mkNrLet d (f `mkLApps` [0]) $ + mkLetNonRec 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)",) $ - mkNrLet d (f `mkLApps` [0]) $ + mkLetNonRec 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)",) $ - mkNrLet d (f `mkLApps` [0]) $ - mkNrLet x (d `mkLApps` [1]) $ + mkLetNonRec d (f `mkLApps` [0]) $ + mkLetNonRec x (d `mkLApps` [1]) $ Var d `mkVarApps` [x] ] @@ -193,14 +193,11 @@ mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty mkTestIds :: [String] -> [Type] -> [Id] mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys -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 +mkRLet v rhs body = mkLetRec [(v, rhs)] body mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr -mkFun v xs rhs body = mkNrLet v (mkLams xs rhs) body +mkFun v xs rhs body = mkLetNonRec v (mkLams xs rhs) body mkRFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr mkRFun v xs rhs body = mkRLet v (mkLams xs rhs) body |