From 46a03fbec6a02761db079d1746532565f34c340f Mon Sep 17 00:00:00 2001
From: Adam Sandberg Eriksson <adam@sandbergericsson.se>
Date: Sat, 14 Nov 2015 22:06:16 +0100
Subject: Implement the Strict language extension

Add a new language extension `-XStrict` which turns all bindings strict
as if the programmer had written a `!` before it. This also upgrades
ordinary Haskell to allow recursive and polymorphic strict bindings.

See the wiki[1] and the Note [Desugar Strict binds] in DsBinds for
specification and implementation details.

[1] https://ghc.haskell.org/trac/ghc/wiki/StrictPragma

Reviewers: austin, tibbe, simonpj, bgamari

Reviewed By: tibbe, bgamari

Subscribers: thomie

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

GHC Trac Issues: #8347
---
 compiler/deSugar/DsExpr.hs | 45 ++++++++++++++++++++++++---------------------
 1 file changed, 24 insertions(+), 21 deletions(-)

(limited to 'compiler/deSugar/DsExpr.hs')

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index dc6be9cddd..886961c4d0 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -109,16 +109,17 @@ ds_val_bind (NonRecursive, hsbinds) body
         -- ToDo: in some bizarre case it's conceivable that there
         --       could be dict binds in the 'binds'.  (See the notes
         --       below.  Then pattern-match would fail.  Urk.)
-    strictMatchOnly bind
-  = putSrcSpanDs loc (dsStrictBind bind body)
+    unliftedMatchOnly bind
+  = putSrcSpanDs loc (dsUnliftedBind bind body)
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (_is_rec, binds) body
-  = do  { prs <- dsLHsBinds binds
+  = do  { (force_vars,prs) <- dsLHsBinds binds
+        ; let body' = foldr seqVar body force_vars
         ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
           case prs of
             [] -> return body
-            _  -> return (Let (Rec prs) body) }
+            _  -> return (Let (Rec prs) body') }
         -- Use a Rec regardless of is_rec.
         -- Why? Because it allows the binds to be all
         -- mixed up, which is what happens in one rare case
@@ -131,29 +132,31 @@ ds_val_bind (_is_rec, binds) body
         --    only have to deal with lifted ones now; so Rec is ok
 
 ------------------
-dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
-dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
                , abs_exports = exports
                , abs_ev_binds = ev_binds
                , abs_binds = lbinds }) body
   = do { let body1 = foldr bind_export body exports
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
+       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
                             body1 lbinds
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
-dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
-                      , fun_tick = tick }) body
-                -- Can't be a bang pattern (that looks like a PatBind)
-                -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun )) matches
+dsUnliftedBind (FunBind { fun_id = L _ fun
+                        , fun_matches = matches
+                        , fun_co_fn = co_fn
+                        , fun_tick = tick }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
        ; let rhs' = mkOptTickBox tick rhs
        ; return (bindNonRec fun rhs' body) }
 
-dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
     do { rhs <- dsGuarded grhss ty
@@ -164,19 +167,19 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
        ; return (bindNonRec var rhs result) }
 
-dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
 ----------------------
-strictMatchOnly :: HsBind Id -> Bool
-strictMatchOnly (AbsBinds { abs_binds = lbinds })
-  = anyBag (strictMatchOnly . unLoc) lbinds
-strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
+unliftedMatchOnly :: HsBind Id -> Bool
+unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
+  = anyBag (unliftedMatchOnly . unLoc) lbinds
+unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
   =  isUnLiftedType rhs_ty
-  || isStrictLPat lpat
+  || isUnliftedLPat lpat
   || any (isUnLiftedType . idType) (collectPatBinders lpat)
-strictMatchOnly (FunBind { fun_id = L _ id })
+unliftedMatchOnly (FunBind { fun_id = L _ id })
   = isUnLiftedType (idType id)
-strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
+unliftedMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
 {-
 ************************************************************************
-- 
cgit v1.2.1