From 333cf5e0e6c67600fad5ce3154afbc579ed32595 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Fri, 8 Jun 2007 12:50:01 +0000
Subject: [PATCH] pattern matching optimization; trace of fun in compilation
 with -v

---
 src/GF/Compile/Optimize.hs     | 15 +++++++++++++--
 src/GF/Grammar/Compute.hs      | 32 +++++++++++++++++---------------
 src/GF/Grammar/PatternMatch.hs | 12 ++++++++----
 3 files changed, 38 insertions(+), 21 deletions(-)

diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index 61e1615f0..a540ee715 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -34,6 +34,14 @@ import GF.Infra.Option
 import Control.Monad
 import Data.List
 
+import Debug.Trace
+
+
+-- conditional trace
+
+prtIf :: (Print a) => Bool -> a -> a
+prtIf b t = if b then trace (" " ++ prt t) t else t
+
 -- experimental evaluation, option to import
 oEval = iOpt "eval"
 
@@ -113,10 +121,13 @@ evalResInfo oopts gr (c,info) = case info of
 
 evalCncInfo :: 
   Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
-evalCncInfo opts gr cnc abs (c,info) = errIn ("optimizing" +++ prt c) $ case info of
+evalCncInfo opts gr cnc abs (c,info) = do
+
+ seq (prtIf (oElem beVerbose opts) c) $ return ()
+
+ errIn ("optimizing" +++ prt c) $ case info of
 
   CncCat ptyp pde ppr -> do
-
     pde' <- case (ptyp,pde) of
       (Yes typ, Yes de) -> 
         liftM yes $ pEval ([(strVar, typeStr)], typ) de
diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index 24f475f03..d9bd70301 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -141,9 +141,11 @@ computeTermOpt rec gr = comp where
              return $ S t' v' -- if v' is not canonical
 
      S t v -> do
-       t'     <- comp g t
-       v'     <- comp g v
-       case t' of
+      t'     <- comp g t
+      v'     <- comp g v
+      case v' of
+       FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants        
+       _ -> case t' of
          FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
 
          T _ [(PV IW,c)] -> comp g c           --- an optimization
@@ -152,21 +154,21 @@ computeTermOpt rec gr = comp where
          T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
          T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
 
-
+         -- course-of-values table: look up by index, no pattern matching needed
          V ptyp ts -> do
            vs <- allParamValues gr ptyp
-           ps <- mapM term2patt vs
-           let cc = zip ps ts
-           case v' of
-             FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-             _ -> case matchPattern cc v' of
-               Ok (c,g') -> comp (g' ++ g) c
-               _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
-               _ -> return $ S t' v' -- if v' is not canonical
+           case lookup v' (zip vs [0 .. length vs - 1]) of
+             Just i -> comp g $ ts !! i
+             _ -> return $ S t' v' -- if v' is not canonical
 
-         T _ cc -> case v' of
-	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-           _ -> case matchPattern cc v' of
+         T (TComp _) cs -> do
+           case term2patt v' of
+             Ok p' -> case lookup p' cs of
+               Just u -> comp g u
+               _ -> return $ S t' v' -- if v' is not canonical
+             _ -> return $ S t' v'
+
+         T _ cc -> case matchPattern cc v' of
              Ok (c,g') -> comp (g' ++ g) c
              _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
              _ -> return $ S t' v' -- if v' is not canonical
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 804333b14..881f10198 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -29,8 +29,11 @@ import Control.Monad
 
 matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
 matchPattern pts term = 
-  errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
-  findMatch [([p],t) | (p,t) <- pts] [term]
+  if not (isInConstantForm term)
+    then prtBad "variables occur in" term
+  else 
+    errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
+    findMatch [([p],t) | (p,t) <- pts] [term]
 
 testOvershadow :: [Patt] -> [Term] -> Err [Patt]
 testOvershadow pts vs = do
@@ -54,14 +57,15 @@ tryMatch (p,t) = do
   t' <- termForm t
   trym p t'
  where
+  isInConstantFormt = True -- tested already
   trym p t' =
     case (p,t') of
       (PVal _ i, (_,Val _ j,_)) 
           | i == j -> return []
           | otherwise -> Bad $ "no match of values"
       (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
-      (PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard
-      (PV x,  _) | isInConstantForm t -> return [(x,t)]
+      (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
+      (PV x,  _) | isInConstantFormt -> return [(x,t)]
       (PString s, ([],K i,[])) | s==i -> return []
       (PInt s, ([],EInt i,[])) | s==i -> return []
       (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?