b5267d06f94587a8e513b9c91ea1ce9d8eb80917
[nofib.git] / real / anna / Main.hs
1
2 --==========================================================--
3 --=== Main module Main.hs ===--
4 --==========================================================--
5
6 module Main where
7 import BaseDefs
8 import Utils
9 import MyUtils
10 import Parser2
11 import PrettyPrint
12 import LambdaLift5
13 import TypeCheck5
14 import EtaAbstract
15 import StrictAn6
16 import ReadTable
17
18 import System -- partain: for 1.3
19 import Char(isDigit)
20
21 --==========================================================--
22 --
23 maBaseTypes :: TcTypeEnv
24
25 maBaseTypes
26 = [
27 ("_not", Scheme [] (TArr tcBool tcBool)),
28 ("_+", Scheme [] (TArr tcInt (TArr tcInt tcInt))),
29 ("_-", Scheme [] (TArr tcInt (TArr tcInt tcInt))),
30 ("_*", Scheme [] (TArr tcInt (TArr tcInt tcInt))),
31 ("_/", Scheme [] (TArr tcInt (TArr tcInt tcInt))),
32 ("_%", Scheme [] (TArr tcInt (TArr tcInt tcInt))),
33
34 ("_<", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
35 ("_<=", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
36 ("_==", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
37 ("_~=", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
38 ("_>=", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
39 ("_>", Scheme [] (TArr tcInt (TArr tcInt tcBool))),
40
41 ("_|", Scheme [] (TArr tcBool (TArr tcBool tcBool))),
42 ("_&", Scheme [] (TArr tcBool (TArr tcBool tcBool))),
43 ("_#", Scheme [] (TArr tcBool (TArr tcBool tcBool)))
44 -- *** parallel or *** ---
45 ]
46
47
48 --==========================================================--
49 --
50 maBaseAnns :: AList Naam (HExpr Naam)
51
52 maBaseAnns
53 = [
54 ("_not", strictUnaryFunc ),
55 ("_+", strictBinaryFunc ),
56 ("_-", strictBinaryFunc ),
57 ("_*", strictBinaryFunc ),
58 ("_/", strictBinaryFunc ),
59 ("_%", strictBinaryFunc ),
60 ("_<", strictBinaryFunc ),
61 ("_<=", strictBinaryFunc ),
62 ("_==", strictBinaryFunc ),
63 ("_~=", strictBinaryFunc ),
64 ("_>=", strictBinaryFunc ),
65 ("_>", strictBinaryFunc ),
66 ("_|", strictBinaryFunc ),
67 ("_&", strictBinaryFunc ),
68 ("_#", nonLambdaDefinableFunc ),
69 ("False", HPoint One),
70 ("True", HPoint One)
71 ]
72 where
73 strictUnaryFunc
74 = HPoint (Rep (RepTwo
75 (Min1Max0 1 [MkFrel [One]]
76 [MkFrel [Zero]])))
77 strictBinaryFunc
78 = HPoint (Rep (RepTwo
79 (Min1Max0 2 [MkFrel [One, One]]
80 [MkFrel [Zero, One], MkFrel [One, Zero]])))
81 nonLambdaDefinableFunc
82 = HPoint (Rep (RepTwo
83 (Min1Max0 2 [MkFrel [Zero, One], MkFrel [One, Zero]]
84 [MkFrel [Zero, Zero]])))
85
86
87 --==========================================================--
88 --
89 maKludgeFlags :: [Flag] -> [Flag]
90
91 maKludgeFlags flags
92 = if DryRun `elem` flags
93 then bdDryRunSettings ++ flags ++ bdDefaultSettings
94 else flags ++ bdDefaultSettings
95
96
97 --==========================================================--
98 --
99 maStrictAn :: AList Domain Int -> [Flag] -> [Char] -> [Char]
100
101 maStrictAn table flagsInit fileName
102 = "\nJules's Strictness Analyser, version 0.400" ++
103 "\nCopyright (c) Julian Seward 1992" ++
104 (let n = length table in
105 mySeq n ("\nRead " ++ show n ++ " lattice sizes.\n")) ++
106 "\n\n=============" ++
107 "\n=== Input ===" ++
108 "\n=============\n" ++
109 (ppPrintParsed prog) ++
110 "\n\n\n=============" ++
111 "\n=== Types ===" ++
112 "\n=============\n" ++
113 prettyTypes ++
114 "\n\n" ++
115 strictAnResults ++ "\n"
116 where
117 flags = maKludgeFlags flagsInit
118 -- call the strictness analyser if required
119 strictAnResults
120 = if Typecheck `notElem` flags
121 then
122 saMain
123 (eaEtaAbstract typedTree) darAug fullEnvAug pseudoParams
124 maBaseAnns tdsAug flags table
125 else ""
126
127 -- call the parser (never returns if cannot parse)
128 (dar, (tds, expr)) = paParse fileName
129
130 (progAfterLL, pseudoParams)
131 = llMain builtInNames expr doPretty
132 builtInNames = map first maBaseAnns
133 prog = (tds, progAfterLL)
134 doPretty = NoPretty `notElem` flags
135
136 -- call the typechecker, fish out the resulting components
137 (prettyTypes, typedTree, fullEnv)
138 = f (tcCheck maBaseTypes ([1],[0]) prog)
139 f (words, (Fail m))
140 = panic "maStrictAn: Typecheck failed -- cannot proceed."
141 f (words, Ok (rootTree, fullEnv))
142 = (words, rootTree, fullEnv)
143
144 -- augment type definitions to cover built-in type bool
145 tdsAug = [("bool", [], [("True", []), ("False", [])])] ++ tds
146 darAug = [(False, ["bool"])] ++ dar
147
148 -- augment type environment to include built-in types
149 fullEnvAug = fullEnv ++ map2nd deScheme maBaseTypes
150 deScheme (Scheme _ texpr) = texpr
151
152 {-
153 --==========================================================--
154 --
155 anna :: [Flag] -> String -> Dialogue
156
157 anna flags name
158 = getEnv "ANNADIR" noANNADIR (\anna_dir ->
159 readFile (anna_dir++"/anna_table") noTable (\tablestr ->
160 let table = rtReadTable tablestr in
161 readFile (name++".cor") noFile (\str ->
162 let result = maStrictAn table flags str in
163 appendChan stdout result writeFails done)))
164 where
165 noANNADIR err = abandon "ANNADIR not defined"
166 noTable err = abandon "Cannot find $ANNADIR/table"
167 noFile err = abandon ("Can't open "++name++".cor")
168 writeFails (WriteError s) = abandon s
169 abandon s = appendChan stdout s abort done
170 getEnv envvar fail succ = succ "/home/r62/users/sewardj/Bin"
171 twords n = "\nRead " ++ show n ++ " lattice sizes.\n"
172 -}
173
174
175 --==========================================================--
176 --
177 --main :: [Response] -> [Request]
178
179 main :: IO ()
180
181 main = do
182 raw_args <- getArgs
183 let cmd_line_args = maGetFlags raw_args
184 anna_dir <- getEnv "ANNADIR"
185 tableStr <- readFile (anna_dir++"/anna_table")
186 file_contents <- getContents
187 let table = rtReadTable tableStr
188 putStr (maStrictAn table cmd_line_args file_contents)
189
190 {- OLD 1.2
191 main resps
192 = [
193 GetArgs,
194 fr 0 (GetEnv "ANNADIR"),
195 fr 1 (ReadFile ),
196 fr 2 (ReadChan stdin),
197 fr 3 (AppendChan stdout )
198 ] ++ fr 4 [] (maStrictAn table cmd_line_args file_contents)
199 where
200 cmd_line_args = case (resps ## 0) of
201 StrList ss -> maGetFlags ss
202 _ -> panic "GetArgs request failed"
203
204 anna_dir = case (mySeq cmd_line_args (resps ## 1)) of
205 Str s -> s
206 _ -> myFail "Environment variable \"ANNADIR\" is not set."
207
208 tableStr = case (mySeq anna_dir (resps ## 2)) of
209 Str s -> s
210 _ -> myFail ("Can't read " ++ anna_dir ++ "/anna_table")
211
212 file_contents = case (mySeq (head tableStr) (resps ## 3)) of
213 Str s -> s
214 _ -> panic "ReadChan request failed"
215
216 --append_res = case (mySeq (head file_contents) (resps ## 4)) of
217 -- Success -> (42 :: Int)
218 -- _ -> panic "AppendChan request failed"
219
220 fr n x = case resps ## n of
221 Success -> x
222 _ -> x
223
224 table = rtReadTable tableStr
225 -}
226
227 --==========================================================--
228 --
229 maGetFlags :: [String] -> [Flag]
230
231 maGetFlags [] = []
232 maGetFlags ("-fTypecheck" :fs) = Typecheck : maGetFlags fs
233 maGetFlags ("-fSimp" :fs) = Simp : maGetFlags fs
234 maGetFlags ("-fNoCaseOpt" :fs) = NoCaseOpt : maGetFlags fs
235 maGetFlags ("-fShowHExpr" :fs) = ShowHExpr : maGetFlags fs
236 maGetFlags ("-fNoPretty" :fs) = NoPretty : maGetFlags fs
237 maGetFlags ("-fNoFormat" :fs) = NoFormat : maGetFlags fs
238 maGetFlags ("-fNoBaraki" :fs) = NoBaraki : maGetFlags fs
239 maGetFlags ("-fSimpleInv" :fs) = SimpleInv : maGetFlags fs
240 maGetFlags ("-fForceAll" :fs) = ForceAll : maGetFlags fs
241 maGetFlags ("-fDryRun" :fs) = DryRun : maGetFlags fs
242
243 maGetFlags
244 (('-':'f':'P':'o':'l':'y':'L':'i':'m':f):fs)
245 = (PolyLim (paNumval (filter isDigit f))): maGetFlags fs
246
247 maGetFlags
248 (('-':'f':'L':'o':'w':'e':'r':'L':'i':'m':f):fs)
249 = (LowerLim (paNumval (filter isDigit f))): maGetFlags fs
250
251 maGetFlags
252 (('-':'f':'U':'p':'p':'e':'r':'L':'i':'m':f):fs)
253 = (UpperLim (paNumval (filter isDigit f))): maGetFlags fs
254
255 maGetFlags
256 (('-':'f':'S':'c':'a':'l':'e':'U':'p':f):fs)
257 = (ScaleUp (paNumval (filter isDigit f))): maGetFlags fs
258
259 maGetFlags (other:_) = myFail ("Unknown flag: " ++ other ++ maUsage )
260
261
262 --==========================================================--
263 --
264 maUsage :: String
265
266 maUsage
267 = concat
268 [
269 "\n\nUsage: Anna400 [lmlflags -] [flags] < corefile",
270 "\n",
271 "\nAllowable flags are:",
272 "\n -fTypecheck don't do strictness analysis",
273 "\n -fSimp simplify abstract expressions",
274 "\n -fNoCaseOpt don't do case-of-case optimisation",
275 "\n -fShowHExpr show abstract expressions",
276 "\n -fNoPretty don't clean up after lambda lifting",
277 "\n -fNoFormat don't prettily format first-order output",
278 "\n -fNoBaraki don't use Baraki generalisation",
279 "\n -fSimpleInv use mindless inverses",
280 "\n -fForceAll force all thunks before analysis",
281 "\n -fDryRun trial run so as to check lattice table is ok",
282 "\n -fPolyLimN set generalisation limit to `N' (default 10000)",
283 "\n -fLowerLimN set lower lattice threshold to `N' (default 0)",
284 "\n -fUpperLimN set upper lattice threshold to `N' (default 1000000)",
285 "\n -fScaleUpN set scaleup ratio to N/10 (default 20)",
286 "\nDefault settings are opposite to those listed.\n"
287 ]
288
289
290 --==========================================================--
291 --=== end Main.hs ===--
292 --==========================================================--