Update levity polymorphism
authorRichard Eisenberg <rae@cs.brynmawr.edu>
Thu, 15 Dec 2016 02:37:43 +0000 (21:37 -0500)
committerRichard Eisenberg <rae@cs.brynmawr.edu>
Thu, 19 Jan 2017 15:31:52 +0000 (10:31 -0500)
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.

163 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/basicTypes/MkId.hs
compiler/cmm/CmmUtils.hs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmArgRep.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreArity.hs
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreSubst.hs
compiler/coreSyn/CoreSyn.hs
compiler/coreSyn/CoreUtils.hs
compiler/coreSyn/MkCore.hs
compiler/coreSyn/PprCore.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsCCall.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsExpr.hs-boot
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMonad.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchCon.hs
compiler/deSugar/PmExpr.hs
compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/Debugger.hs
compiler/ghci/GHCi.hsc
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsUtils.hs
compiler/iface/IfaceSyn.hs
compiler/iface/IfaceType.hs
compiler/iface/TcIface.hs
compiler/iface/ToIface.hs
compiler/main/DynFlags.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/prelude/PrelNames.hs
compiler/prelude/PrimOp.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/prelude/TysWiredIn.hs-boot
compiler/simplCore/SetLevels.hs
compiler/simplCore/SimplEnv.hs
compiler/simplCore/SimplUtils.hs
compiler/simplCore/Simplify.hs
compiler/simplStg/RepType.hs
compiler/simplStg/UnariseStg.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgLint.hs
compiler/stgSyn/StgSyn.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenFunctor.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcTypeable.hs
compiler/typecheck/TcUnify.hs
compiler/types/FamInstEnv.hs
compiler/types/Kind.hs
compiler/types/TyCoRep.hs
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/utils/Bag.hs
compiler/utils/Outputable.hs
docs/users_guide/glasgow_exts.rst
docs/users_guide/using-warnings.rst
docs/users_guide/using.rst
libraries/base/Data/Typeable/Internal.hs
libraries/base/Unsafe/Coerce.hs
libraries/base/tests/T11334a.hs
libraries/base/tests/T11334a.stdout
libraries/ghc-prim/GHC/Types.hs
libraries/integer-gmp/src/GHC/Integer/Logarithms.hs
libraries/integer-gmp/src/GHC/Integer/Type.hs
testsuite/tests/deSugar/should_compile/T10662.stderr
testsuite/tests/dependent/should_compile/RaeJobTalk.hs
testsuite/tests/dependent/should_fail/T11473.stderr
testsuite/tests/deriving/should_fail/T12512.hs
testsuite/tests/deriving/should_fail/T12512.stderr
testsuite/tests/ghci/scripts/GhciKinds.stdout
testsuite/tests/ghci/scripts/T9140.stdout
testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T
testsuite/tests/patsyn/should_fail/unboxed-bind.hs
testsuite/tests/patsyn/should_fail/unboxed-bind.stderr
testsuite/tests/quasiquotation/T7918.stdout
testsuite/tests/simplCore/should_compile/T9400.stderr
testsuite/tests/simplCore/should_compile/spec-inline.stderr
testsuite/tests/th/T12403.stdout
testsuite/tests/th/T12478_1.stdout
testsuite/tests/th/T5358.stderr
testsuite/tests/th/T5976.stderr
testsuite/tests/th/T8987.stderr
testsuite/tests/typecheck/should_compile/T11723.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T11736.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T12987.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs [deleted file]
testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr [deleted file]
testsuite/tests/typecheck/should_fail/LevPolyBounded.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/StrictBinds.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/StrictBinds.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T11723.hs [deleted file]
testsuite/tests/typecheck/should_fail/T11723.stderr [deleted file]
testsuite/tests/typecheck/should_fail/T11724.stderr
testsuite/tests/typecheck/should_fail/T12973.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12973.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13105.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13105.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T2806.hs
testsuite/tests/typecheck/should_fail/T2806.stderr
testsuite/tests/typecheck/should_fail/T6078.stderr
testsuite/tests/typecheck/should_fail/all.T
testsuite/tests/typecheck/should_fail/tcfail203.hs
testsuite/tests/typecheck/should_fail/tcfail203.stderr
testsuite/tests/typecheck/should_fail/tcfail203a.stderr
testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/KindInvariant.stderr
testsuite/tests/typecheck/should_run/StrictPats.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/StrictPats.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/T12809.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/T12809.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/TypeOf.hs
testsuite/tests/typecheck/should_run/TypeOf.stdout
testsuite/tests/typecheck/should_run/TypeRep.hs
testsuite/tests/typecheck/should_run/TypeRep.stdout
testsuite/tests/typecheck/should_run/all.T
testsuite/tests/unboxedsums/T12711.stdout
testsuite/tests/unboxedsums/UbxSumLevPoly.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/all.T
testsuite/tests/unboxedsums/sum_rr.hs
testsuite/tests/unboxedsums/sum_rr.stderr [deleted file]
testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
utils/haddock

index 5f73843..37baf2b 100644 (file)
@@ -753,7 +753,7 @@ pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
                -> SDoc        -- ^ 'SDoc' where the alternative havs been pretty
                               -- printed and finally packed into a paragraph.
 pprAlternative pp x alt arity =
-    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt - 1) vbar)
+    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
 
 {-
 ************************************************************************
index 84cafa3..bab8caf 100644 (file)
@@ -85,12 +85,13 @@ module Id (
 
         -- ** Reading 'IdInfo' fields
         idArity,
-        idCallArity,
+        idCallArity, idFunRepArity,
         idUnfolding, realIdUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
         idCafInfo,
         idOneShotInfo, idStateHackOneShotInfo,
         idOccInfo,
+        isNeverLevPolyId,
 
         -- ** Writing 'IdInfo' fields
         setIdUnfolding,
@@ -125,6 +126,7 @@ import Var( Id, CoVar, DictId,
 import qualified Var
 
 import Type
+import RepType
 import TysPrim
 import DataCon
 import Demand
@@ -563,6 +565,9 @@ idCallArity id = callArityInfo (idInfo id)
 setIdCallArity :: Id -> Arity -> Id
 setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id
 
+idFunRepArity :: Id -> RepArity
+idFunRepArity x = countFunRepArgs (idArity x) (idType x)
+
 -- | Returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
 isBottomingId id = isBottomingSig (idStrictness id)
@@ -863,3 +868,6 @@ transferPolyIdInfo old_id abstract_wrt new_id
                                  `setInlinePragInfo` old_inline_prag
                                  `setOccInfo` old_occ_info
                                  `setStrictnessInfo` new_strictness
+
+isNeverLevPolyId :: Id -> Bool
+isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
index 392c1ec..3c6727c 100644 (file)
@@ -8,6 +8,8 @@
 Haskell. [WDP 94/11])
 -}
 
+{-# LANGUAGE CPP #-}
+
 module IdInfo (
         -- * The IdDetails type
         IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
@@ -66,8 +68,14 @@ module IdInfo (
 
         -- ** Tick-box Info
         TickBoxOp(..), TickBoxId,
+
+        -- ** Levity info
+        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,
+        isNeverLevPolyIdInfo
     ) where
 
+#include "HsVersions.h"
+
 import CoreSyn
 
 import Class
@@ -78,10 +86,12 @@ import BasicTypes
 import DataCon
 import TyCon
 import PatSyn
+import Type
 import ForeignCall
 import Outputable
 import Module
 import Demand
+import Util
 
 -- infixl so you can say (id `set` a `set` b)
 infixl  1 `setRuleInfo`,
@@ -92,7 +102,9 @@ infixl  1 `setRuleInfo`,
           `setOccInfo`,
           `setCafInfo`,
           `setStrictnessInfo`,
-          `setDemandInfo`
+          `setDemandInfo`,
+          `setNeverLevPoly`,
+          `setLevityInfoWithType`
 
 {-
 ************************************************************************
@@ -127,7 +139,8 @@ data IdDetails
                                 -- or class operation of a class
 
   | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator
-  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call
+  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.
+                                -- Type will be simple: no type families, newtypes, etc
 
   | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
 
@@ -169,18 +182,18 @@ pprIdDetails :: IdDetails -> SDoc
 pprIdDetails VanillaId = empty
 pprIdDetails other     = brackets (pp other)
  where
-   pp VanillaId         = panic "pprIdDetails"
-   pp (DataConWorkId _) = text "DataCon"
-   pp (DataConWrapId _) = text "DataConWrapper"
-   pp (ClassOpId {})    = text "ClassOp"
-   pp (PrimOpId _)      = text "PrimOp"
-   pp (FCallId _)       = text "ForeignCall"
-   pp (TickBoxOpId _)   = text "TickBoxOp"
-   pp (DFunId nt)       = text "DFunId" <> ppWhen nt (text "(nt)")
+   pp VanillaId               = panic "pprIdDetails"
+   pp (DataConWorkId _)       = text "DataCon"
+   pp (DataConWrapId _)       = text "DataConWrapper"
+   pp (ClassOpId {})          = text "ClassOp"
+   pp (PrimOpId _)            = text "PrimOp"
+   pp (FCallId _)             = text "ForeignCall"
+   pp (TickBoxOpId _)         = text "TickBoxOp"
+   pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")
    pp (RecSelId { sel_naughty = is_naughty })
-                         = brackets $ text "RecSel"
-                            <> ppWhen is_naughty (text "(naughty)")
-   pp CoVarId           = text "CoVarId"
+                              = brackets $ text "RecSel" <>
+                                           ppWhen is_naughty (text "(naughty)")
+   pp CoVarId                 = text "CoVarId"
 
 {-
 ************************************************************************
@@ -221,8 +234,10 @@ data IdInfo
         strictnessInfo  :: StrictSig,      --  ^ A strictness signature
 
         demandInfo      :: Demand,       -- ^ ID demand information
-        callArityInfo :: !ArityInfo    -- ^ How this is called.
+        callArityInfo   :: !ArityInfo,   -- ^ How this is called.
                                          -- n <=> all calls have at least n arguments
+
+        levityInfo      :: LevityInfo    -- ^ when applied, will this Id ever have a levity-polymorphic type?
     }
 
 -- Setters
@@ -272,7 +287,8 @@ vanillaIdInfo
             occInfo             = NoOccInfo,
             demandInfo          = topDmd,
             strictnessInfo      = nopSig,
-            callArityInfo     = unknownArity
+            callArityInfo       = unknownArity,
+            levityInfo          = NoLevityInfo
            }
 
 -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
@@ -520,3 +536,51 @@ data TickBoxOp
 
 instance Outputable TickBoxOp where
     ppr (TickBox mod n)         = text "tick" <+> ppr (mod,n)
+
+{-
+************************************************************************
+*                                                                      *
+   Levity
+*                                                                      *
+************************************************************************
+
+Note [Levity info]
+~~~~~~~~~~~~~~~~~~
+
+Ids store whether or not they can be levity-polymorphic at any amount
+of saturation. This is helpful in optimizing the levity-polymorphism check
+done in the desugarer, where we can usually learn that something is not
+levity-polymorphic without actually figuring out its type. See
+isExprLevPoly in CoreUtils for where this info is used. Storing
+this is required to prevent perf/compiler/T5631 from blowing up.
+
+-}
+
+-- See Note [Levity info]
+data LevityInfo = NoLevityInfo  -- always safe
+                | NeverLevityPolymorphic
+  deriving Eq
+
+instance Outputable LevityInfo where
+  ppr NoLevityInfo           = text "NoLevityInfo"
+  ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"
+
+-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when
+-- applied). The Type is only there for checking that it's really never levity
+-- polymorphic
+setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
+setNeverLevPoly info ty
+  = ASSERT2( not (resultIsLevPoly ty), ppr ty )
+    info { levityInfo = NeverLevityPolymorphic }
+
+setLevityInfoWithType :: IdInfo -> Type -> IdInfo
+setLevityInfoWithType info ty
+  | not (resultIsLevPoly ty)
+  = info { levityInfo = NeverLevityPolymorphic }
+  | otherwise
+  = info
+
+isNeverLevPolyIdInfo :: IdInfo -> Bool
+isNeverLevPolyIdInfo info
+  | NeverLevityPolymorphic <- levityInfo info = True
+  | otherwise                                 = False
index df9d202..417a6c7 100644 (file)
@@ -55,7 +55,6 @@ import TyCon
 import CoAxiom
 import Class
 import NameSet
-import VarSet
 import Name
 import PrimOp
 import ForeignCall
@@ -287,8 +286,9 @@ mkDictSelId name clas
              getNth arg_tys val_index
 
     base_info = noCafIdInfo
-                `setArityInfo`         1
-                `setStrictnessInfo`    strict_sig
+                `setArityInfo`          1
+                `setStrictnessInfo`     strict_sig
+                `setLevityInfoWithType` sel_ty
 
     info | new_tycon
          = base_info `setInlinePragInfo` alwaysInlinePragma
@@ -380,10 +380,13 @@ mkDataConWorkId wkr_name data_con
     alg_wkr_ty = dataConRepType data_con
     wkr_arity = dataConRepArity data_con
     wkr_info  = noCafIdInfo
-                `setArityInfo`       wkr_arity
-                `setStrictnessInfo`  wkr_sig
-                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
-                                                     -- even if arity = 0
+                `setArityInfo`          wkr_arity
+                `setStrictnessInfo`     wkr_sig
+                `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
+                                                        -- even if arity = 0
+                `setLevityInfoWithType` alg_wkr_ty
+                  -- NB: unboxed tuples have workers, so we can't use
+                  -- setNeverLevPoly
 
     wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
@@ -409,8 +412,9 @@ mkDataConWorkId wkr_name data_con
     nt_wrap_ty   = dataConUserType data_con
     nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                   `setArityInfo` 1      -- Arity 1
-                  `setInlinePragInfo`    alwaysInlinePragma
-                  `setUnfoldingInfo`     newtype_unf
+                  `setInlinePragInfo`     alwaysInlinePragma
+                  `setUnfoldingInfo`      newtype_unf
+                  `setLevityInfoWithType` nt_wrap_ty
     id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
     newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                             isSingleton nt_arg_tys, ppr data_con  )
@@ -520,6 +524,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
                              -- We need to get the CAF info right here because TidyPgm
                              -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                              -- so it not make sure that the CAF info is sane
+                         `setNeverLevPoly`      wrap_ty
 
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
              wrap_arg_dmds = map mk_dmd arg_ibangs
@@ -965,10 +970,11 @@ mkPrimOpId prim_op
     id   = mkGlobalId (PrimOpId prim_op) name ty info
 
     info = noCafIdInfo
-           `setRuleInfo`          mkRuleInfo (maybeToList $ primOpRules name prim_op)
-           `setArityInfo`         arity
-           `setStrictnessInfo`    strict_sig
-           `setInlinePragInfo`    neverInlinePragma
+           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)
+           `setArityInfo`          arity
+           `setStrictnessInfo`     strict_sig
+           `setInlinePragInfo`     neverInlinePragma
+           `setLevityInfoWithType` res_ty
                -- We give PrimOps a NOINLINE pragma so that we don't
                -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
                -- test) about a RULE conflicting with a possible inlining
@@ -985,7 +991,7 @@ mkPrimOpId prim_op
 
 mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
 mkFCallId dflags uniq fcall ty
-  = ASSERT( isEmptyVarSet (tyCoVarsOfType ty) )
+  = ASSERT( noFreeVarsOfType ty )
     -- A CCallOpId should have no free type variables;
     -- when doing substitutions won't substitute over it
     mkGlobalId (FCallId fcall) name ty info
@@ -997,8 +1003,9 @@ mkFCallId dflags uniq fcall ty
     name = mkFCallName uniq occ_str
 
     info = noCafIdInfo
-           `setArityInfo`         arity
-           `setStrictnessInfo`    strict_sig
+           `setArityInfo`          arity
+           `setStrictnessInfo`     strict_sig
+           `setLevityInfoWithType` ty
 
     (bndrs, _) = tcSplitPiTys ty
     arity      = count isAnonTyBinder bndrs
@@ -1101,7 +1108,8 @@ dollarId = pcMiscPrelId dollarName ty
 proxyHashId :: Id
 proxyHashId
   = pcMiscPrelId proxyName ty
-       (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
+       (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
+                    `setNeverLevPoly`  ty )
   where
     -- proxy# :: forall k (a:k). Proxy# k a
     bndrs   = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks)
@@ -1139,6 +1147,7 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
   where
     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                        `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)
+                       `setNeverLevPoly`   addrPrimTy
 
 ------------------------------------------------
 seqId :: Id     -- See Note [seqId magic]
@@ -1147,6 +1156,7 @@ seqId = pcMiscPrelId seqName ty info
     info = noCafIdInfo `setInlinePragInfo` inline_prag
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
                        `setRuleInfo`       mkRuleInfo [seq_cast_rule]
+                       `setNeverLevPoly`   ty
 
     inline_prag
          = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
@@ -1188,13 +1198,13 @@ match_seq_of_cast _ _ _ _ = Nothing
 lazyId :: Id    -- See Note [lazyId magic]
 lazyId = pcMiscPrelId lazyIdName ty info
   where
-    info = noCafIdInfo
+    info = noCafIdInfo `setNeverLevPoly` ty
     ty  = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
 
 noinlineId :: Id -- See Note [noinlineId magic]
 noinlineId = pcMiscPrelId noinlineIdName ty info
   where
-    info = noCafIdInfo
+    info = noCafIdInfo `setNeverLevPoly` ty
     ty  = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
 
 oneShotId :: Id -- See Note [The oneShot function]
@@ -1240,6 +1250,7 @@ magicDictId :: Id  -- See Note [magicDictId magic]
 magicDictId = pcMiscPrelId magicDictName ty info
   where
   info = noCafIdInfo `setInlinePragInfo` neverInlinePragma
+                     `setNeverLevPoly`   ty
   ty   = mkSpecForAllTys [alphaTyVar] alphaTy
 
 --------------------------------------------------------------------------------
@@ -1249,6 +1260,7 @@ coerceId = pcMiscPrelId coerceName ty info
   where
     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
+                       `setNeverLevPoly`   ty
     eqRTy     = mkTyConApp coercibleTyCon [ liftedTypeKind
                                           , alphaTy, betaTy ]
     eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind
@@ -1291,7 +1303,7 @@ unboxed values (unsafeCoerce 3#).
 
 In contrast unsafeCoerce# is even more dangerous because you *can* use
 it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
-   forall (a:OpenKind) (b:OpenKind). a -> b
+   forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b
 
 Note [seqId magic]
 ~~~~~~~~~~~~~~~~~~
@@ -1552,11 +1564,13 @@ inlined.
 realWorldPrimId :: Id   -- :: State# RealWorld
 realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
                      (noCafIdInfo `setUnfoldingInfo` evaldUnfolding    -- Note [evaldUnfoldings]
-                                  `setOneShotInfo` stateHackOneShot)
+                                  `setOneShotInfo` stateHackOneShot
+                                  `setNeverLevPoly` realWorldStatePrimTy)
 
 voidPrimId :: Id     -- Global constant :: Void#
 voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy
-                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)    -- Note [evaldUnfoldings]
+                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding     -- Note [evaldUnfoldings]
+                             `setNeverLevPoly`  voidPrimTy)
 
 voidArgId :: Id       -- Local lambda-bound :: Void#
 voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
index f0bc096..3260cba 100644 (file)
@@ -11,7 +11,7 @@
 module CmmUtils(
         -- CmmType
         primRepCmmType, slotCmmType, slotForeignHint,
-        typeCmmType, typeForeignHint,
+        typeCmmType, typeForeignHint, primRepForeignHint,
 
         -- CmmLit
         zeroCLit, mkIntCLit,
@@ -65,7 +65,7 @@ module CmmUtils(
 #include "HsVersions.h"
 
 import TyCon    ( PrimRep(..), PrimElemRep(..) )
-import RepType  ( UnaryType, SlotTy (..), typePrimRep )
+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
 
 import SMRep
 import Cmm
@@ -90,7 +90,8 @@ import Hoopl
 
 primRepCmmType :: DynFlags -> PrimRep -> CmmType
 primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
-primRepCmmType dflags PtrRep           = gcWord dflags
+primRepCmmType dflags LiftedRep        = gcWord dflags
+primRepCmmType dflags UnliftedRep      = gcWord dflags
 primRepCmmType dflags IntRep           = bWord dflags
 primRepCmmType dflags WordRep          = bWord dflags
 primRepCmmType _      Int64Rep         = b64
@@ -120,11 +121,12 @@ primElemRepCmmType FloatElemRep  = f32
 primElemRepCmmType DoubleElemRep = f64
 
 typeCmmType :: DynFlags -> UnaryType -> CmmType
-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
 
 primRepForeignHint :: PrimRep -> ForeignHint
 primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
-primRepForeignHint PtrRep       = AddrHint
+primRepForeignHint LiftedRep    = AddrHint
+primRepForeignHint UnliftedRep  = AddrHint
 primRepForeignHint IntRep       = SignedHint
 primRepForeignHint WordRep      = NoHint
 primRepForeignHint Int64Rep     = SignedHint
@@ -142,7 +144,7 @@ slotForeignHint FloatSlot     = NoHint
 slotForeignHint DoubleSlot    = NoHint
 
 typeForeignHint :: UnaryType -> ForeignHint
-typeForeignHint = primRepForeignHint . typePrimRep
+typeForeignHint = primRepForeignHint . typePrimRep1
 
 ---------------------------------------------------
 --
index aac556d..bb82da2 100644 (file)
@@ -232,10 +232,10 @@ cgDataCon data_con
             -- We're generating info tables, so we don't know and care about
             -- what the actual arguments are. Using () here as the place holder.
             arg_reps :: [NonVoid PrimRep]
-            arg_reps = [ NonVoid (typePrimRep rep_ty)
+            arg_reps = [ NonVoid rep_ty
                        | ty <- dataConRepArgTys data_con
-                       , rep_ty <- repTypeArgs ty
-                       , not (isVoidTy rep_ty)]
+                       , rep_ty <- typePrimRep ty
+                       , not (isVoidRep rep_ty) ]
 
         ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
             -- NB: the closure pointer is assumed *untagged* on
index 9821b0a..969e14f 100644 (file)
@@ -64,7 +64,8 @@ argRepString V64 = "V64"
 
 toArgRep :: PrimRep -> ArgRep
 toArgRep VoidRep           = V
-toArgRep PtrRep            = P
+toArgRep LiftedRep         = P
+toArgRep UnliftedRep       = P
 toArgRep IntRep            = N
 toArgRep WordRep           = N
 toArgRep AddrRep           = N
index 7b9813a..3cc0af0 100644 (file)
@@ -163,8 +163,8 @@ assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
 -- Why are these here?
 
 idPrimRep :: Id -> PrimRep
-idPrimRep id = typePrimRep (idType id)
-    -- NB: typePrimRep fails on unboxed tuples,
+idPrimRep id = typePrimRep1 (idType id)
+    -- NB: typePrimRep1 fails on unboxed tuples,
     --     but by StgCmm no Ids have unboxed tuple type
 
 addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
@@ -176,7 +176,7 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
                            in NonVoid (argPrimRep arg', arg'))
 
 argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep (stgArgType arg)
+argPrimRep arg = typePrimRep1 (stgArgType arg)
 
 
 -----------------------------------------------------------------------------
@@ -292,8 +292,8 @@ might_be_a_function :: Type -> Bool
 -- Return False only if we are *sure* it's a data type
 -- Look through newtypes etc as much as poss
 might_be_a_function ty
-  | UnaryRep rep <- repType ty
-  , Just tc <- tyConAppTyCon_maybe rep
+  | [LiftedRep] <- typePrimRep ty
+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
   , isDataTyCon tc
   = False
   | otherwise
index 01c99ec..ba093fe 100644 (file)
@@ -193,7 +193,4 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg
 -- about accidental collision
 idToReg dflags (NonVoid id)
              = LocalReg (idUnique id)
-                        (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
-                                              _ -> primRepCmmType dflags (idPrimRep id))
-
-
+                        (primRepCmmType dflags (idPrimRep id))
index 8282f1e..9e1d7fa 100644 (file)
@@ -39,8 +39,8 @@ import ForeignCall
 import Id
 import PrimOp
 import TyCon
-import Type
-import RepType          ( isVoidTy, countConRepArgs )
+import Type             ( isUnliftedType )
+import RepType          ( isVoidTy, countConRepArgs, primRepSlot )
 import CostCentre       ( CostCentreStack, currentCCS )
 import Maybes
 import Util
@@ -49,6 +49,7 @@ import Outputable
 
 import Control.Monad (unless,void)
 import Control.Arrow (first)
+import Data.Function ( on )
 
 import Prelude hiding ((<*>))
 
@@ -402,14 +403,23 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
   = -- assignment suffices for unlifted types
     do { dflags <- getDynFlags
        ; unless reps_compatible $
-           panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+                    (pp_bndr v $$ pp_bndr bndr)
        ; v_info <- getCgIdInfo v
        ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
                     (idInfoToAmode v_info)
        ; bindArgToReg (NonVoid bndr)
        ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
   where
-    reps_compatible = idPrimRep v == idPrimRep bndr
+    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
+      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
+      -- the types of the binders are generated from slotPrimRep and might not
+      -- match. Test case:
+      --   swap :: (# Int | Int #) -> (# Int | Int #)
+      --   swap (# x | #) = (# | x #)
+      --   swap (# | y #) = (# y | #)
+
+    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
 
 {- Note [Dodgy unsafeCoerce 2, #3132]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index d12eaaf..2e3ed39 100644 (file)
@@ -525,16 +525,16 @@ getFCallArgs args
   = do  { mb_cmms <- mapM get args
         ; return (catMaybes mb_cmms) }
   where
-    get arg | isVoidRep arg_rep
+    get arg | null arg_reps
             = return Nothing
             | otherwise
             = do { cmm <- getArgAmode (NonVoid arg)
                  ; dflags <- getDynFlags
                  ; return (Just (add_shim dflags arg_ty cmm, hint)) }
             where
-              arg_ty  = stgArgType arg
-              arg_rep = typePrimRep arg_ty
-              hint    = typeForeignHint arg_ty
+              arg_ty   = stgArgType arg
+              arg_reps = typePrimRep arg_ty
+              hint     = typeForeignHint arg_ty
 
 add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
 add_shim dflags arg_ty expr
@@ -549,6 +549,5 @@ add_shim dflags arg_ty expr
 
   | otherwise = expr
   where
-    UnaryRep rep_ty = repType arg_ty
-    tycon           = tyConAppTyCon rep_ty
+    tycon           = tyConAppTyCon (unwrapType arg_ty)
         -- should be a tycon app, since this is a foreign call
index dedc114..4a976e6 100644 (file)
@@ -362,11 +362,11 @@ newUnboxedTupleRegs res_ty
         ; sequel <- getSequel
         ; regs <- choose_regs dflags sequel
         ; ASSERT( regs `equalLength` reps )
-          return (regs, map slotForeignHint reps) }
+          return (regs, map primRepForeignHint reps) }
   where
-    MultiRep reps = repType res_ty
+    reps = typePrimRep res_ty
     choose_regs _ (AssignTo regs _) = return regs
-    choose_regs dflags _            = mapM (newTemp . slotCmmType dflags) reps
+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps
 
 
 
index e6b1f11..e5b4ebc 100644 (file)
@@ -987,6 +987,10 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
        = go n subst' ty' (EtaVar tv' : eis)
 
        | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
+       , not (isTypeLevPoly arg_ty)
+          -- See Note [Levity polymorphism invariants] in CoreSyn
+          -- See also test case typecheck/should_run/EtaExpandLevPoly
+
        , let (subst', eta_id') = freshEtaId n subst arg_ty
            -- Avoid free vars of the original expression
        = go (n-1) subst' res_ty (EtaVar eta_id' : eis)
@@ -1001,7 +1005,8 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
          go n subst ty' (EtaCo co : eis)
 
        | otherwise       -- We have an expression of arity > 0,
-                         -- but its type isn't a function.
+                         -- but its type isn't a function, or a binder
+                         -- is levity-polymorphic
        = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
          (getTCvInScope subst, reverse eis)
         -- This *can* legitmately happen:
@@ -1011,6 +1016,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
         -- with an explicit lambda having a non-function type
 
 
+
 --------------
 -- Avoiding unnecessary substitution; use short-cutting versions
 
index dd86ba5..f9e7f86 100644 (file)
@@ -795,6 +795,12 @@ lintCoreArg fun_ty (Type arg_ty)
 
 lintCoreArg fun_ty arg
   = do { arg_ty <- lintCoreExpr arg
+           -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (not (isTypeLevPoly arg_ty))
+           (text "Levity-polymorphic argument:" <+>
+             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
+          -- check for levity polymorphism first, because otherwise isUnliftedType panics
+
        ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
                 (mkLetAppMsg arg)
        ; lintValApp arg fun_ty arg_ty }
@@ -1028,10 +1034,9 @@ lintIdBndr top_lvl id linterF
            (mkNonTopExternalNameMsg id)
 
        ; (ty, k) <- lintInTy (idType id)
-
-       -- Check for levity polymorphism
-       ; lintL (not (isLevityPolymorphic k))
-           (text "RuntimeRep-polymorphic binder:" <+>
+          -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (not (isKindLevPoly k))
+           (text "Levity-polymorphic binder:" <+>
                  (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
 
        ; let id' = setIdType id ty
@@ -1085,7 +1090,7 @@ lintType ty@(TyConApp tc tys)
   = lintType ty'   -- Expand type synonyms, so that we do not bogusly complain
                    --  about un-saturated type synonyms
 
-  | isUnliftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
        -- Also type synonyms and type families
   , length tys < tyConArity tc
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
@@ -1128,7 +1133,7 @@ lintKind :: OutKind -> LintM ()
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
 lintKind k = do { sk <- lintType k
-                ; unless ((isStarKind sk) || (isUnliftedTypeKind sk))
+                ; unless (classifiesTypeWithValues sk)
                          (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
                                       2 (text "has kind:" <+> ppr sk))) }
 
@@ -1398,15 +1403,17 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
                      2 (vcat [ text "From:" <+> ppr ty1
                              , text "  To:" <+> ppr ty2])
      isUnBoxed :: PrimRep -> Bool
-     isUnBoxed PtrRep = False
-     isUnBoxed _      = True
+     isUnBoxed = not . isGcPtrRep
+
+       -- see #9122 for discussion of these checks
      checkTypes t1 t2
-       = case (repType t1, repType t2) of
-           (UnaryRep _, UnaryRep _) ->
-              validateCoercion (typePrimRep t1) (typePrimRep t2)
-           (MultiRep rep1, MultiRep rep2) ->
-              checkWarnL (rep1 == rep2) (report "multi values with different reps")
-           _  -> addWarnL (report "multi rep and unary rep")
+       = do { checkWarnL (reps1 `equalLength` reps2)
+                         (report "values with different # of reps")
+            ; zipWithM_ validateCoercion reps1 reps2 }
+       where
+         reps1 = typePrimRep t1
+         reps2 = typePrimRep t2
+
      validateCoercion :: PrimRep -> PrimRep -> LintM ()
      validateCoercion rep1 rep2
        = do { dflags <- getDynFlags
index 73be490..d98536c 100644 (file)
@@ -502,7 +502,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
 
     old_ty = idType old_id
     no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
-                     isEmptyVarSet (tyCoVarsOfType old_ty)
+                     noFreeVarsOfType old_ty
 
         -- new_id has the right IdInfo
         -- The lazy-set is because we're in a loop here, with
@@ -622,7 +622,7 @@ substCo subst co = Coercion.substCo (getTCvSubst subst) co
 
 substIdType :: Subst -> Id -> Id
 substIdType subst@(Subst _ _ tv_env cv_env) id
-  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (tyCoVarsOfType old_ty) = id
+  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id
   | otherwise   = setIdType id (substTy subst old_ty)
                 -- The tyCoVarsOfType is cheaper than it looks
                 -- because we cache the free tyvars of the type
@@ -1058,7 +1058,12 @@ maybe_substitute subst b r
   , isAlwaysActive (idInlineActivation b)       -- Note [Inline prag in simplOpt]
   , not (isStableUnfolding (idUnfolding b))
   , not (isExportedId b)
-  , not (isUnliftedType (idType b)) || exprOkForSpeculation r
+  , let id_ty = idType b
+     -- A levity-polymorphic id? Impossible you say?
+     -- See Note [Levity polymorphism invariants] in CoreSyn
+     -- Ah, but it *is* possible in the compulsory unfolding of unsafeCoerce#
+     -- This check prevents the isUnliftedType check from panicking.
+  , isTypeLevPoly id_ty || not (isUnliftedType (idType b)) || exprOkForSpeculation r
   = Just (extendIdSubst subst b r)
 
   | otherwise
index 317a78d..fd0cf3e 100644 (file)
@@ -404,6 +404,9 @@ For example
   \(r::RuntimeRep). \(a::TYPE r). \(x::a). e
 is illegal because x's type has kind (TYPE r), which has 'r' free.
 
+See Note [Levity polymorphism checking] in DsMonad to see where these
+invariants are established for user-written code.
+
 Note [CoreSyn let goal]
 ~~~~~~~~~~~~~~~~~~~~~~~
 * The simplifier tries to ensure that if the RHS of a let is a constructor
index 6373307..84f3a93 100644 (file)
@@ -22,7 +22,7 @@ module CoreUtils (
         filterAlts, combineIdenticalAlts, refineDefaultAlt,
 
         -- * Properties of expressions
-        exprType, coreAltType, coreAltsType,
+        exprType, coreAltType, coreAltsType, isExprLevPoly,
         exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
         getIdFromTrivialExpr_maybe,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
@@ -130,6 +130,45 @@ coreAltsType :: [CoreAlt] -> Type
 coreAltsType (alt:_) = coreAltType alt
 coreAltsType []      = panic "corAltsType"
 
+-- | Is this expression levity polymorphic? This should be the
+-- same as saying (isKindLevPoly . typeKind . exprType) but
+-- much faster.
+isExprLevPoly :: CoreExpr -> Bool
+isExprLevPoly = go
+  where
+   go (Var _)                      = False  -- no levity-polymorphic binders
+   go (Lit _)                      = False  -- no levity-polymorphic literals
+   go e@(App f _) | not (go_app f) = False
+                  | otherwise      = check_type e
+   go (Lam _ _)                    = False
+   go (Let _ e)                    = go e
+   go e@(Case {})                  = check_type e -- checking type is fast
+   go e@(Cast {})                  = check_type e
+   go (Tick _ e)                   = go e
+   go e@(Type {})                  = pprPanic "isExprLevPoly ty" (ppr e)
+   go (Coercion {})                = False  -- this case can happen in SetLevels
+
+   check_type = isTypeLevPoly . exprType  -- slow approach
+
+      -- if the function is a variable (common case), check its
+      -- levityInfo. This might mean we don't need to look up and compute
+      -- on the type. Spec of these functions: return False if there is
+      -- no possibility, ever, of this expression becoming levity polymorphic,
+      -- no matter what it's applied to; return True otherwise.
+      -- returning True is always safe. See also Note [Levity info] in
+      -- IdInfo
+   go_app (Var id)        = not (isNeverLevPolyId id)
+   go_app (Lit _)         = False
+   go_app (App f _)       = go_app f
+   go_app (Lam _ e)       = go_app e
+   go_app (Let _ e)       = go_app e
+   go_app (Case _ _ ty _) = resultIsLevPoly ty
+   go_app (Cast _ co)     = resultIsLevPoly (pSnd $ coercionKind co)
+   go_app (Tick _ e)      = go_app e
+   go_app e@(Type {})     = pprPanic "isExprLevPoly app ty" (ppr e)
+   go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)
+
+
 {-
 Note [Type bindings]
 ~~~~~~~~~~~~~~~~~~~~
@@ -1841,6 +1880,7 @@ diffIdInfo env bndr1 bndr2
     && occInfo info1 == occInfo info2
     && demandInfo info1 == demandInfo info2
     && callArityInfo info1 == callArityInfo info2
+    && levityInfo info1 == levityInfo info2
   = locBind "in unfolding of" bndr1 bndr2 $
     diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)
   | otherwise
index f670ae3..882faa7 100644 (file)
@@ -172,7 +172,7 @@ mk_val_app fun arg arg_ty res_ty
         -- game, mk_val_app returns an expression that does not have
         -- have a free wild-id.  So the only thing that can go wrong
         -- is if you take apart this case expression, and pass a
-        -- fragmet of it as the fun part of a 'mk_val_app'.
+        -- fragment of it as the fun part of a 'mk_val_app'.
 
 -----------
 mkWildEvBinder :: PredType -> EvVar
@@ -757,4 +757,3 @@ Notice the runtime-representation polymorphism. This ensures that
 "error" can be instantiated at unboxed as well as boxed types.
 This is OK because it never returns, so the return type is irrelevant.
 -}
-
index 5394697..152a701 100644 (file)
@@ -6,6 +6,7 @@
 Printing of Core syntax
 -}
 
+{-# LANGUAGE MultiWayIf #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PprCore (
         pprCoreExpr, pprParendExpr,
index 1f6effa..7faf8fb 100644 (file)
@@ -21,6 +21,7 @@ import HsSyn
 import Module
 import Outputable
 import DynFlags
+import ConLike
 import Control.Monad
 import SrcLoc
 import ErrUtils
@@ -509,6 +510,8 @@ addBinTickLHsExpr boxLabel (L pos e0)
 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
 addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
 addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut con)
+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
 addTickHsExpr e@(HsIPVar _)      = return e
 addTickHsExpr e@(HsOverLit _)    = return e
 addTickHsExpr e@(HsOverLabel _)  = return e
index 93af69b..f686b68 100644 (file)
@@ -25,9 +25,10 @@ import qualified HsUtils
 --     So WATCH OUT; check each use of split*Ty functions.
 -- Sigh.  This is a pain.
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import TcType
+import Type ( splitPiTy )
 import TcEvidence
 import CoreSyn
 import CoreFVs
@@ -38,7 +39,7 @@ import DsBinds (dsHsWrapper)
 import Name
 import Var
 import Id
-import DataCon
+import ConLike
 import TysWiredIn
 import BasicTypes
 import PrelNames
@@ -46,7 +47,7 @@ import Outputable
 import Bag
 import VarSet
 import SrcLoc
-import ListSetOps( assocDefault )
+import ListSetOps( assocMaybe )
 import Data.List
 import Util
 import UniqDFM
@@ -59,23 +60,67 @@ mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
 -- See Note [CmdSyntaxTable] in HsExpr
 mkCmdEnv tc_meths
   = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
+
+       -- NB: Some of these lookups might fail, but that's OK if the
+       -- symbol is never used. That's why we use Maybe first and then
+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
+       ; let the_arr_id     = assocMaybe prs arrAName
+             the_compose_id = assocMaybe prs composeAName
+             the_first_id   = assocMaybe prs firstAName
+             the_app_id     = assocMaybe prs appAName
+             the_choice_id  = assocMaybe prs choiceAName
+             the_loop_id    = assocMaybe prs loopAName
+
+           -- used as an argument in, e.g., do_premap
+       ; check_lev_poly 3 the_arr_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 5 the_compose_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 4 the_first_id
+
+           -- the result of the_app_id is used as an argument in, e.g.,
+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp
+       ; check_lev_poly 2 the_app_id
+
+           -- used as an argument in, e.g., HsCmdIf
+       ; check_lev_poly 5 the_choice_id
+
+           -- used as an argument in, e.g., RecStmt
+       ; check_lev_poly 4 the_loop_id
+
        ; return (meth_binds, DsCmdEnv {
-               arr_id     = Var (find_meth prs arrAName),
-               compose_id = Var (find_meth prs composeAName),
-               first_id   = Var (find_meth prs firstAName),
-               app_id     = Var (find_meth prs appAName),
-               choice_id  = Var (find_meth prs choiceAName),
-               loop_id    = Var (find_meth prs loopAName)
+               arr_id     = Var (unmaybe the_arr_id arrAName),
+               compose_id = Var (unmaybe the_compose_id composeAName),
+               first_id   = Var (unmaybe the_first_id firstAName),
+               app_id     = Var (unmaybe the_app_id appAName),
+               choice_id  = Var (unmaybe the_choice_id choiceAName),
+               loop_id    = Var (unmaybe the_loop_id loopAName)
              }) }
   where
     mk_bind (std_name, expr)
       = do { rhs <- dsExpr expr
-           ; id <- newSysLocalDs (exprType rhs)
+           ; id <- newSysLocalDs (exprType rhs)  -- no check needed; these are functions
            ; return (NonRec id rhs, (std_name, id)) }
 
-    find_meth prs std_name
-      = assocDefault (mk_panic std_name) prs std_name
-    mk_panic std_name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr std_name)
+    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
+    unmaybe (Just id) _  = id
+
+      -- returns the result type of a pi-type (that is, a forall or a function)
+      -- Note that this result type may be ill-scoped.
+    res_type :: Type -> Type
+    res_type ty = res_ty
+      where
+        (_, res_ty) = splitPiTy ty
+
+    check_lev_poly :: Int -- arity
+                   -> Maybe Id -> DsM ()
+    check_lev_poly _     Nothing = return ()
+    check_lev_poly arity (Just id)
+      = dsNoLevPoly (nTimes arity res_type (idType id))
+          (text "In the result of the function" <+> quotes (ppr id))
+
 
 -- arr :: forall b c. (b -> c) -> a b c
 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
@@ -320,7 +365,7 @@ dsCmd ids local_vars stack_ty res_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-    core_arrow <- dsLExpr arrow
+    core_arrow <- dsLExprNoLP arrow
     core_arg   <- dsLExpr arg
     stack_id   <- newSysLocalDs stack_ty
     core_make_arg <- matchEnvStack env_ids stack_id core_arg
@@ -376,7 +421,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
     (core_cmd, free_vars, env_ids')
              <- dsfixCmd ids local_vars stack_ty' res_ty cmd
     stack_id <- newSysLocalDs stack_ty
-    arg_id <- newSysLocalDs arg_ty
+    arg_id <- newSysLocalDsNoLP arg_ty
     -- push the argument expression onto the stack
     let
         stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
@@ -409,7 +454,7 @@ dsCmd ids local_vars stack_ty res_ty
         local_vars' = pat_vars `unionVarSet` local_vars
         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
     (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body
-    param_ids <- mapM newSysLocalDs pat_tys
+    param_ids <- mapM newSysLocalDsNoLP pat_tys
     stack_id' <- newSysLocalDs stack_ty'
 
     -- the expression is built from the inside out, so the actions
@@ -527,8 +572,8 @@ dsCmd ids local_vars stack_ty res_ty
     left_con <- dsLookupDataCon leftDataConName
     right_con <- dsLookupDataCon rightDataConName
     let
-        left_id  = HsVar (noLoc (dataConWrapId left_con))
-        right_id = HsVar (noLoc (dataConWrapId right_con))
+        left_id  = HsConLikeOut (RealDataCon left_con)
+        right_id = HsConLikeOut (RealDataCon right_con)
         left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
         right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
 
@@ -565,7 +610,7 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
@@ -573,7 +618,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
     (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
     stack_id <- newSysLocalDs stack_ty
     -- build a new environment, plus the stack, using the let bindings
-    core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id)
+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
     -- match the old environment and stack against the input
     core_map <- matchEnvStack env_ids stack_id core_binds
     return (do_premap ids
@@ -590,7 +635,10 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
 --
 --              ---> premap (\ (env,stk) -> env) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+    putSrcSpanDs loc $
+      dsNoLevPoly stmts_ty
+        (text "In the do-command:" <+> ppr do_block)
     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
     let env_ty = mkBigCoreVarTupTy env_ids
     core_fst <- mkFstExpr env_ty stack_ty
@@ -656,7 +704,9 @@ dsfixCmd
                 DIdSet,         -- subset of local vars that occur free
                 [Id])           -- the same local vars as a list, fed back
 dsfixCmd ids local_vars stk_ty cmd_ty cmd
-  = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
+           (text "When desugaring the command:" <+> ppr cmd)
+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
 
 -- Feed back the list of local variables actually used a command,
 -- for use as the input tuple of the generated arrow.
@@ -697,7 +747,9 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 --
 --              ---> premap (\ (xs) -> ((xs), ())) c
 
-dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do
+dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do
+    putSrcSpanDs loc $ dsNoLevPoly res_ty
+                         (text "In the command:" <+> ppr body)
     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
     let env_ty = mkBigCoreVarTupTy env_ids
     env_var <- newSysLocalDs env_ty
@@ -765,6 +817,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
         out_ty = mkBigCoreVarTupTy out_ids
         before_c_ty = mkCorePairTy in_ty1 out_ty
         after_c_ty = mkCorePairTy c_ty out_ty
+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
     snd_fn <- mkSndExpr c_ty out_ty
     return (do_premap ids in_ty before_c_ty out_ty core_mux $
                 do_compose ids before_c_ty after_c_ty out_ty
@@ -834,7 +887,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
 --
 --              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
 
-dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do
+dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
     -- build a new environment using the let bindings
     core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
     -- match the old environment against the input
@@ -1004,6 +1057,8 @@ dsfixCmdStmts
 
 dsfixCmdStmts ids local_vars out_ids stmts
   = trimInput (dsCmdStmts ids local_vars out_ids stmts)
+   -- TODO: Add levity polymorphism check for the resulting expression.
+   -- But I (Richard E.) don't know enough about arrows to do so.
 
 dsCmdStmts
         :: DsCmdEnv             -- arrow combinators
index 833d357..ae18ffd 100644 (file)
@@ -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)
index d7cba65..b90dd80 100644 (file)
@@ -84,6 +84,7 @@ follows:
 
 dsCCall :: CLabelString -- C routine to invoke
         -> [CoreExpr]   -- Arguments (desugared)
+                        -- Precondition: none have levity-polymorphic types
         -> Safety       -- Safety of the call
         -> Type         -- Type of the result: IO t
         -> DsM CoreExpr -- Result, of type ???
@@ -122,7 +123,7 @@ mkFCall dflags uniq the_fcall val_args res_ty
     ty      = mkInvForAllTys tyvars body_ty
     the_fcall_id = mkFCallId dflags uniq the_fcall ty
 
-unboxArg :: CoreExpr                    -- The supplied argument
+unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic
          -> DsM (CoreExpr,              -- To pass as the actual argument
                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                 )
@@ -130,6 +131,8 @@ unboxArg :: CoreExpr                    -- The supplied argument
 --      (x#::Int#, \W. case x of I# x# -> W)
 -- where W is a CoreExpr that probably mentions x#
 
+-- always returns a non-levity-polymorphic expression
+
 unboxArg arg
   -- Primtive types: nothing to unbox
   | isPrimitiveType arg_ty
index 8025c69..575b510 100644 (file)
@@ -6,9 +6,9 @@
 Desugaring exporessions.
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, MultiWayIf #-}
 
-module DsExpr ( dsExpr, dsLExpr, dsLocalBinds
+module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
               , dsValBinds, dsLit, dsSyntaxExpr ) where
 
 #include "HsVersions.h"
@@ -41,6 +41,7 @@ import MkCore
 import DynFlags
 import CostCentre
 import Id
+import MkId
 import Module
 import ConLike
 import DataCon
@@ -65,12 +66,14 @@ import Control.Monad
 ************************************************************************
 -}
 
-dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
-dsLocalBinds EmptyLocalBinds    body = return body
-dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
-dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
+dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds (L _   EmptyLocalBinds)    body = return body
+dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
+                                               dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
 
 -------------------------
+-- caller sets location
 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
 dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
@@ -89,25 +92,72 @@ dsIPBinds (IPBinds ip_binds ev_binds) body
            return (Let (NonRec n e') body)
 
 -------------------------
+-- caller sets location
 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 -- Special case for bindings which bind unlifted variables
 -- We need to do a case right away, rather than building
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [L loc bind] <- bagToList hsbinds,
+  | [L loc bind] <- bagToList hsbinds
         -- Non-recursive, non-overloaded bindings only come in ones
         -- 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.)
-    unliftedMatchOnly bind
-  = putSrcSpanDs loc (dsUnliftedBind bind body)
+  , isUnliftedHsBind bind
+  = putSrcSpanDs loc $
+     -- see Note [Strict binds checks] in DsBinds
+    if is_polymorphic bind
+    then errDsCoreExpr (poly_bind_err bind)
+            -- data Ptr a = Ptr Addr#
+            -- f x = let p@(Ptr y) = ... in ...
+            -- Here the binding for 'p' is polymorphic, but does
+            -- not mix with an unlifted binding for 'y'.  You should
+            -- use a bang pattern.  Trac #6078.
+
+    else do { when (looksLazyPatBind bind) $
+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
+        -- Complain about a binding that looks lazy
+        --    e.g.    let I# y = x in ...
+        -- Remember, in checkStrictBinds we are going to do strict
+        -- matching, so (for software engineering reasons) we insist
+        -- that the strictness is manifest on each binding
+        -- However, lone (unboxed) variables are ok
+
+
+            ; dsUnliftedBind bind body }
+  where
+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
+                     = not (null tvs && null evs)
+    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
+                     = not (null tvs && null evs)
+    is_polymorphic _ = False
+
+    unlifted_must_be_bang bind
+      = hang (text "Pattern bindings containing unlifted types should use" $$
+              text "an outermost bang pattern:")
+           2 (ppr bind)
+
+    poly_bind_err bind
+      = hang (text "You can't mix polymorphic and unlifted bindings:")
+           2 (ppr bind) $$
+        text "Probable fix: add a type signature"
+
+ds_val_bind (is_rec, binds) _body
+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
+  = ASSERT( isRec is_rec )
+    errDsCoreExpr $
+    hang (text "Recursive bindings for unlifted types aren't allowed:")
+       2 (vcat (map ppr (bagToList binds)))
 
 -- Ordinary case for bindings; none should be unlifted
-ds_val_bind (_is_rec, binds) body
-  = do  { (force_vars,prs) <- dsLHsBinds binds
+ds_val_bind (is_rec, binds) body
+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
+               -- we should never produce a non-recursive list of multiple binds
+
+        ; (force_vars,prs) <- dsLHsBinds binds
         ; let body' = foldr seqVar body force_vars
-        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
           case prs of
             [] -> return body
             _  -> return (Let (Rec prs) body') }
@@ -170,20 +220,6 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
 
 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
-----------------------
-unliftedMatchOnly :: HsBind Id -> Bool
-unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
-  = anyBag (unliftedMatchOnly . unLoc) lbinds
-unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
-  = unliftedMatchOnly bind
-unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
-  =  isUnliftedType rhs_ty
-  || isUnliftedLPat lpat
-  || any (isUnliftedType . idType) (collectPatBinders lpat)
-unliftedMatchOnly (FunBind { fun_id = L _ id })
-  = isUnliftedType (idType id)
-unliftedMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
-
 {-
 ************************************************************************
 *                                                                      *
@@ -194,7 +230,26 @@ unliftedMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 
-dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
+dsLExpr (L loc e)
+  = putSrcSpanDs loc $
+    do { core_expr <- dsExpr e
+   -- uncomment this check to test the hsExprType function in TcHsSyn
+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
+       ; return core_expr }
+
+-- | Variant of 'dsLExpr' that ensures that the result is not levity
+-- polymorphic. This should be used when the resulting expression will
+-- be an argument to some other function.
+-- See Note [Levity polymorphism checking] in DsMonad
+-- See Note [Levity polymorphism invariants] in CoreSyn
+dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
+dsLExprNoLP (L loc e)
+  = putSrcSpanDs loc $
+    do { e' <- dsExpr e
+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
+       ; return e' }
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
@@ -202,6 +257,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
                                 -- See Note [Desugaring vars]
 dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
+dsExpr (HsConLikeOut con)     = return (dsConLike con)
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
 dsExpr (HsOverLabel _)        = panic "dsExpr: HsOverLabel"
 dsExpr (HsLit lit)            = dsLit lit
@@ -227,7 +283,7 @@ dsExpr (HsLamCase matches)
        ; return $ Lam discrim_var matching_code }
 
 dsExpr e@(HsApp fun arg)
-  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
+  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg
 
 dsExpr (HsAppTypeOut e _)
     -- ignore type arguments here; they're in the wrappers instead at this point
@@ -275,10 +331,10 @@ will sort it out.
 
 dsExpr e@(OpApp e1 op _ e2)
   = -- for the type of y, we need the type of op's 2nd argument
-    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2]
 
 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
-  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
+  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 dsExpr e@(SectionR op expr) = do
@@ -287,8 +343,8 @@ dsExpr e@(SectionR op expr) = do
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
         -- See comment with SectionL
     y_core <- dsLExpr expr
-    x_id <- newSysLocalDs x_ty
-    y_id <- newSysLocalDs y_ty
+    x_id <- newSysLocalDsNoLP x_ty
+    y_id <- newSysLocalDsNoLP y_ty
     return (bindNonRec y_id y_core $
             Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
 
@@ -296,7 +352,7 @@ dsExpr (ExplicitTuple tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
                     -- For every missing expression, we need
                     -- another lambda in the desugaring.
-               = do { lam_var <- newSysLocalDs ty
+               = do { lam_var <- newSysLocalDsNoLP ty
                     ; return (lam_var : lam_vars, Var lam_var : args) }
              go (lam_vars, args) (L _ (Present expr))
                     -- Expressions that are present don't generate
@@ -338,7 +394,7 @@ dsExpr (HsCase discrim matches)
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
-dsExpr (HsLet (L _ binds) body) = do
+dsExpr (HsLet binds body) = do
     body' <- dsLExpr body
     dsLocalBinds binds body'
 
@@ -391,7 +447,7 @@ dsExpr (ExplicitPArr ty []) = do
 dsExpr (ExplicitPArr ty xs) = do
     singletonP <- dsDPHBuiltin singletonPVar
     appP       <- dsDPHBuiltin appPVar
-    xs'        <- mapM dsLExpr xs
+    xs'        <- mapM dsLExprNoLP xs
     let unary  fn x   = mkApps (Var fn) [Type ty, x]
         binary fn x y = mkApps (Var fn) [Type ty, x, y]
 
@@ -404,10 +460,10 @@ dsExpr (ArithSeq expr witness seq)
                    ; dsSyntaxExpr fl [newArithSeq] }
 
 dsExpr (PArrSeq expr (FromTo from to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
 
 dsExpr (PArrSeq expr (FromThenTo from thn to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
 
 dsExpr (PArrSeq _ _)
   = panic "DsExpr.dsExpr: Infinite parallel array!"
@@ -426,7 +482,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview.
 -}
 
 dsExpr (HsStatic _ expr@(L loc _)) = do
-    expr_ds <- dsLExpr expr
+    expr_ds <- dsLExprNoLP expr
     let ty = exprType expr_ds
     makeStaticId <- dsLookupGlobalId makeStaticName
 
@@ -478,7 +534,7 @@ dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
              mk_arg (arg_ty, fl)
                = case findField (rec_flds rbinds) (flSelector fl) of
                    (rhs:rhss) -> ASSERT( null rhss )
-                                 dsLExpr rhs
+                                 dsLExprNoLP rhs
                    []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
              unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
 
@@ -592,10 +648,8 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                                          field_labels arg_ids
                  mk_val_arg fl pat_arg_id
                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
-                 -- SAFE: the typechecker will complain if the synonym is
-                 -- not bidirectional
-                 wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con)
-                 inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id))
+
+                 inst_con = noLoc $ HsWrap wrap (HsConLikeOut con)
                         -- Reconstruct with the WrapId so that unpacking happens
                  -- The order here is because of the order in `TcPatSyn`.
                  wrap = mkWpEvVarApps theta_vars                                <.>
@@ -702,7 +756,10 @@ dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
        ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]
        ; return (core_res_wrap (mkApps fun wrapped_args)) }
+  where
+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
 
 findField :: [LHsRecField Id arg] -> Name -> [arg]
 findField rbinds sel
@@ -774,7 +831,7 @@ dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
 -- See Note [Desugaring explicit lists]
 dsExplicitList elt_ty Nothing xs
   = do { dflags <- getDynFlags
-       ; xs' <- mapM dsLExpr xs
+       ; xs' <- mapM dsLExprNoLP xs
        ; if length xs' > maxBuildLength
                 -- Don't generate builds if the list is very long.
          || length xs' == 0
@@ -795,23 +852,23 @@ dsExplicitList elt_ty (Just fln) xs
 
 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
 dsArithSeq expr (From from)
-  = App <$> dsExpr expr <*> dsLExpr from
+  = App <$> dsExpr expr <*> dsLExprNoLP from
 dsArithSeq expr (FromTo from to)
   = do dflags <- getDynFlags
        warnAboutEmptyEnumerations dflags from Nothing to
        expr' <- dsExpr expr
-       from' <- dsLExpr from
-       to'   <- dsLExpr to
+       from' <- dsLExprNoLP from
+       to'   <- dsLExprNoLP to
        return $ mkApps expr' [from', to']
 dsArithSeq expr (FromThen from thn)
-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
 dsArithSeq expr (FromThenTo from thn to)
   = do dflags <- getDynFlags
        warnAboutEmptyEnumerations dflags from (Just thn) to
        expr' <- dsExpr expr
-       from' <- dsLExpr from
-       thn'  <- dsLExpr thn
-       to'   <- dsLExpr to
+       from' <- dsLExprNoLP from
+       thn'  <- dsLExprNoLP thn
+       to'   <- dsLExprNoLP to
        return $ mkApps expr' [from', thn', to']
 
 {-
@@ -837,7 +894,7 @@ dsDo stmts
            ; rest <- goL stmts
            ; dsSyntaxExpr then_expr [rhs2, rest] }
 
-    go _ (LetStmt (L _ binds)) stmts
+    go _ (LetStmt binds) stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
@@ -935,6 +992,22 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
 {-
 ************************************************************************
 *                                                                      *
+   Desugaring ConLikes
+*                                                                      *
+************************************************************************
+-}
+
+dsConLike :: ConLike -> CoreExpr
+dsConLike (RealDataCon dc) = Var (dataConWrapId dc)
+dsConLike (PatSynCon ps) = case patSynBuilder ps of
+  Just (id, add_void)
+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+    | otherwise -> Var id
+  _ -> pprPanic "dsConLike" (ppr ps)
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Errors and contexts}
 *                                                                      *
 ************************************************************************
index cc8b7ea..864df83 100644 (file)
@@ -1,10 +1,10 @@
 module DsExpr where
-import HsSyn    ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr )
+import HsSyn    ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
 import Var      ( Id )
 import DsMonad  ( DsM )
 import CoreSyn  ( CoreExpr )
 
 dsExpr  :: HsExpr  Id -> DsM CoreExpr
-dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
 dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
-dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
index dc084ee..9998a4d 100644 (file)
@@ -200,7 +200,7 @@ dsFCall fn_id co fcall mDeclHeader = do
         (tv_bndrs, rho)      = tcSplitForAllTyVarBndrs ty
         (arg_tys, io_res_ty) = tcSplitFunTys rho
 
-    args <- newSysLocalsDs arg_tys
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
 
     let
@@ -300,7 +300,7 @@ dsPrimCall fn_id co fcall = do
         (tvs, fun_ty)        = tcSplitForAllTys ty
         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
 
-    args <- newSysLocalsDs arg_tys
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
 
     ccall_uniq <- newUnique
     dflags <- getDynFlags
@@ -724,8 +724,7 @@ toCType = f False
 
 typeTyCon :: Type -> TyCon
 typeTyCon ty
-  | UnaryRep rep_ty <- repType ty
-  , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
   = tc
   | otherwise
   = pprPanic "DsForeign.typeTyCon" (ppr ty)
@@ -784,7 +783,7 @@ getPrimTyOf ty
         prim_ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
   where
-        UnaryRep rep_ty = repType ty
+        rep_ty = unwrapType ty
 
 -- represent a primitive type as a Char, for building a string that
 -- described the foreign function type.  The types are size-dependent,
@@ -793,7 +792,7 @@ primTyDescChar :: DynFlags -> Type -> Char
 primTyDescChar dflags ty
  | ty `eqType` unitTy = 'v'
  | otherwise
- = case typePrimRep (getPrimTyOf ty) of
+ = case typePrimRep1 (getPrimTyOf ty) of
      IntRep      -> signed_word
      WordRep     -> unsigned_word
      Int64Rep    -> 'L'
index 0c34bc2..0a66bd0 100644 (file)
@@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchCon
         -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
-dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty
+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty
   = ASSERT( notNull grhss )
     do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
        ; let match_result1 = foldr1 combineMatchResults match_results
@@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
     pred_expr <- dsLExpr expr
     return (mkGuardedMatchResult pred_expr match_result)
 
-matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do
+matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs (dsLocalBinds binds) match_result)
         -- NB the dsLet occurs inside the match_result
@@ -138,6 +138,7 @@ isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey
                                     || v `hasKey` getUnique trueDataConId
                                             = Just return
         -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
 isTrueLHsExpr (L _ (HsTick tickish e))
     | Just ticks <- isTrueLHsExpr e
     = Just (\x -> do wrapped <- ticks x
index 45320cc..2bb303e 100644 (file)
@@ -12,7 +12,7 @@ module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import HsSyn
 import TcHsSyn
@@ -81,10 +81,10 @@ dsListComp lquals res_ty = do
 dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
 dsInnerListComp (ParStmtBlock stmts bndrs _)
   = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
+             list_ty          = mkListTy bndrs_tuple_type
 
              -- really use original bndrs below!
-       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)])
-                            (mkListTy bndrs_tuple_type)
+       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
 
        ; return (expr, bndrs_tuple_type) }
 
@@ -135,6 +135,9 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
                 , Var unzip_fn'
                 , inner_list_expr' ]
 
+    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
+      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
+
     -- Build a pattern that ensures the consumer binds into the NEW binders,
     -- which hold lists rather than single values
     let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!
@@ -225,7 +228,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above
     return (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt (L _ binds) : quals) list = do
+deListComp (LetStmt binds : quals) list = do
     core_rest <- deListComp quals list
     dsLocalBinds binds core_rest
 
@@ -234,7 +237,7 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
     deBindComp pat inner_list_expr quals list
 
 deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above
-    core_list1 <- dsLExpr list1
+    core_list1 <- dsLExprNoLP list1
     deBindComp pat core_list1 quals core_list2
 
 deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
@@ -272,6 +275,8 @@ deBindComp pat core_list1 quals core_list2 = do
     let res_ty = exprType core_list2
         h_ty   = u1_ty `mkFunTy` res_ty
 
+       -- no levity polymorphism here, as list comprehensions don't work
+       -- with RebindableSyntax. NB: These are *not* monad comps.
     [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 
     -- the "fail" value ...
@@ -320,7 +325,7 @@ dfListComp _ _ [] = panic "dfListComp"
 
 dfListComp c_id n_id (LastStmt body _ _ : quals)
   = ASSERT( null quals )
-    do { core_body <- dsLExpr body
+    do { core_body <- dsLExprNoLP body
        ; return (mkApps (Var c_id) [core_body, Var n_id]) }
 
         -- Non-last: must be a guard
@@ -329,7 +334,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do
     core_rest <- dfListComp c_id n_id quals
     return (mkIfThenElse core_guard core_rest (Var n_id))
 
-dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do
+dfListComp c_id n_id (LetStmt binds : quals) = do
     -- new in 1.3, local bindings
     core_rest <- dfListComp c_id n_id quals
     dsLocalBinds binds core_rest
@@ -361,7 +366,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do
     let b_ty   = idType n_id
 
     -- create some new local id's
-    [b, x] <- newSysLocalsDs [b_ty, x_ty]
+    b <- newSysLocalDs b_ty
+    x <- newSysLocalDs x_ty
 
     -- build rest of the comprehesion
     core_rest <- dfListComp c_id b quals
@@ -489,7 +495,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
 --
 dsPArrComp (BindStmt p e _ _ _ : qs) = do
     filterP <- dsDPHBuiltin filterPVar
-    ce <- dsLExpr e
+    ce <- dsLExprNoLP e
     let ety'ce  = parrElemType ce
         false   = Var falseDataConId
         true    = Var trueDataConId
@@ -571,12 +577,12 @@ dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
 --  where
 --    {x_1, ..., x_n} = DV (ds)         -- Defined Variables
 --
-dePArrComp (LetStmt (L _ ds) : qs) pa cea = do
+dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do
     mapP <- dsDPHBuiltin mapPVar
     let xs = collectLocalBinders ds
         ty'cea = parrElemType cea
     v <- newSysLocalDs ty'cea
-    clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
+    clet <- dsLocalBinds lds (mkCoreTup (map Var xs))
     let'v <- newSysLocalDs (exprType clet)
     let projBody = mkCoreLet (NonRec let'v clet) $
                    mkCoreTup [Var v, Var let'v]
@@ -632,7 +638,7 @@ dePArrParComp qss quals = do
 
 -- generate Core corresponding to `\p -> e'
 --
-deLambda :: Type                       -- type of the argument
+deLambda :: Type                       -- type of the argument (not levity-polymorphic)
          -> LPat Id                    -- argument pattern
          -> LHsExpr Id                 -- body
          -> DsM (CoreExpr, Type)
@@ -641,7 +647,7 @@ deLambda ty p e =
 
 -- generate Core for a lambda pattern match, where the body is already in Core
 --
-mkLambda :: Type                        -- type of the argument
+mkLambda :: Type                        -- type of the argument (not levity-polymorphic)
          -> LPat Id                     -- argument pattern
          -> CoreExpr                    -- desugared body
          -> DsM (CoreExpr, Type)
@@ -682,7 +688,7 @@ dsMcStmt (LastStmt body _ ret_op) stmts
        ; dsSyntaxExpr ret_op [body'] }
 
 --   [ .. | let binds, stmts ]
-dsMcStmt (LetStmt (L _ binds)) stmts
+dsMcStmt (LetStmt binds) stmts
   = do { rest <- dsMcStmts stmts
        ; dsLocalBinds binds rest }
 
@@ -743,7 +749,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
        ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
 
        ; body        <- dsMcStmts stmts_rest
-       ; n_tup_var'  <- newSysLocalDs n_tup_ty'
+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'
        ; tup_n_var'  <- newSysLocalDs tup_n_ty'
        ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
        ; us          <- newUniqueSupply
@@ -841,6 +847,7 @@ dsInnerMonadComp :: [ExprLStmt Id]
 dsInnerMonadComp stmts bndrs ret_op
   = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
 
+
 -- The `unzip` function for `GroupStmt` in a monad comprehensions
 --
 --   unzip :: m (a,b,..) -> (m a,m b,..)
@@ -855,7 +862,7 @@ dsInnerMonadComp stmts bndrs ret_op
 mkMcUnzipM :: TransForm
            -> HsExpr TcId       -- fmap
            -> Id                -- Of type n (a,b,c)
-           -> [Type]            -- [a,b,c]
+           -> [Type]            -- [a,b,c]   (not levity-polymorphic)
            -> DsM CoreExpr      -- Of type (n a, n b, n c)
 mkMcUnzipM ThenForm _ ys _
   = return (Var ys) -- No unzipping to do
index d46aeaa..24cca5d 100644 (file)
 module DsMonad (
         DsM, mapM, mapAndUnzipM,
         initDs, initDsTc, initTcDsForSolver, fixDs,
-        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
+        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
         Applicative(..),(<$>),
 
-        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
+        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
         newFailLocalDs, newPredVarDs,
         getSrcSpanDs, putSrcSpanDs,
         mkPrintUnqualifiedDs,
@@ -36,20 +37,28 @@ module DsMonad (
         -- Iterations for pm checking
         incrCheckPmIterDs, resetPmIterDs,
 
-        -- Warnings
-        DsWarning, warnDs, failWithDs, discardWarningsDs,
+        -- Warnings and errors
+        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
+        failWithDs, failDs, discardWarningsDs,
+        askNoErrsDs,
 
         -- Data types
         DsMatchContext(..),
         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
-        CanItFail(..), orFail
+        CanItFail(..), orFail,
+
+        -- Levity polymorphism
+        dsNoLevPoly, dsNoLevPolyExpr
     ) where
 
 import TcRnMonad
 import FamInstEnv
 import CoreSyn
+import MkCore    ( mkCoreTup )
+import CoreUtils ( exprType, isExprLevPoly )
 import HsSyn
 import TcIface
+import TcMType ( checkForLevPolyX, formatLevPolyErr )
 import LoadIface
 import Finder
 import PrelNames
@@ -312,11 +321,51 @@ And all this mysterious stuff is so we can occasionally reach out and
 grab one or more names.  @newLocalDs@ isn't exported---exported
 functions are defined with it.  The difference in name-strings makes
 it easier to read debugging output.
+
+Note [Levity polymorphism checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the Levity Polymorphism paper
+<http://cs.brynmawr.edu/~rae/papers/2017/levity/levity.pdf>, levity
+polymorphism is forbidden in precisely two places: in the type of a bound
+term-level argument and in the type of an argument to a function. The paper
+explains it more fully, but briefly: expressions in these contexts need to be
+stored in registers, and it's hard (read, impossible) to store something
+that's levity polymorphic.
+
+We cannot check for bad levity polymorphism conveniently in the type checker,
+because we can't tell, a priori, which levity metavariables will be solved.
+At one point, I (Richard) thought we could check in the zonker, but it's hard
+to know where precisely are the abstracted variables and the arguments. So
+we check in the desugarer, the only place where we can see the Core code and
+still report respectable syntax to the user. This covers the vast majority
+of cases; see calls to DsMonad.dsNoLevPoly and friends.
+
+Levity polymorphism is also prohibited in the types of binders, and the
+desugarer checks for this in GHC-generated Ids. (The zonker handles
+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
+The newSysLocalDs variant is used in the vast majority of cases where
+the binder is obviously not levity polymorphic, omitting the check.
+It would be nice to ASSERT that there is no levity polymorphism here,
+but we can't, because of the fixM in DsArrows. It's all OK, though:
+Core Lint will catch an error here.
+
+However, the desugarer is the wrong place for certain checks. In particular,
+the desugarer can't report a sensible error message if an HsWrapper is malformed.
+After all, GHC itself produced the HsWrapper. So we store some message text
+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
+desugarer.
+
+There are a few more checks in places where Core is generated outside the
+desugarer. For example, in datatype and class declarations, where levity
+polymorphism is checked for during validity checking. It would be nice to
+have one central place for all this, but that doesn't seem possible while
+still reporting nice error messages.
+
 -}
 
 -- Make a new Id with the same print name, but different type, and new unique
 newUniqueId :: Id -> Type -> DsM Id
-newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
 
 duplicateLocalDs :: Id -> DsM Id
 duplicateLocalDs old_local
@@ -327,12 +376,26 @@ newPredVarDs :: PredType -> DsM Var
 newPredVarDs pred
  = newSysLocalDs pred
 
-newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs  = mkSysLocalOrCoVarM (fsLit "ds")
+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDsNoLP  = mk_local (fsLit "ds")
+
+-- this variant should be used when the caller can be sure that the variable type
+-- is not levity-polymorphic. It is necessary when the type is knot-tied because
+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
 newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
+  -- the fail variable is used only in a situation where we can tell that
+  -- levity-polymorphism is impossible.
 
-newSysLocalsDs :: [Type] -> DsM [Id]
-newSysLocalsDs tys = mapM newSysLocalDs tys
+newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
+newSysLocalsDs = mapM newSysLocalDs
+
+mk_local :: FastString -> Type -> DsM Id
+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
+                                      ppr ty)  -- could improve the msg with another
+                                               -- parameter indicating context
+                    ; mkSysLocalOrCoVarM fs ty }
 
 {-
 We can also reach out and either set/grab location information from
@@ -387,6 +450,7 @@ putSrcSpanDs (RealSrcSpan real_span) thing_inside
   = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
 
 -- | Emit a warning for the current source location
+-- NB: Warns whether or not -Wxyz is set
 warnDs :: WarnReason -> SDoc -> DsM ()
 warnDs reason warn
   = do { env <- getGblEnv
@@ -396,15 +460,50 @@ warnDs reason warn
                    mkWarnMsg dflags loc (ds_unqual env) warn
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 
-failWithDs :: SDoc -> DsM a
-failWithDs err
+-- | Emit a warning only if the correct WarnReason is set in the DynFlags
+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
+warnIfSetDs flag warn
+  = whenWOptM flag $
+    warnDs (Reason flag) warn
+
+errDs :: SDoc -> DsM ()
+errDs err
   = do  { env <- getGblEnv
         ; loc <- getSrcSpanDs
         ; dflags <- getDynFlags
         ; let msg = mkErrMsg dflags loc (ds_unqual env) err
-        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+
+-- | Issue an error, but return the expression for (), so that we can continue
+-- reporting errors.
+errDsCoreExpr :: SDoc -> DsM CoreExpr
+errDsCoreExpr err
+  = do { errDs err
+       ; return $ mkCoreTup [] }
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+  = do  { errDs err
         ; failM }
 
+failDs :: DsM a
+failDs = failM
+
+-- (askNoErrsDs m) runs m
+-- If m fails, (askNoErrsDs m) fails
+-- If m succeeds with result r, (askNoErrsDs m) succeeds with result (r, b),
+--  where b is True iff m generated no errors
+-- Regardless of success or failure, any errors generated by m are propagated
+-- c.f. TcRnMonad.askNoErrs
+askNoErrsDs :: DsM a -> DsM (a, Bool)
+askNoErrsDs m
+ = do { errs_var <- newMutVar emptyMessages
+      ; env <- getGblEnv
+      ; res <- setGblEnv (env { ds_msgs = errs_var }) m
+      ; (warns, errs) <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+      ; return (res, isEmptyBag errs) }
+
 mkPrintUnqualifiedDs :: DsM PrintUnqualified
 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
 
@@ -529,3 +628,16 @@ discardWarningsDs thing_inside
         ; writeTcRef (ds_msgs env) old_msgs
 
         ; return result }
+
+-- | Fail with an error message if the type is levity polymorphic.
+dsNoLevPoly :: Type -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
+
+-- | Check an expression for levity polymorphism, failing if it is
+-- levity polymorphic.
+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPolyExpr e doc
+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+  | otherwise       = return ()
index 290c172..0d336ad 100644 (file)
@@ -121,7 +121,7 @@ selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
 selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
                                   -- Note [Localise pattern binders]
 selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
+selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)
                                   -- OK, better make up one...
 
 {-
@@ -736,7 +736,7 @@ mkSelectorBinds ticks pat val_expr
 
   | is_flat_prod_lpat pat'           -- Special case (B)
   = do { let pat_ty = hsLPatType pat'
-       ; val_var <- newSysLocalDs pat_ty
+       ; val_var <- newSysLocalDsNoLP pat_ty
 
        ; let mk_bind tick bndr_var
                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
index 672157e..f5c3cf5 100644 (file)
@@ -444,7 +444,18 @@ tidy1 v (AsPat (L _ var) pat)
 -}
 
 tidy1 v (LazyPat pat)
-  = do  { (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+    -- This is a convenient place to check for unlifted types under a lazy pattern.
+    -- Doing this check during type-checking is unsatisfactory because we may
+    -- not fully know the zonked types yet. We sure do here.
+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+        ; unless (null unlifted_bndrs) $
+          putSrcSpanDs (getLoc pat) $
+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                       text "Unlifted variables:")
+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+                                 unlifted_bndrs)))
+
+        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
@@ -705,7 +716,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
         ; locn   <- getSrcSpanDs
 
         ; new_vars    <- case matches of
-                           []    -> mapM newSysLocalDs arg_tys
+                           []    -> mapM newSysLocalDsNoLP arg_tys
                            (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
 
         ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
@@ -951,6 +962,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     -- we have to compare the wrappers
     exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
     exp (HsVar i) (HsVar i') =  i == i'
+    exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
     -- the instance for IPName derives using the id, so this works if the
     -- above does
     exp (HsIPVar i) (HsIPVar i') = i == i'
@@ -1012,7 +1024,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     --        equating different ways of writing a coercion)
     wrap WpHole WpHole = True
     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'
+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
     wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
     wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
     wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
index 73b6ec3..4a7d1cd 100644 (file)
@@ -207,7 +207,7 @@ same_fields flds1 flds2
 
 -----------------
 selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
-selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDs arg_tys
+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys
 selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
 selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
 
index e45984d..e35358f 100644 (file)
@@ -20,6 +20,7 @@ import Id
 import Name
 import NameSet
 import DataCon
+import ConLike
 import TysWiredIn
 import Outputable
 import Util
@@ -230,6 +231,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
 hsExprToPmExpr :: HsExpr Id -> PmExpr
 
 hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut  c) = PmExprVar (conLikeName c)
 hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)
 hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)
 
index 9a5e414..a4373b4 100644 (file)
@@ -321,7 +321,7 @@ collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
     go xs (AnnLam x (_,e))
-      | repTypeArgs (idType x) `lengthExceeds` 1
+      | typePrimRep (idType x) `lengthExceeds` 1
       = multiValException
       | otherwise
       = go (x:xs) e
@@ -551,8 +551,6 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
-   , [rep_ty1] <- repTypeArgs (idType bind1)
-   , [rep_ty2] <- repTypeArgs (idType bind2)
         -- Convert
         --      case .... of x { (# V'd-thing, a #) -> ... }
         -- to
@@ -561,23 +559,25 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
         --
         -- Note that it does not matter losing the void-rep thing from the
         -- envt (it won't be bound now) because we never look such things up.
-   , Just res <- case () of
-                   _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2)
+   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
+                   ([], [_])
                      -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
-                     | isVoidTy rep_ty2 && not (isVoidTy rep_ty1)
+                   ([_], [])
                      -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
-                     | otherwise
-                     -> Nothing
+                   _ -> Nothing
    = res
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
-   , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples
+   , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples
    = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
 
 schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
    | isUnboxedTupleType (idType bndr)
-   , [ty] <- repTypeArgs (idType bndr)
+   , Just ty <- case typePrimRep (idType bndr) of
+       [_]  -> Just (unwrapType (idType bndr))
+       []   -> Just voidPrimTy
+       _    -> Nothing
        -- handles any pattern with a single non-void binder; in particular I/O
        -- monad returns (# RealWorld#, a #)
    = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
@@ -793,7 +793,7 @@ doCase  :: Word -> Sequel -> BCEnv
         -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
         -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-  | repTypeArgs (idType bndr) `lengthExceeds` 1
+  | typePrimRep (idType bndr) `lengthExceeds` 1
   = multiValException
   | otherwise
   = do
@@ -970,7 +970,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          pargs _ [] = return []
          pargs d (a:az)
-            = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a))
+            = let arg_ty = unwrapType (exprType (deAnnotate' a))
 
               in case tyConAppTyCon_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
@@ -1195,24 +1195,22 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 maybe_getCCallReturnRep fn_ty
    = let
        (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
-       r_reps = repTypeArgs r_ty
+       r_reps = typePrimRepArgs r_ty
 
        blargh :: a -- Used at more than one type
        blargh = pprPanic "maybe_getCCallReturn: can't handle:"
                          (pprType fn_ty)
      in
        case r_reps of
-         [] -> panic "empty repTypeArgs"
-         [ty]
-           | typePrimRep ty == PtrRep
-            -> blargh
-           | isVoidTy ty
-            -> Nothing
-           | otherwise
-            -> Just (typePrimRep ty)
+         []            -> panic "empty typePrimRepArgs"
+         [VoidRep]     -> Nothing
+         [rep]
+           | isGcPtrRep rep -> blargh
+           | otherwise      -> Just rep
+
                  -- if it was, it would be impossible to create a
                  -- valid return value placeholder on the stack
-         _  -> blargh
+         _             -> blargh
 
 maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
 -- Detect and extract relevant info for the tagToEnum kludge.
@@ -1224,7 +1222,7 @@ maybe_is_tagToEnum_call app
   = Nothing
   where
     extract_constr_Names ty
-           | [rep_ty] <- repTypeArgs ty
+           | rep_ty <- unwrapType ty
            , Just tyc <- tyConAppTyCon_maybe rep_ty
            , isDataTyCon tyc
            = map (getName . dataConWorkId) (tyConDataCons tyc)
@@ -1331,8 +1329,7 @@ pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
    = pushAtom d p a
 
 pushAtom d p (AnnVar v)
-   | [rep_ty] <- repTypeArgs (idType v)
-   , V <- typeArgRep rep_ty
+   | [] <- typePrimRep (idType v)
    = return (nilOL, 0)
 
    | isFCallId v
@@ -1542,7 +1539,11 @@ bcIdArgRep :: Id -> ArgRep
 bcIdArgRep = toArgRep . bcIdPrimRep
 
 bcIdPrimRep :: Id -> PrimRep
-bcIdPrimRep = typePrimRep . bcIdUnaryType
+bcIdPrimRep id
+  | [rep] <- typePrimRepArgs (idType id)
+  = rep
+  | otherwise
+  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
 
 isFollowableArg :: ArgRep -> Bool
 isFollowableArg P = True
@@ -1552,11 +1553,6 @@ isVoidArg :: ArgRep -> Bool
 isVoidArg V = True
 isVoidArg _ = False
 
-bcIdUnaryType :: Id -> UnaryType
-bcIdUnaryType x = case repTypeArgs (idType x) of
-    [rep_ty] -> rep_ty
-    _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
-
 -- See bug #1257
 multiValException :: a
 multiValException = throwGhcException (ProgramError
@@ -1625,12 +1621,12 @@ isVAtom _                     = False
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
 atomPrimRep (AnnVar v)              = bcIdPrimRep v
-atomPrimRep (AnnLit l)              = typePrimRep (literalType l)
+atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)
 
 -- Trac #12128:
 -- A case expresssion can be an atom because empty cases evaluate to bottom.
 -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
-atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == PtrRep) PtrRep
+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
 atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
 
@@ -1648,7 +1644,7 @@ mkStackOffsets original_depth szsw
    = map (subtract 1) (tail (scanl (+) original_depth szsw))
 
 typeArgRep :: Type -> ArgRep
-typeArgRep = toArgRep . typePrimRep
+typeArgRep = toArgRep . typePrimRep1
 
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad
index 4a4a039..6dc89e1 100644 (file)
@@ -16,7 +16,7 @@ import HscTypes
 import Name             ( Name, getName )
 import NameEnv
 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
-import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons, isVoidRep )
+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import RepType
 import StgCmmLayout     ( mkVirtConstrSizes )
 import StgCmmClosure    ( tagForCon, NonVoid (..) )
@@ -56,9 +56,7 @@ make_constr_itbls hsc_env cons =
   mk_itbl dcon conNo = do
      let rep_args = [ NonVoid prim_rep
                     | arg <- dataConRepArgTys dcon
-                    , slot_ty <- repTypeSlots (repType arg)
-                    , let prim_rep = slotPrimRep slot_ty
-                    , not (isVoidRep prim_rep) ]
+                    , prim_rep <- typePrimRep arg ]
 
          (tot_wds, ptr_wds) =
              mkVirtConstrSizes dflags rep_args
index 64ac154..4d7f8e3 100644 (file)
@@ -28,7 +28,6 @@ import Var hiding ( varName )
 import VarSet
 import UniqFM
 import Type
-import Kind
 import GHC
 import Outputable
 import PprTyThing
@@ -78,7 +77,7 @@ pprintClosureCommand bindThings force str = do
        term_    <- GHC.obtainTermFromId maxBound force id'
        term     <- tidyTermTyVars term_
        term'    <- if bindThings &&
-                      False == isUnliftedTypeKind (termType term)
+                      (not (isUnliftedType (termType term)))
                      then bindSuspensions term
                      else return term
      -- Before leaving, we compare the type obtained to see if it's more specific
index 4503034..2354908 100644 (file)
@@ -641,13 +641,13 @@ wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
 -- only works when the interpreter is running in the same process as
 -- the compiler, so it fails when @-fexternal-interpreter@ is on.
 wormholeRef :: DynFlags -> RemoteRef a -> IO a
-wormholeRef dflags r
+wormholeRef dflags _r
   | gopt Opt_ExternalInterpreter dflags
   = throwIO (InstallationError
       "this operation requires -fno-external-interpreter")
 #ifdef GHCI
   | otherwise
-  = localRef r
+  = localRef _r
 #else
   | otherwise
   = throwIO (InstallationError
index 815e5e6..03b2f95 100644 (file)
@@ -735,7 +735,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
          traceTR (text "Following a MutVar")
          contents_tv <- newVar liftedTypeKind
          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
-         ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
+         ASSERT(isUnliftedType my_ty) return ()
          (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
                             contents_ty (mkTyConApp tycon [world,contents_ty])
          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
@@ -805,9 +805,9 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
            (ptr_i, ws, terms1) <- go ptr_i ws tys
            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
-      = case repTypeArgs ty of
+      = case typePrimRepArgs ty of
           [rep_ty] ->  do
-            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty (typePrimRep rep_ty)
+            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty
             (ptr_i, ws, terms1) <- go ptr_i ws tys
             return (ptr_i, ws, term0 : terms1)
           rep_tys -> do
@@ -818,18 +818,18 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
     go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
     go_unary_types ptr_i ws (rep_ty:rep_tys) = do
       tv <- newVar liftedTypeKind
-      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv (typePrimRep rep_ty)
+      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep_ty
       (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
       return (ptr_i, ws, term0 : terms1)
 
-    go_rep ptr_i ws ty rep = case rep of
-      PtrRep -> do
-        t <- appArr (recurse ty) (ptrs clos) ptr_i
-        return (ptr_i + 1, ws, t)
-      _ -> do
-        dflags <- getDynFlags
-        let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
-        return (ptr_i, ws1, Prim ty ws0)
+    go_rep ptr_i ws ty rep
+      | isGcPtrRep rep
+      = do t <- appArr (recurse ty) (ptrs clos) ptr_i
+           return (ptr_i + 1, ws, t)
+      | otherwise
+      = do dflags <- getDynFlags
+           let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
+           return (ptr_i, ws1, Prim ty ws0)
 
     unboxedTupleTerm ty terms
       = Term ty (Right (tupleDataCon Unboxed (length terms)))
@@ -919,17 +919,15 @@ findPtrTys i ty
   = findPtrTyss i elem_tys
 
   | otherwise
-  = -- Can't directly call repTypeArgs here -- we lose type information in
-    -- some cases (e.g. singleton tuples)
-    case repType ty of
-      UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)])
-                      | otherwise                    -> return (i,     [])
-      MultiRep slot_tys ->
-        foldM (\(i, extras) rep_ty ->
-                if typePrimRep rep_ty == PtrRep
+  = case typePrimRep ty of
+      [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
+            | otherwise      -> return (i,     [])
+      prim_reps              ->
+        foldM (\(i, extras) prim_rep ->
+                if isGcPtrRep prim_rep
                   then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
                   else return (i, extras))
-              (i, []) (map slotTyToType slot_tys)
+              (i, []) prim_reps
 
 findPtrTyss :: Int
             -> [Type]
@@ -955,7 +953,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
 --
 -- I believe that con_app_ty should not have any enclosing foralls
 getDataConArgTys dc con_app_ty
-  = do { let UnaryRep rep_con_app_ty = repType con_app_ty
+  = do { let rep_con_app_ty = unwrapType con_app_ty
        ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
                    $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
        ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
@@ -1193,7 +1191,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                (_, vars) <- instTyVars (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
-                   UnaryRep rep_ty = repType ty'
+                   rep_ty = unwrapType ty'
                _ <- liftTcM (unifyType noThing ty rep_ty)
         -- assumes that reptype doesn't ^^^^ touch tyconApp args
                return ty'
@@ -1235,14 +1233,13 @@ dictsView ty = ty
 isMonomorphic :: RttiType -> Bool
 isMonomorphic ty = noExistentials && noUniversals
  where (tvs, _, ty')  = tcSplitSigmaTy ty
-       noExistentials = isEmptyVarSet (tyCoVarsOfType ty')
+       noExistentials = noFreeVarsOfType ty'
        noUniversals   = null tvs
 
 -- Use only for RTTI types
 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
 isMonomorphicOnNonPhantomArgs ty
-  | UnaryRep rep_ty <- repType ty
-  , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty
+  | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
   , phantom_vars  <- tyConPhantomTyVars tc
   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
                            , tyv `notElem` phantom_vars]
index 421a358..e04dc89 100644 (file)
@@ -63,6 +63,9 @@ Global bindings (where clauses)
 -- | Haskell Local Bindings
 type HsLocalBinds id = HsLocalBindsLR id id
 
+-- | Located Haskell local bindings
+type LHsLocalBinds id = Located (HsLocalBinds id)
+
 -- | Haskell Local Bindings with separate Left and Right identifier types
 --
 -- Bindings in a 'let' expression
@@ -82,6 +85,8 @@ data HsLocalBindsLR idL idR
   | EmptyLocalBinds
       -- ^ Empty Local Bindings
 
+type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
+
 deriving instance (DataId idL, DataId idR)
   => Data (HsLocalBindsLR idL idR)
 
index f4aa88c..e4d8431 100644 (file)
@@ -287,11 +287,17 @@ data HsExpr id
                              -- Turned into HsVar by type checker, to support
                              --   deferred type errors.
 
+  | HsConLikeOut ConLike     -- ^ After typechecker only; must be different
+                             -- HsVar for pretty printing
+
   | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
+                                    -- Not in use after typechecking
 
   | HsOverLabel FastString   -- ^ Overloaded label (See Note [Overloaded labels]
                              --   in GHC.OverloadedLabels)
-  | HsIPVar   HsIPName       -- ^ Implicit parameter
+                             --   NB: Not in use after typechecking
+
+  | HsIPVar   HsIPName       -- ^ Implicit parameter (not in use after typechecking)
   | HsOverLit (HsOverLit id) -- ^ Overloaded literals
 
   | HsLit     HsLit          -- ^ Simple (non-overloaded) literals
@@ -413,7 +419,7 @@ data HsExpr id
   --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsLet       (Located (HsLocalBinds id))
+  | HsLet       (LHsLocalBinds id)
                 (LHsExpr  id)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
@@ -811,6 +817,7 @@ ppr_lexpr e = ppr_expr (unLoc e)
 ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc
 ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
 ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut c) = pprPrefixOcc c
 ppr_expr (HsIPVar v)      = ppr v
 ppr_expr (HsOverLabel l)  = char '#' <> ppr l
 ppr_expr (HsLit lit)      = ppr lit
@@ -827,27 +834,36 @@ ppr_expr e@(HsAppType {})    = ppr_apps e []
 ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
 
 ppr_expr (OpApp e1 op _ e2)
-  = case unLoc op of
-      HsVar (L _ v) -> pp_infixly v
-      HsRecFld f    -> pp_infixly f
-      HsUnboundVar h@TrueExprHole{} -> pp_infixly (unboundVarOcc h)
-      _             -> pp_prefixly
+  | Just pp_op <- should_print_infix (unLoc op)
+  = pp_infixly pp_op
+  | otherwise
+  = pp_prefixly
+
   where
+    should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
+    should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
+    should_print_infix (HsRecFld f)    = Just (pprInfixOcc f)
+    should_print_infix (HsUnboundVar h@TrueExprHole{})
+                                       = Just (pprInfixOcc (unboundVarOcc h))
+    should_print_infix (HsWrap _ e)    = should_print_infix e
+    should_print_infix _               = Nothing
+
     pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
     pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
 
     pp_prefixly
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
-    pp_infixly v
-      = hang pp_e1 2 (sep [pprInfixOcc v, nest 2 pp_e2])
+    pp_infixly pp_op
+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
 ppr_expr (SectionL expr op)
   = case unLoc op of
-      HsVar (L _ v) -> pp_infixly v
-      _             -> pp_prefixly
+      HsVar (L _ v)  -> pp_infixly v
+      HsConLikeOut c -> pp_infixly (conLikeName c)
+      _              -> pp_prefixly
   where
     pp_expr = pprDebugParendExpr expr
 
@@ -857,8 +873,9 @@ ppr_expr (SectionL expr op)
 
 ppr_expr (SectionR op expr)
   = case unLoc op of
-      HsVar (L _ v) -> pp_infixly v
-      _             -> pp_prefixly
+      HsVar (L _ v)  -> pp_infixly v
+      HsConLikeOut c -> pp_infixly (conLikeName c)
+      _              -> pp_prefixly
   where
     pp_expr = pprDebugParendExpr expr
 
@@ -1004,6 +1021,8 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
 
 ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
+ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
 ppr_expr (HsArrForm op _ args)
   = hang (text "(|" <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
@@ -1070,6 +1089,7 @@ hsExprNeedsParens (HsLit {})          = False
 hsExprNeedsParens (HsOverLit {})      = False
 hsExprNeedsParens (HsVar {})          = False
 hsExprNeedsParens (HsUnboundVar {})   = False
+hsExprNeedsParens (HsConLikeOut {})   = False
 hsExprNeedsParens (HsIPVar {})        = False
 hsExprNeedsParens (HsOverLabel {})    = False
 hsExprNeedsParens (ExplicitTuple {})  = False
@@ -1085,12 +1105,14 @@ hsExprNeedsParens (HsRecFld{})        = False
 hsExprNeedsParens (RecordCon{})       = False
 hsExprNeedsParens (HsSpliceE{})       = False
 hsExprNeedsParens (RecordUpd{})       = False
+hsExprNeedsParens (HsWrap _ e)        = hsExprNeedsParens e
 hsExprNeedsParens _ = True
 
 
 isAtomicHsExpr :: HsExpr id -> Bool
 -- True of a single token
 isAtomicHsExpr (HsVar {})        = True
+isAtomicHsExpr (HsConLikeOut {}) = True
 isAtomicHsExpr (HsLit {})        = True
 isAtomicHsExpr (HsOverLit {})    = True
 isAtomicHsExpr (HsIPVar {})      = True
@@ -1178,7 +1200,7 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdLet    (Located (HsLocalBinds id))      -- let(rec)
+  | HsCmdLet    (LHsLocalBinds id)      -- let(rec)
                 (LHsCmd  id)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
     --       'ApiAnnotation.AnnOpen' @'{'@,
@@ -1299,6 +1321,12 @@ ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
 ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
+                                         , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _    [arg1, arg2])
+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
+                                         , pprCmdArg (unLoc arg2)])
 ppr_cmd (HsCmdArrForm op _ _ args)
   = hang (text "(|" <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
@@ -1452,8 +1480,8 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats
 -- For details on above see note [Api annotations] in ApiAnnotation
 data GRHSs id body
   = GRHSs {
-      grhssGRHSs :: [LGRHS id body],       -- ^ Guarded RHSs
-      grhssLocalBinds :: Located (HsLocalBinds id) -- ^ The where clause
+      grhssGRHSs :: [LGRHS id body],      -- ^ Guarded RHSs
+      grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause
     }
 deriving instance (Data body,DataId id) => Data (GRHSs id body)
 
@@ -1511,7 +1539,7 @@ pprMatch match
 
             LambdaExpr -> (char '\\', m_pats match)
 
-            _  -> ASSERT( null pats1 )
+            _  -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
                   (ppr pat1, [])        -- No parens around the single pat
 
     (pat1:pats1) = m_pats match
@@ -1640,7 +1668,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
   --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | LetStmt  (Located (HsLocalBindsLR idL idR))
+  | LetStmt  (LHsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
   | ParStmt  [ParStmtBlock idL idR]
@@ -2308,6 +2336,19 @@ data HsMatchContext id
   deriving Functor
 deriving instance (DataIdPost id) => Data (HsMatchContext id)
 
+instance OutputableBndr id => Outputable (HsMatchContext id) where
+  ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix
+  ppr LambdaExpr            = text "LambdaExpr"
+  ppr CaseAlt               = text "CaseAlt"
+  ppr IfAlt                 = text "IfAlt"
+  ppr ProcExpr              = text "ProcExpr"
+  ppr PatBindRhs            = text "PatBindRhs"
+  ppr RecUpd                = text "RecUpd"
+  ppr (StmtCtxt _)          = text "StmtCtxt _"
+  ppr ThPatSplice           = text "ThPatSplice"
+  ppr ThPatQuote            = text "ThPatQuote"
+  ppr PatSyn                = text "PatSyn"
+
 isPatSynCtxt :: HsMatchContext id -> Bool
 isPatSynCtxt ctxt =
   case ctxt of
index c29f0c2..174e837 100644 (file)
@@ -28,8 +28,8 @@ module HsPat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isUnliftedHsBind, looksLazyPatBind,
-        isUnliftedLPat, isBangedLPat, isBangedPatBind,
+        looksLazyPatBind,
+        isBangedLPat, isBangedPatBind,
         hsPatNeedsParens,
         isIrrefutableHsPat,
 
@@ -555,19 +555,6 @@ patterns are treated specially, of course.
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
-isUnliftedLPat :: LPat id -> Bool
-isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
-isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
-isUnliftedLPat (L _ (SumPat _ _ _ _))       = True
-isUnliftedLPat _                            = False
-
-isUnliftedHsBind :: HsBind id -> Bool
--- A pattern binding with an outermost bang or unboxed tuple or sum must be
--- matched strictly.
--- Defined in this module because HsPat is above HsBinds in the import graph
-isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p
-isUnliftedHsBind _                         = False
-
 isBangedPatBind :: HsBind id -> Bool
 isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
 isBangedPatBind _ = False
@@ -582,15 +569,20 @@ looksLazyPatBind :: HsBind id -> Bool
 --     a StrictHsBind (as above) or
 --     a VarPat
 -- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
-looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
-looksLazyPatBind _                         = False
+-- Looks through AbsBinds
+looksLazyPatBind (PatBind { pat_lhs = p })
+  = looksLazyLPat p
+looksLazyPatBind (AbsBinds { abs_binds = binds })
+  = anyBag (looksLazyPatBind . unLoc) binds
+looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })
+  = looksLazyPatBind bind
+looksLazyPatBind _
+  = False
 
 looksLazyLPat :: LPat id -> Bool
 looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
 looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
 looksLazyLPat (L _ (BangPat {}))           = False
-looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
-looksLazyLPat (L _ (SumPat _ _ _ _))       = False
 looksLazyLPat (L _ (VarPat {}))            = False
 looksLazyLPat (L _ (WildPat {}))           = False
 looksLazyLPat _                            = True
index b49cd98..58948cc 100644 (file)
@@ -28,7 +28,8 @@ module HsUtils(
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
 
-  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
+  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
+  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
   nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
@@ -71,6 +72,8 @@ module HsUtils(
   noRebindableInfo,
 
   -- Collecting binders
+  isUnliftedHsBind,
+
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   collectHsIdBinders,
   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
@@ -105,6 +108,8 @@ import Type   ( filterOutInvisibleTypes )
 import TysWiredIn ( unitTy )
 import TcType
 import DataCon
+import ConLike
+import Id
 import Name
 import NameSet
 import NameEnv
@@ -365,6 +370,10 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
 nlHsVar :: id -> LHsExpr id
 nlHsVar n = noLoc (HsVar (noLoc n))
 
+-- NB: Only for LHsExpr **Id**
+nlHsDataCon :: DataCon -> LHsExpr Id
+nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
+
 nlHsLit :: HsLit -> LHsExpr id
 nlHsLit n = noLoc (HsLit n)
 
@@ -772,9 +781,72 @@ These functions should only be used on HsSyn *after* the renamer,
 to return a [Name] or [Id].  Before renaming the record punning
 and wild-card mechanism makes it hard to know what is bound.
 So these functions should not be applied to (HsSyn RdrName)
+
+Note [Unlifted id check in isHsUnliftedBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
+strict binding that should be disallowed at the top level? At first glance,
+no, because it's a function. But consider how this is desugared via
+AbsBinds:
+
+  -- x :: Num a => (# a, a #)
+  x = (# 3, 4 #)
+
+becomes
+
+  x = \ $dictNum ->
+      let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
+      x_mono
+
+Note that the inner let is strict. And thus if we have a bunch of mutually
+recursive bindings of this form, we could end up in trouble. This was shown
+up in #9140.
+
+But if there is a type signature on x, everything changes because of the
+desugaring used by AbsBindsSig:
+
+  x :: Num a => (# a, a #)
+  x = (# 3, 4 #)
+
+becomes
+
+  x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
+
+No strictness anymore! The bottom line here is that, for inferred types, we
+care about the strictness of the type after the =>. For checked types
+(AbsBindsSig), we care about the overall strictness.
+
+This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
+a problem when compiling
+
+  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
+
+Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
+if you try.) Looking at the whole type, on the other hand, tells you that this
+is a lifted function type, with no trouble at all.
+
 -}
 
 ----------------- Bindings --------------------------
+
+-- | Should we treat this as an unlifted bind? This will be true for any
+-- bind that binds an unlifted variable, but we must be careful around
+-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
+-- information, see Note [Strict binds check] is DsBinds.
+isUnliftedHsBind :: HsBind Id -> Bool  -- works only over typechecked binds
+isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
+  = isUnliftedType (idType id)
+isUnliftedHsBind bind
+  = any is_unlifted_id (collectHsBindBinders bind)
+  where
+    is_unlifted_id id
+      = case tcSplitSigmaTy (idType id) of
+          (_, _, tau) -> isUnliftedType tau
+          -- For the is_unlifted check, we need to look inside polymorphism
+          -- and overloading.  E.g.  x = (# 1, True #)
+          -- would get type forall a. Num a => (# a, Bool #)
+          -- and we want to reject that.  See Trac #9140
+
 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                          -- No pattern synonyms here
index cb5e3a7..4c95f90 100644 (file)
@@ -316,6 +316,7 @@ data IfaceInfoItem
   | HsUnfold        Bool             -- True <=> isStrongLoopBreaker is true
                     IfaceUnfolding   -- See Note [Expose recursive functions]
   | HsNoCafRefs
+  | HsLevity                         -- Present <=> never levity polymorphic
 
 -- NB: Specialisations and rules come in separately and are
 -- only later attached to the Id.  Partial reason: some are orphans.
@@ -1156,6 +1157,7 @@ instance Outputable IfaceInfoItem where
   ppr (HsArity arity)       = text "Arity:" <+> int arity
   ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
   ppr HsNoCafRefs           = text "HasNoCafRefs"
+  ppr HsLevity              = text "Never levity-polymorphic"
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = text "<compulsory>" <+> parens (ppr e)
@@ -1817,6 +1819,7 @@ instance Binary IfaceInfoItem where
     put_ bh (HsUnfold lb ad)      = putByte bh 2 >> put_ bh lb >> put_ bh ad
     put_ bh (HsInline ad)         = putByte bh 3 >> put_ bh ad
     put_ bh HsNoCafRefs           = putByte bh 4
+    put_ bh HsLevity              = putByte bh 5
     get bh = do
         h <- getByte bh
         case h of
@@ -1826,7 +1829,8 @@ instance Binary IfaceInfoItem where
                     ad <- get bh
                     return (HsUnfold lb ad)
             3 -> liftM HsInline $ get bh
-            _ -> return HsNoCafRefs
+            4 -> return HsNoCafRefs
+            _ -> return HsLevity
 
 instance Binary IfaceUnfolding where
     put_ bh (IfCoreUnfold s e) = do
index b667522..ad1a3ea 100644 (file)
@@ -49,7 +49,7 @@ module IfaceType (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TysWiredIn ( ptrRepLiftedDataConTyCon )
+import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
 
 import DynFlags
 import StaticFlags ( opt_PprStyle_Debug )
@@ -296,7 +296,7 @@ isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
 isIfaceLiftedTypeKind (IfaceTyConApp tc
                        (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
   =  tc `ifaceTyConHasKey` tYPETyConKey
-  && ptr_rep_lifted `ifaceTyConHasKey` ptrRepLiftedDataConKey
+  && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
 isIfaceLiftedTypeKind _ = False
 
 splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
@@ -779,7 +779,7 @@ defaultRuntimeRepVars = go emptyFsEnv
 
     go subs (IfaceTyVar tv)
       | tv `elemFsEnv` subs
-      = IfaceTyConApp ptrRepLifted ITC_Nil
+      = IfaceTyConApp liftedRep ITC_Nil
 
     go subs (IfaceFunTy kind ty)
       = IfaceFunTy (go subs kind) (go subs ty)
@@ -795,10 +795,10 @@ defaultRuntimeRepVars = go emptyFsEnv
 
     go _ other = other
 
-    ptrRepLifted :: IfaceTyCon
-    ptrRepLifted =
+    liftedRep :: IfaceTyCon
+    liftedRep =
         IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)
-      where dc_name = getName ptrRepLiftedDataConTyCon
+      where dc_name = getName liftedRepDataConTyCon
 
     isRuntimeRep :: IfaceType -> Bool
     isRuntimeRep (IfaceTyConApp tc _) =
@@ -965,14 +965,9 @@ pprTyTcApp' ctxt_prec tc tys dflags style
 
   | tc `ifaceTyConHasKey` tYPETyConKey
   , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
-  , rep `ifaceTyConHasKey` ptrRepLiftedDataConKey
+  , rep `ifaceTyConHasKey` liftedRepDataConKey
   = kindStar
 
-  | tc `ifaceTyConHasKey` tYPETyConKey
-  , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
-  , rep `ifaceTyConHasKey` ptrRepUnliftedDataConKey
-  = char '#'
-
   | not opt_PprStyle_Debug
   , tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
   = text "(TypeError ...)"   -- Suppress detail unles you _really_ want to see
@@ -1055,9 +1050,6 @@ ppr_iface_tc_app pp ctxt_prec tc tys
   || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
   = kindStar   -- Handle unicode; do not wrap * in parens
 
-  | tc `ifaceTyConHasKey` unliftedTypeKindTyConKey
-  = ppr tc  -- Do not wrap # in parens
-
   | not (isSymOcc (nameOccName (ifaceTyConName tc)))
   = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
 
index 3c8742e..988860f 100644 (file)
@@ -1469,6 +1469,7 @@ tcIdInfo ignore_prags name ty info = do
     tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
     tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)
 
         -- The next two are lazy, so they don't transitively suck stuff in
     tcPrag info (HsUnfold lb if_unf)
index 8e80bb3..696d0ff 100644 (file)
@@ -346,7 +346,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
 toIfaceIdInfo id_info
   = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
-                    inline_hsinfo,  unfold_hsinfo] of
+                    inline_hsinfo,  unfold_hsinfo, levity_hsinfo] of
        []    -> NoInfo
        infos -> HasInfo infos
                -- NB: strictness and arity must appear in the list before unfolding
@@ -378,6 +378,10 @@ toIfaceIdInfo id_info
     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
                   | otherwise = Just (HsInline inline_prag)
 
+    ------------  Levity polymorphism  ----------
+    levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity
+                  | otherwise                    = Nothing
+
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
index 41f7235..bcd5a25 100644 (file)
@@ -564,6 +564,10 @@ data GeneralFlag
 -- displayed. If a warning isn't controlled by a flag, this is made
 -- explicit at the point of use.
 data WarnReason = NoReason | Reason !WarningFlag
+  deriving Show
+
+instance Outputable WarnReason where
+  ppr = text . show
 
 data WarningFlag =
 -- See Note [Updating flag description in the User's Guide]
@@ -631,6 +635,7 @@ data WarningFlag =
    | Opt_WarnUnrecognisedWarningFlags     -- since 8.0
    | Opt_WarnSimplifiableClassConstraints -- Since 8.2
    | Opt_WarnCPPUndef                     -- Since 8.2
+   | Opt_WarnUnbangedStrictPatterns       -- Since 8.2
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -3363,6 +3368,7 @@ wWarningFlagsDeps = [
   depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans
     "it has no effect",
   flagSpec "cpp-undef"                   Opt_WarnCPPUndef,
+  flagSpec "unbanged-strict-patterns"    Opt_WarnUnbangedStrictPatterns,
   flagSpec "deferred-type-errors"        Opt_WarnDeferredTypeErrors,
   flagSpec "deferred-out-of-scope-variables"
                                          Opt_WarnDeferredOutOfScopeVariables,
@@ -4062,7 +4068,8 @@ minusWOpts
         Opt_WarnUnusedImports,
         Opt_WarnIncompletePatterns,
         Opt_WarnDodgyExports,
-        Opt_WarnDodgyImports
+        Opt_WarnDodgyImports,
+        Opt_WarnUnbangedStrictPatterns
       ]
 
 -- | Things you get with -Wall
index 5b3c058..3b44bb1 100644 (file)
@@ -2964,4 +2964,3 @@ nameOfObject other       = pprPanic "nameOfObject" (ppr other)
 byteCodeOfObject :: Unlinked -> CompiledByteCode
 byteCodeOfObject (BCOs bc) = bc
 byteCodeOfObject other     = pprPanic "byteCodeOfObject" (ppr other)
-
index 3c2973d..93abb07 100644 (file)
@@ -63,7 +63,6 @@ import Name             hiding ( varName )
 import NameSet
 import Avail
 import RdrName
-import VarSet
 import VarEnv
 import ByteCodeTypes
 import Linker
@@ -481,9 +480,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
            -- Filter out any unboxed ids;
            -- we can't bind these at the prompt
        pointers = filter (\(id,_) -> isPointer id) vars
-       isPointer id | UnaryRep ty <- repType (idType id)
-                    , PtrRep <- typePrimRep ty = True
-                    | otherwise                = False
+       isPointer id | [rep] <- typePrimRep (idType id)
+                    , isGcPtrRep rep                   = True
+                    | otherwise                        = False
 
        (ids, offsets) = unzip pointers
 
@@ -551,7 +550,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
    return hsc_env'
     where
-     noSkolems = isEmptyVarSet . tyCoVarsOfType . idType
+     noSkolems = noFreeVarsOfType . idType
      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
       let tmp_ids = [id | AnId id <- ic_tythings ic]
           Just id = find (\i -> idName i == name) tmp_ids
index e7ad536..fcddcdb 100644 (file)
@@ -1650,12 +1650,11 @@ eitherTyConKey                          = mkPreludeTyConUnique 84
 
 -- Kind constructors
 liftedTypeKindTyConKey, tYPETyConKey,
-  unliftedTypeKindTyConKey, constraintKindTyConKey,
+  constraintKindTyConKey,
   starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey,
   vecCountTyConKey, vecElemTyConKey :: Unique
 liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
 tYPETyConKey                            = mkPreludeTyConUnique 88
-unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89
 constraintKindTyConKey                  = mkPreludeTyConUnique 92
 starKindTyConKey                        = mkPreludeTyConUnique 93
 unicodeStarKindTyConKey                 = mkPreludeTyConUnique 94
@@ -1895,25 +1894,27 @@ metaDataDataConKey                      = mkPreludeDataConUnique 68
 metaConsDataConKey                      = mkPreludeDataConUnique 69
 metaSelDataConKey                       = mkPreludeDataConUnique 70
 
-vecRepDataConKey :: Unique
+vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique
 vecRepDataConKey                        = mkPreludeDataConUnique 71
+tupleRepDataConKey                      = mkPreludeDataConUnique 72
+sumRepDataConKey                        = mkPreludeDataConUnique 73
 
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 runtimeRepSimpleDataConKeys :: [Unique]
-ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey :: Unique
+liftedRepDataConKey :: Unique
 runtimeRepSimpleDataConKeys@(
-  ptrRepLiftedDataConKey : ptrRepUnliftedDataConKey : _)
-  = map mkPreludeDataConUnique [72..83]
+  liftedRepDataConKey : _)
+  = map mkPreludeDataConUnique [74..82]
 
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 -- VecCount
 vecCountDataConKeys :: [Unique]
-vecCountDataConKeys = map mkPreludeDataConUnique [84..89]
+vecCountDataConKeys = map mkPreludeDataConUnique [83..88]
 
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 -- VecElem
 vecElemDataConKeys :: [Unique]
-vecElemDataConKeys = map mkPreludeDataConUnique [90..99]
+vecElemDataConKeys = map mkPreludeDataConUnique [89..98]
 
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES DataUniques 100-150
@@ -2309,5 +2310,4 @@ pretendNameIsInScope :: Name -> Bool
 pretendNameIsInScope n
   = any (n `hasKey`)
     [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey
-    , unliftedTypeKindTyConKey
-    , runtimeRepTyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ]
+    , runtimeRepTyConKey, liftedRepDataConKey ]
index 0acac66..41458b0 100644 (file)
@@ -37,7 +37,7 @@ import Demand
 import OccName          ( OccName, pprOccName, mkVarOccFS )
 import TyCon            ( TyCon, isPrimTyCon, PrimRep(..) )
 import Type
-import RepType          ( typePrimRep, tyConPrimRep )
+import RepType          ( typePrimRep1, tyConPrimRep1 )
 import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
                           SourceText(..) )
 import ForeignCall      ( CLabelString )
@@ -579,10 +579,10 @@ data PrimOpResultInfo
 getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
 getPrimOpResultInfo op
   = case (primOpInfo op) of
-      Dyadic  _ ty                        -> ReturnsPrim (typePrimRep ty)
-      Monadic _ ty                        -> ReturnsPrim (typePrimRep ty)
-      Compare _ _                         -> ReturnsPrim (tyConPrimRep intPrimTyCon)
-      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc)
+      Dyadic  _ ty                        -> ReturnsPrim (typePrimRep1 ty)
+      Monadic _ ty                        -> ReturnsPrim (typePrimRep1 ty)
+      Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)
+      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)
                          | otherwise      -> ReturnsAlg tc
                          where
                            tc = tyConAppTyCon ty
index dce0369..9806484 100644 (file)
@@ -24,10 +24,10 @@ module TysPrim(
         openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
 
         -- Kind constructors...
-        tYPETyConName, unliftedTypeKindTyConName,
+        tYPETyConName,
 
         -- Kinds
-        tYPE,
+        tYPE, primRepToRuntimeRep,
 
         funTyCon, funTyConName,
         primTyCons,
@@ -81,9 +81,9 @@ module TysPrim(
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TysWiredIn
-  ( runtimeRepTy, liftedTypeKind
-  , vecRepDataConTyCon, ptrRepUnliftedDataConTyCon
-  , voidRepDataConTy, intRepDataConTy
+  ( runtimeRepTy, unboxedTupleKind, liftedTypeKind
+  , vecRepDataConTyCon, tupleRepDataConTyCon
+  , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy
   , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy
   , floatRepDataConTy, doubleRepDataConTy
   , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
@@ -91,7 +91,8 @@ import {-# SOURCE #-} TysWiredIn
   , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy
   , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy
   , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy
-  , doubleElemRepDataConTy )
+  , doubleElemRepDataConTy
+  , mkPromotedListTy )
 
 import Var              ( TyVar, mkTyVar )
 import Name
@@ -151,7 +152,6 @@ primTyCons
     , eqReprPrimTyCon
     , eqPhantPrimTyCon
 
-    , unliftedTypeKindTyCon
     , tYPETyCon
 
 #include "primop-vector-tycons.hs-incl"
@@ -356,25 +356,26 @@ Note [TYPE and RuntimeRep]
 All types that classify values have a kind of the form (TYPE rr), where
 
     data RuntimeRep     -- Defined in ghc-prim:GHC.Types
-      = PtrRepLifted
-      | PtrRepUnlifted
+      = LiftedRep
+      | UnliftedRep
       | IntRep
       | FloatRep
       .. etc ..
 
     rr :: RuntimeRep
 
-    TYPE :: RuntimeRep -> TYPE 'PtrRepLifted  -- Built in
+    TYPE :: RuntimeRep -> TYPE 'LiftedRep  -- Built in
 
 So for example:
-    Int        :: TYPE 'PtrRepLifted
-    Array# Int :: TYPE 'PtrRepUnlifted
+    Int        :: TYPE 'LiftedRep
+    Array# Int :: TYPE 'UnliftedRep
     Int#       :: TYPE 'IntRep
     Float#     :: TYPE 'FloatRep
-    Maybe      :: TYPE 'PtrRepLifted -> TYPE 'PtrRepLifted
+    Maybe      :: TYPE 'LiftedRep -> TYPE 'LiftedRep
+    (# , #)    :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2])
 
 We abbreviate '*' specially:
-    type * = TYPE 'PtrRepLifted
+    type * = TYPE 'LiftedRep
 
 The 'rr' parameter tells us how the value is represented at runime.
 
@@ -402,22 +403,12 @@ generator never has to manipulate a value of type 'a :: TYPE rr'.
   Always inlined, and hence specialised to the call site
      (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (a :: TYPE r1) (b :: TYPE r2).
-                     a -> b -> TYPE 'UnboxedTupleRep
-     See Note [Unboxed tuple kinds]
-
-Note [Unboxed tuple kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-What kind does (# Int, Float# #) have?
-The "right" answer would be
-    TYPE ('UnboxedTupleRep [PtrRepLifted, FloatRep])
-Currently we do not do this.  We just have
-    (# Int, Float# #) :: TYPE 'UnboxedTupleRep
-which does not tell us exactly how is is represented.
+                     a -> b -> TYPE ('TupleRep '[r1, r2])
 
 Note [PrimRep and kindPrimRep]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 As part of its source code, in TyCon, GHC has
-  data PrimRep = PtrRep | IntRep | FloatRep | ...etc...
+  data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc...
 
 Notice that
  * RuntimeRep is part of the syntax tree of the program being compiled
@@ -439,8 +430,8 @@ PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo.
 
 -}
 
-tYPETyCon, unliftedTypeKindTyCon :: TyCon
-tYPETyConName, unliftedTypeKindTyConName :: Name
+tYPETyCon :: TyCon
+tYPETyConName :: Name
 
 tYPETyCon = mkKindTyCon tYPETyConName
                         (mkTemplateAnonTyConBinders [runtimeRepTy])
@@ -448,22 +439,12 @@ tYPETyCon = mkKindTyCon tYPETyConName
                         [Nominal]
                         (mkPrelTyConRepName tYPETyConName)
 
-   -- See Note [TYPE and RuntimeRep]
-   -- NB: unlifted is wired in because there is no way to parse it in
-   -- Haskell. That's the only reason for wiring it in.
-unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName
-                          [] liftedTypeKind []
-                          (tYPE (TyConApp ptrRepUnliftedDataConTyCon []))
-                          True   -- no foralls
-                          True   -- family free
-
 --------------------------
 -- ... and now their names
 
 -- If you edit these, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
 tYPETyConName             = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon
-unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
 
 mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
 mkPrimTyConName = mkPrimTcName BuiltInSyntax
@@ -494,41 +475,44 @@ pcPrimTyCon name roles rep
   = mkPrimTyCon name binders result_kind roles
   where
     binders     = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles)
-    result_kind = tYPE rr
-
-    rr = case rep of
-      VoidRep       -> voidRepDataConTy
-      PtrRep        -> TyConApp ptrRepUnliftedDataConTyCon []
-      IntRep        -> intRepDataConTy
-      WordRep       -> wordRepDataConTy
-      Int64Rep      -> int64RepDataConTy
-      Word64Rep     -> word64RepDataConTy
-      AddrRep       -> addrRepDataConTy
-      FloatRep      -> floatRepDataConTy
-      DoubleRep     -> doubleRepDataConTy
-      VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']
-        where
-          n' = case n of
-            2  -> vec2DataConTy
-            4  -> vec4DataConTy
-            8  -> vec8DataConTy
-            16 -> vec16DataConTy
-            32 -> vec32DataConTy
-            64 -> vec64DataConTy
-            _  -> pprPanic "Disallowed VecCount" (ppr n)
-
-          elem' = case elem of
-            Int8ElemRep   -> int8ElemRepDataConTy
-            Int16ElemRep  -> int16ElemRepDataConTy
-            Int32ElemRep  -> int32ElemRepDataConTy
-            Int64ElemRep  -> int64ElemRepDataConTy
-            Word8ElemRep  -> word8ElemRepDataConTy
-            Word16ElemRep -> word16ElemRepDataConTy
-            Word32ElemRep -> word32ElemRepDataConTy
-            Word64ElemRep -> word64ElemRepDataConTy
-            FloatElemRep  -> floatElemRepDataConTy
-            DoubleElemRep -> doubleElemRepDataConTy
-
+    result_kind = tYPE (primRepToRuntimeRep rep)
+
+-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep
+-- Defined here to avoid (more) module loops
+primRepToRuntimeRep :: PrimRep -> Type
+primRepToRuntimeRep rep = case rep of
+  VoidRep       -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]
+  LiftedRep     -> liftedRepDataConTy
+  UnliftedRep   -> unliftedRepDataConTy
+  IntRep        -> intRepDataConTy
+  WordRep       -> wordRepDataConTy
+  Int64Rep      -> int64RepDataConTy
+  Word64Rep     -> word64RepDataConTy
+  AddrRep       -> addrRepDataConTy
+  FloatRep      -> floatRepDataConTy
+  DoubleRep     -> doubleRepDataConTy
+  VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']
+    where
+      n' = case n of
+        2  -> vec2DataConTy
+        4  -> vec4DataConTy
+        8  -> vec8DataConTy
+        16 -> vec16DataConTy
+        32 -> vec32DataConTy
+        64 -> vec64DataConTy
+        _  -> pprPanic "Disallowed VecCount" (ppr n)
+
+      elem' = case elem of
+        Int8ElemRep   -> int8ElemRepDataConTy
+        Int16ElemRep  -> int16ElemRepDataConTy
+        Int32ElemRep  -> int32ElemRepDataConTy
+        Int64ElemRep  -> int64ElemRepDataConTy
+        Word8ElemRep  -> word8ElemRepDataConTy
+        Word16ElemRep -> word16ElemRepDataConTy
+        Word32ElemRep -> word32ElemRepDataConTy
+        Word64ElemRep -> word64ElemRepDataConTy
+        FloatElemRep  -> floatElemRepDataConTy
+        DoubleElemRep -> doubleElemRepDataConTy
 
 pcPrimTyCon0 :: Name -> PrimRep -> TyCon
 pcPrimTyCon0 name rep
@@ -799,7 +783,7 @@ proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nomina
   where
      -- Kind: forall k. k -> Void#
      binders = mkTemplateTyConBinders [liftedTypeKind] (\ks-> ks)
-     res_kind = tYPE voidRepDataConTy
+     res_kind = unboxedTupleKind []
 
 
 {- *********************************************************************
@@ -815,7 +799,7 @@ eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles
   where
     -- Kind :: forall k1 k2. k1 -> k2 -> Void#
     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)
-    res_kind = tYPE voidRepDataConTy
+    res_kind = unboxedTupleKind []
     roles    = [Nominal, Nominal, Nominal, Nominal]
 
 -- like eqPrimTyCon, but the type for *Representational* coercions
@@ -826,7 +810,7 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
   where
     -- Kind :: forall k1 k2. k1 -> k2 -> Void#
     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)
-    res_kind = tYPE voidRepDataConTy
+    res_kind = unboxedTupleKind []
     roles    = [Nominal, Nominal, Representational, Representational]
 
 -- like eqPrimTyCon, but the type for *Phantom* coercions.
@@ -837,7 +821,7 @@ eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles
   where
     -- Kind :: forall k1 k2. k1 -> k2 -> Void#
     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)
-    res_kind = tYPE voidRepDataConTy
+    res_kind = unboxedTupleKind []
     roles    = [Nominal, Nominal, Phantom, Phantom]
 
 {- *********************************************************************
@@ -849,14 +833,14 @@ eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles
 arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,
     byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon,
     smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon
-arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] PtrRep
-mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] PtrRep
-mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] PtrRep
-byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        PtrRep
-arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       PtrRep
-mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep
-smallArrayPrimTyCon        = pcPrimTyCon smallArrayPrimTyConName        [Representational] PtrRep
-smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] PtrRep
+arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] UnliftedRep
+mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] UnliftedRep
+mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] UnliftedRep
+byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        UnliftedRep
+arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       UnliftedRep
+mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep
+smallArrayPrimTyCon        = pcPrimTyCon smallArrayPrimTyConName        [Representational] UnliftedRep
+smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep
 
 mkArrayPrimTy :: Type -> Type
 mkArrayPrimTy elt           = TyConApp arrayPrimTyCon [elt]
@@ -883,7 +867,7 @@ mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt]
 ********************************************************************* -}
 
 mutVarPrimTyCon :: TyCon
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep
 
 mkMutVarPrimTy :: Type -> Type -> Type
 mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [s, elt]
@@ -897,7 +881,7 @@ mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [s, elt]
 -}
 
 mVarPrimTyCon :: TyCon
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep
 
 mkMVarPrimTy :: Type -> Type -> Type
 mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [s, elt]
@@ -911,7 +895,7 @@ mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [s, elt]
 -}
 
 tVarPrimTyCon :: TyCon
-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep
 
 mkTVarPrimTy :: Type -> Type -> Type
 mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
@@ -939,7 +923,7 @@ mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
 -}
 
 stableNamePrimTyCon :: TyCon
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] UnliftedRep
 
 mkStableNamePrimTy :: Type -> Type
 mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
@@ -953,7 +937,7 @@ mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
 -}
 
 compactPrimTyCon :: TyCon
-compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName PtrRep
+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep
 
 compactPrimTy :: Type
 compactPrimTy = mkTyConTy compactPrimTyCon
@@ -969,7 +953,7 @@ compactPrimTy = mkTyConTy compactPrimTyCon
 bcoPrimTy    :: Type
 bcoPrimTy    = mkTyConTy bcoPrimTyCon
 bcoPrimTyCon :: TyCon
-bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep
+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep
 
 {-
 ************************************************************************
@@ -980,7 +964,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep
 -}
 
 weakPrimTyCon :: TyCon
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep
 
 mkWeakPrimTy :: Type -> Type
 mkWeakPrimTy v = TyConApp weakPrimTyCon [v]
@@ -1005,7 +989,7 @@ to the thread id internally.
 threadIdPrimTy :: Type
 threadIdPrimTy    = mkTyConTy threadIdPrimTyCon
 threadIdPrimTyCon :: TyCon
-threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep
 
 {-
 ************************************************************************
index 1aea16a..66eb396 100644 (file)
@@ -62,7 +62,7 @@ module TysWiredIn (
         nilDataCon, nilDataConName, nilDataConKey,
         consDataCon_RDR, consDataCon, consDataConName,
         promotedNilDataCon, promotedConsDataCon,
-        mkListTy,
+        mkListTy, mkPromotedListTy,
 
         -- * Maybe
         maybeTyCon, maybeTyConName,
@@ -76,6 +76,8 @@ module TysWiredIn (
         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
         pairTyCon,
         unboxedUnitTyCon, unboxedUnitDataCon,
+        unboxedTupleKind, unboxedSumKind,
+
         -- ** Constraint tuples
         cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
         cTupleDataConName, cTupleDataConNames,
@@ -89,7 +91,7 @@ module TysWiredIn (
         -- * Kinds
         typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
         isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
-        starKindTyCon, starKindTyConName, unboxedTupleKind,
+        starKindTyCon, starKindTyConName,
         unicodeStarKindTyCon, unicodeStarKindTyConName,
         liftedTypeKindTyCon, constraintKindTyCon,
 
@@ -105,14 +107,13 @@ module TysWiredIn (
         -- * RuntimeRep and friends
         runtimeRepTyCon, vecCountTyCon, vecElemTyCon,
 
-        runtimeRepTy, ptrRepLiftedTy, ptrRepLiftedDataCon, ptrRepLiftedDataConTyCon,
+        runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon,
 
-        vecRepDataConTyCon, ptrRepUnliftedDataConTyCon,
+        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
 
-        voidRepDataConTy, intRepDataConTy,
+        liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
         wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
-        floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy,
-        unboxedSumRepDataConTy,
+        floatRepDataConTy, doubleRepDataConTy,
 
         vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
         vec64DataConTy,
@@ -140,6 +141,7 @@ import Id
 import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
 import Module           ( Module )
 import Type
+import RepType
 import DataCon
 import {-# SOURCE #-} ConLike
 import TyCon
@@ -340,7 +342,7 @@ It has these properties:
     environment (e.g. see Rules.matchRule for one example)
 
   * If (Any k) is the type of a value, it must be a /lifted/ value. So
-    if we have (Any @(TYPE rr)) then rr must be 'PtrRepLifted.  See
+    if we have (Any @(TYPE rr)) then rr must be 'LiftedRep.  See
     Note [TYPE and RuntimeRep] in TysPrim.  This is a convenient
     invariant, and makes isUnliftedTyCon well-defined; otherwise what
     would (isUnliftedTyCon Any) be?
@@ -401,19 +403,20 @@ liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")
 starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon
 unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon
 
-runtimeRepTyConName, vecRepDataConName :: Name
+runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name
 runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
 vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon
+tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon
+sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon
 
 -- See Note [Wiring in RuntimeRep]
 runtimeRepSimpleDataConNames :: [Name]
 runtimeRepSimpleDataConNames
   = zipWith3Lazy mk_special_dc_name
-      [ fsLit "PtrRepLifted", fsLit "PtrRepUnlifted"
-      , fsLit "VoidRep", fsLit "IntRep"
+      [ fsLit "LiftedRep", fsLit "UnliftedRep"
+      , fsLit "IntRep"
       , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep"
-      , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep"
-      , fsLit "UnboxedTupleRep", fsLit "UnboxedSumRep" ]
+      , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ]
       runtimeRepSimpleDataConKeys
       runtimeRepSimpleDataCons
 
@@ -575,10 +578,9 @@ constraintKindTyCon :: TyCon
 constraintKindTyCon = pcTyCon False constraintKindTyConName
                               Nothing [] []
 
-liftedTypeKind, constraintKind, unboxedTupleKind :: Kind
-liftedTypeKind   = tYPE ptrRepLiftedTy
+liftedTypeKind, constraintKind :: Kind
+liftedTypeKind   = tYPE liftedRepTy
 constraintKind   = mkTyConApp constraintKindTyCon []
-unboxedTupleKind = tYPE unboxedTupleRepDataConTy
 
 -- mkFunKind and mkForAllKind are defined here
 -- solely so that TyCon can use them via a SOURCE import
@@ -814,6 +816,18 @@ boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
 boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]
 unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
 
+-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed
+-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type
+-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep
+-- [IntRep, LiftedRep])@
+unboxedTupleSumKind :: TyCon -> [Type] -> Kind
+unboxedTupleSumKind tc rr_tys
+  = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])
+
+-- | Specialization of 'unboxedTupleSumKind' for tuples
+unboxedTupleKind :: [Type] -> Kind
+unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon
+
 mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
 mk_tuple Boxed arity = (tycon, tuple_con)
   where
@@ -848,15 +862,14 @@ mk_tuple Unboxed arity = (tycon, tuple_con)
     tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)
                                         (\ks -> map tYPE ks)
 
-    tc_res_kind | arity == 0 = tYPE voidRepDataConTy  -- Nullary unboxed tuple
-                | otherwise  = unboxedTupleKind
+    tc_res_kind = unboxedTupleKind rr_tys
 
     tc_arity    = arity * 2
     flavour     = UnboxedAlgTyCon
 
-    dc_tvs     = binderVars tc_binders
-    dc_arg_tys = mkTyVarTys (drop arity dc_tvs)
-    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon
+    dc_tvs               = binderVars tc_binders
+    (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)
+    tuple_con            = pcDataCon dc_name dc_tvs dc_arg_tys tycon
 
     boxity  = Unboxed
     modu    = gHC_PRIM
@@ -952,6 +965,10 @@ sumDataCon alt arity
 unboxedSumArr :: Array Int (TyCon, Array Int DataCon)
 unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]
 
+-- | Specialization of 'unboxedTupleSumKind' for sums
+unboxedSumKind :: [Type] -> Kind
+unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon
+
 -- | Create type constructor and data constructors for n-ary unboxed sum.
 mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)
 mk_sum arity = (tycon, sum_cons)
@@ -962,12 +979,11 @@ mk_sum arity = (tycon, sum_cons)
     tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)
                                         (\ks -> map tYPE ks)
 
-    tyvars = mkTemplateTyVars (replicate arity runtimeRepTy ++
-                               map (tYPE . mkTyVarTy) (take arity tyvars))
+    tyvars = binderVars tc_binders
 
-    tc_res_kind = tYPE unboxedSumRepDataConTy
+    tc_res_kind = unboxedSumKind rr_tys
 
-    open_tvs = drop arity tyvars
+    (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars)
 
     tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq
                             (ATyCon tycon) BuiltInSyntax
@@ -984,7 +1000,7 @@ mk_sum arity = (tycon, sum_cons)
                                             (AConLike (RealDataCon dc))
                                             BuiltInSyntax
                 in dc
-    tyvar_tys = mkTyVarTys open_tvs
+
     tc_uniq   = mkSumTyConUnique   arity
     dc_uniq i = mkSumDataConUnique i arity
 
@@ -1062,25 +1078,26 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon
 liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon
 
 -- Type syononyms; see Note [TYPE and RuntimeRep] in TysPrim
--- type Type = tYPE 'PtrRepLifted
--- type *    = tYPE 'PtrRepLifted
--- type *    = tYPE 'PtrRepLifted  -- Unicode variant
+-- type Type = tYPE 'LiftedRep
+-- type *    = tYPE 'LiftedRep
+-- type *    = tYPE 'LiftedRep  -- Unicode variant
 
 liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName
                                        [] liftedTypeKind []
-                                       (tYPE ptrRepLiftedTy)
+                                       (tYPE liftedRepTy)
 
 starKindTyCon         = buildSynTyCon starKindTyConName
                                        [] liftedTypeKind []
-                                       (tYPE ptrRepLiftedTy)
+                                       (tYPE liftedRepTy)
 
 unicodeStarKindTyCon  = buildSynTyCon unicodeStarKindTyConName
                                        [] liftedTypeKind []
-                                       (tYPE ptrRepLiftedTy)
+                                       (tYPE liftedRepTy)
 
 runtimeRepTyCon :: TyCon
 runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing []
-                          (vecRepDataCon : runtimeRepSimpleDataCons)
+                          (vecRepDataCon : tupleRepDataCon :
+                           sumRepDataCon : runtimeRepSimpleDataCons)
 
 vecRepDataCon :: DataCon
 vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
@@ -1091,37 +1108,64 @@ vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
     prim_rep_fun [count, elem]
       | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)
       , VecElem  e <- tyConRuntimeRepInfo (tyConAppTyCon elem)
-      = VecRep n e
+      = [VecRep n e]
     prim_rep_fun args
       = pprPanic "vecRepDataCon" (ppr args)
 
 vecRepDataConTyCon :: TyCon
 vecRepDataConTyCon = promoteDataCon vecRepDataCon
 
-ptrRepUnliftedDataConTyCon :: TyCon
-ptrRepUnliftedDataConTyCon = promoteDataCon ptrRepUnliftedDataCon
+tupleRepDataCon :: DataCon
+tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]
+                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)
+  where
+    prim_rep_fun [rr_ty_list]
+      = concatMap (runtimeRepPrimRep doc) rr_tys
+      where
+        rr_tys = extractPromotedList rr_ty_list
+        doc    = text "tupleRepDataCon" <+> ppr rr_tys
+    prim_rep_fun args
+      = pprPanic "tupleRepDataCon" (ppr args)
+
+tupleRepDataConTyCon :: TyCon
+tupleRepDataConTyCon = promoteDataCon tupleRepDataCon
+
+sumRepDataCon :: DataCon
+sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]
+                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)
+  where
+    prim_rep_fun [rr_ty_list]
+      = map slotPrimRep (ubxSumRepType prim_repss)
+      where
+        rr_tys     = extractPromotedList rr_ty_list
+        doc        = text "sumRepDataCon" <+> ppr rr_tys
+        prim_repss = map (runtimeRepPrimRep doc) rr_tys
+    prim_rep_fun args
+      = pprPanic "sumRepDataCon" (ppr args)
+
+sumRepDataConTyCon :: TyCon
+sumRepDataConTyCon = promoteDataCon sumRepDataCon
 
 -- See Note [Wiring in RuntimeRep]
 runtimeRepSimpleDataCons :: [DataCon]
-ptrRepLiftedDataCon, ptrRepUnliftedDataCon :: DataCon
-runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _)
+liftedRepDataCon :: DataCon
+runtimeRepSimpleDataCons@(liftedRepDataCon : _)
   = zipWithLazy mk_runtime_rep_dc
-    [ PtrRep, PtrRep, VoidRep, IntRep, WordRep, Int64Rep
-    , Word64Rep, AddrRep, FloatRep, DoubleRep
-    , panic "unboxed tuple PrimRep", panic "unboxed sum PrimRep" ]
+    [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep
+    , Word64Rep, AddrRep, FloatRep, DoubleRep ]
     runtimeRepSimpleDataConNames
   where
     mk_runtime_rep_dc primrep name
-      = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> primrep))
+      = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))
 
 -- See Note [Wiring in RuntimeRep]
-voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
-  word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy,
-  unboxedTupleRepDataConTy, unboxedSumRepDataConTy :: Type
-[_, _, voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
-   word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy,
-   unboxedTupleRepDataConTy, unboxedSumRepDataConTy] = map (mkTyConTy . promoteDataCon)
-                                   runtimeRepSimpleDataCons
+liftedRepDataConTy, unliftedRepDataConTy,
+  intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
+  word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
+[liftedRepDataConTy, unliftedRepDataConTy,
+   intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
+   word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
+  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
 
 vecCountTyCon :: TyCon
 vecCountTyCon = pcNonEnumTyCon vecCountTyConName Nothing []
@@ -1167,12 +1211,12 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
   doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)
                                 vecElemDataCons
 
-ptrRepLiftedDataConTyCon :: TyCon
-ptrRepLiftedDataConTyCon = promoteDataCon ptrRepLiftedDataCon
+liftedRepDataConTyCon :: TyCon
+liftedRepDataConTyCon = promoteDataCon liftedRepDataCon
 
--- The type ('PtrRepLifted)
-ptrRepLiftedTy :: Type
-ptrRepLiftedTy = mkTyConTy ptrRepLiftedDataConTyCon
+-- The type ('LiftedRep)
+liftedRepTy :: Type
+liftedRepTy = mkTyConTy liftedRepDataConTyCon
 
 {- *********************************************************************
 *                                                                      *
@@ -1570,3 +1614,36 @@ promotedGTDataCon     = promoteDataCon gtDataCon
 promotedConsDataCon, promotedNilDataCon :: TyCon
 promotedConsDataCon   = promoteDataCon consDataCon
 promotedNilDataCon    = promoteDataCon nilDataCon
+
+-- | Make a *promoted* list.
+mkPromotedListTy :: Kind   -- ^ of the elements of the list
+                 -> [Type] -- ^ elements
+                 -> Type
+mkPromotedListTy k tys
+  = foldr cons nil tys
+  where
+    cons :: Type  -- element
+         -> Type  -- list
+         -> Type
+    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]
+
+    nil :: Type
+    nil = mkTyConApp promotedNilDataCon [k]
+
+-- | Extract the elements of a promoted list. Panics if the type is not a
+-- promoted list
+extractPromotedList :: Type    -- ^ The promoted list
+                    -> [Type]
+extractPromotedList tys = go tys
+  where
+    go list_ty
+      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty
+      = ASSERT( tc `hasKey` consDataConKey )
+        t : go ts
+
+      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty
+      = ASSERT( tc `hasKey` nilDataConKey )
+        []
+
+      | otherwise
+      = pprPanic "extractPromotedList" (ppr tys)
index 7b7229c..26e4201 100644 (file)
@@ -17,13 +17,12 @@ constraintKind :: Kind
 
 runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon
 runtimeRepTy :: Type
-ptrRepLiftedTy :: Type
 
-ptrRepLiftedDataConTyCon, ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon
+liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon
 
-voidRepDataConTy, intRepDataConTy,
+liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
   wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
-  floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy :: Type
+  floatRepDataConTy, doubleRepDataConTy :: Type
 
 vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
   vec64DataConTy :: Type
@@ -34,3 +33,5 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
   doubleElemRepDataConTy :: Type
 
 anyTypeOfKind :: Kind -> Type
+unboxedTupleKind :: [Type] -> Type
+mkPromotedListTy :: Type -> [Type] -> Type
index 06ff71e..0b81f29 100644 (file)
@@ -65,6 +65,7 @@ module SetLevels (
 import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
+                        , isExprLevPoly
                         , exprOkForSpeculation
                         , collectMakeStaticArgs
                         )
@@ -82,7 +83,6 @@ import Demand           ( StrictSig, increaseStrictSigArity )
 import Name             ( getOccName, mkSystemVarName )
 import OccName          ( occNameString )
 import Type             ( isUnliftedType, Type, mkLamTypes, splitTyConApp_maybe )
-import Kind             ( isLevityPolymorphic, typeKind )
 import BasicTypes       ( Arity, RecFlag(..) )
 import DataCon          ( dataConOrigResTy )
 import TysWiredIn
@@ -485,7 +485,7 @@ lvlMFE True env e@(_, AnnCase {})
 lvlMFE strict_ctxt env ann_expr
   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
          -- Only floating to the top level is allowed.
-  || isLevityPolymorphic (typeKind expr_ty)
+  || isExprLevPoly expr
          -- We can't let-bind levity polymorphic expressions
          -- See Note [Levity polymorphism invariants] in CoreSyn
   || notWorthFloating expr abs_vars
index 59ac440..8a26220 100644 (file)
@@ -691,7 +691,7 @@ substCo env co = Coercion.substCo (getTCvSubst env) co
 substIdType :: SimplEnv -> Id -> Id
 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
   |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
-  || isEmptyVarSet (tyCoVarsOfType old_ty)
+  || noFreeVarsOfType old_ty
   = id
   | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
                 -- The tyCoVarsOfType is cheaper than it looks
index 4812e7e..bdc3634 100644 (file)
@@ -450,15 +450,22 @@ mkArgInfo fun rules n_val_args call_cont
     -- add_type_str is done repeatedly (for each call); might be better
     -- once-for-all in the function
     -- But beware primops/datacons with no strictness
-    add_type_str _ [] = []
-    add_type_str fun_ty strs            -- Look through foralls
-        | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions
-        = add_type_str fun_ty' strs
-    add_type_str fun_ty (str:strs)      -- Add strict-type info
-        | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
-        = (str || isStrictType arg_ty) : add_type_str fun_ty' strs
-    add_type_str _ strs
-        = strs
+
+    add_type_str
+      = go
+      where
+        go _ [] = []
+        go fun_ty strs            -- Look through foralls
+            | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions
+            = go fun_ty' strs
+        go fun_ty (str:strs)      -- Add strict-type info
+            | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
+            = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs
+               -- If the type is levity-polymorphic, we can't know whether it's
+               -- strict. isLiftedType_maybe will return Just False only when
+               -- we're sure the type is unlifted.
+        go _ strs
+            = strs
 
 {- Note [Unsaturated functions]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index fb31784..2c8ff5e 100644 (file)
@@ -1157,6 +1157,10 @@ simplCast env body co0 cont0
        addCoerce co (ApplyToVal { sc_arg = arg, sc_env = arg_se
                                 , sc_dup = dup, sc_cont = tail })
          | Just (co1, co2) <- pushCoValArg co
+         , Pair _ new_ty <- coercionKind co1
+         , not (isTypeLevPoly new_ty)  -- without this check, we get a lev-poly arg
+                                       -- See Note [Levity polymorphism invariants] in CoreSyn
+                                       -- test: typecheck/should_run/EtaExpandLevPoly
          = do { (dup', arg_se', arg') <- simplArg env dup arg_se arg
                    -- When we build the ApplyTo we can't mix the OutCoercion
                    -- 'co' with the InExpr 'arg', so we simplify
index 6309aec..f59a854 100644 (file)
@@ -2,37 +2,40 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module RepType
-  ( -- * Code generator views onto Types
+  (
+    -- * Code generator views onto Types
     UnaryType, NvUnaryType, isNvUnaryType,
-    RepType(..), repType, repTypeArgs, isUnaryRep, isMultiRep,
+    unwrapType,
 
     -- * Predicates on types
-    isVoidTy, typePrimRep,
+    isVoidTy,
 
     -- * Type representation for the code generator
-    countConRepArgs, idFunRepArity, tyConPrimRep,
+    typePrimRep, typePrimRep1,
+    runtimeRepPrimRep, typePrimRepArgs,
+    PrimRep(..), primRepToType,
+    countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,
 
     -- * Unboxed sum representation type
-    ubxSumRepType, layout, typeSlotTy, SlotTy (..), slotTyToType,
-    slotPrimRep, repTypeSlots
+    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
+    slotPrimRep, primRepSlot
   ) where
 
 #include "HsVersions.h"
 
 import BasicTypes (Arity, RepArity)
 import DataCon
-import Id
 import Outputable
 import PrelNames
+import Coercion
 import TyCon
 import TyCoRep
 import Type
-import TysPrim
-import TysWiredIn
 import Util
+import TysPrim
+import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )
 
 import Data.List (foldl', sort)
-import Data.Maybe (maybeToList)
 import qualified Data.IntSet as IS
 
 {- **********************************************************************
@@ -49,101 +52,64 @@ type UnaryType   = Type
      --   NvUnaryType : never an unboxed tuple or sum, or void
      --
      --   UnaryType   : never an unboxed tuple or sum;
-     --                 can be Void# (but not (# #))
+     --                 can be Void# or (# #)
 
 isNvUnaryType :: Type -> Bool
 isNvUnaryType ty
-  = case repType ty of
-      UnaryRep _  -> True
-      MultiRep ss -> not (null ss)
-
-data RepType
-  = MultiRep [SlotTy]     -- Represented by multiple values (e.g. unboxed tuple or sum)
-  | UnaryRep NvUnaryType  -- Represented by a single value; but never Void#, or any
-                          -- other zero-width type (isVoidTy)
-
-instance Outputable RepType where
-  ppr (MultiRep slots) = text "MultiRep" <+> ppr slots
-  ppr (UnaryRep ty)    = text "UnaryRep" <+> ppr ty
-
-isMultiRep :: RepType -> Bool
-isMultiRep (MultiRep _) = True
-isMultiRep _            = False
-
-isUnaryRep :: RepType -> Bool
-isUnaryRep (UnaryRep _) = True
-isUnaryRep _            = False
+  | [_] <- typePrimRep ty
+  = True
+  | otherwise
+  = False
 
 -- INVARIANT: the result list is never empty.
-repTypeArgs :: Type -> [UnaryType]
-repTypeArgs ty = case repType ty of
-                    MultiRep []    -> [voidPrimTy]
-                    MultiRep slots -> map slotTyToType slots
-                    UnaryRep ty    -> [ty]
-
-repTypeSlots :: RepType -> [SlotTy]
-repTypeSlots (MultiRep slots) = slots
-repTypeSlots (UnaryRep ty)    = maybeToList (typeSlotTy ty)
-
--- | 'repType' figure out how a type will be represented at runtime. It looks
--- through
---
---      1. For-alls
---      2. Synonyms
---      3. Predicates
---      4. All newtypes, including recursive ones, but not newtype families
---      5. Casts
---
-repType :: Type -> RepType
-repType ty
-  = go initRecTc ty
+typePrimRepArgs :: Type -> [PrimRep]
+typePrimRepArgs ty
+  | [] <- reps
+  = [VoidRep]
+  | otherwise
+  = reps
   where
-    go :: RecTcChecker -> Type -> RepType
-    go rec_nts ty                       -- Expand predicates and synonyms
-      | Just ty' <- coreView ty
-      = go rec_nts ty'
-
-    go rec_nts (ForAllTy _ ty2)         -- Drop type foralls
-      = go rec_nts ty2
-
-    go rec_nts ty@(TyConApp tc tys)     -- Expand newtypes
-      | isNewTyCon tc
-      , tys `lengthAtLeast` tyConArity tc
-      , Just rec_nts' <- checkRecTc rec_nts tc   -- See Note [Expanding newtypes] in TyCon
-      = go rec_nts' (newTyConInstRhs tc tys)
-
-      | isUnboxedTupleTyCon tc
-      = MultiRep (concatMap (repTypeSlots . go rec_nts) non_rr_tys)
-
-      | isUnboxedSumTyCon tc
-      = MultiRep (ubxSumRepType non_rr_tys)
-
-      | isVoidTy ty
-      = MultiRep []
-      where
-        -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-        non_rr_tys = dropRuntimeRepArgs tys
-
-    go rec_nts (CastTy ty _)
-      = go rec_nts ty
-
-    go _ ty@(CoercionTy _)
-      = pprPanic "repType" (ppr ty)
-
-    go _ ty = UnaryRep ty
-
-
-idFunRepArity :: Id -> RepArity
-idFunRepArity x = countFunRepArgs (idArity x) (idType x)
+    reps = typePrimRep ty
+
+-- | Gets rid of the stuff that prevents us from understanding the
+-- runtime representation of a type. Including:
+--   1. Casts
+--   2. Newtypes
+--   3. Foralls
+--   4. Synonyms
+-- But not type/data families, because we don't have the envs to hand.
+unwrapType :: Type -> Type
+unwrapType ty
+  | Just (_, unwrapped)
+      <- topNormaliseTypeX stepper mappend inner_ty
+  = unwrapped
+  | otherwise
+  = inner_ty
+  where
+    inner_ty = go ty
+
+    go t | Just t' <- coreView t = go t'
+    go (ForAllTy _ t)            = go t
+    go (CastTy t _)              = go t
+    go t                         = t
+
+     -- cf. Coercion.unwrapNewTypeStepper
+    stepper rec_nts tc tys
+      | Just (ty', _) <- instNewTyCon_maybe tc tys
+      = case checkRecTc rec_nts tc of
+          Just rec_nts' -> NS_Step rec_nts' (go ty') ()
+          Nothing       -> NS_Abort   -- infinite newtypes
+      | otherwise
+      = NS_Done
 
 countFunRepArgs :: Arity -> Type -> RepArity
 countFunRepArgs 0 _
   = 0
 countFunRepArgs n ty
-  | UnaryRep (FunTy arg res) <- repType ty
-  = length (repTypeArgs arg) + countFunRepArgs (n - 1) res
+  | FunTy arg res <- unwrapType ty
+  = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res
   | otherwise
-  = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty))
+  = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
 
 countConRepArgs :: DataCon -> RepArity
 countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
@@ -152,14 +118,14 @@ countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
     go 0 _
       = 0
     go n ty
-      | UnaryRep (FunTy arg res) <- repType ty
-      = length (repTypeSlots (repType arg)) + go (n - 1) res
+      | FunTy arg res <- unwrapType ty
+      = length (typePrimRep arg) + go (n - 1) res
       | otherwise
-      = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty))
+      = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
 
 -- | True if the type has zero width.
 isVoidTy :: Type -> Bool
-isVoidTy ty = typePrimRep ty == VoidRep
+isVoidTy = null . typePrimRep
 
 
 {- **********************************************************************
@@ -176,52 +142,59 @@ type SortedSlotTys = [SlotTy]
 --
 -- E.g.
 --
---   (# Int | Maybe Int | (# Int, Bool #) #)
+--   (# Int# | Maybe Int | (# Int#, Float# #) #)
 --
--- We call `ubxSumRepType [ Int, Maybe Int, (# Int,Bool #) ]`,
--- which returns [Tag#, PtrSlot, PtrSlot]
+-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`,
+-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot]
 --
 -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head
 -- of the list we have the slot for the tag.
-ubxSumRepType :: [Type] -> [SlotTy]
-ubxSumRepType constrs0 =
-  ASSERT2( length constrs0 > 1, ppr constrs0 ) -- otherwise it isn't a sum type
-  let
-    combine_alts :: [SortedSlotTys]  -- slots of constructors
-                 -> SortedSlotTys    -- final slots
-    combine_alts constrs = foldl' merge [] constrs
-
-    merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
-    merge existing_slots []
-      = existing_slots
-    merge [] needed_slots
-      = needed_slots
-    merge (es : ess) (s : ss)
-      | Just s' <- s `fitsIn` es
-      = -- found a slot, use it
-        s' : merge ess ss
-      | s < es
-      = -- we need a new slot and this is the right place for it
-        s : merge (es : ess) ss
-      | otherwise
-      = -- keep searching for a slot
-        es : merge ess (s : ss)
-
-    -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
-    rep :: Type -> SortedSlotTys
-    rep ty = sort (repTypeSlots (repType ty))
-
-    sumRep = WordSlot : combine_alts (map rep constrs0)
-             -- WordSlot: for the tag of the sum
-  in
-    sumRep
-
-layout :: SortedSlotTys -- Layout of sum. Does not include tag.
-                        -- We assume that they are in increasing order
-       -> [SlotTy]      -- Slot types of things we want to map to locations in the
-                        -- sum layout
-       -> [Int]         -- Where to map 'things' in the sum layout
-layout sum_slots0 arg_slots0 =
+ubxSumRepType :: [[PrimRep]] -> [SlotTy]
+ubxSumRepType constrs0
+  -- These first two cases never classify an actual unboxed sum, which always
+  -- has at least two disjuncts. But it could happen if a user writes, e.g.,
+  -- forall (a :: TYPE (SumRep [IntRep])). ...
+  -- which could never be instantiated. We still don't want to panic.
+  | length constrs0 < 2
+  = [WordSlot]
+
+  | otherwise
+  = let
+      combine_alts :: [SortedSlotTys]  -- slots of constructors
+                   -> SortedSlotTys    -- final slots
+      combine_alts constrs = foldl' merge [] constrs
+
+      merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
+      merge existing_slots []
+        = existing_slots
+      merge [] needed_slots
+        = needed_slots
+      merge (es : ess) (s : ss)
+        | Just s' <- s `fitsIn` es
+        = -- found a slot, use it
+          s' : merge ess ss
+        | s < es
+        = -- we need a new slot and this is the right place for it
+          s : merge (es : ess) ss
+        | otherwise
+        = -- keep searching for a slot
+          es : merge ess (s : ss)
+
+      -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
+      rep :: [PrimRep] -> SortedSlotTys
+      rep ty = sort (map primRepSlot ty)
+
+      sumRep = WordSlot : combine_alts (map rep constrs0)
+               -- WordSlot: for the tag of the sum
+    in
+      sumRep
+
+layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag.
+                              -- We assume that they are in increasing order
+             -> [SlotTy]      -- Slot types of things we want to map to locations in the
+                              -- sum layout
+             -> [Int]         -- Where to map 'things' in the sum layout
+layoutUbxSum sum_slots0 arg_slots0 =
     go arg_slots0 IS.empty
   where
     go :: [SlotTy] -> IS.IntSet -> [Int]
@@ -273,11 +246,12 @@ typeSlotTy ty
   | isVoidTy ty
   = Nothing
   | otherwise
-  = Just (primRepSlot (typePrimRep ty))
+  = Just (primRepSlot (typePrimRep1 ty))
 
 primRepSlot :: PrimRep -> SlotTy
 primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")
-primRepSlot PtrRep      = PtrSlot
+primRepSlot LiftedRep   = PtrSlot
+primRepSlot UnliftedRep = PtrSlot
 primRepSlot IntRep      = WordSlot
 primRepSlot WordRep     = WordSlot
 primRepSlot Int64Rep    = Word64Slot
@@ -287,16 +261,8 @@ primRepSlot FloatRep    = FloatSlot
 primRepSlot DoubleRep   = DoubleSlot
 primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")
 
--- Used when unarising sum binders (need to give unarised Ids types)
-slotTyToType :: SlotTy -> Type
-slotTyToType PtrSlot    = anyTypeOfKind liftedTypeKind
-slotTyToType Word64Slot = int64PrimTy
-slotTyToType WordSlot   = intPrimTy
-slotTyToType DoubleSlot = doublePrimTy
-slotTyToType FloatSlot  = floatPrimTy
-
 slotPrimRep :: SlotTy -> PrimRep
-slotPrimRep PtrSlot     = PtrRep
+slotPrimRep PtrSlot     = LiftedRep   -- choice between lifted & unlifted seems arbitrary
 slotPrimRep Word64Slot  = Word64Rep
 slotPrimRep WordSlot    = WordRep
 slotPrimRep DoubleSlot  = DoubleRep
@@ -332,41 +298,68 @@ fitsIn ty1 ty2
 *                                                                       *
 ********************************************************************** -}
 
--- | Discovers the primitive representation of a more abstract 'UnaryType'
-typePrimRep :: HasDebugCallStack => UnaryType -> PrimRep
-typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty))
+-- | Discovers the primitive representation of a 'Type'. Returns
+-- a list of 'PrimRep': it's a list because of the possibility of
+-- no runtime representation (void) or multiple (unboxed tuple/sum)
+typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
+typePrimRep ty = kindPrimRep (text "typePrimRep" <+>
+                              parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
                              (typeKind ty)
 
+-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
+-- an empty list of PrimReps becomes a VoidRep
+typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
+typePrimRep1 ty = case typePrimRep ty of
+  []    -> VoidRep
+  [rep] -> rep
+  _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))
+
 -- | Find the runtime representation of a 'TyCon'. Defined here to
--- avoid module loops. Do not call this on unboxed tuples or sums,
--- because they don't /have/ a runtime representation
-tyConPrimRep :: HasDebugCallStack => TyCon -> PrimRep
+-- avoid module loops. Returns a list of the register shapes necessary.
+tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
 tyConPrimRep tc
-  = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc )
-    ASSERT2( not (isUnboxedSumTyCon   tc), ppr tc )
-    kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
+  = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
                 res_kind
   where
     res_kind = tyConResKind tc
 
--- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep'
+-- | Like 'tyConPrimRep', but assumed that there is precisely zero or
+-- one 'PrimRep' output
+tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
+tyConPrimRep1 tc = case tyConPrimRep tc of
+  []    -> VoidRep
+  [rep] -> rep
+  _     -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))
+
+-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
 -- of values of types of this kind.
-kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> PrimRep
+kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
 kindPrimRep doc ki
   | Just ki' <- coreViewOneStarKind ki
   = kindPrimRep doc ki'
-kindPrimRep _ (TyConApp typ [runtime_rep])
+kindPrimRep doc (TyConApp typ [runtime_rep])
   = ASSERT( typ `hasKey` tYPETyConKey )
-    go runtime_rep
-  where
-    go rr
-      | Just rr' <- coreView rr
-      = go rr'
-    go (TyConApp rr_dc args)
-      | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
-      = fun args
-    go rr
-      = pprPanic "kindPrimRep.go" (ppr rr)
+    runtimeRepPrimRep doc runtime_rep
 kindPrimRep doc ki
-  = WARN( True, text "kindPrimRep defaulting to PtrRep on" <+> ppr ki $$ doc )
-    PtrRep  -- this can happen legitimately for, e.g., Any
+  = pprPanic "kindPrimRep" (ppr ki $$ doc)
+
+  -- TODO (RAE): Remove:
+  -- WARN( True, text "kindPrimRep defaulting to LiftedRep on" <+> ppr ki $$ doc )
+  -- [LiftedRep]  -- this can happen legitimately for, e.g., Any
+
+-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
+-- it encodes.
+runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
+runtimeRepPrimRep doc rr_ty
+  | Just rr_ty' <- coreView rr_ty
+  = runtimeRepPrimRep doc rr_ty'
+  | TyConApp rr_dc args <- rr_ty
+  , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
+  = fun args
+  | otherwise
+  = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)
+
+-- | Convert a PrimRep back to a Type. Used only in the unariser to give types
+-- to fresh Ids. Really, only the type's representation matters.
+primRepToType :: PrimRep -> Type
+primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep
index e8ba200..aa42586 100644 (file)
@@ -209,7 +209,7 @@ import Outputable
 import RepType
 import StgSyn
 import Type
-import TysPrim (intPrimTyCon, intPrimTy)
+import TysPrim (intPrimTy)
 import TysWiredIn
 import UniqSupply
 import Util
@@ -225,7 +225,7 @@ import qualified Data.IntMap as IM
 --
 --   x :-> MultiVal [a,b,c] in rho
 --
--- iff  x's repType is a MultiRep, or equivalently
+-- iff  x's typePrimRep is not a singleton, or equivalently
 --      x's type is an unboxed tuple, sum or void.
 --
 --    x :-> UnaryVal x'
@@ -487,24 +487,24 @@ mapTupleIdBinders
 mapTupleIdBinders ids args0 rho0
   = ASSERT(not (any (isVoidTy . stgArgType) args0))
     let
-      ids_unarised :: [(Id, RepType)]
-      ids_unarised = map (\id -> (id, repType (idType id))) ids
+      ids_unarised :: [(Id, [PrimRep])]
+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
 
-      map_ids :: UnariseEnv -> [(Id, RepType)] -> [StgArg] -> UnariseEnv
+      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
       map_ids rho [] _  = rho
-      map_ids rho ((x, x_rep) : xs) args =
+      map_ids rho ((x, x_reps) : xs) args =
         let
-          x_arity = length (repTypeSlots x_rep)
+          x_arity = length x_reps
           (x_args, args') =
             ASSERT(args `lengthAtLeast` x_arity)
             splitAt x_arity args
 
           rho'
-            | isMultiRep x_rep
-            = extendRho rho x (MultiVal x_args)
-            | otherwise
+            | x_arity == 1
             = ASSERT(x_args `lengthIs` 1)
               extendRho rho x (UnaryVal (head x_args))
+            | otherwise
+            = extendRho rho x (MultiVal x_args)
         in
           map_ids rho' xs args'
     in
@@ -521,9 +521,9 @@ mapSumIdBinders
 mapSumIdBinders [id] args rho0
   = ASSERT(not (any (isVoidTy . stgArgType) args))
     let
-      arg_slots = concatMap (repTypeSlots . repType . stgArgType) args
-      id_slots  = repTypeSlots (repType (idType id))
-      layout1   = layout arg_slots id_slots
+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+      id_slots  = map primRepSlot $ typePrimRep (idType id)
+      layout1   = layoutUbxSum arg_slots id_slots
     in
       if isMultiValBndr id
         then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
@@ -550,12 +550,12 @@ mkUbxSum
   -> [OutStgArg]  -- Final tuple arguments
 mkUbxSum dc ty_args args0
   = let
-      (_ : sum_slots) = ubxSumRepType ty_args
+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
         -- drop tag slot
 
       tag = dataConTag dc
 
-      layout'  = layout sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
+      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
       tag_arg  = StgLitArg (MachInt (fromIntegral tag))
       arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
 
@@ -656,12 +656,12 @@ unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder r
 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
 -- Result list of binders is never empty
 unariseFunArgBinder rho x  =
-  case repType (idType x) of
-    UnaryRep _     -> return (rho, [x])
-    MultiRep []    -> return (extendRho rho x (MultiVal []), [voidArgId])
-                            -- NB: do not remove void binders
-    MultiRep slots -> do
-      xs <- mkIds (mkFastString "us") (map slotTyToType slots)
+  case typePrimRep (idType x) of
+    []   -> return (extendRho rho x (MultiVal []), [voidArgId])
+                           -- NB: do not remove void binders
+    [_]  -> return (rho, [x])
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
       return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
 
 --------------------------------------------------------------------------------
@@ -687,10 +687,10 @@ unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder r
 
 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
 unariseConArgBinder rho x =
-  case repType (idType x) of
-    UnaryRep _     -> return (rho, [x])
-    MultiRep slots -> do
-      xs <- mkIds (mkFastString "us") (map slotTyToType slots)
+  case typePrimRep (idType x) of
+    [_]  -> return (rho, [x])
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
       return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
 
 unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
@@ -720,7 +720,11 @@ mkId :: FastString -> UnaryType -> UniqSM Id
 mkId = mkSysLocalOrCoVarM
 
 isMultiValBndr :: Id -> Bool
-isMultiValBndr = isMultiRep . repType . idType
+isMultiValBndr id
+  | [_] <- typePrimRep (idType id)
+  = False
+  | otherwise
+  = True
 
 isUnboxedSumBndr :: Id -> Bool
 isUnboxedSumBndr = isUnboxedSumType . idType
@@ -732,7 +736,7 @@ mkTuple :: [StgArg] -> StgExpr
 mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
 
 tagAltTy :: AltType
-tagAltTy = PrimAlt intPrimTyCon
+tagAltTy = PrimAlt IntRep
 
 tagTy :: Type
 tagTy = intPrimTy
index 5531d31..dcb923a 100644 (file)
@@ -472,16 +472,25 @@ coreToStgExpr (Let bind body) = do
 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
 
 mkStgAltType :: Id -> [CoreAlt] -> AltType
-mkStgAltType bndr alts = case repType (idType bndr) of
-    UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
-        Just tc | isUnliftedTyCon tc -> PrimAlt tc
-                | isAbstractTyCon tc -> look_for_better_tycon
-                | isAlgTyCon tc      -> AlgAlt tc
-                | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
-                                        PolyAlt
-        Nothing                      -> PolyAlt
-    MultiRep slots -> MultiValAlt (length slots)
+mkStgAltType bndr alts
+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
+
+  | otherwise
+  = case prim_reps of
+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
+        Just tc
+          | isAbstractTyCon tc -> look_for_better_tycon
+          | isAlgTyCon tc      -> AlgAlt tc
+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+                                  PolyAlt
+        Nothing                -> PolyAlt
+      [unlifted] -> PrimAlt unlifted
+      not_unary  -> MultiValAlt (length not_unary)
   where
+   bndr_ty   = idType bndr
+   prim_reps = typePrimRep bndr_ty
+
    _is_poly_alt_tycon tc
         =  isFunTyCon tc
         || isPrimTyCon tc   -- "Any" is lifted but primitive
@@ -650,8 +659,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         arg_ty = exprType arg
         stg_arg_ty = stgArgType stg_arg
         bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
-                || (map typePrimRep (repTypeArgs arg_ty)
-                        /= map typePrimRep (repTypeArgs stg_arg_ty))
+                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
         -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
         -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
         -- we can treat an unlifted value as lifted.  But the other way round
@@ -802,7 +810,8 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
   | StgConApp con args _ <- unticked_rhs
   , not (con_updateable con args)
   = -- CorePrep does this right, but just to make sure
-    ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+           , ppr bndr $$ ppr con $$ ppr args)
     StgRhsCon noCCS con args
   | otherwise
   = StgRhsClosure noCCS binder_info
index 0dba8d8..e31e7ae 100644 (file)
@@ -196,21 +196,19 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
 
     in_scope <- MaybeT $ liftM Just $
      case alts_type of
-        AlgAlt tc     -> check_bndr tc >> return True
-        PrimAlt tc    -> check_bndr tc >> return True
+        AlgAlt tc     -> check_bndr (tyConPrimRep tc) >> return True
+        PrimAlt rep   -> check_bndr [rep]             >> return True
         MultiValAlt _ -> return False -- Binder is always dead in this case
         PolyAlt       -> return True
 
     MaybeT $ addInScopeVars [bndr | in_scope] $
              lintStgAlts alts scrut_ty
   where
-    scrut_ty          = idType bndr
-    UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple or sum
-    check_bndr tc = case tyConAppTyCon_maybe scrut_rep of
-                        Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
-                        Nothing      -> addErrL bad_bndr
+    scrut_ty        = idType bndr
+    scrut_reps      = typePrimRep scrut_ty
+    check_bndr reps = checkL (scrut_reps == reps) bad_bndr
                   where
-                     bad_bndr = mkDefltMsg bndr tc
+                     bad_bndr = mkDefltMsg bndr reps
 
 lintStgAlts :: [StgAlt]
             -> Type               -- Type of scrutinee
@@ -418,20 +416,18 @@ stgEqType :: Type -> Type -> Bool
 -- Fundamentally this is a losing battle because of unsafeCoerce
 
 stgEqType orig_ty1 orig_ty2
-  = gos (repType orig_ty1) (repType orig_ty2)
+  = gos (typePrimRep orig_ty1) (typePrimRep orig_ty2)
   where
-    gos :: RepType -> RepType -> Bool
-    gos (MultiRep slots1) (MultiRep slots2)
-      = slots1 == slots2
-    gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2
-    gos _ _ = False
+    gos :: [PrimRep] -> [PrimRep] -> Bool
+    gos [_]   [_]   = go orig_ty1 orig_ty2
+    gos reps1 reps2 = reps1 == reps2
 
     go :: UnaryType -> UnaryType -> Bool
     go ty1 ty2
       | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
       , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
       , let res = if tc1 == tc2
-                  then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2)
+                  then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` typePrimRep) tc_args1 tc_args2)
                   else  -- TyCons don't match; but don't bleat if either is a
                         -- family TyCon because a coercion might have made it
                         -- equal to something else
@@ -462,10 +458,10 @@ _mkCaseAltMsg _alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
             (Outputable.empty) -- LATER: ppr alts
 
-mkDefltMsg :: Id -> TyCon -> MsgDoc
-mkDefltMsg bndr tc
-  = ($$) (text "Binder of a case expression doesn't match type of scrutinee:")
-         (ppr bndr $$ ppr (idType bndr) $$ ppr tc)
+mkDefltMsg :: Id -> [PrimRep] -> MsgDoc
+mkDefltMsg bndr reps
+  = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")
+         (ppr bndr $$ ppr (idType bndr) $$ ppr reps)
 
 mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
 mkFunAppMsg fun_ty arg_tys expr
index 64c8448..48e836c 100644 (file)
@@ -62,7 +62,7 @@ import PprCore     ( {- instances -} )
 import PrimOp      ( PrimOp, PrimCall )
 import TyCon       ( PrimRep(..), TyCon )
 import Type        ( Type )
-import RepType     ( typePrimRep )
+import RepType     ( typePrimRep1 )
 import Unique      ( Unique )
 import Util
 
@@ -104,10 +104,10 @@ isDllConApp dflags this_mod con args
     = isDllName dflags this_mod (dataConName con) || any is_dll_arg args
  | otherwise = False
   where
-    -- NB: typePrimRep is legit because any free variables won't have
+    -- NB: typePrimRep1 is legit because any free variables won't have
     -- unlifted type (there are no unlifted things at top level)
     is_dll_arg :: StgArg -> Bool
-    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
                              && isDllName dflags this_mod (idName v)
     is_dll_arg _             = False
 
@@ -124,9 +124,10 @@ isDllConApp dflags this_mod con args
 --    $WT1 = T1 Int (Coercion (Refl Int))
 -- The coercion argument here gets VoidRep
 isAddrRep :: PrimRep -> Bool
-isAddrRep AddrRep = True
-isAddrRep PtrRep  = True
-isAddrRep _       = False
+isAddrRep AddrRep     = True
+isAddrRep LiftedRep   = True
+isAddrRep UnliftedRep = True
+isAddrRep _           = False
 
 -- | Type of an @StgArg@
 --
@@ -533,10 +534,11 @@ type GenStgAlt bndr occ
      GenStgExpr bndr occ)       -- ...right-hand side.
 
 data AltType
-  = PolyAlt             -- Polymorphic (a type variable)
+  = PolyAlt             -- Polymorphic (a lifted type variable)
   | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
+                        -- the arity could indeed be 1 for unary unboxed tuple
   | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
-  | PrimAlt     TyCon   -- Primitive data type; the AltCons will be LitAlts
+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
 
 {-
 ************************************************************************
index 2206480..2ad00d5 100644 (file)
@@ -9,7 +9,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
-                 tcValBinds, tcHsBootSigs, tcPolyCheck,
+                 tcHsBootSigs, tcPolyCheck,
                  tcVectDecls, addTypecheckedBinds,
                  chooseInferredQuantifiers,
                  badBootDeclErr ) where
@@ -57,7 +57,7 @@ import Maybes
 import Util
 import BasicTypes
 import Outputable
-import PrelNames( gHC_PRIM, ipClassName )
+import PrelNames( ipClassName )
 import TcValidity (checkValidType)
 import Unique (getUnique)
 import UniqFM
@@ -399,7 +399,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
 
     tc_sub_group rec_tc binds =
-      tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
+      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
 
 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
 recursivePatSynErr binds
@@ -430,7 +430,7 @@ tc_single _top_lvl sig_fn _prag_fn
         Just                 _  -> panic "tc_single"
 
 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
-  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
+  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
                                       NonRecursive NonRecursive
                                       closed
                                       [lbind]
@@ -461,7 +461,7 @@ mkEdges sig_fn binds
                                      , bndr <- collectHsBindBinders bind ]
 
 ------------------------
-tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
+tcPolyBinds :: TcSigFun -> TcPragEnv
             -> RecFlag         -- Whether the group is really recursive
             -> RecFlag         -- Whether it's recursive after breaking
                                -- dependencies based on type signatures
@@ -480,7 +480,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
 -- Knows nothing about the scope of the bindings
 -- None of the bindings are pattern synonyms
 
-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
+tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
   = setSrcSpan loc                              $
     recoverM (recoveryCode binder_names sig_fn) $ do
         -- Set up main recover; take advantage of any type sigs
@@ -490,15 +490,11 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
     ; dflags   <- getDynFlags
     ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
     ; traceTc "Generalisation plan" (ppr plan)
-    ; result@(tc_binds, poly_ids) <- case plan of
+    ; result@(_, poly_ids) <- case plan of
          NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
          InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
 
-        -- Check whether strict bindings are ok
-        -- These must be non-recursive etc, and are not generalised
-        -- They desugar to a case expression in the end
-    ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
     ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
                                             , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
                                           ])
@@ -552,11 +548,8 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
        ; return (binds', mono_ids') }
   where
     tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
-      = do { mono_ty' <- zonkTcType (idType mono_id)
-             -- Zonk, mainly to expose unboxed types to checkStrictBinds
-           ; let mono_id' = setIdType mono_id mono_ty'
-           ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
-           ; return mono_id' }
+      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
+           ; return mono_id }
            -- NB: tcPrags generates error messages for
            --     specialisation pragmas for non-overloaded sigs
            -- Indeed that is why we call it here!
@@ -1499,7 +1492,6 @@ decideGeneralisationPlan
    :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
    -> GeneralisationPlan
 decideGeneralisationPlan dflags lbinds closed sig_fn
-  | unlifted_pat_binds                       = NoGen
   | has_partial_sigs                         = InferGen (and partial_sig_mrs)
   | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
   | mono_local_binds closed                  = NoGen
@@ -1519,10 +1511,6 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
         , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
 
     has_partial_sigs   = not (null partial_sig_mrs)
-    unlifted_pat_binds = any isUnliftedHsBind binds
-       -- Unlifted patterns (unboxed tuple) must not
-       -- be polymorphic, because we are going to force them
-       -- See Trac #4498, #8762
 
     mono_restriction  = xopt LangExt.MonomorphismRestriction dflags
                      && any restricted binds
@@ -1594,107 +1582,6 @@ isClosedBndrGroup binds = do
         -- These won't be in the local type env.
         -- Ditto class method etc from the current module
 
--------------------
-checkStrictBinds :: TopLevelFlag -> RecFlag
-                 -> [LHsBind Name]
-                 -> LHsBinds TcId -> [Id]
-                 -> TcM ()
--- Check that non-overloaded unlifted bindings are
---      a) non-recursive,
---      b) not top level,
---      c) not a multiple-binding group (more or less implied by (a))
-
-checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
-  | any_unlifted_bndr || any_strict_pat   -- This binding group must be matched strictly
-  = do  { check (isNotTopLevel top_lvl)
-                (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
-        ; check (isNonRec rec_group)
-                (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
-
-        ; check (all is_monomorphic (bagToList tc_binds))
-                  (polyBindErr orig_binds)
-            -- data Ptr a = Ptr Addr#
-            -- f x = let p@(Ptr y) = ... in ...
-            -- Here the binding for 'p' is polymorphic, but does
-            -- not mix with an unlifted binding for 'y'.  You should
-            -- use a bang pattern.  Trac #6078.
-
-        ; check (isSingleton orig_binds)
-                (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
-
-        -- Complain about a binding that looks lazy
-        --    e.g.    let I# y = x in ...
-        -- Remember, in checkStrictBinds we are going to do strict
-        -- matching, so (for software engineering reasons) we insist
-        -- that the strictness is manifest on each binding
-        -- However, lone (unboxed) variables are ok
-        ; check (not any_pat_looks_lazy)
-                  (unliftedMustBeBang orig_binds) }
-  | otherwise
-  = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
-    return ()
-  where
-    any_unlifted_bndr  = any is_unlifted poly_ids
-    any_strict_pat     = any (isUnliftedHsBind . unLoc) orig_binds
-    any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
-
-    is_unlifted id = case tcSplitSigmaTy (idType id) of
-                       (_, _, rho) -> isUnliftedType rho
-          -- For the is_unlifted check, we need to look inside polymorphism
-          -- and overloading.  E.g.  x = (# 1, True #)
-          -- would get type forall a. Num a => (# a, Bool #)
-          -- and we want to reject that.  See Trac #9140
-
-    is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
-                     = null tvs && null evs
-    is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
-                     = null tvs && null evs
-    is_monomorphic _ = True
-
-    check :: Bool -> MsgDoc -> TcM ()
-    -- Just like checkTc, but with a special case for module GHC.Prim:
-    --      see Note [Compiling GHC.Prim]
-    check True  _   = return ()
-    check False err = do { mod <- getModule
-                         ; checkTc (mod == gHC_PRIM) err }
-
-unliftedMustBeBang :: [LHsBind Name] -> SDoc
-unliftedMustBeBang binds
-  = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
-       2 (vcat (map ppr binds))
-
-polyBindErr :: [LHsBind Name] -> SDoc
-polyBindErr binds
-  = hang (text "You can't mix polymorphic and unlifted bindings")
-       2 (vcat [vcat (map ppr binds),
-                text "Probable fix: add a type signature"])
-
-strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
-strictBindErr flavour any_unlifted_bndr binds
-  = hang (text flavour <+> msg <+> text "aren't allowed:")
-       2 (vcat (map ppr binds))
-  where
-    msg | any_unlifted_bndr = text "bindings for unlifted types"
-        | otherwise         = text "bang-pattern or unboxed-tuple bindings"
-
-
-{- Note [Compiling GHC.Prim]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Module GHC.Prim has no source code: it is the host module for
-primitive, built-in functions and types.  However, for Haddock-ing
-purposes we generate (via utils/genprimopcode) a fake source file
-GHC/Prim.hs, and give it to Haddock, so that it can generate
-documentation.  It contains definitions like
-    nullAddr# :: NullAddr#
-which would normally be rejected as a top-level unlifted binding. But
-we don't want to complain, because we are only "compiling" this fake
-mdule for documentation purposes.  Hence this hacky test for gHC_PRIM
-in checkStrictBinds.
-
-(We only make the test if things look wrong, so there is no cost in
-the common case.) -}
-
-
 {- *********************************************************************
 *                                                                      *
                Error contexts and messages
@@ -1707,4 +1594,3 @@ patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
                  => LPat id -> GRHSs Name body -> SDoc
 patMonoBindsCtxt pat grhss
   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
-
index 7f5ea9a..671cb13 100644 (file)
@@ -25,7 +25,6 @@ import FamInst ( tcTopNormaliseNewTypeTF_maybe )
 import Var
 import Outputable
 import DynFlags( DynFlags )
-import VarSet
 import NameSet
 import RdrName
 
@@ -461,7 +460,7 @@ mk_strict_superclasses rec_clss ev cls tys
                                   (mkEvScSelectors (EvId evar) cls tys)
        ; concatMapM (mk_superclasses rec_clss) sc_evs }
 
-  | isEmptyVarSet (tyCoVarsOfTypes tys)
+  | all noFreeVarsOfType tys
   = return [] -- Wanteds with no variables yield no deriveds.
               -- See Note [Improvement from Ground Wanteds]
 
index 6135800..7b19cd0 100644 (file)
@@ -410,9 +410,7 @@ tcExtendTyVarEnv2 binds thing_inside
 
 isTypeClosedLetBndr :: Id -> Bool
 -- See Note [Bindings with closed types] in TcRnTypes
-isTypeClosedLetBndr id
-  | isEmptyVarSet (tyCoVarsOfType (idType id)) = True
-  | otherwise                                  = False
+isTypeClosedLetBndr = noFreeVarsOfType . idType
 
 tcExtendLetEnv :: TopLevelFlag -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
 -- Used for both top-level value bindings and and nested let/where-bindings
index 639134e..bb591c8 100644 (file)
@@ -33,8 +33,7 @@ import HsBinds ( PatSynBind(..) )
 import Name
 import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
                , mkRdrUnqual, isLocalGRE, greSrcSpan )
-import PrelNames ( typeableClassName, hasKey, ptrRepLiftedDataConKey
-                 , ptrRepUnliftedDataConKey )
+import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )
 import Id
 import Var
 import VarSet
@@ -1464,7 +1463,7 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
              extra2 = important $ mkEqInfoMsg ct ty1 ty2
 
              interesting_tyvars
-               = filter (not . isEmptyVarSet . tyCoVarsOfType . tyVarKind) $
+               = filter (not . noFreeVarsOfType . tyVarKind) $
                  filter isTyVar $
                  fvVarList $
                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
@@ -1689,20 +1688,14 @@ misMatchMsg ct oriented ty1 ty2
   = misMatchMsg ct (Just IsSwapped) ty2 ty1
 
   -- These next two cases are when we're about to report, e.g., that
-  -- 'PtrRepLifted doesn't match 'VoidRep. Much better just to say
+  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
   -- lifted vs. unlifted
   | Just (tc1, []) <- splitTyConApp_maybe ty1
-  , tc1 `hasKey` ptrRepLiftedDataConKey
+  , tc1 `hasKey` liftedRepDataConKey
   = lifted_vs_unlifted
 
   | Just (tc2, []) <- splitTyConApp_maybe ty2
-  , tc2 `hasKey` ptrRepLiftedDataConKey
-  = lifted_vs_unlifted
-
-  | Just (tc1, []) <- splitTyConApp_maybe ty1
-  , Just (tc2, []) <- splitTyConApp_maybe ty2
-  ,    (tc1 `hasKey` ptrRepLiftedDataConKey && tc2 `hasKey` ptrRepUnliftedDataConKey)
-    || (tc1 `hasKey` ptrRepUnliftedDataConKey && tc2 `hasKey` ptrRepLiftedDataConKey)
+  , tc2 `hasKey` liftedRepDataConKey
   = lifted_vs_unlifted
 
   | otherwise  -- So now we have Nothing or (Just IsSwapped)
index 6055f01..60a838b 100644 (file)
@@ -162,7 +162,7 @@ data HsWrapper
        -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
        -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 
-  | WpFun HsWrapper HsWrapper TcType
+  | WpFun HsWrapper HsWrapper TcType SDoc
        -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ]
        -- So note that if  wrap1 :: exp_arg <= act_arg
        --                  wrap2 :: act_res <= exp_res
@@ -170,6 +170,9 @@ data HsWrapper
        -- This isn't the same as for mkFunCo, but it has to be this way
        -- because we can't use 'sym' to flip around these HsWrappers
        -- The TcType is the "from" type of the first wrapper
+       -- The SDoc explains the circumstances under which we have created this
+       -- WpFun, in case we run afoul of levity polymorphism restrictions in
+       -- the desugarer. See Note [Levity polymorphism checking] in DsMonad
 
   | WpCast TcCoercionR        -- A cast:  [] `cast` co
                               -- Guaranteed not the identity coercion
@@ -186,8 +189,67 @@ data HsWrapper
 
   | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,
                                 -- so that the identity coercion is always exactly WpHole
-  deriving Data.Data
 
+-- Cannot derive Data instance because SDoc is not Data (it stores a function).
+-- So we do it manually:
+instance Data.Data HsWrapper where
+  gfoldl _ z WpHole             = z WpHole
+  gfoldl k z (WpCompose a1 a2)  = z WpCompose `k` a1 `k` a2
+  gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3
+  gfoldl k z (WpCast a1)        = z WpCast `k` a1
+  gfoldl k z (WpEvLam a1)       = z WpEvLam `k` a1
+  gfoldl k z (WpEvApp a1)       = z WpEvApp `k` a1
+  gfoldl k z (WpTyLam a1)       = z WpTyLam `k` a1
+  gfoldl k z (WpTyApp a1)       = z WpTyApp `k` a1
+  gfoldl k z (WpLet a1)         = z WpLet `k` a1
+
+  gunfold k z c = case Data.constrIndex c of
+                    1 -> z WpHole
+                    2 -> k (k (z WpCompose))
+                    3 -> k (k (k (z wpFunEmpty)))
+                    4 -> k (z WpCast)
+                    5 -> k (z WpEvLam)
+                    6 -> k (z WpEvApp)
+                    7 -> k (z WpTyLam)
+                    8 -> k (z WpTyApp)
+                    _ -> k (z WpLet)
+
+  toConstr WpHole          = wpHole_constr
+  toConstr (WpCompose _ _) = wpCompose_constr
+  toConstr (WpFun _ _ _ _) = wpFun_constr
+  toConstr (WpCast _)      = wpCast_constr
+  toConstr (WpEvLam _)     = wpEvLam_constr
+  toConstr (WpEvApp _)     = wpEvApp_constr
+  toConstr (WpTyLam _)     = wpTyLam_constr
+  toConstr (WpTyApp _)     = wpTyApp_constr
+  toConstr (WpLet _)       = wpLet_constr
+
+  dataTypeOf _ = hsWrapper_dataType
+
+hsWrapper_dataType :: Data.DataType
+hsWrapper_dataType
+  = Data.mkDataType "HsWrapper"
+      [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr
+      , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr
+      , wpLet_constr]
+
+wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr,
+  wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr
+wpHole_constr    = mkHsWrapperConstr "WpHole"
+wpCompose_constr = mkHsWrapperConstr "WpCompose"
+wpFun_constr     = mkHsWrapperConstr "WpFun"
+wpCast_constr    = mkHsWrapperConstr "WpCast"
+wpEvLam_constr   = mkHsWrapperConstr "WpEvLam"
+wpEvApp_constr   = mkHsWrapperConstr "WpEvApp"
+wpTyLam_constr   = mkHsWrapperConstr "WpTyLam"
+wpTyApp_constr   = mkHsWrapperConstr "WpTyApp"
+wpLet_constr     = mkHsWrapperConstr "WpLet"
+
+mkHsWrapperConstr :: String -> Data.Constr
+mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix
+
+wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper
+wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty
 
 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 WpHole <.> c = c
@@ -198,12 +260,13 @@ mkWpFun :: HsWrapper -> HsWrapper
         -> TcType    -- the "from" type of the first wrapper
         -> TcType    -- either type of the second wrapper (used only when the
                      -- second wrapper is the identity)
+        -> SDoc      -- what caused you to want a WpFun? Something like "When converting ..."
         -> HsWrapper
-mkWpFun WpHole       WpHole       _  _  = WpHole
-mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
-mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
-mkWpFun (WpCast co1) (WpCast co2) _  _  = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
-mkWpFun co1          co2          t1 _  = WpFun co1 co2 t1
+mkWpFun WpHole       WpHole       _  _  = WpHole
+mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
+mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
+mkWpFun (WpCast co1) (WpCast co2) _  _  = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
+mkWpFun co1          co2          t1 _  d = WpFun co1 co2 t1 d
 
 -- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@,
 -- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@,
@@ -211,13 +274,14 @@ mkWpFun co1          co2          t1 _  = WpFun co1 co2 t1
 -- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@.
 -- Notice that the result wrapper goes the other way round to all
 -- the others. This is a result of sub-typing contravariance.
-mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> HsWrapper
-mkWpFuns args res_ty res_wrap = snd $ go args res_ty res_wrap
+-- The SDoc is a description of what you were doing when you called mkWpFuns.
+mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper
+mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap
   where
     go [] res_ty res_wrap = (res_ty, res_wrap)
     go ((arg_ty, arg_wrap) : args) res_ty res_wrap
       = let (tail_ty, tail_wrap) = go args res_ty res_wrap in
-        (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty)
+        (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc)
 
 mkWpCastR :: TcCoercionR -> HsWrapper
 mkWpCastR co
@@ -762,7 +826,7 @@ evVarsOfTypeable ev =
 instance Outputable HsWrapper where
   ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>"))
 
-pprHsWrapper ::HsWrapper ->  (Bool -> SDoc) -> SDoc
+pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc
 -- With -fprint-typechecker-elaboration, print the wrapper
 --   otherwise just print what's inside
 -- The pp_thing_inside function takes Bool to say whether
@@ -778,7 +842,7 @@ pprHsWrapper wrap pp_thing_inside
     -- False <=> appears as body of let or lambda
     help it WpHole             = it
     help it (WpCompose f1 f2)  = help (help it f2) f1
-    help it (WpFun f1 f2 t1)   = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+>
+    help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+>
                                               help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False
     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (text "|>"
                                               <+> pprParendCo co)]
index 71fe070..4c21a85 100644 (file)
@@ -388,8 +388,9 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
              -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
 
              -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
-             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc
                      <.> wrap_arg1
+             doc = text "When looking at the argument to ($)"
 
        ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
 
@@ -1230,9 +1231,12 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
            ; (inner_wrap, args', inner_res_ty)
                <- go (arg_ty : acc_args) (n+1) res_ty args
                -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
-           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
+           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap
                     , Left arg' : args'
                     , inner_res_ty ) }
+      where
+        doc = text "When checking the" <+> speakNth n <+>
+              text "argument to" <+> quotes (ppr fun)
 
     ty_app_err ty arg
       = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
@@ -1356,9 +1360,10 @@ tcSynArgE orig sigma_ty syn_ty thing_inside
            ; return ( result
                     , match_wrapper <.>
                       mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
-                              arg_ty res_ty ) }
+                              arg_ty res_ty doc ) }
       where
         herald = text "This rebindable syntax expects a function with"
+        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig
 
     go rho_ty (SynType the_ty)
       = do { wrap   <- tcSubTypeET orig GenSigCtxt the_ty rho_ty
@@ -1631,21 +1636,21 @@ tc_infer_id lbl id_name
     return_data_con con
        -- For data constructors, must perform the stupid-theta check
       | null stupid_theta
-      = return_id con_wrapper_id
+      = return (HsConLikeOut (RealDataCon con), con_ty)
 
       | otherwise
        -- See Note [Instantiating stupid theta]
-      = do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id)
+      = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty
            ; (subst, tvs') <- newMetaTyVars tvs
            ; let tys'   = mkTyVarTys tvs'
                  theta' = substTheta subst theta
                  rho'   = substTy subst rho
            ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
            ; addDataConStupidTheta con tys'
-           ; return (mkHsWrap wrap (HsVar (noLoc con_wrapper_id)), rho') }
+           ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') }
 
       where
-        con_wrapper_id = dataConWrapId con
+        con_ty         = dataConUserType con
         stupid_theta   = dataConStupidTheta con
 
     check_naughty id
index 5679f9f..21875ff 100644 (file)
@@ -130,12 +130,13 @@ gen_Functor_binds loc tycon
     data_cons = tyConDataCons tycon
     fun_name = L loc fmap_RDR
     fmap_bind = mkRdrFunBind fun_name eqns
+    fun_match_ctxt = FunRhs fun_name Prefix
 
-    fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
+    fmap_eqn con = evalState (match_for_con fun_match_ctxt [f_Pat] con =<< parts) bs_RDRs
       where
         parts = sequence $ foldDataConArgs ft_fmap con
 
-    eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
+    eqns | null data_cons = [mkSimpleMatch fun_match_ctxt
                                            [nlWildPat, nlWildPat]
                                            (error_Expr "Void fmap")]
          | otherwise      = map fmap_eqn data_cons
@@ -153,7 +154,7 @@ gen_Functor_binds loc tycon
                    -- fmap f = \x b -> h (x (g b))
                  , ft_tup = \t gs -> do
                      gg <- sequence gs
-                     mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
+                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
                    -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                  , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
                    -- fmap f = fmap g
@@ -162,9 +163,10 @@ gen_Functor_binds loc tycon
                  , ft_co_var = panic "contravariant" }
 
     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
-    match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
+    match_for_con :: HsMatchContext RdrName
+                  -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_for_con = mkSimpleConMatch CaseAlt $
+    match_for_con ctxt = mkSimpleConMatch ctxt $
         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
 
 {-
index 9f320f5..581795e 100644 (file)
@@ -12,8 +12,11 @@ checker.
 {-# LANGUAGE CPP, TupleSections #-}
 
 module TcHsSyn (
-        mkHsDictLet, mkHsApp,
+        -- * Extracting types from HsSyn
         hsLitType, hsLPatType, hsPatType,
+
+        -- * Other HsSyn functions
+        mkHsDictLet, mkHsApp,
         mkHsAppTy, mkHsCaseAlt,
         nlHsIntLit,
         shortCutLit, hsOverLitName,
@@ -32,24 +35,22 @@ module TcHsSyn (
         zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
         zonkCoToCo, zonkSigType,
         zonkEvBinds,
-
-        -- * Validity checking
-        checkForRepresentationPolymorphism
   ) where
 
 #include "HsVersions.h"
 
 import HsSyn
 import Id
+import IdInfo
 import TcRnMonad
 import PrelNames
 import TcType
 import TcMType
 import TcEvidence
 import TysPrim
+import TyCon   ( isUnboxedTupleTyCon )
 import TysWiredIn
 import Type
-import TyCon
 import Coercion
 import ConLike
 import DataCon
@@ -57,7 +58,6 @@ import HscTypes
 import Name
 import NameEnv
 import Var
-import VarSet
 import VarEnv
 import DynFlags
 import Literal
@@ -76,12 +76,10 @@ import Control.Arrow ( second )
 {-
 ************************************************************************
 *                                                                      *
-\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+       Extracting the type from HsSyn
 *                                                                      *
 ************************************************************************
 
-Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
-then something is wrong.
 -}
 
 hsLPatType :: OutPat Id -> Type
@@ -109,7 +107,6 @@ hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
 hsPatType (CoPat _ _ ty)              = ty
 hsPatType p                           = pprPanic "hsPatType" (ppr p)
 
-
 hsLitType :: HsLit -> TcType
 hsLitType (HsChar _ _)       = charTy
 hsLitType (HsCharPrim _ _)   = charPrimTy
@@ -150,7 +147,7 @@ shortCutLit _ (HsIsString src s) ty
   | otherwise     = Nothing
 
 mkLit :: DataCon -> HsLit -> HsExpr Id
-mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit)
 
 ------------------------------
 hsOverLitName :: OverLitVal -> Name
@@ -296,11 +293,12 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
 -- zonkIdBndr is used *after* typechecking to get the Id's type
 -- to its final form.  The TyVarEnv give
 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
-zonkIdBndr env id
-  = do ty' <- zonkTcTypeToType env (idType id)
-       ensureNotRepresentationPolymorphic ty'
-         (text "In the type of binder" <+> quotes (ppr id))
-       return (setIdType id ty')
+zonkIdBndr env v
+  = do ty' <- zonkTcTypeToType env (idType v)
+       ensureNotLevPoly ty'
+         (text "In the type of binder" <+> quotes (ppr v))
+
+       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
 
 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
@@ -617,7 +615,10 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs
 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
 
 zonkExpr env (HsVar (L l id))
-  = return (HsVar (L l (zonkIdOcc env id)))
+  = ASSERT( isNothing (isDataConId_maybe id) )
+    return (HsVar (L l (zonkIdOcc env id)))
+
+zonkExpr _ e@(HsConLikeOut {}) = return e
 
 zonkExpr _ (HsIPVar id)
   = return (HsIPVar id)
@@ -930,6 +931,12 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
        new_stack_tys <- zonkTcTypeToType env stack_tys
        new_ty <- zonkTcTypeToType env ty
        new_ids <- mapSndM (zonkExpr env) ids
+
+       MASSERT( isLiftedTypeKind (typeKind new_stack_tys) )
+         -- desugarer assumes that this is not levity polymorphic...
+         -- but indeed it should always be lifted due to the typing
+         -- rules for arrows
+
        return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
 
 -------------------------------------------------------------------------
@@ -938,10 +945,10 @@ zonkCoFn env WpHole   = return (env, WpHole)
 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                     ; (env2, c2') <- zonkCoFn env1 c2
                                     ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
-                                   ; (env2, c2') <- zonkCoFn env1 c2
-                                   ; t1'         <- zonkTcTypeToType env2 t1
-                                   ; return (env2, WpFun c1' c2' t1') }
+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
+                                     ; (env2, c2') <- zonkCoFn env1 c2
+                                     ; t1'         <- zonkTcTypeToType env2 t1
+                                     ; return (env2, WpFun c1' c2' t1' d) }
 zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
                               ; return (env, WpCast co') }
 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
@@ -1181,7 +1188,7 @@ zonk_pat env (ParPat p)
 
 zonk_pat env (WildPat ty)
   = do  { ty' <- zonkTcTypeToType env ty
-        ; ensureNotRepresentationPolymorphic ty'
+        ; ensureNotLevPoly ty'
             (text "In a wildcard pattern")
         ; return (env, WildPat ty') }
 
@@ -1237,9 +1244,19 @@ zonk_pat env (SumPat pat alt arity tys)
 
 zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
                           , pat_dicts = evs, pat_binds = binds
-                          , pat_args = args, pat_wrap = wrapper })
+                          , pat_args = args, pat_wrap = wrapper
+                          , pat_con = L _ con })
   = ASSERT( all isImmutableTyVar tyvars )
     do  { new_tys <- mapM (zonkTcTypeToType env) tys
+
+          -- an unboxed tuple pattern (but only an unboxed tuple pattern)
+          -- might have levity-polymorphic arguments. Check for this badness.
+        ; case con of
+            RealDataCon dc
+              | isUnboxedTupleTyCon (dataConTyCon dc)
+              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
+            _ -> return ()
+
         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
           -- Must zonk the existential variables, because their
           -- /kind/ need potential zonking.
@@ -1254,6 +1271,8 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
                             pat_binds = new_binds,
                             pat_args = new_args,
                             pat_wrap = new_wrapper}) }
+  where
+    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
 
 zonk_pat env (LitPat lit) = return (env, LitPat lit)
 
@@ -1630,10 +1649,10 @@ zonkTvSkolemising tv
 zonkTypeZapping :: UnboundTyVarZonker
 -- This variant is used for everything except the LHS of rules
 -- It zaps unbound type variables to Any, except for RuntimeRep
--- vars which it zonks to PtrRepLIfted
+-- vars which it zonks to LiftedRep
 -- Works on both types and kinds
 zonkTypeZapping tv
-  = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy
+  = do { let ty | isRuntimeRepVar tv = liftedRepTy
                 | otherwise          = anyTypeOfKind (tyVarKind tv)
        ; writeMetaTyVar tv ty
        ; return ty }
@@ -1670,118 +1689,4 @@ We do this in two stages.
 Quantifying here is awkward because (a) the data type is big and (b)
 finding the free type vars of an expression is necessarily monadic
 operation. (consider /\a -> f @ b, where b is side-effected to a)
-
-Note [Unboxed tuples in representation polymorphism check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recall that all types that have values (that is, lifted and unlifted
-types) have kinds that look like (TYPE rep), where (rep :: RuntimeRep)
-tells how the values are represented at runtime. Lifted types have
-kind (TYPE PtrRepLifted) (for which * is just a synonym) and, say,
-Int# has kind (TYPE IntRep).
-
-It would be terrible if the code generator came upon a binder of a type
-whose kind is something like TYPE r, where r is a skolem type variable.
-The code generator wouldn't know what to do. So we eliminate that case
-here.
-
-Although representation polymorphism and the RuntimeRep type catch
-most ways of abusing unlifted types, it still isn't quite satisfactory
-around unboxed tuples. That's because all unboxed tuple types have kind
-TYPE UnboxedTupleRep, which is clearly a lie: it doesn't actually tell
-you what the representation is.
-
-Naively, when checking for representation polymorphism, you might think we can
-just look for free variables in a type's RuntimeRep. But this misses the
-UnboxedTupleRep case.
-
-So, instead, we handle unboxed tuples specially. Only after unboxed tuples
-are handled do we look for free tyvars in a RuntimeRep.
-
-We must still be careful in the UnboxedTupleRep case. A binder whose type
-has kind UnboxedTupleRep is OK -- only as long as the type is really an
-unboxed tuple, which the code generator treats specially. So we do this:
- 1. Check if the type is an unboxed tuple. If so, recur.
- 2. Check if the kind is TYPE UnboxedTupleRep. If so, error.
- 3. Check if the kind has any free variables. If so, error.
-
-In case 1, we have a type that looks like
-
-  (# , #) PtrRepLifted IntRep Bool Int#
-
-recalling that
-
-  (# , #) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep).
-             TYPE r1 -> TYPE r2 -> TYPE UnboxedTupleRep
-
-It's tempting just to look at the RuntimeRep arguments to make sure
-that they are devoid of free variables and not UnboxedTupleRep. This
-naive check, though, fails on nested unboxed tuples, like
-(# Int#, (# Bool, Void# #) #). Thus, instead of looking at the RuntimeRep
-args to the unboxed tuple constructor, we look at the types themselves.
-
-Here are a few examples:
-
-   type family F r :: TYPE r
-
-   x :: (F r :: TYPE r)   -- REJECTED: simple representation polymorphism
-     where r is an in-scope type variable of kind RuntimeRep
-
-   x :: (F PtrRepLifted :: TYPE PtrRepLifted)   -- OK
-   x :: (F IntRep       :: TYPE IntRep)         -- OK
-
-   x :: (F UnboxedTupleRep :: TYPE UnboxedTupleRep)  -- REJECTED
-
-   x :: ((# Int, Bool #) :: TYPE UnboxedTupleRep)    -- OK
 -}
-
--- | According to the rules around representation polymorphism
--- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder
--- can have a representation-polymorphic type. This check ensures
--- that we respect this rule. It is a bit regrettable that this error
--- occurs in zonking, after which we should have reported all errors.
--- But it's hard to see where else to do it, because this can be discovered
--- only after all solving is done. And, perhaps most importantly, this
--- isn't really a compositional property of a type system, so it's
--- not a terrible surprise that the check has to go in an awkward spot.
-ensureNotRepresentationPolymorphic
-  :: Type  -- its zonked type
-  -> SDoc  -- where this happened
-  -> TcM ()
-ensureNotRepresentationPolymorphic ty doc
-  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type
-                   -- forall a. a. See, for example, test ghci/scripts/T9140
-    checkForRepresentationPolymorphism doc ty
-
-   -- See Note [Unboxed tuples in representation polymorphism check]
-checkForRepresentationPolymorphism :: SDoc -> Type -> TcM ()
-checkForRepresentationPolymorphism extra ty
-  | Just (tc, tys) <- splitTyConApp_maybe ty
-  , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
-  = mapM_ (checkForRepresentationPolymorphism extra) (dropRuntimeRepArgs tys)
-
-  | tuple_rep || sum_rep
-  = addErr (vcat [ text "The type" <+> quotes (ppr tidy_ty) <+>
-                     (text "is not an unboxed" <+> tuple_or_sum <> comma)
-                 , text "and yet its kind suggests that it has the representation"
-                 , text "of an unboxed" <+> tuple_or_sum <> text ". This is not allowed." ] $$
-            extra)
-
-  | not (isEmptyVarSet (tyCoVarsOfType runtime_rep))
-  = addErr $
-    hang (text "A representation-polymorphic type is not allowed here:")
-       2 (vcat [ text "Type:" <+> ppr tidy_ty
-               , text "Kind:" <+> ppr tidy_ki ]) $$
-    extra
-
-  | otherwise
-  = return ()
-  where
-    tuple_rep    = runtime_rep `eqType` unboxedTupleRepDataConTy
-    sum_rep      = runtime_rep `eqType` unboxedSumRepDataConTy
-    tuple_or_sum = text (if tuple_rep then "tuple" else "sum")
-
-    ki          = typeKind ty
-    runtime_rep = getRuntimeRepFromKind "check_type" ki
-
-    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
-    tidy_ki             = tidyType tidy_env (typeKind ty)
index 107f4f9..15f6217 100644 (file)
@@ -65,7 +65,6 @@ import VarSet
 import TyCon
 import ConLike
 import DataCon
-import TysPrim ( tYPE )
 import Class
 import Name
 import NameEnv
@@ -605,8 +604,11 @@ tc_hs_type mode (HsSumTy hs_tys) exp_kind
   = do { let arity = length hs_tys
        ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
        ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
-       ; let arg_tys = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds ++ tau_tys
-       ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) (tYPE unboxedSumRepDataConTy) exp_kind
+       ; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds
+             arg_tys  = arg_reps ++ tau_tys
+       ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys)
+                           (unboxedSumKind arg_reps)
+                           exp_kind
        }
 
 --------- Promoted lists and tuples
@@ -717,8 +719,7 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind
   = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
        ; let arg_tys  = case tup_sort of
                    -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
-                 UnboxedTuple    -> map (getRuntimeRepFromKind "finish_tuple") tau_kinds
-                                    ++ tau_tys
+                 UnboxedTuple    -> tau_reps ++ tau_tys
                  BoxedTuple      -> tau_tys
                  ConstraintTuple -> tau_tys
        ; tycon <- case tup_sort of
@@ -733,10 +734,9 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind
        ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind }
   where
     arity = length tau_tys
+    tau_reps = map (getRuntimeRepFromKind "finish_tuple") tau_kinds
     res_kind = case tup_sort of
-                 UnboxedTuple
-                   | arity == 0  -> tYPE voidRepDataConTy
-                   | otherwise   -> unboxedTupleKind
+                 UnboxedTuple    -> unboxedTupleKind tau_reps
                  BoxedTuple      -> liftedTypeKind
                  ConstraintTuple -> constraintKind
 
index 4b2b383..9298b10 100644 (file)
@@ -42,6 +42,7 @@ import TcEvidence
 import TyCon
 import CoAxiom
 import DataCon
+import ConLike
 import Class
 import Var
 import VarEnv
@@ -835,7 +836,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                      --    con_app_tys  = MkD ty1 ty2
                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
-             con_app_tys  = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr)
+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)
+                                     (HsConLikeOut (RealDataCon dict_constr))
                        -- NB: We *can* have covars in inst_tys, in the case of
                        -- promoted GADT constructors.
 
@@ -892,6 +894,8 @@ addDFunPrags dfun_id sc_meth_ids
  where
    con_app    = mkLams dfun_bndrs $
                 mkApps (Var (dataConWrapId dict_con)) dict_args
+                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
+                 -- See Note [Levity polymorphism checking] in DsMonad
    dict_args  = map Type inst_tys ++
                 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
 
index 2e9a7a7..8f0a79c 100644 (file)
@@ -81,7 +81,11 @@ module TcMType (
 
   zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo,
 
-  tcGetGlobalTyCoVars
+  tcGetGlobalTyCoVars,
+
+  ------------------------------
+  -- Levity polymorphism
+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
   ) where
 
 #include "HsVersions.h"
@@ -1011,7 +1015,7 @@ zonkQuantifiedTyVar default_kind tv
     zonk_meta_tv :: TcTyVar -> TcM (Maybe TcTyVar)
     zonk_meta_tv tv
       | isRuntimeRepVar tv   -- Never quantify over a RuntimeRep var
-      = do { writeMetaTyVar tv ptrRepLiftedTy
+      = do { writeMetaTyVar tv liftedRepTy
            ; return Nothing }
 
       | default_kind         -- -XNoPolyKinds and this is a kind var
@@ -1569,3 +1573,55 @@ tidySkolemInfo env (SigSkol cx ty)      = SigSkol cx (tidyType env ty)
 tidySkolemInfo env (InferSkol ids)      = InferSkol (mapSnd (tidyType env) ids)
 tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
 tidySkolemInfo _   info                 = info
+
+-------------------------------------------------------------------------
+{-
+%************************************************************************
+%*                                                                      *
+             Levity polymorphism checks
+*                                                                      *
+************************************************************************
+
+See Note [Levity polymorphism checking] in DsMonad
+
+-}
+
+-- | According to the rules around representation polymorphism
+-- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder
+-- can have a representation-polymorphic type. This check ensures
+-- that we respect this rule. It is a bit regrettable that this error
+-- occurs in zonking, after which we should have reported all errors.
+-- But it's hard to see where else to do it, because this can be discovered
+-- only after all solving is done. And, perhaps most importantly, this
+-- isn't really a compositional property of a type system, so it's
+-- not a terrible surprise that the check has to go in an awkward spot.
+ensureNotLevPoly :: Type  -- its zonked type
+                 -> SDoc  -- where this happened
+                 -> TcM ()
+ensureNotLevPoly ty doc
+  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type
+                   -- forall a. a. See, for example, test ghci/scripts/T9140
+    checkForLevPoly doc ty
+
+  -- See Note [Levity polymorphism checking] in DsMonad
+checkForLevPoly :: SDoc -> Type -> TcM ()
+checkForLevPoly = checkForLevPolyX addErr
+
+checkForLevPolyX :: Monad m
+                 => (SDoc -> m ())  -- how to report an error
+                 -> SDoc -> Type -> m ()
+checkForLevPolyX add_err extra ty
+  | isTypeLevPoly ty
+  = add_err (formatLevPolyErr ty $$ extra)
+  | otherwise
+  = return ()
+
+formatLevPolyErr :: Type  -- levity-polymorphic type
+                 -> SDoc
+formatLevPolyErr ty
+  = hang (text "A levity-polymorphic type is not allowed here:")
+       2 (vcat [ text "Type:" <+> ppr tidy_ty
+               , text "Kind:" <+> ppr tidy_ki ])
+  where
+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
+    tidy_ki             = tidyType tidy_env (typeKind ty)
index b1d444a..036482d 100644 (file)
@@ -47,7 +47,6 @@ import VarSet
 import Util
 import Outputable
 import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad
 import Control.Arrow  ( second )
 import ListSetOps ( getNth )
 
@@ -336,7 +335,7 @@ tc_pat penv (BangPat pat) pat_ty thing_inside
   = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
         ; return (BangPat pat', res) }
 
-tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
+tc_pat penv (LazyPat pat) pat_ty thing_inside
   = do  { (pat', (res, pat_ct))
                 <- tc_lpat pat pat_ty (makeLazy penv) $
                    captureConstraints thing_inside
@@ -346,18 +345,6 @@ tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
         -- captureConstraints/extendConstraints:
         --   see Note [Hopping the LIE in lazy patterns]
 
-        -- Check there are no unlifted types under the lazy pattern
-        -- This is a very unsatisfactory test.  We have to zonk because
-        -- the binder-tys are typically just a unification variable,
-        -- which should by now have been unified... but it might be
-        -- deferred for the constraint solver...Ugh!  Also
-        -- collecting the pattern binders again is not very cool.
-        -- But it's all very much a corner case: a lazy pattern with
-        -- unboxed types inside it
-        ; bndr_tys <- mapM (zonkTcType . idType) (collectPatBinders pat')
-        ; when (any isUnliftedType bndr_tys)
-               (lazyUnliftedPatErr lpat)
-
         -- Check that the expected pattern type is itself lifted
         ; pat_ty <- readExpType pat_ty
         ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind
@@ -406,10 +393,11 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
 
         ; overall_pat_ty <- readExpType overall_pat_ty
         ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
-                                    overall_pat_ty inf_res_ty
+                                    overall_pat_ty inf_res_ty doc
                -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
                --                (overall_pat_ty -> inf_res_ty)
               expr_wrap = expr_wrap2' <.> expr_wrap1
+              doc = text "When checking the view pattern function:" <+> (ppr expr)
         ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) }
 
 -- Type signatures in patterns
@@ -1185,9 +1173,3 @@ polyPatSig :: TcType -> SDoc
 polyPatSig sig_ty
   = hang (text "Illegal polymorphic type signature in pattern:")
        2 (ppr sig_ty)
-
-lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM ()
-lazyUnliftedPatErr pat
-  = failWithTc $
-    hang (text "A lazy (~) pattern cannot contain unlifted types:")
-       2 (ppr pat)
index 47a27b3..587e2b8 100644 (file)
@@ -34,7 +34,7 @@ import FastString
 import Var
 import VarEnv( emptyTidyEnv, mkInScopeSet )
 import Id
-import IdInfo( RecSelParent(..))
+import IdInfo( RecSelParent(..), setLevityInfoWithType )
 impo