--
-----------------------------------------------------------------------------
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module RtClosureInspect(
- cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
+ cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
Term(..),
+ isTerm,
+ isSuspension,
+ isPrim,
pprTerm,
cPprTerm,
cPprTermBase,
-- unsafeDeepSeq,
cvReconstructType,
computeRTTIsubst,
- sigmaType
+ sigmaType,
+ Closure(..),
+ getClosureData,
+ ClosureType(..),
+ isConstr,
+ isIndirection
) where
#include "HsVersions.h"
import DataCon
import Type
-import TcRnMonad ( TcM, initTc, initTcPrintErrors, ioToTcRn,
+import TcRnMonad ( TcM, initTc, ioToTcRn,
tryTcErrs)
import TcType
import TcMType
import Data.Array.Base
import Data.List ( partition )
import qualified Data.Sequence as Seq
+import Data.Monoid
+import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
import Foreign
import System.IO.Unsafe
>> return () -- TOMDO: what about the coercion?
-- we should consider family instances
-
-
-- Type & Term reconstruction
-cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
+cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
+cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
tv <- newVar argTypeKind
case mb_ty of
- Nothing -> go tv tv hval >>= zonkTerm
- Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
+ Nothing -> go bound tv tv hval >>= zonkTerm
+ Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
Just ty -> do
(ty',rev_subst) <- instScheme (sigmaType ty)
addConstraint tv ty'
- term <- go tv tv hval >>= zonkTerm
+ term <- go bound tv tv hval >>= zonkTerm
--restore original Tyvars
return$ mapTermType (substTy rev_subst) term
where
- go tv ty a = 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)
+ go bound tv ty a = do
let monomorphic = not(isTyVarTy tv)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
-- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
-- force blackholes, because it would almost certainly result in deadlock,
-- and showing the '_' is more useful.
- t | isThunk t && force -> seq a $ go tv ty a
+ t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
- Indirection _ -> go tv ty $! (ptrs clos ! 0)
+ Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
(newVar (liftedTypeKind))
- subTerms <- sequence [appArr (go tv tv) (ptrs clos) i
+ subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
addConstraint myType signatureType
subTermsP <- sequence $ drop extra_args
-- ^^^ all extra arguments are pointed
- [ appArr (go tv t) (ptrs clos) i
+ [ appArr (go (pred bound) tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
- otherwise ->
- return (Suspension (tipe clos) (Just tv) a Nothing)
+ tipe_clos ->
+ return (Suspension tipe_clos (Just tv) a Nothing)
+-- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
-- assumption: ^^^ looks through newtypes
tv <- newVar argTypeKind
case mb_ty of
Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
- (uncurry go)
- [(tv, hval)]
+ (uncurry go)
+ (Seq.singleton (tv, hval))
max_depth
zonkTcType tv -- TODO untested!
Just ty | isMonomorphic ty -> return ty
- Just ty -> do
- (ty',rev_subst) <- instScheme (sigmaType ty)
+ Just ty -> do
+ (ty',rev_subst) <- instScheme (sigmaType ty)
addConstraint tv ty'
- search (isMonomorphic `fmap` zonkTcType tv)
- (\(ty,a) -> go ty a)
- [(tv, hval)]
+ search (isMonomorphic `fmap` zonkTcType tv)
+ (\(ty,a) -> go ty a)
+ (Seq.singleton (tv, hval))
max_depth
substTy rev_subst `fmap` zonkTcType tv
where
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
- search stop expand [] depth = return ()
+ search stop expand l depth | Seq.null l = return ()
search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
show max_depth ++ " steps"
- search stop expand (x:xx) d = unlessM stop $ do
- new <- expand x
- search stop expand (xx ++ new) $! (pred d)
+ search stop expand l d | x :< xx <- viewl l = unlessM stop $ do
+ new <- expand x
+ search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
-- returns unification tasks,since we are going to want a breadth-first search
go :: Type -> HValue -> TR [(Type, HValue)]
- go tv a = do
+ go tv a = do
clos <- trIO $ getClosureData a
case tipe clos of
Indirection _ -> go tv $! (ptrs clos ! 0)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
- Nothing-> do
+ Nothing-> do
-- TODO: Check this case
- vars <- replicateM (length$ elems$ ptrs clos)
+ vars <- replicateM (length$ elems$ ptrs clos)
(newVar (liftedTypeKind))
- subTerms <- sequence [ appArr (go tv) (ptrs clos) i
+ subTerms <- sequence [ appArr (go tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
forM [0..length (elems $ ptrs clos)] $ \i -> do
- tv <- newVar liftedTypeKind
+ tv <- newVar liftedTypeKind
return$ appArr (\e->(tv,e)) (ptrs clos) i
- Just dc -> do
- let extra_args = length(dataConRepArgTys dc) -
+ Just dc -> do
+ let extra_args = length(dataConRepArgTys dc) -
length(dataConOrigArgTys dc)
subTtypes <- mapMif (not . isMonomorphic)
(\t -> newVar (typeKind t))
(dataConRepArgTys dc)
+
-- It is vital for newtype reconstruction that the unification step
-- is done right here, _before_ the subterms are RTTI reconstructed
let myType = mkFunTys subTtypes tv
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i
- | (i,t) <- drop extra_args $ zip [0..] subTtypes]
+ | (i,t) <- drop extra_args $
+ zip [0..] (filter isPointed subTtypes)]
otherwise -> return []
-- This helper computes the difference between a base type t and the
projects / ghc-hetmet.git / blobdiff