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)