|
| 1 | +(***********************************************************************) |
| 2 | +(* *) |
| 3 | +(* OCaml *) |
| 4 | +(* *) |
| 5 | +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) |
| 6 | +(* *) |
| 7 | +(* Copyright 1996 Institut National de Recherche en Informatique et *) |
| 8 | +(* en Automatique. All rights reserved. This file is distributed *) |
| 9 | +(* under the terms of the Q Public License version 1.0. *) |
| 10 | +(* *) |
| 11 | +(***********************************************************************) |
| 12 | +(* Adapted for Javascript backend : Hongbo Zhang, *) |
| 13 | + |
| 14 | +(* Scalar replacement of aggregates (SROA) for local mutable blocks. |
| 15 | +
|
| 16 | + A block can be replaced by mutable scalar bindings when every occurrence |
| 17 | + of the block is a direct, statically indexed field read or write. JavaScript |
| 18 | + closures capture bindings, so direct accesses from nested functions remain |
| 19 | + eligible. Analysis is kept separate from rewriting so a failed eligibility |
| 20 | + check cannot partially transform the term. *) |
| 21 | + |
| 22 | +let valid_field field_count index = index >= 0 && index < field_count |
| 23 | + |
| 24 | +(* Does the block appear anywhere other than as a direct, in-range field read |
| 25 | + or write? [escapes] and [rewrite] below are a matched pair: [rewrite] handles |
| 26 | + exactly the occurrences [escapes] accepts, and asserts on the rest. Extending |
| 27 | + one without the other is a compiler crash rather than a type error, so keep |
| 28 | + their cases in step. *) |
| 29 | +let rec escapes block field_count (lam : Lambda.t) = |
| 30 | + match lam with |
| 31 | + | Lvar id -> Ident.same id block |
| 32 | + | Lassign (id, value) -> |
| 33 | + Ident.same id block || escapes block field_count value |
| 34 | + | Lprim {primitive = Pfield (index, _); args = [Lvar id]} |
| 35 | + when Ident.same id block -> |
| 36 | + not (valid_field field_count index) |
| 37 | + | Lprim {primitive = Psetfield (index, _); args = [Lvar id; value]} |
| 38 | + when Ident.same id block -> |
| 39 | + (not (valid_field field_count index)) || escapes block field_count value |
| 40 | + | _ -> Lambda.shallow_exists (escapes block field_count) lam |
| 41 | + |
| 42 | +let rec rewrite block fields (lam : Lambda.t) = |
| 43 | + match lam with |
| 44 | + | Lprim {primitive = Pfield (index, _); args = [Lvar id]} |
| 45 | + when Ident.same id block -> |
| 46 | + Lambda.var fields.(index) |
| 47 | + | Lprim {primitive = Psetfield (index, _); args = [Lvar id; value]} |
| 48 | + when Ident.same id block -> |
| 49 | + Lambda.assign fields.(index) (rewrite block fields value) |
| 50 | + (* Unreachable: [escapes] rejected the block for both of these, so [replace] |
| 51 | + never reaches the rewrite. They are kept as assertions rather than dropped |
| 52 | + so that a future occurrence form added to [escapes] but not here fails |
| 53 | + loudly instead of silently losing the write. *) |
| 54 | + | Lvar id when Ident.same id block -> assert false |
| 55 | + | Lassign (id, _) when Ident.same id block -> assert false |
| 56 | + | _ -> Lambda.shallow_map_sharing (rewrite block fields) lam |
| 57 | + |
| 58 | +let fields_for_block block info field_count = |
| 59 | + let fallback () = |
| 60 | + Array.init field_count (fun index -> |
| 61 | + if index = 0 then block else Ident.rename block) |
| 62 | + in |
| 63 | + if field_count = 1 then [|block|] |
| 64 | + else |
| 65 | + let names = |
| 66 | + match info with |
| 67 | + | Lambda.Blk_record {fields} | Lambda.Blk_record_inlined {fields} -> |
| 68 | + if Array.length fields = field_count then |
| 69 | + Some (Array.map (fun (name, _) -> name) fields) |
| 70 | + else None |
| 71 | + | Lambda.Blk_record_ext {fields} -> |
| 72 | + if Array.length fields = field_count then Some fields else None |
| 73 | + | Lambda.Blk_tuple | Lambda.Blk_constructor _ | Lambda.Blk_poly_var |
| 74 | + | Lambda.Blk_module _ | Lambda.Blk_module_export _ | Lambda.Blk_extension |
| 75 | + -> |
| 76 | + None |
| 77 | + in |
| 78 | + match names with |
| 79 | + | None -> fallback () |
| 80 | + | Some names -> |
| 81 | + Array.map (fun name -> Ident.create (Ident.name block ^ "_" ^ name)) names |
| 82 | + |
| 83 | +let replace ~block ~info ~initializers body = |
| 84 | + match initializers with |
| 85 | + | [] -> None |
| 86 | + | _ -> |
| 87 | + let field_count = List.length initializers in |
| 88 | + if escapes block field_count body then None |
| 89 | + else |
| 90 | + let fields = fields_for_block block info field_count in |
| 91 | + let body = rewrite block fields body in |
| 92 | + Some |
| 93 | + (Ext_list.fold_right2 (Array.to_list fields) initializers body |
| 94 | + (fun field init body -> Lambda.let_ Variable field init body)) |
| 95 | + |
| 96 | +let rec simplify (lam : Lambda.t) = |
| 97 | + match lam with |
| 98 | + | Llet (kind, block, init, body) -> ( |
| 99 | + let init' = simplify init in |
| 100 | + let body' = simplify body in |
| 101 | + match (kind, init') with |
| 102 | + | ( (Strict | StrictOpt), |
| 103 | + Lambda.Lprim {primitive = Pmakeblock info; args = initializers} ) |
| 104 | + when not (Lambda.is_immutable_block info) -> ( |
| 105 | + match replace ~block ~info ~initializers body' with |
| 106 | + | Some replacement -> replacement |
| 107 | + | None -> |
| 108 | + if init' == init && body' == body then lam |
| 109 | + else Lambda.let_ kind block init' body') |
| 110 | + | _ -> |
| 111 | + if init' == init && body' == body then lam |
| 112 | + else Lambda.let_ kind block init' body') |
| 113 | + | _ -> Lambda.shallow_map_sharing simplify lam |
0 commit comments