gistfile1.hs

mkset :: Ord a => [a] -> M.Map a ()
mkset = M.fromList . map (\x->(x,()))

gc :: Ord k => M.Map k v -> [k] -> (v -> [k]) -> M.Map k v
gc pvals proots ptrs = M.unions $ follow pvals proots
    where
      follow _ [] = []
      follow vals roots = 
          let rootset = mkset roots
              rootobjs = vals `M.intersection` rootset
              newptrs = M.elems rootobjs >>= ptrs
              nonrootobjs = vals `M.difference` rootset
          in rootobjs:(follow nonrootobjs newptrs)

garbageCollect :: PrologState ()
garbageCollect = do
  (Environment curr max root bind) <- psEnv
  let rootvars = M.elems $ (M.mapKeys fst $ M.mapWithKey const bind) `M.intersection` mkset root
  let bind' = gc bind rootvars getvars 
  psSetEnv (Environment curr max root bind')
      where
        getvars (VarTerm v) = [v]
        getvars (NumTerm n) = []
        getvars (AtomTerm a) = []
        getvars (FuncTerm f ts) = getvars =<< ts