Commit 84ad2e46 authored by bbr's avatar bbr
Browse files

fixed a heavy performance bug with nfctc

- also repaired some issue with new generator
- but (=:=) is still not functional!
parent b1196e71
......@@ -13,8 +13,11 @@ import Data.IORef
-- and may be called from compiled programs.
-------------------------------------------------
--SHOCKING: there was an additional ctcStore False (nf ...) around here,
-- runtimes were desastrous. Why was that??????
nfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
nfCTC cont = ctcStore False (nf (ctcStore False (nf cont)))
nfCTC cont = ctcStore False (nf cont)
hnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a
hnfCTC = ctcStore False
......@@ -62,7 +65,7 @@ patternFail s x = case consKind x of
-- generate branching
orsCTC :: BaseCurry a => [a] -> a
orsCTC xs = branching (nextOrRef ()) xs
orsCTC xs = branching (nextOrRef Generator) xs
-- generate free variable
freeIORef :: BaseCurry a => () -> a
......@@ -77,19 +80,19 @@ storeRefCounter :: IORef (Int,Int)
storeRefCounter = unsafePerformIO (newIORef (0,0))
-- generate a new reference
nextRef :: Bool -> OrRef
nextRef b = unsafePerformIO (do
nextRef :: Bool -> OrRefKind -> OrRef
nextRef b k = unsafePerformIO (do
(v,o) <- readIORef storeRefCounter
writeIORef storeRefCounter (if b then (v+1,o) else (v,o+1))
return (mkRef (if b then v else o)))
return (mkRefWithGenInfo k (if b then v else o)))
-- generate a reference for a branching
nextOrRef :: () -> OrRef
nextOrRef _ = nextRef False
nextOrRef :: OrRefKind -> OrRef
nextOrRef = nextRef False
-- generate a reference for a free variable
nextFreeRef :: BaseCurry a => () -> FreeVarRef a
nextFreeRef _ = FreeVarRef (deref (nextRef True))
nextFreeRef _ = FreeVarRef (deref (nextRef True Generator))
(unsafePerformIO (newIORef (failed (ErrorCall ""))))
---------------------------------------------------------------
......@@ -148,7 +151,7 @@ freeCTC :: (BaseCurry b, BaseCurry a) => (b -> a) -> a
freeCTC f = let x=freeIORef () in f x
orCTC :: BaseCurry a => a -> a -> a
orCTC x y = orsCTC [x,y]
orCTC x y = branching (nextOrRef Other) [x,y]
orBased :: RunTimeOptions
orBased = withFree {freeFunc = freeOrBased}
......
......@@ -5,9 +5,10 @@ module Store
trace,vtrace,vtrace',
OrRef,OrRefKind,deref,cover,uncover,mkRef,isCovered,
OrRef,OrRefKind(Generator,Other),deref,cover,uncover,mkRef,isCovered,
mkRefWithGenInfo, isGenerator, chainedTo,
narrowOrRef
) where
......
......@@ -662,7 +662,7 @@ genEq x y = ghnfCTC (\x'-> ghnfCTC (eq x') y) x
genStrEq :: Curry t0 => t0 -> t0 -> Result StrEqResult
genStrEq a b = (\ a' -> (onceMore a') `hnfCTC` b) `hnfCTC` a
where
onceMore a' b' = (\ a'' -> (unify a'') b') `hnfCTC` a'
onceMore a' b' = (\ a'' -> unify a'' b') `hnfCTC` a'
unify x y st = checkFree (consKind x) (consKind y)
where
checkFree Free Free
......@@ -675,6 +675,7 @@ genStrEq a b = (\ a' -> (onceMore a') `hnfCTC` b) `hnfCTC` a
checkFree _ Free = let p=pattern () in
bind (freeVarRef y) p (hnfCTC (unify x) p st)
checkFree Val Val = strEq x y st
checkFree x y = error $ "checkFree " ++ show (x,y)
strEqFail :: String -> StrEqResult
strEqFail s = C_False --C_SuccessFail (ErrorCall ("(=:=) for type "++s))
......
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