Source file driver.ml

(* Js_of_ocaml compiler
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program 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 Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)
open! Stdlib

let debug = Debug.find "main"

let times = Debug.find "times"

let should_export = function
  | `Iife -> false
  | `Named _ | `Anonymous -> true

let tailcall p =
  if Config.Flag.effects ()
  then p
  else (
    if debug () then Format.eprintf "Tail-call optimization...@.";
    Tailcall.f p)

let deadcode' p =
  if debug () then Format.eprintf "Dead-code...@.";
  Deadcode.f p

let deadcode p =
  let r, _ = deadcode' p in
  r

let inline p =
  if Config.Flag.inline () && Config.Flag.deadcode ()
  then (
    let p, live_vars = deadcode' p in
    if debug () then Format.eprintf "Inlining...@.";
    Inline.f p live_vars)
  else p

let specialize_1 (p, info) =
  if debug () then Format.eprintf "Specialize...@.";
  Specialize.f info p

let specialize_js (p, info) =
  if debug () then Format.eprintf "Specialize js...@.";
  Specialize_js.f info p

let specialize_js_once p =
  if debug () then Format.eprintf "Specialize js once...@.";
  Specialize_js.f_once p

let specialize' (p, info) =
  let p = specialize_1 (p, info) in
  let p = specialize_js (p, info) in
  p, info

let specialize p = fst (specialize' p)

let eval (p, info) = if Config.Flag.staticeval () then Eval.f info p else p

let flow p =
  if debug () then Format.eprintf "Data flow...@.";
  Flow.f p

let flow_simple p =
  if debug () then Format.eprintf "Data flow...@.";
  Flow.f ~skip_param:true p

let phi p =
  if debug () then Format.eprintf "Variable passing simplification...@.";
  Phisimpl.f p

let effects p =
  if Config.Flag.effects ()
  then (
    if debug () then Format.eprintf "Effects...@.";
    Effects.f p |> inline |> deadcode |> phi |> flow |> fst |> Lambda_lifting.f)
  else p

let print p =
  if debug () then Code.Print.program (fun _ _ -> "") p;
  p

let ( +> ) f g x = g (f x)

let rec loop max name round i (p : 'a) : 'a =
  let p' = round p in
  if i >= max || Code.eq p' p
  then p'
  else (
    if times () then Format.eprintf "Start Iteration (%s) %d...@." name i;
    loop max name round (i + 1) p')

let identity x = x

(* o1 *)

let o1 : 'a -> 'a =
  print
  +> tailcall
  +> flow_simple (* flow simple to keep information for future tailcall opt *)
  +> specialize'
  +> eval
  +> inline (* inlining may reveal new tailcall opt *)
  +> deadcode
  +> tailcall
  +> phi
  +> flow
  +> specialize'
  +> eval
  +> inline
  +> deadcode
  +> print
  +> flow
  +> specialize'
  +> eval
  +> inline
  +> deadcode
  +> phi
  +> flow
  +> specialize
  +> identity

(* o2 *)

let o2 : 'a -> 'a = loop 10 "o1" o1 1 +> print

(* o3 *)

let round1 : 'a -> 'a =
  print
  +> tailcall
  +> inline (* inlining may reveal new tailcall opt *)
  +> deadcode (* deadcode required before flow simple -> provided by constant *)
  +> flow_simple (* flow simple to keep information for future tailcall opt *)
  +> specialize'
  +> eval
  +> identity

let round2 = flow +> specialize' +> eval +> deadcode +> o1

let o3 = loop 10 "tailcall+inline" round1 1 +> loop 10 "flow" round2 1 +> print

let generate d ~exported_runtime ~wrap_with_fun (p, live_vars) =
  if times () then Format.eprintf "Start Generation...@.";
  let should_export = should_export wrap_with_fun in
  Generate.f p ~exported_runtime ~live_vars ~should_export d

let header formatter ~custom_header =
  match custom_header with
  | None -> ()
  | Some c -> Pretty_print.string formatter (c ^ "\n")

let jsoo_header formatter build_info =
  Pretty_print.string formatter "// Generated by js_of_ocaml\n";
  Pretty_print.string formatter (Build_info.to_string build_info)

let debug_linker = Debug.find "linker"

let global_object = Constant.global_object

let extra_js_files =
  lazy
    (List.fold_left (Builtins.all ()) ~init:[] ~f:(fun acc file ->
         try
           let name = Builtins.File.name file in
           let ss =
             List.concat_map
               ~f:Linker.Fragment.provides
               (Linker.Fragment.parse_builtin file)
             |> StringSet.of_list
           in
           (name, ss) :: acc
         with _ -> acc))

let report_missing_primitives missing =
  let missing =
    List.fold_left
      (Lazy.force extra_js_files)
      ~init:missing
      ~f:(fun missing (file, pro) ->
        let d = StringSet.inter missing pro in
        if not (StringSet.is_empty d)
        then (
          warn "Missing primitives provided by %s:@." file;
          StringSet.iter (fun nm -> warn "  %s@." nm) d;
          StringSet.diff missing pro)
        else missing)
  in
  if not (StringSet.is_empty missing)
  then (
    warn "Missing primitives:@.";
    StringSet.iter (fun nm -> warn "  %s@." nm) missing)

let gen_missing js missing =
  let open Javascript in
  let miss =
    StringSet.fold
      (fun prim acc ->
        let p = ident prim in
        ( p
        , Some
            ( ECond
                ( EBin
                    ( NotEqEq
                    , EDot (EVar (ident global_object), prim)
                    , EVar (ident "undefined") )
                , EDot (EVar (ident global_object), prim)
                , EFun
                    ( None
                    , []
                    , [ ( Statement
                            (Expression_statement
                               (ECall
                                  ( EVar (ident "caml_failwith")
                                  , [ ( EBin
                                          ( Plus
                                          , EStr (prim, `Utf8)
                                          , EStr (" not implemented", `Utf8) )
                                      , `Not_spread )
                                    ]
                                  , N )))
                        , N )
                      ]
                    , N ) )
            , N ) )
        :: acc)
      missing
      []
  in
  if not (StringSet.is_empty missing)
  then (
    warn "There are some missing primitives@.";
    warn "Dummy implementations (raising 'Failure' exception) ";
    warn "will be used if they are not available at runtime.@.";
    warn "You can prevent the generation of dummy implementations with ";
    warn "the commandline option '--disable genprim'@.";
    report_missing_primitives missing);
  (Statement (Variable_statement miss), N) :: js

let mark_start_of_generated_code = Debug.find ~even_if_quiet:true "mark-runtime-gen"

let link ~standalone ~linkall (js : Javascript.source_elements) : Linker.output =
  if not standalone
  then { runtime_code = js; always_required_codes = [] }
  else
    let t = Timer.make () in
    if times () then Format.eprintf "Start Linking...@.";
    let traverse = new Js_traverse.free in
    let js = traverse#program js in
    let js =
      if mark_start_of_generated_code ()
      then
        let open Javascript in
        ( Statement
            (Expression_statement
               (EStr ("--MARK--" ^ "start-of-jsoo-gen" ^ "--MARK--", `Utf8)))
        , N )
        :: js
      else js
    in
    let free = traverse#get_free_name in
    let prim = Primitive.get_external () in
    let prov = Linker.get_provided () in
    let all_external = StringSet.union prim prov in
    let used = StringSet.inter free all_external in
    let linkinfos = Linker.init () in
    let linkinfos, missing = Linker.resolve_deps ~linkall linkinfos used in
    (* gen_missing may use caml_failwith *)
    let linkinfos, missing =
      if (not (StringSet.is_empty missing)) && Config.Flag.genprim ()
      then
        let linkinfos, missing2 =
          Linker.resolve_deps linkinfos (StringSet.singleton "caml_failwith")
        in
        linkinfos, StringSet.union missing missing2
      else linkinfos, missing
    in
    let js = if Config.Flag.genprim () then gen_missing js missing else js in
    if times () then Format.eprintf "  linking: %a@." Timer.print t;
    let js =
      if linkall
      then
        let open Javascript in
        let all = Linker.all linkinfos in
        let all = List.map all ~f:(fun name -> PNI name, EVar (ident name)) in
        ( Statement
            (Expression_statement
               (EBin (Eq, EDot (EVar (ident global_object), "jsoo_runtime"), EObj all)))
        , N )
        :: js
      else js
    in
    Linker.link js linkinfos

let check_js js =
  let t = Timer.make () in
  if times () then Format.eprintf "Start Checks...@.";
  let traverse = new Js_traverse.free in
  let js = traverse#program js in
  let free = traverse#get_free_name in
  let prim = Primitive.get_external () in
  let prov = Linker.get_provided () in
  let all_external = StringSet.union prim prov in
  let missing = StringSet.inter free all_external in
  let missing = StringSet.diff missing Reserved.provided in
  let other = StringSet.diff free missing in
  let res = Var_printer.get_reserved () in
  let other = StringSet.diff other res in
  if not (StringSet.is_empty missing) then report_missing_primitives missing;
  let probably_prov = StringSet.inter other Reserved.provided in
  let other = StringSet.diff other probably_prov in
  if (not (StringSet.is_empty other)) && debug_linker ()
  then (
    warn "Missing variables:@.";
    StringSet.iter (fun nm -> warn "  %s@." nm) other);
  if (not (StringSet.is_empty probably_prov)) && debug_linker ()
  then (
    warn "Variables provided by the browser:@.";
    StringSet.iter (fun nm -> warn "  %s@." nm) probably_prov);
  if times () then Format.eprintf "  checks: %a@." Timer.print t;
  js

let coloring js =
  let t = Timer.make () in
  if times () then Format.eprintf "Start Coloring...@.";
  let traverse = new Js_traverse.free in
  let js = traverse#program js in
  let free = traverse#get_free_name in
  Var_printer.add_reserved (StringSet.elements free);
  let js = Js_assign.program js in
  if times () then Format.eprintf "  coloring: %a@." Timer.print t;
  js

let output formatter build_info ~standalone ~custom_header ~source_map () js =
  let t = Timer.make () in
  if times () then Format.eprintf "Start Writing file...@.";
  if standalone then header ~custom_header formatter;
  if Config.Flag.header () then jsoo_header formatter build_info;
  Js_output.program formatter ?source_map js;
  if times () then Format.eprintf "  write: %a@." Timer.print t

let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_codes } =
  let module J = Javascript in
  let t = Timer.make () in
  if times () then Format.eprintf "Start Optimizing js...@.";
  (* pre pack optim *)
  let js =
    if Config.Flag.share_constant ()
    then (
      let t1 = Timer.make () in
      let js = (new Js_traverse.share_constant)#program js in
      if times () then Format.eprintf "    share constant: %a@." Timer.print t1;
      js)
    else js
  in
  let js =
    if Config.Flag.compact_vardecl ()
    then (
      let t2 = Timer.make () in
      let js = (new Js_traverse.compact_vardecl)#program js in
      if times () then Format.eprintf "    compact var decl: %a@." Timer.print t2;
      js)
    else js
  in
  (* pack *)
  let wrap_in_iife ~use_strict js =
    let var ident e =
      J.Statement (J.Variable_statement [ J.ident ident, Some (e, J.N) ]), J.N
    in
    let expr e = J.Statement (J.Expression_statement e), J.N in
    let freenames =
      let o = new Js_traverse.free in
      let (_ : J.program) = o#program js in
      o#get_free_name
    in
    let export_shim js =
      if StringSet.mem Constant.exports freenames
      then
        if should_export wrap_with_fun
        then var Constant.exports (J.EObj []) :: js
        else
          let export_node =
            let s =
              Printf.sprintf
                {|((typeof module === 'object' && module.exports) || %s)|}
                global_object
            in
            let lex = Parse_js.Lexer.of_lexbuf (Lexing.from_string s) in
            Parse_js.parse_expr lex
          in
          var Constant.exports export_node :: js
      else js
    in
    let old_global_object_shim js =
      if StringSet.mem Constant.old_global_object freenames
      then var Constant.old_global_object (J.EVar (J.ident global_object)) :: js
      else js
    in

    let efun args body = J.EFun (None, args, body, J.U) in
    let sfun name args body = J.Function_declaration (name, args, body, J.U), J.U in
    let mk f =
      let js = export_shim js in
      let js = old_global_object_shim js in
      let js = if use_strict then expr (J.EStr ("use strict", `Utf8)) :: js else js in
      f [ J.ident global_object ] js
    in
    match wrap_with_fun with
    | `Anonymous -> expr (mk efun)
    | `Named name -> mk (sfun (J.ident name))
    | `Iife ->
        expr (J.ECall (mk efun, [ J.EVar (J.ident global_object), `Not_spread ], J.N))
  in
  let always_required_js =
    (* consider adding a comments in the generated file with original
       location. e.g.
       {v
          //# 1 myfile.js
       v}
    *)
    List.map
      always_required_codes
      ~f:(fun { Linker.program; filename = _; requires = _ } ->
        wrap_in_iife ~use_strict:false program)
  in
  let runtime_js = wrap_in_iife ~use_strict:(Config.Flag.strictmode ()) js in
  let js = always_required_js @ [ runtime_js ] in
  let js =
    match wrap_with_fun, standalone with
    | `Named name, (true | false) ->
        let export_node =
          let s =
            Printf.sprintf
              {|
if (typeof module === 'object' && module.exports) {
  module['exports'] = %s;
}
|}
              name
          in
          let lex = Parse_js.Lexer.of_lexbuf (Lexing.from_string s) in
          Parse_js.parse lex
        in
        js @ export_node
    | `Anonymous, _ -> js
    | `Iife, false -> js
    | `Iife, true ->
        let e =
          let s =
            {|
(function (Object) {
  typeof globalThis !== 'object' && (
    this ?
      get() :
      (Object.defineProperty(Object.prototype, '_T_', {
        configurable: true,
        get: get
      }), _T_)
  );
  function get() {
    var global = this || self;
    global.globalThis = global;
    delete Object.prototype._T_;
  }
}(Object));
|}
          in
          let lex = Parse_js.Lexer.of_lexbuf (Lexing.from_string s) in
          Parse_js.parse lex
        in
        e @ js
  in
  (* post pack optim *)
  let t3 = Timer.make () in
  let js = (new Js_traverse.simpl)#program js in
  if times () then Format.eprintf "    simpl: %a@." Timer.print t3;
  let t4 = Timer.make () in
  let js = (new Js_traverse.clean)#program js in
  if times () then Format.eprintf "    clean: %a@." Timer.print t4;
  let js =
    if Config.Flag.shortvar ()
    then (
      let t5 = Timer.make () in
      let js = (new Js_traverse.rename_variable)#program js in
      if times () then Format.eprintf "    shortten vars: %a@." Timer.print t5;
      js)
    else js
  in
  if times () then Format.eprintf "  optimizing: %a@." Timer.print t;
  js

let configure formatter p =
  let pretty = Config.Flag.pretty () in
  Pretty_print.set_compact formatter (not pretty);
  Code.Var.set_pretty (pretty && not (Config.Flag.shortvar ()));
  Code.Var.set_stable (Config.Flag.stable_var ());
  p

type profile = Code.program -> Code.program

let full
    ~standalone
    ~wrap_with_fun
    ~profile
    ~linkall
    ~source_map
    ~custom_header
    ~build_info
    formatter
    d
    p =
  let exported_runtime = not standalone in
  let opt =
    configure formatter
    +> specialize_js_once
    +> profile
    +> effects
    +> Generate_closure.f
    +> deadcode'
  in
  let emit =
    generate d ~exported_runtime ~wrap_with_fun
    +> link ~standalone ~linkall
    +> pack ~wrap_with_fun ~standalone
    +> coloring
    +> check_js
    +> output formatter build_info ~standalone ~custom_header ~source_map ()
  in
  if times () then Format.eprintf "Start Optimizing...@.";
  let t = Timer.make () in
  let r = opt p in
  let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in
  emit r

let f
    ?(standalone = true)
    ?(wrap_with_fun = `Iife)
    ?(profile = o1)
    ?(linkall = false)
    ?source_map
    ?custom_header
    formatter
    d
    p =
  let build_info = Build_info.create () in
  full
    ~standalone
    ~wrap_with_fun
    ~profile
    ~linkall
    ~source_map
    ~custom_header
    ~build_info
    formatter
    d
    p

let from_string ~prims ~debug s formatter =
  let build_info = Build_info.create () in
  let p, d = Parse_bytecode.from_string ~prims ~debug s in
  full
    ~standalone:false
    ~wrap_with_fun:`Anonymous
    ~profile:o1
    ~linkall:false
    ~source_map:None
    ~custom_header:None
    ~build_info
    formatter
    d
    p

let profiles = [ 1, o1; 2, o2; 3, o3 ]

let profile i = try Some (List.assoc i profiles) with Not_found -> None