[project @ 1996-11-26 15:44:35 by dnt]
[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 --main :: [Response] -> [Request]
155
156 main :: IO ()
157
158 main = do
159 raw_args <- getArgs
160 let cmd_line_args = maGetFlags raw_args
161 anna_dir <- getEnv "ANNADIR"
162 tableStr <- readFile (anna_dir ++ "/anna_table")
163 file_contents <- getContents
164 let table = rtReadTable tableStr
165 putStr (maStrictAn table cmd_line_args file_contents)
166
167
168 --==========================================================--
169 --
170 maGetFlags :: [String] -> [Flag]
171
172 maGetFlags [] = []
173 maGetFlags ("-fTypecheck" :fs) = Typecheck : maGetFlags fs
174 maGetFlags ("-fSimp" :fs) = Simp : maGetFlags fs
175 maGetFlags ("-fNoCaseOpt" :fs) = NoCaseOpt : maGetFlags fs
176 maGetFlags ("-fShowHExpr" :fs) = ShowHExpr : maGetFlags fs
177 maGetFlags ("-fNoPretty" :fs) = NoPretty : maGetFlags fs
178 maGetFlags ("-fNoFormat" :fs) = NoFormat : maGetFlags fs
179 maGetFlags ("-fNoBaraki" :fs) = NoBaraki : maGetFlags fs
180 maGetFlags ("-fSimpleInv" :fs) = SimpleInv : maGetFlags fs
181 maGetFlags ("-fForceAll" :fs) = ForceAll : maGetFlags fs
182 maGetFlags ("-fDryRun" :fs) = DryRun : maGetFlags fs
183
184 maGetFlags
185 (('-':'f':'P':'o':'l':'y':'L':'i':'m':f):fs)
186 = (PolyLim (paNumval (filter isDigit f))): maGetFlags fs
187
188 maGetFlags
189 (('-':'f':'L':'o':'w':'e':'r':'L':'i':'m':f):fs)
190 = (LowerLim (paNumval (filter isDigit f))): maGetFlags fs
191
192 maGetFlags
193 (('-':'f':'U':'p':'p':'e':'r':'L':'i':'m':f):fs)
194 = (UpperLim (paNumval (filter isDigit f))): maGetFlags fs
195
196 maGetFlags
197 (('-':'f':'S':'c':'a':'l':'e':'U':'p':f):fs)
198 = (ScaleUp (paNumval (filter isDigit f))): maGetFlags fs
199
200 maGetFlags (other:_) = myFail ("Unknown flag: " ++ other ++ maUsage )
201
202
203 --==========================================================--
204 --
205 maUsage :: String
206
207 maUsage
208 = concat
209 [
210 "\n\nUsage: Anna400 [lmlflags -] [flags] < corefile",
211 "\n",
212 "\nAllowable flags are:",
213 "\n -fTypecheck don't do strictness analysis",
214 "\n -fSimp simplify abstract expressions",
215 "\n -fNoCaseOpt don't do case-of-case optimisation",
216 "\n -fShowHExpr show abstract expressions",
217 "\n -fNoPretty don't clean up after lambda lifting",
218 "\n -fNoFormat don't prettily format first-order output",
219 "\n -fNoBaraki don't use Baraki generalisation",
220 "\n -fSimpleInv use mindless inverses",
221 "\n -fForceAll force all thunks before analysis",
222 "\n -fDryRun trial run so as to check lattice table is ok",
223 "\n -fPolyLimN set generalisation limit to `N' (default 10000)",
224 "\n -fLowerLimN set lower lattice threshold to `N' (default 0)",
225 "\n -fUpperLimN set upper lattice threshold to `N' (default 1000000)",
226 "\n -fScaleUpN set scaleup ratio to N/10 (default 20)",
227 "\nDefault settings are opposite to those listed.\n"
228 ]
229
230
231 --==========================================================--
232 --=== end Main.hs ===--
233 --==========================================================--