mlstub.ml 16.3 KB
Newer Older
1
2
3
4
#load "q_MLast.cmo";;

(* TODO:
   - optimizations: generate labels and atoms only once.
5
   - translate record to open record on positive occurence
6
7
8
9
10
11
12
13
14
15
16
17
18
19
*)


open Mltypes
open Ident

module IntMap = 
  Map.Make(struct type t = int let compare : t -> t -> int = compare end)

module IntHash =
  Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)

(* Compute CDuce type *)

20
21
let vars = ref [||]

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
let memo_typ = IntHash.create 13

let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
let label lab = LabelPool.mk (Ns.empty, U.mk lab)
let bigcup f l = List.fold_left (fun accu x -> Types.cup accu (f x)) Types.empty l

let rec typ t =
  try IntHash.find memo_typ t.uid
  with Not_found ->
    let node = Types.make () in
    IntHash.add memo_typ t.uid node;
    Types.define node (typ_descr t.def);
    node

and typ_descr = function
  | Link t -> typ_descr t.def
38
  | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
39
40
  | Tuple tl -> Types.tuple (List.map typ tl)
  | PVariant l -> bigcup pvariant l
41
42
  | Variant (_,l,_) -> bigcup variant l
  | Record (_,l,_) ->
43
44
45
46
47
      let l = List.map (fun (lab,t) -> label lab, typ t) l in
      Types.record' (false,(LabelMap.from_list_disj l))
  | Abstract "int" -> Builtin_defs.caml_int
  | Abstract "char" -> Builtin_defs.char_latin1
  | Abstract "string" -> Builtin_defs.string_latin1
48
  | Abstract s -> Types.abstract (Types.Abstract.atom s)
49
50
  | Builtin ("list", [t])
  | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
51
  | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
52
  | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
53
  | Builtin ("Cduce_lib.Value.t", []) -> Types.any
54
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
55
  | Builtin ("unit", []) -> Sequence.nil_type
56
  | Var i -> Types.descr (!vars).(i)
57
58
59
60
61
62
63
64
65
66
67
68
69
  | _ -> assert false
	   
and pvariant = function
  | (lab, None) -> atom lab
  | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)

and variant = function
  | (lab, []) -> atom lab
  | (lab, c) -> Types.tuple (Types.cons (atom lab) :: List.map typ c)


(* Syntactic tools *)

70
71
72
73
let var_counter = ref 0
let mk_var _ =
  incr var_counter;
  Printf.sprintf "x%i" !var_counter
74

75
let mk_vars = List.map mk_var
76

77
let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

let let_in p e body =
  <:expr< let $list:[ p, e ]$ in $body$ >>

let atom_ascii lab =
  <:expr< Value.atom_ascii $str: String.escaped lab$ >>

let label_ascii lab =
  <:expr< Value.label_ascii $str: String.escaped lab$ >>

let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>

let pmatch e l = 
  let l = List.map (fun (p,e) -> p,None,e) l in
  <:expr< match $e$ with [ $list:l$ ] >>

let rec matches ine oute = function
  | [v1;v2] ->
      let_in <:patt<($lid:v1$,$lid:v2$)>> <:expr< Value.get_pair $ine$ >> oute
  | v::vl ->
98
99
100
      let r = mk_var () in
      let oute = matches <:expr< $lid:r$ >> oute vl in
      let_in <:patt<($lid:v$,$lid:r$)>> <:expr< Value.get_pair $ine$ >> oute
101
102
103
104
105
  | [] -> assert false

let list_lit el =
  List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>

106
107
108
109
110
111
112
113
let protect e f =
  match e with
    | <:expr< $lid:x$ >> -> f e
    | e ->
	let x = mk_var () in
	let r = f <:expr< $lid:x$ >> in
	<:expr< let $lid:x$ = $e$ in $r$ >> 

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
(* Registered types *)

module HashTypes = Hashtbl.Make(Types)
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0

let register_type t =
  let n =
    try HashTypes.find registered_types t
    with Not_found ->
      let i = !nb_registered_types in
      HashTypes.add registered_types t i;
      incr nb_registered_types;
      i 
  in
  <:expr< types.($int:string_of_int n$) >>

let get_registered_types () =
  let a = Array.make !nb_registered_types Types.empty in
  HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
  a

136
137
(* OCaml -> CDuce conversions *)

138

139
140
141
142
143
144
145
146
147
let to_cd_gen = ref []

let to_cd_fun_name t = 
  Printf.sprintf "to_cd_%i" t.uid

let to_cd_fun t =
  to_cd_gen := t :: !to_cd_gen;
  to_cd_fun_name t

148
149
150
151
152
153
154
155
156
let to_ml_gen = ref []

let to_ml_fun_name t =
  Printf.sprintf "to_ml_%i" t.uid

let to_ml_fun t =
  to_ml_gen := t :: !to_ml_gen;
  to_ml_fun_name t

157
158
159
160
161
162
163
164
165
166
let rec tuple = function
  | [v] -> v
  | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >> 
  | [] -> assert false

let pat_tuple vars = 
  let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
  <:patt< ($list:pl$) >>


167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
let call_lab f l x =
  if l = "" then <:expr< $f$ $x$ >>
  else
    if l.[0] = '?' then 
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< $f$ (? $l$ : $x$) >>
    else 
      <:expr< $f$ (~ $l$ : $x$) >>

let abstr_lab l x res =
  if l = "" then <:expr< fun $lid:x$ -> $res$ >>
  else
    if l.[0] = '?' then 
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
    else
      <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>



187
188
189
190
191
192
193
194
let rec to_cd e t =
(*  Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@."
    Mltypes.print t t.uid t.recurs; *)
  if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >>
  else to_cd_descr e t.def

and to_cd_descr e = function
  | Link t -> to_cd e t
195
196
  | Arrow (l,t,s) -> 
      (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
197
198
199
200
      protect e 
      (fun y ->
	 let x = mk_var () in
	 let arg = to_ml <:expr< $lid:x$ >> t in
201
	 let res = to_cd (call_lab y l arg) s in
202
203
204
205
206
	 let abs = <:expr< fun $lid:x$ -> $res$ >> in
	 let tt = register_type (Types.descr (typ t)) in
	 let ss = register_type (Types.descr (typ s)) in
	 <:expr< Value.Abstraction ([($tt$,$ss$)],$abs$) >>
      )
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
  | Tuple tl -> 
      (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
      let vars = mk_vars tl in
      let_in (pat_tuple vars) e (tuple (tuple_to_cd tl vars))
  | PVariant l ->
      (* match <...> with 
	 | `A -> Value.atom_ascii "A" 
	 | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
      *)
      let cases = 
	List.map
	  (function 
	     | (lab,None) -> <:patt< `$lid:lab$ >>, atom_ascii lab
	     | (lab,Some t) -> 
		 <:patt< `$lid:lab$ x >>, 
		 pair (atom_ascii lab) (to_cd <:expr< x >> t)
	  ) l in
      pmatch e cases
225
  | Variant (p,l,_) ->
226
      (* match <...> with 
227
228
	 | P.A -> Value.atom_ascii "A" 
	 | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
229
230
231
232
      *)
      let cases = 
	List.map
	  (function 
233
	     | (lab,[]) -> <:patt< $lid:p^lab$ >>, atom_ascii lab
234
235
	     | (lab,tl) -> 
		 let vars = mk_vars tl in
236
		 <:patt< $lid:p^lab$ $pat_tuple vars$ >>,
237
238
239
		 tuple (atom_ascii lab :: tuple_to_cd tl vars)
	  ) l in
      pmatch e cases
240
241
  | Record (p,l,_) ->
      (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
242
243
244
245
246
      protect e
      (fun x ->
	 let l = 
	   List.map
	     (fun (lab,t) ->
247
		let e = to_cd <:expr<$x$.$lid:p^lab$>> t in
248
249
250
251
		<:expr< ($label_ascii lab$, $e$) >>)
	     l
	 in
	 <:expr< Value.record $list_lit l$ >>)
252
      
253
254
255
  | Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
  | Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
  | Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
256
  | Abstract s -> <:expr< Value.abstract $str:String.escaped s$ $e$ >>
257
258
259
  | Builtin ("list",[t]) ->
      (* Value.sequence_rev (List.rev_map fun_t <...>) *)
      <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ $e$) >>
260
261
  | Builtin ("array",[t]) ->
      <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
262
  | Builtin ("Pervasives.ref",[t]) ->
263
264
265
266
267
268
269
270
271
272
273
274
      (* let x = <...> in 
         Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
      protect e 
      (fun e ->
	 let y = mk_var () in
	 let tt = register_type (Types.descr (typ t)) in
	 let get_x = <:expr< $e$.val >> in
	 let get = <:expr< fun () -> $to_cd get_x t$ >> in
	 let tr_y = to_ml <:expr< $lid:y$ >> t in
	 let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
	 <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
      )
275
276
  | Builtin ("Big_int.big_int", []) -> 
      <:expr< Value.ocaml2cduce_bigint $e$ >>
277
  | Builtin ("Cduce_lib.Value.t", []) -> e
278
279
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
      <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
280
  | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
281
  | Var _ -> e
282
283
284
285
286
287
288
289
  | _ -> assert false

and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars

(* CDuce -> OCaml conversions *)



290
and to_ml e t =
291
292
293
294
295
296
297
(*  Format.fprintf Format.std_formatter "to_ml %a@."
    Mltypes.print t; *)
  if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
  else to_ml_descr e t.def

and to_ml_descr e = function
  | Link t -> to_ml e t
298
299
  | Arrow (l,t,s) -> 
      (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
300
301
302
303
304
      protect e 
      (fun y ->
	 let x = mk_var () in
	 let arg = to_cd <:expr< $lid:x$ >> t in
	 let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
305
	 abstr_lab l x res
306
      )
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321

  | Tuple tl -> 
      (* let (x1,r) = Value.get_pair <...> in
         let (x2,r) = Value.get_pair r in
         ...
         let (xn-1,xn) = Value.get_pair r in
	 (t1(x1),...,tn(xn)) *)

      let vars = mk_vars tl in
      let el = tuple_to_ml tl vars in
      matches e <:expr< ($list:el$) >> vars
  | PVariant l ->
      (* match Value.get_variant <...> with 
	 | "A",None -> `A 
	 | "B",Some x -> `B (t(x))
322
	 | _ -> assert false
323
      *)
324
      let x = mk_var () in
325
326
327
328
329
330
331
      let cases = 
	List.map 
	  (function 
	     | (lab,None) -> 
		 <:patt< ($str: String.escaped lab$, None) >>,
		 <:expr< `$lid:lab$ >>
	     | (lab,Some t) ->
332
333
334
335
		 let x = mk_var () in
		 let ex = <:expr< $lid:x$ >> in
		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
		 <:expr< `$lid:lab$ $to_ml ex t$ >>
336
	  ) l in
337
      let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
338
      pmatch <:expr< Value.get_variant $e$ >> cases
339
  | Variant (_,l,false) ->
340
      failwith "Private Sum type"
341
  | Variant (p,l,true) ->
342
      (* match Value.get_variant <...> with 
343
	 | "A",None -> P.A 
344
345
346
347
348
349
350
351
352
353
	 | "B",Some x -> let (x1,r) = x in ... 
      *)
      let cases = 
	List.map 
	  (function 
	     | (lab,[]) -> 
		 <:patt< ($str: String.escaped lab$, None) >>,
		 (match lab with (* Stupid Camlp4 *)
		    | "true" -> <:expr< True >>
		    | "false" -> <:expr< False >>
354
		    | lab -> <:expr< $lid:p^lab$ >>)
355
	     | (lab,[t]) ->
356
357
358
		 let x = mk_var () in
		 let ex = <:expr< $lid:x$ >> in
		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
359
		 <:expr< $lid:p^lab$ $to_ml ex t$ >>
360
361
362
	     | (lab,tl) ->
		 let vars = mk_vars tl in
		 let el = tuple_to_ml tl vars in
363
364
365
		 let x = mk_var () in
		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
		 matches <:expr< $lid:x$ >> 
366
		         <:expr< $lid:p^lab$ ($list:el$) >> vars
367
	  ) l in
368
      let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
369
      pmatch <:expr< Value.get_variant $e$ >> cases
370
  | Record (_,l,false) ->
371
      failwith "Private Record type"
372
  | Record (p,l,true) ->
373
      (* let x = <...> in
374
	 { P.l1 = t1(Value.get_field x "l1"); ... } *)
375
376
377
378
379
      protect e 
      (fun x ->
	 let l = 
	   List.map
	     (fun (lab,t) ->
380
		(<:patt< $lid:p^lab$>>,
381
382
383
		 to_ml 
		 <:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
	 <:expr< {$list:l$} >>)
384

385
386
387
  | Abstract "int" -> <:expr< Value.cduce2ocaml_int $e$ >>
  | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
  | Abstract "string" -> <:expr< Value.cduce2ocaml_string $e$ >>
388
  | Abstract s -> <:expr< Value.get_abstract $e$ >>
389
390
391
  | Builtin ("list",[t]) ->
      (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
      <:expr< List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$) >>
392
393
394
  | Builtin ("array",[t]) ->
      (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
      <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
395
396
397
398
399
  | Builtin ("Pervasives.ref",[t]) ->
      (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil)  *)
      let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
      let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
      <:expr< Pervasives.ref $to_ml e t$ >>
400
401
  | Builtin ("Big_int.big_int", []) -> 
      <:expr< Value.cduce2ocaml_bigint $e$ >>
402
  | Builtin ("Cduce_lib.Value.t", []) -> e
403
404
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
      <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
405
  | Builtin ("unit", []) -> <:expr< ignore $e$ >>
406
  | Var _ -> e
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
  | _ -> assert false

and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars


let to_ml_done = IntHash.create 13
let to_cd_done = IntHash.create 13

let global_transl () = 
  let defs = ref [] in
  let rec aux hd tl gen don fun_name to_descr =
    gen := tl;
    if not (IntHash.mem don hd.uid) then (
      IntHash.add don hd.uid ();
      let p = <:patt< $lid:fun_name hd$ >> in
      let e = <:expr< fun x -> $to_descr <:expr< x >> hd.def$ >> in
      defs := (p,e) :: !defs
    );
    loop ()
  and loop () = match !to_cd_gen,!to_ml_gen with
    | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
    | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
    | [],[] -> ()
  in
  loop ();
  !defs

(* Check type constraints and generate stub code *)

436
437
let err_ppf = Format.err_formatter

438
439
let exts = ref []

440
let check_value ty_env c_env (s,caml_t,t) =
441
  (* Find the type for the value in the CDuce module *)
442
  let id = Id.mk (Ns.empty, U.mk s) in
443
444
445
  let vt = 
    try Typer.find_value id ty_env
    with Not_found ->
446
447
      Format.fprintf err_ppf
      "The interface exports a value %s which is not available in the module@." s;
448
449
450
451
452
453
454
455
456
457
      exit 1
  in

  (* Compute expected CDuce type *)
  let et = Types.descr (typ t) in

  (* Check subtyping *)
  if not (Types.subtype vt et) then
    (
      Format.fprintf
458
459
460
461
462
       err_ppf
       "The type for the value %s is invalid@\n\
        Expected Caml type:@[%a@]@\n\
        Expected CDuce type:@[%a@]@\n\
        Inferred type:@[%a@]@."
463
       s
464
       print_ocaml caml_t
465
466
467
468
469
470
471
       Types.Print.print et
       Types.Print.print vt;
      exit 1
    );
   
  (* Generate stub code *)
  (* let x = t(Eval.get_slot cu slot) *)
472
  let x = mk_var () in
473
474
  let slot = Compile.find_slot id c_env in
  let e = to_ml <:expr< Eval.get_slot cu $int:string_of_int slot$ >> t in
475
  <:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
476

477
let stub name ty_env c_env values =
478
  let items = List.map (check_value ty_env c_env) values in
479

480
  let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
481
482
  let g = global_transl () in

483
484
485
486
  (* 
     let (v1,v2,...,vn) = 
     let module C = struct
      let cu = ...
487
      open Cduce_lib
488
      Config.init_all ()
489
490
491
492
493
494
      let types = ...
      let rec <global translation functions>
      <fills external slots>
      <run the unit>
      let <stubs for values>
     end in (C.x1,...,C.xn)
495
496
  *)

497
498
499
500
501
  let items_def = List.map (fun (_,_,d) -> d) items in
  let items_expr = List.map (fun (_,e,_) -> e)  items in
  let items_pat = List.map (fun (p,_,_) -> p) items in

  let m = 
502
    [ <:str_item< open Cduce_lib >>;
503
      <:str_item< Config.init_all () >>;
504
505
      <:str_item< value types = Librarian.registered_types cu >> ] @
    (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
506
    [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
507
508
509
510
511
512
513
514
515
    <:str_item< Librarian.run cu >> ] @
    (if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in

  let items_expr = 
    match items_expr with 
      | [] -> <:expr< () >> 
      | l -> <:expr< ($list:l$) >> in

  <:patt< ($list:items_pat$) >>, m, items_expr
516
517


518
let register () =
519
520
  Typer.has_ocaml_unit :=
    (fun cu -> Mltypes.has_cmi (U.get_str cu));
521
522
523
524
  Librarian.stub_ml := 
  (fun cu ty_env c_env ->
     try
       let name = String.capitalize cu in
525
526
527
       let (prolog, values) = 
	 try Mltypes.read_cmi name
	 with Not_found ->  
528
(* 	   Printf.eprintf "Warning: no caml interface\n"; *)
529
	   ("",[]) in
530
531
532
       let code = stub cu ty_env c_env values in
       Some (Obj.magic (prolog,code)),
       get_registered_types ()
533
     with Mltypes.Error s -> raise (Location.Generic s)
534
535
  );

536
  Externals.register :=
537
  (fun i s args ->
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
     try
       let (t,n) = Mltypes.find_value s in
       let m = List.length args in
       if n <> m then
	 Location.raise_generic
	   (Printf.sprintf 
	      "Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
       exts := (s, t) :: !exts;

       vars := Array.of_list args;
       let cdt = Types.descr (typ t) in
       vars := [| |];
       cdt
     with Not_found -> 
       Location.raise_generic
         (Printf.sprintf "Cannot resolve ocaml external %s" s)
554
  )
555

556
557
558
559
560
let () =
  Config.register 
    "ocaml" 
    "OCaml interface" 
    register