|
sourcecode:
|
import Data.List ( intersperse )
import Data.Maybe ( catMaybes )
import System.Environment ( getArgs )
import System.IO
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Read
import ReadShowTerm ( showTerm )
import System.CurryPath ( stripCurrySuffix )
import System.Directory ( doesFileExist, renameFile )
import System.Process ( exitWith )
import CurryBrowseAnalysis.Linearity
import CurryBrowseAnalysis.Dependency
-- Example: optimizeNonstrictEqualityInModule "last"
-- Check arguments and call main function:
main = do
args <- getArgs
case args of
[prog] -> optimizeNonstrictEqualityInModuleIfNecessary
(stripCurrySuffix prog)
_ -> putStrLn $ "ERROR: Illegal arguments: " ++
concat (intersperse " " args) ++ "\n" ++
"Usage: curry-nonstrictopt <module_name>"
optimizeNonstrictEqualityInModuleIfNecessary prog = do
let progfcy = flatCurryFileName prog
optimized <- hasCommentOption progfcy "-fpopt"
if optimized
then putStrLn ("Program '"++progfcy++"' already optimized")
else optimizeNonstrictEqualityInModule prog
optimizeNonstrictEqualityInModule prog = do
progs <- readFlatCurryWithImports prog
storeOptimizedModule prog
(optimizeNonstrictEquality (concatMap funcsOfProg progs) (head progs))
storeOptimizedModule prog ([],nsu,lnsu,optmod) = do
let progfcy = flatCurryFileName prog
optfcy = prog++"_lo.fcy"
writeFile optfcy ("{- -fpopt -}\n" ++ showTerm optmod)
renameFile optfcy progfcy
putStrLn (show nsu ++ " non-strict unifications found, " ++ show lnsu ++
" optimized into linear unifications.")
putStrLn ("Optimized program written to '"++progfcy++"'")
storeOptimizedModule prog ((cyc:cycs),_,_,_) = do
putStrLn $ "ERROR: illegal use of function patterns in program \""++prog++"\"!"
putStrLn $ "The following functions are defined by self-dependent function patterns:"
putStrLn (concatMap (\ (m,f)->m++"."++f++" ") (cyc:cycs))
exitWith 1
------------------------------------------------------------------------------
-- Checks whether a file exists and the file starts with a comment of the form
-- "{- ...-}" and contains the second argument as a word in the comment:
hasCommentOption :: String -> String -> IO Bool
hasCommentOption filename option = do
existsfile <- doesFileExist filename
if existsfile
then do cwords <- readWordsInFirstCommentLine filename
return (option `elem` cwords)
else return False
-- Read the words in the first comment line and return them, if the file
-- start with a comment, otherwise return the empty list:
readWordsInFirstCommentLine :: String -> IO [String]
readWordsInFirstCommentLine filename = do
fh <- openFile filename ReadMode
c1 <- hGetChar fh
c2 <- hGetChar fh
if c1=='{' && c2=='-'
then do cs <- getCommentString fh
hClose fh
return (words cs)
else do hClose fh
return []
getCommentString fh = do
c <- hGetChar fh
if c=='-' then getCommentString' fh
else do cs <- getCommentString fh
return (c:cs)
getCommentString' fh = do
c <- hGetChar fh
if c=='}' then return []
else if c=='-'
then do cs <- getCommentString' fh
return ('-':cs)
else do cs <- getCommentString fh
return ('-':c:cs)
------------------------------------------------------------------------------
-- Replace "=:<=" by "=:<<=" if the left argument is a linear term with
-- linear functions.
-- The first argument is the list of all functions occuring in the program,
-- the second argument is the current module to be optimized.
-- The result is a tuple containing the number of "=:<=" occurring in the
-- module, the number of the optimized occurrences, and the optimized module.
optimizeNonstrictEquality :: [FuncDecl] -> Prog -> ([QName],Int,Int,Prog)
optimizeNonstrictEquality allfuns (Prog mod imps ts funs ops) =
let (cycfuns,nsus,lnsus,optfs) =
unzip4 (map (optimizeFun (indirectlyDependent allfuns)
(analyseRightLinearity allfuns)) funs)
in (catMaybes cycfuns, sum nsus, sum lnsus, Prog mod imps ts optfs ops)
-- Optimize a single function definition.
-- The first argument is the list of all functions together with a flag
-- whether they are defined by right-linear rules and functions.
-- The result is (n,l,fd) where n is the number of non-strict equalities
-- in the function definition, l is the number of optimized linear
-- non-strict equalities, and fd is the optimized function definition.
optimizeFun :: [(QName,[QName])] -> [(QName,Bool)] -> FuncDecl
-> (Maybe QName,Int,Int,FuncDecl)
optimizeFun depinfo lininfo (Func qn ar vis ty (Rule vs e)) =
let (cyc,nsu,lnsu,opte) = optimizeExp (isDependent depinfo qn,lininfo) e
in (if cyc then Just qn else Nothing, nsu, lnsu,
Func qn ar vis ty (Rule vs opte))
optimizeFun _ _ (Func qn ar vis ty (External e)) =
(Nothing,0,0,Func qn ar vis ty (External e))
-- does a function (argument 3) depend on another function (argument 2)
-- (w.r.t. dependencies given in argument 1)?
isDependent :: [(QName,[QName])] -> QName -> QName -> Bool
isDependent deps dependonfun fname =
dependonfun `elem` (maybe [] id (lookup fname deps))
optimizeExp :: (QName->Bool, [(QName,Bool)]) -> Expr -> (Bool,Int,Int,Expr)
optimizeExp _ (Var i) = (False,0,0,Var i)
optimizeExp _ (Lit l) = (False,0,0,Lit l)
optimizeExp funinfo@(depinfo,lininfo) (Comb ct f es)
| f==("Prelude","=:<=") && length es == 2
= let e1 = head es
e2 = head (tail es)
(cyc1,nsu1,lnsu1,opte1) = optimizeExp funinfo e1
(cyc2,nsu2,lnsu2,opte2) = optimizeExp funinfo e2
cyclicFP = cyc1 || cyc2 || any depinfo (funcsInExpr e1)
in if linearExpr e1 && onlyLinearFunctions lininfo e1
then (cyclicFP,nsu1+nsu2+1,lnsu1+lnsu2+1,
Comb ct ("Prelude","=:<<=") [opte1,opte2])
else (cyclicFP,nsu1+nsu2+1,lnsu1+lnsu2,
Comb ct ("Prelude","=:<=") [opte1,opte2])
| otherwise
= let (cycs,nsus,lnsus,optes) = unzip4 (map (optimizeExp funinfo) es)
in (or cycs, sum nsus, sum lnsus, Comb ct f optes)
optimizeExp funinfo (Free vs e) =
let (cyc,nsu,lnsu,opte) = optimizeExp funinfo e
in (cyc,nsu,lnsu,Free vs opte)
optimizeExp funinfo (Let bs exp) =
let (cyc,nsu,lnsu,optexp) = optimizeExp funinfo exp
(bvs,bes) = unzip bs
(cycs,nsus,lnsus,optbes) = unzip4 (map (optimizeExp funinfo) bes)
in (or (cyc:cycs), nsu + sum nsus, lnsu + sum lnsus,
Let (zip bvs optbes) optexp)
optimizeExp funinfo (Or e1 e2) =
let (cyc1,nsu1,lnsu1,opte1) = optimizeExp funinfo e1
(cyc2,nsu2,lnsu2,opte2) = optimizeExp funinfo e2
in (cyc1||cyc2, nsu1+nsu2, lnsu1+lnsu2, Or opte1 opte2)
optimizeExp funinfo (Case ct exp bs) =
let (cyc,nsu,lnsu,optexp) = optimizeExp funinfo exp
(cycs,nsus,lnsus,optbs) = unzip4 (map optimizeBranch bs)
in (or (cyc:cycs), nsu + sum nsus, lnsu + sum lnsus, Case ct optexp optbs)
where
optimizeBranch (Branch patt be) =
let (ncyc,nsub,lnsub,optbe) = optimizeExp funinfo be
in (ncyc,nsub,lnsub,Branch patt optbe)
-- does an expression contains only functions defined by right-linear rules
-- and functions?
onlyLinearFunctions :: [(QName,Bool)] -> Expr -> Bool
onlyLinearFunctions li e = all isRightLinearDefined (funcsInExpr e)
where
isRightLinearDefined fun = maybe False id (lookup fun li)
-- goodies:
funcsOfProg (Prog _ _ _ funcs _) = funcs
sum = foldl (+) 0
unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
unzip4 [] = ([],[],[],[])
unzip4 ((x,y,z,v):ts) = (x:xs,y:ys,z:zs,v:vs) where (xs,ys,zs,vs) = unzip4 ts
|