[project @ 2001-11-02 14:27:36 by simonpj]

new program

spectral/lambda/Main.hs

+module Main( main ) where
+
+-- From Mark: marku@cs.waikato.ac.nz [Nov 2001]
+-- This program contrasts the cost of direct and
+-- state-monadic style of computation.
+
+-- Experiments with Higher-Order mappings over terms.
+-- Speed comparisons of passing environments in a monad, versus explicitly.
+--
+--  With Hugs98 Feb 2001:  (K reductions/ K cells)
+--     N       mainSimple            mainMonad
+--             Redns   Cells       Redns    Cells
+--     10         4.7     8          15      28
+--     20        16.0    27          49      92
+--     30        33.5    57         102     192
+--     40        58      98         175     329
+--     50        89     150         268     502
+--     80       221     373         664    1242
+--    160       865    1456        2582    4826
+--    320      3419    5754       10181   19021
+--
+-- With GHC 5.00.1
+--     N       mainSimple            mainMonad
+--             secs    Kbytes         secs    Kbytes
+--     100     0.02      1180         0.08      8213
+--     200     0.080     4529         0.30     31997
+--     400     0.310    17850         1.36    126333
+--     800     1.54     70928          6.6    502096
+--  1 1600     7.66    282833         34.6   2001963
+--  2 1600                            28.76  1725128  1 with newtype
+--  3 1600                            28.1   1694119  2 + eval covers ALL cases
+--  4 1600                            28.5   1742828  3 + recursion calls eval
+--  5 1600     7.13    282832                         1 with no Add typechecks
+--
+-- Conclusion:  mainMonad is about 4 times slower than mainSimple
+--              and about 7 times more memory.
+--              
+
+import System
+
+main :: IO ()
+main = do { mainSimple ; mainMonad }
+
+mainSimple =
+    do  args <- getArgs
+	if null args
+	   then putStrLn "Args: number-to-sum-up-to"
+	   else putStrLn (show (simpleEval [] (App sum0 (Con (read(head args))))))
+
+mainMonad =
+    do  args <- getArgs
+	if null args
+	   then putStrLn "Args: number-to-sum-up-to"
+	   else (ev (App sum0 (Con (read(head args))))) >> return ()
+
+
+------------------------------------------------------------
+-- Data structures
+------------------------------------------------------------
+--instance Show (a -> b) where
+--    show f = "<function>"
+
+
+data Term
+    = Var String
+    | Con Int
+    | Incr
+    | Add Term Term
+    | Lam String Term
+    | App Term Term
+    | IfZero Term Term Term
+    -- the following terms are used internally
+    | Thunk Term Env  -- a closure
+    deriving (Eq,Read,Show)
+
+type Env = [(String,Term)]
+
+
+----------------------------------------------------------------------
+-- Evaluate a term
+----------------------------------------------------------------------
+ev :: Term -> IO (Env,Term)
+ev t =
+    do  let StateMonad2 m = traverseTerm t
+	let (env,t2) = m []
+	putStrLn (pp t2 ++ "  " ++ ppenv env)
+	return (env,t2)
+
+
+-----------------------------------------------------------------
+-- This class extends Monad to have the standard features
+-- we expect while evaluating/manipulating expressions.
+----------------------------------------------------
+class (Monad m) => EvalEnvMonad m where
+    incr :: m ()     -- example of a state update function
+    -- these defines the traversal!
+    traverseTerm :: Term -> m Term
+    --traversePred :: Pred -> m Pred
+    lookupVar :: String -> m Term
+    pushVar   :: String -> Term -> m a -> m a
+    currEnv   :: m Env         -- returns the current environment
+    withEnv   :: Env -> m a -> m a  -- uses the given environment
+    pushVar v t m = do env <- currEnv; withEnv ((v,t):env) m
+
+
+-- Here is a monad that evaluates the term.
+newtype StateMonad2 a = StateMonad2 (Env -> (Env,a))
+
+instance (Show a) => Show (StateMonad2 a) where
+    show (StateMonad2 f) = show (f [])
+
+instance Monad StateMonad2  where
+    return a = StateMonad2 (\s -> (s,a))
+    fail msg = StateMonad2 (\s -> (s,error msg))
+    (StateMonad2 g) >>= h =
+	StateMonad2 (\a -> (let (s,a1) = g a in
+			    (let StateMonad2 h' = h a1 in
+			     h' s)))
+
+instance EvalEnvMonad StateMonad2 where
+    incr = StateMonad2 (\s -> (s,()))
+    traverseTerm = eval
+    lookupVar v =
+	StateMonad2 (\env -> (env, lookup2 env))
+	where
+	lookup2 env = maybe (error ("undefined var: " ++ v)) id (lookup v env)
+    currEnv =
+	StateMonad2 (\env -> (env,env))
+    withEnv tmp (StateMonad2 m) =
+	StateMonad2 (\env -> let (_,t) = m tmp in (env,t))
+
+
+eval :: (EvalEnvMonad m) => Term -> m Term
+eval (Var x)   =
+    do e <- currEnv
+       t <- lookupVar x
+       traverseTerm t
+eval (Add u v) =
+    do {Con u' <- traverseTerm u;
+	Con v' <- traverseTerm v;
+	return (Con (u'+v'))}
+eval (Thunk t e) =
+    withEnv e (traverseTerm t)
+eval f@(Lam x b) =
+    do  env <- currEnv
+	return (Thunk f env)  -- return a closure!
+eval (App u v) =
+    do {u' <- traverseTerm u;
+	-- call-by-name, so we do not evaluate the argument v
+	apply u' v
+       }
+eval (IfZero c a b) =
+    do {val <- traverseTerm c;
+	if val == Con 0
+	   then traverseTerm a
+	   else traverseTerm b}
+eval (Con i)   = return (Con i)
+eval (Incr)    = incr >> return (Con 0)
+
+--apply :: Term -> Term -> StateMonad2 Term
+apply (Thunk (Lam x b) e) a =
+    do  orig <- currEnv
+	withEnv e (pushVar x (Thunk a orig) (traverseTerm b))
+apply a b         = fail ("bad application: " ++ pp a ++
+			      "  [ " ++ pp b ++ " ].")
+
+
+
+
+----------------------------------------------------------------------
+-- A directly recursive Eval, with explicit environment
+----------------------------------------------------------------------
+-- A trivial monad so that we can use monad syntax.
+data Id a = Id a
+
+instance Monad Id where
+    return t = Id t
+    fail = error
+    (Id t) >>= f = f t
+
+instance Show a => Show (Id a) where
+    show (Id t) = show t
+
+simpleEval :: Env -> Term -> Id Term
+simpleEval env (Var v) =
+    simpleEval env (maybe (error ("undefined var: " ++ v)) id (lookup v env))
+simpleEval env e@(Con _) =
+    return e
+simpleEval env e@Incr =
+    return (Con 0)
+simpleEval env (Add u v) =
+    do {Con u' <- simpleEval env u;
+	Con v' <- simpleEval env v;
+	return (Con (u' + v'))}
+    where
+    addCons (Con a) (Con b) = return (Con (a+b))
+    addCons (Con _) b = fail ("type error in second arg of Add: " ++ pp b)
+    addCons a (Con _) = fail ("type error in first arg of Add: " ++ pp a)
+simpleEval env f@(Lam x b) =
+    return (Thunk f env)  -- return a closure!
+simpleEval env (App u v) =
+    do {u' <- simpleEval env u;
+	-- call-by-name, so we do not evaluate the argument v
+	simpleApply env u' v
+       }
+simpleEval env (IfZero c a b) =
+    do {val <- simpleEval env c;
+	if val == Con 0
+	   then simpleEval env a
+	   else simpleEval env b}
+simpleEval env (Thunk t e) =
+    simpleEval e t
+
+simpleApply :: Env -> Term -> Term -> Id Term
+simpleApply env (Thunk (Lam x b) e) a =
+    simpleEval env2 b
+    where
+    env2 = (x, Thunk a env) : e
+simpleApply env a b         = fail ("bad application: " ++ pp a ++
+			      "  [ " ++ pp b ++ " ].")
+
+------------------------------------------------------------
+-- Utility functions for printing terms and envs.
+------------------------------------------------------------
+ppenv env = "[" ++ concatMap (\(v,t) -> v ++ "=" ++ pp t ++ ", ") env ++ "]"
+
+
+pp :: Term -> String
+pp = ppn 0
+
+-- Precedences:
+--   0 = Lam and If (contents never bracketed)
+--   1 = Add
+--   2 = App
+--   3 = atomic and bracketed things
+ppn :: Int -> Term -> String
+ppn _ (Var v) = v
+ppn _ (Con i) = show i
+ppn _ (Incr)  = "INCR"
+ppn n (Lam v t) = bracket n 0 ("@" ++ v ++ ". " ++ ppn (-1) t)
+ppn n (Add a b) = bracket n 1 (ppn 1 a ++ " + " ++ ppn 1 b)
+ppn n (App a b) = bracket n 2 (ppn 2 a ++ " " ++ ppn 2 b)
+ppn n (IfZero c a b) = bracket n 0
+    ("IF " ++ ppn 0 c ++ " THEN " ++ ppn 0 a ++ " ELSE " ++ ppn 0 b)
+ppn n (Thunk t e) = bracket n 0 (ppn 3 t ++ "::" ++ ppenv e)
+
+bracket outer this t | this <= outer = "(" ++ t ++ ")"
+		     | otherwise     = t
+
+
+------------------------------------------------------------
+-- Test Data
+------------------------------------------------------------
+x  = (Var "x")
+y  = (Var "y")
+a1 = (Lam "x" (Add (Var "x") (Con 1)))
+aa = (Lam "x" (Add (Var "x") (Var "x")))
+
+-- These should all return 1
+iftrue = (IfZero (Con 0) (Con 1) (Con 2))
+iffalse = (IfZero (Con 1) (Con 2) (Con 1))
+
+-- This function sums all the numbers from 0 upto its argument.
+sum0 :: Term
+sum0 = (App fix partialSum0)
+partialSum0 = (Lam "sum"
+		  (Lam "n"
+		   (IfZero (Var "n")
+		    (Con 0)
+		    (Add (Var "n") (App (Var "sum") nMinus1)))))
+nMinus1 = (Add (Var "n") (Con (-1)))
+
+lfxx :: Term
+lfxx = (Lam "x" (App (Var "F") (App (Var "x") (Var "x"))))
+
+-- This is the fix point combinator:  Y
+fix :: Term
+fix = (Lam "F" (App lfxx lfxx))

spectral/lambda/Makefile

+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+-include opts.mk
+
+# Arguments for the test program
+SRC_RUNTEST_OPTS += 1600
+
+include $(TOP)/mk/target.mk

spectral/lambda/lambda.stdout

+Con 1280800
+1280800  []