diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index 080057323..2881ee4ca 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/src/GF/Canon/CanonToGFCC.hs @@ -33,11 +33,17 @@ import GF.Data.Operations import Data.List import qualified Data.Map as Map +import Debug.Trace ---- +-- the main function: generate GFCC from GFCM. prCanon2gfcc :: CanonGrammar -> String -prCanon2gfcc = Pr.printTree . canon2gfcc . canon2canon . unoptimizeCanon +prCanon2gfcc = + Pr.printTree . canon2gfcc . reorder . canon2canon . unoptimizeCanon + -- phases defined below, except unoptimizeCanon. This is needed to + -- reorganize the grammar. GFCC has its own back-end optimization. +-- Generate GFCC from GFCM. -- this assumes a grammar translated by canon2canon canon2gfcc :: CanonGrammar -> C.Grammar @@ -72,36 +78,41 @@ mkTerm tr = case tr of K (KS s) -> C.K (C.KS s) K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants E -> C.S [] - Par _ _ -> C.C 444 ---- just for debugging ----- _ -> C.S [C.K (C.KS (show tr))] ---- just for debugging - _ -> C.S [C.K (C.KS (A.prt tr))] ---- just for debugging + Par _ _ -> prtTrace tr $ C.C 66661 ---- just for debugging + _ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- just for debugging where mkLab (L (IC l)) = case l of '_':ds -> (read ds) :: Integer - _ -> 789 + _ -> prtTrace tr $ 66663 --- translate tables and records to arrays, return just one module per language -canon2canon :: CanonGrammar -> CanonGrammar -canon2canon cgr = reorder $ M.MGrammar $ map c2c $ M.modules cgr where - reorder cg = M.MGrammar $ +-- return just one module per language + +reorder :: CanonGrammar -> CanonGrammar +reorder cg = M.MGrammar $ (abs, M.ModMod $ - M.Module M.MTAbstract M.MSComplete [] [] [] (sorted2tree adefs)): + M.Module M.MTAbstract M.MSComplete [] [] [] adefs): [(c, M.ModMod $ M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) - | (c,js) <- cncs cg] - abs = maybe (error "no abstract") id $ M.greatestAbstract cgr - adefs = sortBy (\ (f,_) (g,_) -> compare f g) + | (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) <- mos, M.isModAbs mo, + (i,mo) <- M.allModMod cg, M.isModAbs mo, finfo <- tree2list (M.jments mo)] - cncs cg = sortBy (\ (x,_) (y,_) -> compare x y) + cncs = sortBy (\ (x,_) (y,_) -> compare x y) [(lang, concr lang) | lang <- M.allConcretes cg abs] - mos = M.allModMod cgr - concr la = sortBy (\ (f,_) (g,_) -> compare f g) + concr la = sortBy (\ (f,_) (g,_) -> compare f g) [finfo | (i,mo) <- mos, M.isModCnc mo, ----- TODO: separate langs finfo <- tree2list (M.jments mo)] +-- translate tables and records to arrays, parameters and labels to indices + +canon2canon :: CanonGrammar -> CanonGrammar +canon2canon 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) @@ -109,36 +120,63 @@ canon2canon cgr = reorder $ M.MGrammar $ map c2c $ M.modules cgr where j2j (f,j) = case j of GFC.CncFun x y tr z -> (f,GFC.CncFun x y (t2t tr) z) _ -> (f,j) - t2t = term2term cgr (paramValues cgr) + t2t = term2term cg pv + pv@(labels,_,_) = paramValues cg + tr = trace + (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | + ((c,l),i) <- Map.toList labels]) type ParamEnv = - (Map.Map Term Integer, -- untyped terms to values - Map.Map CIdent (Map.Map Term Integer)) -- types to their terms to values + (Map.Map (Ident,[Label]) Integer, -- numbered labels + Map.Map Term Integer, -- untyped terms to values + Map.Map CType (Map.Map Term Integer)) -- types to their terms to values +--- gathers those param types that are actually used in lincats paramValues :: CanonGrammar -> ParamEnv -paramValues cgr = (untyps,typs) where - params = [(mty, errVal [] $ Look.lookupParamValues cgr mty) | - (m,mo) <- M.allModMod cgr, - (ty,ResPar _) <- tree2list $ M.jments mo, - let mty = CIQ m ty - ] +paramValues cgr = (labels,untyps,typs) where + params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] + partyps = nub $ [ty | + (_,(_,CncCat (RecType ls) _ _)) <- jments, + ty <- [ty | Lbg _ ty <- ls] + ] ++ [ + Cn (CIQ m ty) | + (m,(ty,ResPar _)) <- jments + ] + 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 = [(cat,ls) | (_,(cat,CncCat (RecType ls) _ _)) <- jments] + labels = Map.fromList $ concat + [((cat,[lab]),i):[((cat,[lab,lab2]),j) | + RecType rs <- [typ], (Lbg lab2 _,j) <- zip rs [0..]] + | + (cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]] term2term :: CanonGrammar -> ParamEnv -> Term -> Term -term2term cgr env@(untyps,typs) tr = case tr of +term2term cgr env@(labels,untyps,typs) tr = case tr of Par c ps | any isVar ps -> mkCase c ps - Par _ _ -> EInt $ valNum tr - R rs | any (isStr . trmAss) rs -> R [Ass (r2r l) (t2t t) | Ass l t <- rs] - R rs -> EInt $ valNum tr - P t l -> P (t2t t) (r2r l) + Par _ _ -> valNum tr + R rs | any (isStr . trmAss) rs -> + R [Ass (mkLab i) (t2t t) | (i,Ass l t) <- zip [0..] rs, not (isLock l t)] + R rs -> valNum tr + P t l -> r2r tr T ty cs -> V ty [t2t t | Cas _ t <- cs] S t p -> S (t2t t) (t2t p) _ -> composSafeOp t2t tr where t2t = term2term cgr env - r2r l = L (IC "_111") ---- TODO: number of label - valNum tr = maybe 456 id $ Map.lookup tr untyps + -- Conj@0.s + r2r tr = case tr of + P x@(Arg (A cat i)) lab -> + P x . mkLab $ maybe (prtTrace tr $ 66664) id $ + Map.lookup (cat,[lab]) labels + P p@(P x@(Arg (A cat i)) lab1) lab2 -> + P (r2r p) . mkLab $ maybe (prtTrace tr $ 66664) id $ + Map.lookup (cat,[lab1,lab2]) labels + P a lab -> P (t2t a) $ mkLab (prtTrace tr 66665) + mkLab k = L (IC ("_" ++ show k)) + valNum tr = maybe (K (KS (A.prt tr +++ prtTrace tr "66667"))) EInt $ + Map.lookup tr untyps isStr tr = case tr of Par _ _ -> False EInt _ -> False @@ -146,19 +184,27 @@ term2term cgr env@(untyps,typs) tr = case tr of FV ts -> any isStr ts P t r -> True ---- TODO _ -> True + isLock l t = case t of --- need not look at l + R [] -> True + _ -> False trmAss (Ass _ t) = t isVar p = case p of Arg _ -> True P q _ -> isVar q _ -> False - mkCase c ps = EInt 666 ---- TODO: expand param constr with var + mkCase c ps = EInt (prtTrace tr 66668) ---- TODO: expand param constr with var +prtTrace tr n = n ----trace ("-- ERROR" +++ 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] @@ -174,18 +220,16 @@ optTerm tr = case tr of isK t = case t of C.K (C.KS _) -> True _ -> False - 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 --- implementation - type TermList = Map.Map C.Term (Int,Int) -- number of occs, id type TermM a = STM (TermList,Int) a @@ -238,173 +282,3 @@ collectSubterms t = case t of _ -> ((1, i ), i+1) writeSTM (Map.insert t (count,id) ts, next) - - - - - - - -{- -canon2sourceModule :: CanonModule -> Err G.SourceModule -canon2sourceModule (i,mi) = do - i' <- redIdent i - info' <- case mi of - M.ModMod m -> do - (e,os) <- redExtOpen m - flags <- mapM redFlag $ M.flags m - (abstr,mt) <- case M.mtype m of - M.MTConcrete a -> do - a' <- redIdent a - return (a', M.MTConcrete a') - M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed - M.MTResource -> return (i',M.MTResource) --- c' not needed - M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed - defs <- mapMTree redInfo $ M.jments m - return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs - _ -> Bad $ "cannot decompile module type" - return (i',info') - where - redExtOpen m = do - e' <- return $ M.extend m - os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ - M.opens m - return (e',os') - -redInfo :: (Ident,Info) -> Err (Ident,G.Info) -redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do - c' <- redIdent c - info' <- case info of - AbsCat cont fs -> do - return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs)) - AbsFun typ df -> do - return $ G.AbsFun (Yes typ) (Yes df) - AbsTrans t -> do - return $ G.AbsTrans t - - ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par - - CncCat pty ptr ppr -> do - ty' <- redCType pty - trm' <- redCTerm ptr - ppr' <- redCTerm ppr - return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr') - CncFun (CIQ abstr cat) xx body ppr -> do - xx' <- mapM redArgVar xx - body' <- redCTerm body - ppr' <- redCTerm ppr - cat' <- redIdent cat - return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing - (Yes (F.mkAbs xx' body')) (Yes ppr') - - AnyInd b c -> liftM (G.AnyInd b) $ redIdent c - - return (c',info') - -redQIdent :: CIdent -> Err G.QIdent -redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c) - -redIdent :: Ident -> Err Ident -redIdent = return - -redFlag :: Flag -> Err O.Option -redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x]) - -redDecl :: Decl -> Err G.Decl -redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a) - -redType :: Exp -> Err G.Type -redType = redTerm - -redTerm :: Exp -> Err G.Term -redTerm t = return $ trExp t - --- resource - -redParam (ParD c cont) = do - c' <- redIdent c - cont' <- mapM redCType cont - return $ (c', [(IW,t) | t <- cont']) - --- concrete syntax - -redCType :: CType -> Err G.Type -redCType t = case t of - RecType lbs -> do - let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs] - ls' = map redLabel ls - ts' <- mapM redCType ts - return $ G.RecType $ zip ls' ts' - Table p v -> liftM2 G.Table (redCType p) (redCType v) - Cn mc -> liftM (uncurry G.QC) $ redQIdent mc - TStr -> return $ F.typeStr - TInts i -> return $ F.typeInts (fromInteger i) - -redCTerm :: Term -> Err G.Term -redCTerm x = case x of - Arg argvar -> liftM G.Vr $ redArgVar argvar - I cident -> liftM (uncurry G.Q) $ redQIdent cident - Par cident terms -> liftM2 F.mkApp - (liftM (uncurry G.QC) $ redQIdent cident) - (mapM redCTerm terms) - LI id -> liftM G.Vr $ redIdent id - R assigns -> do - let (ls,ts) = unzip [(l,t) | Ass l t <- assigns] - let ls' = map redLabel ls - ts' <- mapM redCTerm ts - return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts'] - P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) - T ctype cases -> do - ctype' <- redCType ctype - let (ps,ts) = unzip [(ps,t) | Cas ps t <- cases] - ps' <- mapM (mapM redPatt) ps - ts' <- mapM redCTerm ts - let tinfo = case ps' of - [[G.PV _]] -> G.TTyped ctype' - _ -> G.TComp ctype' - return $ G.TSh tinfo $ zip ps' ts' - V ctype ts -> do - ctype' <- redCType ctype - ts' <- mapM redCTerm ts - return $ G.V ctype' ts' - S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term) - C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term) - FV terms -> liftM G.FV $ mapM redCTerm terms - K (KS str) -> return $ G.K str - EInt i -> return $ G.EInt i - EFloat i -> return $ G.EFloat i - E -> return $ G.Empty - K (KP d vs) -> return $ - G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs]) - where - tList ss = case ss of --- this should be in Macros - [] -> G.Empty - _ -> foldr1 G.C $ map G.K ss - -failure x = Bad $ "not yet" +++ show x ---- - -redArgVar :: ArgVar -> Err Ident -redArgVar x = case x of - A x i -> return $ IA (prIdent x, fromInteger i) - AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i) - -redLabel :: Label -> G.Label -redLabel (L x) = G.LIdent $ prIdent x -redLabel (LV i) = G.LVar $ fromInteger i - -redPatt :: Patt -> Err G.Patt -redPatt p = case p of - PV x -> liftM G.PV $ redIdent x - PC mc ps -> do - (m,c) <- redQIdent mc - liftM (G.PP m c) (mapM redPatt ps) - PR rs -> do - let (ls,ts) = unzip [(l,t) | PAss l t <- rs] - ls' = map redLabel ls - ts <- mapM redPatt ts - return $ G.PR $ zip ls' ts - PI i -> return $ G.PInt i - PF i -> return $ G.PFloat i - _ -> Bad $ "cannot recompile pattern" +++ show p - --} diff --git a/src/GF/Canon/log.txt b/src/GF/Canon/log.txt new file mode 100644 index 000000000..22913ba54 --- /dev/null +++ b/src/GF/Canon/log.txt @@ -0,0 +1,15 @@ +GFCC, 6/9/2006 + +66661 24 Par remaining to be sent to GFC +66662 0 not covered by mkTerm +66663 36 label not in numeric format in mkTerm +66664 2 label not found in symbol table +66665 36 projection from deeper than just arg var: NP.agr.n +66667 0 parameter value not found in symbol table +66668 1 variable in parameter argument + + + +66664 2 +66665 125 missing: (VP.s!vf).fin +66668 1