[WIP] Memoization tables

pact.cabal

@@ -114,6 +114,7 @@ library
     Pact.Types.KeySet
     Pact.Types.Lang
     Pact.Types.Logger
+    Pact.Types.Memoize
     Pact.Types.Names
     Pact.Types.Namespace
     Pact.Types.Native

src/Pact/Eval.hs

@@ -82,6 +82,7 @@ import Pact.Runtime.Typecheck
 import Pact.Runtime.Utils
 import Pact.Types.Advice
 import Pact.Types.Capability
+import Pact.Types.Memoize (memoLookup, termFunctionCall)
 import Pact.Types.PactValue
 import Pact.Types.KeySet
 import Pact.Types.Pretty
@@ -214,7 +215,9 @@ evalByName n as i = do
 
 -- | Application with additional args.
 apply :: App (Term Ref) -> [Term Name] -> Eval e (Term Name)
-apply app as = reduceApp $ over appArgs (++ map liftTerm as) app
+apply app as = do
+  reduceApp $ over appArgs (++ map liftTerm as) app
+
 
 topLevelCall
   :: Info -> Text -> GasArgs -> (Gas -> Eval e (Gas, a)) -> Eval e a
@@ -1043,7 +1046,7 @@ unsafeReduce t = return (t >>= const (tStr "Error: unsafeReduce on non-static te
 
 -- | Main function for reduction/evaluation.
 reduce :: Term Ref ->  Eval e (Term Name)
-reduce (TApp a _) = reduceApp a
+reduce (TApp a _) = reduceAppWithMemoTable a
 reduce (TVar t _) = deref t
 reduce t@TLiteral {} = unsafeReduce t
 reduce t@TGuard {} = unsafeReduce t
@@ -1115,14 +1118,24 @@ resolveArg ai as i = case as ^? ix i of
 appCall :: Pretty t => FunApp -> Info -> [Term t] -> Eval e (Gas,a) -> Eval e a
 appCall fa ai as = call (StackFrame (_faName fa) ai (Just (fa,map abbrev as)))
 
-enforcePactValue :: Pretty n => (Term n) -> Eval e PactValue
+enforcePactValue :: (Pretty n, Show n) => (Term n) -> Eval e PactValue
 enforcePactValue t = case toPactValue t of
   Left s -> evalError' t $ "Only value-level terms permitted: " <> pretty s
   Right v -> return v
 
-enforcePactValue' :: (Pretty n, Traversable f) => f (Term n) -> Eval e (f PactValue)
+enforcePactValue' :: (Pretty n, Show n, Traversable f) => f (Term n) -> Eval e (f PactValue)
 enforcePactValue' = traverse enforcePactValue
 
+reduceAppWithMemoTable :: App (Term Ref) -> Eval e (Term Name)
+reduceAppWithMemoTable app = do
+  memoTable <- use evalMemoTable
+  fcResult <- catchesPactError (termFunctionCall reduce app)
+  case fcResult of
+    Right fc -> case memoLookup fc memoTable of
+      Just res -> return (fromPactValue res)
+      Nothing -> reduceApp app
+    Left _ -> reduceApp app
+
 reduceApp :: App (Term Ref) -> Eval e (Term Name)
 reduceApp (App (TVar (Direct t) _) as ai) = reduceDirect t as ai
 reduceApp (App (TVar (Ref r) _) as ai) = reduceApp (App r as ai)

src/Pact/Repl/Lib.hs

@@ -23,6 +23,7 @@ module Pact.Repl.Lib where
 
 import Control.Arrow ((&&&))
 import Control.Concurrent.MVar
+import Control.DeepSeq (deepseq)
 import Control.Lens
 import Control.Exception.Safe
 import Control.Monad.Reader
@@ -73,6 +74,7 @@ import Pact.Persist.Pure
 import Pact.PersistPactDb
 import Pact.Types.Logger
 import Pact.Types.Pretty
+import Pact.Types.Memoize (unguardedInsert, termFunctionCall)
 import Pact.Repl.Types
 import Pact.Native.Capabilities (evalCap)
 import Pact.Gas.Table
@@ -275,6 +277,21 @@ replDefs = ("Repl",
        (funType tTyString [("on-chain", tTyBool)])
        [LitExample "(env-simulate-onchain true)"]
        "Set a flag to simulate on-chain behavior that differs from the repl, in particular for observing things like errors and stack traces."
+
+     ,defZNative "env-memoize" envMemoize
+
+       (funType tTyString [("f", TyAny)]
+        -- funType tTyString [("f", TyAny), ("x", TyAny)] <>
+        -- funType tTyString [("f", TyAny), ("x", TyAny), ("y", TyAny)] <>
+        -- funType tTyString [("f", TyAny), ("x", TyAny), ("y", TyAny), ("z", TyAny)]
+       )
+
+       []
+       ("WIP")
+     ,defZRNative "env-clear-memotable" envClearMemotable
+      (funType tTyString [])
+      ["(env-clear-memotable)"]
+      "Reset the memoization table."
      ])
      where
        json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
@@ -445,7 +462,7 @@ continuePact i as = case as of
       return (pid, y)
 
 mkSimpleYield
-  :: Pretty n
+  :: (Pretty n, Show n)
   => Maybe Provenance
   -> ObjectMap (Term n)
   -> Eval e (Maybe Yield)
@@ -880,3 +897,33 @@ envSimulateOnChain _i [TLiteral (LBool simulateOnChain) _] = do
   let ppInRepl = if simulateOnChain then "true" else "false"
   return $ tStr $ "Set on-chain simulation execution mode to: " <> ppInRepl
 envSimulateOnChain i as = argsError i as
+
+-- (env-memoize shift 10 1)
+envMemoize :: ZNativeFun LibState
+envMemoize _i [] = error "TODO: No arguments"
+envMemoize _i [TApp (App memoFun memoArgs _) _ ] = do
+
+  -- Reduce the args to the memoized function and ensure they
+  -- evaluate to values.
+  reducedArgs :: [Term Name] <- traverse (reduce >=> enforcePactValue >=> pure . fromPactValue) memoArgs
+
+  -- Raise the reduced args.
+  let liftedArgs = map liftTerm reducedArgs
+
+  let app  = App memoFun liftedArgs def
+  let app'  = App memoFun memoArgs def
+  result <- reduce $ TApp app def
+  -- result <- eval (TApp app def)
+  table0 <- use evalMemoTable
+  entry <- termFunctionCall reduce app'
+  let result' = either (\e -> error $ "Could not convert result: " ++ show e) id $ toPactValue result
+  let table1 = unguardedInsert (entry, result') table0
+  evalMemoTable .= table1
+  return $ deepseq table1 $ tStr "Ok"
+envMemoize i as = argsError' i as
+
+envClearMemotable :: RNativeFun LibState
+envClearMemotable _i [] = do
+  evalMemoTable .= mempty
+  return $ tStr "Ok"
+envClearMemotable i as = argsError i as

src/Pact/Types/Memoize.hs

@@ -0,0 +1,123 @@
+-- |
+-- Module      :  Pact.Types.Memoize
+-- Copyright   :  (C) 2016 Stuart Popejoy
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
+--
+-- Memoization of function applications, and the machinery for proving
+-- the precomputed results are accurate.
+--
+-- The memoization table allows certain function applications to
+-- be replaced by a pre-computed result.
+--
+-- Insertion into the table can be done via the repl builtin:
+-- `env-add-memo-entry`.
+
+
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Pact.Types.Memoize (
+
+  -- * Use a `MemoTable` to short-cut application of a function.
+  memoLookup,
+
+  -- * Add an entry to the `MemoTable`.
+  unguardedInsert,
+
+  -- * Runtime representation of a memo table. Meant to be part of
+  -- the Eval environment.
+  MemoTable (MemoTable),
+
+  FunctionCall(..),
+  termFunctionCall,
+
+) where
+
+import Control.DeepSeq (NFData)
+import Data.Default (Default, def)
+import Data.Map (Map)
+import Data.Traversable (forM)
+import qualified Data.Map as Map
+import GHC.Generics (Generic)
+
+import Pact.Types.PactValue (PactValue, toPactValue)
+-- import Pact.Types.Pretty (Pretty)
+import Pact.Types.Term
+
+-- A MemoTable maps function applications to their evaluation result.
+-- The MemoTable is part of `EvalEnv`.
+--
+-- Pairs are validated on their way into the table, so we do not
+-- need to check their validity again when the table is used for
+-- substitution.
+--
+-- NOTE: It is stored as an association list rather than a hashmap
+-- in order to avoid the need to Eq, Ord, Hashable constraints
+-- on `App` and `Term`. We can revisit this.
+--
+-- TODO: Can we assume it's always `Term Name` in the table, and remove
+-- our type parameter `n`?
+data MemoTable = MemoTable {
+  unMemoTable :: Map FunctionCall PactValue
+  } deriving (Show, Generic)
+
+instance NFData MemoTable
+instance Default MemoTable where def = MemoTable mempty
+
+instance Semigroup MemoTable where
+  MemoTable a <> MemoTable b = MemoTable (a <> b)
+
+instance Monoid MemoTable where
+  mempty = MemoTable mempty
+
+-- Insert a pair of function application and result into the memotable.
+-- Insertion is guarded by a `Witness` - a means of asserting that
+-- the pair is valid. The `Witness` is evaluated in some monad,
+-- (normally `Eval`).
+unguardedInsert
+  :: (FunctionCall, PactValue)
+  -> MemoTable
+  -> MemoTable
+unguardedInsert (funCall, result) MemoTable { unMemoTable = table0 } =
+      MemoTable { unMemoTable =
+                  Map.insert funCall result table0 }
+
+
+memoLookup :: FunctionCall -> MemoTable -> Maybe PactValue
+memoLookup key MemoTable {unMemoTable = table} = do
+  Map.lookup key table
+
+
+newtype AnyFunctionName = AnyFunctionName {
+  unAnyFunctionName :: Either NativeDefName QualifiedName
+  } deriving (Eq, Ord, Show, Generic)
+
+instance NFData AnyFunctionName
+
+data FunctionCall = FunctionCall {
+  fcFunction :: AnyFunctionName,
+  fcArgs :: [PactValue]
+} deriving (Eq, Show, Generic, Ord)
+
+instance NFData FunctionCall
+
+
+termFunctionCall :: Monad m => (Term Ref -> m (Term Name)) -> App (Term Ref) -> m FunctionCall
+termFunctionCall eval App { _appFun = fn, _appArgs = args } = do
+    let
+    fcFunction <-
+        case fn of
+          TNative { _tNativeName } -> return $ AnyFunctionName $ Left _tNativeName
+          TVar { _tVar } -> case _tVar of
+            Direct (TNative { _tNativeName  }) -> return $ AnyFunctionName $ Left _tNativeName
+            Ref (TDef { _tDef = Def { _dDefName = DefName fnName, _dModule, _dDefType = Defun } }) ->
+              return $ AnyFunctionName $ Right $ QualifiedName { _qnQual = _dModule, _qnName = fnName, _qnInfo = def}
+            e -> error ("TVar: " ++ show e)
+          l -> error $ "TODO " ++ show l -- return $ Left (show l)
+    fcArgs <- forM args $ \arg -> do
+      reducedArg <- eval arg
+      case toPactValue reducedArg of
+        Left e -> error $ "TODO: " ++ show e
+        Right a -> return a
+    return $ FunctionCall { fcFunction = fcFunction , fcArgs }

src/Pact/Types/PactValue.hs

@@ -50,7 +50,7 @@ import Data.Aeson hiding (Value(..))
 import Data.Default (def)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Vector (Vector)
 import qualified Data.Vector as V
 import GHC.Generics hiding (Meta)
@@ -162,13 +162,14 @@ instance SizeOf PactValue where
 
 
 -- | Strict conversion.
-toPactValue :: Pretty n => Term n -> Either Text PactValue
+toPactValue :: (Show n, Pretty n) => Term n -> Either Text PactValue
 toPactValue (TLiteral l _) = pure $ PLiteral l
 toPactValue (TObject (Object o _ _ _) _) = PObject <$> traverse toPactValue o
 toPactValue (TList l _ _) = PList <$> V.mapM toPactValue l
 toPactValue (TGuard x _) = PGuard <$> traverse toPactValue x
 toPactValue (TModRef m _) = pure $ PModRef m
-toPactValue t = Left $ "Unable to convert Term: " <> renderCompactText t
+-- toPactValue t = Left $ "Unable to convert Term: " <> renderCompactText t
+toPactValue t = Left $ "Unable to convert Term: " <> pack (show t)
 
 fromPactValue :: PactValue -> Term Name
 fromPactValue (PLiteral l) = TLiteral l def

src/Pact/Types/Runtime.hs

@@ -35,7 +35,7 @@ module Pact.Types.Runtime
    Purity(..),
    RefState(..),rsLoaded,rsLoadedModules,rsNamespace,rsQualifiedDeps,
    EvalState(..),evalRefs,evalCallStack,evalPactExec,
-   evalCapabilities,evalLogGas,evalEvents,
+   evalCapabilities,evalLogGas,evalEvents,evalMemoTable,
    Eval(..),runEval,runEval',catchesPactError,
    call,method,
    readRow,writeRow,keys,txids,createUserTable,getUserTableInfo,beginTx,commitTx,rollbackTx,getTxLog,
@@ -88,6 +88,7 @@ import Pact.Types.Lang
 import Pact.Types.Orphans ()
 import Pact.Types.PactError
 import Pact.Types.PactValue
+import Pact.Types.Memoize (MemoTable)
 import Pact.Types.Advice
 import Pact.Types.Persistence
 import Pact.Types.Pretty
@@ -309,10 +310,12 @@ data EvalState = EvalState {
     , _evalLogGas :: Maybe [(Text,Gas)]
       -- | Accumulate events
     , _evalEvents :: ![PactEvent]
+      -- | Memo table entries
+    , _evalMemoTable :: !MemoTable
     } deriving (Show, Generic)
 makeLenses ''EvalState
 instance NFData EvalState
-instance Default EvalState where def = EvalState def def def def def def
+instance Default EvalState where def = EvalState def def def def def def def
 
 -- | Interpreter monad, parameterized over back-end MVar state type.
 newtype Eval e a =

tests/pact/memoize.repl

@@ -0,0 +1,34 @@
+(env-gasmodel "table")
+(env-gaslimit 1000000)
+
+(env-clear-memotable)
+
+; Define an expensive function, which we will use to test memoization.
+(module m g
+  (defcap g () true)
+  (defun go(n:integer) "Do an expensive computation"
+         (let ((xs (enumerate 1 n))
+               (fn (lambda (a b) (+ a b))))
+           (fold (fn) 0 xs)
+           )))
+
+; We will test memoization by checking that gas usage is lower
+; for a memo table hit than for a miss.
+(env-gas 0)
+(m.go 10)
+(expect "Executing unmemoized function costs gas" 36 (env-gas))
+
+(env-memoize (m.go 10))
+(env-gas 0)
+(m.go 10)
+(expect "Executing memoized function is cheap" 0 (env-gas))
+
+
+(env-gas 0)
+(shift 10 (shift 1 1))
+(expect "Executing unmemoized native costs gas" 3 (env-gas))
+
+(env-memoize (shift 10 (shift 1 1)))
+(env-gas 0)
+(shift 10 2)
+(expect "Executing memoized native is cheap" 0 (env-gas))