viewcvs.cgi/compile/compile.ml

open Ident
open Lambda

type env = {
  cu: Types.CompUnit.t option;  (* None: toplevel *)
  vars: var_loc Env.t;
  stack_size: int;
  global_size: int
}

let global_size env = env.global_size

let dump ppf env =
  Env.iter 
    (fun id loc ->
       Format.fprintf ppf "Var %a : %a@\n" U.print (Id.value id) Lambda.print_var_loc loc)
    env.vars


let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
let empty_toplevel = mk None
let empty x = mk (Some x)


let serialize s env =
  assert (env.stack_size = 0);
  (match env.cu with
    | Some cu -> Types.CompUnit.serialize s cu
    | None -> assert false);
  Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
  Serialize.Put.int s env.global_size

let deserialize s =
  let cu = Types.CompUnit.deserialize s in
  let vars = 
    Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
  let size = Serialize.Get.int s in
  { cu = Some cu; vars = vars; stack_size = 0; global_size = size }


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

let from_comp_unit = ref (fun cu -> assert false)

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


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.ExtVar (cu,x) -> Var (find_ext cu x)
  | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
  | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
      Xml (compile env false e1, compile env false e2, compile env tail e3)
  | Typed.Xml (_,_) -> assert false
  | 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,k,sch,t) -> Validate (compile env tail e, k, 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)

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

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


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

and compile_branches env tail (brs : Typed.branches) =
  (* Don't compile unused branches, because they have not been
     type checked. *)
  let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
  { 
    brs = List.map (compile_branch env tail) used;
    brs_tail = tail;
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

and compile_branch env tail br =
  let env = 
    List.fold_left 
      (fun env x ->
         { env with 
             vars = Env.add x (Stack env.stack_size) env.vars;
             stack_size = env.stack_size + 1 }

      ) env (Patterns.fv br.Typed.br_pat) in
  (br.Typed.br_pat, compile env tail br.Typed.br_body)


let enter_globals env n = 
  match env.cu with
    | None ->
        let env = 
          List.fold_left
            (fun env x ->
               { env with
                   vars = Env.add x (Global env.stack_size) env.vars;
                   stack_size = env.stack_size + 1 })
            env n in
        (env,[])
    | Some cu ->
        List.fold_left
        (fun (env,code) x ->
         let code = SetGlobal (cu, env.global_size) :: code in
         let env = 
           { env with
               vars = Env.add x (Ext (cu, env.global_size)) env.vars;
               global_size = env.global_size + 1 } in
         (env,code)
        )
        (env,[])
        n

let compile_expr env = compile env false

let compile_eval env e = [ Push (compile_expr env e); Pop ]

let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
  let e = compile_expr env decl.Typed.let_body in
  let (env,code) = enter_globals env (Patterns.fv pat) in
  (env, (Push e) :: (Split pat) :: code)

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 env = function
    | { Typed.exp_descr=Typed.Abstraction a } -> 
        Push (compile_abstr env a)
    | _ -> assert false in
  let names = List.map fun_name funs in
  let (env,code) = enter_globals env names in
  let exprs = List.map (fun_a env) funs in
  (env, exprs @ code)


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

open Location

let eval ~run ~show (tenv,cenv,codes) e =
  let (e,t) = Typer.type_expr tenv e in
  let expr = compile_expr cenv e in
  if run then
    let v = Eval.expr expr in
    show None t (Some v)
  else
    show None t None;
  (tenv,cenv, Pop :: Push expr ::codes)

let run_show ~run ~show tenv cenv codes ids =
  if run then
    let () = Eval.code_items codes in
    List.iter 
      (fun (id,_) -> show (Some id) 
         (Typer.find_value id tenv)
         (Some (Eval.var (find id cenv)))) ids
  else
    List.iter 
      (fun (id,_) -> show (Some id) 
         (Typer.find_value id tenv)
         None) ids
  
let let_decl ~run ~show (tenv,cenv,codes) p e =
  let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
  let (cenv,code) = compile_let_decl cenv decl in
  run_show ~run ~show tenv cenv code ids;
  (tenv,cenv,List.rev_append code codes)
  
let let_funs ~run ~show (tenv,cenv,codes) funs =
  let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
  let (cenv,code) = compile_rec_funs cenv funs in
  run_show ~run ~show tenv cenv code ids;
  (tenv,cenv,List.rev_append code codes)
  
let type_defs (tenv,cenv,codes) typs =
  let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
  (tenv,cenv,codes)

let namespace (tenv,cenv,codes) pr ns =
  let tenv = Typer.enter_ns pr ns tenv in
  (tenv,cenv,codes)

let find_cu (tenv,_,_) cu =
  Typer.find_cu cu tenv

let using (tenv,cenv,codes) x cu =
  let tenv = Typer.enter_cu x cu tenv in
  (tenv,cenv,codes)

let rec collect_funs accu = function
  | { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
  | rest -> (accu,rest)

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

let rec phrases ~run ~show ~loading ~directive =
  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
      | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
          Typer.register_schema name schema;
          loop accu rest
      | { descr = Ast.Namespace (pr,ns) } :: rest ->
          loop (namespace accu pr ns) rest
      | { descr = Ast.Using (x,cu) } :: rest ->
          let cu = find_cu accu cu in
          loading cu;
          loop (using accu x cu) rest
      | { 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 _ _ _ -> ()) 
  ?(loading=fun _ -> ())
  ?(directive=fun _ _ _ -> ())  tenv cenv phs =
  let (tenv,cenv,codes) = phrases ~run ~show ~loading ~directive (tenv,cenv,[]) phs in
  (tenv,cenv,List.rev codes)
1	open Ident
2	open Lambda
3
4	type env = {
5	cu: Types.CompUnit.t option; (* None: toplevel *)
6	vars: var_loc Env.t;
7	stack_size: int;
8	global_size: int
9	}
10
11	let global_size env = env.global_size
12
13	let dump ppf env =
14	Env.iter
15	(fun id loc ->
16	Format.fprintf ppf "Var %a : %a@\n" U.print (Id.value id) Lambda.print_var_loc loc)
17	env.vars
18
19
20	let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
21	let empty_toplevel = mk None
22	let empty x = mk (Some x)
23
24
25	let serialize s env =
26	assert (env.stack_size = 0);
27	(match env.cu with
28	\| Some cu -> Types.CompUnit.serialize s cu
29	\| None -> assert false);
30	Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
31	Serialize.Put.int s env.global_size
32
33	let deserialize s =
34	let cu = Types.CompUnit.deserialize s in
35	let vars =
36	Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
37	let size = Serialize.Get.int s in
38	{ cu = Some cu; vars = vars; stack_size = 0; global_size = size }
39
40
41	let find x env =
42	try Env.find x env.vars
43	with Not_found ->
44	failwith ("Compile: cannot find " ^ (Ident.to_string x))
45
46	let from_comp_unit = ref (fun cu -> assert false)
47
48	let find_ext cu x =
49	let env = !from_comp_unit cu in
50	find x env
51
52
53	let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
54	and compile_aux env tail = function
55	\| Typed.Forget (e,_) -> compile env tail e
56	\| Typed.Var x -> Var (find x env)
57	\| Typed.ExtVar (cu,x) -> Var (find_ext cu x)
58	\| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
59	\| Typed.Abstraction a -> compile_abstr env a
60	\| Typed.Cst c -> Const c
61	\| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
62	\| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
63	Xml (compile env false e1, compile env false e2, compile env tail e3)
64	\| Typed.Xml (_,_) -> assert false
65	\| Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
66	\| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
67	\| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
68	\| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
69	\| Typed.Transform (e,brs) -> Transform
70	(compile env false e, compile_branches env false brs)
71	\| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
72	\| Typed.Validate (e,k,sch,t) -> Validate (compile env tail e, k, sch, t)
73	\| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
74	\| Typed.Dot (e,l) -> Dot (compile env tail e, l)
75	\| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
76	\| Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
77	\| Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
78	\| Typed.Ref (e,t) -> Ref (compile env tail e, t)
79
80	and compile_abstr env a =
81	let fun_env =
82	match a.Typed.fun_name with
83	\| Some x -> Env.add x (Env 0) Env.empty
84	\| None -> Env.empty in
85
86	let (slots,nb_slots,fun_env) =
87	List.fold_left
88	(fun (slots,nb_slots,fun_env) x ->
89	match find x env with
90	\| (Stack _ \| Env _) as p ->
91	p::slots,
92	succ nb_slots,
93	Env.add x (Env nb_slots) fun_env;
94	\| Global _ \| Ext _ as p ->
95	slots,
96	nb_slots,
97	Env.add x p fun_env
98	\| Dummy -> assert false
99	)
100	([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
101
102
103	let slots = Array.of_list (List.rev slots) in
104	let env = { env with vars = fun_env; stack_size = 0 } in
105	let body = compile_branches env true a.Typed.fun_body in
106	Abstraction (slots, a.Typed.fun_iface, body)
107
108	and compile_branches env tail (brs : Typed.branches) =
109	(* Don't compile unused branches, because they have not been
110	type checked. *)
111	let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
112	{
113	brs = List.map (compile_branch env tail) used;
114	brs_tail = tail;
115	brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
116	brs_input = brs.Typed.br_typ;
117	brs_compiled = None
118	}
119
120	and compile_branch env tail br =
121	let env =
122	List.fold_left
123	(fun env x ->
124	{ env with
125	vars = Env.add x (Stack env.stack_size) env.vars;
126	stack_size = env.stack_size + 1 }
127
128	) env (Patterns.fv br.Typed.br_pat) in
129	(br.Typed.br_pat, compile env tail br.Typed.br_body)
130
131
132	let enter_globals env n =
133	match env.cu with
134	\| None ->
135	let env =
136	List.fold_left
137	(fun env x ->
138	{ env with
139	vars = Env.add x (Global env.stack_size) env.vars;
140	stack_size = env.stack_size + 1 })
141	env n in
142	(env,[])
143	\| Some cu ->
144	List.fold_left
145	(fun (env,code) x ->
146	let code = SetGlobal (cu, env.global_size) :: code in
147	let env =
148	{ env with
149	vars = Env.add x (Ext (cu, env.global_size)) env.vars;
150	global_size = env.global_size + 1 } in
151	(env,code)
152	)
153	(env,[])
154	n
155
156	let compile_expr env = compile env false
157
158	let compile_eval env e = [ Push (compile_expr env e); Pop ]
159
160	let compile_let_decl env decl =
161	let pat = decl.Typed.let_pat in
162	let e = compile_expr env decl.Typed.let_body in
163	let (env,code) = enter_globals env (Patterns.fv pat) in
164	(env, (Push e) :: (Split pat) :: code)
165
166	let compile_rec_funs env funs =
167	let fun_name = function
168	\| { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
169	\| _ -> assert false in
170	let fun_a env = function
171	\| { Typed.exp_descr=Typed.Abstraction a } ->
172	Push (compile_abstr env a)
173	\| _ -> assert false in
174	let names = List.map fun_name funs in
175	let (env,code) = enter_globals env names in
176	let exprs = List.map (fun_a env) funs in
177	(env, exprs @ code)
178
179
180	(****************************************)
181
182	open Location
183
184	let eval ~run ~show (tenv,cenv,codes) e =
185	let (e,t) = Typer.type_expr tenv e in
186	let expr = compile_expr cenv e in
187	if run then
188	let v = Eval.expr expr in
189	show None t (Some v)
190	else
191	show None t None;
192	(tenv,cenv, Pop :: Push expr ::codes)
193
194	let run_show ~run ~show tenv cenv codes ids =
195	if run then
196	let () = Eval.code_items codes in
197	List.iter
198	(fun (id,_) -> show (Some id)
199	(Typer.find_value id tenv)
200	(Some (Eval.var (find id cenv)))) ids
201	else
202	List.iter
203	(fun (id,_) -> show (Some id)
204	(Typer.find_value id tenv)
205	None) ids
206
207	let let_decl ~run ~show (tenv,cenv,codes) p e =
208	let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
209	let (cenv,code) = compile_let_decl cenv decl in
210	run_show ~run ~show tenv cenv code ids;
211	(tenv,cenv,List.rev_append code codes)
212
213	let let_funs ~run ~show (tenv,cenv,codes) funs =
214	let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
215	let (cenv,code) = compile_rec_funs cenv funs in
216	run_show ~run ~show tenv cenv code ids;
217	(tenv,cenv,List.rev_append code codes)
218
219	let type_defs (tenv,cenv,codes) typs =
220	let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
221	(tenv,cenv,codes)
222
223	let namespace (tenv,cenv,codes) pr ns =
224	let tenv = Typer.enter_ns pr ns tenv in
225	(tenv,cenv,codes)
226
227	let find_cu (tenv,_,_) cu =
228	Typer.find_cu cu tenv
229
230	let using (tenv,cenv,codes) x cu =
231	let tenv = Typer.enter_cu x cu tenv in
232	(tenv,cenv,codes)
233
234	let rec collect_funs accu = function
235	\| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
236	\| rest -> (accu,rest)
237
238	let rec collect_types accu = function
239	\| { descr = Ast.TypeDecl (x,t) } :: rest ->
240	collect_types ((x,t) :: accu) rest
241	\| rest -> (accu,rest)
242
243	let rec phrases ~run ~show ~loading ~directive =
244	let rec loop accu phs =
245	match phs with
246	\| { descr = Ast.FunDecl _ } :: _ ->
247	let (funs,rest) = collect_funs [] phs in
248	loop (let_funs ~run ~show accu funs) rest
249	\| { descr = Ast.TypeDecl (_,_) } :: _ ->
250	let (typs,rest) = collect_types [] phs in
251	loop (type_defs accu typs) rest
252	\| { descr = Ast.SchemaDecl (name, schema) } :: rest ->
253	Typer.register_schema name schema;
254	loop accu rest
255	\| { descr = Ast.Namespace (pr,ns) } :: rest ->
256	loop (namespace accu pr ns) rest
257	\| { descr = Ast.Using (x,cu) } :: rest ->
258	let cu = find_cu accu cu in
259	loading cu;
260	loop (using accu x cu) rest
261	\| { descr = Ast.EvalStatement e } :: rest ->
262	loop (eval ~run ~show accu e) rest
263	\| { descr = Ast.LetDecl (p,e) } :: rest ->
264	loop (let_decl ~run ~show accu p e) rest
265	\| { descr = Ast.Directive d } :: rest ->
266	let (tenv,cenv,_) = accu in
267	directive tenv cenv d;
268	loop accu rest
269	\| [] ->
270	accu
271	in
272	loop
273
274	let comp_unit ?(run=false)
275	?(show=fun _ _ _ -> ())
276	?(loading=fun _ -> ())
277	?(directive=fun _ _ _ -> ()) tenv cenv phs =
278	let (tenv,cenv,codes) = phrases ~run ~show ~loading ~directive (tenv,cenv,[]) phs in
279	(tenv,cenv,List.rev codes)