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