为什么这个树记忆的 Haskell 函数不比未记忆的版本快？答案

【问题标题】：Why isn't this tree memoized Haskell function faster than the unmemoized version?为什么这个树记忆的 Haskell 函数不比未记忆的版本快？
【发布时间】：2012-10-26 17:25:55
【问题描述】：

我试图了解如何在 Haskell 中通过各种数据类型的参数来记忆函数。我已经实现了在 Ralf Hinze 的文章“Memo functions, polytypically!”中找到的 Tree 类型的制表和应用函数

我的实现如下。我的测试函数计算深度为 d 的树中子树的数量。如果我记住递归调用，这个函数应该更快吗？不是：对我的系统上的两个版本进行计时：

helmholtz:LearningHaskell edechter$ time ./Memo 1 23
Not memoized: # of subtrees for tree of depth 23 is: 25165822

real    0m1.898s
user    0m1.886s
sys 0m0.011s
helmholtz:LearningHaskell edechter$ time ./Memo 0 23
Memoized: # of subtrees for tree of depth 23 is: 25165822

real    0m5.129s
user    0m5.013s
sys 0m0.115s

我的代码很简单：

-- Memo.hs
import System.Environment

data Tree = Leaf | Fork Tree Tree deriving Show
data TTree v = NTree v (TTree (TTree v)) deriving Show

applyTree :: TTree v -> (Tree -> v)
applyTree (NTree tl tf) Leaf = tl
applyTree (NTree tl tf) (Fork l r) = applyTree (applyTree tf l) r

tabulateTree :: (Tree -> v) -> TTree v
tabulateTree f = NTree (f Leaf) (tabulateTree $ \l
                                     -> tabulateTree $ \r -> f (Fork l r))

numSubTrees :: Tree -> Int
numSubTrees Leaf = 1
numSubTrees (Fork l r ) = 2 + numSubTrees l + numSubTrees r

memo = applyTree . tabulateTree

mkTree d | d == 0 = Leaf
         | otherwise = Fork (mkTree $ d-1) (mkTree $ d-1)

main = do
  args <- getArgs
  let version = read $ head args
      d = read $ args !! 1
      (version_name, out) = if version == 0
                              then ("Memoized", (memo numSubTrees) (mkTree d))
                              else ("Not memoized", numSubTrees (mkTree d))
  putStrLn $ version_name ++ ": # of subtrees for tree of depth "
               ++ show d ++ " is: " ++ show out

更新

我明白为什么我的函数不会利用记忆，但我仍然不明白如何构建一个可以利用这一点的函数。基于斐波那契记忆示例here，我的尝试如下：

memofunc :: Tree -> Int
memofunc  = memo f
    where f (Fork l r) = memofunc l + memofunc r
          f (Leaf) = 1

func :: Tree -> Int
func (Leaf) = 1
func (Fork l r) = func l + func r

但这仍然没有做正确的事情：

helmholtz:LearningHaskell edechter$ time ./Memo 0 23
Memoized: # of subtrees for tree of depth 23 is: 8388608

real    0m10.436s
user    0m9.895s
sys 0m0.532s
helmholtz:LearningHaskell edechter$ time ./Memo 1 23
Not memoized: # of subtrees for tree of depth 23 is: 8388608

real    0m1.666s
user    0m1.654s
sys 0m0.011s

【问题讨论】：

numSubTrees 只通过树一次，所以你不能指望记忆化在那里有什么不同。您是否期望它能够注意到mkTree 生成的树具有相等的左右子树？（它不能）。
好的，但是为什么记忆的版本不能注意到它们有相等的左右子树呢？在计算完左子树后，它不会在表中查找右子树而不是重新计算它吗？

标签： haskell tree memoization

【解决方案1】：

numSubTrees 是递归函数，你的memo 无法窥视递归：这意味着memo numSubTrees 只查找第一个调用，而递归调用仍在使用未记忆的版本。

【讨论】：

好的，谢谢，我明白这是怎么回事。我已经用新功能及其记忆版本更新了我的问题。这不应该参考每次通话的备忘录表吗？

【解决方案2】：

两位回答者都是正确的，但这里有一个更完整的回答。

我的原始代码中有两个错误。第一个，我在更新中更正了，我原来的 memoized 函数只在第一次调用中使用了 memo 表。递归调用只是普通的 unmemoized 函数调用。

但是，即使修复了这个错误，也没有提高速度。这不是因为该函数未能调用备忘录表，而是因为没有足够的递归调用来证明对表的索引是合理的。但是如果我们让函数在相同的子树上执行更多的调用，我们会看到记忆化会带来改进。

-- Memo.hs                                                                                                                                                                                                  

import System.Environment                                                                                                                                                                                   

data Tree = Leaf | Fork Tree Tree deriving Show                                                                                                                                                             
data TTree v = NTree v (TTree (TTree v)) deriving Show                                                                                                                                                      

applyTree :: TTree v -> (Tree -> v)                                                                                                                                                                         
applyTree (NTree tl tf) Leaf = tl                                                                                                                                                                           
applyTree (NTree tl tf) (Fork l r) = applyTree (applyTree tf l) r                                                                                                                                           

tabulateTree :: (Tree -> v) -> TTree v                                                                                                                                                                      
tabulateTree f = NTree (f Leaf) (tabulateTree $ \l                                                                                                                                                          
                                     -> tabulateTree $ \r -> f (Fork l r))                                                                                                                                  

memofunc :: Tree -> Int                                                                                                                                                                                     
memofunc t  = (memo func) t                                                                                                                                                                                 
    where func :: Tree -> Int                                                                                                                                                                               
          func (Leaf) = 1                                                                                                                                                                                   
          func (Fork Leaf Leaf) = 1                                                                                                                                                                         
          func (Fork l@(Fork a b) r) = memofunc l + memofunc a + memofunc b                                                                                                                                 
                                       + memofunc r                                                                                                                                                         

func :: Tree -> Int                                                                                                                                                                                         
func (Leaf) = 1                                                                                                                                                                                             
func (Fork Leaf Leaf) = 1                                                                                                                                                                                   
func (Fork l@(Fork a b) r) = func l + func a + func b + func r                                                                                                                                              


memo = applyTree . tabulateTree                                                                                                                                                                             

mkTree d | d == 0 = Leaf                                                                                                                                                                                    
         | otherwise = Fork (mkTree $ d-1) (mkTree $ d-1)                                                                                                                                                   

main = do                                                                                                                                                                                                   
  args <- getArgs                                                                                                                                                                                           
  let version = read $ head args                                                                                                                                                                            
      d = read $ args !! 1                                                                                                                                                                                  
      (version_name, out) = if version == 0                                                                                                                                                                 
                            then ("Memoized", (memofunc) (mkTree d))                                                                                                                                        
                            else ("Not memoized", func (mkTree d))                                                                                                                                          
  putStrLn $ version_name ++ ": function apply to tree of depth "                                                                                                                                           
               ++ show d ++ " is: " ++ show out

导致记忆和非记忆运行时间的原因（在深度 23 的平衡树上）：

helmholtz:LearningHaskell edechter$ time ./Memo 0 21
Memoized: function apply to tree of depth 21 is: 733219840

real    0m2.954s
user    0m2.781s
sys 0m0.162s
helmholtz:LearningHaskell edechter$ time ./Memo 1 21
Not memoized: function apply to tree of depth 21 is: 733219840

real    0m6.334s
user    0m6.304s
sys 0m0.025s

【讨论】：