1(* 2 Copyright (c) 2012,13 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License as published by the Free Software Foundation; either 7 version 2.1 of the License, or (at your option) any later version. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18 19functor CODETREE_REMOVE_REDUNDANT( 20 structure BASECODETREE: BaseCodeTreeSig 21 structure CODETREE_FUNCTIONS: CodetreeFunctionsSig 22 23 sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing 24) : 25 sig 26 type codetree 27 type loadForm 28 type codeUse 29 val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree 30 structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end 31 end 32= 33struct 34 open BASECODETREE 35 open CODETREE_FUNCTIONS 36 exception InternalError = Misc.InternalError 37 38 (* This function annotates the tree with information about how variables are used. This assists 39 the optimiser to choose the best alternative for code. It also discards bindings that 40 are unused and side-effect-free. These can arise as the result of optimiser constructing 41 bindings in case they are required. That was originally its only function; hence the name. *) 42 fun cleanProc (pt, procUses: codeUse list, prev: int * codeUse list -> loadForm, recursiveRef: codeUse list -> unit, localCount, checkArg) = 43 let 44 val locals = Array.array(localCount, []) 45 fun addLocalUse addr use = 46 Array.update(locals, addr, use @ Array.sub(locals, addr)) 47 48 fun cleanLambda(lambda as {body, isInline, name, argTypes, resultType, localCount, closure, ...}: lambdaForm, 49 lambdaUse) = 50 let 51 (* Rebuild the closure with the entries actually used. *) 52 val closureUse = makeClosure() 53 54 fun lookup (closureEntry, clUse) = 55 let 56 (* Find the original closure entry. *) 57 val ext = List.nth(closure, closureEntry) 58 (* Process the closure entry. We need to do this to record the 59 usage information even if we have already seen this entry. *) 60 val copied = cleanExtract(ext, clUse) 61 in 62 addToClosure closureUse copied 63 end 64 65 (* This array records the way the arguments are used inside the function. *) 66 val argUses = Array.array (List.length argTypes, []) 67 fun checkArg(addr, uses) = Array.update(argUses, addr, uses @ Array.sub(argUses, addr)) 68 69 val recursiveRefRef = ref [] 70 fun addRef use = recursiveRefRef := use @ !recursiveRefRef 71 72 val resultOfApps = 73 List.foldl 74 (fn (UseApply (l, _), r) => l @ r | (UseExport, r) => UseExport :: r | (_, r) => UseGeneral :: r) [] 75 76 val bodyUse = resultOfApps lambdaUse 77 78 val bodyCode = cleanProc(body, bodyUse, lookup, addRef, localCount, checkArg) 79 val recursiveApps = !recursiveRefRef 80 (* If we have called this function somewhere and used the result that gives us a hint on the 81 preferred result. If the function is recursive, though, we can't assume anything 82 because the result of the recursive calls may be used in some other context. For 83 example they could be passed into an argument function which may require more fields. 84 That in turn affects any functions whose results are used. See Test138.ML. 85 So, we check to see whether the result of recursive use has added anything to the 86 original usage and reprocess the body if it has. *) 87 val recursiveResults = resultOfApps recursiveApps 88 val needReprocess = 89 if null recursiveApps orelse 90 List.exists(fn UseGeneral => true | UseExport => true | _ => false) bodyUse 91 then NONE (* Not recursive or already general or export *) 92 else if List.all(fn UseField _ => true | _ => false) bodyUse andalso 93 List.all(fn UseField _ => true | _ => false) recursiveResults 94 then (* All the entries are UseField - has the recursion added something new? *) 95 if List.foldl 96 (fn (UseField(n, _), false) => 97 List.all 98 (fn UseField(m, _) => m <> n | _ => raise InternalError "not UseField") 99 bodyUse (* false if it's already there *) 100 | (_, true) => true 101 | _ => raise InternalError "not UseField") 102 false recursiveResults 103 then SOME recursiveApps 104 else NONE 105 else SOME [UseGeneral] (* If there's anything else reprocess it with UseGeneral *) 106 in 107 case needReprocess of 108 SOME reprocessWith => cleanLambda(lambda, lambdaUse @ reprocessWith) 109 | NONE => 110 let 111 val newClosure = extractClosure closureUse 112 113 val newArgTypes = ListPair.zip(map #1 argTypes, Array.foldr (op ::) [] argUses) 114 in 115 {body=bodyCode, isInline=isInline, name=name, 116 closure=newClosure, argTypes=newArgTypes, resultType=resultType, 117 localCount=localCount, recUse = recursiveApps} : lambdaForm 118 end 119 end 120 121 (* Process a load from a variable. Locals and arguments operate on the relevant array, 122 closure entries involve a look-up *) 123 and cleanExtract(ext as LoadLocal addr, codeUse) = 124 ( 125 (* Check we're actually adding to the usage. *) 126 null codeUse andalso raise InternalError "cleanExtract: empty usage"; 127 addLocalUse addr codeUse; 128 ext 129 ) 130 131 | cleanExtract(ext as LoadArgument addr, codeUse) = 132 ( 133 checkArg(addr, codeUse); 134 ext 135 ) 136 137 | cleanExtract(LoadClosure addr, codeUse) = prev(addr, codeUse) 138 139 | cleanExtract(LoadRecursive, codeUse) = (recursiveRef codeUse; LoadRecursive) 140 141 and cleanCode (code, codeUse) = 142 let 143 fun doClean codeUse (Newenv(decs, exp)) = 144 let 145 (* First process the expression so as to mark any references it makes. *) 146 val processedExp = cleanCode (exp, codeUse) 147 148 (* Process the declarations in reverse order. A binding may be used in 149 a later declaration but apart from mutually-recursive functions no binding 150 can be used in an earlier one. *) 151 fun processDecs [] = [] 152 153 | processDecs(Declar{value, addr, ...} :: rest) = 154 let 155 val processedRest = processDecs rest 156 val decUses = 157 case Array.sub(locals, addr) of 158 [] => if sideEffectFree value then [] else [UseGeneral] 159 | uses => uses 160 in 161 (* We can drop bindings that are unused if they have no side-effects. 162 If we retain the binding we must set at least one reference. *) 163 if null decUses 164 then processedRest (* Skip it *) 165 else 166 let 167 val cleanvalue = 168 case value of 169 Lambda lambda => Lambda(cleanLambda(lambda, decUses)) 170 | value => cleanCode (value, decUses) 171 in 172 Declar{value=cleanvalue, addr=addr, use=decUses} :: processedRest 173 end 174 end 175 176 | processDecs(RecDecs decs :: rest) = 177 let 178 val processedRest = processDecs rest 179 (* We now know the entries that have actually been used 180 in the rest of the code. We need to include those 181 declarations and any that they use. 182 The result we pass down may well exclude some or all 183 recursive uses. We need to include UseGeneral in 184 the result for safety. *) 185 fun processMutuals([], excluded, true) = 186 (* If we have included a function in this 187 pass we have to reprocess the list of 188 those we excluded before. *) 189 processMutuals(excluded, [], false) 190 | processMutuals([], _, false) = 191 (* We didn't add anything more - finish *) [] 192 | processMutuals( 193 (this as {addr, lambda, ...}) :: rest, excluded, added) = 194 ( 195 case Array.sub(locals, addr) of 196 [] => (* Put this on the excluded list. *) 197 processMutuals(rest, this::excluded, added) 198 | useSoFar => 199 (* Process this then the rest of the list. *) 200 (addr, cleanLambda(lambda, UseGeneral :: useSoFar)) :: 201 processMutuals(rest, excluded, true) 202 ) 203 val entriesUsed = processMutuals(decs, [], false) 204 (* Get all the uses now we're finished and have identified 205 all the recursive uses. *) 206 val processedDecs = 207 map (fn(a, l) => {addr=a, lambda=l, use=Array.sub(locals, a)}) entriesUsed 208 in 209 if null processedDecs 210 then processedRest 211 else RecDecs processedDecs :: processedRest 212 end 213 214 | processDecs(NullBinding exp :: rest) = 215 let 216 val processedRest = processDecs rest 217 in 218 if sideEffectFree exp 219 then processedRest 220 else NullBinding(cleanCode(exp, [UseGeneral])) :: processedRest 221 end 222 223 | processDecs(Container{setter, size, addr, ...} :: rest) = 224 let 225 val processedRest = processDecs rest 226 val decUses = 227 case Array.sub(locals, addr) of 228 [] => if sideEffectFree setter then [] else [UseGeneral] 229 | uses => uses 230 in 231 (* We can drop bindings that are unused if they have no side-effects. 232 If we retain the binding we must set at least one reference. *) 233 (* Currently SetContainer is treated as having a side-effect so 234 we will never discard this even if the container is unused. *) 235 if null decUses 236 then processedRest (* Skip it *) 237 else Container{setter=cleanCode (setter, [UseGeneral]), addr=addr, size=size, use=decUses} :: processedRest 238 end 239 240 val processedDecs = processDecs decs 241 in 242 SOME(mkEnv(processedDecs, processedExp)) 243 end (* Newenv *) 244 245 (* Reference to a binding. *) 246 | doClean codeUse (Extract ext) = SOME(Extract(cleanExtract(ext, codeUse))) 247 248 (* Select a field from a tuple. We can't do this for selection from datatypes because 249 some fields may not be present on all paths. *) 250 | doClean codeUse (Indirect{base, offset, isVariant = false}) = 251 (* Try to pass down the use. If the "base" is an Extract or another Indirect 252 we may be able to record this information. If it is something else we can't. *) 253 SOME(Indirect{base=cleanCode(base, [UseField(offset, codeUse)]), offset=offset, isVariant=false}) 254 255 | doClean codeUse (Tuple{ fields, isVariant = false}) = 256 let 257 (* If the use of the tuple include UseGeneral or UseExport then every field is 258 required. If, though, we have UseField we can transfer the corresponding 259 usage onto the field of the tuple. *) 260 fun fieldUse n (UseField(offset, uses), tl) = 261 if n = offset then uses @ tl else tl 262 | fieldUse _ (use, tl) = use :: tl 263 264 fun fieldUses n = 265 (* For the moment, if we find that the field is not used we set the 266 usage to UseGeneral. I'm not convinced it would be safe to 267 discard anything in the expression at this point. *) 268 case List.foldl(fieldUse n) [] codeUse of 269 [] => [UseGeneral] 270 | other => other 271 272 fun processField([], _) = [] 273 | processField(hd::tl, n) = 274 cleanCode(hd, fieldUses n) :: processField(tl, n+1) 275 in 276 SOME(Tuple{ fields = processField(fields, 0), isVariant = false}) 277 end 278 279 | doClean codeUse (Lambda lam) = SOME(Lambda(cleanLambda(lam, codeUse))) 280 281 | doClean codeUse (Eval{function, argList, resultType}) = 282 (* As with Indirect we try to pass this information down so that if 283 the function is a variable it will be marked as "called". *) 284 let 285 val args = map (fn (c, t) => (cleanCode(c, [UseGeneral]), t)) argList 286 val argTuples = map #1 args 287 in 288 SOME( 289 Eval{ 290 function=cleanCode(function, [UseApply(codeUse, argTuples)]), 291 argList=args, resultType = resultType 292 }) 293 end 294 295 | doClean codeUse (Cond(i, t, e)) = 296 SOME(Cond(cleanCode(i, [UseGeneral]), cleanCode(t, codeUse), cleanCode(e, codeUse))) 297 298 | doClean use (BeginLoop{loop, arguments}) = 299 let 300 val cleanBody = cleanCode(loop, use) 301 (* Remove unused arguments. They're unnecessary and may cause problems 302 later on. *) 303 fun filterUnused [] = ([], []) 304 | filterUnused (({use=[], value, ...}, _) :: args) = 305 let 306 val (used, discards) = filterUnused args 307 (* We only need to keep this if it might have a side-effect. *) 308 in 309 (used, NullBinding(cleanCode(value, [UseGeneral])) :: discards) 310 end 311 | filterUnused(({value, addr, use}, t) :: args) = 312 let 313 val (used, discards) = filterUnused args 314 in 315 (({value=cleanCode(value, use), addr=addr, use=use}, t) :: used, discards) 316 end 317 val (usedArgs, discards) = filterUnused arguments 318 in 319 if not(null discards) 320 then 321 let 322 fun splitArgs([], []) = ([], []) 323 | splitArgs((arg, _) :: args, ({use=[], ...}, _) :: arguments) = 324 let 325 val (useArgs, discards) = splitArgs(args, arguments) 326 in 327 (* We actually only need to keep this argument if it might have 328 a side-effect but keep it anyway. *) 329 (useArgs, NullBinding arg :: discards) 330 end 331 | splitArgs(arg :: args, _ :: arguments) = 332 let 333 val (useArgs, discards) = splitArgs(args, arguments) 334 in 335 (arg :: useArgs, discards) 336 end 337 | splitArgs _ = raise InternalError "splitArgs" 338 339 fun filterLoopArgs(Loop l) = 340 let 341 val (useArgs, discards) = splitArgs(l, arguments) 342 in 343 SOME(Newenv(discards, Loop useArgs)) 344 end 345 (* Don't descend into functions or inner loops. *) 346 | filterLoopArgs(instr as Lambda _) = SOME instr 347 | filterLoopArgs(instr as BeginLoop _) = SOME instr 348 | filterLoopArgs _ = NONE 349 350 val newLoop = 351 BeginLoop {loop = mapCodetree filterLoopArgs cleanBody, arguments = usedArgs} 352 in 353 SOME(Newenv(discards, newLoop)) 354 end 355 else SOME(BeginLoop {loop = cleanBody, arguments = usedArgs}) 356 end 357 358 | doClean _ _ = NONE (* Anything else *) 359 in 360 (* If we recognise this as a special case we use the result otherwise 361 we process it as a general value using UseGeneral as the usage. *) 362 case doClean codeUse code of 363 SOME result => result 364 | NONE => mapCodetree (doClean [UseGeneral]) code 365 end 366 367 in 368 cleanCode (pt, procUses) 369 end (* cleanProc *) 370 371 val cleanProc = 372 fn (code, procUse, prev, localCount) => 373 cleanProc(code, procUse, fn (i, _) => prev i, fn _ => (), localCount, fn _ => ()) 374 375 structure Sharing = 376 struct 377 type codetree = codetree 378 and loadForm = loadForm 379 and codeUse = codeUse 380 end 381end; 382