Prelude Data.IORef> :p l
l = (_t4::Maybe Integer) : (_t5::[Maybe Integer])
Prelude Data.IORef> p <- newIORef l
Prelude Data.IORef> :p p
p = GHC.IOBase.IORef (GHC.STRef.STRef {((_t6::Maybe Integer) :
(_t7::[Maybe Integer]))})
Prelude Data.IORef> :sp p
p = GHC.IOBase.IORef (GHC.STRef.STRef {(_ : _)})
I used braces to denote the contents of a reference.
Perhaps there is a more appropriate notation?
\ty dc t -> do
(term, names) <- t
return (NewtypeWrap ty dc term, names)
\ty dc t -> do
(term, names) <- t
return (NewtypeWrap ty dc term, names)
+ , fRefWrap = \ty t -> do
+ (term, names) <- t
+ return (RefWrap ty term, names)
}
doSuspension freeNames ct mb_ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
}
doSuspension freeNames ct mb_ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
GHC.setSessionDynFlags cms dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
GHC.setSessionDynFlags cms dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
- cPprShowable _ _ = panic "cPprShowable - unreachable"
+ cPprShowable prec RefWrap{wrapped_term=t} = cPprShowable prec t
+ cPprShowable _ _ = return Nothing
needsParens ('"':_) = False -- some simple heuristics to see whether parens
-- are redundant in an arbitrary Show output
needsParens ('"':_) = False -- some simple heuristics to see whether parens
-- are redundant in an arbitrary Show output
isTerm,
isSuspension,
isPrim,
isTerm,
isSuspension,
isPrim,
pprTerm,
cPprTerm,
cPprTermBase,
pprTerm,
cPprTerm,
cPprTermBase,
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.Arr ( Array(..) )
import GHC.Exts
import Control.Monad
import Data.Maybe
import Control.Monad
import Data.Maybe
| NewtypeWrap{ ty :: Type
, dc :: Either String DataCon
, wrapped_term :: Term }
| NewtypeWrap{ ty :: Type
, dc :: Either String DataCon
, wrapped_term :: Term }
+ | RefWrap { ty :: Type
+ , wrapped_term :: Term }
isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
isTerm Term{} = True
isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
isTerm Term{} = True
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {} = True
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {} = True
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm _ = False
instance Outputable (Term) where
isFullyEvaluatedTerm _ = False
instance Outputable (Term) where
| AP
| PAP
| Indirection Int
| AP
| PAP
| Indirection Int
+ | MutVar Int
+ | Other Int
deriving (Show, Eq)
data Closure = Closure { tipe :: ClosureType
deriving (Show, Eq)
data Closure = Closure { tipe :: ClosureType
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
| i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
| i >= FUN && i <= FUN_STATIC = Fun
| i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
| i >= FUN && i <= FUN_STATIC = Fun
- | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
+ | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
| i == THUNK_SELECTOR = ThunkSelector
| i == BLACKHOLE = Blackhole
| i == THUNK_SELECTOR = ThunkSelector
| i == BLACKHOLE = Blackhole
- | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
- | fromIntegral i == aP_CODE = AP
+ | i >= IND && i <= IND_STATIC = Indirection i'
+ | i' == aP_CODE = AP
- | fromIntegral i == pAP_CODE = PAP
- | otherwise = Other (fromIntegral i)
-
+ | i' == pAP_CODE = PAP
+ | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
+ | otherwise = Other i'
+ where i' = fromIntegral i
+
isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
-----------------------------------
type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
-----------------------------------
type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
-data TermFold a = TermFold { fTerm :: TermProcessor a a
- , fPrim :: Type -> [Word] -> a
- , fSuspension :: ClosureType -> Maybe Type -> HValue
+data TermFold a = TermFold { fTerm :: TermProcessor a a
+ , fPrim :: Type -> [Word] -> a
+ , fSuspension :: ClosureType -> Maybe Type -> HValue
-> Maybe Name -> a
, fNewtypeWrap :: Type -> Either String DataCon
-> a -> a
-> Maybe Name -> a
, fNewtypeWrap :: Type -> Either String DataCon
-> a -> a
+ , fRefWrap :: Type -> a -> a
}
foldTerm :: TermFold a -> Term -> a
}
foldTerm :: TermFold a -> Term -> a
foldTerm tf (Prim ty v ) = fPrim tf ty v
foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
foldTerm tf (Prim ty v ) = fPrim tf ty v
foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
+foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
idTermFold :: TermFold Term
idTermFold = TermFold {
fTerm = Term,
fPrim = Prim,
fSuspension = Suspension,
idTermFold :: TermFold Term
idTermFold = TermFold {
fTerm = Term,
fPrim = Prim,
fSuspension = Suspension,
- fNewtypeWrap = NewtypeWrap
+ fNewtypeWrap = NewtypeWrap,
+ fRefWrap = RefWrap
}
idTermFoldM :: Monad m => TermFold (m Term)
idTermFoldM = TermFold {
fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
fPrim = (return.). Prim,
fSuspension = (((return.).).). Suspension,
}
idTermFoldM :: Monad m => TermFold (m Term)
idTermFoldM = TermFold {
fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
fPrim = (return.). Prim,
fSuspension = (((return.).).). Suspension,
- fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t
+ fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
+ fRefWrap = \ty t -> RefWrap ty `liftM` t
}
mapTermType :: (Type -> Type) -> Term -> Term
}
mapTermType :: (Type -> Type) -> Term -> Term
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,
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,
- fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t}
+ fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
+ fRefWrap = \ty t -> RefWrap (f ty) t}
termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
fSuspension = \_ mb_ty _ _ ->
maybe emptyVarEnv tyVarsOfType mb_ty,
fPrim = \ _ _ -> emptyVarEnv,
fSuspension = \_ mb_ty _ _ ->
maybe emptyVarEnv tyVarsOfType mb_ty,
fPrim = \ _ _ -> emptyVarEnv,
- fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t}
+ fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
+ fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
where concatVarEnv = foldr plusVarEnv emptyVarEnv
----------------------------------
where concatVarEnv = foldr plusVarEnv emptyVarEnv
----------------------------------
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
-pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
-pprTermM1 t = pprDeeper `liftM` ppr_termM1 t
-
ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p 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} = braces `liftM` y p t
ppr_termM _ _ t = ppr_termM1 t
ppr_termM _ _ t = ppr_termM1 t
+ppr_termM1 :: Monad m => Term -> m SDoc
ppr_termM1 Prim{value=words, ty=ty} =
return$ text$ repPrim (tyConAppTyCon ty) words
ppr_termM1 Prim{value=words, ty=ty} =
return$ text$ repPrim (tyConAppTyCon ty) words
-ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
| Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
| Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
- | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
-ppr_termM1 _ = panic "ppr_termM1"
+ | 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"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- splitNewTyConApp_maybe ty
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- splitNewTyConApp_maybe ty
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ = go 0 where
printers = printers_ go
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ = go 0 where
printers = printers_ go
- go prec t | isTerm t || isNewtypeWrap t = do
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
Just doc <- firstJustM mb_customDocs
return$ cparen (prec>app_prec+1) doc
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
Just doc <- firstJustM mb_customDocs
return$ cparen (prec>app_prec+1) doc
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
+-- We also follow references
+ MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
+ -- , tycon == mutVarPrimTyCon
+ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ addConstraint tv (mkTyConApp tycon [world,tv'])
+ x <- go bound tv' ty_contents contents
+ return (RefWrap ty x)
+
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
return (Suspension tipe_clos (Just tv) a Nothing)
matchSubTypes dc ty
return (Suspension tipe_clos (Just tv) a Nothing)
matchSubTypes dc ty
clos <- trIO $ getClosureData a
case tipe clos of
Indirection _ -> go tv $! (ptrs clos ! 0)
clos <- trIO $ getClosureData a
case tipe clos of
Indirection _ -> go tv $! (ptrs clos ! 0)
+ MutVar _ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ world <- newVar liftedTypeKind
+ addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
+-- x <- go tv' ty_contents contents
+ return [(tv', contents)]
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)