blob: 2af10859ec56a245e7d74515c3f36e227449d189 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Damien Doligez, projet Para, INRIA Rocquencourt *)
(* *)
(* Copyright 1997 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [Lazy]: deferred computations *)
(*
WARNING: some purple magic is going on here. Do not take this file
as an example of how to program in Objective Caml.
*)
(* We make use of two special tags provided by the runtime:
[lazy_tag] and [forward_tag].
A value of type ['a Lazy.t] can be one of three things:
1. A block of size 1 with tag [lazy_tag]. Its field is a closure of
type [unit -> 'a] that computes the value.
2. A block of size 1 with tag [forward_tag]. Its field is the value
of type ['a] that was computed.
3. Anything else. This has type ['a] and is the value that was computed.
Exceptions are stored in format (1).
The GC will magically change things from (2) to (3) according to its
fancy.
We have to use the built-in type constructor [lazy_t] to
let the compiler implement the special typing and compilation
rules for the [lazy] keyword.
*)
type 'a t = 'a lazy_t;;
exception Undefined;;
let raise_undefined = Obj.repr (fun () -> raise Undefined);;
external is_forward : Obj.t -> bool = "lazy_is_forward";;
external follow_forward : Obj.t -> 'a = "lazy_follow_forward";;
let force (l : 'arg t) =
let x = Obj.repr l in
if is_forward x then (follow_forward x : 'arg)
else if Obj.is_int x then (Obj.obj x : 'arg)
else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
else begin
let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
Obj.set_field x 0 raise_undefined;
try
let result = closure () in
Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *)
Obj.set_tag x (Obj.forward_tag);
result
with e ->
Obj.set_field x 0 (Obj.repr (fun () -> raise e));
raise e
end
;;
let force_val (l : 'arg t) =
let x = Obj.repr l in
if is_forward x then (follow_forward x : 'arg)
else if Obj.is_int x then (Obj.obj x : 'arg)
else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
else begin
let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
Obj.set_field x 0 raise_undefined;
let result = closure () in
Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *)
Obj.set_tag x (Obj.forward_tag);
result
end
;;
let lazy_from_fun (f : unit -> 'arg) =
let x = Obj.new_block Obj.lazy_tag 1 in
Obj.set_field x 0 (Obj.repr f);
(Obj.obj x : 'arg t)
;;
let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
let lazy_is_val (l : 'arg t) =
let x = Obj.repr l in
is_forward x || Obj.is_int x || Obj.tag x <> Obj.lazy_tag
;;
|
