import Name
import VarEnv
import Util
+import ListSetOps
import VarSet
import TysPrim
import PrelNames
import DynFlags
import Outputable
import FastString
-import Panic
+-- import Panic
import Constants ( wORD_SIZE )
import GHC.Arr ( Array(..) )
import GHC.Exts
-import GHC.IOBase ( IO(IO) )
+
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO ( IO(..) )
+#else
+import GHC.IOBase ( IO(..) )
+#endif
import Control.Monad
import Data.Maybe
import Data.List
import qualified Data.Sequence as Seq
import Data.Monoid
-import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
-import Foreign
+import Data.Sequence (viewl, ViewL(..))
+import Foreign hiding (unsafePerformIO)
import System.IO.Unsafe
-import System.IO
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
instance Outputable ClosureType where
ppr = text . show
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
aP_CODE, pAP_CODE :: Int
aP_CODE = AP
ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
-pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- tcSplitTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
, Just new_dc <- tyConSingleDataCon_maybe tc = do
- real_term <- y max_prec t
- return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+ real_term <- y max_prec t
+ return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
-------------------------------------------------------
. mapM (y (-1))
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
- (\ p Term{subTerms=[h,t]} -> doList p h t)
+ (\ p t -> doList p t)
, ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
, ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
, ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
| pred t = Just `liftM` f prec t
ifTerm _ _ _ _ = return Nothing
- isIntegerTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (tyConName tc == integerTyConName)
-
isTupleTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (isBoxedTupleTyCon tc)
(tc,_) <- tcSplitTyConApp_maybe ty
return (a_tc == tc)
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
coerceShow f _p = return . text . show . f . unsafeCoerce# . val
--Note pprinting of list terms is not lazy
- doList p h t = do
+ doList p (Term{subTerms=[h,t]}) = do
let elems = h : getListTerms t
isConsLast = not(termType(last elems) `coreEqType` termType h)
print_elems <- mapM (y cons_prec) elems
getListTerms Term{subTerms=[]} = []
getListTerms t@Suspension{} = [t]
getListTerms t = pprPanic "getListTerms" (ppr t)
+ doList _ _ = panic "doList"
repPrim :: TyCon -> [Word] -> String
liftTcM = id
newVar :: Kind -> TR TcType
-newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
+newVar = liftTcM . newFlexiTyVarTy
-- | Returns the instantiated type scheme ty', and the substitution sigma
-- such that sigma(ty') = ty
instScheme :: Type -> TR (TcType, TvSubst)
instScheme ty = liftTcM$ do
- (tvs, _, _) <- tcInstType return ty
+ (tvs, _, _) <- tcInstType return ty
(tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
text "with", ppr expected])
(congruenceNewtypes actual expected >>=
- (getLIE . uncurry boxyUnify) >> return ())
+ (captureConstraints . uncurry unifyType) >> return ())
-- TOMDO: what about the coercion?
-- we should consider family instances
clos <- trIO $ getClosureData a
case tipe clos of
-- Thunks we may want to force
--- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
--- force blackholes, because it would almost certainly result in deadlock,
--- and showing the '_' is more useful.
t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
seq a (go (pred max_depth) my_ty old_ty a)
+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
+-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
+-- showing '_' which is what we want.
+ Blackhole -> do traceTR (text "Following a BLACKHOLE")
+ appArr (go max_depth my_ty old_ty) (ptrs clos) 0
-- We always follow indirections
Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
go max_depth my_ty old_ty $! (ptrs clos ! 0)
-- to subterms is already being done via matching.
when (not monomorphic) $ do
let myType = mkFunTys subTermTvs my_ty
- (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
+ (signatureType,_) <- instScheme (mydataConType dc)
-- It is vital for newtype reconstruction that the unification step
-- is done right here, _before_ the subterms are RTTI reconstructed
addConstraint myType signatureType
go my_ty a = do
clos <- trIO $ getClosureData a
case tipe clos of
+ Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
Indirection _ -> go my_ty $! (ptrs clos ! 0)
MutVar _ -> do
contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
-- It is vital for newtype reconstruction that the unification step
-- is done right here, _before_ the subterms are RTTI reconstructed
let myType = mkFunTys subTtypes my_ty
- (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
+ (signatureType,_) <- instScheme(mydataConType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i
| (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
-- In particular, we want them to unify with things.
improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
- traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
+ traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
- getLIE(boxyUnify rtti_ty' ty')
+ _ <- captureConstraints (unifyType rtti_ty' ty')
tvs1_contents <- zonkTcTyVars ty_tvs'
let subst = (uncurry zipTopTvSubst . unzip)
[(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
| null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
| otherwise = dataConRepArgTys dc
+mydataConType :: DataCon -> Type
+-- ^ Custom version of DataCon.dataConUserType where we
+-- - remove the equality constraints
+-- - use the representation types for arguments, including dictionaries
+-- - keep the original result type
+mydataConType dc
+ = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
+ mkFunTys arg_tys $
+ res_ty
+ where univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+ eq_spec = dataConEqSpec dc
+ arg_tys = [case a of
+ PredTy p -> predTypeRep p
+ _ -> a
+ | a <- dataConRepArgTys dc]
+ res_ty = dataConOrigResTy dc
+
isRefType :: Type -> Bool
isRefType ty
| Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
text " in presence of newtype evidence " <> ppr new_tycon)
vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon vars
- liftTcM (boxyUnify ty (repType ty'))
+ _ <- liftTcM (unifyType ty (repType ty'))
-- assumes that reptype doesn't ^^^^ touch tyconApp args
return ty'
}
--------------------------------------------------------------------------------
--- representation types for thetas
-rttiView :: Type -> Type
-rttiView ty | Just ty' <- coreView ty = rttiView ty'
-rttiView ty
- | (tvs, theta, tau) <- tcSplitSigmaTy ty
- = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
-
-- Restore Class predicates out of a representation type
dictsView :: Type -> Type
-- dictsView ty = ty