More work on the new partial evaluator

The work done by the partial evaluator is now divied in two stages:
 - A static "term traversal" stage that happens only once per term and uses
   only statically known information. In particular, the values of lambda bound
   variables are unknown during this stage. Some tables are transformed to
   reduce the cost of pattern matching.
 - A dynamic "function application" stage, where function bodies can be
   evaluated repeatedly with different arguments, without the term traversal
   overhead and without recomputing statically known information.

Also the treatment of predefined functions has been reworked to take advantage
of the staging and better handle partial applications.

1 files changed, 113 insertions, 64 deletions

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index e6fd6af7c..f37fd989f 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -1,93 +1,142 @@
 -- | Implementations of predefined functions
-module GF.Compile.Compute.Predef where
+{-# LANGUAGE FlexibleInstances #-}
+module GF.Compile.Compute.Predef(predef,predefName,delta) where
 
 import Text.PrettyPrint(render,hang,text)
 import qualified Data.Map as Map
+import Data.Array(array,(!))
 import Data.List (isInfixOf)
 import Data.Char (isUpper,toLower,toUpper)
+import Control.Monad(ap)
 
 import GF.Data.Utilities (mapSnd,apBoth)
 
 import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident,varX)
+import GF.Infra.Ident (Ident,varX,showIdent)
+import GF.Data.Operations(Err,err)
 import GF.Grammar.Predef
 import PGF.Data(BindType(..))
 
-predefs :: Map.Map Ident ([Value]->Value)
-predefs = Map.fromList $ mapSnd strictf
-    [(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp),
-     (cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs),
-     (cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)),
-     (cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)),
-     (cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)),
-     (cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl),
-     (cEqVal,unimpl),(cError,apSS' VError)]
-    --- add more functions!!!
+--------------------------------------------------------------------------------
+class Predef a where
+  toValue :: a -> Value
+  fromValue :: Value -> Err a
+
+instance Predef Int where
+  toValue = VInt
+  fromValue (VInt i) = return i
+  fromValue v = verror "Int" v
+
+instance Predef Bool where
+  toValue = boolV
+
+instance Predef String where
+  toValue = string
+  fromValue v = case norm v of
+                  VString s -> return s
+                  _ -> verror "String" v
+
+instance Predef Value where
+  toValue = id
+  fromValue = return
+{-
+instance (Predef a,Predef b) => Predef (a->b) where
+  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
+-}
+verror t v =
+  case v of
+    VError e -> fail e
+    VGen {}  -> fail $ "Expected a static value of type "++t
+                       ++", got a dynamic value"
+    _ -> fail $ "Expected a value of type "++t++", got "++show v
+
+--------------------------------------------------------------------------------
+
+predef f = maybe undef return (Map.lookup f predefs)
   where
-    unimpl = bug "unimplemented predefined function"
-
-    tk i s = take (max 0 (length s - i)) s
-    dp i s = drop (max 0 (length s - i)) s
-    occur s t = isInfixOf s t
-    occurs s t = any (`elem` t) s
-
-    apIII f vs = case vs of
-                   [VInt i1, VInt i2] -> VInt (f i1 i2)
-                   _ -> bug $ "f::Int->Int->Int got "++show vs
-
-    apIIB f vs = case vs of
-                   [VInt i1, VInt i2] -> boolV (f i1 i2)
-                   _ -> bug $ "f::Int->Int->Bool got "++show vs
-
-    apISS f vs = case vs of
-                   [VInt i, VString s] -> string (f i s)
-                   [VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v ->
-                               case norm v of
-                                 VString s -> string (f i s)
-                                 _ -> bug $ "f::Int->Str->Str got "++show (vs++[v])
-                   _ -> bug $ "f::Int->Str->Str got "++show vs
-
-    apSSB f vs = case vs of
-                   [VString s1, VString s2] -> boolV (f s1 s2)
-                   _ -> bug $ "f::Str->Str->Bool got "++show vs
+    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
+
+predefs :: Map.Map Ident Predefined
+predefs = Map.fromList predefList
+
+predefName pre = predefNames ! pre
+predefNames = array (minBound,maxBound) (map swap predefList)
+
+predefList =
+    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
+     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
+     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
+     (cLessInt,LessInt),
+     -- cShow, cRead, cMapStr, cEqVal
+     (cError,Error),
+     -- Canonical values:
+     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInts,Ints)]
+    --- add more functions!!!
 
-    apSB  f vs = case vs of
-                   [VString s] -> boolV (f s)
-                   _ -> bug $ "f::Str->Bool got "++show vs
+delta f vs =
+    case f of
+      Drop    -> ap2 (drop::Int->String->String)
+      Take    -> ap2 (take::Int->String->String)
+      Tk      -> ap2 tk
+      Dp      -> ap2 dp
+      EqStr   -> ap2 ((==)::String->String->Bool)
+      Occur   -> ap2 occur
+      Occurs  -> ap2 occurs
+      ToUpper -> ap1 (map toUpper)
+      ToLower -> ap1 (map toLower)
+      IsUpper -> ap1 (all isUpper)
+      Length  -> ap1 (length::String->Int)
+      Plus    -> ap2 ((+)::Int->Int->Int)
+      EqInt   -> ap2 ((==)::Int->Int->Bool)
+      LessInt -> ap2 ((<)::Int->Int->Bool)
+    {- | Show | Read | ToStr | MapStr | EqVal -}
+      Error   -> ap1 VError
+      -- Canonical values:
+      PBool   -> canonical
+      Ints    -> canonical
+      PFalse  -> canonical
+      PTrue   -> canonical
+  where
+    canonical = delay
+    delay = return (VApp f vs) -- wrong number of arguments
 
-    apSS  f vs = case vs of
-                   [VString s] -> string (f s)
-                   _ -> bug $ "f::Str->Str got "++show vs
+    ap1 f = case vs of
+              [v1] -> (toValue . f) `fmap` fromValue v1
+              _ -> delay
 
-    apSS' f vs = case vs of
-                   [VString s] -> f s
-                   _ -> bug $ "f::Str->_ got "++show vs
+    ap2 f = case vs of
+             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
+             _ -> delay
 
-    boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
+    unimpl id = bug $ "unimplemented predefined function: "++showIdent id
+--  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
 
-    strictf f vs = case normvs vs of
-                     Left err -> VError err
-                     Right vs -> f vs
+    tk i s = take (max 0 (length s - i)) s :: String
+    dp i s = drop (max 0 (length s - i)) s :: String
+    occur s t = isInfixOf (s::String) t
+    occurs s t = any (`elem` t) (s::String)
 
-    normvs = mapM (strict . norm)
+boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
 
-    norm v =
-      case v of
-        VC v1 v2 -> case apBoth norm (v1,v2) of
-                      (VString s1,VString s2) -> VString (s1++" "++s2)
-                      (v1,v2) -> VC v1 v2
-        _ -> v
+norm v =
+  case v of
+    VC v1 v2 -> case apBoth norm (v1,v2) of
+                  (VString s1,VString s2) -> VString (s1++" "++s2)
+                  (v1,v2) -> VC v1 v2
+    _ -> v
 
-    strict v = case v of
-                 VError err -> Left err
-                 _ -> Right v
+strict v = case v of
+             VError err -> Left err
+             _ -> Right v
 
-    string s = case words s of
-                 [] -> VString ""
-                 ss -> foldr1 VC (map VString ss)
+string s = case words s of
+             [] -> VString ""
+             ss -> foldr1 VC (map VString ss)
 
 ---
 
+swap (x,y) = (y,x)
+
 bug msg = ppbug (text msg)
 ppbug doc = error $ render $
                     hang (text "Internal error in Compute.Predef:") 4 doc