Update levity polymorphism

This commit implements the proposal in
https://github.com/ghc-proposals/ghc-proposals/pull/29 and
https://github.com/ghc-proposals/ghc-proposals/pull/35.

Here are some of the pieces of that proposal:

* Some of RuntimeRep's constructors have been shortened.

* TupleRep and SumRep are now parameterized over a list of RuntimeReps.
* This
means that two types with the same kind surely have the same
representation.
Previously, all unboxed tuples had the same kind, and thus the fact
above was
false.

* RepType.typePrimRep and friends now return a *list* of PrimReps. These
functions can now work successfully on unboxed tuples. This change is
necessary because we allow abstraction over unboxed tuple types and so
cannot
always handle unboxed tuples specially as we did before.

* We sometimes have to create an Id from a PrimRep. I thus split PtrRep
* into
LiftedRep and UnliftedRep, so that the created Ids have the right
strictness.

* The RepType.RepType type was removed, as it didn't seem to help with
* much.

* The RepType.repType function is also removed, in favor of typePrimRep.

* I have waffled a good deal on whether or not to keep VoidRep in
TyCon.PrimRep. In the end, I decided to keep it there. PrimRep is *not*
represented in RuntimeRep, and typePrimRep will never return a list
including
VoidRep. But it's handy to have in, e.g., ByteCodeGen and friends. I can
imagine another design choice where we have a PrimRepV type that is
PrimRep
with an extra constructor. That seemed to be a heavier design, though,
and I'm
not sure what the benefit would be.

* The last, unused vestiges of # (unliftedTypeKind) have been removed.

* There were several pretty-printing bugs that this change exposed;
* these are fixed.

* We previously checked for levity polymorphism in the types of binders.
* But we
also must exclude levity polymorphism in function arguments. This is
hard to check
for, requiring a good deal of care in the desugarer. See Note [Levity
polymorphism
checking] in DsMonad.

* In order to efficiently check for levity polymorphism in functions, it
* was necessary
to add a new bit of IdInfo. See Note [Levity info] in IdInfo.

* It is now safe for unlifted types to be unsaturated in Core. Core Lint
* is updated
accordingly.

* We can only know strictness after zonking, so several checks around
* strictness
in the type-checker (checkStrictBinds, the check for unlifted variables
under a ~
pattern) have been moved to the desugarer.

* Along the way, I improved the treatment of unlifted vs. banged
* bindings. See
Note [Strict binds checks] in DsBinds and #13075.

* Now that we print type-checked source, we must be careful to print
* ConLikes correctly.
This is facilitated by a new HsConLikeOut constructor to HsExpr.
Particularly troublesome
are unlifted pattern synonyms that get an extra void# argument.

* Includes a submodule update for haddock, getting rid of #.

* New testcases:
  typecheck/should_fail/StrictBinds
  typecheck/should_fail/T12973
  typecheck/should_run/StrictPats
  typecheck/should_run/T12809
  typecheck/should_fail/T13105
  patsyn/should_fail/UnliftedPSBind
  typecheck/should_fail/LevPolyBounded
  typecheck/should_compile/T12987
  typecheck/should_compile/T11736

* Fixed tickets:
  #12809
  #12973
  #11736
  #13075
  #12987

* This also adds a test case for #13105. This test case is
* "compile_fail" and
succeeds, because I want the testsuite to monitor the error message.
When #13105 is fixed, the test case will compile cleanly.

1 files changed, 74 insertions, 17 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 833d3570b3..ae18ffdf43 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -58,7 +58,7 @@ import SrcLoc
 import Maybes
 import OrdList
 import Bag
-import BasicTypes hiding ( TopLevel )
+import BasicTypes
 import DynFlags
 import FastString
 import Util
@@ -75,24 +75,42 @@ import Control.Monad
 -- | Desugar top level binds, strict binds are treated like normal
 -- binds since there is no good time to force before first usage.
 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds binds = fmap (toOL . snd) (ds_lhs_binds binds)
+dsTopLHsBinds binds
+     -- see Note [Strict binds checks]
+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
+       ; mapBagM_ (top_level_err "strict pattern bindings")    bang_binds
+       ; return nilOL }
 
--- | Desugar all other kind of bindings, Ids of strict binds are returned to
--- later be forced in the binding gorup body, see Note [Desugar Strict binds]
-dsLHsBinds :: LHsBinds Id
-           -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBinds binds = do { (force_vars, binds') <- ds_lhs_binds binds
-                      ; return (force_vars, binds') }
+  | otherwise
+  = do { (force_vars, prs) <- dsLHsBinds binds
+       ; when debugIsOn $
+         do { xstrict <- xoptM LangExt.Strict
+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
+              -- with -XStrict, even top-level vars are listed as force vars.
 
-------------------------
+       ; return (toOL prs) }
+
+  where
+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
+    bang_binds     = filterBag (isBangedPatBind  . unLoc) binds
+
+    top_level_err desc (L loc bind)
+      = putSrcSpanDs loc $
+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
+                  2 (ppr bind))
 
-ds_lhs_binds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)])
 
-ds_lhs_binds binds
-  = do { ds_bs <- mapBagM dsLHsBind binds
+-- | Desugar all other kind of bindings, Ids of strict binds are returned to
+-- later be forced in the binding gorup body, see Note [Desugar Strict binds]
+dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds binds
+  = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )
+       ; ds_bs <- mapBagM dsLHsBind binds
        ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
                          id ([], []) ds_bs) }
 
+------------------------
 dsLHsBind :: LHsBind Id
           -> DsM ([Id], [(Id,CoreExpr)])
 dsLHsBind (L loc bind) = do dflags <- getDynFlags
@@ -168,7 +186,7 @@ dsHsBind dflags
   = -- See Note [AbsBinds wrappers] in HsBinds
     addDictsDs (toTcTypeBag (listToBag dicts)) $
          -- addDictsDs: push type constraints deeper for pattern match check
-    do { (_, bind_prs) <- ds_lhs_binds binds
+    do { (_, bind_prs) <- dsLHsBinds binds
        ; let core_bind = Rec bind_prs
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; core_wrap <- dsHsWrapper wrap -- Usually the identity
@@ -192,7 +210,7 @@ dsHsBind dflags
          (AbsBinds { abs_tvs = [], abs_ev_vars = []
                    , abs_exports = exports
                    , abs_ev_binds = ev_binds, abs_binds = binds })
-  = do { (force_vars, bind_prs) <- ds_lhs_binds binds
+  = do { (force_vars, bind_prs) <- dsLHsBinds binds
        ; let mk_bind (ABE { abe_wrap = wrap
                           , abe_poly = global
                           , abe_mono = local
@@ -213,7 +231,7 @@ dsHsBind dflags
          -- See Note [Desugaring AbsBinds]
   = addDictsDs (toTcTypeBag (listToBag dicts)) $
          -- addDictsDs: push type constraints deeper for pattern match check
-     do { (local_force_vars, bind_prs) <- ds_lhs_binds binds
+     do { (local_force_vars, bind_prs) <- dsLHsBinds binds
         ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
                               | (lcl_id, rhs) <- bind_prs ]
                 -- Monomorphic recursion possible, hence Rec
@@ -590,6 +608,38 @@ tuple `t`, thus:
 See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more
 detailed explanation of the desugaring of strict bindings.
 
+Note [Strict binds checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several checks around properly formed strict bindings. They
+all link to this Note. These checks must be here in the desugarer because
+we cannot know whether or not a type is unlifted until after zonking, due
+to levity polymorphism. These checks all used to be handled in the typechecker
+in checkStrictBinds (before Jan '17).
+
+We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
+
+  x :: Char
+  (# True, x #) = blah
+
+is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
+
+Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.
+Define a "strict bind" to be either an unlifted bind or a banged bind.
+
+The restrictions are:
+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
+
+  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
+     surprised by the strictness of an unlifted bind.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
+     variables or constraints.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+
 -}
 
 ------------------------
@@ -1056,11 +1106,16 @@ dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
 dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
                                    ; w2 <- dsHsWrapper c2
                                    ; return (w1 . w2) }
-dsHsWrapper (WpFun c1 c2 t1)  = do { x  <- newSysLocalDs t1
+ -- See comments on WpFun in TcEvidence for an explanation of what
+ -- the specification of this clause is
+dsHsWrapper (WpFun c1 c2 t1 doc)
+                              = do { x  <- newSysLocalDsNoLP t1
                                    ; w1 <- dsHsWrapper c1
                                    ; w2 <- dsHsWrapper c2
                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
-                                   ; return (\e -> Lam x (w2 (app e (w1 (Var x))))) }
+                                         arg     = w1 (Var x)
+                                   ; dsNoLevPolyExpr arg doc
+                                   ; return (\e -> (Lam x (w2 (app e arg)))) }
 dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)
                                 return $ \e -> mkCastDs e co
 dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
@@ -1106,6 +1161,8 @@ dsEvTerm (EvCast tm co)
 dsEvTerm (EvDFunApp df tys tms)
   = do { tms' <- mapM dsEvTerm tms
        ; return $ Var df `mkTyApps` tys `mkApps` tms' }
+  -- The use of mkApps here is OK vis-a-vis levity polymorphism because
+  -- the terms are always evidence variables with types of kind Constraint
 
 dsEvTerm (EvCoercion co) = return (Coercion co)
 dsEvTerm (EvSuperClass d n)