Replace (State# RealWorld) with Void# where we just want a 0-bit value
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 22 Nov 2013 15:23:22 +0000 (15:23 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 22 Nov 2013 18:59:28 +0000 (18:59 +0000)
We were re-using the super-magical "state token" type (which has
VoidRep and is zero bits wide) for situations in which we simply want
to lambda-abstract over a zero-bit argument. For example, join points:

   case (case x of { True -> e1; False -> e2 }) of
      Red  -> f1
      Blue -> True

==>

  let $j1 = \voidArg::Void# -> f1
  in
  case x of
    True -> case e1 of
              Red -> $j1 void
              Blue -> True
    False -> case e2 of
              Red -> $j1 void
              Blue -> True

This patch introduces

   * The new primitive type GHC.Prim.Void#, with PrimRep = VoidRep

   * A new global Id GHC.Prim.voidPrimId :: Void#.
     This has no binding because the code generator drops it,
     but is used as an argument (eg in the call of $j1)

   * A new local Id, MkId.voidArgId, which can be lambda-bound
     when you need to lambda-abstract over it.

and uses them throughout.

Now the State# thing is used only when we need state!

compiler/basicTypes/MkId.lhs
compiler/deSugar/DsUtils.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/WwLib.lhs
compiler/types/Type.lhs

index e68abd0..2bc0d12 100644 (file)
@@ -33,8 +33,9 @@ module MkId (
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
-        unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
-        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
+        unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
+        voidPrimId, voidArgId,
+        nullAddrId, seqId, lazyId, lazyIdKey,
         coercionTokenId, magicDictId, coerceId,
 
        -- Re-export error Ids
@@ -134,6 +135,7 @@ ghcPrimIds
   = [   -- These can't be defined in Haskell, but they have
         -- perfectly reasonable unfoldings in Core
     realWorldPrimId,
+    voidPrimId,
     unsafeCoerceId,
     nullAddrId,
     seqId,
@@ -1036,11 +1038,14 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 
 \begin{code}
-lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName, magicDictName, coerceName, proxyName :: Name
+lazyIdName, unsafeCoerceName, nullAddrName, seqName,
+   realWorldName, voidPrimIdName, coercionTokenName,
+   magicDictName, coerceName, proxyName :: Name
 unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
 seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
 realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
+voidPrimIdName    = mkWiredInIdName gHC_PRIM (fsLit "void#")         voidPrimIdKey      voidPrimId
 lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")         lazyIdKey           lazyId
 coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
 magicDictName     = mkWiredInIdName gHC_PRIM (fsLit "magicDict")     magicDictKey magicDictId
@@ -1299,27 +1304,29 @@ nasty as-is, change it back to a literal (@Literal@).
 voidArgId is a Local Id used simply as an argument in functions
 where we just want an arg to avoid having a thunk of unlifted type.
 E.g.
-        x = \ void :: State# RealWorld -> (# p, q #)
+        x = \ void :: Void# -> (# p, q #)
 
 This comes up in strictness analysis
 
-\begin{code}
-realWorldPrimId :: Id
-realWorldPrimId -- :: State# RealWorld
-  = pcMiscPrelId realWorldName realWorldStatePrimTy
-      (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)  -- Note [evaldUnfoldings]
-
-{- Note [evaldUnfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [evaldUnfoldings]
+~~~~~~~~~~~~~~~~~~~~~~
 The evaldUnfolding makes it look that some primitive value is
 evaluated, which in turn makes Simplify.interestingArg return True,
 which in turn makes INLINE things applied to said value likely to be
 inlined.
--}
 
-voidArgId :: Id
-voidArgId       -- :: State# RealWorld
-  = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
+
+\begin{code}
+realWorldPrimId :: Id   -- :: State# RealWorld
+realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
+                     (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)    -- Note [evaldUnfoldings]
+
+voidPrimId :: Id     -- Global constant :: Void#
+voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy
+                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)    -- Note [evaldUnfoldings]
+
+voidArgId :: Id       -- Local lambda-bound :: Void#
+voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
 
 coercionTokenId :: Id        -- :: () ~ ()
 coercionTokenId -- Used to replace Coercion terms when we go to STG
index 420cc0f..55eefc7 100644 (file)
@@ -730,10 +730,11 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression
                      CoreExpr) -- Fail variable applied to realWorld#
 -- See Note [Failure thunks and CPR]
 mkFailurePair expr
-  = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
-       ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
-       ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
-                 App (Var fail_fun_var) (Var realWorldPrimId)) }
+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
+       ; fail_fun_arg <- newSysLocalDs voidPrimTy
+       ; let real_arg = setOneShotLambda fail_fun_arg
+       ; return (NonRec fail_fun_var (Lam real_arg expr),
+                 App (Var fail_fun_var) (Var voidPrimId)) }
   where
     ty = exprType expr
 \end{code}
index 6223567..85da3ac 100644 (file)
@@ -1357,7 +1357,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
-    eqReprPrimTyConKey :: Unique
+    eqReprPrimTyConKey, voidPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -1365,6 +1365,7 @@ eqPrimTyConKey                          = mkPreludeTyConUnique 53
 eqReprPrimTyConKey                      = mkPreludeTyConUnique 54
 mutVarPrimTyConKey                      = mkPreludeTyConUnique 55
 ioTyConKey                              = mkPreludeTyConUnique 56
+voidPrimTyConKey                        = mkPreludeTyConUnique 57
 wordPrimTyConKey                        = mkPreludeTyConUnique 58
 wordTyConKey                            = mkPreludeTyConUnique 59
 word8TyConKey                           = mkPreludeTyConUnique 60
@@ -1576,7 +1577,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
     buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
     seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,
     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
-    runtimeErrorIdKey, patErrorIdKey,
+    runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
     realWorldPrimIdKey, recConErrorIdKey,
     unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
     unpackCStringFoldrIdKey, unpackCStringIdKey :: Unique
@@ -1601,6 +1602,7 @@ unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17
 unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 18
 unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 19
 unpackCStringIdKey            = mkPreludeMiscIdUnique 20
+voidPrimIdKey                 = mkPreludeMiscIdUnique 21
 
 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
     returnIOIdKey, newStablePtrIdKey,
index 6e47889..bbe5aba 100644 (file)
@@ -45,6 +45,7 @@ module TysPrim(
        floatPrimTyCon,         floatPrimTy,
        doublePrimTyCon,        doublePrimTy,
 
+       voidPrimTyCon,          voidPrimTy,
        statePrimTyCon,         mkStatePrimTy,
        realWorldTyCon,         realWorldTy, realWorldStatePrimTy,
 
@@ -128,6 +129,7 @@ primTyCons
     , stablePtrPrimTyCon
     , stableNamePrimTyCon
     , statePrimTyCon
+    , voidPrimTyCon
     , proxyPrimTyCon
     , threadIdPrimTyCon
     , wordPrimTyCon
@@ -154,7 +156,7 @@ mkPrimTc fs unique tycon
                  (ATyCon tycon)        -- Relevant TyCon
                  UserSyntax            -- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name
 charPrimTyConName            = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName             = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName           = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -166,6 +168,7 @@ addrPrimTyConName                 = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrim
 floatPrimTyConName           = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
 doublePrimTyConName          = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
 statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
+voidPrimTyConName             = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon
 proxyPrimTyConName            = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon
 eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
 eqReprPrimTyConName           = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
@@ -477,6 +480,12 @@ mkStatePrimTy ty = TyConApp statePrimTyCon [ty]
 statePrimTyCon :: TyCon   -- See Note [The State# TyCon]
 statePrimTyCon  = pcPrimTyCon statePrimTyConName [Nominal] VoidRep
 
+voidPrimTy :: Type
+voidPrimTy = TyConApp voidPrimTyCon []
+
+voidPrimTyCon :: TyCon
+voidPrimTyCon   = pcPrimTyCon voidPrimTyConName [] VoidRep
+
 mkProxyPrimTy :: Type -> Type -> Type
 mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]
 
index 25d765f..03150c6 100644 (file)
@@ -16,7 +16,7 @@ import SimplUtils
 import FamInstEnv       ( FamInstEnv )
 import Literal          ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326
 import Id
-import MkId             ( seqId, realWorldPrimId )
+import MkId             ( seqId, voidPrimId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
 import IdInfo
 import Name             ( mkSystemVarName, isExternalName )
@@ -35,7 +35,7 @@ import CoreUtils
 import CoreArity
 --import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
 import Rules            ( lookupRule, getRules )
-import TysPrim          ( realWorldStatePrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
+import TysPrim          ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( orElse )
@@ -2473,8 +2473,8 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
         ; (final_bndrs', final_args)    -- Note [Join point abstraction]
                 <- if (any isId used_bndrs')
                    then return (used_bndrs', varsToCoreExprs used_bndrs')
-                    else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
-                            ; return ([rw_id], [Var realWorldPrimId]) }
+                    else do { rw_id <- newId (fsLit "w") voidPrimTy
+                            ; return ([setOneShotLambda rw_id], [Var voidPrimId]) }
 
         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
                 -- Note [Funky mkPiTypes]
index 30224ba..225076e 100644 (file)
@@ -23,7 +23,7 @@ import CoreUtils        ( exprIsTrivial, applyTypeToArgs )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
 import UniqSupply
 import Name
-import MkId             ( voidArgId, realWorldPrimId )
+import MkId             ( voidArgId, voidPrimId )
 import Maybes           ( catMaybes, isJust )
 import BasicTypes
 import HscTypes
@@ -1138,7 +1138,7 @@ specCalls env rules_for_me calls_for_me fn rhs
              let body_ty = applyTypeToArgs rhs fn_type inst_args
                  (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
                    | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
-                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
+                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
                    | otherwise = (poly_tyvars, poly_tyvars)
                  spec_id_ty = mkPiTypes lam_args body_ty
 
index 2e6bacd..5c4cdbd 100644 (file)
@@ -18,8 +18,8 @@ import IdInfo           ( vanillaIdInfo )
 import DataCon
 import Demand
 import MkCore           ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
-import MkId             ( realWorldPrimId, voidArgId )
-import TysPrim          ( realWorldStatePrimTy )
+import MkId             ( voidArgId, voidPrimId )
+import TysPrim          ( voidPrimTy )
 import TysWiredIn       ( tupleCon )
 import Type
 import Coercion hiding  ( substTy, substTyVarBndr )
@@ -186,7 +186,7 @@ mkWorkerArgs dflags args all_one_shot res_ty
     | any isId args || not needsAValueLambda
     = (args, args)
     | otherwise
-    = (args ++ [newArg], args ++ [realWorldPrimId])
+    = (args ++ [newArg], args ++ [voidPrimId])
     where
       needsAValueLambda =
         isUnLiftedType res_ty
@@ -643,8 +643,8 @@ mk_absent_let dflags arg
   | Just tc <- tyConAppTyCon_maybe arg_ty
   , Just lit <- absentLiteralOf tc
   = Just (Let (NonRec arg (Lit lit)))
-  | arg_ty `eqType` realWorldStatePrimTy
-  = Just (Let (NonRec arg (Var realWorldPrimId)))
+  | arg_ty `eqType` voidPrimTy
+  = Just (Let (NonRec arg (Var voidPrimId)))
   | otherwise
   = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
     Nothing
index 4ccd020..9940f73 100644 (file)
@@ -63,7 +63,7 @@ module Type (
 
         -- ** Predicates on types
         isTypeVar, isKindVar,
-        isTyVarTy, isFunTy, isDictTy, isPredTy, 
+        isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy,
 
         -- (Lifting and boxity)
         isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
@@ -596,7 +596,7 @@ interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 Note [Nullary unboxed tuple]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We represent the nullary unboxed tuple as the unary (but void) type
-State# RealWorld.  The reason for this is that the ReprArity is never
+Void#.  The reason for this is that the ReprArity is never
 less than the Arity (as it would otherwise be for a function type like
 (# #) -> Int).
 
@@ -642,7 +642,7 @@ repType ty
 
       | isUnboxedTupleTyCon tc
       = if null tys
-         then UnaryRep realWorldStatePrimTy -- See Note [Nullary unboxed tuple]
+         then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple]
          else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys)
 
     go _ ty = UnaryRep ty
@@ -687,6 +687,12 @@ typeRepArity 0 _ = 0
 typeRepArity n ty = case repType ty of
   UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2
   _                        -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty))
+
+isVoidTy :: Type -> Bool
+-- True if the type has zero width
+isVoidTy ty = case repType ty of
+                UnaryRep (TyConApp tc _) -> isVoidRep (tyConPrimRep tc)
+                _                        -> False
 \end{code}
 
 Note [AppTy rep]