compile.ml 10.1 KB
Newer Older
1
2
3
4
open Ident
open Lambda

type env = {
5
  cu: Compunit.t option;  (* None: toplevel *)
6
  vars: var_loc Env.t;
7
8
  sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
  gamma : var_loc Env.t; (* map of type variables to types *)
9
  stack_size: int;
10
  max_stack: int ref;
11
  global_size: int
12
13
}

14
15
let global_size env = env.global_size

16
17
18
19
20
21
22
23
24
let mk cu = { 
  cu = cu; 
  vars = Env.empty;
  sigma = `List [];
  gamma = Env.empty;
  stack_size = 0; 
  max_stack = ref 0; 
  global_size = 0 
}
25
26
let empty_toplevel = mk None
let empty x = mk (Some x)
27

28
29
30
31
32
let find x env =
  try Env.find x env.vars
  with Not_found -> 
    failwith ("Compile: cannot find " ^ (Ident.to_string x))

33
34
let find_slot x env =
  match find x env with
35
    | Ext (_,slot) -> slot
36
37
    | _ -> assert false
 
38
39
40
41
let from_comp_unit = ref (fun cu -> assert false)

let find_ext cu x =
  let env = !from_comp_unit cu in
42
43
  find x env

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
let enter_local env x =
  let new_size = env.stack_size + 1 in
  if new_size > !(env.max_stack) then (env.max_stack) := new_size;
  { env with 
      vars = Env.add x (Local env.stack_size) env.vars;
      stack_size = new_size }

let enter_global_toplevel env x =
  { env with 
      vars = Env.add x (Global env.global_size) env.vars;
      global_size = env.global_size + 1 }

let enter_global_cu cu env x =
  { env with 
      vars = Env.add x (Ext (cu,env.global_size)) env.vars;
      global_size = env.global_size + 1 }

61
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
62
63
64
65
66
67
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
  | Typed.Forget (e,_) -> compile env e
  | Typed.Check (t0,e,t) -> 
      let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
      Check (compile env e, d)
68
  | Typed.Var x -> Var (find x env)
69
70
71
72
73
  | Typed.TVar x ->
      let v = find x env in
      if env.sigma = (`List []) (* && not (find v dom(env.sigma)) *) then Var (v)
      else TVar(v,env.sigma)
  | Typed.Subst(e,sl) -> compile { env with sigma = `Comp(env.sigma,`List sl) } e
74
  | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
75
  | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
76
  | Typed.Abstraction a -> compile_abstr env a
77
78
  | Typed.Cst c -> Const (Value.const c)
  | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
79
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) -> 
80
      Xml (compile env e1, compile env e2, compile env e3)
81
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) -> 
82
      XmlNs (compile env e1, compile env e2, compile env e3,t)
83
  | Typed.Xml _ -> assert false
84
  | Typed.RecordLitt r -> 
85
86
      let r = List.map (fun (l,e) -> (Upool.int l, compile env e)) 
	(LabelMap.get r)
87
88
      in
      Record (Imap.create (Array.of_list r))
89
90
91
92
93
94
95
96
97
98
  | Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
  | Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
  | Typed.Map (e,brs) -> Map (compile env e, compile_branches env brs)
  | Typed.Transform (e,brs) -> Transform (compile env e, compile_branches env brs)
  | Typed.Xtrans (e,brs) -> Xtrans (compile env e, compile_branches env brs)
  | Typed.Validate (e,_,validator) -> Validate (compile env e, validator)
  | Typed.RemoveField (e,l) -> RemoveField (compile env e,l)
  | Typed.Dot (e,l) -> Dot (compile env e, l)
  | Typed.Try (e,brs) -> Try (compile env e, compile_branches env brs)
  | Typed.Ref (e,t) ->  Ref (compile env e, t)
99
  | Typed.External (t,`Ext i) -> 
100
      (match env.cu with
101
	 | Some cu -> Var (External (cu,i))
102
	 | None -> failwith "Cannot compile externals in the toplevel")
103
104
  | Typed.External (t,`Builtin s) -> 
      Var (Builtin s)
105
  | Typed.Op (op,_,args) -> 
106
      let rec aux = function
107
108
	| [arg] -> [ compile env arg ]
	| arg::l -> (compile env arg) :: (aux l)
109
110
	| [] -> [] in
      Op (op, aux args)
111
  | Typed.NsTable (ns,e) ->
112
      NsTable (ns, compile_aux env e)
113
114

and compile_abstr env a =
115
116
117
118
119
  let fun_env = 
    match a.Typed.fun_name with
      | Some x -> Env.add x (Env 0) Env.empty
      | None -> Env.empty in

120
121
122
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
123
	 match find x env with
124
	   | (Local _ | Env _) as p -> 
125
126
127
	       p::slots,
	       succ nb_slots,
	       Env.add x (Env nb_slots) fun_env;
128
	   | Global _ | Ext _ | External _ | Builtin _ as p -> 
129
130
131
132
133
	       slots,
	       nb_slots,
	       Env.add x p fun_env
	   | Dummy -> assert false
      )
134
      ([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
135
136
137


  let slots = Array.of_list (List.rev slots) in  
138
139
  let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
  let body = compile_branches env a.Typed.fun_body in
140
141
142
  let sigma = `Sel(a.Typed.fun_fv,a.Typed.fun_iface,env.sigma) in
  (*
  if equal (inter (Types.all_vars(Env.find x env.gamma)) dom(env.sigma)) empty then
143
144
    Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), false, sigma)
  else 
145
    *)
146
    Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, sigma)
147

148
and compile_branches env (brs : Typed.branches) =
149
  (* Don't compile unused branches, because they have not been type checked. *)
150
  let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
151
152
153
  let b = List.map (compile_branch env) used in
  let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
  { brs_stack_pos = env.stack_size;
154
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
155
    brs_disp = disp;
156
157
    brs_rhs = rhs 
  }
158

159
160
(* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type 
 * p_i / t_i is used here to add elements to env.gamma *)
161
162
and compile_branch env br =
  let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
163
  (br.Typed.br_pat, compile env br.Typed.br_body )
164
165
166
167
168
169
170
171
172

let enter_globals env n =  match env.cu with
  | None -> List.fold_left enter_global_toplevel env n
  | Some cu -> List.fold_left (enter_global_cu cu) env n

let compile_expr env e =
  let env = { env with max_stack = ref 0; stack_size = 0 } in
  let e = compile env e in
  (e,!(env.max_stack))
173

174
175
let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
176
177
178
  let e,lsize = compile_expr env decl.Typed.let_body in
  let env = enter_globals env (Patterns.fv pat) in

179
  let te = decl.Typed.let_body.Typed.exp_typ in 
180
  let comp = Patterns.Compile.make_branches te [ pat, () ] in
181
182
183
184
185
  let (disp, n) = 
    match comp with
      | (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
      | _ -> assert false in
  (env, [ LetDecls (e,lsize,disp,n) ])
186
187
188
189
190

let compile_rec_funs env funs =
  let fun_name = function
    | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
    | _ -> assert false in
191
192
193
194
195
196
  let fun_a env e =
    let e,lsize = compile_expr env e in
    LetDecl (e,lsize) in
  let env = enter_globals env (List.map fun_name funs) in
  let code= List.map (fun_a env) funs in
  (env, code)
197
198
199
200


(****************************************)

201
open Cduce_loc
202

203
204
let eval ~run ~show (tenv,cenv,codes) e =
  let (e,t) = Typer.type_expr tenv e in
205
  let e,lsize = compile_expr cenv e in
206
  if run then
207
    let v = Eval.expr e lsize in
208
209
210
    show None t (Some v)
  else
    show None t None;
211
  (tenv,cenv, Eval (e,lsize) :: codes)
212

213
let run_show ~run ~show tenv cenv codes ids =
214
  if run then
215
    let () = Eval.eval_toplevel codes in
216
217
218
    List.iter 
      (fun (id,_) -> show (Some id) 
	 (Typer.find_value id tenv)
219
	 (Some (Eval.eval_var (find id cenv)))) ids
220
221
222
223
224
  else
    List.iter 
      (fun (id,_) -> show (Some id) 
	 (Typer.find_value id tenv)
	 None) ids
225
  
226
227
let let_decl ~run ~show (tenv,cenv,codes) p e =
  let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
228
  let (cenv,code) = compile_let_decl cenv decl in
229
  run_show ~run ~show tenv cenv code ids;
230
  (tenv,cenv,List.rev_append code codes)
231
  
232
233
let let_funs ~run ~show (tenv,cenv,codes) funs =
  let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
234
  let (cenv,code) = compile_rec_funs cenv funs in
235
  run_show ~run ~show tenv cenv code ids;
236
  (tenv,cenv,List.rev_append code codes)
237
238
  
let type_defs (tenv,cenv,codes) typs =
239
  let tenv = Typer.type_defs tenv typs in
240
241
  (tenv,cenv,codes)

242
243
let namespace (tenv,cenv,codes) loc pr ns =
  let tenv = Typer.type_ns tenv loc pr ns in
244
245
  (tenv,cenv,codes)

246
247
248
249
let keep_ns (tenv,cenv,codes) k =
  let tenv = Typer.type_keep_ns tenv k in
  (tenv,cenv,codes)

250
251
let schema (tenv,cenv,codes) loc x sch =
  let tenv = Typer.type_schema tenv loc x sch in
252
253
  (tenv,cenv,codes)

254
255
let using (tenv,cenv,codes) loc x cu =
  let tenv = Typer.type_using tenv loc x cu in
256
257
  (tenv,cenv,codes)

258
259
260
261
let do_open (tenv,cenv,codes) loc path =
  let tenv = Typer.type_open tenv loc path in
  (tenv,cenv,codes)

262
263
let rec collect_funs accu = function
  | { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
264
  | rest -> (List.rev accu,rest)
265
266

let rec collect_types accu = function
267
268
  | { descr = Ast.TypeDecl ((loc,x),t) } :: rest -> 
      collect_types ((loc,x,t) :: accu) rest
269
270
  | rest -> (accu,rest)

271
let rec phrases ~run ~show ~directive =
272
273
274
275
276
277
278
279
  let rec loop accu phs =
    match phs with
      | { descr = Ast.FunDecl _ } :: _ -> 
	  let (funs,rest) = collect_funs [] phs in
	  loop (let_funs ~run ~show accu funs) rest
      | { descr = Ast.TypeDecl (_,_) } :: _ ->
	  let (typs,rest) = collect_types [] phs in
	  loop (type_defs accu typs) rest
280
281
282
283
      | { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
	  loop (schema accu loc name uri) rest
      | { descr = Ast.Namespace (pr,ns); loc = loc } :: rest ->
	  loop (namespace accu loc pr ns) rest
284
285
      | { descr = Ast.KeepNs b } :: rest ->
	  loop (keep_ns accu b) rest
286
287
      | { descr = Ast.Using (x,cu); loc = loc } :: rest ->
	  loop (using accu loc x cu) rest
288
289
      | { descr = Ast.Open path; loc = loc } :: rest ->
	  loop (do_open accu loc path) rest
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
      | { descr = Ast.EvalStatement e } :: rest ->
	  loop (eval ~run ~show accu e) rest
      | { descr = Ast.LetDecl (p,e) } :: rest ->
	  loop (let_decl ~run ~show accu p e) rest
      | { descr = Ast.Directive d } :: rest ->
	  let (tenv,cenv,_) = accu in
	  directive tenv cenv d;
	  loop accu rest
      | [] -> 
	  accu
  in
  loop

let comp_unit ?(run=false) 
  ?(show=fun _ _ _ -> ()) 
  ?(directive=fun _ _ _ -> ())  tenv cenv phs =
306
  let (tenv,cenv,codes) = phrases ~run ~show ~directive (tenv,cenv,[]) phs in
307
  (tenv,cenv,List.rev codes)
308
309
310
311
312


let compile_eval_expr env e =
  let e,lsize = compile_expr env e in
  Eval.expr e lsize