isTerm,
isSuspension,
isPrim,
+ isNewtypeWrap,
pprTerm,
cPprTerm,
cPprTermBase,
termTyVars,
-- unsafeDeepSeq,
cvReconstructType,
- computeRTTIsubst,
+ improveRTTIType,
sigmaType,
Closure(..),
getClosureData,
import DataCon
import Type
import Var
-import TcRnMonad ( TcM, initTc, ioToTcRn,
- tryTcErrs, traceTc)
+import TcRnMonad
import TcType
import TcMType
import TcUnify
-import TcGadt
import TcEnv
import DriverPhases
import TyCon
import PrelNames
import TysWiredIn
-import Constants
import Outputable
-import Maybes
+import FastString
import Panic
+import Constants ( wORD_SIZE )
+
import GHC.Arr ( Array(..) )
import GHC.Exts
+import GHC.IOBase ( IO(IO) )
import Control.Monad
import Data.Maybe
import Foreign
import System.IO.Unsafe
+import System.IO
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
{-
- A few examples in this representation:
-
- > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
- > (('a',_,_),_,('b',_,_)) =
- Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
- [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
- , Suspension
- , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
-}
data Term = Term { ty :: Type
, dc :: Either String DataCon
- -- Empty if the datacon aint exported by the .hi
- -- (private constructors in -O0 libraries)
+ -- Carries a text representation if the datacon is
+ -- not exported by the .hi file, which is the case
+ -- for private constructors in -O0 compiled libraries
, val :: HValue
, subTerms :: [Term] }
, value :: [Word] }
| Suspension { ctype :: ClosureType
- , mb_ty :: Maybe Type
+ , ty :: Type
, val :: HValue
, bound_to :: Maybe Name -- Useful for printing
}
| NewtypeWrap{ ty :: Type
, dc :: Either String DataCon
, wrapped_term :: Term }
+ | RefWrap { ty :: Type
+ , wrapped_term :: Term }
isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
isTerm Term{} = True
isNewtypeWrap NewtypeWrap{} = True
isNewtypeWrap _ = False
-termType :: Term -> Maybe Type
-termType t@(Suspension {}) = mb_ty t
-termType t = Just$ ty t
+termType :: Term -> Type
+termType t = ty t
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {} = True
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm _ = False
instance Outputable (Term) where
- ppr = head . cPprTerm cPprTermBase
+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc
+ | otherwise = panic "Outputable Term instance"
-------------------------------------------------------------------------
-- Runtime Closure Datatype and functions for retrieving closure related stuff
| AP
| PAP
| Indirection Int
- | Other Int
+ | MutVar Int
+ | Other Int
deriving (Show, Eq)
data Closure = Closure { tipe :: ClosureType
getClosureData a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
-#ifndef GHCI_TABLES_NEXT_TO_CODE
- -- the info pointer we get back from unpackClosure# is to the
- -- beginning of the standard info table, but the Storable instance
- -- for info tables takes into account the extra entry pointer
- -- when !tablesNextToCode, so we must adjust here:
- itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
-#else
- itbl <- peek (Ptr iptr)
-#endif
+ let iptr'
+ | ghciTablesNextToCode =
+ Ptr iptr
+ | otherwise =
+ -- the info pointer we get back from unpackClosure#
+ -- is to the beginning of the standard info table,
+ -- but the Storable instance for info tables takes
+ -- into account the extra entry pointer when
+ -- !ghciTablesNextToCode, so we must adjust here:
+ Ptr iptr `plusPtr` negate wORD_SIZE
+ itbl <- peek iptr'
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
-readCType i
+readCType i
| i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
| i >= FUN && i <= FUN_STATIC = Fun
- | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
+ | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
| i == THUNK_SELECTOR = ThunkSelector
| i == BLACKHOLE = Blackhole
- | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
- | fromIntegral i == aP_CODE = AP
+ | i >= IND && i <= IND_STATIC = Indirection i'
+ | i' == aP_CODE = AP
| i == AP_STACK = AP
- | fromIntegral i == pAP_CODE = PAP
- | otherwise = Other (fromIntegral i)
-
+ | i' == pAP_CODE = PAP
+ | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
+ | otherwise = Other i'
+ where i' = fromIntegral i
+
isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
isIndirection (Indirection _) = True
---isIndirection ThunkSelector = True
isIndirection _ = False
isThunk (Thunk _) = True
| otherwise = pprPanic "Expected a TcTyCon" (ppr t)
go [] _ = []
go (t:tt) xx
- | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
+ | (x, rest) <- splitAt (sizeofType t) xx
= x : go tt rest
-sizeofTyCon :: TyCon -> Int
-sizeofTyCon = sizeofPrimRep . tyConPrimRep
+sizeofTyCon :: TyCon -> Int -- in *words*
+sizeofTyCon = primRepSizeW . tyConPrimRep
-----------------------------------
-- * Traversals for Terms
-----------------------------------
type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
-data TermFold a = TermFold { fTerm :: TermProcessor a a
- , fPrim :: Type -> [Word] -> a
- , fSuspension :: ClosureType -> Maybe Type -> HValue
- -> Maybe Name -> a
+data TermFold a = TermFold { fTerm :: TermProcessor a a
+ , fPrim :: Type -> [Word] -> a
+ , fSuspension :: ClosureType -> Type -> HValue
+ -> Maybe Name -> a
, fNewtypeWrap :: Type -> Either String DataCon
-> a -> a
+ , fRefWrap :: Type -> a -> a
}
foldTerm :: TermFold a -> Term -> a
foldTerm tf (Prim ty v ) = fPrim tf ty v
foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
+foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
idTermFold :: TermFold Term
idTermFold = TermFold {
fTerm = Term,
fPrim = Prim,
fSuspension = Suspension,
- fNewtypeWrap = NewtypeWrap
+ fNewtypeWrap = NewtypeWrap,
+ fRefWrap = RefWrap
}
idTermFoldM :: Monad m => TermFold (m Term)
idTermFoldM = TermFold {
fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
fPrim = (return.). Prim,
fSuspension = (((return.).).). Suspension,
- fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t
+ fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
+ fRefWrap = \ty t -> RefWrap ty `liftM` t
}
mapTermType :: (Type -> Type) -> Term -> Term
mapTermType f = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
- fSuspension = \ct mb_ty hval n ->
- Suspension ct (fmap f mb_ty) hval n,
- fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t}
+ fSuspension = \ct ty hval n ->
+ Suspension ct (f ty) hval n,
+ fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
+ fRefWrap = \ty t -> RefWrap (f ty) t}
termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
- fSuspension = \_ mb_ty _ _ ->
- maybe emptyVarEnv tyVarsOfType mb_ty,
+ fSuspension = \_ ty _ _ -> tyVarsOfType ty,
fPrim = \ _ _ -> emptyVarEnv,
- fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t}
+ fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
+ fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
where concatVarEnv = foldr plusVarEnv emptyVarEnv
----------------------------------
-- Pretty printing of terms
----------------------------------
-app_prec,cons_prec ::Int
-app_prec = 10
+type Precedence = Int
+type TermPrinter = Precedence -> Term -> SDoc
+type TermPrinterM m = Precedence -> Term -> m SDoc
+
+app_prec,cons_prec, max_prec ::Int
+max_prec = 10
+app_prec = max_prec
cons_prec = 5 -- TODO Extract this info from GHC itself
-pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
-pprTerm y p t | Just doc <- pprTermM y p t = doc
+pprTerm :: TermPrinter -> TermPrinter
+pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
pprTerm _ _ _ = panic "pprTerm"
-pprTermM, pprNewtypeWrap :: Monad m =>
- (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
-pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
- return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
+ return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
-pprTermM y p Term{dc=Right dc, subTerms=tt}
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
- = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
- <+> hsep (map (pprTerm1 True) tt)
+ = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+ <+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
| null tt = return$ ppr dc
| otherwise = do
tt_docs <- mapM (y app_prec) tt
- return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
-
-pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
-
-pprTermM _ _ t = pprTermM1 t
-
-pprTermM1 :: Monad m => Term -> m SDoc
-pprTermM1 Prim{value=words, ty=ty} =
+ return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+ppr_termM y p RefWrap{wrapped_term=t} = do
+ contents <- y app_prec t
+ return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
+ -- The constructor name is wired in here ^^^ for the sake of simplicity.
+ -- I don't think mutvars are going to change in a near future.
+ -- In any case this is solely a presentation matter: MutVar# is
+ -- a datatype with no constructors, implemented by the RTS
+ -- (hence there is no way to obtain a datacon and print it).
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 :: Monad m => Term -> m SDoc
+ppr_termM1 Prim{value=words, ty=ty} =
return$ text$ repPrim (tyConAppTyCon ty) words
-pprTermM1 Term{} = panic "pprTermM1 - unreachable"
-pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
-pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
- | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
- | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
-pprTermM1 _ = panic "pprTermM1"
+ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
+ppr_termM1 Suspension{ty=ty, bound_to=Just n}
+ | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
+ | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 Term{} = panic "ppr_termM1 - Term"
+ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- splitNewTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
- , Just new_dc <- maybeTyConSingleCon tc = do
- real_term <- y 10 t
+ , Just new_dc <- tyConSingleDataCon_maybe tc = do
+ real_term <- y max_prec t
return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
-- which I didn't. Therefore, this code replicates a lot
-- of what type classes provide for free.
--- Concretely a custom term printer takes an explicit
--- recursion knot, and produces a list of Term Processors,
--- which additionally need a precedence value to
--- either produce a SDoc or fail (and they do this in some monad m).
-
-type Precedence = Int
-type RecursionKnot m = Precedence -> Term -> m SDoc
-type CustomTermPrinter m = RecursionKnot m
+type CustomTermPrinter m = TermPrinterM m
-> [Precedence -> Term -> (m (Maybe SDoc))]
--- Takes a list of custom printers with a explicit recursion knot and a term,
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
-- and returns the output of the first succesful printer, or the default printer
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ = go 0 where
printers = printers_ go
- go prec t | isTerm t || isNewtypeWrap t = do
+ go prec t = do
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
Just doc <- firstJustM mb_customDocs
return$ cparen (prec>app_prec+1) doc
- go _ t = pprTermM1 t
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
coerceShow f _p = return . text . show . f . unsafeCoerce# . val
- --TODO pprinting of list terms is not lazy
+ --Note pprinting of list terms is not lazy
doList p h t = do
let elems = h : getListTerms t
- isConsLast = termType(last elems) /= termType h
+ isConsLast = not(termType(last elems) `coreEqType` termType h)
print_elems <- mapM (y cons_prec) elems
return$ if isConsLast
then cparen (p >= cons_prec)
- . hsep
+ . pprDeeperList fsep
. punctuate (space<>colon)
$ print_elems
- else brackets (hcat$ punctuate comma print_elems)
+ else brackets (pprDeeperList fcat$
+ punctuate comma print_elems)
- where Just a /= Just b = not (a `coreEqType` b)
- _ /= _ = True
- getListTerms Term{subTerms=[h,t]} = h : getListTerms t
- getListTerms Term{subTerms=[]} = []
+ where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+ getListTerms Term{subTerms=[]} = []
getListTerms t@Suspension{} = [t]
getListTerms t = pprPanic "getListTerms" (ppr t)
Just x -> return x
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
-runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
traceTR :: SDoc -> TR ()
traceTR = liftTcM . traceTc
trIO :: IO a -> TR a
-trIO = liftTcM . ioToTcRn
+trIO = liftTcM . liftIO
liftTcM :: TcM a -> TR a
liftTcM = id
newVar :: Kind -> TR TcType
-newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
+newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
-- | Returns the instantiated type scheme ty', and the substitution sigma
-- such that sigma(ty') = ty
-- Before unification, congruenceNewtypes needs to
-- do its magic.
addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
+addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry boxyUnify
>> return () -- TOMDO: what about the coercion?
-- we should consider family instances
go bound _ _ _ | seq bound False = undefined
go 0 tv _ty a = do
clos <- trIO $ getClosureData a
- return (Suspension (tipe clos) (Just tv) a Nothing)
+ return (Suspension (tipe clos) tv a Nothing)
go bound tv ty a = do
let monomorphic = not(isTyVarTy tv)
-- This ^^^ is a convention. The ancestor tests for
t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
+-- We also follow references
+ MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
+ -- , tycon == mutVarPrimTyCon
+ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ addConstraint tv (mkTyConApp tycon [world,tv'])
+ x <- go bound tv' ty_contents contents
+ return (RefWrap ty x)
+
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
subTermsP <- sequence $ drop extra_args
- -- ^^^ all extra arguments are pointed
+ -- \^^^ all extra arguments are pointed
[ appArr (go (pred bound) tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
- tipe_clos ->
- return (Suspension tipe_clos (Just tv) a Nothing)
+ tipe_clos ->
+ return (Suspension tipe_clos tv a Nothing)
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
reOrderTerms _ _ [] = []
reOrderTerms pointed unpointed (ty:tys)
| isPointed ty = ASSERT2(not(null pointed)
- , ptext SLIT("reOrderTerms") $$
+ , ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
| otherwise = ASSERT2(not(null unpointed)
- , ptext SLIT("reOrderTerms") $$
+ , ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
| Just (tc, args) <- splitNewTyConApp_maybe ty
, isNewTyCon tc
, wrapped_type <- newTyConInstRhs tc args
- , Just dc <- maybeTyConSingleCon tc
+ , Just dc <- tyConSingleDataCon_maybe tc
, t' <- expandNewtypes t{ ty = wrapped_type
, subTerms = map expandNewtypes tt }
= NewtypeWrap ty (Right dc) t'
clos <- trIO $ getClosureData a
case tipe clos of
Indirection _ -> go tv $! (ptrs clos ! 0)
+ MutVar _ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ world <- newVar liftedTypeKind
+ addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
+-- x <- go tv' ty_contents contents
+ return [(tv', contents)]
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
zip [0..] (filter isPointed subTtypes)]
_ -> return []
- -- This helper computes the difference between a base type t and the
- -- improved rtti_t computed by RTTI
- -- The main difference between RTTI types and their normal counterparts
- -- is that the former are _not_ polymorphic, thus polymorphism must
- -- be stripped. Syntactically, forall's must be stripped.
- -- We also remove predicates.
-computeRTTIsubst :: Type -> Type -> TvSubst
-computeRTTIsubst ty rtti_ty =
- case mb_subst of
- Just subst -> subst
- Nothing -> pprPanic "Failed to compute a RTTI substitution"
- (ppr (ty, rtti_ty))
- -- In addition, we strip newtypes too, since the reconstructed type might
- -- not have recovered them all
- -- TODO stripping newtypes shouldn't be necessary, test
- where mb_subst = tcUnifyTys (const BindMe)
- [rttiView ty]
- [rttiView rtti_ty]
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
+improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
+ let (_,ty0) = splitForAllTys ty
+ ty_tvs = varSetElems $ tyVarsOfType ty0
+ let (_,rtti_ty0)= splitForAllTys rtti_ty
+ rtti_tvs = varSetElems $ tyVarsOfType rtti_ty0
+ (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs [] ty0)
+ (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
+ boxyUnify rtti_ty' ty'
+ tvs1_contents <- zonkTcTyVars ty_tvs'
+ let subst = uncurry zipTopTvSubst
+ (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
+ , getTyVar_maybe ty /= Just tv
+ , not(isTyVarTy ty)])
+-- liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
+ return subst
-- Dealing with newtypes
{-
- A parallel fold over two Type values,
+ congruenceNewtypes does a parallel fold over two Type values,
compensating for missing newtypes on both sides.
This is necessary because newtypes are not present
- in runtime, but since sometimes there is evidence
- available we do our best to reconstruct them.
- Evidence can come from DataCon signatures or
+ in runtime, but sometimes there is evidence available.
+ Evidence can come from DataCon signatures or
from compile-time type inference.
- I am using the words congruence and rewriting
- because what we are doing here is an approximation
- of unification modulo a set of equations, which would
- come from newtype definitions. These should be the
- equality coercions seen in System Fc. Rewriting
- is performed, taking those equations as rules,
- before launching unification.
-
- It doesn't make sense to rewrite everywhere,
- or we would end up with all newtypes. So we rewrite
- only in presence of evidence.
- The lhs comes from the heap structure of ptrs,nptrs.
- The rhs comes from a DataCon type signature.
- Rewriting in the rhs is restricted to the result type.
+ What we are doing here is an approximation
+ of unification modulo a set of equations derived
+ from newtype definitions. These equations should be the
+ same as the equality coercions generated for newtypes
+ in System Fc. The idea is to perform a sort of rewriting,
+ taking those equations as rules, before launching unification.
+
+ The caller must ensure the following.
+ The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
+ The 2nd type (rhs) comes from a DataCon type signature.
+ Rewriting (i.e. adding/removing a newtype wrapper) can happen
+ in both types, but in the rhs it is restricted to the result type.
Note that it is very tricky to make this 'rewriting'
work with the unification implemented by TcM, where
- substitutions are 'inlined'. The order in which
- constraints are unified is vital for this.
- This is a simple form of residuation, the technique of
- delaying unification steps until enough information
- is available.
+ substitutions are operationally inlined. The order in which
+ constraints are unified is vital as we cannot modify
+ anything that has been touched by a previous unification step.
+Therefore, congruenceNewtypes is sound only if the types
+recovered by the RTTI mechanism are unified Top-Down.
-}
congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes lhs rhs
fTerm = \ty dc v tt -> sequence tt >>= \tt ->
zonkTcType ty >>= \ty' ->
return (Term ty' dc v tt)
- ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
+ ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
return (Suspension ct ty v b)
,fNewtypeWrap= \ty dc t ->
return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
projects / ghc-hetmet.git / blobdiff