compile.ml 9.48 KB
Newer Older
1 2 3 4
open Ident
open Lambda

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

11 12
let global_size env = env.global_size

13 14 15
let dump ppf env =
  Env.iter 
    (fun id loc ->
16 17 18
       Format.fprintf ppf "Var %a : %a@\n" 
	 Ident.print id 
	 Lambda.print_var_loc loc)
19 20 21
    env.vars


22 23 24
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)
25

26

27
let serialize s env =
28 29 30 31
  assert (env.stack_size = 0);
  (match env.cu with
    | Some cu -> Types.CompUnit.serialize s cu
    | None -> assert false);
32
  Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
33
  Serialize.Put.int s env.global_size
34 35

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


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

48 49
let find_slot x env =
  match find x env with
50
    | Ext (_,slot) -> slot
51 52 53
    | _ -> assert false
 

54 55 56 57
let from_comp_unit = ref (fun cu -> assert false)

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

60

61 62 63
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
64
  | Typed.Check (t0,e,t) -> Check (!t0, compile env false e, t)
65
  | Typed.Var x -> Var (find x env)
66
  | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
67
  | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
68 69
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
70
  | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
71
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) -> 
72
      Xml (compile env false e1, compile env false e2, compile env tail e3)
73 74 75
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) -> 
      XmlNs (compile env false e1, compile env false e2, compile env tail e3,t)
  | Typed.Xml _ -> assert false
76 77 78 79
  | Typed.RecordLitt r -> 
      let r = List.map (fun (l,e) -> (l, compile env false e)) (LabelMap.get r)
      in
      Record (Imap.create (Array.of_list r))
80 81 82 83 84 85
  | 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)
86
  | Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
87 88 89 90
  | 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.Ref (e,t) ->  Ref (compile env tail e, t)
91
  | Typed.External (t,`Ext i) -> 
92
      (match env.cu with
93
	 | Some cu -> Var (External (cu,i))
94
	 | None -> failwith "Cannot compile externals in the toplevel")
95 96
  | Typed.External (t,`Builtin s) -> 
      Var (Builtin s)
97
  | Typed.Op (op,_,args) -> 
98 99 100 101 102
      let rec aux = function
	| [arg] -> [ compile env tail arg ]
	| arg::l -> (compile env false arg) :: (aux l)
	| [] -> [] in
      Op (op, aux args)
103 104
  | Typed.NsTable (ns,e) ->
      NsTable (ns, compile_aux env tail e)
105 106

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

112 113 114
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
115
	 match find x env with
116 117 118 119
	   | (Stack _ | Env _) as p -> 
	       p::slots,
	       succ nb_slots,
	       Env.add x (Env nb_slots) fun_env;
120
	   | Global _ | Ext _ | External _ | Builtin _ as p -> 
121 122 123 124 125
	       slots,
	       nb_slots,
	       Env.add x p fun_env
	   | Dummy -> assert false
      )
126
      ([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
127 128 129


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

134
and compile_branches env tail (brs : Typed.branches) =
135 136 137
  (* 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
138
  { 
139
    brs = List.map (compile_branch env tail) used;
140 141
    brs_tail = tail;
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
142
    brs_input = brs.Typed.br_typ;
143
    brs_compiled = None;
144 145
  }

146
and compile_branch env tail br =
147 148 149
  let env = 
    List.fold_left 
      (fun env x ->
150 151 152
	 { env with 
	     vars = Env.add x (Stack env.stack_size) env.vars;
	     stack_size = env.stack_size + 1 }
153

154
      ) env (Patterns.fv br.Typed.br_pat) in
155 156 157
  (br.Typed.br_pat, compile env tail br.Typed.br_body)


158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
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 ]
185

186 187
let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
188
  let e = compile_expr env decl.Typed.let_body in
189
  let (env,code) = enter_globals env (Patterns.fv pat) in
190
  (env, (Push e) :: (Split pat) :: code)
191 192 193 194 195

let compile_rec_funs env funs =
  let fun_name = function
    | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
    | _ -> assert false in
196 197 198
  let fun_a env = function
    | { Typed.exp_descr=Typed.Abstraction a } -> 
	Push (compile_abstr env a)
199 200
    | _ -> assert false in
  let names = List.map fun_name funs in
201 202 203
  let (env,code) = enter_globals env names in
  let exprs = List.map (fun_a env) funs in
  (env, exprs @ code)
204 205 206 207 208 209


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

open Location

210 211
let eval ~run ~show (tenv,cenv,codes) e =
  let (e,t) = Typer.type_expr tenv e in
212
  let expr = compile_expr cenv e in
213
  if run then
214
    let v = Eval.expr expr in
215 216 217
    show None t (Some v)
  else
    show None t None;
218
  (tenv,cenv, Pop :: Push expr ::codes)
219

220
let run_show ~run ~show tenv cenv codes ids =
221
  if run then
222
    let () = Eval.code_items codes in
223 224 225 226 227 228 229 230 231
    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
232
  
233 234
let let_decl ~run ~show (tenv,cenv,codes) p e =
  let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
235
  let (cenv,code) = compile_let_decl cenv decl in
236
  run_show ~run ~show tenv cenv code ids;
237
  (tenv,cenv,List.rev_append code codes)
238
  
239 240
let let_funs ~run ~show (tenv,cenv,codes) funs =
  let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
241
  let (cenv,code) = compile_rec_funs cenv funs in
242
  run_show ~run ~show tenv cenv code ids;
243
  (tenv,cenv,List.rev_append code codes)
244 245
  
let type_defs (tenv,cenv,codes) typs =
246
  let tenv = Typer.type_defs tenv typs in
247 248 249
  (tenv,cenv,codes)

let namespace (tenv,cenv,codes) pr ns =
250
  let tenv = Typer.type_ns tenv pr ns in
251 252
  (tenv,cenv,codes)

253 254 255 256
let keep_ns (tenv,cenv,codes) k =
  let tenv = Typer.type_keep_ns tenv k in
  (tenv,cenv,codes)

257
let schema (tenv,cenv,codes) x sch =
258
  let tenv = Typer.type_schema tenv x sch in
259 260
  (tenv,cenv,codes)

261 262 263
let find_cu (tenv,_,_) cu =
  Typer.find_cu cu tenv

264 265 266 267
let using (tenv,cenv,codes) x cu =
  let tenv = Typer.enter_cu x cu tenv in
  (tenv,cenv,codes)

268 269 270 271 272
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
273 274
  | { descr = Ast.TypeDecl ((loc,x),t) } :: rest -> 
      collect_types ((loc,x,t) :: accu) rest
275 276
  | rest -> (accu,rest)

277 278 279 280 281 282 283 284 285
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
286 287
      | { descr = Ast.SchemaDecl (name, uri) } :: rest ->
	  loop (schema accu name uri) rest
288 289
      | { descr = Ast.Namespace (pr,ns) } :: rest ->
	  loop (namespace accu pr ns) rest
290 291
      | { descr = Ast.KeepNs b } :: rest ->
	  loop (keep_ns accu b) rest
292
      | { descr = Ast.Using (x,cu) } :: rest ->
293
	  let cu = find_cu accu cu in
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
	  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
314
  (tenv,cenv,List.rev codes)