fix fixpoint algo

parent 03b3c623
...@@ -117,9 +117,9 @@ memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,oldCache), ...@@ -117,9 +117,9 @@ memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,oldCache),
-- cache with previous knowledge about the result or ⊥, compute -- cache with previous knowledge about the result or ⊥, compute
-- the result of the function and update the fixpoint cache. -- the result of the function and update the fixpoint cache.
Nothing -> do Nothing -> do
let yOld = fromMaybe bottom (M.unsafeLookup x oldCache) let (x',stack') = runState (stackWidening x) stack
newCache' = M.insert x yOld newCache yOld = fromMaybe bottom (M.unsafeLookup x' oldCache)
(x',stack') = runState (stackWidening x) stack newCache' = M.insert x' yOld newCache
(newCache'',y) <- f (stackWidening,widening) -< (((stack',oldCache), newCache'),x') (newCache'',y) <- f (stackWidening,widening) -< (((stack',oldCache), newCache'),x')
let newCache''' = M.unsafeInsertWith (flip (T.widening widening)) x' y newCache'' let newCache''' = M.unsafeInsertWith (flip (T.widening widening)) x' y newCache''
y' = fromJust (M.unsafeLookup x' newCache''') y' = fromJust (M.unsafeLookup x' newCache''')
......
...@@ -36,12 +36,9 @@ pi2 = arr snd ...@@ -36,12 +36,9 @@ pi2 = arr snd
-- | Zips two lists together. -- | Zips two lists together.
zipWith :: ArrowChoice c => c (x,y) z -> c ([x],[y]) [z] zipWith :: ArrowChoice c => c (x,y) z -> c ([x],[y]) [z]
zipWith f = proc (l1,l2) -> case (l1,l2) of zipWith f = proc (l1,l2) -> case (l1,l2) of
([],_) -> returnA -< [] ([],_) -> returnA -< []
(_,[]) -> returnA -< [] (_,[]) -> returnA -< []
(a:as,b:bs) -> do (a:as,b:bs) -> uncurry (:) ^<< f *** zipWith f -< ((a,b),(as,bs))
c <- f -< (a,b)
cs <- zipWith f -< (as,bs)
returnA -< c:cs
-- | Folds a computation over a list from left to right. -- | Folds a computation over a list from left to right.
fold :: ArrowChoice c => c (a,x) a -> c ([x],a) a fold :: ArrowChoice c => c (a,x) a -> c ([x],a) a
......
...@@ -10,8 +10,8 @@ import Prelude hiding (lookup,map,Either(..),(**)) ...@@ -10,8 +10,8 @@ import Prelude hiding (lookup,map,Either(..),(**))
import Control.Arrow import Control.Arrow
import Data.HashMap.Strict (HashMap) import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Strict as H import qualified Data.HashMap.Lazy as H
import Data.Hashable import Data.Hashable
import Data.Order import Data.Order
import Data.Identifiable import Data.Identifiable
...@@ -47,6 +47,7 @@ widening w (Map m1) (Map m2) = Map $ H.map join $ H.unionWith (E.widening (finit ...@@ -47,6 +47,7 @@ widening w (Map m1) (Map m2) = Map $ H.map join $ H.unionWith (E.widening (finit
Left (_,a) -> (May,a) Left (_,a) -> (May,a)
Right (_,b) -> (May,b) Right (_,b) -> (May,b)
LeftRight (t1,a) (t2,b) -> (t1 t2,a `w` b) LeftRight (t1,a) (t2,b) -> (t1 t2,a `w` b)
{-# INLINE widening #-}
{-# SCC widening #-} {-# SCC widening #-}
instance (Identifiable a, PreOrd b) => LowerBounded (Map a b) where instance (Identifiable a, PreOrd b) => LowerBounded (Map a b) where
......
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