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 serialize s env =
  Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
  Serialize.Put.int s env.stack_size    

let deserialize s =
  let vars = 
    Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
  let size = Serialize.Get.int s in
  { vars = vars; stack_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
  match find x env with
    | Global i -> ExtVar (cu,i)
    | _ -> assert false

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

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 _ 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 = { 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) =
  { 
    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);
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

and compile_branch env tail 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 (Patterns.fv_list br.Typed.br_pat) in
  (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_eval env e = Eval (compile env false e)

let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
  let code = Let_decl (pat, compile env false (decl.Typed.let_body)) in
  let env = enter_globals env (Patterns.fv_list pat) in
  (env, 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 = 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
  (env, Let_funs exprs)


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

open Location

let eval (tenv,cenv,codes) e =
  let (e,_) = Typer.type_expr tenv e in
  let code = compile_eval cenv e in 
  (tenv,cenv,code :: codes)
  
let let_decl (tenv,cenv,codes) p e =
  let (tenv,decl,_) = Typer.type_let_decl tenv p e in
  let (cenv,code) = compile_let_decl cenv decl in
  (tenv,cenv,code :: codes)
  
let let_funs (tenv,cenv,codes) funs =
  let (tenv,funs,_) = Typer.type_let_funs tenv funs in
  let (cenv,code) = compile_rec_funs cenv funs in
  (tenv,cenv,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 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 accu phs = match phs with
  | { descr = Ast.FunDecl _ } :: _ -> 
      let (funs,rest) = collect_funs [] phs in
      phrases (let_funs accu funs) rest
  | { descr = Ast.TypeDecl (_,_) } :: _ ->
      let (typs,rest) = collect_types [] phs in
      phrases (type_defs accu typs) rest
  | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
      Typer.register_schema name schema;
      phrases accu rest
  | { descr = Ast.Namespace (pr,ns) } :: rest ->
      phrases (namespace accu pr ns) rest
  | { descr = Ast.Using (x,cu) } :: rest ->
      phrases (using accu x cu) rest
  | { descr = Ast.EvalStatement e } :: rest ->
      phrases (eval accu e) rest
  | { descr = Ast.LetDecl (p,e) } :: rest ->
      phrases (let_decl accu p e) rest
  | { descr = Ast.Debug l } :: rest -> 
      phrases accu rest
  | { descr = Ast.Directive _ } :: rest ->
      phrases accu rest
  | [] -> accu

let comp_unit tenv cenv phs =
  let (tenv,cenv,codes) = phrases (tenv,cenv,[]) phs in
  (tenv,cenv,List.rev codes)
1	abate	691	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	abate	705	let serialize s env =
12			Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
13			Serialize.Put.int s env.stack_size
14
15			let deserialize s =
16			let vars =
17			Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
18			let size = Serialize.Get.int s in
19			{ vars = vars; stack_size = size }
20
21
22
23
24	abate	692	let find x env =
25			try Env.find x env.vars
26			with Not_found ->
27			failwith ("Compile: cannot find " ^ (Ident.to_string x))
28
29	abate	713	let from_comp_unit = ref (fun cu -> assert false)
30
31			let find_ext cu x =
32			let env = !from_comp_unit cu in
33			match find x env with
34			\| Global i -> ExtVar (cu,i)
35			\| _ -> assert false
36
37	abate	692	let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
38			and compile_aux env tail = function
39			\| Typed.Forget (e,_) -> compile env tail e
40			\| Typed.Var x -> Var (find x env)
41	abate	713	\| Typed.ExtVar (cu,x) -> find_ext cu x
42	abate	692	\| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
43	abate	691	\| Typed.Abstraction a -> compile_abstr env a
44			\| Typed.Cst c -> Const c
45	abate	692	\| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
46	abate	691	\| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
47	abate	692	Xml (compile env false e1, compile env false e2, compile env tail e3)
48	abate	691	\| Typed.Xml (_,_) -> assert false
49	abate	692	\| Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
50			\| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
51			\| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
52			\| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
53			\| Typed.Transform (e,brs) -> Transform
54			(compile env false e, compile_branches env false brs)
55			\| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
56			\| Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
57			\| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
58			\| Typed.Dot (e,l) -> Dot (compile env tail e, l)
59			\| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
60			\| Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
61			\| Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
62			\| Typed.Ref (e,t) -> Ref (compile env tail e, t)
63	abate	691
64	abate	692	and compile_abstr env a =
65			let fun_env =
66			match a.Typed.fun_name with
67			\| Some x -> Env.add x (Env 0) Env.empty
68			\| None -> Env.empty in
69	abate	691
70			let (slots,nb_slots,fun_env) =
71			List.fold_left
72			(fun (slots,nb_slots,fun_env) x ->
73	abate	692	match find x env with
74	abate	691	\| (Stack _ \| Env _) as p ->
75			p::slots,
76			succ nb_slots,
77			Env.add x (Env nb_slots) fun_env;
78			\| Global _ as p ->
79			slots,
80			nb_slots,
81			Env.add x p fun_env
82			\| Dummy -> assert false
83			)
84	abate	692	([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
85	abate	691
86
87			let slots = Array.of_list (List.rev slots) in
88			let env = { vars = fun_env; stack_size = 0 } in
89	abate	692	let body = compile_branches env true a.Typed.fun_body in
90			Abstraction (slots, a.Typed.fun_iface, body)
91	abate	691
92	abate	692	and compile_branches env tail (brs : Typed.branches) =
93	abate	691	{
94	abate	692	brs = List.map (compile_branch env tail) brs.Typed.br_branches;
95			brs_tail = tail;
96			brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
97	abate	691	brs_input = brs.Typed.br_typ;
98			brs_compiled = None
99			}
100
101	abate	692	and compile_branch env tail br =
102	abate	691	let env =
103			List.fold_left
104			(fun env x ->
105			{ vars = Env.add x (Stack env.stack_size) env.vars;
106			stack_size = env.stack_size + 1 }
107	abate	692
108	abate	698	) env (Patterns.fv_list br.Typed.br_pat) in
109	abate	692	(br.Typed.br_pat, compile env tail br.Typed.br_body)
110
111
112			let enter_global env x =
113			{ vars = Env.add x (Global env.stack_size) env.vars;
114			stack_size = env.stack_size + 1 }
115
116			let enter_globals = List.fold_left enter_global
117
118	abate	698	let compile_eval env e = Eval (compile env false e)
119
120	abate	692	let compile_let_decl env decl =
121			let pat = decl.Typed.let_pat in
122	abate	698	let code = Let_decl (pat, compile env false (decl.Typed.let_body)) in
123			let env = enter_globals env (Patterns.fv_list pat) in
124			(env, code)
125	abate	692
126
127			let compile_rec_funs env funs =
128			let fun_name = function
129			\| { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
130			\| _ -> assert false in
131			let fun_a = function
132			\| { Typed.exp_descr=Typed.Abstraction a } -> a
133			\| _ -> assert false in
134			let names = List.map fun_name funs in
135			let env = enter_globals env names in
136			let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
137	abate	698	(env, Let_funs exprs)
138
139
140			(****************************************)
141
142			open Location
143
144			let eval (tenv,cenv,codes) e =
145			let (e,_) = Typer.type_expr tenv e in
146			let code = compile_eval cenv e in
147			(tenv,cenv,code :: codes)
148
149			let let_decl (tenv,cenv,codes) p e =
150			let (tenv,decl,_) = Typer.type_let_decl tenv p e in
151			let (cenv,code) = compile_let_decl cenv decl in
152			(tenv,cenv,code :: codes)
153
154			let let_funs (tenv,cenv,codes) funs =
155			let (tenv,funs,_) = Typer.type_let_funs tenv funs in
156			let (cenv,code) = compile_rec_funs cenv funs in
157			(tenv,cenv,code :: codes)
158
159			let type_defs (tenv,cenv,codes) typs =
160			let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
161			(tenv,cenv,codes)
162
163			let namespace (tenv,cenv,codes) pr ns =
164			let tenv = Typer.enter_ns pr ns tenv in
165			(tenv,cenv,codes)
166
167	abate	713	let using (tenv,cenv,codes) x cu =
168			let tenv = Typer.enter_cu x cu tenv in
169			(tenv,cenv,codes)
170
171	abate	698	let rec collect_funs accu = function
172			\| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
173			\| rest -> (accu,rest)
174
175			let rec collect_types accu = function
176			\| { descr = Ast.TypeDecl (x,t) } :: rest ->
177			collect_types ((x,t) :: accu) rest
178			\| rest -> (accu,rest)
179
180			let rec phrases accu phs = match phs with
181			\| { descr = Ast.FunDecl _ } :: _ ->
182			let (funs,rest) = collect_funs [] phs in
183			phrases (let_funs accu funs) rest
184			\| { descr = Ast.TypeDecl (_,_) } :: _ ->
185			let (typs,rest) = collect_types [] phs in
186			phrases (type_defs accu typs) rest
187			\| { descr = Ast.SchemaDecl (name, schema) } :: rest ->
188			Typer.register_schema name schema;
189			phrases accu rest
190			\| { descr = Ast.Namespace (pr,ns) } :: rest ->
191			phrases (namespace accu pr ns) rest
192	abate	713	\| { descr = Ast.Using (x,cu) } :: rest ->
193			phrases (using accu x cu) rest
194	abate	698	\| { descr = Ast.EvalStatement e } :: rest ->
195			phrases (eval accu e) rest
196			\| { descr = Ast.LetDecl (p,e) } :: rest ->
197			phrases (let_decl accu p e) rest
198			\| { descr = Ast.Debug l } :: rest ->
199			phrases accu rest
200			\| { descr = Ast.Directive _ } :: rest ->
201			phrases accu rest
202			\| [] -> accu
203
204			let comp_unit tenv cenv phs =
205			let (tenv,cenv,codes) = phrases (tenv,cenv,[]) phs in
206			(tenv,cenv,List.rev codes)