Skip to content

GitLab

Commit cb429c8a authored by mnislaih's avatar mnislaih
Browse files

We no longer instantiate tyvars to Unknown types in the :print mechanism 

Instead, we keep the original tyvars.
The plan is to exploit type relationships among closures to recover more types.
parent 49ae18be
Hide whitespace changes
Inline Side-by-side
compiler/ghci/Debugger.hs
View file @ cb429c8a
......@@ -62,12 +62,11 @@ pprintClosureCommand bindThings force str = do
mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
io$ updateIds cms (catMaybes mb_new_ids)
where
-- Find the Id, clean up 'Unknowns' in the idType
-- Find the Id
cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
cleanUp cms newNames str = do
tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
return$ listToMaybe (map (stripUnknowns newNames)
[ i | Just (AnId i) <- tythings])
return$ listToMaybe [ i | Just (AnId i) <- tythings]
-- Do the obtainTerm--bindSuspensions-refineIdType dance
-- Warning! This function got a good deal of side-effects
......@@ -83,10 +82,8 @@ pprintClosureCommand bindThings force str = do
showDocWith LeftMode (doc (mkErrStyle unqual))
(putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
-- Before leaving, we compare the type obtained to see if it's more specific
-- Note how we need the Unknown-clear type returned by obtainTerm
let Just reconstructedType = termType term
new_type <- instantiateTyVarsToUnknown cms
(mostSpecificType (idType id) reconstructedType)
new_type = mostSpecificType (idType id) reconstructedType
return . Just $ setIdType id new_type
updateIds :: Session -> [Id] -> IO ()
......@@ -129,9 +126,8 @@ bindSuspensions cms@(Session ref) t = do
availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
concrete_tys <- mapM (instantiateTyVarsToUnknown cms) tys
let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
| (name,ty) <- zip names concrete_tys]
| (name,ty) <- zip names tys]
new_type_env = extendTypeEnvWithIds type_env ids
new_rn_env = extendLocalRdrEnv rn_env names
new_ic = ictxt { ic_rn_local_env = new_rn_env,
......@@ -208,45 +204,3 @@ newGrimName cms userName = do
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcLoc
return name
-- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
stripUnknowns :: [Name] -> Id -> Id
stripUnknowns names id = setIdType id . fst . go names . idType
$ id
where
go tyvarsNames@(v:vv) ty
| Just (ty1,ty2) <- splitFunTy_maybe ty = let
(ty1',vv') = go tyvarsNames ty1
(ty2',vv'')= go vv' ty2
in (mkFunTy ty1' ty2', vv'')
| Just (ty1,ty2) <- splitAppTy_maybe ty = let
(ty1',vv') = go tyvarsNames ty1
(ty2',vv'')= go vv' ty2
in (mkAppTy ty1' ty2', vv'')
| Just (tycon, args) <- splitTyConApp_maybe ty
, Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
, (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
in (arg':aa,vv'))
([],vv') args
= (mkAppTys tycon' args',vv'')
| Just (tycon, args) <- splitTyConApp_maybe ty
, (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
in (arg':aa,vv'))
([],tyvarsNames) args
= (mkTyConApp tycon args',vv')
| otherwise = (ty, tyvarsNames)
where fixTycon tycon (v:vv) = do
k <- lookup (tyConName tycon) kinds
return (mkTyVarTy$ mkTyVar v k, vv)
kinds = [ (unknownTyConName, liftedTypeKind)
, (unknown1TyConName, kind1)
, (unknown2TyConName, kind2)
, (unknown3TyConName, kind3)]
kind1 = mkArrowKind liftedTypeKind liftedTypeKind
kind2 = mkArrowKind kind1 liftedTypeKind
kind3 = mkArrowKind kind2 liftedTypeKind
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown (Session ref) ty
= do hsc_env <- readIORef ref
DebuggerTys.instantiateTyVarsToUnknown hsc_env ty
compiler/ghci/DebuggerTys.hs deleted 100644 → 0
View file @ 49ae18be
-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------
module DebuggerTys (instantiateTyVarsToUnknown) where
import HscTypes
import Type
import TcRnDriver
import Var
import PrelNames
import TyCon
import DataCon
import Control.Monad
----------------------------------------------------------------------------
-- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
----------------------------------------------------------------------------
instantiateTyVarsToUnknown :: HscEnv -> Type -> IO Type
instantiateTyVarsToUnknown hsc_env ty
-- We have a GADT, so just fix its tyvars
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
, isGADT tycon
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- We have a regular TyCon, so map recursively to its args
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
= do unknownTyVar <- unknownTV
args' <- mapM (instantiateTyVarsToUnknown hsc_env) args
return$ mkTyConApp tycon args'
-- we have a tyvar of kind *
| Just tyvar <- getTyVar_maybe ty
, ([],_) <- splitKindFunTys (tyVarKind tyvar)
= unknownTV
-- we have a higher kind tyvar, so insert an unknown of the appropriate kind
| Just tyvar <- getTyVar_maybe ty
, (args,_) <- splitKindFunTys (tyVarKind tyvar)
= liftM mkTyConTy $ unknownTC !! length args
-- Base case
| otherwise = return ty
where unknownTV = do
Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName
return$ mkTyConTy unknown_tc
unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
unknownTC1 = do
Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown1TyConName
return unknown_tc
unknownTC2 = do
Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown2TyConName
return unknown_tc
unknownTC3 = do
Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown3TyConName
return unknown_tc
-- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
| otherwise = False
fixTyVars ty
| Just (tycon, args) <- splitTyConApp_maybe ty
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- Fix the tyvar so that the interactive environment doesn't choke on it TODO
| Just tv <- getTyVar_maybe ty = return ty --TODO
| otherwise = return ty
compiler/ghci/RtClosureInspect.hs
View file @ cb429c8a
......@@ -464,10 +464,12 @@ newVar = liftTcM . newFlexiTyVar
liftTcM = id
instScheme :: Type -> TR TcType
instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
where fst3 (x,y,z) = x
trd (x,y,z) = z
-- | Returns the instantiated type scheme ty', and the substitution sigma
-- such that sigma(ty') = ty
instScheme :: Type -> TR (TcType, TvSubst)
instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
(tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm hsc_env force mb_ty a = do
......@@ -488,14 +490,19 @@ cvObtainTerm hsc_env force mb_ty a = do
cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
tv <- case (isMonomorphic `fmap` mb_ty) of
Just True -> return (fromJust mb_ty)
_ -> do
tv_ <- liftM mkTyVarTy (newVar argTypeKind)
when (isJust mb_ty) $
instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv_
return tv_
go tv (fromMaybe tv mb_ty) hval
tv <- liftM mkTyVarTy (newVar argTypeKind)
case mb_ty of
Nothing -> go tv tv hval
Just ty | isMonomorphic ty -> go ty ty hval
Just ty -> do
(ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty)
addConstraint tv ty'
term <- go tv tv hval
--restore original Tyvars
return$ flip foldTerm term idTermFold {
fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
where
go tv ty a = do
let monomorphic = not(isTyVarTy tv) -- This is a convention. The ancestor tests for
......@@ -522,7 +529,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
-- right here, _before_ the subterms are RTTI reconstructed.
when (not monomorphic) $ do
let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
instScheme(dataConRepType dc) >>= addConstraint myType
instScheme(dataConRepType dc) >>= addConstraint myType . fst
subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
[ appArr (go tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
......
compiler/main/GHC.hs
View file @ cb429c8a
......@@ -2310,7 +2310,7 @@ extendEnvironment hsc_env apStack idsOffsets = do
let (ids, hValues) = unzip idsVals
let names = map idName ids
let global_ids = map globaliseAndTidy ids
typed_ids <- mapM instantiateIdType global_ids
typed_ids <- return global_ids -- mapM instantiateIdType global_ids
let ictxt = hsc_IC hsc_env
rn_env = ic_rn_local_env ictxt
type_env = ic_type_env ictxt
......@@ -2334,12 +2334,6 @@ extendEnvironment hsc_env apStack idsOffsets = do
= let tidied_type = tidyTopType$ idType id
in setIdType (globaliseId VanillaGlobal id) tidied_type
-- | Instantiate the tyVars with GHC.Base.Unknown
instantiateIdType :: Id -> IO Id
instantiateIdType id = do
instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
return$ setIdType id instantiatedType
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
......
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