VisitorsRuntime.ml 22.7 KB
Newer Older
POTTIER Francois's avatar
POTTIER Francois committed
1 2
(* -------------------------------------------------------------------------- *)

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
(* [array_equal eq xs1 xs2] tests whether the arrays [xs1] and [xs2] have the
   same components. The arrays must have the same length. The components are
   compared using [eq]. *)

let rec array_equal eq i n xs1 xs2 =
  i = n ||
  let x1 = Array.unsafe_get xs1 i
  and x2 = Array.unsafe_get xs2 i in
  eq x1 x2 && array_equal eq (i + 1) n xs1 xs2

let array_equal eq xs1 xs2 =
  let n = Array.length xs1 in
  assert (Array.length xs2 = n);
  array_equal eq 0 n xs1 xs2

(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
20 21
(* An exception used at arity 2 and above. *)

POTTIER Francois's avatar
POTTIER Francois committed
22 23 24 25 26
exception StructuralMismatch

let fail () =
  raise StructuralMismatch

27 28 29 30 31 32 33 34 35 36 37 38 39 40
let wrap f t =
  try
    f t;
    true
  with StructuralMismatch ->
    false

let wrap2 f t1 t2 =
  try
    f t1 t2;
    true
  with StructuralMismatch ->
    false

POTTIER Francois's avatar
POTTIER Francois committed
41 42
(* -------------------------------------------------------------------------- *)

43 44 45
(* A virtual base class for monoids. *)

class virtual ['z] monoid = object
46 47
  method private virtual zero: 'z
  method private virtual plus: 'z -> 'z -> 'z
48 49 50 51 52 53 54 55
end

(* -------------------------------------------------------------------------- *)

(* Common monoids. *)

class ['z] addition_monoid = object
  inherit ['z] monoid
56 57
  method private zero = 0
  method private plus = (+)
58 59
end

POTTIER Francois's avatar
POTTIER Francois committed
60 61 62 63 64 65
class ['z] unit_monoid = object
  inherit ['z] monoid
  method private zero = ()
  method private plus () () = ()
end

66 67
(* -------------------------------------------------------------------------- *)

68
(* Visitor methods for the primitive types. *)
69

70 71 72 73 74 75 76
(* We COULD declare all of the methods below as polymorphic in ['env]. Indeed,
   they ARE polymorphic in ['env], because they do not extend it or look it up.
   However, by doing so, we would PREVENT users from overriding these methods
   so as to actually extend or look up the environment. It probably does not
   make much difference either way, but I feel better if the methods are not
   polymorphic in ['env]. *)

77 78
(* -------------------------------------------------------------------------- *)

79
(* [iter] *)
80

81
class ['self] iter = object (self)
82

83
  method private visit_array: 'a .
84
    ('env -> 'a -> unit) -> 'env -> 'a array -> unit
85 86 87 88 89 90
  = fun f env xs ->
      (* For speed, we inline [Array.iter]. Chances are, we save a closure
         allocation, as using [Array.iter] would require us to build [f env]. *)
      for i = 0 to Array.length xs - 1 do
        f env (Array.unsafe_get xs i)
      done
91

92
  method private visit_bool:
93
    'env -> bool -> unit
94
  = fun _ _ -> ()
95

96
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
97 98 99
    'env -> bytes -> unit
  = fun _ _ -> ()

100
  method private visit_char:
101
    'env -> char -> unit
102
  = fun _ _ -> ()
103

104
  method private visit_float:
105
    'env -> float -> unit
106
  = fun _ _ -> ()
107

108
  method private visit_int:
109
    'env -> int -> unit
110
  = fun _ _ -> ()
111

112
  method private visit_int32:
113
    'env -> int32 -> unit
114
  = fun _ _ -> ()
115

116
  method private visit_int64:
117
    'env -> int64 -> unit
118
  = fun _ _ -> ()
119

120
  method private visit_lazy_t: 'a .
POTTIER Francois's avatar
POTTIER Francois committed
121 122 123 124
    ('env -> 'a -> unit) -> 'env -> 'a Lazy.t -> unit
  = fun f env (lazy x) ->
      f env x

125
  method private visit_list: 'a .
126
    ('env -> 'a -> unit) -> 'env -> 'a list -> unit
127 128 129 130 131 132 133
  = fun f env xs ->
      match xs with
      | [] ->
          ()
      | x :: xs ->
          f env x;
          self # visit_list f env xs
134

135
  method private visit_nativeint:
136 137 138
    'env -> nativeint -> unit
  = fun _ _ -> ()

139
  method private visit_option: 'a .
140
    ('env -> 'a -> unit) -> 'env -> 'a option -> unit
141 142 143 144 145 146
  = fun f env ox ->
      match ox with
      | None ->
          ()
      | Some x ->
          f env x
147

148
  method private visit_ref: 'a .
149
    ('env -> 'a -> unit) -> 'env -> 'a ref -> unit
150 151
  = fun f env rx ->
      f env !rx
152

153
  method private visit_result: 'a 'e.
154 155 156
    ('env -> 'a -> unit) ->
    ('env -> 'e -> unit) ->
     'env -> ('a, 'e) result -> unit
157 158 159 160
  = fun f g env r ->
      match r with
      | Ok a -> f env a
      | Error b -> g env b
161

162
  method private visit_string:
163
    'env -> string -> unit
164
  = fun _ _ -> ()
165

166
  method private visit_unit:
167
    'env -> unit -> unit
168
  = fun _ _ -> ()
169 170

end
171

172 173 174 175
(* -------------------------------------------------------------------------- *)

(* [map] *)

176
class ['self] map = object (self)
177

178
  method private visit_array: 'a 'b .
179
    ('env -> 'a -> 'b) -> 'env -> 'a array -> 'b array
180 181
  = fun f env xs ->
      Array.map (f env) xs
182
      (* We could in principle inline [Array.map] so as to avoid allocating
POTTIER Francois's avatar
POTTIER Francois committed
183 184
         the closure [f env]. That would be a bit painful, though. Anyway,
         in [flambda] mode, the compiler might be able to do that for us. *)
185

186
  method private visit_bool:
187
    'env -> bool -> bool
188
  = fun _ x -> x
189

190
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
191 192 193
    'env -> bytes -> bytes
  = fun _ x -> x

194
  method private visit_char:
195
    'env -> char -> char
196
  = fun _ x -> x
197

198
  method private visit_float:
199
    'env -> float -> float
200
  = fun _ x -> x
201

202
  method private visit_int:
203
    'env -> int -> int
204
  = fun _ x -> x
205

206
  method private visit_int32:
207
    'env -> int32 -> int32
208
  = fun _ x -> x
209

210
  method private visit_int64:
211
    'env -> int64 -> int64
212
  = fun _ x -> x
213

214
  method private visit_lazy_t: 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
215 216 217 218 219 220 221 222 223
    ('env -> 'a -> 'b) -> 'env -> 'a Lazy.t -> 'b Lazy.t
  = fun f env thx ->
      (* We seem to have two options: either force the suspension now
         and rebuild a trivial suspension, or build now a suspension
         that will perform the traversal when forced. We choose the
         latter, which seems more interesting. If this is not the
         desired behavior, it can of course be overridden. *)
      lazy (f env (Lazy.force thx))

224
  method private visit_list: 'a 'b .
225
    ('env -> 'a -> 'b) -> 'env -> 'a list -> 'b list
226 227 228 229 230 231 232
  = fun f env xs ->
      match xs with
      | [] ->
          []
      | x :: xs ->
          let x = f env x in
          x :: self # visit_list f env xs
233

234
  method private visit_nativeint:
235 236 237
    'env -> nativeint -> nativeint
  = fun _ x -> x

238
  method private visit_option: 'a 'b .
239
    ('env -> 'a -> 'b) -> 'env -> 'a option -> 'b option
240 241 242 243 244 245
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          Some (f env x)
246

247
  method private visit_ref: 'a 'b .
248
    ('env -> 'a -> 'b) -> 'env -> 'a ref -> 'b ref
249 250
  = fun f env rx ->
      ref (f env !rx)
251

252
  method private visit_result: 'a 'b 'e 'f .
253 254 255
    ('env -> 'a -> 'b) ->
    ('env -> 'e -> 'f) ->
     'env -> ('a, 'e) result -> ('b, 'f) result
256 257 258 259
  = fun f g env r ->
      match r with
      | Ok a -> Ok (f env a)
      | Error b -> Error (g env b)
260

261
  method private visit_string:
262
    'env -> string -> string
263
  = fun _ x -> x
264

265
  method private visit_unit:
266
    'env -> unit -> unit
267
  = fun _ x -> x
268 269

end
270

271 272
(* -------------------------------------------------------------------------- *)

273 274 275 276 277 278 279 280 281 282 283 284 285
(* [endo] *)

class ['self] endo = object (self)

  (* We might wish to inherit from [map] and override only those methods where
     a physical equality check is needed. Yet, we cannot do that, because some
     methods, like [visit_list], have more restrictive types in this class than
     in the class [map]. *)

  (* It may seem fishy to use an [endo] visitor at type [array], but one never
     knows -- maybe the user wants this. Maybe she is using an array as an
     immutable data structure. *)

286
  method private visit_array: 'a .
287 288 289 290 291
    ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array
  = fun f env xs ->
      let xs' = Array.map (f env) xs in
      if array_equal (==) xs xs' then xs else xs'

292
  method private visit_bool:
293 294 295
    'env -> bool -> bool
  = fun _ x -> x

296
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
297 298 299
    'env -> bytes -> bytes
  = fun _ x -> x

300
  method private visit_char:
301 302 303
    'env -> char -> char
  = fun _ x -> x

304
  method private visit_float:
305 306 307
    'env -> float -> float
  = fun _ x -> x

308
  method private visit_int:
309 310 311
    'env -> int -> int
  = fun _ x -> x

312
  method private visit_int32:
313 314 315
    'env -> int32 -> int32
  = fun _ x -> x

316
  method private visit_int64:
317 318 319
    'env -> int64 -> int64
  = fun _ x -> x

320
  method private visit_lazy_t : 'a .
POTTIER Francois's avatar
POTTIER Francois committed
321 322 323 324 325 326 327 328 329 330 331
    ('env -> 'a -> 'a) -> 'env -> 'a Lazy.t -> 'a Lazy.t
  = fun f env thx ->
      (* We could use the same code as in [map], which does not preserve sharing.
         Or, we can force the suspension now, compute [x'], and if [x] and
         [x'] coincide, then we can return the original suspension (now
         forced), so as to preserve sharing. We choose the latter behavior. If
         this is not the desired behavior, it can of course be overridden. *)
      let x = Lazy.force thx in
      let x' = f env x in
      if x == x' then thx else lazy x'

332
  method private visit_list: 'a .
333 334 335 336 337 338 339 340 341 342 343 344 345
    ('env -> 'a -> 'a) -> 'env -> 'a list -> 'a list
  = fun f env this ->
      match this with
      | [] ->
          []
      | x :: xs ->
          let x' = f env x in
          let xs' = self # visit_list f env xs in
          if x == x' && xs == xs' then
            this
          else
            x' :: xs'

346
  method private visit_nativeint:
347 348 349
    'env -> nativeint -> nativeint
  = fun _ x -> x

350
  method private visit_option: 'a .
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
    ('env -> 'a -> 'a) -> 'env -> 'a option -> 'a option
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          let x' = f env x in
          if x == x' then
            ox
          else
            Some x'

  (* It probably does not make sense to use an [endo] visitor at type
     [ref], but one never knows -- maybe the user wants this. Anyway,
     it is consistent with the behavior of [endo] visitors at mutable
     record types. *)

368
  method private visit_ref: 'a .
369 370 371 372 373 374 375 376 377
    ('env -> 'a -> 'a) -> 'env -> 'a ref -> 'a ref
  = fun f env rx ->
      let x = !rx in
      let x' = f env x in
      if x == x' then
        rx
      else
        ref x'

378
  method private visit_result: 'a 'e .
379 380 381 382 383 384 385 386 387 388 389 390
    ('env -> 'a -> 'a) ->
    ('env -> 'e -> 'e) ->
     'env -> ('a, 'e) result -> ('a, 'e) result
  = fun f g env r ->
      match r with
      | Ok a ->
          let a' = f env a in
          if a == a' then r else Ok a'
      | Error b ->
          let b' = g env b in
          if b == b' then r else Error b'

391
  method private visit_string:
392 393 394
    'env -> string -> string
  = fun _ x -> x

395
  method private visit_unit:
396 397 398 399 400 401 402
    'env -> unit -> unit
  = fun _ x -> x

end

(* -------------------------------------------------------------------------- *)

403 404
(* [reduce] *)

405 406 407 408
class virtual ['self] reduce = object (self : 'self)

  inherit ['z] monoid

409
  method private visit_array: 'a .
410 411
    ('env -> 'a -> 'z) -> 'env -> 'a array -> 'z
  = fun f env xs ->
412
      Array.fold_left (fun z x -> self#plus z (f env x)) self#zero xs
413 414 415
      (* We might wish to inline [Array.fold_left] and save a closure
         allocation. That said, in flambda mode, the compiler might be
         able to do that automatically. *)
416

417
  method private visit_bool:
418 419 420
    'env -> bool -> 'z
  = fun _env _ -> self#zero

421
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
422 423 424
    'env -> bytes -> 'z
  = fun _env _ -> self#zero

425
  method private visit_char:
426 427 428
    'env -> char -> 'z
  = fun _env _ -> self#zero

429
  method private visit_float:
430 431 432
    'env -> float -> 'z
  = fun _env _ -> self#zero

433
  method private visit_int:
434 435 436
    'env -> int -> 'z
  = fun _env _ -> self#zero

437
  method private visit_int32:
438 439 440
    'env -> int32 -> 'z
  = fun _env _ -> self#zero

441
  method private visit_int64:
442 443 444
    'env -> int64 -> 'z
  = fun _env _ -> self#zero

445
  method private visit_lazy_t: 'a .
POTTIER Francois's avatar
POTTIER Francois committed
446 447 448 449
    ('env -> 'a -> 'z) -> 'env -> 'a Lazy.t -> 'z
  = fun f env (lazy x) ->
      f env x

450
  method private visit_list: 'a .
451 452
    ('env -> 'a -> 'z) -> 'env -> 'a list -> 'z
  = fun f env xs ->
453 454 455 456 457 458 459 460
      self # list_fold_left f env self#zero xs
      (* The above line is equivalent to the following: *)
      (* List.fold_left (fun z x -> self#plus z (f env x)) self#zero xs *)
      (* By using the auxiliary method [list_fold_left] instead of calling
         the library function [List.fold_left], we save a closure allocation,
         at least in non-flambda mode. A micro-benchmark shows no performance
         impact, either way. *)

461
  method private list_fold_left: 'a .
462 463 464 465 466 467 468 469
    ('env -> 'a -> 'z) -> 'env -> 'z -> 'a list -> 'z
  = fun f env z xs ->
    match xs with
    | [] ->
        z
    | x :: xs ->
        let z = self#plus z (f env x) in
        self # list_fold_left f env z xs
470

471
  method private visit_nativeint:
472 473 474
    'env -> nativeint -> 'z
  = fun _env _ -> self#zero

475
  method private visit_option: 'a .
476 477 478 479 480 481 482 483
    ('env -> 'a -> 'z) -> 'env -> 'a option -> 'z
  = fun f env ox ->
      match ox with
      | Some x ->
          f env x
      | None ->
          self#zero

484
  method private visit_ref: 'a .
485 486 487 488
    ('env -> 'a -> 'z) -> 'env -> 'a ref -> 'z
  = fun f env rx ->
      f env !rx

489
  method private visit_result: 'a 'e .
490 491 492 493 494 495 496 497 498 499
    ('env -> 'a -> 'z) ->
    ('env -> 'e -> 'z) ->
     'env -> ('a, 'e) result -> 'z
  = fun f g env r ->
      match r with
      | Ok a ->
          f env a
      | Error b ->
          g env b

500
  method private visit_string:
501 502 503
    'env -> string -> 'z
  = fun _env _ -> self#zero

504
  method private visit_unit:
505 506 507 508
    'env -> unit -> 'z
  = fun _env _ -> self#zero

end
509

510 511
(* -------------------------------------------------------------------------- *)

512 513 514 515 516 517 518 519 520 521 522 523
(* [mapreduce] *)

class virtual ['self] mapreduce = object (_self)

  inherit ['z] monoid

  (* TEMPORARY *)

end

(* -------------------------------------------------------------------------- *)

524 525 526 527
(* [fold] *)

class ['self] fold = object (_self)

528 529 530 531 532
  (* No methods are provided, as we do not wish to fix the types of these
     methods. It is up to the user to inherit from a class that defines
     appropriate methods. Note that [RuntimeVisitors.map] is likely to be
     appropriate in many situations. *)

533 534 535 536
end

(* -------------------------------------------------------------------------- *)

537 538
(* [iter2] *)

539
class ['self] iter2 = object (self)
540

541
  method private visit_array: 'a 'b .
542
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
543
  = fun f env xs1 xs2 ->
544
      (* We inline [Array.iter2]. *)
545
      if Array.length xs1 = Array.length xs2 then
546 547 548
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
549 550
      else
        fail()
551

552
  method private visit_bool:
553
    'env -> bool -> bool -> unit
554
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
555

556
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
557 558 559
    'env -> bytes -> bytes -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

560
  method private visit_char:
561
    'env -> char -> char -> unit
562
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
563

564
  method private visit_float:
565
    'env -> float -> float -> unit
566
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
567

568
  method private visit_int:
569
    'env -> int -> int -> unit
570
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
571

572
  method private visit_int32:
573
    'env -> int32 -> int32 -> unit
574
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
575

576
  method private visit_int64:
577
    'env -> int64 -> int64 -> unit
578
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
579

580
  method private visit_lazy_t: 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
581 582 583 584
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> unit
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

585
  method private visit_list: 'a 'b .
586
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
587 588 589 590 591 592 593 594 595
  = fun f env xs1 xs2 ->
      match xs1, xs2 with
      | [], [] ->
          ()
      | x1 :: xs1, x2 :: xs2 ->
          f env x1 x2;
          self # visit_list f env xs1 xs2
      | _, _ ->
          fail()
596

597
  method private visit_nativeint:
598 599 600
    'env -> nativeint -> nativeint -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

601
  method private visit_option: 'a 'b .
602
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
603 604 605 606 607 608 609 610
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()
611

612
  method private visit_ref: 'a 'b .
613
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a ref -> 'b ref -> unit
614 615
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2
616

617
  method private visit_result: 'a 'b 'e 'f .
618 619 620
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
621 622 623 624 625
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 -> f env a1 a2
      | Error b1, Error b2 -> g env b1 b2
      | _, _ -> fail()
626

627
  method private visit_string:
628
    'env -> string -> string -> unit
629
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
630

631
  method private visit_unit:
632
    'env -> unit -> unit -> unit
633
  = fun _ _x1 _x2 -> ()
634 635

end
636

637 638 639 640
(* -------------------------------------------------------------------------- *)

(* [map2] *)

641
class ['self] map2 = object (self)
642

643
  method private visit_array: 'a 'b 'c .
644
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
645 646 647 648 649
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
        Array.map2 (f env) xs1 xs2
      else
        fail()
650

651
  method private visit_bool:
652
    'env -> bool -> bool -> bool
653
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
654

655
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
656 657 658
    'env -> bytes -> bytes -> bytes
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

659
  method private visit_char:
660
    'env -> char -> char -> char
661
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
662

663
  method private visit_float:
664
    'env -> float -> float -> float
665
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
666

667
  method private visit_int:
668
    'env -> int -> int -> int
669
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
670

671
  method private visit_int32:
672
    'env -> int32 -> int32 -> int32
673
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
674

675
  method private visit_int64:
676
    'env -> int64 -> int64 -> int64
677
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
678

679
  method private visit_lazy_t: 'a 'b 'c .
POTTIER Francois's avatar
POTTIER Francois committed
680 681 682 683 684
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 'c Lazy.t
  = fun f env thx1 thx2 ->
      (* As in [map]. *)
      lazy (f env (Lazy.force thx1) (Lazy.force thx2))

685
  method private visit_list: 'a 'b 'c .
686
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
687 688 689 690 691 692 693 694 695
  = fun f env xs1 xs2 ->
      match xs1, xs2 with
      | [], [] ->
          []
      | x1 :: xs1, x2 :: xs2 ->
          let x = f env x1 x2 in
          x :: self # visit_list f env xs1 xs2
      | _, _ ->
          fail()
696

697
  method private visit_nativeint:
698 699 700
    'env -> nativeint -> nativeint -> nativeint
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

701
  method private visit_option: 'a 'b 'c .
702
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
703 704 705 706 707 708 709 710 711
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          None
      | Some x1, Some x2 ->
          let x = f env x1 x2 in
          Some x
      | _, _ ->
          fail()
712

713
  method private visit_ref: 'a 'b 'c .
714
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a ref -> 'b ref -> 'c ref
715 716
  = fun f env rx1 rx2 ->
      ref (f env !rx1 !rx2)
717

718
  method private visit_result: 'a 'b 'c 'e 'f 'g .
719 720 721
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
722 723 724 725 726
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 -> Ok (f env a1 a2)
      | Error b1, Error b2 -> Error (g env b1 b2)
      | _, _ -> fail()
727

728
  method private visit_string:
729
    'env -> string -> string -> string
730
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
731

732
  method private visit_unit:
733
    'env -> unit -> unit -> unit
734
  = fun _ _x1 _x2 -> ()
735 736

end
737

738 739 740 741
(* -------------------------------------------------------------------------- *)

(* [reduce2] *)

742 743 744 745
class virtual ['self] reduce2 = object (self : 'self)

  inherit ['z] monoid

746
  method private visit_array: 'a 'b .
747 748
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a array -> 'b array -> 'z
  = fun f env xs1 xs2 ->
749 750
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
751
      if Array.length xs1 = Array.length xs2 then
752
        let z = ref self#zero in
753 754 755
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
756
          z := self#plus !z (f env x1 x2)
757
        done;
758 759 760 761
        !z
      else
        fail()

762
  method private visit_bool:
763 764 765 766
    'env -> bool -> bool -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

767
  method private visit_bytes:
POTTIER Francois's avatar
POTTIER Francois committed
768 769 770 771
    'env -> bytes -> bytes -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

772
  method private visit_char:
773 774 775 776
    'env -> char -> char -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

777
  method private visit_float:
778 779 780 781
    'env -> float -> float -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

782
  method private visit_int:
783 784 785 786
    'env -> int -> int -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

787
  method private visit_int32:
788 789 790 791
    'env -> int32 -> int32 -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

792
  method private visit_int64:
793 794 795 796
    'env -> int64 -> int64 -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

797
  method private visit_lazy_t: 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
798 799 800 801
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 'z
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

802
  method private visit_list: 'a 'b .
803 804
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a list -> 'b list -> 'z
  = fun f env xs1 xs2 ->
805 806
      if List.length xs1 = List.length xs2 then
        List.fold_left2 (fun z x1 x2 -> self#plus z (f env x1 x2)) self#zero xs1 xs2
807 808 809
      else
        fail()

810
  method private visit_nativeint:
811 812 813 814
    'env -> nativeint -> nativeint -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

815
  method private visit_option: 'a 'b .
816 817 818 819 820 821 822 823 824 825 826
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a option -> 'b option -> 'z
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | Some x1, Some x2 ->
          f env x1 x2
      | None, None ->
          self#zero
      | Some _, None
      | None, Some _ ->
          fail()

827
  method private visit_ref: 'a 'b .
828 829 830 831
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a ref -> 'b ref -> 'z
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2

832
  method private visit_result: 'a 'b 'e 'f .
833 834 835 836 837 838 839 840 841 842 843 844 845
    ('env -> 'a -> 'b -> 'z) ->
    ('env -> 'e -> 'f -> 'z) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> 'z
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 ->
          f env a1 a2
      | Error b1, Error b2 ->
          g env b1 b2
      | Ok _, Error _
      | Error _, Ok _ ->
          fail()

846
  method private visit_string:
847 848 849 850
    'env -> string -> string -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

851
  method private visit_unit:
852 853 854 855 856
    'env -> unit -> unit -> 'z
  = fun _env () () ->
      self#zero

end
857 858 859 860 861 862 863

(* -------------------------------------------------------------------------- *)

(* [fold2] *)

class ['self] fold2 = object (_self)

864 865
  (* See the comment in the class [fold] above. *)

866
end
867 868 869 870 871 872 873 874 875 876 877 878

(* -------------------------------------------------------------------------- *)

(* [mapreduce2] *)

class virtual ['self] mapreduce2 = object (_self)

  inherit ['z] monoid

  (* TEMPORARY *)

end