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

type env = {
5
  cu: Compunit.t option;  (* None: toplevel *)
Pietro Abate's avatar
Pietro Abate committed
6
  vars: var_loc Env.t; (* Id.t to var_loc *)
7
  sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
8
  gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
9
  xi : Var.Set.t IdMap.map;
10
  stack_size: int;
11
  max_stack: int ref;
12
  global_size: int
13 14
}

15 16
let global_size env = env.global_size

17 18 19
let mk cu = { 
  cu = cu; 
  vars = Env.empty;
20
  sigma = Lambda.Identity;
21
  gamma = IdMap.empty;
22
  xi = IdMap.empty;
23 24 25 26
  stack_size = 0; 
  max_stack = ref 0; 
  global_size = 0 
}
27 28
let empty_toplevel = mk None
let empty x = mk (Some x)
29

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

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

let find_ext cu x =
  let env = !from_comp_unit cu in
44 45
  find x env

46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
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 }

63
let rec domain = function 
64
  |Identity -> assert false
65 66
  |List l -> Types.Tallying.domain l
  |Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
Pietro Abate's avatar
Pietro Abate committed
67 68
  |Sel(_,_,sigma) -> (domain sigma)

69 70 71 72 73 74
let rec codomain = function
  | Identity -> Var.Set.empty
  | List(l) -> Types.Tallying.codomain l
  | Comp(s1,s2) -> Var.Set.union (codomain s1) (codomain s2)
  | Sel(_,_,sigma) -> (codomain sigma)

Pietro Abate's avatar
Pietro Abate committed
75 76 77 78 79 80
let fresharg =
  let count = ref 0 in
  function () ->
    let s = Printf.sprintf "__ARG%d" !count in
    incr count;
    (0,U.mk s)
Pietro Abate's avatar
Pietro Abate committed
81 82 83
    (*
    (Ns.Uri.mk (U.mk ""),U.mk s)
*)
Pietro Abate's avatar
Pietro Abate committed
84
;;
85

Julien Lopez's avatar
Julien Lopez committed
86
(* Comp for Lambda.sigma but simplify if possible. *)
Julien Lopez's avatar
Julien Lopez committed
87
let rec comp s1 s2 = match s1, s2 with
88 89
  | Identity, _ -> s2
  | _, Identity -> s1
Julien Lopez's avatar
Julien Lopez committed
90

Julien Lopez's avatar
Julien Lopez committed
91
  | Comp(s3, s4), List(_) -> (match comp s4 s2 with
92
      | Comp(_) as s5 when s4 = s5 -> s1
Julien Lopez's avatar
Julien Lopez committed
93 94 95
      | Comp(_) -> Comp(s1, s2)
      | res -> comp s3 res)
  | List(_), Comp(s3, s4) | Sel(_), Comp(s3, s4) -> (match comp s1 s3 with
96
      | Comp(_) as s5 when s3 = s5 -> s2
Julien Lopez's avatar
Julien Lopez committed
97 98 99 100 101 102
      | Comp(_) -> Comp(s1, s2)
      | res -> comp res s4)
  | Comp(s3, s4), Comp(s5, s6) -> (match comp s4 s5 with
      | Comp(_) -> Comp(s1, s2)
      | res -> comp s3 (comp res s6))

Julien Lopez's avatar
Julien Lopez committed
103 104 105 106
  (* If a variable in the image of s2 is in the domain of s1 we can't simplify *)
  | _, _ when not (Var.Set.is_empty (Var.Set.inter (domain s1) (codomain s2)))
      -> Comp(s1, s2)

107
  | List(_), List(_) | Sel(_), List(_) ->
Julien Lopez's avatar
Julien Lopez committed
108 109
    if Var.Set.subset (domain s1) (domain s2) then s2 else Comp(s1, s2)

Julien Lopez's avatar
Julien Lopez committed
110
  (* Default: comp s1 s2 -> Comp(s1, s2). *)
111
  | _, _ -> Comp(s1, s2)
Pietro Abate's avatar
WIP  
Pietro Abate committed
112

113
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
114
(* Typed -> Lambda *)
115 116 117 118 119 120
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)
121
  | Typed.Var x -> Var (find x env)
122 123
  | Typed.TVar x ->
      let v = find x env in
124
      let ts = Types.all_vars (Types.descr (IdMap.assoc x env.gamma)) in
125 126
      let is_mono x =
        let from_xi = try IdMap.assoc x env.xi with Not_found -> Var.Set.empty in
127
        let d = Var.Set.inter from_xi (domain(env.sigma)) in
128
        Var.Set.is_empty (Var.Set.inter ts d)
Pietro Abate's avatar
Pietro Abate committed
129
      in
130 131
      if Var.Set.is_empty ts then Var (v) else
      if env.sigma = Identity then TVar(v,env.sigma) else
132
      if is_mono x then Var (v) else TVar(v,env.sigma)
133
  | Typed.Subst(e,sl) -> compile { env with sigma = comp env.sigma (List sl) } e
134
  | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
135
  | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
136
  | Typed.Abstraction a -> compile_abstr env a
137 138
  | Typed.Cst c -> Const (Value.const c)
  | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
139
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) -> 
140
      Xml (compile env e1, compile env e2, compile env e3)
141
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) -> 
142
      XmlNs (compile env e1, compile env e2, compile env e3,t)
143
  | Typed.Xml _ -> assert false
144
  | Typed.RecordLitt r -> 
145 146
      let r = List.map (fun (l,e) -> (Upool.int l, compile env e)) 
	(LabelMap.get r)
147 148
      in
      Record (Imap.create (Array.of_list r))
149 150 151 152 153 154 155 156 157 158
  | 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)
159
  | Typed.External (t,`Ext i) -> 
160
      (match env.cu with
161
	 | Some cu -> Var (External (cu,i))
162
	 | None -> failwith "Cannot compile externals in the toplevel")
163 164
  | Typed.External (t,`Builtin s) -> 
      Var (Builtin s)
165
  | Typed.Op (op,_,args) -> 
166
      let rec aux = function
167 168
	| [arg] -> [ compile env arg ]
	| arg::l -> (compile env arg) :: (aux l)
169 170
	| [] -> [] in
      Op (op, aux args)
171
  | Typed.NsTable (ns,e) ->
172
      NsTable (ns, compile_aux env e)
173 174

and compile_abstr env a =
175
  let fun_env, fun_name = 
176
    match a.Typed.fun_name with
177 178
      | Some x -> Env.add x (Env 0) Env.empty, Ident.IdMap.singleton x (Types.cons a.Typed.fun_typ)
      | None -> Env.empty, Ident.IdMap.empty
179
  in
180 181 182
  let is_mono = 
    let vars =
      List.fold_left(fun acc (t1,t2) ->
Pietro Abate's avatar
WIP  
Pietro Abate committed
183 184
        let ts1 = Types.all_vars t1 in
        let ts2 = Types.all_vars t2 in
185 186
        let tu = Var.Set.union ts1 ts2 in
        Var.Set.union acc tu
Pietro Abate's avatar
WIP  
Pietro Abate committed
187 188
      ) Var.Set.empty a.Typed.fun_iface
    in
189 190 191 192 193
    if Var.Set.is_empty vars then true else
    if env.sigma = Identity then false
    else
      let d = domain(env.sigma) in
      Var.Set.is_empty (Var.Set.inter d vars)
Pietro Abate's avatar
WIP  
Pietro Abate committed
194 195 196
  in
  let (slots,nb_slots,fun_env) = 
    (* we add a nameless empty slot for the argument *)
197 198
    if is_mono then ([Dummy],1,fun_env)
    else
199 200
      let (x, y) = fresharg () in
      ([Dummy;Dummy],2,Env.add (Ns.Uri.from_int x, y) (Env 1) fun_env)
Pietro Abate's avatar
WIP  
Pietro Abate committed
201
  in
202
  let (slots,nb_slots,fun_env) = 
Pietro Abate's avatar
WIP  
Pietro Abate committed
203
    (* here De Bruijn indexes are reshuffled *)
204 205
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
206
	 match find x env with
207
	   | (Local _ | Env _) as p -> 
208 209 210
	       p::slots,
	       succ nb_slots,
	       Env.add x (Env nb_slots) fun_env;
211
	   | Global _ | Ext _ | External _ | Builtin _ as p -> 
212 213 214 215 216
	       slots,
	       nb_slots,
	       Env.add x p fun_env
	   | Dummy -> assert false
      )
Pietro Abate's avatar
WIP  
Pietro Abate committed
217
      (slots,nb_slots,fun_env) (IdSet.get a.Typed.fun_fv) 
218
  in
219
  let slots = Array.of_list (List.rev slots) in  
220
  let env =
221 222 223 224 225
    { env with vars = fun_env; 
      gamma = IdMap.merge (fun _ v2 -> v2) env.gamma fun_name;
      stack_size = 0; 
      max_stack = ref 0 } 
  in
226
  let body = compile_branches env a.Typed.fun_body in
Pietro Abate's avatar
Pietro Abate committed
227 228 229
  let rec lift n = function
    |Sel(Env i, iface, s) -> Sel(Env (i+n),iface,lift n s)
    |Comp(s1,s2) -> Comp(lift n s1,lift n s2)
230 231
    |s -> s
  in
232
  if is_mono then
233
    Abstraction(slots, a.Typed.fun_iface, body, !(env.max_stack))
Pietro Abate's avatar
WIP  
Pietro Abate committed
234
  else
235 236
    let sigma = match env.sigma with
      | Identity -> Identity
Pietro Abate's avatar
Pietro Abate committed
237 238
      | _ -> Sel(Env 1,a.Typed.fun_iface,lift nb_slots (env.sigma)) 
    in
239
    PolyAbstraction(slots, a.Typed.fun_iface, body, !(env.max_stack), sigma)
240

241
and compile_branches env (brs : Typed.branches) =
242
  (* Don't compile unused branches, because they have not been type checked. *)
243
  let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
244
  let b = List.map (compile_branch env) used in
245 246 247
  (* here I need to pull type information from each pattern and then
   * compute for each variable gamma(x) . I should be able to compute gamma(x) 
   * using the information computed in (disp,rhs) *)
248 249
  let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
  { brs_stack_pos = env.stack_size;
250
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
251
    brs_disp = disp;
252 253
    brs_rhs = rhs 
  }
254

255 256
(* 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 *)
257
and compile_branch env br =
258 259
  let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
  let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
260 261
  let env = 
    { env with 
262
      gamma = IdMap.merge (fun _ v2 -> v2) m env.gamma;
263
      xi = IdMap.merge (fun _ v2 -> v2) env.xi br.Typed.br_vars_poly
264 265
    }
  in
266
  (br.Typed.br_pat, compile env br.Typed.br_body)
267 268 269 270 271 272 273 274 275

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))
276

277 278
let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
279 280 281
  let e,lsize = compile_expr env decl.Typed.let_body in
  let env = enter_globals env (Patterns.fv pat) in

282
  let te = decl.Typed.let_body.Typed.exp_typ in 
283
  let comp = Patterns.Compile.make_branches te [ pat, () ] in
284 285 286 287 288
  let (disp, n) = 
    match comp with
      | (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
      | _ -> assert false in
  (env, [ LetDecls (e,lsize,disp,n) ])
289 290 291 292 293

let compile_rec_funs env funs =
  let fun_name = function
    | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
    | _ -> assert false in
294 295 296 297 298 299
  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)
300 301 302 303


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

304
open Cduce_loc
305

306 307
let eval ~run ~show (tenv,cenv,codes) e =
  let (e,t) = Typer.type_expr tenv e in
308
  let e,lsize = compile_expr cenv e in
309
  if run then
310
    let v = Eval.expr e lsize in
311 312 313
    show None t (Some v)
  else
    show None t None;
314
  (tenv,cenv, Eval (e,lsize) :: codes)
315

316
let run_show ~run ~show tenv cenv codes ids =
317
  if run then
318
    let () = Eval.eval_toplevel codes in
Pietro Abate's avatar
Pietro Abate committed
319 320 321 322 323
    List.iter (fun (id,_) ->
      show (Some id) 
	  (Typer.find_value id tenv)
	  (Some (Eval.eval_var (find id cenv)))
    ) ids
324
  else
Pietro Abate's avatar
Pietro Abate committed
325 326 327 328 329
    List.iter (fun (id,_) ->
      show (Some id)
        (Typer.find_value id tenv)
	  None
    ) ids
330
  
331 332
let let_decl ~run ~show (tenv,cenv,codes) p e =
  let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
333
  let (cenv,code) = compile_let_decl cenv decl in
334
  run_show ~run ~show tenv cenv code ids;
335
  (tenv,cenv,List.rev_append code codes)
336
  
337 338
let let_funs ~run ~show (tenv,cenv,codes) funs =
  let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
339
  let (cenv,code) = compile_rec_funs cenv funs in
340
  run_show ~run ~show tenv cenv code ids;
341
  (tenv,cenv,List.rev_append code codes)
342 343
  
let type_defs (tenv,cenv,codes) typs =
344
  let tenv = Typer.type_defs tenv typs in
345 346
  (tenv,cenv,codes)

347 348
let namespace (tenv,cenv,codes) loc pr ns =
  let tenv = Typer.type_ns tenv loc pr ns in
349 350
  (tenv,cenv,codes)

351 352 353 354
let keep_ns (tenv,cenv,codes) k =
  let tenv = Typer.type_keep_ns tenv k in
  (tenv,cenv,codes)

355 356
let schema (tenv,cenv,codes) loc x sch =
  let tenv = Typer.type_schema tenv loc x sch in
357 358
  (tenv,cenv,codes)

359 360
let using (tenv,cenv,codes) loc x cu =
  let tenv = Typer.type_using tenv loc x cu in
361 362
  (tenv,cenv,codes)

363 364 365 366
let do_open (tenv,cenv,codes) loc path =
  let tenv = Typer.type_open tenv loc path in
  (tenv,cenv,codes)

367 368
let rec collect_funs accu = function
  | { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
369
  | rest -> (List.rev accu,rest)
370 371

let rec collect_types accu = function
372 373
  | { descr = Ast.TypeDecl ((loc,x),t) } :: rest -> 
      collect_types ((loc,x,t) :: accu) rest
374 375
  | rest -> (accu,rest)

376
let rec phrases ~run ~show ~directive =
377 378 379 380 381 382 383 384
  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
385 386 387 388
      | { 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
389 390
      | { descr = Ast.KeepNs b } :: rest ->
	  loop (keep_ns accu b) rest
391 392
      | { descr = Ast.Using (x,cu); loc = loc } :: rest ->
	  loop (using accu loc x cu) rest
393 394
      | { descr = Ast.Open path; loc = loc } :: rest ->
	  loop (do_open accu loc path) rest
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410
      | { 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 =
411
  let (tenv,cenv,codes) = phrases ~run ~show ~directive (tenv,cenv,[]) phs in
412
  (tenv,cenv,List.rev codes)
413 414 415 416

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