made compile from source use optimized modules internally

src/GF/Devel/Compile.hs

@@ -126,9 +126,15 @@ compileOne opts env@(_,srcgr) file = do
        sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ 
                                            getSourceModule opts file
        (k',sm)  <- compileSourceModule opts env sm0
-       cm  <- putpp "  generating code... " $ generateModuleCode opts path sm
+       let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str
+       cm  <- putpp "  generating code... " $ generateModuleCode opts path sm1
           -- sm is optimized before generation, but not in the env
-       extendCompileEnvInt env (k',sm)
+       let cm2 = unsubexpModule cm
+       extendCompileEnvInt env (k',sm1)
+  where
+   isConcr (_,mi) = case mi of
+     ModMod m -> isModCnc m && mstatus m /= MSIncomplete 
+     _ -> False
 
 
 compileSourceModule :: Options -> CompileEnv -> 
@@ -174,7 +180,7 @@ generateModuleCode opts path minfo@(name,info) = do
 
   let pname  = prefixPathName path (prt name)
   let minfo0 = minfo 
-  let minfo1 = (if isConcr info then optModule else id) minfo
+  let minfo1 = subexpModule minfo0
   let minfo2 = minfo1
 
   let (file,out) = (gfoFile pname, prGrammar (MGrammar [minfo2]))
@@ -184,9 +190,6 @@ generateModuleCode opts path minfo@(name,info) = do
  where 
    putp  = putPointE opts
    putpp = putPointEsil opts
-   isConcr mi = case mi of
-     ModMod m -> isModCnc m && mstatus m /= MSIncomplete 
-     _ -> False
 
 
 -- auxiliaries

src/GF/Devel/GrammarToGFCC.hs

@@ -319,12 +319,12 @@ paramValues cgr = (labels,untyps,typs) where
  
   typsFromTrm :: Term -> STM [Type] Term
   typsFromTrm tr = case tr of
-    V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
     R fs -> mapM_ (typsFromField . snd) fs >> return tr 
       where
         typsFromField (mty, t) = case mty of
           Just x -> updateSTM (x:) >> typsFromTrm t
           _ -> typsFromTrm t
+    V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
     T (TTyped ty) cs -> 
       updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
     T (TComp ty) cs -> 
@@ -396,14 +396,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
    --- this is mainly needed for parameter record projections
    ---- was: errVal t $ Compute.computeConcreteRec cgr t
    comp t = case t of
-     T (TComp typ) ts  -> comp $ V typ (map (comp . snd) ts)  ---- should
+     T (TComp typ) ts  -> comp $ V typ (map (comp . snd) ts)  ---- should...
-     T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
+     T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts)  ---- should
      V typ ts -> V typ (map comp ts)
      S (V typ ts) v0 -> err error id $ do
        let v = comp v0 
-       vs <- Look.allParamValues cgr typ
+       return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps
-       return $ maybe t ---- (error (prt t)) -- should be safe after doVar though
-                      (comp . (ts !!)) $ lookup v (zip vs [0 .. length vs - 1])
      R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
      P (R r) l -> maybe t (comp . snd) $ lookup l r
      _ -> GM.composSafeOp comp t
@@ -437,6 +435,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      Vr (IA (cat, _)) -> return (identC cat,[])
      Vr (IC s) -> return (identC cat,[]) where
        cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
+----     Vr _ -> error $ "getLab " ++ show tr
      P p lab2 -> do
        (cat,labs) <- getLab p
        return (cat,labs++[lab2]) 
@@ -450,15 +449,15 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      _ | tr == x -> t
      _ -> GM.composSafeOp (mkBranch x t) tr     
 
-   valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
+   valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
     where
-      tryPerm tr = valNumFV $ tryVar tr
+      tryFV tr = case GM.appForm tr of
-      tryVar tr = case GM.appForm tr of
+        (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
-        (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryVar ts)]
         (FV ts,_) -> ts
         _ -> [tr]
       valNumFV ts = case ts of
-        [tr] -> prtTrace tr $ K "66667"
+        [tr] -> trace (unwords (map prt (Map.keys typs))) $ 
+                  prtTrace tr $ K "66667"
         _ -> FV $ map valNum ts
 
    mkCurry trm = case trm of

src/GF/Devel/OptimizeGF.hs

@@ -16,7 +16,8 @@
 -----------------------------------------------------------------------------
 
 module GF.Devel.OptimizeGF (
-  optModule,unshareModule,unsubexpModule,unoptModule) where 
+  optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule
+  ) where 
 
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup
@@ -32,7 +33,9 @@ import qualified Data.Map as Map
 import Data.List
 
 optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
-optModule = subexpModule . processModule optim
+optModule = subexpModule . shareModule
+
+shareModule = processModule optim
 
 unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
 unoptModule gr = unshareModule gr . unsubexpModule

src/GF/Grammar/Lookup.hs

@@ -194,6 +194,7 @@ allParamValues cnc ptyp = case ptyp of
      App (Q (IC "Predef") (IC "Ints")) (EInt n) -> 
        return [EInt i | i <- [0..n]]
      QC p c -> lookupParamValues cnc p c
+     Q  p c -> lookupParamValues cnc p c ----
      RecType r -> do
        let (ls,tys) = unzip $ sortByFst r
        tss <- mapM allPV tys