/[svn]/compile/compile.ml
ViewVC logotype

Diff of /compile/compile.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1495 by abate, Tue Jul 10 18:55:50 2007 UTC revision 1753 by abate, Tue Jul 10 19:20:18 2007 UTC
# Line 2  Line 2 
2  open Lambda  open Lambda
3    
4  type env = {  type env = {
5    cu: Types.CompUnit.t option;  (* None: toplevel *)    cu: Compunit.t option;  (* None: toplevel *)
6    vars: var_loc Env.t;    vars: var_loc Env.t;
7    stack_size: int;    stack_size: int;
8      max_stack: int ref;
9    global_size: int    global_size: int
10  }  }
11    
12  let global_size env = env.global_size  let global_size env = env.global_size
13    
14  let dump ppf env =  let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; max_stack = ref 0; global_size = 0 }
   Env.iter  
     (fun id loc ->  
        Format.fprintf ppf "Var %a : %a@\n"  
          Ident.print id  
          Lambda.print_var_loc loc)  
     env.vars  
   
   
 let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }  
15  let empty_toplevel = mk None  let empty_toplevel = mk None
16  let empty x = mk (Some x)  let empty x = mk (Some x)
17    
   
 let serialize s env =  
   assert (env.stack_size = 0);  
   (match env.cu with  
     | Some cu -> Types.CompUnit.serialize s cu  
     | None -> assert false);  
   Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;  
   Serialize.Put.int s env.global_size  
   
 let deserialize s =  
   let cu = Types.CompUnit.deserialize s in  
   let vars =  
     Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in  
   let size = Serialize.Get.int s in  
   { cu = Some cu; vars = vars; stack_size = 0; global_size = size }  
   
   
18  let find x env =  let find x env =
19    try Env.find x env.vars    try Env.find x env.vars
20    with Not_found ->    with Not_found ->
# Line 50  Line 25 
25      | Ext (_,slot) -> slot      | Ext (_,slot) -> slot
26      | _ -> assert false      | _ -> assert false
27    
   
28  let from_comp_unit = ref (fun cu -> assert false)  let from_comp_unit = ref (fun cu -> assert false)
29    
30  let find_ext cu x =  let find_ext cu x =
31    let env = !from_comp_unit cu in    let env = !from_comp_unit cu in
32    find x env    find x env
33    
34    let enter_local env x =
35      let new_size = env.stack_size + 1 in
36      if new_size > !(env.max_stack) then (env.max_stack) := new_size;
37      { env with
38          vars = Env.add x (Local env.stack_size) env.vars;
39          stack_size = new_size }
40    
41    let enter_global_toplevel env x =
42      { env with
43          vars = Env.add x (Global env.global_size) env.vars;
44          global_size = env.global_size + 1 }
45    
46  let rec compile env tail e = compile_aux env tail e.Typed.exp_descr  let enter_global_cu cu env x =
47  and compile_aux env tail = function    { env with
48    | Typed.Forget (e,_) -> compile env tail e        vars = Env.add x (Ext (cu,env.global_size)) env.vars;
49    | Typed.Check (t0,e,t) -> Check (!t0, compile env false e, t)        global_size = env.global_size + 1 }
50    
51    let rec compile env e = compile_aux env e.Typed.exp_descr
52    and compile_aux env = function
53      | Typed.Forget (e,_) -> compile env e
54      | Typed.Check (t0,e,t) ->
55          let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
56          Check (compile env e, d)
57    | Typed.Var x -> Var (find x env)    | Typed.Var x -> Var (find x env)
58    | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)    | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
59    | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)    | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
60    | Typed.Abstraction a -> compile_abstr env a    | Typed.Abstraction a -> compile_abstr env a
61    | Typed.Cst c -> Const c    | Typed.Cst c -> Const (Value.const c)
62    | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)    | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
63    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) ->
64        Xml (compile env false e1, compile env false e2, compile env tail e3)        Xml (compile env e1, compile env e2, compile env e3)
65    | Typed.Xml (_,_) -> assert false    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) ->
66    | Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)        XmlNs (compile env e1, compile env e2, compile env e3,t)
67    | Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)    | Typed.Xml _ -> assert false
68    | Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)    | Typed.RecordLitt r ->
69    | Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)        let r = List.map (fun (l,e) -> (Upool.int l, compile env e))
70    | Typed.Transform (e,brs) -> Transform          (LabelMap.get r)
71        (compile env false e, compile_branches env false brs)        in
72    | Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)        Record (Imap.create (Array.of_list r))
73    | Typed.Validate (e,k,sch,t) -> Validate (compile env tail e, k, sch, t)    | Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
74    | Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)    | Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
75    | Typed.Dot (e,l) -> Dot (compile env tail e, l)    | Typed.Map (e,brs) -> Map (compile env e, compile_branches env brs)
76    | Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)    | Typed.Transform (e,brs) -> Transform (compile env e, compile_branches env brs)
77    | Typed.Ref (e,t) ->  Ref (compile env tail e, t)    | Typed.Xtrans (e,brs) -> Xtrans (compile env e, compile_branches env brs)
78    | Typed.External (t,i) ->    | Typed.Validate (e,_,validator) -> Validate (compile env e, validator)
79      | Typed.RemoveField (e,l) -> RemoveField (compile env e,l)
80      | Typed.Dot (e,l) -> Dot (compile env e, l)
81      | Typed.Try (e,brs) -> Try (compile env e, compile_branches env brs)
82      | Typed.Ref (e,t) ->  Ref (compile env e, t)
83      | Typed.External (t,`Ext i) ->
84        (match env.cu with        (match env.cu with
85           | Some cu -> Var (External (cu,i))           | Some cu -> Var (External (cu,i))
86           | None -> failwith "Cannot compile externals in the toplevel")           | None -> failwith "Cannot compile externals in the toplevel")
87      | Typed.External (t,`Builtin s) ->
88          Var (Builtin s)
89    | Typed.Op (op,_,args) ->    | Typed.Op (op,_,args) ->
90        let rec aux = function        let rec aux = function
91          | [arg] -> [ compile env tail arg ]          | [arg] -> [ compile env arg ]
92          | arg::l -> (compile env false arg) :: (aux l)          | arg::l -> (compile env arg) :: (aux l)
93          | [] -> [] in          | [] -> [] in
94        Op (op, aux args)        Op (op, aux args)
95    | Typed.NsTable (ns,e) ->    | Typed.NsTable (ns,e) ->
96        NsTable (ns, compile_aux env tail e)        NsTable (ns, compile_aux env e)
97    
98  and compile_abstr env a =  and compile_abstr env a =
99    let fun_env =    let fun_env =
# Line 106  Line 105 
105      List.fold_left      List.fold_left
106        (fun (slots,nb_slots,fun_env) x ->        (fun (slots,nb_slots,fun_env) x ->
107           match find x env with           match find x env with
108             | (Stack _ | Env _) as p ->             | (Local _ | Env _) as p ->
109                 p::slots,                 p::slots,
110                 succ nb_slots,                 succ nb_slots,
111                 Env.add x (Env nb_slots) fun_env;                 Env.add x (Env nb_slots) fun_env;
112             | Global _ | Ext _ | External _ as p ->             | Global _ | Ext _ | External _ | Builtin _ as p ->
113                 slots,                 slots,
114                 nb_slots,                 nb_slots,
115                 Env.add x p fun_env                 Env.add x p fun_env
# Line 120  Line 119 
119    
120    
121    let slots = Array.of_list (List.rev slots) in    let slots = Array.of_list (List.rev slots) in
122    let env = { env with vars = fun_env; stack_size = 0 } in    let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
123    let body = compile_branches env true a.Typed.fun_body in    let body = compile_branches env a.Typed.fun_body in
124    Abstraction (slots, a.Typed.fun_iface, body)    Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack))
125    
126  and compile_branches env tail (brs : Typed.branches) =  and compile_branches env (brs : Typed.branches) =
127    (* Don't compile unused branches, because they have not been    (* Don't compile unused branches, because they have not been
128       type checked. *)       type checked. *)
129    let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in    let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
130    {    let b = List.map (compile_branch env) used in
131      brs = List.map (compile_branch env tail) used;    let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
132      brs_tail = tail;    { brs_stack_pos = env.stack_size;
133      brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);      brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
134      brs_input = brs.Typed.br_typ;      brs_disp = disp;
135      brs_compiled = None; brs_compiled2 = None      brs_rhs = rhs }
   }  
   
 and compile_branch env tail br =  
   let env =  
     List.fold_left  
       (fun env x ->  
          { env with  
              vars = Env.add x (Stack env.stack_size) env.vars;  
              stack_size = env.stack_size + 1 }  
136    
137        ) env (Patterns.fv br.Typed.br_pat) in  and compile_branch env br =
138    (br.Typed.br_pat, compile env tail br.Typed.br_body)    let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
139      (br.Typed.br_pat, compile env br.Typed.br_body)
140    
141  let enter_globals env n =  let enter_globals env n =  match env.cu with
142    match env.cu with    | None -> List.fold_left enter_global_toplevel env n
143      | None ->    | Some cu -> List.fold_left (enter_global_cu cu) env n
144          let env =  
145            List.fold_left  let compile_expr env e =
146              (fun env x ->    let env = { env with max_stack = ref 0; stack_size = 0 } in
147                 { env with    let e = compile env e in
148                     vars = Env.add x (Global env.stack_size) env.vars;    (e,!(env.max_stack))
                    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 ]  
149    
150  let compile_let_decl env decl =  let compile_let_decl env decl =
151    let pat = decl.Typed.let_pat in    let pat = decl.Typed.let_pat in
152    let e = compile_expr env decl.Typed.let_body in    let e,lsize = compile_expr env decl.Typed.let_body in
153    let (env,code) = enter_globals env (Patterns.fv pat) in    let env = enter_globals env (Patterns.fv pat) in
154    (env, (Push e) :: (Split pat) :: code)  
155      let comp =
156        Patterns.Compile.make_branches
157          (Types.descr (Patterns.accept pat)) [ pat, () ] in
158      let (disp, n) =
159        match comp with
160          | (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
161          | _ -> assert false in
162      (env, [ LetDecls (e,lsize,disp,n) ])
163    
164  let compile_rec_funs env funs =  let compile_rec_funs env funs =
165    let fun_name = function    let fun_name = function
166      | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x      | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
167      | _ -> assert false in      | _ -> assert false in
168    let fun_a env = function    let fun_a env e =
169      | { Typed.exp_descr=Typed.Abstraction a } ->      let e,lsize = compile_expr env e in
170          Push (compile_abstr env a)      LetDecl (e,lsize) in
171      | _ -> assert false in    let env = enter_globals env (List.map fun_name funs) in
172    let names = List.map fun_name funs in    let code= List.map (fun_a env) funs in
173    let (env,code) = enter_globals env names in    (env, code)
   let exprs = List.map (fun_a env) funs in  
   (env, exprs @ code)  
174    
175    
176  (****************************************)  (****************************************)
# Line 202  Line 179 
179    
180  let eval ~run ~show (tenv,cenv,codes) e =  let eval ~run ~show (tenv,cenv,codes) e =
181    let (e,t) = Typer.type_expr tenv e in    let (e,t) = Typer.type_expr tenv e in
182    let expr = compile_expr cenv e in    let e,lsize = compile_expr cenv e in
183    if run then    if run then
184      let v = Eval.expr expr in      let v = Eval.expr e lsize in
185      show None t (Some v)      show None t (Some v)
186    else    else
187      show None t None;      show None t None;
188    (tenv,cenv, Pop :: Push expr ::codes)    (tenv,cenv, Eval (e,lsize) :: codes)
189    
190  let run_show ~run ~show tenv cenv codes ids =  let run_show ~run ~show tenv cenv codes ids =
191    if run then    if run then
192      let () = Eval.code_items codes in      let () = Eval.eval_toplevel codes in
193      List.iter      List.iter
194        (fun (id,_) -> show (Some id)        (fun (id,_) -> show (Some id)
195           (Typer.find_value id tenv)           (Typer.find_value id tenv)
196           (Some (Eval.var (find id cenv)))) ids           (Some (Eval.eval_var (find id cenv)))) ids
197    else    else
198      List.iter      List.iter
199        (fun (id,_) -> show (Some id)        (fun (id,_) -> show (Some id)
# Line 236  Line 213 
213    (tenv,cenv,List.rev_append code codes)    (tenv,cenv,List.rev_append code codes)
214    
215  let type_defs (tenv,cenv,codes) typs =  let type_defs (tenv,cenv,codes) typs =
216    let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in    let tenv = Typer.type_defs tenv typs in
217    (tenv,cenv,codes)    (tenv,cenv,codes)
218    
219  let namespace (tenv,cenv,codes) pr ns =  let namespace (tenv,cenv,codes) loc pr ns =
220    let tenv = Typer.enter_ns pr ns tenv in    let tenv = Typer.type_ns tenv loc pr ns in
221    (tenv,cenv,codes)    (tenv,cenv,codes)
222    
223  let schema (tenv,cenv,codes) x sch prefix =  let keep_ns (tenv,cenv,codes) k =
224    let tenv = Typer.enter_schema ?prefix x sch tenv in    let tenv = Typer.type_keep_ns tenv k in
225    (tenv,cenv,codes)    (tenv,cenv,codes)
226    
227  let find_cu (tenv,_,_) cu =  let schema (tenv,cenv,codes) loc x sch =
228    Typer.find_cu cu tenv    let tenv = Typer.type_schema tenv loc x sch in
229      (tenv,cenv,codes)
230    
231  let using (tenv,cenv,codes) x cu =  let using (tenv,cenv,codes) loc x cu =
232    let tenv = Typer.enter_cu x cu tenv in    let tenv = Typer.type_using tenv loc x cu in
233    (tenv,cenv,codes)    (tenv,cenv,codes)
234    
235  let rec collect_funs accu = function  let rec collect_funs accu = function
# Line 263  Line 241 
241        collect_types ((loc,x,t) :: accu) rest        collect_types ((loc,x,t) :: accu) rest
242    | rest -> (accu,rest)    | rest -> (accu,rest)
243    
244  let rec phrases ~run ~show ~loading ~directive =  let rec phrases ~run ~show ~directive =
245    let rec loop accu phs =    let rec loop accu phs =
246      match phs with      match phs with
247        | { descr = Ast.FunDecl _ } :: _ ->        | { descr = Ast.FunDecl _ } :: _ ->
# Line 272  Line 250 
250        | { descr = Ast.TypeDecl (_,_) } :: _ ->        | { descr = Ast.TypeDecl (_,_) } :: _ ->
251            let (typs,rest) = collect_types [] phs in            let (typs,rest) = collect_types [] phs in
252            loop (type_defs accu typs) rest            loop (type_defs accu typs) rest
253        | { descr = Ast.SchemaDecl (name, uri, p) } :: rest ->        | { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
254            loop (schema accu name uri p) rest            loop (schema accu loc name uri) rest
255        | { descr = Ast.Namespace (pr,ns) } :: rest ->        | { descr = Ast.Namespace (pr,ns); loc = loc } :: rest ->
256            loop (namespace accu pr ns) rest            loop (namespace accu loc pr ns) rest
257        | { descr = Ast.Using (x,cu) } :: rest ->        | { descr = Ast.KeepNs b } :: rest ->
258            let cu = find_cu accu cu in            loop (keep_ns accu b) rest
259            loading cu;        | { descr = Ast.Using (x,cu); loc = loc } :: rest ->
260            loop (using accu x cu) rest            loop (using accu loc x cu) rest
261        | { descr = Ast.EvalStatement e } :: rest ->        | { descr = Ast.EvalStatement e } :: rest ->
262            loop (eval ~run ~show accu e) rest            loop (eval ~run ~show accu e) rest
263        | { descr = Ast.LetDecl (p,e) } :: rest ->        | { descr = Ast.LetDecl (p,e) } :: rest ->
# Line 295  Line 273 
273    
274  let comp_unit ?(run=false)  let comp_unit ?(run=false)
275    ?(show=fun _ _ _ -> ())    ?(show=fun _ _ _ -> ())
   ?(loading=fun _ -> ())  
276    ?(directive=fun _ _ _ -> ())  tenv cenv phs =    ?(directive=fun _ _ _ -> ())  tenv cenv phs =
277    let (tenv,cenv,codes) = phrases ~run ~show ~loading ~directive (tenv,cenv,[]) phs in    let (tenv,cenv,codes) = phrases ~run ~show ~directive (tenv,cenv,[]) phs in
278    (tenv,cenv,List.rev codes)    (tenv,cenv,List.rev codes)
279    
280    
281    let compile_eval_expr env e =
282      let e,lsize = compile_expr env e in
283      Eval.expr e lsize
Legend:
Removed from v.1495  
changed lines
  Added in v.1753
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5