From 050d435278d3a4dec32ef7c00458fa674aba5a42 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Tue, 17 Jun 2014 14:47:55 +0000
Subject: [PATCH] Compute/ConcreteNew.hs: eliminate selections from wildcard
 tables

This patch also includes some commented out code that was used to search for
the source of code size explosions and an eta expansion bug.
---
 .../GF/Compile/Compute/ConcreteNew.hs         |  1 +
 src/compiler/GF/Compile/GeneratePMCFG.hs      | 26 ++++++++++++++-----
 2 files changed, 21 insertions(+), 6 deletions(-)

diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index 181d48830..7c471f1cc 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -298,6 +298,7 @@ select env vv =
             --let vs = map (value0 env) ats
             i <- maybeErr "no match" $ findIndex (==v2) vs
             return (ix (gloc env) "select" rs i)
+      (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
       (v1@(VT _ _ cs),v2) ->
                  err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
                  match (gloc env) cs v2
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index fb51f9be9..9bd7c176f 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -39,6 +39,7 @@ import Data.Array.Unboxed
 import Control.Monad
 import Control.Monad.Identity
 --import Control.Exception
+--import Debug.Trace(trace)
 
 ----------------------------------------------------------------------
 -- main conversion function
@@ -67,6 +68,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
 
 addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
 addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
   let pres  = protoFCat gr res val
       pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
 
@@ -85,7 +87,8 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
                        !funs_cnt        = e-s+1
                    in (prods_cnt,funs_cnt)
 
-  when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
+  when (verbAtLeast opts Verbose) $
+    ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
   seqs1 `seq` stats `seq` return ()
   when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
   return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
@@ -146,12 +149,19 @@ floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
 convert opts gr cenv loc term ty@(_,val) pargs =
     case term' of
       Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s)
-      _ -> return $ runCnvMonad gr (conv term') (pargs,[])
+      _ -> do {-when (verbAtLeast opts Verbose) $
+                ePutStrLn $
+                  "\n"++take 10000 (renderStyle style{mode=OneLineMode}
+                    (text "term:"<+>ppU 0 term $$
+                     text "eta expanded:"<+>ppU 0 eterm $$
+                     text "normalized:"<+>ppU 0 term'))--}
+              return $ runCnvMonad gr (conv term') (pargs,[])
   where
     conv t = convertTerm opts CNil val =<< unfactor t
 
+    eterm = expand ty term
     term' = {-if flag optNewComp opts
-            then-} normalForm cenv loc (expand ty term) -- new evaluator
+            then-} normalForm cenv loc eterm -- new evaluator
             --else term -- old evaluator is invoked from GF.Compile.Optimize
 
 expand (context,val) = mkAbs pars . recordExpand val . flip mkApp args
@@ -175,12 +185,16 @@ recordExpand typ trm =
 unfactor :: Term -> CnvMonad Term
 unfactor t = CM (\gr c -> c (unfac gr t))
   where
-    unfac gr t = 
+    unfac gr t =
       case t of
         T (TTyped ty) [(PV x,u)] -> let u' = unfac gr u
-                                    in V ty [restore x v u' | v <- allparams ty]
+                                        vs = allparams ty
+                                    in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render (ppU 0 t)) $
+                                       V ty [restore x v u' | v <- vs]
         T (TTyped ty) [(PW  ,u)] -> let u' = unfac gr u
-                                    in V ty [u' | _ <- allparams ty]
+                                        vs = allparams ty
+                                    in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render (ppU 0 t)) $
+                                       V ty [u' | _ <- vs]
         T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
                            ppbug $
                            sep [text "unfactor"<+>ppU 10 t,