Hi,
During debugging my experimental code I found a following problem:
when my module is loaded following occurs:
"
StrictMemo> test
rootVal = memo: [(Ext:*:1:*:Ext:*:2,memo: [(Ext:*:1,doExt( 1 )
1),(Ext:*:1:*:Ext:*:2,
Program error: {_Gc Black Hole}
"
My first idea was problem is a result of interaction of unsafePerformIO
and collector, but this momemt I have no time to investigate it.
I am using Hugs-Jun98 at (Linux) RedHat 4.2
Old version of HUGS leads to same result.
GHC-produced program computes 'test' normally, without crash:
"
memo: [(Ext:*:1:*:Ext:*:2, memo: [(Ext:*:1, doExt( 1 )
1), (Ext:*:1:*:Ext:*:2, memo: [(Ext:*:2, doExt( 2 )
2), (Ext:*:1, 1), (Ext:*:1:*:Ext:*:2, 2)]
2)]
2)]
2
"
Best wishes,
Vladimir (e-mail: [EMAIL PROTECTED])
<<<<<<<<<<<<<<<<<<<<<<<<<<
module StrictMemo where
import IOExts
import Maybe
infixl 5 *:
data Promise = Ext | Pap Promise Promise | Patom A deriving Eq
instance Show Promise where
showsPrec _ (Ext) = showString "Ext"
showsPrec _ (Patom a) = shows a
showsPrec _ (Pap a b) = shows a . showString ":*:" . shows b
(*:) :: A -> A -> Promise
root :: Promise
readPromises :: IO [Promise]
--------------------- forceRec/get "kernel" --------------------------------
forceRec :: Promise -> A
forceRec Ext = error "function Ext needs argument"
forceRec (Patom a) = a
forceRec a@(Pap x y) = case mLookup a of
Just z -> z
Nothing -> mInsert (a,get a (ap x y))
where
ap Ext x = unsafePerformIO (doExt (get a x))
ap x y = get a x *: get a y
get :: Promise -> Promise -> A
get a a' = unsafePerformIO get'
where
get' = do depInsert (a,a')
return (forceRec a')
--------------------- Root-related code -----------------------------------
ext :: A -> Promise
ext a = Pap Ext (Patom a)
rootVal :: A
rootVal = get root root
--------------------- MemoTable definition/collector ----------------------
type MemoTab = [(Promise, A)]
memo = unsafePerformIO (newIORef [])
type DepTab = [(Promise,Promise)]
deps = unsafePerformIO (newIORef [])
revRel :: [(a,b)] -> [(b,a)]
revRel rel = map (\(x,y) -> (y,x)) rel
mLookup :: Promise -> Maybe A
mLookup a = unsafePerformIO (readIORef memo >>= \m ->
return (listToMaybe [y|(x,y)<-m,x==a]))
mCollect :: IO ()
mCollect = readIORef memo >>= \m ->
readIORef deps >>= \d ->
let valids = close d [root] in
mRemove (filter (\p -> not (p `elem` valids)) (map fst m))
depInsert e = readIORef deps >>= \d ->
writeIORef deps (e:d)
mInsert :: (Promise,A) -> A
mInsert e@(a,v) = unsafePerformIO (readIORef memo >>= \m ->
mRemove (filter(conflict a)(map fst m)) >>
readIORef memo >>= \m' ->
writeIORef memo (e:m') >>
putStr ("memo: " ++show (e:m')++ "\n") >>
return v)
mRemove :: [Promise] -> IO ()
mRemove l = readIORef memo >>= \m ->
readIORef deps >>= \d ->
let invalids = close (revRel d) l in
accumulate (map doRem invalids) >>
let remCriteria = filter (\e -> not (fst e `elem` invalids)) in
writeIORef memo (remCriteria m) >>
writeIORef deps (remCriteria d)
--------------------- External section ------------------------------------
conflict :: Promise -> Promise -> Bool
conflict _ _ = False
doExt a = do putStr ("doExt( " ++ show a ++ " )\n")
return (Patom a)
doRem a = do putStr ("doRem( " ++ show a ++ " )\n")
--------------------- Testing section ------------------------------------
type A = Int
root = Pap (ext 1) (ext 2)
readPromises = do return [Patom 2]
a *: b = Patom (a * b)
test :: IO ()
test = do p <- readPromises
-- mRemove p
putStr ("rootVal = " ++ show rootVal ++ "\n")
-- mCollect
test
--------------------- From GHC Util ---------------------------------------
-- This algorithm for transitive closure is straightforward, albeit quadratic.
transitiveClosure :: (a -> [a]) -- Successor function
-> (a -> a -> Bool) -- Equality predicate
-> [a]
-> [a] -- The transitive closure
transitiveClosure succ eq xs
= go [] xs
where
go done [] = done
go done (x:xs) | x `is_in` done = go done xs
| otherwise = go (x:done) (succ x ++ xs)
x `is_in` [] = False
x `is_in` (y:ys) | eq x y = True
| otherwise = x `is_in` ys
close rel = transitiveClosure (\x->[y'|(x',y')<-rel,x==x']) (==)
>>>>>>>>>>>>>>>>>>>>>>>>>>
