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