js_output.ml

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 * 
 * 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, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a 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. *)








module E = Js_exp_make 
module S = Js_stmt_make 

type finished = 
  | True 
  | False 
  | Dummy (* Have no idea, so that when [++] is applied, always use the other *)

type t  =  { 
  block : J.block ;
  value : J.expression option;
  finished : finished ; 
    (** When [finished] is true the block is already terminated, value does not make sense
        default is false, false is  an conservative approach 
     *)
}

type st = Lam_compile_defs.st 

let make ?value ?(finished=False) block = {block ; value ; finished }

let of_stmt ?value ?(finished = False) stmt = {block = [stmt] ; value ; finished }

let of_block ?value ?(finished = False) block = 
  {block  ; value ; finished }

let dummy = {value = None; block = []; finished = Dummy }

let handle_name_tail 
    (name : st)
    (should_return : Lam_compile_defs.return_type)
    lam (exp : J.expression) : t =
  begin match name, should_return with 
  | EffectCall, ReturnFalse -> 
      if Lam_analysis.no_side_effects lam 
      then dummy
      else {block = []; value  = Some exp ; finished = False}
  | EffectCall, ReturnTrue _ ->
      make [S.return  exp] ~finished:True
  | Declare (kind, n), ReturnFalse -> 
      make [ S.define ~kind n  exp]
  | Assign n ,ReturnFalse -> 
      make [S.assign n exp ]
  | (Declare _ | Assign _ ), ReturnTrue _ -> 
      make [S.unknown_lambda lam] ~finished:True
  | NeedValue, _ -> {block = []; value = Some exp; finished = False }
  end

let handle_block_return 
    (st : st) 
    (should_return : Lam_compile_defs.return_type)
    (lam : Lam.t) (block : J.block) exp : t = 
  match st, should_return with 
  | Declare (kind,n), ReturnFalse -> 
    make (block @ [ S.define ~kind  n exp])
  | Assign n, ReturnFalse -> make (block @ [S.assign n exp])
  | (Declare _ | Assign _), ReturnTrue _ -> make [S.unknown_lambda lam] ~finished:True
  | EffectCall, ReturnFalse -> make block ~value:exp
  | EffectCall, ReturnTrue _ -> make (block @ [S.return exp]) ~finished:True
  | NeedValue, _ ->  make block ~value:exp

let statement_of_opt_expr (x : J.expression option) : J.statement =
  match x with 
  | None -> S.empty ()
  | Some x when Js_analyzer.no_side_effect_expression x -> S.empty ()
        (* TODO, pure analysis in lambda instead *)
  | Some x -> S.exp x 

let rec unroll_block (block : J.block) = 
  match block with 
  | [{statement_desc = Block block}] -> unroll_block block 
  |  _ -> block 

let to_block ( x : t)  : J.block = 
  match x with 
  | {block; value = opt; finished} ->
      let block = unroll_block block in
      if finished = True  then block
      else 
        begin match opt with 
        | None -> block (* TODO, pure analysis in lambda instead *)
        | Some x when Js_analyzer.no_side_effect_expression x -> block
        | Some x -> block @ [S.exp x ]
        end

let to_break_block (x : t) : J.block * bool = 
    match x with 
    | {finished = True; block ; _ } -> 
        unroll_block block, false 
       (* value does not matter when [finished] is true
           TODO: check if it has side efects
        *)
    | {block; value =  None; finished } -> 
        let block = unroll_block block in 
        block, (match finished with | True -> false | (False | Dummy)  -> true  )

    | {block; value = opt; _} -> 
        let block = unroll_block block in
        block @ [statement_of_opt_expr opt], true

let rec append  (x : t ) (y : t ) : t =  
    match x , y with (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*)
    | {finished = True; _ }, _ -> x  
    | _, {block = []; value= None; finished = Dummy } -> x 
          (* finished = true --> value = E.undefined otherwise would throw*)
    | {block = []; value= None; _ }, y  -> y 
    | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x 
    | {block = []; value =  Some e1; _}, ({block = []; value = Some e2; finished } as z) -> 
        if Js_analyzer.no_side_effect_expression e1 
        then z
            (* It would optimize cases like [module aliases]
                Bigarray, List 
             *)
        else
          {block = []; value = Some (E.seq e1 e2); finished}
          (* {block = [S.exp e1]; value =  Some e2(\* (E.seq e1 e2) *\); finished} *)

       (** TODO: make everything expression make inlining hard, and code not readable?

           1. readability pends on how we print the expression 
           2. inlining needs generate symbols, which are statements, type mismatch
              we need capture [Exp e]

           can we call them all [statement]? statement has no value 
        *)
    (* | {block = [{statement_desc = Exp e }]; value = None ; _}, _ *)
    (*   -> *)
    (*     append { x with block = []; value = Some e} y *)
    (* |  _ , {block = [{statement_desc = Exp e }]; value = None ; _} *)
    (*   -> *)
    (*     append x { y with block = []; value = Some e} *)

    | {block = block1; value = opt_e1; _},  {block = block2; value = opt_e2; finished} -> 
        let block1 = unroll_block block1 in
        make (block1 @ (statement_of_opt_expr opt_e1  :: unroll_block block2))
          ?value:opt_e2 ~finished


module Ops = struct 
  let (++)  (x : t ) (y : t ) : t =  append x y 
end

(* Fold right is more efficient *)
let concat (xs : t list) : t = 
  List.fold_right (fun x acc -> append x  acc) xs dummy

let to_string x   = 
  Js_dump.string_of_block (to_block x)