Skip to content
This repository
tag: v948
Fetching contributors…

Cannot retrieve contributors at this time

file 134 lines (116 sloc) 5.327 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
(*
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/>.
*)
(* shorthands *)
module P = Passes


module S =
struct
  type t = (QmlAst.ty, unit) QmlGenericScheme.tsc IdentMap.t
  let pass = "pass_Typing"
  let pp f map =
    IdentMap.iter
      (fun k v ->
         Format.fprintf f "@[<2>%s ->@ %a@]@\n" (Ident.to_string k) QmlPrint.pp#tsc v
      ) map
end

module R = ObjectFiles.Make(S)



(* ************************************************************************** *)
(** {b Descr}: Module used to make the type of exceptions persistent along
separate compilation. In effect, to be safe, we must remind the type of
exceptions encountered in modules a module depends on.
The aim is to prevent a guy raising { A : int } and a guy catching
{ A = x } then using x as a string.
The persistent information stored is the QML type, assumed by invariant to
be a sum type always with a column variable (i.e. opened sum) representing
the structure of the type of exceptions.
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
module SExceptions =
struct
  type t = QmlAst.ty
  let pass = "pass_TypingExceptions"
  let pp f _ = Format.pp_print_string f "<dummy>"
end

module RExceptions = ObjectFiles.Make(SExceptions)



let process_code ?(save = true) env =
  (* ATTENTION ! Since the W-based typechecker uses global memoization tables
to speed-up type schemes importation from QML, we must empty them for
each new package compilation otherwise we will retain and confuse the
schemes renamed by different separate compilation-purpose refreshes. *)
  Typer_w.reset_toplevel_tydefs_schemes_env_memo () ;
  Typer_w.reset_toplevel_valdefs_schemes_env_memo () ;
  (* Also reset the type of exceptions, to drop cases coming from usages of
other packages we don't depend on. *)
  Typer_w.reset_type_exception () ;
  let typerEnv = env.P.typerEnv in
  let schema = typerEnv.QmlTypes.schema in
  let code = env.P.qmlAst in
  let initial_gamma = typerEnv.QmlTypes.gamma in
  let (rebuilt_gamma, stdlib_map) =
    let (map, map_stdlib) =
      R.fold_with_name ~deep: true
        (fun package (acc_map, acc_stdlib) map ->
           let map =
             IdentMap.map (QmlRefresh.refresh_typevars_from_tsc package) map in
           let acc_map = IdentMap.safe_merge acc_map map in
           let acc_stdlib =
             if ObjectFiles.stdlib_packages package then
               IdentMap.safe_merge acc_stdlib map
             else acc_stdlib in
           (acc_map, acc_stdlib))
        (QmlTypes.Env.Ident.to_map initial_gamma, IdentMap.empty) in
    QmlTypes.Env.Ident.from_map map initial_gamma,
    map_stdlib in
  let typerEnv = { typerEnv with QmlTypes.gamma = rebuilt_gamma } in
  (* Restore the structure of the type "exception". We get the list of types
assumed to be sums, that each module we depend on created. *)
  let exn_tys_list =
    RExceptions.fold_with_name ~deep: true
      (fun _package accu_exn_ty exn_ty ->
         exn_ty :: accu_exn_ty)
      [] in
  (* Inject this structure inside the typechecker by cascading unifications
of all the types found for type "exception" in all the modules we depend
on. *)
  Typer_w.init_type_exception rebuilt_gamma exn_tys_list ;

  let typerEnv = QmlTyper.OfficialTyper.fold typerEnv code in
  let typerEnv =
    if ObjectFiles.compilation_mode() = `init then typerEnv
    else
      QmlDbGen.Schema.fold_expr
        QmlTyper.OfficialTyper.fold_expr typerEnv schema in
  let final_gamma = typerEnv.QmlTypes.gamma in
  (* we remove anything from the gamma that does not come from this compilation,
* i.e. that is in rebuilt gamma but not in initial gamma *)
  let diff_map =
    IdentMap.diff2
      (QmlTypes.Env.Ident.to_map final_gamma)
      (QmlTypes.Env.Ident.to_map rebuilt_gamma)
      (QmlTypes.Env.Ident.to_map initial_gamma) in

  (* Now, recover the structure of the sum type representing the type
"exception". *)
  let exception_ty_structure = Typer_w.get_type_exception_description () in

  if save then (
    R.save diff_map ;
    RExceptions.save exception_ty_structure (* Save the type "exception". *)
  ) ;

  let stdlib_map =
    if ObjectFiles.stdlib_packages (ObjectFiles.get_current_package ()) then
      QmlTypes.Env.Ident.to_map final_gamma
    else stdlib_map in
  let stdlib_gamma =
    QmlTypes.Env.Ident.from_map stdlib_map QmlTypes.Env.empty in
  let diff_gamma = QmlTypes.Env.Ident.from_map diff_map initial_gamma in
  let typerEnv = { typerEnv with QmlTypes.gamma = diff_gamma } in
  { env with
      P.typerEnv = typerEnv ; qmlAst = code ; stdlib_gamma = stdlib_gamma }
Something went wrong with that request. Please try again.