[minor] switch.ml: distinguish types for arguments, tests and actions

Before this change, Switch will use 'make_if' either with tests
explicitly constructed from the provided primitives, or with
a matching scrutinee/argument directly to check that it is
non-zero. (Arguments are expected to be implicitly coercible to
booleans for the 'make_if' functions.)

This assumption may not always hold, for example if we tried to define
a switch construct on tagged integers in
asmcomp/cmm_helpers.ml. (I have a followup commit doing just that.)
The comparison primitives of Cmm return untagged booleans, the
conditional test is untagged, but a tagged integer cannot be tested
for non-zeroness by just using untagged 'if' directly.

The present commit clarifies the matter by separating the type of
actions, tests and arguments at the Switch level. It does not change
behavior in any way, but it makes it much easier to follow these
distinctions. (In particular, it the new typing discipline
demonstrates that the dangerous use of 'make_if' only happens exactly
once in the Switch functor.)

Changes

@@ -72,6 +72,9 @@ Working version
   Types
   (Nicolas Chataing, review by Jacques Garrigue)
 
+- #????: refactor the compilation of the 'switch' construct
+  (Gabriel Scherer, review by ???)
+
 ### Build system:
 
 ### Bug fixes:

asmcomp/cmm_helpers.ml

@@ -1504,8 +1504,10 @@ struct
   let geint = Ccmpi Cge
   let gtint = Ccmpi Cgt
 
-  type act = expression
   type loc = Debuginfo.t
+  type arg = expression
+  type test = expression
+  type act = expression
 
   (* CR mshinwell: GPR#2294 will fix the Debuginfo here *)
 
@@ -1514,6 +1516,7 @@ struct
   let make_offset arg n = add_const arg n Debuginfo.none
   let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
   let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
+  let make_is_nonzero arg = arg
   let make_if cond ifso ifnot =
     Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot,
       Debuginfo.none)

lambda/matching.ml

@@ -2333,9 +2333,10 @@ module SArg = struct
 
   let gtint = Pintcomp Cgt
 
-  type act = Lambda.lambda
-
   type loc = Lambda.scoped_location
+  type arg = Lambda.lambda
+  type test = Lambda.lambda
+  type act = Lambda.lambda
 
   let make_prim p args = Lprim (p, args, Loc_unknown)
 
@@ -2360,6 +2361,8 @@ module SArg = struct
 
   let make_isin h arg = Lprim (Pnot, [ make_isout h arg ], Loc_unknown)
 
+  let make_is_nonzero arg = arg
+
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
 
   let make_switch loc arg cases acts =

lambda/switch.ml

@@ -115,17 +115,23 @@ sig
   val ltint : primitive
   val geint : primitive
   val gtint : primitive
-  type act
+
   type loc
+  type arg
+  type test
+  type act
+
+  val bind : arg -> (arg -> act) -> act
+  val make_const : int -> arg
+  val make_offset : arg -> int -> arg
+  val make_prim : primitive -> arg list -> test
+  val make_isout : arg -> arg -> test
+  val make_isin : arg -> arg -> test
+  val make_is_nonzero : arg -> test
+
+  val make_if : test -> act -> act -> act
+  val make_switch : loc -> arg -> int array -> act array -> act
 
-  val bind : act -> (act -> act) -> act
-  val make_const : int -> act
-  val make_offset : act -> int -> act
-  val make_prim : primitive -> act list -> act
-  val make_isout : act -> act -> act
-  val make_isin : act -> act -> act
-  val make_if : act -> act -> act -> act
-  val make_switch : loc -> act -> int array -> act array -> act
   val make_catch : act -> int * (act -> act)
   val make_exit : int -> act
 end
@@ -571,6 +577,9 @@ let rec pkey chan  = function
   and make_if_ne  arg i ifso ifnot =
     make_if_test Arg.neint arg i ifso ifnot
 
+  let make_if_nonzero arg ifso ifnot =
+    Arg.make_if (Arg.make_is_nonzero arg) ifso ifnot
+
   let do_make_if_out h arg ifso ifno =
     Arg.make_if (Arg.make_isout h arg) ifso ifno
 
@@ -660,7 +669,7 @@ let rec pkey chan  = function
           and right = {s with cases=right} in
 
           if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
-            Arg.make_if
+            make_if_nonzero
               ctx.arg
               (c_test ctx right) (c_test ctx left)
           else if less_tests cright cleft then

lambda/switch.mli

@@ -74,28 +74,35 @@ module type S =
     val ltint : primitive
     val geint : primitive
     val gtint : primitive
-    (* type of actions *)
-    type act
+
     (* type of source locations *)
     type loc
+    (* type of switch scrutinees *)
+    type arg
+    (* type of tests on scrutinees *)
+    type test
+    (* type of actions *)
+    type act
 
     (* Various constructors, for making a binder,
         adding one integer, etc. *)
-    val bind : act -> (act -> act) -> act
-    val make_const : int -> act
-    val make_offset : act -> int -> act
-    val make_prim : primitive -> act list -> act
-    val make_isout : act -> act -> act
-    val make_isin : act -> act -> act
-    val make_if : act -> act -> act -> act
+    val bind : arg -> (arg -> act) -> act
+    val make_const : int -> arg
+    val make_offset : arg -> int -> arg
+    val make_prim : primitive -> arg list -> test
+    val make_isout : arg -> arg -> test
+    val make_isin : arg -> arg -> test
+    val make_is_nonzero : arg -> test
+
+    val make_if : test -> act -> act -> act
    (* construct an actual switch :
       make_switch arg cases acts
       NB:  cases is in the value form *)
-    val make_switch : loc -> act -> int array -> act array -> act
+    val make_switch : loc -> arg -> int array -> act array -> act
+
    (* Build last minute sharing of action stuff *)
    val make_catch : act -> int * (act -> act)
    val make_exit : int -> act
-
   end
 
 
@@ -116,14 +123,14 @@ module Make :
       val zyva :
           Arg.loc ->
           (int * int) ->
-           Arg.act ->
+           Arg.arg ->
            (int * int * int) array ->
            (Arg.act, _) t_store ->
            Arg.act
 
 (* Output test sequence, sharing tracked *)
      val test_sequence :
-           Arg.act ->
+           Arg.arg ->
            (int * int * int) array ->
            (Arg.act, _) t_store ->
            Arg.act