compile.ml 2.17 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
open Ident
open Lambda

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

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

let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
  | Typed.Forget (e,_) -> compile env e
  | Typed.Var x -> Var (Env.find x env.vars)
  | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
  | Typed.Abstraction a -> compile_abstr env a
  | Typed.Cst c -> Const c
  | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
      let env' = env in
      Xml (compile env e1, compile env' e2, compile env' e3)
  | Typed.Xml (_,_) -> assert false
  | Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
  | Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
  | Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
  | _ -> assert false



and compile_abstr env a =
  let (slots,nb_slots,fun_env) = 
    List.fold_left 
      (fun (slots,nb_slots,fun_env) x ->
	 match Env.find x env.vars 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
      )
      ([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in


  let recurs,fun_env,slots = match a.Typed.fun_name with
    | Some x when IdSet.mem a.Typed.fun_fv x -> 
	true, Env.add x (Env 0) fun_env, Dummy::slots
    | _ -> false, fun_env, slots in
  let slots = Array.of_list (List.rev slots) in  
  let env = { vars = fun_env; stack_size = 0 } in
  let body = compile_branches env a.Typed.fun_body in
  Abstraction (recurs, slots, a.Typed.fun_iface, body)

and compile_branches env (brs : Typed.branches) =
  { 
    brs = List.map (compile_branch env) brs.Typed.br_branches;
    brs_input = brs.Typed.br_typ;
    brs_compiled = None
  }

and compile_branch env 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 (IdSet.get (Patterns.fv br.Typed.br_pat)) in
  (br.Typed.br_pat, compile env br.Typed.br_body)