Commit 0229b0d9 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Modify for base-2.0.0

parent 43515b19
{
"name": "nonstrictunif-optimize",
"version": "0.0.1",
"version": "2.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Linearity optimizer for functional patterns",
"category": [ "Optimization" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
"flatcurry": ">= 0.0.1"
"flatcurry": ">= 3.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 1.14.0"
"pakcs": ">= 2.0.0"
},
"executable": {
"name": "curry-nonstrictopt",
......
......@@ -10,10 +10,10 @@ module CurryBrowseAnalysis.Dependency
dependencyGraphs, localDependencyGraphs) where
import FlatCurry.Types
import List
import SetRBT
import Sort(leqString)
import Maybe(fromJust)
import Data.List
import qualified Data.Set.RBTree as Set
import Data.Maybe (fromJust)
import Sort (leqString)
-- Generic global function analysis where the property of each function is a combination
-- of a property of the function and all its dependent functions.
......@@ -51,29 +51,29 @@ externalDependent funcs =
-- Result: a list of pairs of qualified functions names and the corresponding
-- called functions
indirectlyDependent :: [FuncDecl] -> [(QName,[QName])]
indirectlyDependent funs = map (\ (f,ds) -> (f,setRBT2list ds))
indirectlyDependent funs = map (\ (f,ds) -> (f,Set.toList ds))
(depsClosure (map directlyDependent funs))
-- list of direct dependencies for a function
callsDirectly :: FuncDecl -> [QName]
callsDirectly fun = setRBT2list (snd (directlyDependent fun))
callsDirectly fun = Set.toList (snd (directlyDependent fun))
-- set of direct dependencies for a function
directlyDependent :: FuncDecl -> (QName,SetRBT QName)
directlyDependent :: FuncDecl -> (QName,Set.SetRBT QName)
directlyDependent (Func f _ _ _ (Rule _ e)) = (f,funcSetOfExpr e)
directlyDependent (Func f _ _ _ (External _)) = (f,emptySet)
directlyDependent (Func f _ _ _ (External _)) = (f,Set.empty)
-- compute the transitive closure of all dependencies based on a list of
-- direct dependencies:
depsClosure :: [(QName,SetRBT QName)] -> [(QName,SetRBT QName)]
depsClosure directdeps = map (\(f,ds)->(f,closure ds (setRBT2list ds)))
depsClosure :: [(QName,Set.SetRBT QName)] -> [(QName,Set.SetRBT QName)]
depsClosure directdeps = map (\(f,ds)->(f,closure ds (Set.toList ds)))
directdeps
where
closure olddeps [] = olddeps
closure olddeps (f:fs) =
let newdeps = filter (\e->not (elemRBT e olddeps))
(setRBT2list (maybe emptySet id (lookup f directdeps)))
in closure (foldr insertRBT olddeps newdeps) (newdeps++fs)
let newdeps = filter (\e->not (Set.member e olddeps))
(Set.toList (maybe Set.empty id (lookup f directdeps)))
in closure (foldr Set.insert olddeps newdeps) (newdeps++fs)
-- Computes the list of all direct dependencies for all functions.
-- This is useful to represent the dependency graph for each function.
......@@ -83,8 +83,8 @@ depsClosure directdeps = map (\(f,ds)->(f,closure ds (setRBT2list ds)))
dependencyGraphs :: [FuncDecl] -> [(QName,[(QName,[QName])])]
dependencyGraphs funs =
let directdeps = map directlyDependent funs
in map (\(f,ds) -> (f,map (\g->(g,setRBT2list (fromJust (lookup g directdeps))))
(setRBT2list (insertRBT f ds))))
in map (\(f,ds) -> (f,map (\g->(g,Set.toList (fromJust (lookup g directdeps))))
(Set.toList (Set.insert f ds))))
(depsClosure directdeps)
-- Computes for all functions the list of all direct local dependencies, i.e.,
......@@ -98,42 +98,42 @@ localDependencyGraphs :: [FuncDecl] -> [(QName,[(QName,[QName])])]
localDependencyGraphs funs =
let directdeps = map directlyDependent funs
in map (\(f,ds) -> (f,map (\g->(g,if fst f == fst g
then setRBT2list (fromJust (lookup g directdeps))
then Set.toList (fromJust (lookup g directdeps))
else []))
(setRBT2list (insertRBT f ds))))
(Set.toList (Set.insert f ds))))
(localDepsClosure directdeps)
-- compute the transitive closure of all local dependencies based on a list of
-- direct dependencies:
localDepsClosure :: [(QName,SetRBT QName)] -> [(QName,SetRBT QName)]
localDepsClosure :: [(QName,Set.SetRBT QName)] -> [(QName,Set.SetRBT QName)]
localDepsClosure directdeps =
map (\(f,ds)->(f,closure (fst f) ds (setRBT2list ds))) directdeps
map (\(f,ds)->(f,closure (fst f) ds (Set.toList ds))) directdeps
where
closure _ olddeps [] = olddeps
closure mod olddeps (f:fs)
| mod == fst f -- f is local in this module: add dependencies
= let newdeps = filter (\e->not (elemRBT e olddeps))
(setRBT2list (maybe emptySet id (lookup f directdeps)))
in closure mod (foldr insertRBT olddeps newdeps) (newdeps++fs)
= let newdeps = filter (\e->not (Set.member e olddeps))
(Set.toList (maybe Set.empty id (lookup f directdeps)))
in closure mod (foldr Set.insert olddeps newdeps) (newdeps++fs)
| otherwise = closure mod olddeps fs
-- Gets a list of all functions (including partially applied functions)
-- called in an expression:
funcsInExpr :: Expr -> [QName]
funcsInExpr e = setRBT2list (funcSetOfExpr e)
funcsInExpr e = Set.toList (funcSetOfExpr e)
-- Gets the set of all functions (including partially applied functions)
-- called in an expression:
funcSetOfExpr :: Expr -> SetRBT QName
funcSetOfExpr (Var _) = emptySet
funcSetOfExpr (Lit _) = emptySet
funcSetOfExpr :: Expr -> Set.SetRBT QName
funcSetOfExpr (Var _) = Set.empty
funcSetOfExpr (Lit _) = Set.empty
funcSetOfExpr (Comb ct f es) =
if isConstructorComb ct then unionMap funcSetOfExpr es
else insertRBT f (unionMap funcSetOfExpr es)
else Set.insert f (unionMap funcSetOfExpr es)
funcSetOfExpr (Free _ e) = funcSetOfExpr e
funcSetOfExpr (Let bs e) = unionRBT (unionMap (funcSetOfExpr . snd) bs) (funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = unionRBT (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e) (unionMap funcSetOfBranch bs)
funcSetOfExpr (Let bs e) = Set.union (unionMap (funcSetOfExpr . snd) bs) (funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = Set.union (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = Set.union (funcSetOfExpr e) (unionMap funcSetOfBranch bs)
where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
funcSetOfExpr (Typed e _) = funcSetOfExpr e
......@@ -143,14 +143,7 @@ isConstructorComb ct = case ct of
ConsPartCall _ -> True
_ -> False
unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f
emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = leqString (m1++('.':n1)) (m2++('.':n2))
unionMap :: (a -> Set.SetRBT QName) -> [a] -> Set.SetRBT QName
unionMap f = foldr Set.union Set.empty . map f
-- end of Dependency
......@@ -8,8 +8,8 @@
module CurryBrowseAnalysis.Linearity(analyseRightLinearity,hasRightLinearRules,linearExpr) where
import FlatCurry.Types
import Maybe
import List
import Data.Maybe
import Data.List
import CurryBrowseAnalysis.Dependency(analyseWithDependencies)
------------------------------------------------------------------------------
......@@ -47,27 +47,27 @@ linearVariables (Comb _ f es)
| f==("Prelude","?") && length es == 2 -- treat "?" as Or:
= linearVariables (Or (head es) (head (tail es)))
| otherwise
= mapMMaybe linearVariables es >>- \esvars ->
= mapM linearVariables es >>= \esvars ->
let vars = concat esvars
in if nub vars == vars
then Just vars
else Nothing
linearVariables (Free vs e) =
linearVariables e >>- \evars -> Just (evars \\ vs)
linearVariables e >>= \evars -> Just (evars \\ vs)
linearVariables (Let bs e) =
mapMMaybe linearVariables (map snd bs) >>- \bsvars ->
linearVariables e >>- \evars ->
mapM linearVariables (map snd bs) >>= \bsvars ->
linearVariables e >>= \evars ->
let vars = concat (evars : bsvars)
in if nub vars == vars
then Just (vars \\ (map fst bs))
else Nothing
linearVariables (Or e1 e2) =
linearVariables e1 >>- \e1vars ->
linearVariables e2 >>- \e2vars ->
linearVariables e1 >>= \e1vars ->
linearVariables e2 >>= \e2vars ->
Just (union e1vars e2vars)
linearVariables (Case _ e bs) =
linearVariables e >>- \evars ->
mapMMaybe linearVariables (map (\ (Branch _ be) -> be) bs) >>- \bsvars ->
linearVariables e >>= \evars ->
mapM linearVariables (map (\ (Branch _ be) -> be) bs) >>= \bsvars ->
let vars = foldr union [] (map (\ (branch,bsv) -> bsv \\ patternVars branch)
(zip bs bsvars)) ++ evars
in if nub vars == vars
......
......@@ -8,16 +8,18 @@
--- @version January 2006
------------------------------------------------------------------------
import Directory(doesFileExist,renameFile)
import FileGoodies
import System.Directory (doesFileExist, renameFile)
import System.FilePath (dropExtension)
import System.IO
import System.Process (exitWith)
import System.Environment (getArgs)
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import ReadShowTerm (showTerm)
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Read
import IO
import List(intersperse)
import Maybe(catMaybes)
import ReadShowTerm(showTerm)
import System
import CurryBrowseAnalysis.Linearity
import CurryBrowseAnalysis.Dependency
......@@ -28,7 +30,7 @@ import CurryBrowseAnalysis.Dependency
main = do
args <- getArgs
case args of
[prog] -> optimizeNonstrictEqualityInModuleIfNecessary (stripSuffix prog)
[prog] -> optimizeNonstrictEqualityInModuleIfNecessary (dropExtension prog)
_ -> putStrLn $ "ERROR: Illegal arguments: " ++
concat (intersperse " " args) ++ "\n" ++
"Usage: OptNonStrict.state <module_name>"
......@@ -153,7 +155,7 @@ optimizeExp funinfo@(depinfo,lininfo) (Comb ct f es)
| 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) =
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) =
......@@ -191,4 +193,3 @@ 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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment