A lightweight reactive document library.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

640 lines
20 KiB

  1. (** Create-only version of [Obj.t] *)
  2. module Any : sig
  3. type t
  4. val any : 'a -> t
  5. end = struct
  6. type t = Obj.t
  7. let any = Obj.repr
  8. end
  9. type 'a eval =
  10. | Eval_none
  11. | Eval_progress
  12. | Eval_some of 'a
  13. type 'a t_ =
  14. | Pure of 'a
  15. | Impure of 'a (* NOTE: is this really used anywhere? *)
  16. | Operator : {
  17. mutable value : 'a eval; (* cached value *)
  18. mutable trace : trace; (* list of parents this can invalidate *)
  19. mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
  20. desc: 'a desc;
  21. } -> 'a t_
  22. | Root : {
  23. mutable value : 'a eval; (* cached value *)
  24. mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
  25. mutable on_invalidate : 'a -> unit;
  26. mutable acquired : bool;
  27. child : 'a t_;
  28. } -> 'a t_
  29. and _ desc =
  30. | Map : 'a t_ * ('a -> 'b) -> 'b desc
  31. | Map2 : 'a t_ * 'b t_ * ('a -> 'b -> 'c) -> 'c desc
  32. | Pair : 'a t_ * 'b t_ -> ('a * 'b) desc
  33. | App : ('a -> 'b) t_ * 'a t_ -> 'b desc
  34. | Join : { child : 'a t_ t_; mutable intermediate : 'a t_ option } -> 'a desc
  35. | Var : { mutable binding : 'a } -> 'a desc
  36. | Prim : { acquire : unit -> 'a;
  37. release : 'a -> unit } -> 'a desc
  38. (* a set of (active) parents for a ['a t], used during invalidation *)
  39. and trace =
  40. | T0
  41. | T1 : _ t_ -> trace
  42. | T2 : _ t_ * _ t_ -> trace
  43. | T3 : _ t_ * _ t_ * _ t_ -> trace
  44. | T4 : _ t_ * _ t_ * _ t_ * _ t_ -> trace
  45. | Tn : { mutable active : int; mutable count : int;
  46. mutable entries : Any.t t_ array } -> trace
  47. (* a set of direct children for a composite document *)
  48. and trace_idx =
  49. | I0
  50. | I1 : { mutable idx : int ;
  51. obj : 'a t_;
  52. mutable next : trace_idx } -> trace_idx
  53. (* The type system cannot see that t is covariant in its parameter.
  54. Use the Force to convince it. *)
  55. type +'a t
  56. external inj : 'a t_ -> 'a t = "%identity"
  57. external prj : 'a t -> 'a t_ = "%identity"
  58. external prj2 : 'a t t -> 'a t_ t_ = "%identity"
  59. (* Basic combinators *)
  60. let return x = inj (Pure x)
  61. let pure x = inj (Pure x)
  62. let impure x = inj (
  63. match prj x with
  64. | Pure x -> Impure x
  65. | other -> other
  66. )
  67. let is_pure x = match prj x with
  68. | Pure x -> Some x
  69. | _ -> None
  70. let dummy = Pure (Any.any ())
  71. let operator desc =
  72. Operator { value = Eval_none; trace = T0; desc; trace_idx = I0 }
  73. let map f x = inj (
  74. match prj x with
  75. | Pure vx -> Pure (f vx)
  76. | x -> operator (Map (x, f))
  77. )
  78. let map2 f x y = inj (
  79. match prj x, prj y with
  80. | Pure vx, Pure vy -> Pure (f vx vy)
  81. | x, y -> operator (Map2 (x, y, f))
  82. )
  83. let map' x f = map f x
  84. let map2' x y f = map2 f x y
  85. let pair x y = inj (
  86. match prj x, prj y with
  87. | Pure vx, Pure vy -> Pure (vx, vy)
  88. | x, y -> operator (Pair (x, y))
  89. )
  90. let app f x = inj (
  91. match prj f, prj x with
  92. | Pure vf, Pure vx -> Pure (vf vx)
  93. | f, x -> operator (App (f, x))
  94. )
  95. let join child = inj (
  96. match prj2 child with
  97. | Pure v -> v
  98. | child -> operator (Join { child; intermediate = None })
  99. )
  100. let bind x f = join (map f x)
  101. (* Management of trace indices *)
  102. let addr oc obj =
  103. Printf.fprintf oc "0x%08x" (Obj.magic obj : int)
  104. external t_equal : _ t_ -> _ t_ -> bool = "%eq"
  105. external obj_t : 'a t_ -> Any.t t_ = "%identity"
  106. let rec dump_trace : type a. a t_ -> unit =
  107. fun obj -> match obj with
  108. | Pure _ -> Printf.eprintf "%a: Pure _\n%!" addr obj
  109. | Impure _ -> Printf.eprintf "%a: Impure _\n%!" addr obj
  110. | Operator t ->
  111. Printf.eprintf "%a: Operator _ -> %a\n%!" addr obj dump_trace_aux t.trace;
  112. begin match t.trace with
  113. | T0 -> ()
  114. | T1 a -> dump_trace a
  115. | T2 (a,b) -> dump_trace a; dump_trace b
  116. | T3 (a,b,c) -> dump_trace a; dump_trace b; dump_trace c
  117. | T4 (a,b,c,d) -> dump_trace a; dump_trace b; dump_trace c; dump_trace d
  118. | Tn t -> Array.iter dump_trace t.entries
  119. end
  120. | Root _ -> Printf.eprintf "%a: Root _\n%!" addr obj
  121. and dump_trace_aux oc = function
  122. | T0 -> Printf.fprintf oc "T0"
  123. | T1 a -> Printf.fprintf oc "T1 %a" addr a
  124. | T2 (a,b) ->
  125. Printf.fprintf oc "T2 (%a, %a)" addr a addr b
  126. | T3 (a,b,c) ->
  127. Printf.fprintf oc "T3 (%a, %a, %a)" addr a addr b addr c
  128. | T4 (a,b,c,d) ->
  129. Printf.fprintf oc "T4 (%a, %a, %a, %a)" addr a addr b addr c addr d
  130. | Tn t ->
  131. Printf.fprintf oc "Tn {active = %d; count = %d; entries = "
  132. t.active t.count;
  133. Array.iter (Printf.fprintf oc "(%a)" addr) t.entries;
  134. Printf.fprintf oc "}"
  135. let dump_trace x = dump_trace (obj_t (prj x))
  136. let add_idx obj idx = function
  137. | Pure _ | Impure _ -> assert false
  138. | Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
  139. | Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
  140. let rec rem_idx_rec obj = function
  141. | I0 -> assert false
  142. | I1 t as self ->
  143. if t_equal t.obj obj
  144. then (t.idx, t.next)
  145. else (
  146. let idx, result = rem_idx_rec obj t.next in
  147. t.next <- result;
  148. (idx, self)
  149. )
  150. (* remove [obj] from the lwd's trace. *)
  151. let rem_idx obj = function
  152. | Pure _ | Impure _ -> assert false
  153. | Root t' ->
  154. let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
  155. t'.trace_idx <- trace_idx; idx
  156. | Operator t' ->
  157. let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
  158. t'.trace_idx <- trace_idx; idx
  159. (* move [obj] from old index to new index. *)
  160. let rec mov_idx_rec obj oldidx newidx = function
  161. | I0 -> assert false
  162. | I1 t ->
  163. if t.idx = oldidx && t_equal t.obj obj
  164. then t.idx <- newidx
  165. else mov_idx_rec obj oldidx newidx t.next
  166. let mov_idx obj oldidx newidx = function
  167. | Pure _ | Impure _ -> assert false
  168. | Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
  169. | Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
  170. let rec get_idx_rec obj = function
  171. | I0 -> assert false
  172. | I1 t ->
  173. if t_equal t.obj obj
  174. then t.idx
  175. else get_idx_rec obj t.next
  176. (* find index of [obj] in the given lwd *)
  177. let get_idx obj = function
  178. | Pure _ | Impure _ -> assert false
  179. | Root t' -> get_idx_rec obj t'.trace_idx
  180. | Operator t' -> get_idx_rec obj t'.trace_idx
  181. (* Propagating invalidation recursively.
  182. Each document is invalidated at most once,
  183. and only if it has [t.value = Some _]. *)
  184. let rec invalidate_node : type a . a t_ -> unit = function
  185. | Pure _ | Impure _ -> assert false
  186. | Root ({ value; _ } as t) ->
  187. t.value <- Eval_none;
  188. begin match value with
  189. | Eval_none | Eval_progress -> ()
  190. | Eval_some x ->
  191. t.on_invalidate x (* user callback that {i observes} this root. *)
  192. end
  193. | Operator { value = Eval_none; _ } -> ()
  194. | Operator t ->
  195. t.value <- Eval_none;
  196. invalidate_trace t.trace; (* invalidate parents recursively *)
  197. (* invalidate recursively documents in the given trace *)
  198. and invalidate_trace = function
  199. | T0 -> ()
  200. | T1 x -> invalidate_node x
  201. | T2 (x, y) ->
  202. invalidate_node x;
  203. invalidate_node y
  204. | T3 (x, y, z) ->
  205. invalidate_node x;
  206. invalidate_node y;
  207. invalidate_node z
  208. | T4 (x, y, z, w) ->
  209. invalidate_node x;
  210. invalidate_node y;
  211. invalidate_node z;
  212. invalidate_node w
  213. | Tn t ->
  214. let active = t.active in
  215. t.active <- 0;
  216. for i = 0 to active - 1 do
  217. invalidate_node t.entries.(i)
  218. done
  219. (* Variables *)
  220. type 'a var = 'a t_
  221. let var x = operator (Var {binding = x})
  222. let get x = inj x
  223. let set (vx:_ var) x : unit =
  224. match vx with
  225. | Operator ({desc = Var v; _}) ->
  226. (* set the variable, and invalidate all observers *)
  227. invalidate_node vx;
  228. v.binding <- x
  229. | _ -> assert false
  230. let peek = function
  231. | Operator ({desc = Var v; _}) -> v.binding
  232. | _ -> assert false
  233. (* Primitives *)
  234. type 'a prim = 'a t
  235. let prim ~acquire ~release =
  236. inj (operator (Prim { acquire; release }))
  237. let get_prim x = x
  238. let invalidate x = match prj x with
  239. | Operator ({ desc = Prim p; _ } as t) ->
  240. let value = t.value in
  241. t.value <- Eval_none;
  242. (* the value is invalidated, be sure to invalidate all parents as well *)
  243. invalidate_trace t.trace;
  244. begin match value with
  245. | Eval_none | Eval_progress -> ()
  246. | Eval_some v -> p.release v
  247. end
  248. | _ -> assert false
  249. type release_list =
  250. | Release_done
  251. | Release_more :
  252. { origin : 'a t_; element : 'b t_; next : release_list } -> release_list
  253. type release_queue = release_list ref
  254. let make_release_queue () = ref Release_done
  255. type release_failure = exn * Printexc.raw_backtrace
  256. (* [sub_release [] origin self] is called when [origin] is released,
  257. where [origin] is reachable from [self]'s trace.
  258. We're going to remove [origin] from that trace as [origin] is now dead.
  259. [sub_release] cannot raise.
  260. If a primitive raises, the exception is caught and a warning is emitted. *)
  261. let rec sub_release
  262. : type a b . release_failure list -> a t_ -> b t_ -> release_failure list
  263. = fun failures origin -> function
  264. | Root _ -> assert false
  265. | Pure _ | Impure _ -> failures
  266. | Operator t as self ->
  267. (* compute [t.trace \ {origin}] *)
  268. let trace = match t.trace with
  269. | T0 -> assert false
  270. | T1 x -> assert (t_equal x origin); T0
  271. | T2 (x, y) ->
  272. if t_equal x origin then T1 y
  273. else if t_equal y origin then T1 x
  274. else assert false
  275. | T3 (x, y, z) ->
  276. if t_equal x origin then T2 (y, z)
  277. else if t_equal y origin then T2 (x, z)
  278. else if t_equal z origin then T2 (x, y)
  279. else assert false
  280. | T4 (x, y, z, w) ->
  281. if t_equal x origin then T3 (y, z, w)
  282. else if t_equal y origin then T3 (x, z, w)
  283. else if t_equal z origin then T3 (x, y, w)
  284. else if t_equal w origin then T3 (x, y, z)
  285. else assert false
  286. | Tn tn as trace ->
  287. let revidx = rem_idx self origin in
  288. assert (t_equal tn.entries.(revidx) origin);
  289. let count = tn.count - 1 in
  290. tn.count <- count;
  291. if revidx < count then (
  292. let obj = tn.entries.(count) in
  293. tn.entries.(revidx) <- obj;
  294. tn.entries.(count) <- dummy;
  295. mov_idx self count revidx obj
  296. ) else
  297. tn.entries.(revidx) <- dummy;
  298. if tn.active > count then tn.active <- count;
  299. if count = 4 then (
  300. (* downgrade to [T4] to save space *)
  301. let a = tn.entries.(0) and b = tn.entries.(1) in
  302. let c = tn.entries.(2) and d = tn.entries.(3) in
  303. ignore (rem_idx self a : int);
  304. ignore (rem_idx self b : int);
  305. ignore (rem_idx self c : int);
  306. ignore (rem_idx self d : int);
  307. T4 (a, b, c, d)
  308. ) else (
  309. let len = Array.length tn.entries in
  310. if count <= len lsr 2 then
  311. Tn { active = tn.active; count = tn.count;
  312. entries = Array.sub tn.entries 0 (len lsr 1) }
  313. else
  314. trace
  315. )
  316. in
  317. t.trace <- trace;
  318. match trace with
  319. | T0 ->
  320. (* [self] is not active anymore, since it's not reachable
  321. from any root. We can release its cached value and
  322. recursively release its subtree. *)
  323. let value = t.value in
  324. t.value <- Eval_progress;
  325. begin match t.desc with
  326. | Map (x, _) -> sub_release failures self x
  327. | Map2 (x, y, _) ->
  328. sub_release (sub_release failures self x) self y
  329. | Pair (x, y) ->
  330. sub_release (sub_release failures self x) self y
  331. | App (x, y) ->
  332. sub_release (sub_release failures self x) self y
  333. | Join ({ child; intermediate } as t) ->
  334. let failures = sub_release failures self child in
  335. begin match intermediate with
  336. | None -> failures
  337. | Some child' ->
  338. t.intermediate <- None;
  339. sub_release failures self child'
  340. end
  341. | Var _ -> failures
  342. | Prim t ->
  343. begin match value with
  344. | Eval_none | Eval_progress -> failures
  345. | Eval_some x ->
  346. begin match t.release x with
  347. | () -> failures
  348. | exception exn ->
  349. let bt = Printexc.get_raw_backtrace () in
  350. (exn, bt) :: failures
  351. end
  352. end
  353. end
  354. | _ -> failures
  355. (* [sub_acquire] cannot raise *)
  356. let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin ->
  357. function
  358. | Root _ -> assert false
  359. | Pure _ | Impure _ -> ()
  360. | Operator t as self ->
  361. (* [acquire] is true if this is the first time this operator
  362. is used, in which case we need to acquire its children *)
  363. let acquire = match t.trace with T0 -> true | _ -> false in
  364. let trace = match t.trace with
  365. | T0 -> T1 origin
  366. | T1 x -> T2 (origin, x)
  367. | T2 (x, y) -> T3 (origin, x, y)
  368. | T3 (x, y, z) -> T4 (origin, x, y, z)
  369. | T4 (x, y, z, w) ->
  370. let obj_origin = obj_t origin in
  371. let entries =
  372. [| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |]
  373. in
  374. for i = 0 to 4 do add_idx self i entries.(i) done;
  375. Tn { active = 5; count = 5; entries }
  376. | Tn tn as trace ->
  377. let index = tn.count in
  378. let entries, trace =
  379. (* possibly resize array [entries] *)
  380. if index < Array.length tn.entries then (
  381. tn.count <- tn.count + 1;
  382. (tn.entries, trace)
  383. ) else (
  384. let entries = Array.make (index * 2) dummy in
  385. Array.blit tn.entries 0 entries 0 index;
  386. (entries, Tn { active = tn.active; count = index + 1; entries })
  387. )
  388. in
  389. let obj_origin = obj_t origin in
  390. entries.(index) <- obj_origin;
  391. add_idx self index obj_origin;
  392. trace
  393. in
  394. t.trace <- trace;
  395. if acquire then (
  396. (* acquire immediate children, and so on recursively *)
  397. match t.desc with
  398. | Map (x, _) -> sub_acquire self x
  399. | Map2 (x, y, _) ->
  400. sub_acquire self x;
  401. sub_acquire self y
  402. | Pair (x, y) ->
  403. sub_acquire self x;
  404. sub_acquire self y
  405. | App (x, y) ->
  406. sub_acquire self x;
  407. sub_acquire self y
  408. | Join { child; intermediate } ->
  409. sub_acquire self child;
  410. begin match intermediate with
  411. | None -> ()
  412. | Some _ ->
  413. assert false (* this can't initialized already, first-time acquire *)
  414. end
  415. | Var _ -> ()
  416. | Prim _ -> ()
  417. )
  418. (* make sure that [origin] is in [self.trace], passed as last arg. *)
  419. let activate_tracing self origin = function
  420. | Tn tn ->
  421. let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *)
  422. let active = tn.active in
  423. (* [idx < active] means [self] is already traced by [origin].
  424. We only have to add [self] to the entries if [idx >= active]. *)
  425. if idx >= active then (
  426. tn.active <- active + 1;
  427. );
  428. if idx > active then (
  429. (* swap with last entry in [tn.entries] *)
  430. let old = tn.entries.(active) in
  431. tn.entries.(idx) <- old;
  432. tn.entries.(active) <- obj_t origin;
  433. mov_idx self active idx old;
  434. mov_idx self idx active origin
  435. )
  436. | _ -> ()
  437. (* [sub_sample origin self] computes a value for [self].
  438. [sub_sample] raise if any user-provided computation raises.
  439. Graph will be left in a coherent state but exception will be propagated
  440. to the observer. *)
  441. let sub_sample queue =
  442. let rec aux : type a b . a t_ -> b t_ -> b = fun origin ->
  443. function
  444. | Root _ -> assert false
  445. | Pure x | Impure x -> x
  446. | Operator t as self ->
  447. (* try to use cached value, if present *)
  448. match t.value with
  449. | Eval_some value ->
  450. activate_tracing self origin t.trace;
  451. value
  452. | _ ->
  453. t.value <- Eval_progress;
  454. let result : b = match t.desc with
  455. | Map (x, f) -> f (aux self x)
  456. | Map2 (x, y, f) -> f (aux self x) (aux self y)
  457. | Pair (x, y) -> (aux self x, aux self y)
  458. | App (f, x) -> (aux self f) (aux self x)
  459. | Join x ->
  460. let intermediate =
  461. (* We haven't touched any state yet,
  462. it is safe for [aux] to raise *)
  463. aux self x.child
  464. in
  465. begin match x.intermediate with
  466. | None ->
  467. x.intermediate <- Some intermediate;
  468. sub_acquire self intermediate;
  469. | Some x' when x' != intermediate ->
  470. queue := Release_more {
  471. origin = self;
  472. element = x';
  473. next = !queue;
  474. };
  475. x.intermediate <- Some intermediate;
  476. sub_acquire self intermediate;
  477. | Some _ -> ()
  478. end;
  479. aux self intermediate
  480. | Var x -> x.binding
  481. | Prim t -> t.acquire ()
  482. in
  483. begin match t.value with
  484. | Eval_progress -> t.value <- Eval_some result;
  485. | Eval_none | Eval_some _ -> ()
  486. end;
  487. (* [self] just became active, so it may invalidate [origin] in case its
  488. value changes because of [t.desc], like if it's a variable and gets
  489. mutated, or if it's a primitive that gets invalidated.
  490. We need to put [origin] into [self.trace] in case it isn't there yet. *)
  491. activate_tracing self origin t.trace;
  492. result
  493. in
  494. aux
  495. type 'a root = 'a t
  496. let observe ?(on_invalidate=ignore) child : _ root =
  497. let root = Root {
  498. child = prj child;
  499. value = Eval_none;
  500. on_invalidate;
  501. trace_idx = I0;
  502. acquired = false;
  503. } in
  504. inj root
  505. exception Release_failure of exn option * release_failure list
  506. let raw_flush_release_queue queue =
  507. let rec aux failures = function
  508. | Release_done -> failures
  509. | Release_more t ->
  510. let failures = sub_release failures t.origin t.element in
  511. aux failures t.next
  512. in
  513. aux [] queue
  514. let flush_release_queue queue =
  515. let queue' = !queue in
  516. queue := Release_done;
  517. raw_flush_release_queue queue'
  518. let sample queue x = match prj x with
  519. | Pure _ | Impure _ | Operator _ -> assert false
  520. | Root t as self ->
  521. match t.value with
  522. | Eval_some value -> value
  523. | _ ->
  524. (* no cached value, compute it now *)
  525. if not t.acquired then (
  526. t.acquired <- true;
  527. sub_acquire self t.child;
  528. );
  529. t.value <- Eval_progress;
  530. let value = sub_sample queue self t.child in
  531. begin match t.value with
  532. | Eval_progress -> t.value <- Eval_some value; (* cache value *)
  533. | Eval_none | Eval_some _ -> ()
  534. end;
  535. value
  536. let is_damaged x = match prj x with
  537. | Pure _ | Impure _ | Operator _ -> assert false
  538. | Root {value = Eval_some _; _} -> false
  539. | Root {value = Eval_none | Eval_progress; _} -> true
  540. let release queue x = match prj x with
  541. | Pure _ | Impure _ | Operator _ -> assert false
  542. | Root t as self ->
  543. if t.acquired then (
  544. (* release subtree, remove cached value *)
  545. t.value <- Eval_none;
  546. t.acquired <- false;
  547. queue := Release_more { origin = self; element = t.child; next = !queue }
  548. )
  549. let set_on_invalidate x f =
  550. match prj x with
  551. | Pure _ | Impure _ | Operator _ -> assert false
  552. | Root t -> t.on_invalidate <- f
  553. let flush_or_fail main_exn queue =
  554. match flush_release_queue queue with
  555. | [] -> ()
  556. | failures -> raise (Release_failure (main_exn, failures))
  557. let quick_sample root =
  558. let queue = ref Release_done in
  559. match sample queue root with
  560. | result -> flush_or_fail None queue; result
  561. | exception exn -> flush_or_fail (Some exn) queue; raise exn
  562. let quick_release root =
  563. let queue = ref Release_done in
  564. release queue root;
  565. flush_or_fail None queue
  566. module Infix = struct
  567. let (>>=) = bind
  568. let (>|=) = map'
  569. let (<*>) = app
  570. end
  571. (*$R
  572. let x = var 0 in
  573. let y = map succ (get x) in
  574. let o_y = Lwd.observe y in
  575. assert_equal 1 (quick_sample o_y);
  576. set x 10;
  577. assert_equal 11 (quick_sample o_y);
  578. *)