gfcc compilation: know bugs fixed

src/GF/Canon/CanonToGFCC.hs

@@ -176,7 +176,7 @@ paramValues cgr = (labels,untyps,typs) where
             ]
   typsFrom ty = case ty of
     Table p t  -> typsFrom p ++ typsFrom t
-    RecType ls -> ty : concat [typsFrom t | Lbg _ t <- ls]
+    RecType ls -> RecType ls : concat [typsFrom t | Lbg _ t <- ls]
     _ -> [ty]
  
   typsFromTrm :: Term -> STM [CType] Term
@@ -210,11 +210,11 @@ term2term :: CanonGrammar -> ParamEnv -> Term -> Term
 term2term cgr env@(labels,untyps,typs) tr = case tr of
   Par _ _ -> mkValCase tr 
   R rs ->
-    let 
+    let
       rs' = [Ass (mkLab i) (t2t t) | 
-               (i,Ass l t) <- zip [0..] rs, not (isLock l t)]
+               (i,Ass l t) <- zip [0..] rs] ---- , not (isLock l t)]
     in if (any (isStr . trmAss) rs)
-      then trace (A.prt tr) $ R rs'
+      then R rs'
       else R [Ass (L (IC "_")) (mkValCase tr), Ass (L (IC "__")) (R rs')]
   P t l    -> r2r tr
   T _ cs0  -> checkCases cs0 $
@@ -261,19 +261,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
                _ -> error $ A.prt ty
              _ -> error $ A.prt tr
        updateSTM ((tyvs, (tr', tr)):) 
-
-{-
-       case Map.lookup (cat,lab) labels of
-         Just (ty,_) -> case Map.lookup ty typs of
-           Just vs -> do
-             let tyvs = (ty,[t | 
-                            (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) 
-                                            (Map.assocs vs)])
-             updateSTM ((tyvs, (tr', tr)):) 
-           _ -> return ()
-         _ -> return ()
--}
-
        return tr'
      _ -> composOp doVar tr
 
@@ -288,15 +275,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      _ -> composSafeOp (mkBranch x t) tr     
 
    mkLab k = L (IC ("_" ++ show k))
+
    valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
-    --- a hack needed because GFCC does not guarantee 
-    --- canonical order of param records
-    --- complexity could be lowered by sorting the records
     where
       tryPerm tr = case tr of
-        R rs -> case [v | Just v <- 
-                       [Map.lookup (R rs') untyps | rs' <- permutations rs]] of
-	  v:_ -> EInt v
+        R rs -> case Map.lookup (R rs) untyps of
+	  Just v -> EInt v
           _ -> valNumFV $ tryVar tr
         _ -> valNumFV $ tryVar tr
       tryVar tr = case tr of
@@ -306,9 +290,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
       valNumFV ts = case ts of
         [tr] -> K (KS (A.prt tr +++ prtTrace tr "66667"))
         _ -> FV $ map valNum ts
-      permutations xx = case xx of
-        [] -> [[]]
-        _  -> [x:xs | x <- xx, xs <- permutations (xx \\ [x])]
    isStr tr = case tr of
      Par _ _ -> False
      EInt _  -> False
@@ -330,14 +311,19 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      RecType ts -> any isStrType [t | Lbg _ t <- ts]
      Table _ t -> isStrType t
      _ -> False
-   isLock l t = case t of --- need not look at l
-     R [] -> True
-     _ -> False
    trmAss (Ass _ t) = t
 
    --- this is mainly needed for parameter record projections
    comp t = errVal t $ Look.ccompute cgr [] t
 
+-- remove lock fields; currently not done
+isLock l t = case t of --- need not look at l
+     R [] -> True
+     _ -> False
+isLockTyp l t = case t of --- need not look at l
+     RecType [] -> True
+     _ -> False
+
 
 
 prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
@@ -398,6 +384,7 @@ addSubexpConsts tree lins =
        C.S ts  -> C.S $ map (recomp f) ts
        C.W s t -> C.W s (recomp f t)
        C.P t p -> C.P (recomp f t) (recomp f p)
+       C.RP t p -> C.RP (recomp f t) (recomp f p)
 --       C.A x t -> C.A x (recomp f t)
        _ -> t
    fid n = C.CId $ "_" ++ show n
@@ -418,11 +405,12 @@ collectSubterms t = case t of
   C.R ts -> do
     mapM collectSubterms ts
     add t
+  C.RP u v -> do
+    collectSubterms v
+    add t
   C.S ts -> do
     mapM collectSubterms ts
     add t
---  C.A x b -> do
---    collectSubterms b -- t itself can only occur once in a grammar
   C.W s u -> do
     collectSubterms u
     add t

src/GF/Canon/GFCC/DataGFCC.hs

@@ -97,20 +97,21 @@ compute mcfg lang args = comp where
   look = lookLin mcfg lang
   idx xs i = 
       if length xs <= i  ---- debug
-      then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
-      xs !! i 
+      then trace ("ERROR in compiler producing " ++ show xs ++ " !! " ++ show i)
+                 (last xs)
+      else xs !! i 
 
   getIndex t0 t =  case t of
       C i -> fromInteger i
       RP p _ -> getIndex t0 $ p
-      _ -> error $ "compiler error: index from " ++ show t
+      _ -> trace ("ERROR in compiler: index from " ++ show t) 0
       ---- TODO: this is workaround for a compiler bug
       -- R (u : _) -> trace (show t ++ " IN\n" ++ show t0) $ getIndex t0 u
 
   getFields t = case t of
       R rs -> rs
       RP _ r -> getFields r
-      _ -> error $ "compiler error: fields from " ++ show t
+      _ -> trace ("ERROR in compiler: fields from " ++ show t) [t]
 
 mkGFCC :: Grammar -> GFCC
 mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {

src/GF/Compile/GrammarToCanon.hs

@@ -31,7 +31,7 @@ import GF.Canon.MkGFC
 import qualified GF.Canon.PrintGFC as P
 
 import Control.Monad
-import Data.List (nub)
+import Data.List (nub,sortBy)
 
 -- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
 
@@ -155,6 +155,13 @@ redType = redTerm
 redTerm :: Type -> Err G.Exp
 redTerm t = return $ rtExp t
 
+-- to normalize records and record types
+sortByLabel :: (a -> Label) -> [a] -> [a]
+sortByLabel f = sortBy (\ x y -> compare (f x) (f y))
+
+sortByFst :: Ord a => [(a,b)] -> [(a,b)]
+sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
 -- resource
 
 redParam :: Param -> Err G.ParDef
@@ -180,7 +187,7 @@ redCType t = case t of
     let (ls,ts) = unzip lbs
         ls' = map redLabel ls
     ts' <- mapM redCType ts
-    return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts'
+    return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
   Table p v  -> liftM2 G.Table (redCType p) (redCType v)
   Q m c    -> liftM G.Cn $ redQIdent (m,c)
   QC m c   -> liftM G.Cn $ redQIdent (m,c)
@@ -208,7 +215,7 @@ redCTerm t = case t of
     let (ls,tts) = unzip rs
         ls' = map redLabel ls
     ts <- mapM (redCTerm . snd) tts
-    return $ G.R $ map (uncurry G.Ass) $ zip ls' ts
+    return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
   RecType [] -> return $ G.R [] --- comes out in parsing
   P tr l -> do
     tr' <- redCTerm tr
@@ -260,7 +267,7 @@ redPatt p = case p of
     let (ls,tts) = unzip rs
         ls' = map redLabel ls
     ts <- mapM redPatt tts
-    return $ G.PR $  map (uncurry G.PAss) $ zip ls' ts
+    return $ G.PR $  map (uncurry G.PAss) $ sortByFst $ zip ls' ts
   PT _ q -> redPatt q
   PInt i -> return $ G.PI i
   PFloat i -> return $ G.PF i