Merge pull request #474 from bloomberg/div_by_zero

[fix] div by zero semantics

jscomp/common/js_config.ml

@@ -262,3 +262,8 @@ let is_same_file () =
   !debug_file <> "" &&  !debug_file = !current_file
 
 let tool_name = "BuckleScript"
+let check_div_by_zero = ref true
+
+let get_check_div_by_zero () = !check_div_by_zero 
+
+

jscomp/common/js_config.mli

@@ -102,3 +102,7 @@ val get_debug_file : unit -> string
 val is_same_file : unit -> bool 
 
 val tool_name : string
+
+val check_div_by_zero : bool ref 
+
+val get_check_div_by_zero : unit -> bool 

jscomp/js_exp_make.ml

@@ -1044,37 +1044,54 @@ let float_div ?comment e1 e2 =
 let float_notequal ?comment e1 e2 = 
   bin ?comment NotEqEq e1 e2
 
-(** Division by zero is undefined behavior*)
-let unchecked_int32_div ?comment e1 e2 : J.expression = 
-  to_int32 (float_div ?comment e1 e2)
 
 let int32_asr ?comment e1 e2 : J.expression = 
   { comment ; 
     expression_desc = Bin (Asr, e1,e2)
   }
 
-let int32_div ?comment (e1 : J.expression) (e2 : J.expression)
-  : J.expression = 
+(** Division by zero is undefined behavior*)
+let int32_div ~checked ?comment 
+    (e1 : t) (e2 : t) : t = 
   match e1.expression_desc, e2.expression_desc with 
   | Length _ , Number (Int {i = 2l} | Uint 2l | Nint 2n)
     -> int32_asr e1 one_int_literal 
-  | Number(Int {i = i0}) , Number (Int {i = i1} ) when i1 <> 0l
-    -> int (Int32.div i0 i1)
+  | e1_desc , Number (Int {i = i1} ) when i1 <> 0l
+    -> 
+    begin match e1_desc with 
+    | Number(Int {i = i0})
+      -> 
+      int (Int32.div i0 i1)
+    | _ -> to_int32 (float_div ?comment e1 e2)
+    end
   | _, _ -> 
-    to_int32 (float_div ?comment e1 e2)
+    if checked  then 
+      runtime_call Js_config.int32 "div" [e1; e2]
+    else to_int32 (float_div ?comment e1 e2)
 
 
+let int32_mod ~checked ?comment e1 (e2 : t) : J.expression = 
+  match e2.expression_desc with 
+  | Number (Int {i }) when i <> 0l 
+    -> 
+    { comment ; 
+      expression_desc = Bin (Mod, e1,e2)
+    }
+
+  | _ -> 
+    if checked then 
+      runtime_call Js_config.int32 "mod_" [e1;e2]
+    else 
+      { comment ; 
+        expression_desc = Bin (Mod, e1,e2)
+      }
+
 
 let float_mul ?comment e1 e2 = 
   bin ?comment Mul e1 e2 
 
 
 
-(* TODO: check division by zero *)                
-let int32_mod ?comment e1 e2 : J.expression = 
-  { comment ; 
-    expression_desc = Bin (Mod, e1,e2)
-  }
 
 let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = 
   match e1, e2  with 

jscomp/js_exp_make.mli

@@ -162,11 +162,14 @@ val unchecked_int32_minus : binary_op
 val int32_minus : binary_op
 val int32_mul : binary_op
 val unchecked_int32_mul : binary_op
-val int32_div : binary_op
+
+val int32_div : checked:bool -> binary_op
+val int32_mod : checked:bool -> binary_op
+
 val int32_lsl : binary_op
 val int32_lsr : binary_op
 val int32_asr : binary_op
-val int32_mod : binary_op
+
 val int32_bxor : binary_op
 val int32_band : binary_op
 val int32_bor : binary_op

jscomp/js_main.ml

@@ -77,9 +77,12 @@ let buckle_script_flags =
     " set will generate `.d.ts` file for typescript (experimental)")
   :: ("-bs-diagnose", Arg.Set Js_config.diagnose, 
       " More verbose output")
+  :: ("-bs-no-check-div-by-zero", Arg.Clear Js_config.check_div_by_zero, 
+      " unsafe mode, don't check div by zero and mod by zero")
   :: ("-bs-files", Arg.Rest collect_file, 
       " Provide batch of files, the compiler will sort it before compiling"
      )
+
   :: Ocaml_options.mk_impl impl
   :: Ocaml_options.mk_intf intf 
   :: Ocaml_options.mk__ anonymous

jscomp/lam.ml

@@ -424,8 +424,12 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
               | Paddint -> int_ (Int32.add aa bb)
               | Psubint -> int_ (Int32.sub aa bb)
               | Pmulint -> int_ (Int32.mul aa  bb)
-              | Pdivint -> (try int_ (Int32.div aa  bb) with _ -> default ())
-              | Pmodint -> int_ (Int32.rem aa  bb)
+              | Pdivint -> 
+                if bb = 0l then default ()
+                else int_ (Int32.div aa bb)
+              | Pmodint ->
+                if bb = 0l then default ()
+                else int_ (Int32.rem aa bb)
               | Pandint -> int_ (Int32.logand aa bb)
               | Porint -> int_ (Int32.logor aa bb)
               | Pxorint -> int_ (Int32.logxor aa bb)
@@ -449,7 +453,7 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
           | Psubbint _  -> lift_int32 (Int32.sub aa bb)
           | Pmulbint _ -> lift_int32 (Int32.mul aa  bb)
           | Pdivbint _ ->  (try lift_int32 (Int32.div aa  bb) with _  -> default ())
-          | Pmodbint _ -> lift_int32 (Int32.rem aa  bb)
+          | Pmodbint _ -> (try lift_int32 (Int32.rem aa  bb) with _ -> default ())
           | Pandbint _ -> lift_int32 (Int32.logand aa bb)
           | Porbint _ -> lift_int32 (Int32.logor aa bb)
           | Pxorbint _ -> lift_int32 (Int32.logxor aa bb)
@@ -477,7 +481,7 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
           | Psubbint _  -> lift_int64 (Int64.sub aa bb)
           | Pmulbint _ -> lift_int64 (Int64.mul aa  bb)
           | Pdivbint _ -> (try lift_int64 (Int64.div aa  bb) with _ -> default ())
-          | Pmodbint _ -> lift_int64 (Int64.rem aa  bb)
+          | Pmodbint _ -> (try lift_int64 (Int64.rem aa  bb) with _ -> default ())
           | Pandbint _ -> lift_int64 (Int64.logand aa bb)
           | Porbint _ -> lift_int64 (Int64.logor aa bb)
           | Pxorbint _ -> lift_int64 (Int64.logxor aa bb)

jscomp/lam_compile_primitive.ml

@@ -186,25 +186,31 @@ let translate
       | [e1;e2] -> E.float_div  e1  e2
       | _ -> assert false 
     end
+  | Pdivbint Pnativeint
+    -> 
+    begin match args with 
+      | [e1;e2] ->
+        E.int32_div ~checked:false e1 e2
+      | _ -> assert false
+    end
   | Pdivint 
-  | Pdivbint Lambda.Pnativeint
-  | Pdivbint Lambda.Pint32
+  | Pdivbint Pint32
     -> 
     begin match args with 
       | [e1;e2] ->
-        E.int32_div e1 e2
+        E.int32_div ~checked:(!Js_config.check_div_by_zero) e1 e2
       | _ -> assert false
     end
 
-  | Pdivbint Lambda.Pint64 
+  | Pdivbint Pint64 
     -> Js_long.div args 
   | Pmodint 
-  | Pmodbint Lambda.Pnativeint
-  | Pmodbint Lambda.Pint32
+  | Pmodbint Pnativeint
+  | Pmodbint Pint32
     ->
     begin match args with
       | [e1; e2] ->
-        E.int32_mod   e1  e2
+        E.int32_mod   ~checked:(!Js_config.check_div_by_zero) e1  e2
       | _ -> assert false 
     end
   | Pmodbint Lambda.Pint64 

jscomp/lam_dispatch_primitive.ml

@@ -179,13 +179,21 @@ let query (prim : Lam_compile_env.primitive_description)
     | [e0;e1] -> E.unchecked_int32_add e0 e1 
     | _ -> assert false 
     end
-  | "caml_int32_div"
+  | "caml_int32_div" 
+    -> 
+    begin match args with 
+      | [e0;e1] -> 
+        E.int32_div  ~checked:(!Js_config.check_div_by_zero) e0 e1
+      | _ -> assert false 
+    end
+
   | "caml_nativeint_div" 
     -> (* nativeint behaves exactly the same as js numbers except division *)
     begin match args with 
-    | [e0;e1] -> E.int32_div e0 e1
+    | [e0;e1] -> E.int32_div  ~checked:false e0 e1
     | _ -> assert false 
     end
+
   | "caml_int32_mul"
     -> 
     begin match args with 

jscomp/runtime/Makefile

@@ -21,7 +21,7 @@ $(addsuffix .cmj, $(OTHERS)): caml_builtin_exceptions.cmj  block.cmj js.cmj
 RUNTIME := $(addsuffix .cmj, $(SOURCE_LIST)) 
 
 
-COMPFLAGS += $(MODULE_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -w -40 -bs-npm-output-path $(npm_package_name):lib/js -bs-cross-module-opt -bs-diagnose
+COMPFLAGS += $(MODULE_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -w -40 -bs-npm-output-path $(npm_package_name):lib/js -bs-no-check-div-by-zero -bs-cross-module-opt -bs-diagnose
 
 
 

jscomp/runtime/caml_int32.ml

@@ -28,12 +28,12 @@
 
 
 
-let idiv (x:nativeint) (y:nativeint) = 
+let div (x:nativeint) (y:nativeint) = 
   if y = 0n  then
     raise Division_by_zero
   else Nativeint.div x y
 
-let imod (x : nativeint) (y:nativeint) = 
+let mod_ (x : nativeint) (y:nativeint) = 
   if y = 0n then
     raise Division_by_zero
   else Nativeint.rem x  y

jscomp/runtime/caml_int32.mli

@@ -27,9 +27,9 @@
 
 
 
-val idiv : nativeint -> nativeint -> nativeint
+val div : nativeint -> nativeint -> nativeint
 
-val imod : nativeint -> nativeint -> nativeint
+val mod_ : nativeint -> nativeint -> nativeint
 
 val caml_bswap16 : nativeint -> nativeint
 

jscomp/stdlib/Makefile.shared

@@ -22,7 +22,7 @@ CAMLC=$(CAMLRUN) $(COMPILER)
 #COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -bin-annot -nostdlib \
 #          -safe-string
 COMPFLAGS= $(MODULE_FLAGS) -strict-sequence -w +33..39 -g -warn-error A  -nostdlib \
-          -safe-string -I ../runtime -bs-npm-output-path $(npm_package_name):lib/js -bs-no-builtin-ppx-ml -bs-no-builtin-ppx-mli -bs-cross-module-opt -bs-diagnose
+          -safe-string -I ../runtime -bs-npm-output-path $(npm_package_name):lib/js -bs-no-builtin-ppx-ml -bs-no-builtin-ppx-mli -bs-cross-module-opt -bs-diagnose -bs-no-check-div-by-zero
 
 
 # OPTCOMPILER=ocamlopt.opt

jscomp/test/.depend

@@ -142,6 +142,8 @@ digest_test.cmj : ../stdlib/string.cmi ../stdlib/printf.cmi mt.cmi \
     ext_array.cmj ../stdlib/digest.cmi ../stdlib/array.cmi
 digest_test.cmx : ../stdlib/string.cmx ../stdlib/printf.cmx mt.cmx \
     ext_array.cmx ../stdlib/digest.cmx ../stdlib/array.cmx
+div_by_zero_test.cmj : mt.cmi ../stdlib/int64.cmi ../stdlib/int32.cmi
+div_by_zero_test.cmx : mt.cmx ../stdlib/int64.cmx ../stdlib/int32.cmx
 empty_obj.cmj :
 empty_obj.cmx :
 epsilon_test.cmj : mt.cmi
@@ -822,6 +824,8 @@ digest_test.cmo : ../stdlib/string.cmi ../stdlib/printf.cmi mt.cmi \
     ext_array.cmo ../stdlib/digest.cmi ../stdlib/array.cmi
 digest_test.cmj : ../stdlib/string.cmj ../stdlib/printf.cmj mt.cmj \
     ext_array.cmj ../stdlib/digest.cmj ../stdlib/array.cmj
+div_by_zero_test.cmo : mt.cmi ../stdlib/int64.cmi ../stdlib/int32.cmi
+div_by_zero_test.cmj : mt.cmj ../stdlib/int64.cmj ../stdlib/int32.cmj
 empty_obj.cmo :
 empty_obj.cmj :
 epsilon_test.cmo : mt.cmi

jscomp/test/div_by_zero_test.ml

@@ -0,0 +1,23 @@
+
+
+
+let suites :  Mt.pair_suites ref  = ref []
+let test_id = ref 0
+let eq loc x y = 
+  incr test_id ; 
+  suites := 
+    (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites
+let add suite = 
+  suites := suite :: !suites
+
+let () = 
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (3 / 0))));
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (3 mod 0))));
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (Int32.div 3l  0l))));
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (Int32.rem 3l  0l))));
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (Int64.div 3L  0L))));
+  add (__LOC__, (fun _ -> ThrowAny (fun _ -> ignore (Int64.rem 3L  0L))))
+
+let div x y = x / y + 3 
+
+let () = Mt.from_pair_suites __FILE__ !suites

jscomp/test/test.mllib

@@ -338,4 +338,5 @@ chain_code_test
 method_chain
 recursive_module
 recursive_module_test
-simplify_lambda_632o
+simplify_lambda_632o
+div_by_zero_test

lib/js/caml_int32.js

@@ -3,7 +3,7 @@
 
 var Caml_builtin_exceptions = require("./caml_builtin_exceptions");
 
-function idiv(x, y) {
+function div(x, y) {
   if (y === 0) {
     throw Caml_builtin_exceptions.division_by_zero;
   }
@@ -12,7 +12,7 @@ function idiv(x, y) {
   }
 }
 
-function imod(x, y) {
+function mod_(x, y) {
   if (y === 0) {
     throw Caml_builtin_exceptions.division_by_zero;
   }
@@ -36,8 +36,8 @@ var imul = ( Math.imul || function (x,y) {
 
 var caml_nativeint_bswap = caml_int32_bswap;
 
-exports.idiv                 = idiv;
-exports.imod                 = imod;
+exports.div                  = div;
+exports.mod_                 = mod_;
 exports.caml_bswap16         = caml_bswap16;
 exports.caml_int32_bswap     = caml_int32_bswap;
 exports.caml_nativeint_bswap = caml_nativeint_bswap;