Commit ca67a103 authored by bbr's avatar bbr
Browse files

base files with state as last element

we need to put the state as last element. Otherwise the global module can never work. This is done now for the most basic files.
parent 0c4f92f1
......@@ -33,8 +33,8 @@ data Exception
type C_Exceptions = Exception
type Fun a b = State -> a -> b
type Const a = State -> a
type Result a = State -> a
type Result' a = Store -> a
----------------------------------------------------------------
-- the BaseCurry class
......@@ -42,8 +42,8 @@ type Const a = State -> a
class BaseCurry a where
-- computations of normal forms
nf :: BaseCurry b => (State -> a -> b) -> State -> a -> b
gnf :: BaseCurry b => (State -> a -> b) -> State -> a -> b
nf :: BaseCurry b => (a -> Result b) -> a -> Result b
gnf :: BaseCurry b => (a -> Result b) -> a -> Result b
-- constructors
free :: () -> a
......@@ -92,26 +92,26 @@ bind v val res = unsafePerformIO $ do
-- This function controls all kinds of evaluations to (head) normal forms
-- IMPORTANT: if you change anything here, also update ExternalPrelude.prim_do
ctcStore :: (BaseCurry a,BaseCurry b) => HNFMode -> (State -> a -> b) -> State -> a -> b
ctcStore mode cont state x =
ctcStore :: (BaseCurry a,BaseCurry b) => HNFMode -> (a -> Result b) -> a -> Result b
ctcStore mode cont x state =
case consKind x of
-- cases solvable without store
Val -> cont state x
Val -> cont x state
Failed -> addException (curryError ("Prelude."++if mode then "$#" else "$!")) x
Branching -> let ref = orRef x
bs = branches x
in case state of
Nothing -> mapOr state (ctcStore mode cont) ref bs
Nothing -> mapOr (ctcStore mode cont) ref bs state
Just store -> case fromStore store ref of
Nothing -> branching ref
(zipWith (ctcBranch contCTC store ref) [0..] bs)
Just i -> ctcStore mode cont state (bs!!i)
(zipWith (ctcBranch contCTC ref store) [0..] bs)
Just i -> ctcStore mode cont (bs!!i) state
Free -> let ref = freeVarRef x in
case binding x of
Left x' -> if mode then suspCTC Nothing (freeVarRef x') susp
else cont state x'
Right v -> ctcStore mode cont state v
Left x' -> if mode then suspCTC (freeVarRef x') susp Nothing
else cont x' state
Right v -> ctcStore mode cont v state
Suspended -> treatSusp state (ctcStore mode cont) (suspRef x) (suspCont x)
{--- now we need to have the store
......@@ -121,7 +121,7 @@ ctcStore mode cont state x =
Suspended -> wakeUp contCTC (suspCont x) store-}
where
contCTC st = ctcStore mode cont (Just st)
contCTC x st = ctcStore mode cont x (Just st)
susp = ctcStore mode cont
{-
......@@ -143,8 +143,8 @@ findBind :: (BaseCurry a,BaseCurry b) => (Store -> a -> b) -> a -> SuspCont b
findBind cont ref store =
either (suspend False . findBind cont) (cont store) (binding ref)
-}
suspCTC :: (BaseCurry a,BaseCurry b) => State -> FreeVarRef a -> (State -> a -> b) -> b
suspCTC st ref cont = unsafePerformIO $ do
suspCTC :: (BaseCurry a,BaseCurry b) => FreeVarRef a -> (a -> Result b) -> Result b
suspCTC ref cont st = unsafePerformIO $ do
sr <- newIORef undefined
writeIORef sr (susp sr)
return (suspend True sr)
......@@ -154,17 +154,17 @@ suspCTC st ref cont = unsafePerformIO $ do
case b of
Left _ -> return Nothing
Right v -> do
let result = Just (cont st v)
let result = Just (cont v st)
writeIORef sr (const result)
return result
-- TODO: use state! also above!
-- maybe look at test susp: new state?
treatSusp :: (BaseCurry a,BaseCurry b) => State -> (State->a->b) -> SuspRef -> SuspCont a -> b
treatSusp :: (BaseCurry a,BaseCurry b) => State -> (a->Result b) -> SuspRef -> SuspCont a -> b
treatSusp st cont ref susp = unsafePerformIO $ do
waker <- readIORef susp
case waker () of
Just v -> return (cont st v)
Just v -> return (cont v st)
Nothing -> do
sr <- newIORef undefined
writeIORef sr (testSusp sr)
......@@ -176,7 +176,7 @@ treatSusp st cont ref susp = unsafePerformIO $ do
case waker () of
Nothing -> return Nothing
Just v -> do
let result = Just (cont st v)
let result = Just (cont v st)
writeIORef sr (const result)
return result
......@@ -190,19 +190,19 @@ fetchState cont = suspend True (cont . Just)
-- pulling continuations into each branch of an or
ctcBranch :: (BaseCurry a, BaseCurry b) =>
(Store -> b -> a) -> Store -> OrRef -> Int -> b -> a
ctcBranch cont store orRef nr x =
(b -> Result' a) -> OrRef -> Store -> Int -> b -> a
ctcBranch cont orRef store nr x =
let newStore = addToStore store orRef nr in
cont newStore x
cont x newStore
-- pull continuations into branches without modifying a store
-- TODO: add right number to state!
mapOr :: (BaseCurry a,BaseCurry b) => State -> (State -> a -> b) -> OrRef -> Branches a -> b
mapOr Nothing f ref bs = mapOr (Just emptyStore) f ref bs
mapOr st@(Just store) f ref bs = case fromStore store ref of
mapOr :: (BaseCurry a,BaseCurry b) => (a -> Result b) -> OrRef -> Branches a -> Result b
mapOr f ref bs Nothing = mapOr f ref bs (Just emptyStore)
mapOr f ref bs st@(Just store) = case fromStore store ref of
Nothing -> branching ref
(zipWith (ctcBranch (f . Just) store ref) [0..] bs)
Just i -> f st (bs!!i)
(zipWith (ctcBranch (\ x st -> f x (Just st)) ref store) [0..] bs)
Just i -> f (bs!!i) st
addException :: (BaseCurry a,BaseCurry b) => Exception -> a -> b
addException _ x = failed (exceptions x)
......
......@@ -13,29 +13,29 @@ import Data.IORef
-- and may be called from compiled programs.
-------------------------------------------------
nfCTC :: (BaseCurry a,BaseCurry b) => (State -> b -> a) -> State -> b -> a
nfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
nfCTC cont = ctcStore False (nf cont)
hnfCTC :: (BaseCurry a,BaseCurry b) => (State -> b -> a) -> State -> b -> a
hnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
hnfCTC = ctcStore False
gnfCTC :: (BaseCurry a,BaseCurry b) => (State -> b -> a) -> State -> b -> a
gnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
gnfCTC cont = ctcStore True (gnf cont)
ghnfCTC :: (BaseCurry a,BaseCurry b) => (State -> b -> a) -> State -> b -> a
ghnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
ghnfCTC = ctcStore True
nf0 :: (BaseCurry a, BaseCurry b) => (a -> b) -> a -> b
nf0 cont = trace "nf0" $ nfCTC (const cont) Nothing
nf0 cont x = nfCTC (\ x st -> cont x) x Nothing
hnf0 :: (BaseCurry a, BaseCurry b) => (a->b) -> a -> b
hnf0 cont = hnfCTC (const cont) Nothing
hnf0 cont x = hnfCTC (\ x st -> cont x) x Nothing
gnf0 :: (BaseCurry a, BaseCurry b) => (a -> b) -> a -> b
gnf0 cont = trace "gnf0" $ gnfCTC (const cont) Nothing
gnf0 cont x = gnfCTC (\ x st -> cont x) x Nothing
ghnf0 :: (BaseCurry a, BaseCurry b) => (a->b) -> a -> b
ghnf0 cont = ctcStore True (const cont) Nothing
ghnf0 cont x = ctcStore True (\ x st -> cont x) x Nothing
-----------------------------------------------------------------
-- treatment for the basic cases of flexible pattern matching
......
Supports Markdown
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