|
sourcecode:
|
module FlatCurry.Compact
( generateCompactFlatCurryFile, computeCompactFlatCurry
, Option(..), RequiredSpec, requires, alwaysRequired
, defaultRequired
) where
import FlatCurry.Types
import FlatCurry.Files
import qualified Data.Set.RBTree as RBS
import qualified Data.Table.RBTree as RBT
import Data.Maybe
import Data.List ( nub, union )
import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix)
import System.FilePath ( takeFileName, (</>) )
import System.Directory
import XML
infix 0 `requires`
------------------------------------------------------------------------------
--- Options to guide the compactification process.
--- @cons Verbose - for more output
--- @cons Main - optimize for one main (unqualified!) function supplied here
--- @cons Exports - optimize w.r.t. the exported functions of the module only
--- @cons InitFuncs - optimize w.r.t. given list of initially required functions
--- @cons Required - list of functions that are implicitly required and, thus,
--- should not be deleted if the corresponding module
--- is imported
--- @cons Import - module that should always be imported
--- (useful in combination with option InitFuncs)
data Option =
Verbose
| Main String
| Exports
| InitFuncs [QName]
| Required [RequiredSpec]
| Import String
deriving Eq
isMainOption :: Option -> Bool
isMainOption o =
case o of Main _ -> True
_ -> False
getMainFuncFromOptions :: [Option] -> String
getMainFuncFromOptions (o:os) =
case o of Main f -> f
_ -> getMainFuncFromOptions os
getMainFuncFromOptions [] =
error "FlatCurry.Compact.getMainFuncFromOptions: option missing"
getRequiredFromOptions :: [Option] -> [RequiredSpec]
getRequiredFromOptions options = concat [ fs | Required fs <- options ]
-- add Import for modules containing always required functions:
addImport2Options :: [Option] -> [Option]
addImport2Options options =
options ++
map Import (nub (concatMap alwaysReqMod (getRequiredFromOptions options)))
where
alwaysReqMod (AlwaysReq (m,_)) = [m]
alwaysReqMod (Requires _ _) = []
------------------------------------------------------------------------------
--- Data type to specify requirements of functions.
data RequiredSpec = AlwaysReq QName | Requires QName QName
deriving Eq
--- (fun `requires` reqfun) specifies that the use of the function "fun"
--- implies the application of function "reqfun".
requires :: QName -> QName -> RequiredSpec
requires fun reqfun = Requires fun reqfun
--- (alwaysRequired fun) specifies that the function "fun" should be
--- always present if the corresponding module is loaded.
alwaysRequired :: QName -> RequiredSpec
alwaysRequired fun = AlwaysReq fun
--- Functions that are implicitly required in a FlatCurry program
--- (since they might be generated by external functions like
--- "==" or "=:=" on the fly).
defaultRequired :: [RequiredSpec]
defaultRequired =
[alwaysRequired (prelude,"apply"),
alwaysRequired (prelude,"letrec"),
alwaysRequired (prelude,"cond"),
alwaysRequired (prelude,"failure"),
(prelude,"==") `requires` (prelude,"&&"),
(prelude,"=:=") `requires` (prelude,"&"),
(prelude,"=:<=") `requires` (prelude,"ifVar"),
(prelude,"=:<=") `requires` (prelude,"=:="),
(prelude,"=:<=") `requires` (prelude,"&>"),
(prelude,"=:<<=") `requires` (prelude,"&"),
(prelude,"$#") `requires` (prelude,"ensureNotFree"),
(prelude,"readFile") `requires` (prelude,"prim_readFileContents"),
("Ports","prim_openPortOnSocket") `requires` ("Ports","basicServerLoop"),
("Ports","prim_timeoutOnStream") `requires` ("Ports","basicServerLoop"),
("Ports","prim_choiceSPEP") `requires` ("Ports","basicServerLoop"),
("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ]
prelude :: String
prelude = "Prelude"
--- Get functions that are required in a module w.r.t.
--- a requirement specification.
getRequiredInModule :: [RequiredSpec] -> String -> [QName]
getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs
where
getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else []
getImpReq (Requires _ _) = []
--- Get functions that are implicitly required by a function w.r.t.
--- a requirement specification.
getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName]
getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs
where
getImpReq (AlwaysReq _) = []
getImpReq (Requires f reqf) = if f==fun then [reqf] else []
--- The basic types that are always required in a FlatCurry program.
defaultRequiredTypes :: [QName]
defaultRequiredTypes =
[(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"),
(prelude,"Success"),(prelude,"IO")]
-------------------------------------------------------------------------------
-- Main functions:
-------------------------------------------------------------------------------
--- Computes a single FlatCurry program containing all functions potentially
--- called from a set of main functions and writes it into a FlatCurry file.
--- This is done by merging all imported FlatCurry modules and removing
--- the imported functions that are definitely not used.
--- @param options - list of options
--- @param progname - name of the Curry program that should be compacted
--- @param target - name of the target file where the compact program is saved
generateCompactFlatCurryFile :: [Option] -> String -> String -> IO ()
generateCompactFlatCurryFile options progname target = do
optprog <- computeCompactFlatCurry options progname
writeFCY target optprog
--- Computes a single FlatCurry program containing all functions potentially
--- called from a set of main functions.
--- This is done by merging all imported FlatCurry modules (these are loaded
--- demand-driven so that modules that contains no potentially called functions
--- are not loaded) and removing the imported functions that are definitely
--- not used.
--- @param options - list of options
--- @param progname - name of the Curry program that should be compacted
--- @return the compact FlatCurry program
computeCompactFlatCurry :: [Option] -> String -> IO Prog
computeCompactFlatCurry orgoptions progname =
let options = addImport2Options orgoptions in
if (elem Exports options) && (any isMainOption options)
then error
"CompactFlat: Options 'Main' and 'Exports' can't be be used together!"
else do
putStr "CompactFlat: Searching relevant functions in module "
prog <- readCurrentFlatCurry progname
resultprog <- makeCompactFlatCurry prog options
putStrLn $ "CompactFlat: Number of functions after optimization: " ++
show (length (moduleFuns resultprog))
return resultprog
--- Create the optimized program.
makeCompactFlatCurry :: Prog -> [Option] -> IO Prog
makeCompactFlatCurry mainmod options = do
(initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options
let initFuncTable = extendFuncTable (RBT.empty (<))
(concatMap moduleFuns loadedmods)
required = getRequiredFromOptions options
loadedreqfuns = concatMap (getRequiredInModule required)
(map moduleName loadedmods)
initreqfuncs = initfuncs ++ loadedreqfuns
(finalmods,finalfuncs,finalcons,finaltcons) <-
getCalledFuncs required
loadedmnames loadedmods initFuncTable
(foldr RBS.insert (RBS.empty (<)) initreqfuncs)
(RBS.empty (<)) (RBS.empty (<))
initreqfuncs
putStrLn ("\nCompactFlat: Total number of functions (without unused imports): "
++ show (foldr (+) 0 (map (length . moduleFuns) finalmods)))
let finalfnames = map functionName finalfuncs
return (Prog (moduleName mainmod)
[]
(let allTDecls = concatMap moduleTypes finalmods
reqTCons = extendTConsWithConsType finalcons finaltcons
allTDecls
allReqTCons = requiredDatatypes reqTCons allTDecls
in filter (\tdecl->tconsName tdecl `RBS.member` allReqTCons)
allTDecls)
finalfuncs
(filter (\ (Op oname _ _) -> oname `elem` finalfnames)
(concatMap moduleOps finalmods)))
-- compute the transitive closure of a set of type constructors w.r.t.
-- to a given list of type declaration so that the set contains
-- all type constructor names occurring in the type declarations:
requiredDatatypes :: RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName
requiredDatatypes tcnames tdecls =
let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
in if null newtcons
then tcnames
else requiredDatatypes (foldr RBS.insert tcnames newtcons) tdecls
-- Extract the new type constructors (w.r.t. a given set) contained in a
-- type declaration:
newTypeConsOfTDecl :: RBS.SetRBT QName -> TypeDecl -> [QName]
newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (TypeNew tcons _ _ (NewCons _ _ texp)) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames))
(concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps)
cdecls)
else []
-- Extend set of type constructor with type constructors of data declarations
-- contain some constructor.
extendTConsWithConsType :: RBS.SetRBT QName -> RBS.SetRBT QName -> [TypeDecl]
-> RBS.SetRBT QName
extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
extendTConsWithConsType cnames (RBS.insert tname tcons) tds
extendTConsWithConsType cnames tcons (TypeNew tname _ _ cdecl : tds) =
if newConsName cdecl `RBS.member` cnames
then extendTConsWithConsType cnames (RBS.insert tname tcons) tds
else extendTConsWithConsType cnames tcons tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
if tname `elem` defaultRequiredTypes ||
any (\cdecl->consName cdecl `RBS.member` cnames) cdecls
then extendTConsWithConsType cnames (RBS.insert tname tcons) tds
else extendTConsWithConsType cnames tcons tds
-- Extend function table (mapping from qualified names to function declarations)
-- by some new function declarations:
extendFuncTable :: RBT.TableRBT QName FuncDecl -> [FuncDecl]
-> RBT.TableRBT QName FuncDecl
extendFuncTable ftable fdecls =
foldr (\f t -> RBT.update (functionName f) f t) ftable fdecls
-------------------------------------------------------------------------------
-- Generate the Prog to start with:
-------------------------------------------------------------------------------
-- Compute the initially required functions in the compact program
-- together with the set of module names and contents that are initially loaded:
requiredInCompactProg :: Prog -> [Option] -> IO ([QName],RBS.SetRBT String,[Prog])
requiredInCompactProg mainmod options
| not (null initfuncs)
= do impprogs <- mapM readCurrentFlatCurry imports
return (concat initfuncs, add2mainmodset imports, mainmod:impprogs)
| Exports `elem` options
= do impprogs <- mapM readCurrentFlatCurry imports
return (nub mainexports, add2mainmodset imports, mainmod:impprogs)
| any isMainOption options
= let func = getMainFuncFromOptions options in
if (mainmodname,func) `elem` (map functionName (moduleFuns mainmod))
then do
impprogs <- mapM readCurrentFlatCurry imports
return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs)
else error $ "CompactFlat: Cannot find main function \""++func++"\"!"
| otherwise
= do impprogs <- mapM readCurrentFlatCurry
(nub (imports ++ moduleImports mainmod))
return (nub (mainexports ++
concatMap (exportedFuncNames . moduleFuns) impprogs),
add2mainmodset (map moduleName impprogs),
mainmod:impprogs)
where
imports = nub [ mname | Import mname <- options ]
mainmodname = moduleName mainmod
initfuncs = [ fs | InitFuncs fs <- options ]
mainexports = exportedFuncNames (moduleFuns mainmod)
mainmodset = RBS.insert mainmodname $ RBS.empty (<)
add2mainmodset mnames = foldr RBS.insert mainmodset mnames
-- extract the names of all exported functions:
exportedFuncNames :: [FuncDecl] -> [QName]
exportedFuncNames funs =
map (\(Func name _ _ _ _)->name)
(filter (\(Func _ _ vis _ _)->vis==Public) funs)
-------------------------------------------------------------------------------
--- Adds all required functions to the program and load modules, if necessary.
--- @param required - list of potentially required functions
--- @param loadedmnames - set of already considered module names
--- @param progs - list of already loaded modules
--- @param functable - mapping from (loaded) function names to their definitions
--- @param loadedfnames - set of already loaded function names
--- @param loadedcnames - set of already required data constructors
--- @param loadedtnames - set of already required data constructors
--- @param fnames - list of function names to be analyzed for dependencies
--- @return (list of loaded modules, list of required function declarations,
--- set of required data constructors, set of required type names)
getCalledFuncs :: [RequiredSpec] -> RBS.SetRBT String -> [Prog]
-> RBT.TableRBT QName FuncDecl
-> RBS.SetRBT QName -> RBS.SetRBT QName -> RBS.SetRBT QName
-> [QName]
-> IO ([Prog],[FuncDecl],RBS.SetRBT QName,RBS.SetRBT QName)
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
loadedtnames ((m,f):fs)
| not (m `RBS.member` loadedmnames)
= do newmod <- readCurrentFlatCurry m
let reqnewfun = getRequiredInModule required m
getCalledFuncs required (RBS.insert m loadedmnames) (newmod:progs)
(extendFuncTable functable (moduleFuns newmod))
(foldr RBS.insert loadedfnames reqnewfun) loadedcnames
loadedtnames ((m,f):fs ++ reqnewfun)
| isNothing (RBT.lookup (m,f) functable)
= -- this must be a data constructor: ingore it since already considered
getCalledFuncs required loadedmnames progs
functable loadedfnames loadedcnames loadedtnames fs
| otherwise = do
let fdecl = fromJust (RBT.lookup (m,f) functable)
funcCalls = allFuncCalls fdecl
newFuncCalls = filter (\qn->not (qn `RBS.member` loadedfnames)) funcCalls
newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
consCalls = allConstructorsOfFunc fdecl
newConsCalls = filter (\qn->not (qn `RBS.member` loadedcnames)) consCalls
newtcons = allTypesOfFunc fdecl
(newprogs,newfuns,newcons, newtypes) <-
getCalledFuncs required loadedmnames progs functable
(foldr RBS.insert loadedfnames (newFuncCalls++newReqs))
(foldr RBS.insert loadedcnames consCalls)
(foldr RBS.insert loadedtnames newtcons)
(fs ++ newFuncCalls ++ newReqs ++ newConsCalls)
return (newprogs, fdecl:newfuns, newcons, newtypes)
-------------------------------------------------------------------------------
-- Operations to get all function calls, types,... in a function declaration:
-------------------------------------------------------------------------------
--- Get all function calls in a function declaration and remove duplicates.
--- @param funcDecl - a function declaration in FlatCurry
--- @return a list of all function calls
allFuncCalls :: FuncDecl -> [QName]
allFuncCalls (Func _ _ _ _ (External _)) = []
allFuncCalls (Func _ _ _ _ (Rule _ expr)) = nub (allFuncCallsOfExpr expr)
--- Get all function calls in an expression.
--- @param expr - an expression
--- @return a list of all function calls
allFuncCallsOfExpr :: Expr -> [QName]
allFuncCallsOfExpr (Var _) = []
allFuncCallsOfExpr (Lit _) = []
allFuncCallsOfExpr (Comb ctype fname exprs) = case ctype of
FuncCall -> fname:fnames
FuncPartCall _ -> fname:fnames
_ -> fnames
where
fnames = concatMap allFuncCallsOfExpr exprs
allFuncCallsOfExpr (Free _ expr) =
allFuncCallsOfExpr expr
allFuncCallsOfExpr (Let bs expr) =
concatMap (allFuncCallsOfExpr . snd) bs ++ allFuncCallsOfExpr expr
allFuncCallsOfExpr (Or expr1 expr2) =
allFuncCallsOfExpr expr1 ++ allFuncCallsOfExpr expr2
allFuncCallsOfExpr (Case _ expr branchExprs) =
allFuncCallsOfExpr expr ++
concatMap allFuncCallsOfBranchExpr branchExprs
allFuncCallsOfExpr (Typed expr _) = allFuncCallsOfExpr expr
--- Get all function calls in a branch expression in case expressions.
--- @param branchExpr - a branch expression
--- @return a list of all function calls
allFuncCallsOfBranchExpr :: BranchExpr -> [QName]
allFuncCallsOfBranchExpr (Branch _ expr) = allFuncCallsOfExpr expr
--- Get all data constructors in a function declaration.
allConstructorsOfFunc :: FuncDecl -> [QName]
allConstructorsOfFunc (Func _ _ _ _ (External _)) = []
allConstructorsOfFunc (Func _ _ _ _ (Rule _ expr)) = allConsOfExpr expr
--- Get all data constructors in an expression.
allConsOfExpr :: Expr -> [QName]
allConsOfExpr (Var _) = []
allConsOfExpr (Lit _) = []
allConsOfExpr (Comb ctype cname exprs) = case ctype of
ConsCall -> cname:cnames
ConsPartCall _ -> cname:cnames
_ -> cnames
where
cnames = unionMap allConsOfExpr exprs
allConsOfExpr (Free _ expr) =
allConsOfExpr expr
allConsOfExpr (Let bs expr) =
union (unionMap (allConsOfExpr . snd) bs) (allConsOfExpr expr)
allConsOfExpr (Or expr1 expr2) =
union (allConsOfExpr expr1) (allConsOfExpr expr2)
allConsOfExpr (Case _ expr branchExprs) =
union (allConsOfExpr expr) (unionMap consOfBranch branchExprs)
where
consOfBranch (Branch (LPattern _) e) = allConsOfExpr e
consOfBranch (Branch (Pattern c _) e) = union [c] (allConsOfExpr e)
allConsOfExpr (Typed expr _) = allConsOfExpr expr
--- Get all type constructors in a function declaration.
allTypesOfFunc :: FuncDecl -> [QName]
allTypesOfFunc (Func _ _ _ texp _) = allTypesOfTExpr texp
--- Get all data constructors in an expression.
allTypesOfTExpr :: TypeExpr -> [QName]
allTypesOfTExpr (TVar _) = []
allTypesOfTExpr (FuncType texp1 texp2) =
union (allTypesOfTExpr texp1) (allTypesOfTExpr texp2)
allTypesOfTExpr (TCons tcons args) =
union [tcons] (unionMap allTypesOfTExpr args)
allTypesOfTExpr (ForallType _ texp) = allTypesOfTExpr texp
unionMap :: Eq b => (a -> [b]) -> [a] -> [b]
unionMap f = foldr union [] . map f
-------------------------------------------------------------------------------
-- Functions to get direct access to some data inside a datatype:
-------------------------------------------------------------------------------
--- Extracts the function name of a function declaration.
functionName :: FuncDecl -> QName
functionName (Func name _ _ _ _) = name
--- Extracts the constructor name of a constructor declaration.
consName :: ConsDecl -> QName
consName (Cons name _ _ _) = name
--- Extracts the constructor name of a newtype constructor declaration.
newConsName :: NewConsDecl -> QName
newConsName (NewCons name _ _) = name
--- Extracts the type name of a type declaration.
tconsName :: TypeDecl -> QName
tconsName (Type name _ _ _) = name
tconsName (TypeSyn name _ _ _) = name
tconsName (TypeNew name _ _ _) = name
--- Extracts the names of imported modules of a FlatCurry program.
moduleImports :: Prog -> [String]
moduleImports (Prog _ imports _ _ _) = imports
--- Extracts the types of a FlatCurry program.
moduleTypes :: Prog -> [TypeDecl]
moduleTypes (Prog _ _ types _ _) = types
--- Extracts the operators of a FlatCurry program.
moduleOps :: Prog -> [OpDecl]
moduleOps (Prog _ _ _ _ ops) = ops
--- Extracts the name of the Prog.
moduleName :: Prog -> String
moduleName (Prog name _ _ _ _) = name
--- Extracts the functions of the program.
moduleFuns :: Prog -> [FuncDecl]
moduleFuns (Prog _ _ _ funs _) = funs
-------------------------------------------------------------------------------
-- Functions for comparison:
-------------------------------------------------------------------------------
--- Compares two qualified names.
--- Returns True, if the first name is lexicographically smaller than
--- the second name using the leString function to compare String.
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = let cm = compare m1 m2
in cm == LT || (cm == EQ && n1 <= n2)
-------------------------------------------------------------------------------
-- I/O functions:
-------------------------------------------------------------------------------
-- Read a FlatCurry program (parse only if necessary):
readCurrentFlatCurry :: String -> IO Prog
readCurrentFlatCurry modname = do
putStr (modname++"...")
mbsrc <- lookupModuleSourceInLoadPath modname
case mbsrc of
Nothing -> error ("Curry file for module \""++modname++"\" not found!")
Just (moddir,progname) -> do
let fcyname = flatCurryFileName (moddir </> takeFileName modname)
fcyexists <- doesFileExist fcyname
if not fcyexists
then readFlatCurry modname >>= processPrimitives progname
else do
ctime <- getModificationTime progname
ftime <- getModificationTime fcyname
if ctime>ftime
then readFlatCurry progname >>= processPrimitives progname
else readFlatCurryFile fcyname >>= processPrimitives progname
-- read primitive specification and transform FlatCurry program accordingly:
processPrimitives :: String -> Prog -> IO Prog
processPrimitives progname prog = do
pspecs <- readPrimSpec (moduleName prog)
(stripCurrySuffix progname ++ ".pakcs")
return (mergePrimSpecIntoModule pspecs prog)
mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog
mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops
mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl]
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
maybe [Func name ar vis tp rule]
(\ (lib,entry) ->
if null entry
then []
else [Func name ar vis tp (External (lib++' ':entry))])
(lookup name trans)
readPrimSpec :: String -> String -> IO [(QName,QName)]
readPrimSpec mod xmlfilename = do
existsXml <- doesFileExist xmlfilename
if existsXml
then do --putStrLn $ "Reading specification '" ++ xmlfilename ++ "'..."
xmldoc <- readXmlFile xmlfilename
return (xml2primtrans mod xmldoc)
else return []
xml2primtrans :: String -> XmlExp -> [(QName,QName)]
xml2primtrans mod xe = case xe of
XElem "primitives" [] primitives -> map xml2prim primitives
_ -> error $ "FlatCurry.Compact.xml2primtrans: unexpected document:\n" ++
showXmlDoc xe
where
xml2prim xelem = case xelem of
XElem "primitive" (("name",fname):_) [XElem "entry" [] xfun] ->
((mod,fname), (mod, textOfXml xfun))
XElem "primitive" (("name",fname):_) -- old format
[XElem "library" [] xlib, XElem "entry" [] xfun] ->
((mod,fname), (textOfXml xlib,textOfXml xfun))
XElem "ignore" (("name",fname):_) [] -> ((mod,fname), ("",""))
_ -> error $ "FlatCurry.Compact.xml2prim: unexpected document\n" ++
showXmlDoc xelem
-------------------------------------------------------------------------------
|