在 Haskell 中处理“内存不足”异常/stackoverflow 时如何使用“跟踪”？

Question

上下文：我正在为一种语言编写解释器，该语言基本上是 Haskell 的一个小子集。

Haskell 的懒惰评估是一种便便，并且拒绝评估这个 trace 命令，因为（我怀疑）无限递归会导致“内存不足”异常。

evalE :: VEnv -> Exp -> Value
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined
-- actual definition of evalE follows from here
-- ...

我得到以下结果：

weber % ./run_tests.sh
Building minhs-0.1.0.0...
Preprocessing executable 'minhs-1' for minhs-0.1.0.0...
Check.hs: out of memory (requested 1048576 bytes)
weber %

是否有一些简单的方法可以强制trace 进行评估，而不考虑异常情况？也许是一种快速强制进行严格评估的方法？我真的很想获得一些关于它实际试图评估的调试信息。

编辑：进一步的谷歌搜索揭示了 ($!) 运算符，它应该强制严格。但是我已将其添加到我的代码中，但没有任何改变：

evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") $! False = undefined

还有其他提示吗？我真的很想强制该跟踪来评估它的副作用。

edit2：更多的谷歌搜索显示了seq 运算符，但它的行为并不像宣传的那样。

evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False `seq` False = undefined

即使这样也拒绝打印痕迹。

我还研究了如何让 BangPatterns 扩展工作，但也没有打印跟踪：

evalE !g !e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined

（完整文件供参考。虽然它是一个多文件程序）：

module MinHS.Evaluator where
import qualified MinHS.Env as E
import MinHS.Syntax
import MinHS.Pretty
import qualified Text.PrettyPrint.ANSI.Leijen as PP

import Debug.Trace

type VEnv = E.Env Value

data Value = I Integer
           | B Bool
           | Nil
           | Cons Integer Value
           | Fun VEnv [String] Exp
           deriving (Show)

instance PP.Pretty Value where
  pretty (I i) = numeric $ i
  pretty (B b) = datacon $ show b
  pretty (Nil) = datacon "Nil"
  pretty (Cons x v) = PP.parens (datacon "Cons" PP.<+> numeric x PP.<+> PP.pretty v)
  pretty _ = undefined -- should not ever be used

evaluate :: Program -> Value
evaluate [Bind _ _ _ e] = evalE E.empty e
evaluate bs = evalE E.empty (Let bs (Var "main"))

instance Num Value where
    I x + I y = I (x + y)
    I x * I y = I (x * y)
    I x - I y = I (x - y)
    abs (I x) = I (abs x)
    fromInteger x = I x

instance Integral Value where
    div _ (I 0) = error $ "Cannot divide by zero"
    div (I x) (I y) = I (div x y)
    mod (I x) (I y) = I (mod x y)

instance Real Value where

instance Enum Value where

instance Ord Value where
    I x > I y = x > y
    I x >= I y = x >= y
    I x <= I y = x <= y
    I x < I y = x < y

instance Eq Value where
    I x == I y = x == y
    I x /= I y = x /= y

evalE :: VEnv -> Exp -> Value
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined
evalE g (Num x) = I x
evalE g (App (Prim Neg) x) = (evalE g x) * (-1)
evalE g (Con "False") = B False
evalE g (Con "True") = B True
evalE g (Con "Nil") = Nil
evalE g (App (App (Prim Gt) x) y) = B ((evalE g x) > (evalE g y))
evalE g (App (App (Prim Ge) x) y) = B ((evalE g x) >= (evalE g y))
evalE g (App (App (Prim Lt) x) y) = B ((evalE g x) < (evalE g y))
evalE g (App (App (Prim Le) x) y) = B ((evalE g x) <= (evalE g y))
evalE g (App (App (Prim Eq) x) y) = B ((evalE g x) == (evalE g y))
evalE g (App (App (Prim Ne) x) y) = B ((evalE g x) /= (evalE g y))
evalE g (App (Prim Head) (Con "Nil")) = error $ "Cannot take head of empty list"
evalE g (App (Prim Tail) (Con "Nil")) = error $ "Cannot take tail of empty list"
evalE g (App (Prim Head) (App (App (Con "Cons") x) _)) = evalE g x
evalE g (App (Prim Tail) (App (App (Con "Cons") _) x)) = evalE g x
evalE g (App (Prim Null) list) = case evalE g list of
                                    Nil -> B True
                                    _ -> B False
evalE g (App (App (Con "Cons") (Num x)) y) = Cons x (evalE g y)
evalE g (App (App (Prim Add) x) y) = (evalE g x) + (evalE g y)
evalE g (App (App (Prim Mul) x) y) = (evalE g x) * (evalE g y)
evalE g (App (App (Prim Sub) x) y) = (evalE g x) - (evalE g y)
evalE g (App (App (Prim Quot) x) y) = div (evalE g x) (evalE g y)
evalE g (App (App (Prim Rem) x) y) = mod (evalE g x) (evalE g y)
evalE g (Let bindings exp) = evalE ((E.addAll g . (map (\(Bind str _ _ bexp) -> (str, evalE g bexp)))) bindings) exp
evalE g e@(Var x) = case E.lookup g x of
                    Just y -> y
                    Nothing -> error $ "Variable " ++ x ++ " not defined" ++ errz g e
evalE g (If exp t f) = case evalE g exp of
                        B True -> evalE g t
                        B False -> evalE g f
evalE g e@(Letfun (Bind name _ args exp)) = Fun (E.add g (name, evalE g e)) args exp
evalE g e@(App (Var x) exp) = case E.lookup g x of
                                Just (Fun env args f) -> evalE (E.addAll env [(head args, evalE g exp)]) f
                                Nothing -> error $ "Function " ++ x ++ " not defined" ++ errz g e
evalE g (App exp1 exp2) = case evalE g exp1 of
                            Fun env args f -> evalE (E.addAll env [(head args, evalE g exp2)]) f

evalE g e = error $ "No pattern" ++ errz g e
--evalE g e = error "Implement me!"

errz g e = "\nVEnv: \n" ++ show g ++ "\n\nExp: \n" ++ show e

Answer 1

我认为@leftroundabout 的意思是，如果g 或e 的评估触发了问题，那么跟踪行为将在跟踪任何输出之前生成异常。

trace 将其参数编组为 C 字符串以供输出。因此，show g 和 show e 必须在 trace 打印输出的单个字符之前进行全面评估。

例如，下面的程序：

import Debug.Trace

badsum = sum [1..1000000]

process g | trace ("processing " ++ show g) False = undefined
process _ = "whatever"

main = print (process badsum)

在没有优化的情况下编译并以较小的堆大小运行时：

$ stack ghc -- -fforce-recomp -rtsopts Trace
[1 of 1] Compiling Main             ( Trace.hs, Trace.o )
Linking Trace ...
$ ./Trace +RTS -M10M
Trace: Heap exhausted;
Trace: Current maximum heap size is 10485760 bytes (10 MB).
Trace: Use `+RTS -M<size>' to increase it.

在trace 调用打印任何内容之前生成异常。在评估trace的过程中，g的值被完全评估，在trace产生输出之前触发异常。

将trace 调用替换为trace "processing" False，程序会打印跟踪并运行到完成（因为它从不尝试评估g）。