From 623e05a94fadb810480636a159a087f6d518fa5a Mon Sep 17 00:00:00 2001 From: aarne Date: Sun, 1 Oct 2006 15:41:32 +0000 Subject: [PATCH] gfcc compilation: know bugs fixed --- src/GF/Canon/CanonToGFCC.hs | 50 ++++++++++++-------------------- src/GF/Canon/GFCC/DataGFCC.hs | 9 +++--- src/GF/Compile/GrammarToCanon.hs | 15 +++++++--- 3 files changed, 35 insertions(+), 39 deletions(-) diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index 938c50621..da276bfe7 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/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 diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 09b0acbf5..8588d2f9b 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/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 { diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 089773824..e7da9281d 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/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