viewcvs.cgi/compile/compile.ml

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)
1	open Ident
2	open Lambda
3
4	type env = {
5	vars: var_loc Env.t;
6	stack_size: int
7	}
8
9	let empty = { vars = Env.empty; stack_size = 0 }
10
11	let rec compile env e = compile_aux env e.Typed.exp_descr
12	and compile_aux env = function
13	\| Typed.Forget (e,_) -> compile env e
14	\| Typed.Var x -> Var (Env.find x env.vars)
15	\| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
16	\| Typed.Abstraction a -> compile_abstr env a
17	\| Typed.Cst c -> Const c
18	\| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
19	\| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
20	let env' = env in
21	Xml (compile env e1, compile env' e2, compile env' e3)
22	\| Typed.Xml (_,_) -> assert false
23	\| Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
24	\| Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
25	\| Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
26	\| _ -> assert false
27
28
29
30	and compile_abstr env a =
31	let (slots,nb_slots,fun_env) =
32	List.fold_left
33	(fun (slots,nb_slots,fun_env) x ->
34	match Env.find x env.vars with
35	\| (Stack _ \| Env _) as p ->
36	p::slots,
37	succ nb_slots,
38	Env.add x (Env nb_slots) fun_env;
39	\| Global _ as p ->
40	slots,
41	nb_slots,
42	Env.add x p fun_env
43	\| Dummy -> assert false
44	)
45	([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in
46
47
48	let recurs,fun_env,slots = match a.Typed.fun_name with
49	\| Some x when IdSet.mem a.Typed.fun_fv x ->
50	true, Env.add x (Env 0) fun_env, Dummy::slots
51	\| _ -> false, fun_env, slots in
52	let slots = Array.of_list (List.rev slots) in
53	let env = { vars = fun_env; stack_size = 0 } in
54	let body = compile_branches env a.Typed.fun_body in
55	Abstraction (recurs, slots, a.Typed.fun_iface, body)
56
57	and compile_branches env (brs : Typed.branches) =
58	{
59	brs = List.map (compile_branch env) brs.Typed.br_branches;
60	brs_input = brs.Typed.br_typ;
61	brs_compiled = None
62	}
63
64	and compile_branch env br =
65	let env =
66	List.fold_left
67	(fun env x ->
68	{ vars = Env.add x (Stack env.stack_size) env.vars;
69	stack_size = env.stack_size + 1 }
70	) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
71	(br.Typed.br_pat, compile env br.Typed.br_body)