KiCS-0.8.9: src/lib/Curry/Module/CompactFlatCurry.curry
------------------------------------------------------------------------------
--- This module contains functions to reduce the size of FlatCurry programs
--- by combining the main module and all imports into a single program
--- that contains only the functions directly or indirectly called from
--- a set of main functions.
---
--- @author Michael Hanus, Carsten Heine
--- @version June 2009
------------------------------------------------------------------------------
module CompactFlatCurry(generateCompactFlatCurryFile,computeCompactFlatCurry,
Option(..),RequiredSpec,requires,alwaysRequired,
defaultRequired) where
import FlatCurry
import SetRBT
import TableRBT
import Maybe
import List(nub,union)
import FileGoodies
import Directory
import Sort(cmpString,leqString)
import XML
import Distribution(getLoadPathForFile)
import Time(clockTimeToInt)
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
isMainOption o = case o of
Main _ -> True
_ -> False
getMainFuncFromOptions :: [Option] -> String
getMainFuncFromOptions (o:os) =
case o of
Main f -> f
_ -> getMainFuncFromOptions os
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
--- (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 = "Prelude"
--- Get functions that are required in a module w.r.t.
--- a requirement specification.
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 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 =
[(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
done
--- 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 (emptyTableRBT leqQName)
(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 insertRBT (emptySetRBT leqQName) initreqfuncs)
(emptySetRBT leqQName) (emptySetRBT leqQName)
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 `elemRBT` 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 :: SetRBT QName -> [TypeDecl] -> SetRBT QName
requiredDatatypes tcnames tdecls =
let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
in if null newtcons
then tcnames
else requiredDatatypes (foldr insertRBT tcnames newtcons) tdecls
-- Extract the new type constructors (w.r.t. a given set) contained in a
-- type declaration:
newTypeConsOfTDecl :: SetRBT QName -> TypeDecl -> [QName]
newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
if tcons `elemRBT` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
if tcons `elemRBT` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames))
(concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps)
cdecls)
else []
-- Extend set of type constructor with type constructors of data declarations
-- contain some constructor.
extendTConsWithConsType :: SetRBT QName -> SetRBT QName -> [TypeDecl]
-> SetRBT QName
extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
extendTConsWithConsType cnames (insertRBT tname tcons) tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
if tname `elem` defaultRequiredTypes ||
any (\cdecl->consName cdecl `elemRBT` cnames) cdecls
then extendTConsWithConsType cnames (insertRBT tname tcons) tds
else extendTConsWithConsType cnames tcons tds
-- Extend function table (mapping from qualified names to function declarations)
-- by some new function declarations:
extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl]
-> TableRBT QName FuncDecl
extendFuncTable ftable fdecls =
foldr (\f t -> updateRBT (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],SetRBT String,[Prog])
requiredInCompactProg mainmod options
| not (null initfuncs)
= do impprogs <- mapIO readCurrentFlatCurry imports
return (concat initfuncs, add2mainmodset imports, mainmod:impprogs)
| Exports `elem` options
= do impprogs <- mapIO 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 <- mapIO readCurrentFlatCurry imports
return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs)
else error $ "CompactFlat: Cannot find main function \""++func++"\"!"
| otherwise
= do impprogs <- mapIO 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 = insertRBT mainmodname (emptySetRBT leqString)
add2mainmodset mnames = foldr insertRBT 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] -> SetRBT String -> [Prog]
-> TableRBT QName FuncDecl
-> SetRBT QName -> SetRBT QName -> SetRBT QName
-> [QName]
-> IO ([Prog],[FuncDecl],SetRBT QName,SetRBT QName)
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
loadedtnames ((m,f):fs)
| not (elemRBT m loadedmnames)
= do newmod <- readCurrentFlatCurry m
let reqnewfun = getRequiredInModule required m
getCalledFuncs required (insertRBT m loadedmnames) (newmod:progs)
(extendFuncTable functable (moduleFuns newmod))
(foldr insertRBT loadedfnames reqnewfun) loadedcnames
loadedtnames ((m,f):fs ++ reqnewfun)
| lookupRBT (m,f) functable == Nothing
= -- 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 (lookupRBT (m,f) functable)
funcCalls = allFuncCalls fdecl
newFuncCalls = filter (\qn->not (elemRBT qn loadedfnames)) funcCalls
newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
consCalls = allConstructorsOfFunc fdecl
newConsCalls = filter (\qn->not (elemRBT qn loadedcnames)) consCalls
newtcons = allTypesOfFunc fdecl
(newprogs,newfuns,newcons, newtypes) <-
getCalledFuncs required loadedmnames progs functable
(foldr insertRBT loadedfnames (newFuncCalls++newReqs))
(foldr insertRBT loadedcnames consCalls)
(foldr insertRBT 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
--- 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)
--- 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)
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 type name of a type declaration.
tconsName :: TypeDecl -> QName
tconsName (Type name _ _ _) = name
tconsName (TypeSyn 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 = cmpString m1 m2
in cm==LT || (cm==EQ && leqString n1 n2)
-------------------------------------------------------------------------------
-- I/O functions:
-------------------------------------------------------------------------------
-- Read a FlatCurry program (parse only if necessary):
readCurrentFlatCurry :: String -> IO Prog
readCurrentFlatCurry modname = do
putStr (modname++"...")
progname <- findSourceFileInLoadPath modname
fcyexists <- doesFileExist (flatCurryFileName progname)
if not fcyexists
then readFlatCurry progname >>= processPrimitives progname
else do
ctime <- getSourceModificationTime progname
ftime <- getModificationTime (flatCurryFileName progname)
if clockTimeToInt ctime > clockTimeToInt ftime
then readFlatCurry progname >>= processPrimitives progname
else readFlatCurryFile (flatCurryFileName progname)
>>= processPrimitives progname
getSourceModificationTime progname = do
lexists <- doesFileExist (progname++".lcurry")
if lexists then getModificationTime (progname++".lcurry")
else getModificationTime (progname++".curry")
-- add a directory name for a Curry source file by looking up the
-- current load path (CURRYPATH):
findSourceFileInLoadPath modname = do
loadpath <- getLoadPathForFile modname
mbfname <- lookupFileInPath (baseName modname) [".lcurry",".curry"] loadpath
maybe (error ("Curry file for module \""++modname++"\" not found!"))
(return . stripSuffix)
mbfname
-- read primitive specification and transform FlatCurry program accordingly:
processPrimitives :: String -> Prog -> IO Prog
processPrimitives progname prog = do
pspecs <- readPrimSpec (moduleName prog) (progname++".prim_c2p")
return (mergePrimSpecIntoModule pspecs prog)
mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
let fname = lookup name trans in
if fname==Nothing
then [Func name ar vis tp rule]
else let Just (lib,entry) = fname
in if null entry
then []
else [Func name ar vis tp (External (lib++' ':entry))]
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 mod (XElem "primitives" [] primitives) = map xml2prim primitives
where
xml2prim (XElem "primitive" (("name",fname):_)
[XElem "library" [] xlib, XElem "entry" [] xfun]) =
((mod,fname),(textOfXml xlib,textOfXml xfun))
xml2prim (XElem "ignore" (("name",fname):_) []) = ((mod,fname),("",""))
-------------------------------------------------------------------------------