diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index d78d49b09..cf07fdb65 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -39,7 +39,7 @@ import GF.Compile.CheckGrammar import GF.Compile.Optimize import GF.Compile.Evaluate import GF.Compile.GrammarToCanon -import GF.Compile.GrammarToGFCC ----- +--import GF.Devel.GrammarToGFCC ----- import GF.Canon.Share import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) import GF.UseGrammar.Linear (unoptimizeCanonMod) ---- @@ -300,9 +300,10 @@ compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule generateModuleCode opts path minfo@(name,info) = do - if oElem (iOpt "gfcc") opts - then ioeIO $ putStrLn $ prGrammar2gfcc minfo - else return () +--- DEPREC +--- if oElem (iOpt "gfcc") opts +--- then ioeIO $ putStrLn $ prGrammar2gfcc minfo +--- else return () let pname = prefixPathName path (prt name) minfo0 <- ioeErr $ redModInfo minfo diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs deleted file mode 100644 index e1374bad1..000000000 --- a/src/GF/Compile/GrammarToGFCC.hs +++ /dev/null @@ -1,489 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CanonToGFCC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:17 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.15 $ --- --- GFC to GFCC compiler. AR Aug-Oct 2006 ------------------------------------------------------------------------------ - -module GF.Compile.GrammarToGFCC (prGrammar2gfcc) where - -import GF.Grammar.Grammar -import qualified GF.Canon.GFC as GFC -import qualified GF.Grammar.Lookup as Look - -import qualified GF.Canon.GFCC.AbsGFCC as C -import qualified GF.Canon.GFCC.PrintGFCC as Pr -import qualified GF.Grammar.Abstract as A -import qualified GF.Grammar.Macros as GM -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O - -import GF.Infra.Ident -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List -import qualified Data.Map as Map -import Debug.Trace ---- - --- the main function: generate GFCC from GFCM. - -prGrammar2gfcc :: SourceModule -> String -prGrammar2gfcc = Pr.printTree . mkCanon2gfcc - -mkCanon2gfcc :: SourceModule -> C.Grammar -mkCanon2gfcc = canon2gfcc . {- reorder . utf8Conv .-} canon2canon - --- This is needed to reorganize the grammar. GFCC has its own back-end optimization. --- But we need to have the canonical order in tables, created by valOpt - --- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: SourceModule -> C.Grammar -canon2gfcc cgr@(a,M.ModMod abm) = - C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where - cs = [i2i a] ---- - adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | - (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] - cncs = [C.Cnc (i2i a) (concr abm)] - concr mo = cats mo ++ lindefs mo ++ - -----optConcrete - [C.Lin (i2i f) (mkTerm tr) | - (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)] - cats mo = [C.Lin (i2ic c) (mkCType ty) | - (c,CncCat (Yes ty) _ _) <- tree2list (M.jments mo)] - lindefs mo = [C.Lin (i2id c) (mkTerm tr) | - (c,CncCat _ (Yes tr) _) <- tree2list (M.jments mo)] - -i2i :: Ident -> C.CId -i2i (IC c) = C.CId c -i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols -i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols - -mkType :: A.Type -> C.Type -mkType t = case GM.catSkeleton t of - Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c) - -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - -- record parameter alias - created in gfc preprocessing - RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t) - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt - _ -> C.S [] ----- TStr - where - getI pt = case pt of - C.C i -> i - C.RP i _ -> getI i - _ -> 1 ----- - -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA (_,i)) -> C.V i - EInt i -> C.C $ fromInteger i - -- record parameter alias - created in gfc preprocessing - R [(LIdent "_", (_,i)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t) - -- ordinary record - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - ------ LI x -> C.BV $ i2i x ------ T _ [(PV x, t)] -> C.L (i2i x) (mkTerm t) - - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ t -> mkTerm t ---- only on toplevel - _ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging - where - mkLab (LIdent l) = case l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - --- return just one module per language - -reorder :: SourceGrammar -> SourceGrammar -reorder cg = M.MGrammar $ - (abs, M.ModMod $ - M.Module M.MTAbstract M.MSComplete [] [] [] adefs): - [(c, M.ModMod $ - M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) - | (c,js) <- cncs] - where - abs = maybe (error "no abstract") id $ M.greatestAbstract cg - mos = M.allModMod cg - adefs = - sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g) - [finfo | - (i,mo) <- M.allModMod cg, M.isModAbs mo, - finfo <- tree2list (M.jments mo)] - cncs = sortBy (\ (x,_) (y,_) -> compare x y) - [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = sortBy (\ (f,_) (g,_) -> compare f g) - [finfo | - (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la), - finfo <- tree2list (M.jments mo)] - --- one grammar per language - needed for symtab generation -repartition :: SourceGrammar -> [SourceGrammar] -repartition cg = [M.partOfGrammar cg (lang,mo) | - let abs = maybe (error "no abstract") id $ M.greatestAbstract cg, - let mos = M.allModMod cg, - lang <- M.allConcretes cg abs, - let mo = errVal - (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang - ] - --- convert to UTF8 if not yet converted -utf8Conv :: SourceGrammar -> SourceGrammar -utf8Conv = M.MGrammar . map toUTF8 . M.modules where - toUTF8 mo = case mo of - (i, M.ModMod m) - ----- | hasFlagCanon (flagCanon "coding" "utf8") mo -> mo - | otherwise -> (i, M.ModMod $ - m{ M.jments = M.jments m ----- ------ mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m), - ----- M.flags = setFlag "coding" "utf8" (M.flags m) - } - ) - _ -> mo - - --- translate tables and records to arrays, parameters and labels to indices - ------canon2canon :: SourceGrammar -> SourceGrammar -canon2canon :: SourceModule -> SourceModule -canon2canon sm = c2c sm where - cg = M.MGrammar [sm] ------canon2canon = recollect . map cl2cl . repartition where ------ recollect = ------ M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules ------ cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where - c2c (c,m) = case m of - M.ModMod mo@(M.Module _ _ _ _ _ js) -> - (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js) - _ -> (c,m) - j2j (f,j) = case j of - CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z) - CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y) - _ -> (f,j) - t2t = term2term cg pv - ty2ty = type2type cg pv - pv@(labels,untyps,typs) = paramValues cg - tr = trace $ - (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++ - (unlines [A.prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++ - (unlines [A.prt t | - (t,_) <- Map.toList typs]) - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and in lin terms -paramValues :: SourceGrammar -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] - partyps = nub $ [ty | - (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments, - ty0 <- [ty | (_, ty) <- unlockTyp ls], - ty <- typsFrom ty0 - ] ++ [ - Q m ty | - (m,(ty,ResParam _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Yes tr) _)) <- jments, - ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] - ] - typsFrom ty = case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls] - _ -> [ty] - - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - - jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo] - typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++ - [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] - Table _ t -> getRec t - _ -> [] - -type2type :: SourceGrammar -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - let - rs' = [(mkLab i, t2t t) | - (i,(l, t)) <- zip [0..] (unlockTyp rs)] - in if (any isStrType [t | (_, t) <- rs]) - then RecType rs' - else RecType [(LIdent "_", look ty), (LIdent "__", RecType rs')] - - Table pt vt -> Table (t2t pt) (t2t vt) - Cn _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 1 ---- 66669 - -term2term :: SourceGrammar -> ParamEnv -> Term -> Term -term2term cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase tr - QC _ _ -> mkValCase tr - R rs -> - let - rs' = [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (unlock rs)] - in if (any (isStr . trmAss) rs) - then R rs' - else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))] - P t l -> r2r tr - PI t l i -> EInt $ toInteger i - ------ T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)] - - T (TTyped ty) cs -> V ty [t2t t | (_, t) <- cs] - ---- _ -> K (KS (A.prt tr +++ prtTrace tr "66668")) - V ty ts -> V ty [t2t t | t <- ts] - S t p -> S (t2t t) (t2t p) - _ -> GM.composSafeOp t2t tr - where - t2t = term2term cgr env - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K ((A.prt tr +++ prtTrace tr "66665")) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA (cat, _)) -> return (identC cat,[]) - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ show k ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ A.prt ty - _ -> error $ A.prt tr - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum tr - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps - where - tryPerm tr = case tr of - R rs -> case Map.lookup (R rs) untyps of - Just v -> EInt v - _ -> valNumFV $ tryVar tr - _ -> valNumFV $ tryVar tr - tryVar tr = case tr of ------ Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)] - FV ts -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667")) - _ -> FV $ map valNum ts - isStr tr = case tr of - App _ _ -> False - EInt _ -> False - R rs -> any (isStr . trmAss) rs - FV ts -> any isStr ts - S t _ -> isStr t - Empty -> True - T _ cs -> any isStr [v | (_, v) <- cs] - V _ ts -> any isStr ts - P t r -> case getLab tr of - Ok (cat,labs) -> case - Map.lookup (cat,labs) labels of - Just (ty,_) -> isStrType ty - _ -> True ---- TODO? - _ -> True - _ -> True ---- - trmAss (_,(_, t)) = t - - --- this is mainly needed for parameter record projections - comp t = t ----- $ Look.ccompute cgr [] t - -isStrType ty = case ty of - Sort "Str" -> True - RecType ts -> any isStrType [t | (_, t) <- ts] - Table _ t -> isStrType t - _ -> False - -mkLab k = LIdent (("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - _ -> True -unlockTyp = filter notlock where - notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - - -prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n -prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n - --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optConcrete :: [C.CncDef] -> [C.CncDef] -optConcrete defs = subex - [C.Lin f (optTerm t) | C.Lin f t <- defs] - --- analyse word form lists into prefix + suffixes --- suffix sets can later be shared by subex elim - -optTerm :: C.Term -> C.Term -optTerm tr = case tr of - C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts] - C.R ts -> C.R $ map optTerm ts - C.P t v -> C.P (optTerm t) v - C.L x t -> C.L x (optTerm t) - _ -> tr - where - optToks ss = prf : suffs where - prf = pref (head ss) (tail ss) - suffs = map (drop (length prf)) ss - pref cand ss = case ss of - s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss - _ -> cand - isK t = case t of - C.K (C.KS _) -> True - _ -> False - mkSuff ("":ws) = C.R (map (C.K . C.KS) ws) - mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws)) - - --- common subexpression elimination; see ./Subexpression.hs for the idea - -subex :: [C.CncDef] -> [C.CncDef] -subex js = errVal js $ do - (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0) - return $ addSubexpConsts tree js - -type TermList = Map.Map C.Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef] -addSubexpConsts tree lins = - let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g) - [C.Lin (fid id) trm | (trm,(_,id)) <- list] - in map mkOne $ opers ++ lins - where - mkOne (C.Lin f trm) = (C.Lin f (recomp f trm)) - recomp f t = case Map.lookup t tree of - Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself - _ -> case t of - C.R ts -> C.R $ map (recomp f) ts - 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.L x t -> C.L x (recomp f t) - _ -> t - fid n = C.CId $ "_" ++ show n - list = Map.toList tree - -getSubtermsMod :: [C.CncDef] -> TermM TermList -getSubtermsMod js = do - mapM (getInfo collectSubterms) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get (C.Lin f trm) = do - get trm - return () - -collectSubterms :: C.Term -> TermM () -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.W s u -> do - collectSubterms u - add t - C.P p u -> do - collectSubterms p - collectSubterms u - add t - _ -> return () - where - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs index 1a8d80c5d..913ee24bf 100644 --- a/src/GF/Conversion/Types.hs +++ b/src/GF/Conversion/Types.hs @@ -18,7 +18,7 @@ module GF.Conversion.Types where import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent) import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..)) -import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..)) +import qualified GF.GFCC.AbsGFCC as AbsGFCC (CId(..)) import qualified GF.Grammar.Grammar as Grammar (Term) import GF.Formalism.GCFG