compile.ml 3.91 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
open Ident
open Lambda

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

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

11
12
13
14
15
16
17
18
19
20
let find x env =
  try Env.find x env.vars
  with Not_found -> 
    failwith ("Compile: cannot find " ^ (Ident.to_string x))

let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function
  | Typed.Forget (e,_) -> compile env tail e
  | Typed.Var x -> Var (find x env)
  | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
21
22
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
23
  | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
24
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
25
      Xml (compile env false e1, compile env false e2, compile env tail e3)
26
  | Typed.Xml (_,_) -> assert false
27
28
29
30
31
32
33
34
35
36
37
38
39
40
  | Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
  | Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
  | Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
  | Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
  | Typed.Transform (e,brs) -> Transform 
      (compile env false e, compile_branches env false brs)
  | Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
  | Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
  | Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
  | Typed.Dot (e,l) -> Dot (compile env tail e, l)
  | Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
  | Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
  | Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
  | Typed.Ref (e,t) ->  Ref (compile env tail e, t)
41
42

and compile_abstr env a =
43
44
45
46
47
  let fun_env = 
    match a.Typed.fun_name with
      | Some x -> Env.add x (Env 0) Env.empty
      | None -> Env.empty in

48
49
50
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
51
	 match find x env with
52
53
54
55
56
57
58
59
60
61
	   | (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
      )
62
      ([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
63
64
65
66


  let slots = Array.of_list (List.rev slots) in  
  let env = { vars = fun_env; stack_size = 0 } in
67
68
  let body = compile_branches env true a.Typed.fun_body in
  Abstraction (slots, a.Typed.fun_iface, body)
69

70
and compile_branches env tail (brs : Typed.branches) =
71
  { 
72
73
74
    brs = List.map (compile_branch env tail) brs.Typed.br_branches;
    brs_tail = tail;
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
75
76
77
78
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

79
and compile_branch env tail br =
80
81
82
83
84
  let env = 
    List.fold_left 
      (fun env x ->
	 { vars = Env.add x (Stack env.stack_size) env.vars;
	   stack_size = env.stack_size + 1 }
85

86
      ) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
87
88
89
90
91
92
93
94
95
96
97
98
99
100
  (br.Typed.br_pat, compile env tail br.Typed.br_body)


let enter_global env x =
  { vars = Env.add x (Global env.stack_size) env.vars;
    stack_size = env.stack_size + 1 }

let enter_globals = List.fold_left enter_global

let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
  let decl = { let_pat = pat; let_expr = compile env false (decl.Typed.let_body) } in
  let names = IdSet.get (Patterns.fv pat) in
  let env = enter_globals env names in
101
  (env, decl)
102
103
104
105
106
107
108
109
110
111
112
113


let compile_rec_funs env funs =
  let fun_name = function
    | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
    | _ -> assert false in
  let fun_a = function
    | { Typed.exp_descr=Typed.Abstraction a } -> a
    | _ -> assert false in
  let names = List.map fun_name funs in
  let env = enter_globals env names in
  let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
114
  (env, exprs)