Commit 88bee93a authored by bbr's avatar bbr
Browse files

compiler changed to add state argument

- some small changes in base files
- adding the state argument has been bett abstracted
- compiler adjusted so that auto generated files work
parent ca67a103
......@@ -113,7 +113,7 @@ ctcStore mode cont x state =
else cont x' state
Right v -> ctcStore mode cont v state
Suspended -> treatSusp state (ctcStore mode cont) (suspRef x) (suspCont x)
Suspended -> treatSusp (ctcStore mode cont) (suspRef x) (suspCont x) state
{--- now we need to have the store
conskind -> case state of
Nothing -> fetchState (\st -> ctcStore mode cont st x)
......@@ -160,8 +160,8 @@ suspCTC ref cont st = unsafePerformIO $ do
-- TODO: use state! also above!
-- maybe look at test susp: new state?
treatSusp :: (BaseCurry a,BaseCurry b) => State -> (a->Result b) -> SuspRef -> SuspCont a -> b
treatSusp st cont ref susp = unsafePerformIO $ do
treatSusp :: (BaseCurry a,BaseCurry b) => (a->Result b) -> SuspRef -> SuspCont a -> Result b
treatSusp cont ref susp st = unsafePerformIO $ do
waker <- readIORef susp
case waker () of
Just v -> return (cont v st)
......
......@@ -722,22 +722,22 @@ transBranching caseMode vs@(as,v:bs) opts f tm oName branches
orPat = C.PComb (orName opts typeName) [C.PVar "i",C.PVar "xs"]
suspPat = C.PComb (suspName opts typeName) [C.PVar "ref",C.PVar "susp"]
applyf = C.Lambda [C.PVar "st",C.PVar "x"]
(fapp (sym f) (st:map toVar as ++ C.Var "x" : map toVar bs))
applyf = C.Lambda (addStatePat [C.PVar "x"])
(fapp (sym f) (addStateArg (map toVar as ++ C.Var "x" : map toVar bs)))
newLhs p e = rule (map toPVar as ++ (p:map toPVar bs)) e []
newRules =
[newLhs freePat
(noguard (if caseMode==Flex
then fapp (cusym "narrowCTC")
[st,C.Var "x", applyf]
(addStateArg [C.Var "x", applyf])
else fapp (cusym "suspCTC")
[st,C.Var "ref", applyf]))
(addStateArg [C.Var "ref", applyf])))
,newLhs orPat
(noguard (fapp (cusym "mapOr") [st,applyf,C.Var "i",C.Var "xs"]))
(noguard (fapp (cusym "mapOr") (addStateArg [applyf,C.Var "i",C.Var "xs"])))
,newLhs suspPat
(noguard (fapp (cusym "treatSusp")
[st,applyf,C.Var "ref",C.Var "susp"]))
(addStateArg [applyf,C.Var "ref",C.Var "susp"])))
,newLhs (C.PVar "x")
(noguard (fapp (cusym "patternFail")
[qname_ oName,C.Var "x"]))]
......@@ -939,10 +939,15 @@ stateTypeName :: String
stateTypeName = "State"
addStateType :: C.TypeExpr -> C.TypeExpr
addStateType = C.FuncType (curryTCons stateTypeName [])
addStateType t@(C.TVar _) = C.FuncType (curryTCons stateTypeName []) t
addStateType t@(C.TCons _ _) = C.FuncType (curryTCons stateTypeName []) t
addStateType (C.FuncType t1 t2) = C.FuncType t1 (addStateType t2)
addStatePat :: [C.Pattern] -> [C.Pattern]
addStatePat = (C.PVar "st":)
addStatePat = (++[C.PVar "st"])
addStateArg :: [C.Expr] -> [C.Expr]
addStateArg = (++[C.Var "st"])
----------------------------------------------------------------
-- constants and abbreviations for flat, resp. abstract curry
......
......@@ -42,16 +42,10 @@ ghnf0 cont x = ctcStore True (\ x st -> cont x) x Nothing
-----------------------------------------------------------------
-- called by generated functions for narrowing
narrowCTC :: (BaseCurry a,BaseCurry b) => State -> a -> (State->a->b) -> b
narrowCTC st x f = case binding x of
Left var -> let p = pattern () in bind (freeVarRef var) p (f st p)
Right val -> f st val
{-
-- called by generated functions for suspension
suspCTC :: (BaseCurry a,BaseCurry b) => FreeVarRef a -> (a->b) -> b
suspCTC ref cont = suspend True (findBind (const cont) (freeVar ref))
-}
narrowCTC :: (BaseCurry a,BaseCurry b) => a -> (a -> Result b) -> Result b
narrowCTC x f st = case binding x of
Left var -> let p = pattern () in bind (freeVarRef var) p (f p st)
Right val -> f val st
-- called by generated functions for matching failure
patternFail :: (BaseCurry a,BaseCurry b) => String -> a -> b
......@@ -169,17 +163,3 @@ ten,eleven :: Int
ten = 10
eleven = 11
{-
-------------------------------------------------------------------------
-- getting the store if needs be
-------------------------------------------------------------------------
-- where is this used????
maybeFetchStore :: BaseCurry a => (Store -> a) -> State -> a
maybeFetchStore cont Nothing = fetchState (\ (Just st) -> cont st)
maybeFetchStore cont (Just store) = cont store
maybeFetchState :: BaseCurry a => (State -> a) -> State -> a
maybeFetchState cont = maybe (fetchState cont) (cont . Just)
-}
\ No newline at end of file
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