1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
------------------------------------------------------------------------
--- Linearity optimizer for function patterns and non-strict unification
---
--- Replace occurrences of (fp =:<= x) by (fp =:<<= x) if the function
--- pattern fp always evaluates to a linear term.
---
--- @author Michael Hanus
--- @version November 2020
------------------------------------------------------------------------

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