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

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

9 10 11 12 13 14 15
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


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

18 19 20 21 22 23 24 25 26 27 28 29 30
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 }




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

36 37 38 39 40
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
41
    | Ext(_,_) as v -> Var v
42 43
    | _ -> assert false

44 45 46 47
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)
48
  | Typed.ExtVar (cu,x) -> find_ext cu x
49
  | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
50 51
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
52
  | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
53
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
54
      Xml (compile env false e1, compile env false e2, compile env tail e3)
55
  | Typed.Xml (_,_) -> assert false
56 57 58 59 60 61 62
  | 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)
63
  | Typed.Validate (e,k,sch,t) -> Validate (compile env tail e, k, sch, t)
64 65 66 67 68 69
  | 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)
70 71

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

77 78 79
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
80
	 match find x env with
81 82 83 84
	   | (Stack _ | Env _) as p -> 
	       p::slots,
	       succ nb_slots,
	       Env.add x (Env nb_slots) fun_env;
85
	   | Global _ | Ext _ as p -> 
86 87 88 89 90
	       slots,
	       nb_slots,
	       Env.add x p fun_env
	   | Dummy -> assert false
      )
91
      ([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
92 93 94 95


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

99
and compile_branches env tail (brs : Typed.branches) =
100 101 102
  (* 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
103
  { 
104
    brs = List.map (compile_branch env tail) used;
105 106
    brs_tail = tail;
    brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
107 108 109 110
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

111
and compile_branch env tail br =
112 113 114 115 116
  let env = 
    List.fold_left 
      (fun env x ->
	 { vars = Env.add x (Stack env.stack_size) env.vars;
	   stack_size = env.stack_size + 1 }
117

118
      ) env (Patterns.fv_list br.Typed.br_pat) in
119 120 121 122 123 124 125 126 127
  (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

128 129
let compile_eval env e = Eval (compile env false e)

130 131
let compile_let_decl env decl =
  let pat = decl.Typed.let_pat in
132 133 134
  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)
135 136 137 138 139 140 141 142 143 144 145 146


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
147 148 149 150 151 152 153
  (env, Let_funs exprs)


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

open Location

154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
let eval ~run ~show (tenv,cenv,codes) e =
  let (e,t) = Typer.type_expr tenv e in
  let code = compile_eval cenv e in
  if run then
    let v = Eval.expr code in
    show None t (Some v)
  else
    show None t None;
  (tenv,cenv,code::codes)

let run_show ~run ~show tenv cenv code ids =
  if run then
    let () = Eval.eval code 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
176
  
177 178
let let_decl ~run ~show (tenv,cenv,codes) p e =
  let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
179
  let (cenv,code) = compile_let_decl cenv decl in
180 181
  run_show ~run ~show tenv cenv code ids;
  (tenv,cenv,code::codes)
182
  
183 184
let let_funs ~run ~show (tenv,cenv,codes) funs =
  let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
185
  let (cenv,code) = compile_rec_funs cenv funs in
186 187
  run_show ~run ~show tenv cenv code ids;
  (tenv,cenv,code::codes)
188 189 190 191 192 193 194 195 196
  
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)

197 198 199
let find_cu (tenv,_,_) cu =
  Typer.find_cu cu tenv

200 201 202 203
let using (tenv,cenv,codes) x cu =
  let tenv = Typer.enter_cu x cu tenv in
  (tenv,cenv,codes)

204 205 206 207 208 209 210 211 212
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)

213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
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 ->
228
	  let cu = find_cu accu cu in
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
	  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
249
  (tenv,cenv,List.rev codes)