Commit 463f566a authored by mnislaih's avatar mnislaih
Browse files

Refactoring only

Suspensions in the Term datatype used for RTTI
always get assigned a Type, so there is no reason
to juggle around with a (Maybe Type) anymore. 
parent 19c2956a
......@@ -74,13 +74,13 @@ pprintClosureCommand session bindThings force str = do
term_ <- GHC.obtainTerm cms force id
term <- tidyTermTyVars cms term_
term' <- if bindThings &&
Just False == isUnliftedTypeKind `fmap` termType term
False == isUnliftedTypeKind (termType term)
then bindSuspensions cms term
else return term
-- Before leaving, we compare the type obtained to see if it's more specific
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let Just reconstructed_type = termType term
let reconstructed_type = termType term
subst = unifyRTTI (idType id) (reconstructed_type)
return (term',subst)
......@@ -137,11 +137,10 @@ bindSuspensions cms@(Session ref) t = do
(term, names) <- t
return (RefWrap ty term, names)
}
doSuspension freeNames ct mb_ty hval _name = do
doSuspension freeNames ct ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
n <- newGrimName name
let ty' = fromMaybe (error "unexpected") mb_ty
return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
return (Suspension ct ty hval (Just n), [(n,ty,hval)])
-- A custom Term printer to enable the use of Show instances
......
......@@ -70,7 +70,6 @@ import TysWiredIn
import Constants
import Outputable
import Maybes
import Panic
import GHC.Arr ( Array(..) )
......@@ -114,7 +113,7 @@ data Term = Term { ty :: Type
, value :: [Word] }
| Suspension { ctype :: ClosureType
, mb_ty :: Maybe Type
, ty :: Type
, val :: HValue
, bound_to :: Maybe Name -- Useful for printing
}
......@@ -134,9 +133,8 @@ isPrim _ = False
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
......@@ -284,8 +282,8 @@ 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
, fSuspension :: ClosureType -> Type -> HValue
-> Maybe Name -> a
, fNewtypeWrap :: Type -> Either String DataCon
-> a -> a
, fRefWrap :: Type -> a -> a
......@@ -318,8 +316,8 @@ idTermFoldM = TermFold {
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,
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}
......@@ -327,8 +325,7 @@ 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,
fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
......@@ -369,7 +366,7 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt}
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, ty=ty} = do
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.
......@@ -384,10 +381,9 @@ ppr_termM1 :: Monad m => Term -> m SDoc
ppr_termM1 Prim{value=words, ty=ty} =
return$ text$ repPrim (tyConAppTyCon ty) words
ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
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 Suspension{} = panic "ppr_termM1 - Suspension"
ppr_termM1 Term{} = panic "ppr_termM1 - Term"
ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
......@@ -465,7 +461,7 @@ cPprTermBase y =
--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)
......@@ -475,9 +471,7 @@ cPprTermBase y =
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
where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
getListTerms Term{subTerms=[]} = []
getListTerms t@Suspension{} = [t]
getListTerms t = pprPanic "getListTerms" (ppr t)
......@@ -598,7 +592,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
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
......@@ -667,7 +661,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
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)
return (Suspension tipe_clos tv a Nothing)
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
......@@ -894,7 +888,7 @@ zonkTerm = foldTerm idTermFoldM {
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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment