diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/CheckGrammar.hs | 97 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Coding.hs | 8 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/AppPredefined.hs | 2 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePMCFG.hs | 480 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GrammarToPGF.hs | 227 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Optimize.hs | 8 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Refresh.hs | 8 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Rename.hs | 4 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/SubExOpt.hs | 8 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Update.hs | 18 |
10 files changed, 441 insertions, 419 deletions
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 2b82bc781..1770e60e8 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -102,52 +102,52 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do return info _ -> return info case info of - CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) - _ -> Bad "no def lin" + CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) + _ -> Bad "no def lin" case lookupIdent c js of Ok (AnyInd _ _) -> return js - Ok (CncFun ty (Just def) pn) -> - return $ updateTree (c,CncFun ty (Just def) pn) js - Ok (CncFun ty Nothing pn) -> + Ok (CncFun ty (Just def) mn mf) -> + return $ updateTree (c,CncFun ty (Just def) mn mf) js + Ok (CncFun ty Nothing mn mf) -> case mb_def of - Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js + Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c return js _ -> do case mb_def of Ok def -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js + return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c return js AbsCat (Just _) -> case lookupIdent c js of Ok (AnyInd _ _) -> return js - Ok (CncCat (Just _) _ _) -> return js - Ok (CncCat _ mt mp) -> do + Ok (CncCat (Just _) _ _ _) -> return js + Ok (CncCat _ mt mp mpmcfg) -> do checkWarn $ text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js + return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js _ -> do checkWarn $ text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js + return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js _ -> return js checkCnc js i@(c,info) = case info of - CncFun _ d pn -> case lookupOrigInfo gr (am,c) of - Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> - do (cont,val) <- linTypeOfType gr cm ty - let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) d pn) js - _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract" + CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of + Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> + do (cont,val) <- linTypeOfType gr cm ty + let linty = (snd (valCat ty),cont,val) + return $ updateTree (c,CncFun (Just linty) d mn mf) js + _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract" + return js + CncCat _ _ _ _ -> case lookupOrigInfo gr (am,c) of + Ok _ -> return $ updateTree i js + _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract" return js - CncCat _ _ _ -> case lookupOrigInfo gr (am,c) of - Ok _ -> return $ updateTree i js - _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract" - return js - _ -> return $ updateTree i js + _ -> return $ updateTree i js -- | General Principle: only Just-values are checked. @@ -170,21 +170,41 @@ checkInfo ms (m,mo) c info = do Nothing -> return () return (AbsFun (Just (L loc typ)) ma md moper) - CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do - (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars - mpr <- checkPrintname gr mpr - return (CncFun linty (Just (L loc trm')) mpr) + CncCat mty mdef mpr mpmcfg -> do + mty <- case mty of + Just (L loc typ) -> chIn loc "linearization type of" $ do + (typ,_) <- checkLType gr [] typ typeType + typ <- computeLType gr [] typ + return (Just (L loc typ)) + Nothing -> return Nothing + mdef <- case (mty,mdef) of + (Just (L _ typ),Just (L loc def)) -> + chIn loc "default linearization of" $ do + (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) + return (Just (L loc def)) + _ -> return Nothing + mpr <- case mpr of + (Just (L loc t)) -> + chIn loc "print name of" $ do + (t,_) <- checkLType gr [] t typeStr + return (Just (L loc t)) + _ -> return Nothing + return (CncCat mty mdef mpr mpmcfg) - CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do - (typ,_) <- checkLType gr [] typ typeType - typ <- computeLType gr [] typ - mdef <- case mdef of - Just (L loc def) -> do - (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) - return $ Just (L loc def) - _ -> return mdef - mpr <- checkPrintname gr mpr - return (CncCat (Just (L loc typ)) mdef mpr) + CncFun mty mt mpr mpmcfg -> do + mt <- case (mty,mt) of + (Just (cat,cont,val),Just (L loc trm)) -> + chIn loc "linearization of" $ do + (trm,_) <- checkLType gr [] trm (mkProd cont val []) + return (Just (L loc trm)) + _ -> return mt + mpr <- case mpr of + (Just (L loc t)) -> + chIn loc "print name of" $ do + (t,_) <- checkLType gr [] t typeStr + return (Just (L loc t)) + _ -> return Nothing + return (CncFun mty mt mpr mpmcfg) ResOper pty pde -> do (pty', pde') <- case (pty,pde) of @@ -252,11 +272,6 @@ checkInfo ms (m,mo) c info = do _ -> composOp (compAbsTyp g) t -checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term)) -checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr - return (Just (L loc t)) -checkPrintname gr Nothing = return Nothing - -- | for grammars obtained otherwise than by parsing ---- update!! checkReservedId :: Ident -> Check () checkReservedId x diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs index 1b8753afe..5dc463d0e 100644 --- a/src/compiler/GF/Compile/Coding.hs +++ b/src/compiler/GF/Compile/Coding.hs @@ -20,10 +20,10 @@ codeSourceModule :: (String -> String) -> SourceModule -> SourceModule codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)}) where codj (c,info) = case info of - ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt) - ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts] - CncCat pty pt mpr -> CncCat pty (codeLTerms co pt) (codeLTerms co mpr) - CncFun mty pt mpr -> CncFun mty (codeLTerms co pt) (codeLTerms co mpr) + ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt) + ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts] + CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg + CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg _ -> info codeLTerms co = fmap (codeLTerm co) diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index af440ba0d..514b471c4 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -45,7 +45,7 @@ arrityPredefined f = do ty <- typPredefined f return (length ctxt) predefModInfo :: SourceModInfo -predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives +predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives primitives = Map.fromList [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index aaa4a2961..f4f1a3fca 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -10,10 +10,11 @@ ----------------------------------------------------------------------------- module GF.Compile.GeneratePMCFG - (convertConcrete) where + (generatePMCFG, pgfCncCat + ) where import PGF.CId -import PGF.Data hiding (Type) +import PGF.Data hiding (Type, Production) import GF.Infra.Option import GF.Grammar hiding (Env, mkRecord, mkTable) @@ -28,9 +29,11 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import qualified Data.ByteString.Char8 as BS import Text.PrettyPrint hiding (Str) import Data.Array.IArray +import Data.Array.Unboxed import Data.Maybe import Data.Char (isDigit) import Control.Monad @@ -40,155 +43,83 @@ import Control.Exception ---------------------------------------------------------------------- -- main conversion function - -convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr -convertConcrete opts0 gr am cm = do - let env = emptyGrammarEnv gr cm - when (flag optProf opts) $ do - profileGrammar cm env pfrules - env <- foldM (convertLinDef gr opts) env pflindefs - env <- foldM (convertRule gr opts) env pfrules - return $ getConcr flags printnames env - where - (m,mo) = cm - - opts = addOptions (mflags (snd am)) opts0 - - pflindefs = [ - ((m,id),term,lincat) | - (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)] - - pfrules = [ - (PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) | - (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (jments mo), - let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id) - args = [catSkeleton ty | (_,_,ty) <- ctxt]] - - flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (mflags mo)] - - printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (jments mo), name <- prn info] - where - prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr] - prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr] - prn _ = [] - - flatten (K s) = s - flatten (Alts x _) = flatten x - flatten (C x y) = flatten x +++ flatten y - -i2i :: Ident -> CId -i2i = CId . ident2bs - -profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do - hPutStrLn stderr "" - hPutStrLn stderr ("Language: " ++ showIdent m) - hPutStrLn stderr "" - hPutStrLn stderr "Categories Count" - hPutStrLn stderr "--------------------------------" - mapM_ profileCat (Map.toList catSet) - hPutStrLn stderr "--------------------------------" - hPutStrLn stderr "" - hPutStrLn stderr "Rules Count" - hPutStrLn stderr "--------------------------------" - mapM_ profileRule pfrules - hPutStrLn stderr "--------------------------------" +generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule +generatePMCFG opts mos cmo@(cm,cmi) = do + (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi) + when (verbAtLeast opts Verbose) $ hPutStrLn stderr "" + return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) where - profileCat (cid,(fcat1,fcat2,_)) = do - hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1))) - - profileRule (PFRule fun args res ctypes ctype term) = do - let pargs = map (protoFCat env) args - hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args)))) - where - catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) = - case Map.lookup cat catSet of - Just (s,e,_) -> e-s+1 - Nothing -> 0 - - lformat :: Int -> String -> String - lformat n s = s ++ replicate (n-length s) ' ' - - rformat :: Int -> String -> String - rformat n s = replicate (n-length s) ' ' ++ s - -data ProtoFRule = PFRule Ident {- function -} - [([Cat],Cat)] {- argument types: context size and category -} - ([Cat],Cat) {- result type : context size (always 0) and category -} - [Type] {- argument lin-types representation -} - Type {- result lin-type representation -} - Term {- body -} - -optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv -optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) = - IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet + gr = mGrammar (cmo:mos) + MTConcrete am = mtype cmi + +mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a + -> Map.Map k b -> m (a,Map.Map k c) +mapAccumWithKeyM f a m = do let xs = Map.toAscList m + (a,ys) <- mapAccumM f a xs + return (a,Map.fromAscList ys) where - optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps]) - where - ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv - ff funid xs env - | product (map Set.size ys) == count - = case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of - (env,args) -> let xs = sequence (zipWith addContext pargs args) - in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs - | otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args) - in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs - where - count = length xs - ys = foldr (zipWith Set.insert) (repeat Set.empty) xs - - addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt - return (PArg hyps fid) - - toCncHypo cat = - case Map.lookup cat catSet of - Just (s,e,_) -> do fid <- range (s,e) - guard (fid `IntMap.member` lindefSet) - return (fidVar,fid) - Nothing -> mzero - -convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv -convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do - let pres = protoFCat grammarEnv res - pargs = map (protoFCat grammarEnv) args - - b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[]) - (grammarEnv1,b1) = addSequencesB grammarEnv b - grammarEnv2 = foldBM addRule - grammarEnv1 - (goB b1 CNil []) - (pres,pargs) - grammarEnv3 = optimize pargs grammarEnv2 - when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun) - return $! grammarEnv3 + mapAccumM f a [] = return (a,[]) + mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x + (a,kys) <- mapAccumM f a kxs + return (a,(k,y):kys) + + +addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info) +addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn _) = do + let pres = protoFCat gr res val + pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont] + + pmcfgEnv0 = emptyPMCFGEnv + + b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[]) + (seqs1,b1) = addSequencesB seqs b + pmcfgEnv1 = foldBM addRule + pmcfgEnv0 + (goB b1 CNil []) + (pres,pargs) + pmcfg = getPMCFG pmcfgEnv1 + + stats = let PMCFG prods funs = pmcfg + (s,e) = bounds funs + !prods_cnt = length prods + !funs_cnt = e-s+1 + in (prods_cnt,funs_cnt) + + when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) + seqs1 `seq` stats `seq` return () + when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats) + return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) where + (ctxt,res,_) = err error typeForm (lookupFunType gr am id) + addRule lins (newCat', newArgs') env0 = - let [newCat] = getFIds env0 newCat' - (env1, newArgs) = List.mapAccumL (\env -> addCoercion env . getFIds env) env0 newArgs' - - (env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins)) - - in addApplication env2 newCat (funid,newArgs) - -convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv -convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do - let pres = protoFCat grammarEnv ([],cat) - parg = protoFCat grammarEnv ([],(identW,cVar)) - - b = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[]) - (grammarEnv1,b1) = addSequencesB grammarEnv b - grammarEnv2 = foldBM addRule - grammarEnv1 - (goB b1 CNil []) - (pres,[parg]) - when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId) - return $! grammarEnv2 + let [newCat] = getFIds newCat' + !fun = mkArray lins + newArgs = map getFIds newArgs' + in addFunction env0 newCat fun newArgs + +addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn _) = do + let pres = protoFCat gr (am,id) lincat + parg = protoFCat gr (identW,cVar) typeStr + + pmcfgEnv0 = emptyPMCFGEnv + + b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil lincat) ([parg],[]) + (seqs1,b1) = addSequencesB seqs b + pmcfgEnv1 = foldBM addRule + pmcfgEnv0 + (goB b1 CNil []) + (pres,[parg]) + pmcfg = getPMCFG pmcfgEnv1 + when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres)) + seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg)) where - lindefCId = mkCId ("lindef "++showIdent (snd cat)) - addRule lins (newCat', newArgs') env0 = - let [newCat] = getFIds env0 newCat' - (env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins)) - in addLinDef env1 newCat funid + let [newCat] = getFIds newCat' + !fun = mkArray lins + in addFunction env0 newCat fun [[fidVar]] + +addPMCFG opts gr am cm seqs id info = return (seqs, info) unfactor :: Term -> CnvMonad Term unfactor t = CM (\gr c -> c (unfac gr t)) @@ -202,6 +133,22 @@ unfactor t = CM (\gr c -> c (unfac gr t)) Vr y | y == x -> u _ -> composSafeOp (restore x u) t +pgfCncCat :: SourceGrammar -> Type -> Int -> PGF.Data.CncCat +pgfCncCat gr lincat index = + let ((_,size),schema) = computeCatRange gr lincat + in PGF.Data.CncCat index + (index+size-1) + (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) + (getStrPaths schema))) + where + getStrPaths :: Schema Identity s c -> [Path] + getStrPaths = collect CNil [] + where + collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs + collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs + collect path paths (CStr _) = reversePath path : paths + collect path paths (CPar _) = paths + ---------------------------------------------------------------------- -- CnvMonad monad -- @@ -248,7 +195,7 @@ variants xs = CM (\gr c s -> Variant [c x s | x <- xs]) choices :: Int -> Path -> CnvMonad Term choices nr path = do (args,_) <- get let PFCat _ _ schema = args !! nr - descend schema path CNil + descend schema path CNil where descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of Just (Identity t) -> descend t path (CProj lbl rpath) @@ -305,15 +252,43 @@ data Path -- The annotations are as follows: the strings are annotated with -- their index in the PMCFG tuple, the parameters are annotated -- with their value both as term and as index. -data ProtoFCat = PFCat [Ident] Ident Proto +data ProtoFCat = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)])) type Env = (ProtoFCat, [ProtoFCat]) -protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat -protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) = - case Map.lookup cat catSet of - Just (_,_,proto) -> PFCat (map snd ctxt) cat proto - Nothing -> error "unknown category" - +protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat +protoFCat gr cat lincat = + case computeCatRange gr lincat of + ((_,f),schema) -> PFCat (snd cat) f schema + +getFIds :: ProtoFCat -> [FId] +getFIds (PFCat _ _ schema) = + reverse (solutions (variants schema) ()) + where + variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs + variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs + variants (CStr _) = return 0 + variants (CPar (m,values)) = do (value,index) <- member values + return (m*index) + +catFactor :: ProtoFCat -> Int +catFactor (PFCat _ f _) = f + +computeCatRange gr lincat = compute (0,1) lincat + where + compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t + in (st',(lbl,Identity t'))) st rs + in (st',CRec rs') + compute st (Table pt vt) = let vs = err error id (allParamValues gr pt) + (st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt + in (st',(v,Identity vt'))) st vs + in (st',CTbl pt cs') + compute st (Sort s) + | s == cStr = let (index,m) = st + in ((index+1,m),CStr index) + compute st t = let vs = err error id (allParamValues gr t) + (index,m) = st + in ((index,m*length vs),CPar (m,zip vs [0..])) + ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path ppPath CNil = empty @@ -363,7 +338,7 @@ convertArg opts (Table pt vt) nr path = do mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs) convertArg opts (Sort _) nr path = do (args,_) <- get - let PFCat _ cat schema = args !! nr + let PFCat cat _ schema = args !! nr l = index (reversePath path) schema sym | CProj (LVar i) CNil <- path = SymVar nr i | isLiteralCat opts cat = SymLit nr l @@ -411,26 +386,31 @@ goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss goV (CStr seqid) rpath ss = return (seqid : ss) goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss -addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId)) -addSequencesB env (Case nr path bs) = let (env1,bs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b - in (env',(trm,b'))) env bs - in (env1,Case nr path bs1) -addSequencesB env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequencesB env bs - in (env1,Variant bs1) -addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v - in (env1,Return v1) - -addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId) -addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b - in (env',(lbl,b'))) env vs - in (env1,CRec vs1) -addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b - in (env',(trm,b'))) env vs - in (env1,CTbl pt vs1) -addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin) - in (env1,CStr seqid) -addSequencesV env (CPar i) = (env,CPar i) +---------------------------------------------------------------------- +-- SeqSet + +type SeqSet = Map.Map Sequence SeqId + +addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId)) +addSequencesB seqs (Case nr path bs) = let (seqs1,bs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b + in (seqs',(trm,b'))) seqs bs + in (seqs1,Case nr path bs1) +addSequencesB seqs (Variant bs) = let (seqs1,bs1) = List.mapAccumL addSequencesB seqs bs + in (seqs1,Variant bs1) +addSequencesB seqs (Return v) = let (seqs1,v1) = addSequencesV seqs v + in (seqs1,Return v1) + +addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId) +addSequencesV seqs (CRec vs) = let (seqs1,vs1) = List.mapAccumL (\seqs (lbl,b) -> let (seqs',b') = addSequencesB seqs b + in (seqs',(lbl,b'))) seqs vs + in (seqs1,CRec vs1) +addSequencesV seqs (CTbl pt vs)=let (seqs1,vs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b + in (seqs',(trm,b'))) seqs vs + in (seqs1,CTbl pt vs1) +addSequencesV seqs (CStr lin) = let (seqs1,seqid) = addSequence seqs (optimizeLin lin) + in (seqs1,CStr seqid) +addSequencesV seqs (CPar i) = (seqs,CPar i) optimizeLin [] = [] optimizeLin lin@(SymKS _ : _) = @@ -442,6 +422,15 @@ optimizeLin lin@(SymKS _ : _) = getRest lin = ([],lin) optimizeLin (sym : lin) = sym : optimizeLin lin +addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId) +addSequence seqs lst = + case Map.lookup seq seqs of + Just id -> (seqs,id) + Nothing -> let !last_seq = Map.size seqs + in (Map.insert seq last_seq seqs, last_seq) + where + seq = mkArray lst + ------------------------------------------------------------ -- eval a term to ground terms @@ -478,124 +467,36 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd ---------------------------------------------------------------------- -- GrammarEnv -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet -type Proto = Schema Identity Int (Int,[(Term,Int)]) -type CatSet = Map.Map Ident (FId,FId,Proto) -type SeqSet = Map.Map Sequence SeqId -type FunSet = Map.Map CncFun FunId -type LinDefSet= IntMap.IntMap [FunId] -type CoerceSet= Map.Map [FId] FId -type AppSet = IntMap.IntMap (Set.Set (FunId,[FId])) -type ProdSet = IntMap.IntMap (Set.Set Production) - -emptyGrammarEnv gr (m,mo) = - let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats - in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty - where - computeCatRange index cat ctype - | cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))])) - | cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))])) - | cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))])) - | cat == cVar = (index,(fidVar, fidVar, CStr 0)) - | otherwise = (index+size,(index,index+size-1,schema)) - where - ((_,size),schema) = compute (0,1) ctype - - compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t - in (st',(lbl,Identity t'))) st rs - in (st',CRec rs') - compute st (Table pt vt) = let vs = err error id (allParamValues gr pt) - (st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt - in (st',(v,Identity vt'))) st vs - in (st',CTbl pt cs') - compute st (Sort s) - | s == cStr = let (index,m) = st - in ((index+1,m),CStr index) - compute st t = let vs = err error id (allParamValues gr t) - (index,m) = st - in ((index,m*length vs),CPar (m,zip vs [0..])) +data PMCFGEnv = PMCFGEnv !ProdSet !FunSet +type ProdSet = Set.Set Production +type FunSet = Map.Map (UArray LIndex SeqId) FunId - lincats = - Map.insert cVar (Sort cStr) $ - Map.fromAscList - [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (jments mo)] - -addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv -addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p = - GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet - -addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) - -addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId) -addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst = - case Map.lookup seq seqSet of - Just id -> (env,id) - Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq) - where - seq = mkArray lst +emptyPMCFGEnv = + PMCFGEnv Set.empty Map.empty -addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId) -addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun = +addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv +addFunction (PMCFGEnv prodSet funSet) !fid fun args = case Map.lookup fun funSet of - Just id -> (env,id) - Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid) - -addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId) -addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats = - case sub_fcats of - [fcat] -> (env,fcat) - _ -> case Map.lookup sub_fcats crcSet of - Just fcat -> (env,fcat) - Nothing -> let !fcat = last_id+1 - in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat) - -addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv -addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid = - GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet - -getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr -getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) = - Concr { cflags = flags - , printnames = printnames - , cncfuns = mkSetArray funSet - , lindefs = lindefSet - , sequences = mkSetArray seqSet - , productions = IntMap.union prodSet coercions - , pproductions = IntMap.empty - , lproductions = Map.empty - , lexicon = IntMap.empty - , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema)))) - | (cat,(start,end,schema)) <- Map.toList catSet] - , totalCats = last_id+1 - } + Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet) + funSet + Nothing -> let !funid = Map.size funSet + in PMCFGEnv (Set.insert (Production fid funid args) prodSet) + (Map.insert fun funid funSet) + +getPMCFG :: PMCFGEnv -> PMCFG +getPMCFG (PMCFGEnv prodSet funSet) = + PMCFG (optimize prodSet) (mkSetArray funSet) where - mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - - coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] - - getStrPaths :: Schema Identity s c -> [Path] - getStrPaths = collect CNil [] + optimize ps = Map.foldWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps]) where - collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs - collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs - collect path paths (CStr _) = reversePath path : paths - collect path paths (CPar _) = paths - - -getFIds :: GrammarEnv -> ProtoFCat -> [FId] -getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) = - case Map.lookup cat catSet of - Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ()) - where - variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs - variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs - variants (CStr _) = return 0 - variants (CPar (m,values)) = do (value,index) <- member values - return (m*index) + ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production] + ff (fid,funid) xs prods + | product (map IntSet.size ys) == count + = (Production fid funid (map IntSet.toList ys)) : prods + | otherwise = map (Production fid funid) xs ++ prods + where + count = sum (map (product . map length) xs) + ys = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs ------------------------------------------------------------ -- updating the MCF rule @@ -613,9 +514,9 @@ restrictHead path term = do put (head, args) restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat -restrictProtoFCat path v (PFCat ctxt cat schema) = do +restrictProtoFCat path v (PFCat cat f schema) = do schema <- addConstraint path v schema - return (PFCat ctxt cat schema) + return (PFCat cat f schema) where addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs @@ -631,4 +532,5 @@ restrictProtoFCat path v (PFCat ctxt cat schema) = do | otherwise = do xs <- update k0 f xs return (x:xs) -mkArray lst = listArray (0,length lst-1) lst +mkArray lst = listArray (0,length lst-1) lst +mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 06ececb3c..7e73b36de 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE BangPatterns #-} module GF.Compile.GrammarToPGF (mkCanon2pgf) where import GF.Compile.Export import GF.Compile.GeneratePMCFG import PGF.CId +import PGF.Data(fidInt,fidFloat,fidString) import PGF.Optimize(updateProductionIndices) import qualified PGF.Macros as CM import qualified PGF.Data as C @@ -15,8 +16,8 @@ import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look import qualified GF.Grammar as A import qualified GF.Grammar.Macros as GM ---import qualified GF.Compile.Compute.Concrete as Compute ---- import qualified GF.Infra.Option as O +import GF.Compile.GeneratePMCFG import GF.Infra.Ident import GF.Infra.Option @@ -25,61 +26,72 @@ import GF.Data.Operations import Data.List import Data.Function import Data.Char (isDigit,isSpace) +import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.IntMap as IntMap import qualified Data.ByteString.Char8 as BS +import Data.Array.IArray import Text.PrettyPrint ---import Debug.Trace ---- - --- when developing, swap commenting ---traceD s t = trace s t -traceD s t = t +import Control.Monad.Identity --- the main function: generate PGF from GF. -mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF -mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr - where - abs = err (const cnc) id $ abstractOfConcrete gr cnc - --- Generate PGF from grammar. - -type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes) -type IdModInfo = (Ident,SourceModInfo) - -canon2pgf :: Options -> SourceGrammar -> AbsConcsGrammar -> IO D.PGF -canon2pgf opts gr (am,cms) = do - if dump opts DumpCanon - then putStrLn (render (vcat (map (ppModule Qualified) (am:cms)))) - else return () - (an,abs) <- mkAbstr am - cncs <- mapM (mkConcr am) cms +mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF +mkCanon2pgf opts gr am = do + (an,abs) <- mkAbstr gr am + cncs <- mapM (mkConcr gr) (allConcretes gr am) return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) where - mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats) + mkAbstr gr am = return (i2i am, D.Abstr flags funs cats) where - flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (mflags abm)] + aflags = + concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo]) + + adefs = + [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ + Look.allOrigInfos gr am + + flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags] funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) | - (f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (jments abm)] + ((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs] cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) | - (c,AbsCat (Just (L _ cont))) <- Map.toAscList (jments abm)] + ((m,c),AbsCat (Just (L _ cont))) <- adefs] catfuns cat = (map (\x -> (0,snd x)) . sortBy (compare `on` fst)) - [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (jments abm), snd (GM.valCat ty) == cat] + [(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat] + + mkConcr gr cm = do + return (i2i cm, D.Concr flags + printnames + cncfuns + lindefs + sequences + productions + IntMap.empty + Map.empty + cnccats + IntMap.empty + fid_cnt2) + where + cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo, + Just r <- [lookup i (allExtendSpecs gr cm)]] + + cdefs = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++ + Look.allOrigInfos gr cm - mkConcr am cm@(lang,mo) = do - cnc <- convertConcrete opts gr am cm - return (i2i lang, cnc) + flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF cflags] + + !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs + !(!fid_cnt2,!productions,!lindefs,!sequences,!cncfuns) + = genCncFuns gr am cm cdefs fid_cnt1 cnccats + + printnames = genPrintNames cdefs i2i :: Ident -> CId i2i = CId . ident2bs -b2b :: A.BindType -> C.BindType -b2b A.Explicit = C.Explicit -b2b A.Implicit = C.Implicit - mkType :: [Ident] -> A.Type -> C.Type mkType scope t = case GM.typeForm t of @@ -94,7 +106,7 @@ mkExp scope t = Vr x -> case lookup x (zip scope [0..]) of Just i -> C.EVar i Nothing -> C.EMeta 0 - Abs b x t-> C.EAbs (b2b b) (i2i x) (mkExp (x:scope) t) + Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t) App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2) EInt i -> C.ELit (C.LInt (fromIntegral i)) EFloat f -> C.ELit (C.LFlt f) @@ -120,8 +132,8 @@ mkPatt scope p = mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty in if x == identW - then ( scope,(b2b bt,i2i x,ty')) - else (x:scope,(b2b bt,i2i x,ty'))) scope hyps + then ( scope,(bt,i2i x,ty')) + else (x:scope,(bt,i2i x,ty'))) scope hyps mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] mkDef Nothing = Nothing @@ -148,28 +160,121 @@ compilePatt eqs = whilePP eqs Map.empty mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs) --- return just one module per language +genCncCats gr am cm cdefs = + let (index,cats) = mkCncCats 0 cdefs + in (index, Map.fromList cats) + where + mkCncCats index [] = (index,[]) + mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs) + | id == cInt = + let cc = pgfCncCat gr lincat fidInt + (index',cats) = mkCncCats index cdefs + in (index', (i2i id,cc) : cats) + | id == cFloat = + let cc = pgfCncCat gr lincat fidFloat + (index',cats) = mkCncCats index cdefs + in (index', (i2i id,cc) : cats) + | id == cString = + let cc = pgfCncCat gr lincat fidString + (index',cats) = mkCncCats index cdefs + in (index', (i2i id,cc) : cats) + | otherwise = + let cc@(C.CncCat s e _) = pgfCncCat gr lincat index + (index',cats) = mkCncCats (e+1) cdefs + in (index', (i2i id,cc) : cats) + mkCncCats index (_ :cdefs) = mkCncCats index cdefs + -reorder :: Ident -> SourceGrammar -> AbsConcsGrammar -reorder abs cg = --- M.MGrammar $ - ((abs, ModInfo MTAbstract MSComplete aflags [] Nothing [] [] "" adefs), - [(cnc, ModInfo (MTConcrete abs) MSComplete cflags [] Nothing [] [] "" cdefs) - | cnc <- allConcretes cg abs, let (cflags,cdefs) = concr cnc]) +genCncFuns gr am cm cdefs fid_cnt cnccats = + let (fid_cnt1,funs_cnt1,seqs1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 Map.empty [] IntMap.empty + (fid_cnt2,funs_cnt2,seqs2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 seqs1 funs1 lindefs Map.empty IntMap.empty + in (fid_cnt2,prods,lindefs,mkSetArray seqs2,array (0,funs_cnt2-1) funs2) where - aflags = - concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo]) + mkCncCats [] fid_cnt funs_cnt seqs funs lindefs = + (fid_cnt,funs_cnt,seqs,funs,lindefs) + mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs = + let !funs_cnt' = let (s_funid, e_funid) = bounds funs0 + in funs_cnt+(e_funid-s_funid+1) + lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0 + !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0) + in mkCncCats cdefs fid_cnt funs_cnt' seqs' funs' lindefs' + mkCncCats (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs = + mkCncCats cdefs fid_cnt funs_cnt seqs funs lindefs - adefs = - Map.fromList (predefADefs ++ Look.allOrigInfos cg abs) + mkCncFuns [] fid_cnt funs_cnt seqs funs lindefs crc prods = + (fid_cnt,funs_cnt,seqs,funs,prods) + mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods = + let Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id) + !funs_cnt' = let (s_funid, e_funid) = bounds funs0 + in funs_cnt+(e_funid-s_funid+1) + !(fid_cnt',crc',prods') + = foldl' (toProd lindefs ty_C funs_cnt) + (fid_cnt,crc,prods) prods0 + !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0) + in mkCncFuns cdefs fid_cnt' funs_cnt' seqs' funs' lindefs crc' prods' + mkCncFuns (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods = + mkCncFuns cdefs fid_cnt funs_cnt seqs funs lindefs crc prods + + toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) = + let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) + set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args)) + fid = mkFId res_C fid0 + !prods' = case IntMap.lookup fid prods of + Just set -> IntMap.insert fid (Set.union set0 set) prods + Nothing -> IntMap.insert fid set0 prods + in (fid_cnt,crc,prods') where - predefADefs = - [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] - - concr la = (flags, Map.fromList (predefCDefs ++ jments)) - where - flags = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo, - Just r <- [lookup i (allExtendSpecs cg la)]] - jments = Look.allOrigInfos cg la - predefCDefs = - [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]] + mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) = + case fid0s of + [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt) + fid0s -> case Map.lookup fids crc of + Just fid -> (st,map (flip C.PArg fid) ctxt) + Nothing -> let !crc' = Map.insert fids fid_cnt crc + !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods + in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt) + where + (hargs_C,arg_C) = GM.catSkeleton ty + ctxt = mapM (mkCtxt lindefs) hargs_C + fids = map (mkFId arg_C) fid0s + + toLinDef res offs lindefs (Production fid0 funid0 _) = + IntMap.insertWith (++) fid [offs+funid0] lindefs + where + fid = mkFId res fid0 + + mkFId (_,cat) fid0 = + case Map.lookup (i2i cat) cnccats of + Just (C.CncCat s e _) -> s+fid0 + Nothing -> error "GrammarToPGF.mkFId failed" + + mkCtxt lindefs (_,cat) = + case Map.lookup (i2i cat) cnccats of + Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]] + Nothing -> error "GrammarToPGF.mkCtxt failed" + + toCncFun offs (m,id) (seqs,funs) (funid0,lins0) = + let Ok (ModInfo{mseqs=Just mseqs}) = lookupModule gr m + !(!seqs',lins) = mapAccumL (mkLin mseqs) seqs (elems lins0) + in (seqs',(offs+funid0,C.CncFun (i2i id) (mkArray lins)):funs) + where + mkLin mseqs seqs seqid = + let seq = mseqs ! seqid + in case Map.lookup seq seqs of + Just seqid -> (seqs,seqid) + Nothing -> let !seqid = Map.size seqs + !seqs' = Map.insert seq seqid seqs + in (seqs',seqid) + +genPrintNames cdefs = + Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info] + where + prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr] + prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr] + prn _ = [] + + flatten (K s) = s + flatten (Alts x _) = flatten x + flatten (C x y) = flatten x +++ flatten y + +mkArray lst = listArray (0,length lst-1) lst +mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 303bdb8d0..33632f5bf 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -61,7 +61,7 @@ evalInfo opts ms m c info = do errIn ("optimizing " ++ showIdent c) $ case info of - CncCat ptyp pde ppr -> do + CncCat ptyp pde ppr mpmcfg -> do pde' <- case (ptyp,pde) of (Just (L _ typ), Just (L loc de)) -> do de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de @@ -74,16 +74,16 @@ evalInfo opts ms m c info = do ppr' <- evalPrintname gr ppr - return (CncCat ptyp pde' ppr') + return (CncCat ptyp pde' ppr' mpmcfg) - CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $ + CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $ eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do pde' <- case pde of Just (L loc de) -> do de <- partEval opts gr (cont,val) de return (Just (L loc (factor param c 0 de))) Nothing -> return pde ppr' <- evalPrintname gr ppr - return $ CncFun mt pde' ppr' -- only cat in type actually needed + return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed ResOper pty pde | OptExpand `Set.member` optim -> do diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs index 86e423317..b66e88aa3 100644 --- a/src/compiler/GF/Compile/Refresh.hs +++ b/src/compiler/GF/Compile/Refresh.hs @@ -124,12 +124,12 @@ refreshModule (k,ms) mi@(i,mo) (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k) return $ (k', (c, ResOverload os tyts'):cs) - CncCat mt (Just (L loc trm)) pn -> do ---- refresh mt, pn + CncCat mt (Just (L loc trm)) mn mpmcfg-> do ---- refresh mt, pn (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs) - CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn + return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs) + CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs) + return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs) _ -> return (k, ci:cs) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 805e85464..336e8f946 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -158,8 +158,8 @@ renameInfo status (m,mi) i info = ResValue t -> do t <- renLoc (renameTerm status []) t return (ResValue t) - CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr) - CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr) + CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg) + CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg) _ -> return info where renTerm = renPerh (renameTerm status []) diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index 453c8e3ca..bfa2a1334 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -52,7 +52,7 @@ unsubexpModule sm@(i,mo) -- perform this iff the module has opers hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] unparInfo (c,info) = case info of - CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)] + CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)] ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))] _ -> [(c,info)] @@ -75,9 +75,9 @@ addSubexpConsts mo tree lins = do mapM mkOne $ opers ++ lins where mkOne (f,def) = case def of - CncFun xs (Just (L loc trm)) pn -> do + CncFun xs (Just (L loc trm)) pn pf -> do trm' <- recomp f trm - return (f,CncFun xs (Just (L loc trm')) pn) + return (f,CncFun xs (Just (L loc trm')) pn pf) ResOper ty (Just (L loc trm)) -> do trm' <- recomp f trm return (f,ResOper ty (Just (L loc trm'))) @@ -98,7 +98,7 @@ getSubtermsMod mo js = do return $ Map.filter (\ (nu,_) -> nu > 1) tree0 where getInfo get fi@(f,i) = case i of - CncFun xs (Just (L _ trm)) pn -> do + CncFun xs (Just (L _ trm)) pn _ -> do get trm return $ fi ResOper ty (Just (L _ trm)) -> do diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 2a95df4d5..6eb88b272 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -76,7 +76,7 @@ extendModule gr (name,m) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule -rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do +rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) = do ---- deps <- moduleDeps ms ---- is <- openInterfaces deps i let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 @@ -109,7 +109,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do [i | i <- is, notElem i infs] testErr (stat' == MSComplete || stat == MSIncomplete) ("module" +++ showIdent i +++ "remains incomplete") - ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ @@ -122,7 +122,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1 + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ env_ js1 return (i,mi') @@ -173,8 +173,8 @@ globalizeLoc fpath i = ResValue t -> ResValue (gl t) ResOper mt m -> ResOper (fmap gl mt) (fmap gl m) ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os) - CncCat mc mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) - CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md) + CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) mpmcfg + CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg AnyInd b m -> AnyInd b m where gl (L loc0 x) = loc `seq` L (External fpath loc) x @@ -200,10 +200,10 @@ unifyAnyInfo m i j = case (i,j) of (ResOper mt1 m1, ResOper mt2 m2) -> liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2) - (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) - (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs + (CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) -> + liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2) + (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> + liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2) (AnyInd b1 m1, AnyInd b2 m2) -> do testErr (b1 == b2) $ "indirection status" |