| 1 | (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh |
| 2 | * Jagannathan, and Stephen Weeks. |
| 3 | * Copyright (C) 1997-2000 NEC Research Institute. |
| 4 | * |
| 5 | * MLton is released under a BSD-style license. |
| 6 | * See the file MLton-LICENSE for details. |
| 7 | *) |
| 8 | |
| 9 | functor Peephole(T : PEEPHOLE_TYPES): PEEPHOLE = |
| 10 | struct |
| 11 | open T |
| 12 | |
| 13 | datatype statement_border = Empty |
| 14 | | EmptyOrNonEmpty |
| 15 | type statement_element = (int * int option) * (statement_type -> bool) |
| 16 | type transfer_element = transfer_type -> bool |
| 17 | |
| 18 | val One : (statement_type -> bool) -> statement_element |
| 19 | = fn p => ((1, SOME 1), p) |
| 20 | val All : (statement_type -> bool) -> statement_element |
| 21 | = fn p => ((0, NONE), p) |
| 22 | |
| 23 | type template = {start: statement_border, |
| 24 | statements: statement_element list, |
| 25 | finish: statement_border, |
| 26 | transfer: transfer_element} |
| 27 | |
| 28 | type match = {entry: entry_type, |
| 29 | profileLabel: profileLabel_type, |
| 30 | start: statement_type list, |
| 31 | statements: statement_type list list, |
| 32 | finish: statement_type list, |
| 33 | transfer: transfer_type} |
| 34 | |
| 35 | type rewriter = match -> block option |
| 36 | |
| 37 | type callback = bool -> unit |
| 38 | |
| 39 | type optimization = {template: template, |
| 40 | rewriter: rewriter, |
| 41 | callback: callback} |
| 42 | |
| 43 | datatype match_state |
| 44 | = Start of {block: block} |
| 45 | | Continue of {remaining: optimization list, |
| 46 | match: match} |
| 47 | | Done of {block: block} |
| 48 | |
| 49 | type find_state = {remaining: optimization list, |
| 50 | state: {entry: entry_type, |
| 51 | profileLabel: profileLabel_type, |
| 52 | start: statement_type list, |
| 53 | finish: statement_type list, |
| 54 | transfer: transfer_type}} |
| 55 | |
| 56 | fun split (l, p) |
| 57 | = case l |
| 58 | of [] => ([],[]) |
| 59 | | l as h::t => if p h |
| 60 | then let |
| 61 | val (tt,ff) = split (t, p) |
| 62 | in |
| 63 | (h::tt,ff) |
| 64 | end |
| 65 | else ([],l) |
| 66 | |
| 67 | val rec matcher' : {template_statement: statement_element, |
| 68 | statement: statement_type list, |
| 69 | finish: statement_type list} -> |
| 70 | {statement: statement_type list, |
| 71 | finish: statement_type list} option |
| 72 | = fn (* Zero *) |
| 73 | {template_statement = ((0, SOME 0), _), |
| 74 | statement, |
| 75 | finish} |
| 76 | => SOME {statement = List.rev statement, |
| 77 | finish = finish} |
| 78 | | (* ZeroOrOne *) |
| 79 | {template_statement = ((0, SOME 1), p), |
| 80 | statement, |
| 81 | finish} |
| 82 | => (case finish |
| 83 | of [] => SOME {statement = List.rev statement, |
| 84 | finish = finish} |
| 85 | | (statement'::finish') |
| 86 | => if p statement' |
| 87 | then SOME {statement = List.rev (statement'::statement), |
| 88 | finish = finish'} |
| 89 | else SOME {statement = List.rev statement, |
| 90 | finish = finish}) |
| 91 | | (* One *) |
| 92 | {template_statement = ((1, SOME 1), p), |
| 93 | statement, |
| 94 | finish} |
| 95 | => (case finish |
| 96 | of [] => NONE |
| 97 | | (statement'::finish') |
| 98 | => if p statement' |
| 99 | then SOME {statement = List.rev (statement'::statement), |
| 100 | finish = finish'} |
| 101 | else NONE) |
| 102 | | (* *) |
| 103 | {template_statement = ((0, SOME i), p), |
| 104 | statement, |
| 105 | finish} |
| 106 | => (case finish |
| 107 | of [] => SOME {statement = List.rev statement, |
| 108 | finish = finish} |
| 109 | | (statement'::finish') |
| 110 | => if p statement' |
| 111 | then matcher' {template_statement = ((0, SOME (i-1)), p), |
| 112 | statement = statement'::statement, |
| 113 | finish = finish'} |
| 114 | else SOME {statement = List.rev statement, |
| 115 | finish = finish}) |
| 116 | | (* All *) |
| 117 | {template_statement = ((0, NONE), p), |
| 118 | statement, |
| 119 | finish} |
| 120 | => let |
| 121 | val (statement',finish') = split (finish, p) |
| 122 | in |
| 123 | SOME {statement = List.fold(statement, |
| 124 | statement', |
| 125 | op ::), |
| 126 | finish = finish'} |
| 127 | end |
| 128 | | {template_statement = ((min, max), p), |
| 129 | statement, |
| 130 | finish = (statement'::finish')} |
| 131 | => if p statement' |
| 132 | then matcher' {template_statement |
| 133 | = ((Int.max(min-1,0), |
| 134 | Option.map(max,fn i => i - 1)), p), |
| 135 | statement = statement'::statement, |
| 136 | finish = finish'} |
| 137 | else NONE |
| 138 | | _ => NONE |
| 139 | |
| 140 | val rec matcher : {template_statements: statement_element list, |
| 141 | statements: statement_type list list, |
| 142 | finish: statement_type list} -> |
| 143 | {statements: statement_type list list, |
| 144 | finish: statement_type list} option |
| 145 | = fn {template_statements = [], |
| 146 | statements, |
| 147 | finish} |
| 148 | => SOME {statements = List.rev statements, |
| 149 | finish = finish} |
| 150 | | {template_statements = (template_statement::template_statements), |
| 151 | statements, |
| 152 | finish} |
| 153 | => (case matcher' {template_statement = template_statement, |
| 154 | statement = [], |
| 155 | finish = finish} |
| 156 | of NONE => NONE |
| 157 | | SOME {statement, finish} |
| 158 | => matcher {template_statements = template_statements, |
| 159 | statements = statement::statements, |
| 160 | finish = finish}) |
| 161 | |
| 162 | fun peepholeBlock' {optimizations: optimization list, |
| 163 | match_state: match_state} |
| 164 | = let |
| 165 | fun next {remaining: optimization list, |
| 166 | state as {entry, profileLabel, start, finish, transfer}} : |
| 167 | find_state option |
| 168 | = (case remaining |
| 169 | of [] => NONE |
| 170 | | _::nil |
| 171 | => (case finish |
| 172 | of [] => NONE |
| 173 | | statement::finish |
| 174 | => SOME {remaining = optimizations, |
| 175 | state = {entry = entry, |
| 176 | profileLabel = profileLabel, |
| 177 | start = statement::start, |
| 178 | finish = finish, |
| 179 | transfer = transfer}}) |
| 180 | | _::remaining |
| 181 | => SOME {remaining = remaining, |
| 182 | state = state}) |
| 183 | |
| 184 | fun findMatch' (find_state |
| 185 | as {remaining as {template = {start |
| 186 | = template_start, |
| 187 | statements |
| 188 | = template_statements, |
| 189 | finish |
| 190 | = template_finish, |
| 191 | transfer |
| 192 | = template_transfer}, |
| 193 | ...}::_, |
| 194 | state = {entry, |
| 195 | profileLabel, |
| 196 | start, |
| 197 | finish, |
| 198 | transfer}}) : |
| 199 | match_state |
| 200 | = let |
| 201 | fun loop () |
| 202 | = (case next find_state |
| 203 | of SOME find_state => findMatch' find_state |
| 204 | | NONE |
| 205 | => Done {block = T {entry = entry, |
| 206 | profileLabel = profileLabel, |
| 207 | statements = List.fold(start, |
| 208 | finish, |
| 209 | op ::), |
| 210 | transfer = transfer}}) |
| 211 | in |
| 212 | if not (template_transfer transfer) |
| 213 | then loop () |
| 214 | else if template_start = Empty |
| 215 | andalso |
| 216 | not (List.isEmpty start) |
| 217 | then loop () |
| 218 | else case matcher {template_statements = template_statements, |
| 219 | statements = [], |
| 220 | finish = finish} |
| 221 | of NONE => loop () |
| 222 | | SOME {statements, finish} |
| 223 | => if template_finish = Empty |
| 224 | andalso |
| 225 | not (List.isEmpty finish) |
| 226 | then loop () |
| 227 | else Continue {remaining = remaining, |
| 228 | match |
| 229 | = {entry = entry, |
| 230 | profileLabel = profileLabel, |
| 231 | start = start, |
| 232 | statements = statements, |
| 233 | finish = finish, |
| 234 | transfer = transfer}} |
| 235 | end |
| 236 | | findMatch' _ = Error.bug "Peephole.peepholeBlock'.findMatch'" |
| 237 | |
| 238 | fun findMatch (match_state: match_state) : match_state |
| 239 | = case match_state |
| 240 | of Start {block = T {entry, profileLabel, |
| 241 | statements, transfer}} |
| 242 | => let |
| 243 | val find_state |
| 244 | = {remaining = optimizations, |
| 245 | state = {entry = entry, |
| 246 | profileLabel = profileLabel, |
| 247 | start = [], |
| 248 | finish = statements, |
| 249 | transfer = transfer}} |
| 250 | in |
| 251 | findMatch' find_state |
| 252 | end |
| 253 | | Continue {remaining, |
| 254 | match = {entry, |
| 255 | profileLabel, |
| 256 | start, |
| 257 | statements, |
| 258 | finish, |
| 259 | transfer}, |
| 260 | ...} |
| 261 | => let |
| 262 | val finish = List.foldr(statements, |
| 263 | finish, |
| 264 | op @) |
| 265 | val find_state |
| 266 | = {remaining = remaining, |
| 267 | state = {entry = entry, |
| 268 | profileLabel = profileLabel, |
| 269 | start = start, |
| 270 | finish = finish, |
| 271 | transfer = transfer}} |
| 272 | in |
| 273 | case next find_state |
| 274 | of NONE => Done {block |
| 275 | = T {entry = entry, |
| 276 | profileLabel = profileLabel, |
| 277 | statements = List.fold(start, |
| 278 | finish, |
| 279 | op ::), |
| 280 | transfer = transfer}} |
| 281 | | SOME find_state => findMatch' find_state |
| 282 | end |
| 283 | | Done _ => match_state |
| 284 | |
| 285 | fun peepholeBlock'' {match_state: match_state, |
| 286 | changed: bool} |
| 287 | = case findMatch match_state |
| 288 | of match_state as Continue {remaining = {rewriter, |
| 289 | callback, |
| 290 | ...}::_, |
| 291 | match} |
| 292 | => (case rewriter match |
| 293 | of SOME block |
| 294 | => (callback true; |
| 295 | peepholeBlock'' {match_state |
| 296 | = Start {block = block}, |
| 297 | changed = true}) |
| 298 | | NONE |
| 299 | => (callback false; |
| 300 | peepholeBlock'' {match_state = match_state, |
| 301 | changed = changed})) |
| 302 | | Done {block} => {block = block, changed = changed} |
| 303 | | _ => Error.bug "Peephole.peepholeBlock''" |
| 304 | in |
| 305 | case optimizations |
| 306 | of [] => (case match_state |
| 307 | of Start {block = block} => {block = block, |
| 308 | changed = false} |
| 309 | | _ => Error.bug "Peephole.peepholeBlock'") |
| 310 | | _ => peepholeBlock'' {match_state = match_state, |
| 311 | changed = false} |
| 312 | end |
| 313 | |
| 314 | fun peepholeBlock {block: block, |
| 315 | optimizations: optimization list} |
| 316 | = peepholeBlock' {optimizations = optimizations, |
| 317 | match_state = Start {block = block}} |
| 318 | |
| 319 | fun peepholeBlocks {blocks: block list, |
| 320 | optimizations: optimization list} |
| 321 | = let |
| 322 | val {blocks, changed} |
| 323 | = List.foldr |
| 324 | (blocks, |
| 325 | {blocks = [], changed = false}, |
| 326 | fn (block,{blocks,changed}) |
| 327 | => let |
| 328 | val {block = block', |
| 329 | changed = changed'} |
| 330 | = peepholeBlock' {optimizations = optimizations, |
| 331 | match_state = Start {block = block}} |
| 332 | in |
| 333 | {blocks = block'::blocks, |
| 334 | changed = changed orelse changed'} |
| 335 | end) |
| 336 | in |
| 337 | {blocks = blocks, |
| 338 | changed = changed} |
| 339 | end |
| 340 | end |