checkpoint before 2 type params

Author: jvanburen

lambda/lambda.ml

@@ -131,6 +131,10 @@ type integer_comparison =
 type float_comparison =
     CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
 
+type taggable_integer =
+  | Int8
+  | Int16
+  | Immediate
 
 type unboxed_float = Primitive.unboxed_float =
   | Unboxed_float64
@@ -238,113 +242,192 @@ and scannable_product_element_kind =
 
 
 module Scalar = struct
+  type any_locality_mode = Any_locality_mode
+
+  type tagged_immediate = Tagged_immediate
+
   module Maybe_naked = struct
-    type 'a t =
-      { t : 'a
-      ; naked : bool
-      }
+    type ('a, 'b) t =
+      | Naked of 'a
+      | Value of 'b
 
-    let map {t; naked} ~f =
-      {t = f t; naked}
-  end
+    module Make1 (M : sig
+        type 'a t
 
-  type any_locality_mode = Any_locality_mode
+        val map : 'a t -> f:('a -> 'b) -> 'b t
+      end) = struct
+      type nonrec 'a t = (any_locality_mode M.t, 'a M.t) t
+
+      let map (t : _ t) ~f =
+        match t with
+        | Naked (_ : any_locality_mode M.t) as t -> t
+        | Value t -> Value (M.map t ~f)
+      end
+  end
 
-  type tagged_immediate = Tagged_immediate
 
   module Integral = struct
-    type 'mode t =
-      | Tagged_int8
-      | Tagged_int16
-      | Tagged_immediate
-      | Boxed_int32 of 'mode
-      | Boxed_nativeint of 'mode
-      | Boxed_int64 of 'mode
-      | Naked_int8
-      | Naked_int16
-      | Naked_int32
-      | Naked_nativeint
-      | Naked_int64
+    module Taggable = struct
+      type t =
+        | Int8
+        | Int16
+        | Immediate
+
+      let to_unboxed_integer = function
+        | Int8 -> Unboxed_int8
+        | Int16 -> Unboxed_int16
+        | Immediate -> Unboxed_immediate
+
+      module Maybe_naked = struct
+        type nonrec t = (t, t) Maybe_naked.t
+
+        let layout : t -> layout = function
+          | Naked t -> Punboxed_int (to_unboxed_integer t)
+          | Value (Int8 | Int16 | Immediate) ->
+            Pvalue { raw_kind = Pintval; nullable = Non_nullable }
+
+        let locality_mode : t -> locality_mode option = function
+          | Naked _ -> None
+          | Value _ -> None
+      end
+    end
 
-    let locality_mode = function
-      | Boxed_int32 locality_mode
-      | Boxed_nativeint locality_mode
-      | Boxed_int64 locality_mode ->
-        Some locality_mode
-      | Tagged_int8 | Tagged_int16 | Tagged_immediate | Naked_int8 | Naked_int16
-      | Naked_int32 | Naked_nativeint | Naked_int64 ->
-        None
-
-    let layout = function
-      | Tagged_int8
-      | Tagged_int16
-      | Tagged_immediate -> Pvalue { raw_kind = Pintval; nullable = Non_nullable }
-      | Boxed_int32 _ -> Pvalue { raw_kind = Pboxedintval Boxed_int32; nullable = Non_nullable }
-      | Boxed_nativeint _ -> Pvalue { raw_kind = Pboxedintval Boxed_nativeint; nullable = Non_nullable }
-      | Boxed_int64 _ -> Pvalue { raw_kind = Pboxedintval Boxed_int64; nullable = Non_nullable }
-      | Naked_int8 -> Punboxed_int Unboxed_int8
-      | Naked_int16 -> Punboxed_int Unboxed_int16
-      | Naked_int32 -> Punboxed_int Unboxed_int32
-      | Naked_nativeint -> Punboxed_int Unboxed_nativeint
-      | Naked_int64 -> Punboxed_int Unboxed_int64
+    module Boxable = struct
+      module T = struct
+        type 'mode t =
+          | Int32 of 'mode
+          | Nativeint of 'mode
+          | Int64 of 'mode
+
+        let map t ~f =
+          match t with
+          | Int32 mode -> Int32 (f mode)
+          | Nativeint mode -> Nativeint (f mode)
+          | Int64 mode -> Int64 (f mode)
+
+        let locality_mode (Int32 mode| Nativeint mode | Int64 mode) : locality_mode = mode
+      end
+
+      include T
+
+      let to_boxed_integer = function
+        | Int32 Any_locality_mode -> Boxed_int32
+        | Nativeint Any_locality_mode -> Boxed_nativeint
+        | Int64 Any_locality_mode -> Boxed_int64
+
+      let to_unboxed_integer = function
+        | Int32 Any_locality_mode -> Unboxed_int32
+        | Nativeint Any_locality_mode -> Unboxed_nativeint
+        | Int64 Any_locality_mode -> Unboxed_int64
+
+      module Maybe_naked = struct
+        include Maybe_naked.Make1 (T)
+
+        let layout : any_locality_mode t -> layout = function
+          | Value t -> Pvalue { raw_kind = Pboxedintval (to_boxed_integer t); nullable = Non_nullable }
+          | Naked t -> Punboxed_int (to_unboxed_integer t)
+
+        let locality_mode : locality_mode t -> locality_mode option = function
+          | Naked (_ : any_locality_mode T.t) -> None
+          | Value t -> Some (locality_mode t)
+      end
+
+    end
+
+    module T = struct
+      type 'mode t =
+        | Taggable of Taggable.t
+        | Boxable of 'mode Boxable.t
+
+      let map t ~f =
+        match t with
+        | Taggable (Int8 | Int16 | Immediate) as t -> t
+        | Boxable b -> Boxable (Boxable.map b ~f)
+
+      let locality_mode = function
+        | Taggable (Int8 | Int16 | Immediate) -> None
+        | Boxable b -> Some (Boxable.locality_mode b)
+    end
+    include T
+
+    let to_unboxed_integer = function
+      | Taggable t -> Taggable.to_unboxed_integer t
+      | Boxable b -> Boxable.to_unboxed_integer b
+
+    module Maybe_naked = struct
+      include Maybe_naked.Make1 (T)
+
+      let layout : any_locality_mode t -> layout = function
+        | Value (Taggable t) -> Taggable.Maybe_naked.layout (Value t)
+        | Naked (Taggable t) -> Taggable.Maybe_naked.layout (Naked t)
+        | Value (Boxable t) -> Boxable.Maybe_naked.layout (Value t)
+        | Naked (Boxable t) -> Boxable.Maybe_naked.layout (Naked t)
+      ;;
+
+      let locality_mode : locality_mode t -> locality_mode option = function
+        | Naked (_ : any_locality_mode T.t) -> None
+        | Value t -> locality_mode t
+    end
+  end
+
+  module Floating = struct
+    module T = struct
+      type 'mode t =
+        | Float32 of 'mode
+        | Float64 of 'mode
+    end
+    include T
 
     let map t ~f =
       match t with
-      | Boxed_int32 mode -> Boxed_int32 (f mode)
-      | Boxed_nativeint mode -> Boxed_nativeint (f mode)
-      | Boxed_int64 mode -> Boxed_int64 (f mode)
-      | Tagged_int8 | Tagged_int16 | Tagged_immediate | Naked_int8 | Naked_int16
-      | Naked_int32 | Naked_nativeint | Naked_int64  as t -> t
+      | Float32 mode -> Float32 (f mode)
+      | Float64 mode -> Float64 (f mode)
+
+    let locality_mode (Float32 mode | Float64 mode) : locality_mode = mode
+
+    let to_boxed_float = function
+      | Float32 Any_locality_mode -> Boxed_float32
+      | Float64 Any_locality_mode -> Boxed_float64
+
+    let to_unboxed_float = function
+      | Float32 Any_locality_mode -> Unboxed_float32
+      | Float64 Any_locality_mode -> Unboxed_float64
+
+    let layout : any_locality_mode Maybe_naked.M(T).t -> layout = function
+      | Value t -> Pvalue { raw_kind = Pboxedfloatval (to_boxed_float t); nullable = Non_nullable }
+      | Naked t -> Punboxed_float (to_unboxed_float t)
   end
 
-  module Floating = struct
+  module T1 = struct
     type 'mode t =
-      | Unboxed_float32
-      | Unboxed_float64
-      | Boxed_float32 of 'mode
-      | Boxed_float64 of 'mode
+      | Floating of 'mode Floating.t
+      | Integral of 'mode Integral.t
 
     let map t ~f =
       match t with
-      | Boxed_float32 mode -> Boxed_float32 (f mode)
-      | Boxed_float64 mode -> Boxed_float64 (f mode)
-      | Unboxed_float32 | Unboxed_float64 as t -> t
+      | Floating g -> Floating (Floating.map g ~f)
+      | Integral i -> Integral (Integral.map i ~f)
 
     let locality_mode = function
-      | Unboxed_float32 | Unboxed_float64 -> None
-      | Boxed_float32 mode | Boxed_float64 mode -> Some mode
-
-    let layout = function
-      | Unboxed_float32 -> Punboxed_float Unboxed_float32
-      | Unboxed_float64 -> Punboxed_float Unboxed_float64
-      | Boxed_float32 _ -> Pvalue { raw_kind = Pboxedfloatval Boxed_float32; nullable = Non_nullable }
-      | Boxed_float64 _ -> Pvalue { raw_kind = Pboxedfloatval Boxed_float64; nullable = Non_nullable }
+      | Floating f -> Some (Floating.locality_mode f)
+      | Integral i -> Integral.locality_mode i
+
+    let layout : (any_locality_mode t, any_locality_mode t) Maybe_naked.t -> layout = function
+      | Value (Floating f) -> Floating.layout (Value f)
+      | Naked (Floating f) -> Floating.layout (Naked f)
+      | Value (Integral i) -> Integral.layout (Value i)
+      | Naked (Integral i) -> Integral.layout (Naked i)
   end
 
-  type 'mode t =
-    | Floating of 'mode Floating.t
-    | Integral of 'mode Integral.t
-
-  let locality_mode = function
-    | Floating f -> Floating.locality_mode f
-    | Integral i -> Integral.locality_mode i
+  type 'mode t = 'mode Maybe_naked.M(T1).t
 
-  let layout = function
-    | Floating f -> Floating.layout f
-    | Integral i -> Integral.layout i
+  let locality_mode : locality_mode t -> locality_mode option = function
+    | Naked (_ : any_locality_mode T1.t) -> None
+    | Value t -> Some (locality_mode t)
 
-  type 'mode scalar = 'mode t
 
   module Bytecode = struct
-    type tagged_integer =
-      | Tagged_int8
-      | Tagged_int16
-      | Tagged_immediate
-
-    type t =
-      | Tagged_immediate of tagged_integer
-      | Boxed_integer of boxed_integer
-      | Boxed_float of boxed_float
+    type nonrec t = Boxed of any_locality_mode t
 
     let of_scalar : any_locality_mode scalar -> t Maybe_naked.t = function
       | Integral Naked_int8 -> { t = Tagged_immediate Tagged_int8; naked = true }
@@ -371,7 +454,7 @@ module Scalar = struct
       | Floating (Boxed_float64 Any_locality_mode) ->
         { t = Boxed_float Boxed_float64; naked = false }
 
-    let to_scalar : t Maybe_naked.t -> any_locality_mode scalar =
+    let to_scalar : t Maybe_naked.t -> any_locality_mode scalar = function
       | { t = Tagged_immediate Tagged_int8; naked = true } -> Integral Naked_int8
       | { t = Tagged_immediate Tagged_int16; naked = true } -> Integral Naked_int16
       | { t = Tagged_immediate Tagged_immediate; naked = true } -> Integral Naked_immediate
@@ -2794,7 +2877,7 @@ module Bytecode = struct
              [int_size; Lconst(const_int bits)], loc)
 
     | Tagged_immediate Tagged_immediate-> Misc.fatal_error "There is no Naked_immediate type yet"
-    |
+
 
   (* let unwrap arg ~src ~dst =
    *   match t with