ClosureType(..),
getClosureData, -- :: a -> IO Closure
- Closure ( tipe, infoTable, ptrs, nonPtrs ),
- getClosureType, -- :: a -> IO ClosureType
+ Closure ( tipe, infoPtr, ptrs, nonPtrs ),
isConstr, -- :: ClosureType -> Bool
isIndirection, -- :: ClosureType -> Bool
- getInfoTablePtr, -- :: a -> Ptr StgInfoTable
Term(..),
printTerm,
import Data.List ( partition )
import Foreign.Storable
+import IO
+
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
deriving (Show, Eq)
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?
instance Outputable ClosureType where
ppr = text . show
-getInfoTablePtr :: a -> Ptr StgInfoTable
-getInfoTablePtr x =
- case infoPtr# x of
- itbl_ptr -> castPtr ( Ptr itbl_ptr )
-
-getClosureType :: a -> IO ClosureType
-getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
-
#include "../includes/ClosureTypes.h"
aP_CODE = AP
#undef PAP
getClosureData :: a -> IO Closure
-getClosureData a = do
- itbl <- peek (getInfoTablePtr a)
- let tipe = readCType (BCI.tipe itbl)
- case closurePayload# a of
- (# ptrs, nptrs #) ->
- let elems = BCI.ptrs itbl
+getClosureData a =
+ case unpackClosure# a of
+ (# iptr, ptrs, nptrs #) -> do
+ itbl <- peek (Ptr iptr)
+ let tipe = readCType (BCI.tipe itbl)
+ elems = BCI.ptrs itbl
ptrsList = Array 0 (fromIntegral$ elems) ptrs
- in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
+ ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
readCType :: Integral a => a -> ClosureType
readCType i
printTerm1 _ t = printTerm t
-customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
-customPrintTerm custom = let
+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
go prec t@Term{subTerms=tt, dc=dc} = do
- mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
- case msum mb_customDocs of -- msum is in Maybe monad
+ let mb_customDocs = map ($t) (custom go) :: [m (Maybe SDoc)]
+ first_success <- firstJustM mb_customDocs
+ case first_success of
Just doc -> return$ parensCond (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
- in go 0
- where fixity = undefined
+ 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 =
trd (x,y,z) = z
cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a =
- -- Obtain the term and tidy the type before returning it
- cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
+cvObtainTerm hsc_env force mb_ty a = do
+ -- Obtain the term and tidy the type before returning it
+ term <- cvObtainTerm1 hsc_env force mb_ty a
+ return $ tidyTypes term
where
tidyTypes = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
Suspension ct (fmap tidy mb_ty) hval n
}
tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
- tidyVarEnv ty =
-
- mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
- | (tv,v) <- zip alphaTyVars vars]
+ tidyVarEnv ty = mkVarEnv$
+ [ (v, setTyVarName v (tyVarName tv))
+ | (tv,v) <- zip alphaTyVars vars]
where vars = varSetElems$ tyVarsOfType ty
cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
- tv <- liftM mkTyVarTy (newVar argTypeKind)
- when (isJust mb_ty) $
- instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
- go tv hval
+ 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
where
- go tv a = do
- ctype <- trIO$ getClosureType a
- case ctype of
+ go 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
+ clos <- trIO $ getClosureData a
+ case tipe clos of
-- Thunks we may want to force
- Thunk _ | force -> seq a $ go tv a
+ Thunk _ | force -> seq a $ go tv ty a
-- We always follow indirections
- _ | isIndirection ctype -> do
- clos <- trIO$ getClosureData a
- (go tv $! (ptrs clos ! 0))
+ Indirection _ -> go tv ty $! (ptrs clos ! 0)
-- The interesting case
Constr -> do
- m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
+ m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
case m_dc of
Nothing -> panic "Can't find the DataCon for a term"
Just dc -> do
- clos <- trIO$ getClosureData a
let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
- subTtypes = drop extra_args (dataConRepArgTys dc)
+ subTtypes = matchSubTypes dc ty
(subTtypesP, subTtypesNP) = partition isPointed subTtypes
- n_subtermsP= length subTtypesP
- subTermTvs <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
- baseType <- instScheme (dataConRepType dc)
- let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
- addConstraint myType baseType
- subTermsP <- sequence [ extractSubterm i tv (ptrs clos)
- | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
- subTermTvs ]
+ subTermTvs <- sequence
+ [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
+ | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
+ -- It is vital for newtype reconstruction that the unification step is done
+ -- 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
+ subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
+ [ appArr (go tv t) (ptrs clos) i
+ | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
- subTerms = reOrderTerms subTermsP subTermsNP subTtypes
+ 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
- return (Suspension ctype (Just tv) a Nothing)
+ return (Suspension (tipe clos) (Just tv) a Nothing)
-- Access the array of pointers and recurse down. Needs to be done with
-- care of no introducing a thunk! or go will fail to do its job
- extractSubterm (I# i#) tv ptrs = case ptrs of
+ appArr f arr (I# i#) = case arr of
(Array _ _ ptrs#) -> case indexArray# ptrs# i# of
- (# e #) -> go tv e
+ (# e #) -> f e
+
+ matchSubTypes dc ty
+ | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
+ , null (dataConExTyVars dc) --TODO Handle the case of extra existential tyvars
+ = dataConInstArgTys dc ty_args
+
+ | otherwise = dataConRepArgTys dc
-- This is used to put together pointed and nonpointed subterms in the
-- correct order.
reOrderTerms _ _ [] = []
reOrderTerms pointed unpointed (ty:tys)
- | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
- | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
+ | 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
zonkTerm :: Term -> TcM Term
zonkTerm = foldTerm idTermFoldM {
projects / ghc-hetmet.git / blobdiff