Skip to content
This repository
tag: v317
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 406 lines (377 sloc) 18.134 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module Q = QmlAst
module List = BaseList
module Format = BaseFormat

module IdentAssoc = List.MakeAssoc(Ident)

exception InvalidRecursion

let map_intersection merge_value map1 map2 =
  IdentMap.fold
    (fun k v1 acc ->
       try let v2 = IdentMap.find k map2 in
           IdentMap.add k (merge_value v1 v2) acc
       with Not_found ->
         acc
    ) map1 IdentMap.empty

(* this function takes a binding (from a recursive set of bindings)
* and distinguishes 3 cases:
* - the expression is tagged with @recval (coming from rec val or and val in the syntax)
* returns Some of a map from the direct dependencies of this expression on the other
* identifiers of the bindings of their positions
* - the expression is a lambda -> return None
* - in other cases, the recursion is invalid, and the InvalidRecursion is raised
*)
let is_a_val_binding idents (_i, e) =
  let merge_value = (@) in
  let find_deps e =
    QmlAstWalk.Expr.self_traverse_fold
      (fun self tra deps e ->
         match e with
         | Q.Ident (label, i) when IdentSet.mem i idents -> IdentMap.add i [Annot.pos label] deps
         | Q.Match (_, e, pel) -> (
             let deps = self deps e in
             let depss = List.map (fun (_p,e) -> self IdentMap.empty e) pel in
             match depss with
             | [] -> assert false
             | h :: t ->
                 (* we can sure that we depend on an identifier only if all the
* branches depend on that identifier
* hence we must take the intersection of the dependencies of the branches
* and NOT their union *)
                 let intersection = List.fold_left (map_intersection merge_value) h t in
                 IdentMap.merge merge_value intersection deps
           )
         | Q.Lambda _ ->
             deps
         | _ ->
             tra deps e
      ) IdentMap.empty e in
  let rec is_a_val = function
    | Q.Lambda _ -> None
    | Q.Directive (_, `recval, [e], _) ->
        (* checking that you don't put a val rec on a function *)
        (try match is_a_val e with
         | None ->
             (* FIXME: should be a warning *)
             let context = QmlError.Context.expr e in
             QmlError.error context
               "This expression is a function, it can be recursive without being tagged with 'val'."
         | Some _ -> () (* could be an assert failure? *)
         with InvalidRecursion -> ());
        Some (find_deps e)
    | Q.Directive (_, `recval, _, _) -> assert false
    | Q.Coerce (_, e, _)
    (* BEWARE before editing: keep this set of directive in sync with the one
* in remove_toplevel_directives *)
    | Q.Directive (_, (#Q.type_directive | #Q.slicer_directive | `async), [e], _) -> is_a_val e
    | _ -> raise InvalidRecursion in
  is_a_val e

let lazy_type gamma var =
  let typeident = Q.TypeIdent.of_string Opacapi.Types.finite_single_thread_lazy in
  let (typeident, _) = QmlTypes.Env.TypeIdent.findi ~visibility_applies:true typeident gamma in
  (* grabbing the typeident from the gamma, or else we might have the infamous
* assert failure somewhere in the typer saying "call type_of_type" *)
  Q.TypeName ([var], typeident)
let lazy_force_type gamma var =
  Q.TypeArrow ([lazy_type gamma var], var)
let mutable_make_type gamma ty =
  let var = QmlAstCons.Type.next_var () in
  Q.TypeArrow ([var], lazy_type gamma ty)
let mutable_set_type gamma ty =
  Q.TypeArrow ([lazy_type gamma ty; ty], Q.TypeRecord (Q.TyRow ([], None)))

let force ~val_ gamma annotmap label lazy_i =
  let lazy_force = val_ Opacapi.FiniteSingleThreadLazy.force in
  let ty = QmlAnnotMap.find_ty_label label annotmap in
  let annotmap, force = QmlAstCons.TypedExpr.ident annotmap lazy_force (lazy_force_type gamma ty) in
  let annotmap, lazy_i_expr = QmlAstCons.TypedExpr.ident annotmap lazy_i (lazy_type gamma ty) in
  let annotmap, forced_lazy = QmlAstCons.TypedExpr.apply gamma annotmap force [lazy_i_expr] in
  annotmap, forced_lazy

let partition_map p l =
  let rec aux acc1 acc2 = function
    | [] -> List.rev acc1, List.rev acc2
    | h :: t ->
        match p h with
        | None -> aux acc1 (h :: acc2) t
        | Some v -> aux ((h, v) :: acc1) acc2 t in
  aux [] [] l

let rec drop_until p = function
  | [] -> None, []
  | h :: t ->
      if p h then
        Some h, t
      else
        drop_until p t

(* simple check to reject at compile time some cases of illegal value recursion
* such as [val rec x = x] *)
let check_lack_of_cycle val_deps_bindings =
  let val_deps = List.map (fun ((i,_e),deps) -> (i,deps)) val_deps_bindings in
  let pos_of_def i =
    let (_, e), _ = List.find (fun ((j,_),_) -> Ident.equal i j) val_deps_bindings in
    Q.Pos.expr e in
  let rec aux occur i posl =
    if IdentAssoc.mem i occur then (
      (* the dependencies that cause the immediate loop *)
      let calls = List.rev ((i,posl) :: occur) in
      (* the relevant part of the dependencies *)
      let _, calls = drop_until (fun (j,_) -> Ident.equal i j) calls in
      OManager.serror "@[<v>%a@]@\n@[<v2>Invalid recursive value binding: @{<bright>%s@} depends on itself@]@\n@[<v2>Hint:@ Here is the chain of immediate dependencies:@ %a@]"
        FilePos.pp (pos_of_def i)
        (Ident.original_name i)
        (Format.pp_list "@\n"
           (fun f (i,posl) ->
              (* we have several positions when there are branching,
* but perhaps it gives too much information to show all
* the positions *)
              let pos = List.hd posl in
              Format.fprintf f "@[<v2>%s at %a@]" (Ident.original_name i) FilePos.pp pos
           )) calls;
      (* exiting to give only one error message in the recursive group *)
      raise InvalidRecursion
    ) else
      let occur = (i,posl) :: occur in
      (* only non lambda bindings are in val_deps, so we can get a Not_found here *)
      let deps = try IdentAssoc.find i val_deps with Not_found -> IdentMap.empty in
      IdentMap.iter (aux occur) deps in
  try
    List.iter
      (fun (i,_) -> aux [] i [])
      val_deps
  with InvalidRecursion -> ()

let move_ei_tsc_gen label annotmap e =
  let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
  assert (QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap = None);
  QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) tsc_gen_opt annotmap

(* now the typing directive are just freaking annoying, because there may be
* more slicer directives under them so let's remove them *)
let remove_toplevel_directives annotmap e =
  let rec aux dirs annotmap = function
    | Q.Coerce (label, e, _)
    | Q.Directive (label, #Q.type_directive, [e], _) ->
        let annotmap = move_ei_tsc_gen label annotmap e in
        aux dirs annotmap e
    | Q.Directive (label, (#Q.slicer_directive | `async as v), [e], []) ->
        let annotmap = move_ei_tsc_gen label annotmap e in
        aux (v :: dirs) annotmap e
    | Q.Directive (_, #Q.slicer_directive, _, _) -> assert false
    | e -> annotmap, dirs, e in
  aux [] annotmap e

let rec put_back_toplevel_directives annotmap dirs e =
  match dirs with
  | [] -> annotmap, e
  | dir :: dirs ->
      let label = Q.Label.expr e in
      let new_label = Annot.refresh label in
      let ty = QmlAnnotMap.find_ty_label label annotmap in
      let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
      let annotmap = QmlAnnotMap.remove_tsc_label label annotmap in
      let annotmap = QmlAnnotMap.add_ty_label new_label ty annotmap in
      let annotmap = QmlAnnotMap.add_tsc_opt_label new_label tsc_gen_opt annotmap in
      let e = Q.Directive (new_label, dir, [e], []) in
      put_back_toplevel_directives annotmap dirs e

(*
* rewrites [rec val x = e1
* and f() = e2]
* into
* [lazy_x = mutable_make(0)
* rec f() = e2[lazy_force(lazy_x) / x ]
* _ = mutable_set(lazy_x, ( -> e1[lazy_force(lazy_x) / x ]))
* x = lazy_force(lazy_x)
* ]
* The only expressions in the recursive bindings after this rewriting are lambdas
* (modulo coercions, some directives, etc.)
*)
let process_bindings ~val_ gamma annotmap bindings =
  let idents = List.fold_left (fun acc (i,_) -> IdentSet.add i acc) IdentSet.empty bindings in

  let invalid_bindings = ref [] in
  let val_deps_bindings, fun_bindings =
    partition_map
      (fun b ->
         try is_a_val_binding idents b
         with InvalidRecursion ->
           invalid_bindings := b :: !invalid_bindings;
           None
      ) bindings in
  if !invalid_bindings <> [] then (
    (match bindings with
     | [(i,e)] ->
         (* a more concise error message in the common case of not mutual recursion *)
         let context = QmlError.Context.expr e in
         QmlError.serror context "@[<v2> The recursive definition of @{<bright>%s@} is invalid." (Ident.original_name i)
     | _ ->
         OManager.serror "@[<v2>In the recursive group consisting of {@[<h>%a@]}, the following recursive definitions are invalid:@\n%a@]@\n@]"
          (Format.pp_list ",@ " (fun f i -> Format.pp_print_string f (Ident.original_name i))) (IdentSet.elements idents)
           (Format.pp_list "@ " (fun f (i,e) -> Format.fprintf f "@{<bright>%s@} at %a" (Ident.original_name i) FilePos.pp (Q.Pos.expr e))) !invalid_bindings
    );
    None
  ) else (
    check_lack_of_cycle val_deps_bindings;
    let val_bindings = List.map fst val_deps_bindings in
    if val_bindings = [] then
      None
    else (
      let mutable_make = val_ Opacapi.Mutable.make in
      let mutable_set = val_ Opacapi.Mutable.set in

      (* when we write @server rec val x = ..., then we remove the directive
* @server from the body of x and we will put it on all the toplevel
* bindings generated from x *)
      let annotmap, val_bindings =
        List.fold_left_map
          (fun annotmap (i,e) ->
             let annotmap, dirs, e = remove_toplevel_directives annotmap e in
             annotmap, (i, e, dirs)
          ) annotmap val_bindings in
      let lazy_idents = List.map (fun (i,_,_) -> Ident.refreshf ~map:"lazy_%s" i) val_bindings in
      let annotmap, lazy_defs =
        List.fold_left_map2
          (fun annotmap i (_,e,dirs) ->
             let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
             let annotmap, mutable_make = QmlAstCons.TypedExpr.ident annotmap mutable_make (mutable_make_type gamma ty) in
             (* could put a well typed value if needed (like {evaluating}) *)
             let annotmap, zero = QmlAstCons.TypedExpr.int annotmap 7 in
             let annotmap, def = QmlAstCons.TypedExpr.apply gamma annotmap mutable_make [zero] in
             let annotmap, def = put_back_toplevel_directives annotmap dirs def in
             annotmap, (i, def)
          ) annotmap lazy_idents val_bindings in
      let annotmap, lazy_sets =
        List.fold_left_map2
          (fun annotmap i (_, e, dirs) ->
             let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
             let annotmap, mutable_set = QmlAstCons.TypedExpr.ident annotmap mutable_set (mutable_set_type gamma ty) in
             let annotmap, lambda = QmlAstCons.TypedExpr.lambda annotmap [] e in
             let annotmap, lazy_body = QmlAstCons.TypedExpr.sum_element annotmap ["delayed", lambda] in
             let annotmap, ref_ = QmlAstCons.TypedExpr.ident annotmap i (lazy_type gamma ty) in
             let annotmap, set = QmlAstCons.TypedExpr.apply gamma annotmap mutable_set [ref_; lazy_body] in
             let annotmap, set = put_back_toplevel_directives annotmap dirs set in
             annotmap, (Ident.next "set_lazy", set)
          ) annotmap lazy_idents val_bindings in
      let annotmap, original_bindings =
        List.fold_left_map2
          (fun annotmap lazy_i (i, e, dirs) ->
             let annotmap, forced_lazy = force ~val_ gamma annotmap (Q.Label.expr e) lazy_i in
             let annotmap, forced_lazy = put_back_toplevel_directives annotmap dirs forced_lazy in
             annotmap, (i, forced_lazy)
          ) annotmap lazy_idents val_bindings in
      let assoc_ident = List.map2 (fun lazy_i (i,_,_) -> (i,lazy_i)) lazy_idents val_bindings in
      let rewrite_binding annotmap (i,e) =
        let annotmap, e = QmlAstWalk.Expr.traverse_foldmap
          (fun tra annotmap e ->
             match e with
             | Q.Ident (label, i) -> (
                 try
                   let lazy_i = IdentAssoc.find i assoc_ident in
                   force ~val_ gamma annotmap label lazy_i
                 with Not_found ->
                   annotmap, e
               )
             | _ -> tra annotmap e
          ) annotmap e in
        annotmap, (i, e) in
      let rewrite_bindings annotmap l =
        List.fold_left_map rewrite_binding annotmap l in
      let annotmap, lazy_sets = rewrite_bindings annotmap lazy_sets in
      let annotmap, fun_bindings = rewrite_bindings annotmap fun_bindings in
      Some (
        annotmap,
        lazy_defs,
        (if fun_bindings = [] then None else Some fun_bindings),
        lazy_sets,
        original_bindings
      )
    )
  )

let process_bindings_for_toplevel ~val_ gamma annotmap label bindings =
  match process_bindings ~val_ gamma annotmap bindings with
  | None ->
      None
  | Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
      let code =
        Q.NewVal (Annot.refresh label, lazy_sets) ::
          Q.NewVal (Annot.refresh label, original_bindings) ::
          [] in
      let code =
        match fun_bindings_opt with
        | None -> code
        | Some fun_bindings -> Q.NewValRec (Annot.refresh label, fun_bindings) :: code in
      let code = Q.NewVal (Annot.refresh label, lazy_defs) :: code in
      let add_to_gamma gamma bindings =
        List.fold_left
          (fun gamma (i,e) ->
             let tsc = QmlTypes.Scheme.quantify (QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap) in
             QmlTypes.Env.Ident.add i tsc gamma
          ) gamma bindings in
      let gamma = add_to_gamma gamma lazy_defs in
      let gamma = add_to_gamma gamma lazy_sets in
      Some (gamma, annotmap, code)

let process_code ~val_ gamma annotmap code =

  (* rewriting newvalrec *)
  let (gamma, annotmap), code =
    List.fold_left_collect
      (fun (gamma, annotmap) c ->
         match c with
         | Q.NewValRec (label, bindings) -> (
             match process_bindings_for_toplevel ~val_ gamma annotmap label bindings with
             | None -> (gamma, annotmap), [c]
             | Some (gamma, annotmap, code) -> (gamma, annotmap), code
           )
         | _ -> (gamma, annotmap), [c]
      ) (gamma, annotmap) code in

  (* rewriting letrec and removing @recval *)
  let annotmap, code =
    QmlAstWalk.CodeExpr.fold_map
      (QmlAstWalk.Expr.self_traverse_foldmap
         (fun self tra annotmap e ->
            match e with

            | Q.LetRecIn (label, bindings, e_in) -> (
                match process_bindings ~val_ gamma annotmap bindings with
                | None -> tra annotmap e
                | Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
                    let label2 = Annot.refresh label in
                    let label4 = Annot.refresh label in
                    let label5 = Annot.refresh label in
                    (* not copying the information for ei *)
                    let ty = QmlAnnotMap.find_ty_label label annotmap in
                    let annotmap = QmlAnnotMap.add_ty_label label2 ty annotmap in
                    let annotmap = QmlAnnotMap.add_ty_label label4 ty annotmap in
                    let annotmap = QmlAnnotMap.add_ty_label label5 ty annotmap in
                    let e_in =
                      Q.LetIn (label2, lazy_sets,
                               Q.LetIn (label, original_bindings, e_in)) in
                    let e_in =
                      match fun_bindings_opt with
                      | None -> e_in
                      | Some fun_bindings -> Q.LetRecIn (label4, fun_bindings, e_in) in
                    let e_in =
                      Q.LetIn (label5, lazy_defs, e_in) in
                    (* need to go down to rewrite e_in and lazy_sets
* (although we could just rewrite them instead of calling ourselves
* recursively on the term produced) *)
                    tra annotmap e_in
              )

            | Q.Directive (label, `recval, [e], []) ->
                (* it is possible that we have a recval on a let that is not recursive
* for instance when we say [rec val x = 1] because the dependency analysis
* will transform newvalrec and letrec into newval and letin if possible
* also other rewriting (such as the one for let pattern = expr in expr)
* may duplicate @recval and put them in not quite legal places, so i prefer
* not to give an error and ignore everything *)
               (* cannot instantiate on a recval, but it has possibly been generalized *)
               assert (QmlAnnotMap.find_tsc_inst_opt_label label annotmap = None);
               let annotmap = QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) (QmlAnnotMap.find_tsc_opt_label label annotmap) annotmap in
               self annotmap e

            | Q.Directive (_, `recval, _, _) ->
                assert false

            | _ -> tra annotmap e

         )
      ) annotmap code in

  gamma, annotmap, code
Something went wrong with that request. Please try again.