compile.ml 2.17 KB
Newer Older
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
open Ident
open Lambda

type env = {
  vars: var_loc Env.t;
  stack_size: int
}

let empty = { vars = Env.empty; stack_size = 0 }

let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
  | Typed.Forget (e,_) -> compile env e
  | Typed.Var x -> Var (Env.find x env.vars)
  | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
  | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
      let env' = env in
      Xml (compile env e1, compile env' e2, compile env' e3)
  | Typed.Xml (_,_) -> assert false
  | Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
  | 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)
  | _ -> assert false



and compile_abstr env a =
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
	 match Env.find x env.vars with
	   | (Stack _ | Env _) as p -> 
	       p::slots,
	       succ nb_slots,
	       Env.add x (Env nb_slots) fun_env;
	   | Global _ as p -> 
	       slots,
	       nb_slots,
	       Env.add x p fun_env
	   | Dummy -> assert false
      )
      ([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in


  let recurs,fun_env,slots = match a.Typed.fun_name with
    | Some x when IdSet.mem a.Typed.fun_fv x -> 
	true, Env.add x (Env 0) fun_env, Dummy::slots
    | _ -> false, fun_env, slots in
  let slots = Array.of_list (List.rev slots) in  
  let env = { vars = fun_env; stack_size = 0 } in
  let body = compile_branches env a.Typed.fun_body in
  Abstraction (recurs, slots, a.Typed.fun_iface, body)

and compile_branches env (brs : Typed.branches) =
  { 
    brs = List.map (compile_branch env) brs.Typed.br_branches;
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

and compile_branch env br =
  let env = 
    List.fold_left 
      (fun env x ->
	 { vars = Env.add x (Stack env.stack_size) env.vars;
	   stack_size = env.stack_size + 1 }
      ) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
  (br.Typed.br_pat, compile env br.Typed.br_body)