Commit cd4d522e authored by bbr's avatar bbr
Browse files

better treatment of suspensions (sigh)

- the type of susp constructor for io val has changed
parent 322a79b4
......@@ -23,7 +23,7 @@ data IOVal t0 = IOVal t0
| IOValFail C_Exceptions
| IOValFreeVar (FreeVarRef (IOVal t0))
| IOValOr OrRef (Branches (IO (IOVal t0)))
| IOValSusp SuspRef (SuspCont (IO (IOVal t0)))
| IOValSusp SuspRef (IO (Maybe (IOVal t0)))
data C_Bool = C_False
| C_True
......
......@@ -46,11 +46,11 @@ curryDo _ (IOValFail es) = printExceptions es
curryDo st (IOValOr ref bs) = case fromStore st ref of
Nothing -> searchIOVal [] (zipWith (mkChoice st ref) [0..] bs)
Just i -> (bs !! i) Prelude.>>= curryDo st
curryDo st (IOValSusp _ contRef) = do
cont <- readIORef contRef
case cont () of
curryDo st (IOValSusp _ cont) = do
mVal <- cont
case mVal of
Nothing -> error "top io action is suspension"
Just v -> v Prelude.>>= curryDo st
Just v -> curryDo st v
mkChoice :: Store -> OrRef -> Int -> a -> (Store,a)
mkChoice st ref i x = (addToStore st ref i,x)
......@@ -82,11 +82,11 @@ searchIOVal es ((st,act) : stacts) = do
IOValFail _ -> searchIOVal es stacts
-- switch arguments of (++) for breadth first (bad.)
IOValOr ref bs -> searchIOVal es (zipWith (mkChoice st ref) [0..] bs ++ stacts)
IOValSusp _ contRef -> do
cont <- readIORef contRef
case cont () of
IOValSusp _ cont -> do
mVal <- cont
case mVal of
Nothing -> searchIOVal es stacts
Just v -> searchIOVal es ((st,v) : stacts)
Just v -> searchIOVal es ((st,Prelude.return v) : stacts)
firstVal :: (Store -> a -> b) -> Store -> OrRef -> Branches a -> b
firstVal cont store ref bs = case fromStore store ref of
......@@ -227,16 +227,24 @@ success :: C_Success
success = C_Success
(&) :: C_Success -> C_Success -> Result C_Success
(&) x y st = boolToSuccess (concAnd (successToBool x) (successToBool y) st)
boolToSuccess C_True = C_Success
boolToSuccess C_False = C_SuccessFail (ErrorCall "&")
boolToSuccess (C_BoolFail e) = C_SuccessFail e
boolToSuccess (C_BoolOr r xs) = C_SuccessOr r (map boolToSuccess xs)
successToBool C_Success = C_True
successToBool (C_SuccessFail e) = C_BoolFail e
successToBool (C_SuccessOr r xs) = C_BoolOr r (map successToBool xs)
(&) x y st = boolToSuccess
(concAnd (successToBool x st)
(successToBool y st) st) st
boolToSuccess C_True _ = C_Success
boolToSuccess C_False _ = C_SuccessFail (ErrorCall "&")
boolToSuccess (C_BoolFail e) _ = C_SuccessFail e
boolToSuccess (C_BoolOr r xs) st = mapOr boolToSuccess r xs st
boolToSuccess (C_BoolSusp ref susp) st =
treatSusp boolToSuccess ref susp st
boolToSuccess x@(C_BoolFreeVar _) st = narrowCTC x boolToSuccess st
successToBool C_Success _ = C_True
successToBool (C_SuccessFail e) _ = C_BoolFail e
successToBool (C_SuccessOr r xs) st = mapOr successToBool r xs st
successToBool (C_SuccessSusp ref susp) st =
treatSusp successToBool ref susp st
successToBool x@(C_SuccessFreeVar _) st = narrowCTC x successToBool st
andBreadth :: List C_Bool -> Result C_Bool
andBreadth xs st = startBreadth (toHaskellList xs) st
......@@ -276,11 +284,20 @@ prim_do f x state = case x of
--Left i -> IOValSusp True (findBindIO cont i)
Right v -> prim_do f v state --hnfCTC exec2 state (apply f v)
--IOValSusp _ susp -> case state of
-- Nothing -> fetchState (\st -> prim_do f st x)
-- --Just store -> wakeUpIO f susp state
IOValSusp vr suspTest -> do
mVal <- suspTest
case mVal of
Nothing -> Prelude.return (IOValSusp vr (newSuspCont suspTest))
Just v -> prim_do f v state
where
cont x st = prim_do f x (Just st)
newSuspCont suspTest = do
mVal <- suspTest
case mVal of
Nothing -> Prelude.return Nothing
Just v -> do
result <- prim_do f v state
Prelude.return (Just result)
exec2 :: C_IO b -> Result (IO (IOVal b))
exec2 (C_IO f) = f
......
......@@ -281,7 +281,9 @@ instance (BaseCurry t0) => BaseCurry (IOVal t0) where
branching r bs = IOValOr r (map return bs)
suspend ref cont = error "IOValSusp" --IOValSusp ref (\state -> maybeFetchStore (return . cont) state)
suspend ref sr = IOValSusp ref $ do
cont <- readIORef sr
return (cont ())
consKind (IOValFreeVar _) = Free
consKind (IOValOr _ _) = Branching
......@@ -299,34 +301,36 @@ instance (BaseCurry t0) => BaseCurry (IOVal t0) where
suspRef (IOValSusp x _) = x
suspCont (IOValSusp _ cont) = error "IOValSusp2" -- \store -> unsafePerformIO (cont (Just store))
suspCont (IOValSusp _ _) = error "IOValSusp.suspCont"
instance BaseCurry (IO (IOVal t0)) where
instance (BaseCurry t0) => BaseCurry (IO (IOVal t0)) where
nf f x state = f(x) (state)
gnf f x state = f(x)(state)
failed x = return (IOValFail x)
free = error "IO.free"
pattern = error "IO.pattern"
freeVar = error "IO.freeVar"
freeVarRef = error "IO.freeVarRef"
free u = return (free u)
pattern u = return (pattern u)
freeVar r = error "IO (IOVal _) freeVar"
freeVarRef v = error "IO (IOVal _) freeVarRef"
branching r bs = return (IOValOr r bs)
suspend r cont = error "IO IOValSusp" --return (IOValSusp r (maybeFetchStore cont))
suspend r sr = return $ IOValSusp r $ do
cont <- readIORef sr
maybe (return Nothing) (\ act -> act >>= return . Just) (cont ())
consKind _ = error "IO (IOVal _).consKind"
consKind x = consKind (unsafePerformIO x)
exceptions _ = error "IO (IOVal _).exceptions"
exceptions x = exceptions (unsafePerformIO x)
orRef _ = error "IO (IOVal _).orRef"
orRef x = orRef (unsafePerformIO x)
branches _ = error "IO (IOVal _).branches"
branches x = unsafePerformIO (x >>= \ (IOValOr _ bs) -> return bs)
suspRef _ = error "IO (IOVal _).suspRef"
suspRef x = suspRef (unsafePerformIO x)
suspCont _ = error "IO (IOVal _).suspCont"
suspCont x = error "IO (IOVal _) suspCont"
instance (BaseCurry t0) => BaseCurry (C_IO t0) where
......@@ -753,8 +757,8 @@ instance Curry C_Four where
typeName _ = "Four"
instance Curry (IO (IOVal a)) where
strEq _ _ = error "IO.strEq"
instance BaseCurry a => Curry (IO (IOVal a)) where
strEq x y = error "IO.strEq"
eq _ _ = error "IO.eq"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment