X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=45c5b0fa27d995c07ba37722b86bf97c2d3be74a;hb=b5986072833796acb374e22f18cef8ab839a3419;hp=96edf90a6a3648eefce2ff40ae437bb285baf9f2;hpb=cf48cf640cc96fc0cb50b5c683cf16bbede064a0;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 96edf90..45c5b0f 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -10,16 +10,10 @@ module RtClosureInspect( cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term - ClosureType(..), - getClosureData, -- :: a -> IO Closure - Closure ( tipe, infoPtr, ptrs, nonPtrs ), - isConstr, -- :: ClosureType -> Bool - isIndirection, -- :: ClosureType -> Bool - - Term(..), - printTerm, - customPrintTerm, - customPrintTermBase, + Term(..), + pprTerm, + cPprTerm, + cPprTermBase, termType, foldTerm, TermFold(..), @@ -87,9 +81,9 @@ import IO > (('a',_,_),_,('b',_,_)) = Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_)) - [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk] - , Thunk - , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]] + [ 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 @@ -122,7 +116,7 @@ isFullyEvaluatedTerm Suspension {} = False isFullyEvaluatedTerm Prim {} = True instance Outputable (Term) where - ppr = head . customPrintTerm customPrintTermBase + ppr = head . cPprTerm cPprTermBase ------------------------------------------------------------------------- -- Runtime Closure Datatype and functions for retrieving closure related stuff @@ -142,7 +136,6 @@ data Closure = Closure { tipe :: ClosureType , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue - -- What would be the type here? HValue is ok? Should I build a Ptr? , nonPtrs :: ByteArray# } @@ -175,6 +168,7 @@ readCType i | i == BLACKHOLE = Blackhole | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i) | fromIntegral i == aP_CODE = AP + | i == AP_STACK = AP | fromIntegral i == pAP_CODE = PAP | otherwise = Other (fromIntegral i) @@ -186,6 +180,11 @@ isIndirection (Indirection _) = True --isIndirection ThunkSelector = True isIndirection _ = False +isThunk (Thunk _) = True +isThunk ThunkSelector = True +isThunk AP = True +isThunk _ = False + isFullyEvaluated :: a -> IO Bool isFullyEvaluated a = do closure <- getClosureData a @@ -289,79 +288,75 @@ idTermFoldM = TermFold { -- Pretty printing of terms ---------------------------------- -parensCond True = parens -parensCond False = id app_prec::Int app_prec = 10 -printTerm :: Term -> SDoc -printTerm Prim{value=value} = text value -printTerm t@Term{} = printTerm1 0 t -printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_' -printTerm Suspension{mb_ty=Just ty, bound_to=Just n} - | Just _ <- splitFunTy_maybe ty = text "" - | otherwise = parens$ ppr n <> text "::" <> ppr ty - -printTerm1 p Term{dc=dc, subTerms=tt} +pprTerm :: Int -> Term -> SDoc +pprTerm p Term{dc=dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt - = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2) - <+> hsep (map (printTerm1 True) tt) + = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2) + <+> hsep (map (pprTerm1 True) tt) -} | null tt = ppr dc - | otherwise = parensCond (p > app_prec) - (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt)) + | otherwise = cparen (p >= app_prec) + (ppr dc <+> sep (map (pprTerm app_prec) tt)) where fixity = undefined -printTerm1 _ t = printTerm t +pprTerm _ t = pprTerm1 t -customPrintTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc -customPrintTerm custom = go 0 where --- go :: Monad m => Int -> Term -> m SDoc +pprTerm1 Prim{value=value} = text value +pprTerm1 t@Term{} = pprTerm 0 t +pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_' +pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n} + | Just _ <- splitFunTy_maybe ty = ptext SLIT("") + | otherwise = parens$ ppr n <> text "::" <> ppr ty + + +cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc +cPprTerm custom = go 0 where go prec t@Term{subTerms=tt, dc=dc} = do - let mb_customDocs = map ($t) (custom go) :: [m (Maybe SDoc)] + let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)] first_success <- firstJustM mb_customDocs case first_success of - Just doc -> return$ parensCond (prec>app_prec+1) doc + Just doc -> return$ cparen (prec>app_prec+1) doc -- | dataConIsInfix dc, (t1:t2:tt') <- tt = Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt - return$ parensCond (prec>app_prec+1) - (ppr dc <+> sep pprSubterms) - go _ t = return$ printTerm t + return$ cparen (prec >= app_prec) + (ppr dc <+> sep pprSubterms) + go _ t = return$ pprTerm1 t firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) firstJustM [] = return Nothing -customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)] -customPrintTermBase showP = +cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)] +cPprTermBase pprP = [ - test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms) - , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t) - , test (isDC intDataCon) (coerceShow$ \(a::Int)->a) - , test (isDC charDataCon) (coerceShow$ \(a::Char)->a) --- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a) - , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a) - , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a) - , test isIntegerDC (coerceShow$ \(a::Integer)->a) + ifTerm isTupleDC (\_ -> liftM (parens . hcat . punctuate comma) + . mapM (pprP (-1)) . subTerms) + , ifTerm (isDC consDataCon) (\ p Term{subTerms=[h,t]} -> doList p h t) + , ifTerm (isDC intDataCon) (coerceShow$ \(a::Int)->a) + , ifTerm (isDC charDataCon) (coerceShow$ \(a::Char)->a) +-- , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a) + , ifTerm (isDC floatDataCon) (coerceShow$ \(a::Float)->a) + , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a) + , ifTerm isIntegerDC (coerceShow$ \(a::Integer)->a) ] - where test pred f t = if pred t then liftM Just (f t) else return Nothing + where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing isIntegerDC Term{dc=dc} = dataConName dc `elem` [ smallIntegerDataConName , largeIntegerDataConName] - isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr)) - isDC a_dc Term{dc=dc} = a_dc == dc - coerceShow f = return . text . show . f . unsafeCoerce# . val + isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr)) + isDC a_dc Term{dc=dc} = a_dc == dc + coerceShow f _ = return . text . show . f . unsafeCoerce# . val --TODO pprinting of list terms is not lazy - doList h t = do + doList p h t = do let elems = h : getListTerms t - isConsLast = isSuspension (last elems) && - (mb_ty$ last elems) /= (termType h) - init <- mapM (showP 0) (init elems) - last0 <- showP 0 (last elems) - let last = case length elems of - 1 -> last0 - _ | isConsLast -> text " | " <> last0 - _ -> comma <> last0 - return$ brackets (hcat (punctuate comma init ++ [last])) + isConsLast = termType(last elems) /= termType h + print_elems <- mapM (pprP 5) elems + return$ if isConsLast + then cparen (p >= 5) . hsep . punctuate (space<>colon) + $ print_elems + else brackets (hcat$ punctuate comma print_elems) where Just a /= Just b = not (a `coreEqType` b) _ /= _ = True @@ -469,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 @@ -493,13 +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) - 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 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 @@ -507,7 +510,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do clos <- trIO $ getClosureData a case tipe clos of -- Thunks we may want to force - Thunk _ | force -> seq a $ go tv ty a + t | isThunk t && force -> seq a $ go tv ty a -- We always follow indirections Indirection _ -> go tv ty $! (ptrs clos ! 0) -- The interesting case @@ -526,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] @@ -535,7 +538,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do subTerms = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes) return (Term tv dc a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. - otherwise -> do + otherwise -> return (Suspension (tipe clos) (Just tv) a Nothing) -- Access the array of pointers and recurse down. Needs to be done with @@ -555,11 +558,12 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do -- correct order. reOrderTerms _ _ [] = [] reOrderTerms pointed unpointed (ty:tys) - | isPointed ty = head pointed : reOrderTerms (tailSafe "reorderTerms1" pointed) unpointed tys - | otherwise = head unpointed : reOrderTerms pointed (tailSafe "reorderTerms2" unpointed) tys - -tailSafe msg [] = error msg -tailSafe _ (x:xs) = xs + | isPointed ty = ASSERT2(not(null pointed) + , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) + head pointed : reOrderTerms (tail pointed) unpointed tys + | otherwise = ASSERT2(not(null unpointed) + , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) + head unpointed : reOrderTerms pointed (tail unpointed) tys isMonomorphic = isEmptyVarSet . tyVarsOfType