-freshBlockId :: String -> DFM f BlockId
-freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
-
-liftUSM :: UniqSM a -> DFM f a
-liftUSM uc = DFM f
- where f _ s = let (a, us') = initUs (df_uniqs s) uc
- in (a, s {df_uniqs = us'})
-
-instance Monad (DFA f) where
- DFA f >>= k = DFA (\l s -> let (a, s') = f l s
- DFA f' = k a
- in f' l s')
- return a = DFA (\_ s -> (a, s))
-
-instance Monad (DFM f) where
- DFM f >>= k = DFM (\l s -> let (a, s') = f l s
- DFM f' = k a
- in f' l s')
- return a = DFM (\_ s -> (a, s))
-
-instance FuelUsingMonad (DFM f) where
- fuelRemaining = extract fuelRemainingInState
- lastFuelPass = extract lastFuelPassInState
- fuelExhausted = extract fuelExhaustedInState
- fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s }))
- where fs' s = fuelDecrementState p f f' $ df_fstate s
-
-extract :: (FuelState -> a) -> DFM f a
-extract f = DFM (\_ s -> (f $ df_fstate s, s))
+instance Monad m => Monad (DFM' m f) where
+ DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
+ s' `seq` case k a of DFM' f' -> f' l s')
+ return a = DFM' (\_ s -> return (a, s))
+ -- The `seq` is essential to ensure that entire passes of the dataflow engine
+ -- aren't postponed in a thunk. By making the sequence strict in the state,
+ -- we ensure that each action in the monad is executed immediately, preventing
+ -- stack overflows that previously occurred when finally forcing the old state thunks.
+
+instance FuelUsingMonad (DFM' FuelMonad f) where
+ fuelRemaining = liftToDFM' fuelRemaining
+ lastFuelPass = liftToDFM' lastFuelPass
+ fuelExhausted = liftToDFM' fuelExhausted
+ fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
+ fuelDec1 = liftToDFM' fuelDec1
+instance MonadUnique (DFM' FuelMonad f) where
+ getUniqueSupplyM = liftToDFM' getUniqueSupplyM
+ getUniqueM = liftToDFM' getUniqueM
+ getUniquesM = liftToDFM' getUniquesM
+
+liftToDFM' :: Monad m => m x -> DFM' m f x
+liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
+liftToDFM :: FuelMonad x -> DFM f x
+liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))