Unwire Typeable representation types
authorBen Gamari <bgamari.foss@gmail.com>
Thu, 18 Feb 2016 21:05:02 +0000 (22:05 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 18 Feb 2016 21:08:16 +0000 (22:08 +0100)
In order to make this work I needed to shuffle around typechecking a bit
such that `TyCon` and friends are available during compilation of
GHC.Types.  I also did a bit of refactoring of `TcTypeable`.

Test Plan: Validate

Reviewers: simonpj, austin

Subscribers: simonpj, thomie

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

GHC Trac Issues: #11120

12 files changed:
compiler/prelude/PrelNames.hs
compiler/prelude/TysWiredIn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcTypeable.hs
libraries/ghc-prim/GHC/Types.hs
testsuite/tests/deSugar/should_compile/T2431.stderr
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/roles/should_compile/Roles13.stderr
testsuite/tests/simplCore/should_compile/T7360.stderr
testsuite/tests/simplCore/should_compile/T8274.stdout
testsuite/tests/stranal/should_compile/T10694.stdout

index 609ac03..5c2984b 100644 (file)
@@ -205,6 +205,11 @@ basicKnownKeyNames
         ioTyConName, ioDataConName,
         runMainIOName,
 
+        -- Type representation types
+        trModuleTyConName, trModuleDataConName,
+        trNameTyConName, trNameSDataConName, trNameDDataConName,
+        trTyConTyConName, trTyConDataConName,
+
         -- Typeable
         typeableClassName,
         typeRepTyConName,
@@ -1130,6 +1135,23 @@ rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDo
 ixClassName :: Name
 ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
 
+-- Typeable representation types
+trModuleTyConName
+  , trModuleDataConName
+  , trNameTyConName
+  , trNameSDataConName
+  , trNameDDataConName
+  , trTyConTyConName
+  , trTyConDataConName
+  :: Name
+trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey
+trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey
+trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey
+trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey
+trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey
+trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey
+trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey
+
 -- Class Typeable, and functions for constructing `Typeable` dictionaries
 typeableClassName
   , typeRepTyConName
index 6ad786f..b7bd186 100644 (file)
@@ -88,11 +88,6 @@ module TysWiredIn (
 
         mkWiredInIdName,    -- used in MkId
 
-        -- * Type representations
-        trModuleTyCon, trModuleDataCon,
-        trNameTyCon, trNameSDataCon, trNameDDataCon,
-        trTyConTyCon, trTyConDataCon,
-
         -- * Levity
         levityTy, levityTyCon, liftedDataCon, unliftedDataCon,
         liftedPromDataCon, unliftedPromDataCon,
@@ -188,9 +183,6 @@ wiredInTyCons = [ unitTyCon     -- Not treated like other tuples, because
               , liftedTypeKindTyCon
               , starKindTyCon
               , unicodeStarKindTyCon
-              , trModuleTyCon
-              , trTyConTyCon
-              , trNameTyCon
               ]
 
 mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -615,6 +607,7 @@ unboxedUnitDataCon = tupleDataCon   Unboxed 0
 ********************************************************************* -}
 
 -- See Note [The equality types story] in TysPrim
+-- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
 heqTyCon, coercibleTyCon :: TyCon
 heqClass, coercibleClass :: Class
 heqDataCon, coercibleDataCon :: DataCon
@@ -1063,56 +1056,3 @@ promotedGTDataCon     = promoteDataCon gtDataCon
 promotedConsDataCon, promotedNilDataCon :: TyCon
 promotedConsDataCon   = promoteDataCon consDataCon
 promotedNilDataCon    = promoteDataCon nilDataCon
-
--- * Type representation types
--- See Note [Grand plan for Typable] in TcTypeable.
-trModuleTyConName, trNameTyConName, trTyConTyConName :: Name
-trModuleTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Module")
-                        trModuleTyConKey trModuleTyCon
-trNameTyConName     = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "TrName")
-                        trNameTyConKey trNameTyCon
-trTyConTyConName    = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "TyCon")
-                        trTyConTyConKey trTyConTyCon
-
-trModuleDataConName, trTyConDataConName,
-  trNameSDataConName, trNameDDataConName :: Name
-trModuleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Module")
-                        trModuleDataConKey trModuleDataCon
-trTyConDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TyCon")
-                        trTyConDataConKey trTyConDataCon
-trNameSDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TrNameS")
-                        trNameSDataConKey trNameSDataCon
-trNameDDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TrNameD")
-                        trNameDDataConKey trNameDDataCon
-
-trModuleTyCon :: TyCon
-trModuleTyCon = pcNonRecDataTyCon trModuleTyConName Nothing [] [trModuleDataCon]
-
-trModuleDataCon :: DataCon
-trModuleDataCon = pcDataCon trModuleDataConName [] [trNameTy, trNameTy] trModuleTyCon
-
-trModuleTy :: Type
-trModuleTy = mkTyConTy trModuleTyCon
-
-trNameTyCon :: TyCon
-trNameTyCon = pcNonRecDataTyCon trNameTyConName Nothing [] [trNameSDataCon, trNameDDataCon]
-
-trNameSDataCon, trNameDDataCon :: DataCon
-trNameSDataCon = pcDataCon trNameSDataConName [] [addrPrimTy] trNameTyCon
-trNameDDataCon = pcDataCon trNameDDataConName [] [stringTy] trNameTyCon
-
-trNameTy :: Type
-trNameTy = mkTyConTy trNameTyCon
-
-trTyConTyCon :: TyCon
-trTyConTyCon = pcNonRecDataTyCon trTyConTyConName Nothing [] [trTyConDataCon]
-
-trTyConDataCon :: DataCon
-trTyConDataCon = pcDataCon trTyConDataConName [] [fprint, fprint, trModuleTy, trNameTy] trTyConTyCon
-  where
-    -- TODO: This should be for the target, no?
-#if WORD_SIZE_IN_BITS < 64
-    fprint = word64PrimTy
-#else
-    fprint = wordPrimTy
-#endif
index b483b84..fdc6e5e 100644 (file)
@@ -71,7 +71,7 @@ import TcType
 import MkIface
 import TcSimplify
 import TcTyClsDecls
-import TcTypeable( mkModIdBindings, mkPrimTypeableBinds )
+import TcTypeable ( mkTypeableBinds )
 import LoadIface
 import TidyPgm    ( mkBootModDetailsTc )
 import RnNames
@@ -471,21 +471,19 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
         -- Returns the variables free in the decls
         -- Reason: solely to report unused imports and bindings
 tcRnSrcDecls explicit_mod_hdr decls
- = do { -- Create a binding for $trModule
-        -- Do this before processing any data type declarations,
-        -- which need tcg_tr_module to be initialised
-      ; tcg_env <- mkModIdBindings
-      ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
-
-        -- Do all the declarations
-      ; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env  $
-                                     captureConstraints $
+ = do { -- Do all the declarations
+      ; ((tcg_env, tcl_env), lie) <- captureConstraints $
               do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
                  ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                               checkMain explicit_mod_hdr
                  ; return (tcg_env, tcl_env) }
       ; setEnvs (tcg_env, tcl_env) $ do {
 
+        -- Emit Typeable bindings
+      ; tcg_env <- setGblEnv tcg_env mkTypeableBinds
+
+      ; setGblEnv tcg_env $ do {
+
 #ifdef GHCI
       ; finishTH
 #endif /* GHCI */
@@ -544,7 +542,7 @@ tcRnSrcDecls explicit_mod_hdr decls
 
       ; setGlobalTypeEnv tcg_env' final_type_env
 
-   } }
+   } } }
 
 tc_rn_src_decls :: [LHsDecl RdrName]
                 -> TcM (TcGblEnv, TcLclEnv)
index 314e20c..dce33d3 100644 (file)
@@ -30,7 +30,6 @@ module TcTyDecls(
 
 import TcRnMonad
 import TcEnv
-import TcTypeable( mkTypeableBinds )
 import TcBinds( tcRecSelBinds )
 import TyCoRep( Type(..), TyBinder(..), delBinderVar )
 import TcType
@@ -863,10 +862,7 @@ tcAddImplicits tycons
     do { traceTc "tcAddImplicits" $ vcat
             [ text "tycons" <+> ppr tycons
             , text "implicits" <+> ppr implicit_things ]
-       ; gbl_env <- mkTypeableBinds tycons
-       ; gbl_env <- setGblEnv gbl_env $
-                    tcRecSelBinds (mkRecSelBinds tycons)
-       ; return gbl_env }
+       ; tcRecSelBinds (mkRecSelBinds tycons) }
  where
    implicit_things = concatMap implicitTyConThings tycons
    def_meth_ids    = mkDefaultMethodIds tycons
index 0be765c..3b380f7 100644 (file)
@@ -3,9 +3,9 @@
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
 -}
 
-module TcTypeable(
-    mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings
-  ) where
+{-# LANGUAGE RecordWildCards #-}
+
+module TcTypeable(mkTypeableBinds) where
 
 
 import TcBinds( addTypecheckedBinds )
@@ -14,8 +14,6 @@ import TcEnv
 import TcRnMonad
 import PrelNames
 import TysPrim ( primTyCons )
-import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon
-                  , trTyConDataCon, trNameSDataCon )
 import Id
 import Type
 import TyCon
@@ -28,9 +26,10 @@ import DynFlags
 import Bag
 import Fingerprint(Fingerprint(..), fingerprintString)
 import Outputable
-import Data.Word( Word64 )
 import FastString ( FastString, mkFastString )
 
+import Data.Word( Word64 )
+
 {- Note [Grand plan for Typeable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The overall plan is this:
@@ -67,14 +66,16 @@ The overall plan is this:
 
 There are many wrinkles:
 
-* Since we generate $tcT for every data type T, the types TyCon and
-  Module must be available right from the start; so they are wired in (and
-  defined in ghc-prim:GHC.Types).
+* The timing of when we produce this bindings is rather important: they must be
+  defined after the rest of the module has been typechecked since we need to be
+  able to lookup Module and TyCon in the type environment and we may be
+  currently compiling GHC.Types (where they are defined).
 
 * GHC.Prim doesn't have any associated object code, so we need to put the
-  representations for types defined in this module elsewhere. We put these
-  in GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for injecting
-  the bindings for the GHC.Prim representions when compiling GHC.Types.
+  representations for types defined in this module elsewhere. We chose this
+  place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
+  injecting the bindings for the GHC.Prim representions when compiling
+  GHC.Types.
 
 * TyCon.tyConRepModOcc is responsible for determining where to find
   the representation binding for a given type. This is where we handle
@@ -86,6 +87,32 @@ There are many wrinkles:
 
 -}
 
+-- | Generate the Typeable bindings for a module. This is the only
+-- entry-point of this module and is invoked by the typechecker driver in
+-- 'tcRnSrcDecls'.
+--
+-- See Note [Grand plan for Typeable] in TcTypeable.
+mkTypeableBinds :: TcM TcGblEnv
+mkTypeableBinds
+  = do { -- Create a binding for $trModule.
+         -- Do this before processing any data type declarations,
+         -- which need tcg_tr_module to be initialised
+       ; tcg_env <- mkModIdBindings
+         -- Now we can generate the TyCon representations...
+         -- First we handle the primitive TyCons if we are compiling GHC.Types
+       ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
+         -- Then we produce bindings for the user-defined types in this module.
+       ; setGblEnv tcg_env $
+             let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
+             in mkTypeableTyConBinds tycons
+       }
+  where
+    needs_typeable_binds tc =
+          (not (isFamInstTyCon tc) && isAlgTyCon tc)
+       || isDataFamilyTyCon tc
+       || isClassTyCon tc
+
+
 {- *********************************************************************
 *                                                                      *
             Building top-level binding for $trModule
@@ -96,20 +123,23 @@ mkModIdBindings :: TcM TcGblEnv
 mkModIdBindings
   = do { mod <- getModule
        ; loc <- getSrcSpanM
-       ; mod_nm     <- newGlobalBinder mod (mkVarOcc "$trModule") loc
-       ; let mod_id   = mkExportedVanillaId mod_nm
-                                            (mkTyConApp trModuleTyCon [])
-             mod_bind = mkVarBind mod_id (mkModIdRHS mod)
+       ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
+       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
+       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod
 
        ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
        ; return (tcg_env { tcg_tr_module = Just mod_id }
                  `addTypecheckedBinds` [unitBag mod_bind]) }
 
-mkModIdRHS :: Module -> LHsExpr Id
+mkModIdRHS :: Module -> TcM (LHsExpr Id)
 mkModIdRHS mod
-  = nlHsApps (dataConWrapId trModuleDataCon)
-             [ trNameLit (unitIdFS (moduleUnitId mod))
-             , trNameLit (moduleNameFS (moduleName mod)) ]
+  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
+       ; trNameLit <- mkTrNameLit
+       ; return $ nlHsApps (dataConWrapId trModuleDataCon)
+                           [ trNameLit (unitIdFS (moduleUnitId mod))
+                           , trNameLit (moduleNameFS (moduleName mod)) ]
+       }
 
 {- *********************************************************************
 *                                                                      *
@@ -117,18 +147,16 @@ mkModIdRHS mod
 *                                                                      *
 ********************************************************************* -}
 
-mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
-mkTypeableBinds tycons
-  = do { dflags <- getDynFlags
-       ; gbl_env <- getGblEnv
+-- | Generate TyCon bindings for a set of type constructors
+mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv
+mkTypeableTyConBinds tycons
+  = do { gbl_env <- getGblEnv
        ; mod <- getModule
-       ; let pkg_str  = unitIdString (moduleUnitId mod)
-             mod_str  = moduleNameString (moduleName mod)
-             mod_expr = case tcg_tr_module gbl_env of  -- Should be set by now
+       ; let mod_expr = case tcg_tr_module gbl_env of  -- Should be set by now
                            Just mod_id -> nlHsVar mod_id
                            Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
-             stuff    = (dflags, mod_expr, pkg_str, mod_str)
-             all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
+       ; stuff <- collect_stuff mod mod_expr
+       ; let all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
                              -- We need type representations for any associated types
              tc_binds = map (mk_typeable_binds stuff) all_tycons
              tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
@@ -143,15 +171,28 @@ mkTypeableBinds tycons
 -- See Note [Grand plan for Typeable] in this module.
 mkPrimTypeableBinds :: TcM TcGblEnv
 mkPrimTypeableBinds
-  = do { dflags <- getDynFlags
-       ; mod <- getModule
-       ; let prim_binds :: LHsBinds Id
-             prim_binds
-               | mod == gHC_TYPES = ghcPrimTypeableBinds dflags
-               | otherwise        = emptyBag
-             prim_rep_ids = collectHsBindsBinders prim_binds
-       ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
-       ; return (gbl_env `addTypecheckedBinds` [prim_binds]) }
+  = do { mod <- getModule
+       ; if mod == gHC_TYPES
+           then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName
+                   ; let ghc_prim_module_id =
+                             mkExportedVanillaId trGhcPrimModuleName
+                                                 (mkTyConTy trModuleTyCon)
+
+                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
+                                             <$> mkModIdRHS gHC_PRIM
+
+                   ; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id)
+                   ; let prim_binds :: LHsBinds Id
+                         prim_binds = unitBag ghc_prim_module_bind
+                                      `unionBags` ghcPrimTypeableBinds stuff
+
+                         prim_rep_ids = collectHsBindsBinders prim_binds
+                   ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
+                   ; return (gbl_env `addTypecheckedBinds` [prim_binds])
+                   }
+           else getGblEnv
+       }
+  where
 
 -- | Generate bindings for the type representation of the wired-in TyCons defined
 -- by the virtual "GHC.Prim" module. This differs from the usual
@@ -160,35 +201,50 @@ mkPrimTypeableBinds
 -- "GHC.Types" yet are producing representations for types in "GHC.Prim").
 --
 -- See Note [Grand plan for Typeable] in this module.
-ghcPrimTypeableBinds :: DynFlags -> LHsBinds Id
-ghcPrimTypeableBinds dflags
-  = ghc_prim_module_bind `unionBags` unionManyBags (map mkBind all_prim_tys)
+ghcPrimTypeableBinds :: TypeableStuff -> LHsBinds Id
+ghcPrimTypeableBinds stuff
+  = unionManyBags (map mkBind all_prim_tys)
   where
     all_prim_tys :: [TyCon]
     all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
                          , tc' <- tc : tyConATs tc ]
 
-    ghc_prim_module_id =
-        mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon)
-    ghc_prim_module_bind =
-        unitBag $ mkVarBind ghc_prim_module_id (mkModIdRHS gHC_PRIM)
-
-    stuff :: TypeableStuff
-    stuff = (dflags, nlHsVar ghc_prim_module_id, "ghc-prim", "GHC.Prim")
-
     mkBind :: TyCon -> LHsBinds Id
     mkBind = mk_typeable_binds stuff
 
-trNameLit :: FastString -> LHsExpr Id
-trNameLit fs
-  = nlHsApps (dataConWrapId trNameSDataCon) [nlHsLit (mkHsStringPrimLit fs)]
-
-type TypeableStuff
-  = ( DynFlags
-    , LHsExpr Id  -- Of type GHC.Types.Module
-    , String      -- Package name
-    , String      -- Module name
-    )
+data TypeableStuff
+    = Stuff { dflags         :: DynFlags
+            , mod_rep        :: LHsExpr Id  -- ^ Of type GHC.Types.Module
+            , pkg_str        :: String      -- ^ Package name
+            , mod_str        :: String      -- ^ Module name
+            , trTyConTyCon   :: TyCon       -- ^ of @TyCon@
+            , trTyConDataCon :: DataCon     -- ^ of @TyCon@
+            , trNameLit      :: FastString -> LHsExpr Id
+                                            -- ^ To construct @TrName@s
+            }
+
+-- | Collect various tidbits which we'll need to generate TyCon representations.
+collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff
+collect_stuff mod mod_rep = do
+    dflags <- getDynFlags
+    let pkg_str  = unitIdString (moduleUnitId mod)
+        mod_str  = moduleNameString (moduleName mod)
+
+    trTyConTyCon   <- tcLookupTyCon trTyConTyConName
+    trTyConDataCon <- tcLookupDataCon trTyConDataConName
+    trNameLit      <- mkTrNameLit
+    return Stuff {..}
+
+-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
+-- can save the work of repeating lookups when constructing many TyCon
+-- representations.
+mkTrNameLit :: TcM (FastString -> LHsExpr Id)
+mkTrNameLit = do
+    trNameSDataCon <- tcLookupDataCon trNameSDataConName
+    let trNameLit :: FastString -> LHsExpr Id
+        trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon)
+                                [nlHsLit (mkHsStringPrimLit fs)]
+    return trNameLit
 
 -- | Make bindings for the type representations of a 'TyCon' and its
 -- promoted constructors.
@@ -196,28 +252,26 @@ mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
 mk_typeable_binds stuff tycon
   = mkTyConRepBinds stuff tycon
     `unionBags`
-    unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
+    unionManyBags (map (mkTyConRepBinds stuff . promoteDataCon)
+                       (tyConDataCons tycon))
 
+-- | Make typeable bindings for the given 'TyCon'.
 mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
-mkTyConRepBinds stuff tycon
+mkTyConRepBinds stuff@(Stuff {..}) tycon
   = case tyConRepName_maybe tycon of
       Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
          where
-           rep_id  = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon [])
+           rep_id  = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
            rep_rhs = mkTyConRepRHS stuff tycon
       _ -> emptyBag
 
--- | Produce typeable binds for the promoted 'TyCon' of a data constructor
-mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
-mkTypeableDataConBinds stuff dc
-  = mkTyConRepBinds stuff (promoteDataCon dc)
-
+-- | Produce the right-hand-side of a @TyCon@ representation.
 mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
-mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
+mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
   where
     rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
                        [ nlHsLit (word64 high), nlHsLit (word64 low)
-                       , mod_expr
+                       , mod_rep
                        , trNameLit (mkFastString tycon_str) ]
 
     tycon_str = add_tick (occNameString (getOccName tycon))
@@ -232,4 +286,3 @@ mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
     word64 :: Word64 -> HsLit
     word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
            | otherwise             = \n -> HsWordPrim   (show n) (toInteger n)
-
index dc6c0f5..a1aea0b 100644 (file)
@@ -344,7 +344,7 @@ data Levity = Lifted | Unlifted
 
 {- *********************************************************************
 *                                                                      *
-             Runtime represntation of TyCon
+             Runtime representation of TyCon
 *                                                                      *
 ********************************************************************* -}
 
index 935285a..0d7127d 100644 (file)
@@ -14,6 +14,11 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
 T2431.$WRefl =
   \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a GHC.Prim.~# a)
 
+-- RHS size: {terms: 4, types: 8, coercions: 0}
+absurd :: forall a. Int :~: Bool -> a
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>x]
+absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 a :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
@@ -53,10 +58,5 @@ T2431.$tc:~: =
   GHC.Types.TyCon
     9759653149176674453## 12942818337407067047## T2431.$trModule a3
 
--- RHS size: {terms: 4, types: 8, coercions: 0}
-absurd :: forall a. Int :~: Bool -> a
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>x]
-absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
-
 
 
index 2282681..cc62fa1 100644 (file)
@@ -7,7 +7,7 @@
       These potential instances exist:
         instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’
         instance Show Ordering -- Defined in ‘GHC.Show’
-        instance Show Integer -- Defined in ‘GHC.Show’
+        instance Show TyCon -- Defined in ‘GHC.Show’
         ...plus 30 others
         ...plus 10 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
index 31795bf..3bd9d88 100644 (file)
@@ -2,81 +2,81 @@
 ==================== Tidy Core ====================
 Result size of Tidy Core = {terms: 51, types: 20, coercions: 5}
 
+-- RHS size: {terms: 2, types: 2, coercions: 0}
+a :: Wrap Age -> Wrap Age
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
+a = \ (ds :: Wrap Age) -> ds
+
+-- RHS size: {terms: 1, types: 0, coercions: 5}
+convert :: Wrap Age -> Int
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
+convert =
+  a
+  `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0]
+          :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a :: GHC.Types.TrName
+a1 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a = GHC.Types.TrNameS "main"#
+a1 = GHC.Types.TrNameS "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a1 :: GHC.Types.TrName
+a2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a1 = GHC.Types.TrNameS "Roles13"#
+a2 = GHC.Types.TrNameS "Roles13"#
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 Roles13.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs, Str=DmdType]
-Roles13.$trModule = GHC.Types.Module a a1
+Roles13.$trModule = GHC.Types.Module a1 a2
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a2 :: GHC.Types.TrName
+a3 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a2 = GHC.Types.TrNameS "'MkAge"#
+a3 = GHC.Types.TrNameS "'MkAge"#
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tc'MkAge :: GHC.Types.TyCon
 [GblId, Caf=NoCafRefs, Str=DmdType]
 Roles13.$tc'MkAge =
   GHC.Types.TyCon
-    1226019810264079099## 12180888342844277416## Roles13.$trModule a2
+    1226019810264079099## 12180888342844277416## Roles13.$trModule a3
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a3 :: GHC.Types.TrName
+a4 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a3 = GHC.Types.TrNameS "Age"#
+a4 = GHC.Types.TrNameS "Age"#
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tcAge :: GHC.Types.TyCon
 [GblId, Caf=NoCafRefs, Str=DmdType]
 Roles13.$tcAge =
   GHC.Types.TyCon
-    18304088376370610314## 1954648846714895105## Roles13.$trModule a3
+    18304088376370610314## 1954648846714895105## Roles13.$trModule a4
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a4 :: GHC.Types.TrName
+a5 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a4 = GHC.Types.TrNameS "'MkWrap"#
+a5 = GHC.Types.TrNameS "'MkWrap"#
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tc'MkWrap :: GHC.Types.TyCon
 [GblId, Caf=NoCafRefs, Str=DmdType]
 Roles13.$tc'MkWrap =
   GHC.Types.TyCon
-    12402878715225676312## 13345418993613492500## Roles13.$trModule a4
+    12402878715225676312## 13345418993613492500## Roles13.$trModule a5
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-a5 :: GHC.Types.TrName
+a6 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=DmdType]
-a5 = GHC.Types.TrNameS "Wrap"#
+a6 = GHC.Types.TrNameS "Wrap"#
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tcWrap :: GHC.Types.TyCon
 [GblId, Caf=NoCafRefs, Str=DmdType]
 Roles13.$tcWrap =
   GHC.Types.TyCon
-    5278920226786541118## 14554440859491798587## Roles13.$trModule a5
-
--- RHS size: {terms: 2, types: 2, coercions: 0}
-a6 :: Wrap Age -> Wrap Age
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
-a6 = \ (ds :: Wrap Age) -> ds
-
--- RHS size: {terms: 1, types: 0, coercions: 5}
-convert :: Wrap Age -> Int
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
-convert =
-  a6
-  `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0]
-          :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
+    5278920226786541118## 14554440859491798587## Roles13.$trModule a6
 
 
 
index ac570df..b96512c 100644 (file)
@@ -21,6 +21,58 @@ T7360.$WFoo3 =
     T7360.Foo3 dt
     }
 
+-- RHS size: {terms: 5, types: 2, coercions: 0}
+fun1 [InlPrag=NOINLINE] :: Foo -> ()
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
+fun1 =
+  \ (x :: Foo) ->
+    case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+T7360.fun5 :: ()
+[GblId,
+ Str=DmdType,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
+T7360.fun5 = fun1 T7360.Foo1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+T7360.fun4 :: Int
+[GblId,
+ Caf=NoCafRefs,
+ Str=DmdType m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.fun4 = GHC.Types.I# 0#
+
+-- RHS size: {terms: 16, types: 13, coercions: 0}
+fun2 :: forall a. [a] -> ((), Int)
+[GblId,
+ Arity=1,
+ Str=DmdType <L,1*U>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
+                 (T7360.fun5,
+                  case x of wild {
+                    [] -> T7360.fun4;
+                    : _ [Occ=Dead] _ [Occ=Dead] ->
+                      case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
+                      GHC.Types.I# ww2
+                      }
+                  })}]
+fun2 =
+  \ (@ a) (x :: [a]) ->
+    (T7360.fun5,
+     case x of wild {
+       [] -> T7360.fun4;
+       : ds ds1 ->
+         case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
+         GHC.Types.I# ww2
+         }
+     })
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T7360.$trModule2 :: GHC.Types.TrName
 [GblId,
@@ -141,57 +193,5 @@ T7360.$tcFoo =
     T7360.$trModule
     T7360.$tcFoo1
 
--- RHS size: {terms: 5, types: 2, coercions: 0}
-fun1 [InlPrag=NOINLINE] :: Foo -> ()
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
-fun1 =
-  \ (x :: Foo) ->
-    case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() }
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.fun5 :: ()
-[GblId,
- Str=DmdType,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
-         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
-T7360.fun5 = fun1 T7360.Foo1
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.fun4 :: Int
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
-T7360.fun4 = GHC.Types.I# 0#
-
--- RHS size: {terms: 16, types: 13, coercions: 0}
-fun2 :: forall a. [a] -> ((), Int)
-[GblId,
- Arity=1,
- Str=DmdType <L,1*U>m,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True,
-         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
-         Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
-                 (T7360.fun5,
-                  case x of wild {
-                    [] -> T7360.fun4;
-                    : _ [Occ=Dead] _ [Occ=Dead] ->
-                      case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
-                      GHC.Types.I# ww2
-                      }
-                  })}]
-fun2 =
-  \ (@ a) (x :: [a]) ->
-    (T7360.fun5,
-     case x of wild {
-       [] -> T7360.fun4;
-       : ds ds1 ->
-         case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
-         GHC.Types.I# ww2
-         }
-     })
-
 
 
index 05a0069..43830c7 100644 (file)
@@ -1,3 +1,5 @@
+p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
+n = T8274.Negatives -4# -4.0# -4.0##
 T8274.$trModule2 = GHC.Types.TrNameS "main"#
 T8274.$trModule1 = GHC.Types.TrNameS "T8274"#
 T8274.$tc'Positives1 = GHC.Types.TrNameS "'Positives"#
@@ -8,5 +10,3 @@ T8274.$tc'Negatives1 = GHC.Types.TrNameS "'Negatives"#
 T8274.$tc'Negatives = GHC.Types.TyCon 15950179315687996644## 11481167534507418130## T8274.$trModule T8274.$tc'Negatives1
 T8274.$tcN1 = GHC.Types.TrNameS "N"#
 T8274.$tcN = GHC.Types.TyCon 7479687563082171902## 17616649989360543185## T8274.$trModule T8274.$tcN1
-p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
-n = T8274.Negatives -4# -4.0# -4.0##
index 64d5f7a..eaffa94 100644 (file)
@@ -1,5 +1,5 @@
+[GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m]
+ Str=DmdType <L,U(U)><L,U(U)>,
  Str=DmdType m1,
  Str=DmdType m1,
  Str=DmdType m,
-[GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m]
- Str=DmdType <L,U(U)><L,U(U)>,