tweak

Author: bobzhang

jscomp/core/lam_compile.ml

@@ -51,7 +51,8 @@ let rec flat_catches acc (x : Lam.t)
  flat_catches ((code,handler,bindings)::acc) l
  | _ -> acc, x
 
-let flatten_caches x = flat_catches [] x 
+let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t = 
+ flat_catches [] x 
 
 
 
@@ -101,12 +102,13 @@ type default_case =
  non-toplevel, it will explode code very quickly 
 *) 
 let rec 
- compile_external_field 
+ compile_external_field (* Like [List.empty]*)
  (cxt : Lam_compile_context.t) 
- lam 
+ (lam  : Lam.t)
  (id : Ident.t)
  (pos : int)
- env : Js_output.t = 
+ (env : Env.t)
+ : Js_output.t = 
  let f = Js_output.output_of_expression cxt.st cxt.should_return lam in 
  match Lam_compile_env.cached_find_ml_id_pos id pos env with 
  | {id; name; closed_lambda } ->
@@ -151,17 +153,23 @@ let rec
 
 and compile_external_field_apply 
  (cxt : Lam_compile_context.t) 
- lam 
- args_lambda
+ (lam : Lam.t) (* original lambda*)
+ (args_lambda : Lam.t list)
  (id : Ident.t)
- (pos : int) env : Js_output.t = 
- match Lam_compile_env.cached_find_ml_id_pos 
- id pos env with 
+ (pos : int)
+ (env : Env.t) : Js_output.t = 
+ match
+ Lam_compile_env.cached_find_ml_id_pos 
+ id pos env
+ with 
  | {id; name;arity; closed_lambda ; _} -> 
  let args_code, args = 
  Ext_list.fold_right 
  (fun (x : Lam.t) (args_code, args) ->
- match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with
+ match
+ compile_lambda
+ {cxt with st = NeedValue; should_return = ReturnFalse} x
+ with
  | {block = a; value = Some b} -> 
  (Ext_list.append a args_code), (b :: args )
  | _ -> assert false
@@ -223,8 +231,13 @@ and compile_external_field_apply
  args (List.length args ))
 
 
-and compile_let let_kind (cxt : Lam_compile_context.t) id (arg : Lam.t) : Js_output.t =
- compile_lambda {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg 
+and compile_let 
+ (let_kind : Lam_compile_context.let_kind)
+ (cxt : Lam_compile_context.t)
+ (id : J.ident)
+ (arg : Lam.t) : Js_output.t =
+ compile_lambda
+ {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg 
 (** 
  The second return values are values which need to be wrapped using 
  [caml_update_dummy] 
@@ -339,7 +352,8 @@ and compile_recursive_let ~all_bindings
  | _ -> assert false 
  end
  | Lvar _ ->
- compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
+ compile_lambda
+ {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
  | _ -> 
  (* pathological case:
  fail to capture taill call?
@@ -362,13 +376,16 @@ and compile_recursive_let ~all_bindings
  fun _-> print_endline "hey"; v ()
  ]}
  *)
- compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
+ compile_lambda
+ {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
 
 and compile_recursive_lets_aux cxt id_args : Js_output.t = 
  (* #1716 *)
- let output_code, ids = Ext_list.fold_right
+ let output_code, ids =
+ Ext_list.fold_right
  (fun (ident,arg) (acc, ids) -> 
- let code, declare_ids = compile_recursive_let ~all_bindings:id_args cxt ident arg in
+ let code, declare_ids =
+ compile_recursive_let ~all_bindings:id_args cxt ident arg in
  (code ++ acc, Ext_list.append declare_ids ids )
  ) id_args (Js_output.dummy, [])
  in
@@ -388,7 +405,8 @@ and compile_recursive_lets cxt id_args : Js_output.t =
  | [ ] -> assert false 
  | first::rest ->
  let acc = compile_recursive_lets_aux cxt first in 
- List.fold_left (fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest 
+ List.fold_left
+ (fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest 
  end 
 and compile_general_cases : 
  'a . 
@@ -456,14 +474,18 @@ and compile_general_cases :
  in
  let body = 
  table 
- |> Ext_list.stable_group (fun (_,lam) (_,lam1) -> Lam_analysis.eq_lambda lam lam1)
+ |> Ext_list.stable_group
+ (fun (_,lam) (_,lam1)
+ -> Lam_analysis.eq_lambda lam lam1)
  |> Ext_list.flat_map 
  (fun group -> 
  group 
  |> Ext_list.map_last 
  (fun last (x,lam) -> 
  if last 
- then {J.case = x; body = Js_output.to_break_block (compile_lambda cxt lam) }
+ then {J.case = x;
+ body =
+ Js_output.to_break_block (compile_lambda cxt lam) }
  else { case = x; body = [],false }))
  (* TODO: we should also group default *)
  (* The last clause does not need [break]
@@ -472,11 +494,15 @@ and compile_general_cases :
  in
  [switch ?default ?declaration v body] 
 
-and compile_cases cxt = compile_general_cases (fun x -> E.small_int x) E.int_equal cxt 
- (fun ?default ?declaration e clauses -> S.int_switch ?default ?declaration e clauses)
+and compile_cases cxt =
+ compile_general_cases (fun x -> E.small_int x) E.int_equal cxt 
+ (fun ?default ?declaration e clauses ->
+ S.int_switch ?default ?declaration e clauses)
 
-and compile_string_cases cxt = compile_general_cases E.str E.string_equal cxt 
- (fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses)
+and compile_string_cases cxt =
+ compile_general_cases E.str E.string_equal cxt 
+ (fun ?default ?declaration e clauses ->
+ S.string_switch ?default ?declaration e clauses)
 (* TODO: optional arguments are not good 
  for high order currying *)
 and
@@ -500,15 +526,15 @@ and
 
 
  | Lapply{
- fn = Lapply{ fn = an; args = args'; status = App_na ; };
+ fn = Lapply{ fn = an; args = fn_args; status = App_na ; };
  args; 
  status = App_na; loc }
  -> 
  (* After inlining we can generate such code, 
  see {!Ari_regress_test} 
  *) 
  compile_lambda cxt 
- (Lam.apply an (Ext_list.append args' args) loc App_na )
+ (Lam.apply an (Ext_list.append fn_args args) loc App_na )
  (* External function calll *)
  | Lapply{ fn = 
  Lprim{primitive = Pfield (n,_); 
@@ -651,19 +677,23 @@ and
  ->
  compile_lambda cxt (Lam.sequand l r )
  | _ -> 
- let l_block,l_expr = 
- match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} l with 
- | {block = a; value = Some b} -> a, b
- | _ -> assert false 
- in
- let r_block, r_expr = 
- match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} r with
- | {block = a; value = Some b} -> a, b
- | _ -> assert false 
- in
- let args_code = Ext_list.append l_block r_block in
- let exp = E.and_ l_expr r_expr in
- Js_output.output_of_block_and_expression st should_return lam args_code exp 
+
+ match
+ compile_lambda 
+ {cxt with st = NeedValue; should_return = ReturnFalse} l with 
+ | { value = None } -> assert false 
+ | {block = l_block; value = Some l_expr} ->
+ match
+ compile_lambda
+ {cxt with st = NeedValue; should_return = ReturnFalse} r
+ with
+ | { value = None } -> assert false 
+ | {block = r_block; value = Some r_expr} -> 
+ let args_code = Ext_list.append l_block r_block in
+ let exp = E.and_ l_expr r_expr in
+ Js_output.output_of_block_and_expression 
+ st 
+ should_return lam args_code exp 
  end
 
  | Lprim {primitive = Psequor; args = [l;r]}

jscomp/test/bs_hashtbl_string_test.js

@@ -23,7 +23,7 @@ var hashString = (function (str) {
  while(i !== 0) {
  hash = (hash * 33) ^ str.charCodeAt(--i);
  }
- return hash 
+ return hash
  }
  );