import DataCon
import Type
import Var
-import TcRnMonad ( TcM, initTc, ioToTcRn,
- tryTcErrs, traceTc)
+import TcRnMonad
import TcType
import TcMType
import TcUnify
import PrelNames
import TysWiredIn
-import Constants
import Outputable
-import Maybes
+import FastString
import Panic
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+import Constants ( wORD_SIZE )
+#endif
+
import GHC.Arr ( Array(..) )
import GHC.Exts
-import GHC.IOBase
+import GHC.IOBase ( IO(IO) )
import Control.Monad
import Data.Maybe
-- * 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
}
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
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
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
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}
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}
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.
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"
--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)
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)
traceTR = liftTcM . traceTc
trIO :: IO a -> TR a
-trIO = liftTcM . ioToTcRn
+trIO = liftTcM . liftIO
liftTcM :: TcM a -> TR a
liftTcM = id
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
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)
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.
+{-
+ 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.
+-}
unifyRTTI :: Type -> Type -> TvSubst
unifyRTTI ty rtti_ty =
case mb_subst of
-- 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