[r2003-10-04 02:00:15 by cvscast] Compilation + serialization

Original author: cvscast
Date: 2003-10-04 02:01:37+00:00

Makefile.distrib

@@ -26,7 +26,7 @@ endif
 
 SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %)
 
-CAMLC_P = ocamlc
+CAMLC_P = ocamlc -g
 DEPEND_OCAMLDEP = misc/q_symbol.cmo
 ifeq ($(PROFILE), true)
 	CAMLOPT_P = ocamlopt -p
@@ -117,6 +117,9 @@ INCLUDES = $(DIRS:%=-I %)
 cduce: $(CDUCE:.cmo=.$(EXTENSION))
 	$(LINK) $(INCLUDES) -o $@ $^
 
+bug: $(OBJECTS) bug.cmo
+	$(LINK) $(INCLUDES) -o $@ $^
+
 webiface: $(WEBIFACE:.cmo=.$(EXTENSION))
 	$(LINK) $(INCLUDES) -o $@ $^ -ccopt -static
 # webiface is made static to be able to move it more easily

compile/compile.ml

@@ -83,7 +83,7 @@ and compile_branch env tail br =
 	 { 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
+      ) env (Patterns.fv_list br.Typed.br_pat) in
   (br.Typed.br_pat, compile env tail br.Typed.br_body)
 
 
@@ -93,12 +93,13 @@ let enter_global env x =
 
 let enter_globals = List.fold_left enter_global
 
+let compile_eval env e = Eval (compile env false e)
+
 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
-  (env, decl)
+  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)
 
 
 let compile_rec_funs env funs =
@@ -111,4 +112,67 @@ let compile_rec_funs env funs =
   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
-  (env, exprs)
+  (env, Let_funs exprs)
+
+
+(****************************************)
+
+open Location
+
+let eval (tenv,cenv,codes) e =
+  let (e,_) = Typer.type_expr tenv e in
+  let code = compile_eval cenv e in 
+  (tenv,cenv,code :: codes)
+  
+let let_decl (tenv,cenv,codes) p e =
+  let (tenv,decl,_) = Typer.type_let_decl tenv p e in
+  let (cenv,code) = compile_let_decl cenv decl in
+  (tenv,cenv,code :: codes)
+  
+let let_funs (tenv,cenv,codes) funs =
+  let (tenv,funs,_) = Typer.type_let_funs tenv funs in
+  let (cenv,code) = compile_rec_funs cenv funs in
+  (tenv,cenv,code :: codes)
+  
+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)
+
+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)
+
+let rec phrases accu phs = match phs with
+  | { descr = Ast.FunDecl _ } :: _ -> 
+      let (funs,rest) = collect_funs [] phs in
+      phrases (let_funs accu funs) rest
+  | { descr = Ast.TypeDecl (_,_) } :: _ ->
+      let (typs,rest) = collect_types [] phs in
+      phrases (type_defs accu typs) rest
+  | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
+      Typer.register_schema name schema;
+      phrases accu rest
+  | { descr = Ast.Namespace (pr,ns) } :: rest ->
+      phrases (namespace accu pr ns) rest
+  | { descr = Ast.EvalStatement e } :: rest ->
+      phrases (eval accu e) rest
+  | { descr = Ast.LetDecl (p,e) } :: rest ->
+      phrases (let_decl accu p e) rest
+  | { descr = Ast.Debug l } :: rest -> 
+      phrases accu rest
+  | { descr = Ast.Directive _ } :: rest ->
+      phrases accu rest
+  | [] -> accu
+
+let comp_unit tenv cenv phs =
+  let (tenv,cenv,codes) = phrases (tenv,cenv,[]) phs in
+  (tenv,cenv,List.rev codes)

compile/compile.mli

 open Ident 
+open Lambda
 
 type env
 val empty : env
 val enter_global : env -> id -> env
 val enter_globals : env -> id list -> env
-val find : id -> env -> Lambda.var_loc
+val find : id -> env -> var_loc
 
-val compile : env -> bool -> Typed.texpr -> Lambda.expr
+val compile_eval : env -> Typed.texpr -> code_item
+val compile_let_decl : env -> Typed.let_decl -> env * code_item
+val compile_rec_funs : env -> Typed.texpr list -> env * code_item
 
 
-val compile_let_decl : env -> Typed.let_decl -> env * Lambda.let_decl
-val compile_rec_funs : env -> Typed.texpr list -> env * Lambda.expr list
-
+val comp_unit: 
+  Typer.t -> env -> 
+  Ast.pmodule_item list -> Typer.t * env * Lambda.code_item list

compile/lambda.ml

@@ -38,14 +38,23 @@ and branches = {
     (Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
 }
 
-type let_decl = {
-  let_pat : Patterns.node;
-  let_expr : expr;
-}
+type code_item =
+  | Eval of expr
+  | Let_decl of Patterns.node * expr
+  | Let_funs of expr list
+
+let print_code_item ppf = function
+  | Eval _ -> Format.fprintf ppf "Eval@."
+  | Let_decl _ -> Format.fprintf ppf "Let_decl@."
+  | Let_funs _ -> Format.fprintf ppf "Let_funs@."
+
+type code = code_item list
 
 
 let nbits = 5
 
+let magic_compunit = "CDUCE:0.2:COMPUNIT"
+
 module Put = struct
   let unary_op = ref (fun _ _ -> assert false; ())
   let binary_op = ref (fun _ _ -> assert false; ())
@@ -119,7 +128,7 @@ module Put = struct
 	expr s e;
 	branches s brs
     | Validate (e,sch,t) ->
-	assert false (* Need to store a pointer to the schema ... *)
+	assert false (* TODO:Need to store a pointer to the schema ... *)
     | RemoveField (e,l) ->
 	bits nbits s 14;
 	expr s e;
@@ -147,7 +156,17 @@ module Put = struct
     bool s brs.brs_tail;
     Types.serialize s brs.brs_input;
     bool s brs.brs_accept_chars
-      
+
+  let code_item s = function
+    | Eval e -> bits 2 s 0; expr s e
+    | Let_decl (p,e) -> bits 2 s 1; Patterns.Node.serialize s p; expr s e
+    | Let_funs e -> bits 2 s 2; list expr s e
+
+  let codes = list code_item
+
+  let compunit s c =
+    magic s magic_compunit;
+    codes s c
 end
 	
 
@@ -247,4 +266,21 @@ module Get = struct
       brs_compiled = None
     }
 
+  let code_item s =
+    match bits 2 s with
+      | 0 -> Eval (expr s)
+      | 1 -> 
+	  let p = Patterns.Node.deserialize s in
+	  let e = expr s in
+	  Let_decl (p,e)
+      | 2 -> 
+	  Let_funs (list expr s)
+      | _ -> assert false
+
+  let codes = list code_item
+
+  let compunit s =
+    magic s magic_compunit;
+    codes s
+
 end      

depend

@@ -158,10 +158,12 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
     types/patterns.cmx runtime/run_dispatch.cmx schema/schema_validator.cmx \
     schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
     typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
-compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
-    typing/typed.cmo types/types.cmi compile/compile.cmi 
-compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
-    typing/typed.cmx types/types.cmx compile/compile.cmi 
+compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi types/ident.cmo \
+    compile/lambda.cmo parser/location.cmi types/patterns.cmi \
+    typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi 
+compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx types/ident.cmx \
+    compile/lambda.cmx parser/location.cmx types/patterns.cmx \
+    typing/typed.cmx typing/typer.cmx types/types.cmx compile/compile.cmi 
 compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
     parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
     runtime/value.cmi compile/operators.cmi 
@@ -231,7 +233,8 @@ runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
 runtime/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi 
 runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
     runtime/value.cmi 
-compile/compile.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo 
+compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
+    typing/typed.cmo typing/typer.cmi 
 compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
     typing/typer.cmi types/types.cmi runtime/value.cmi 
 types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi 

driver/cduce.ml

@@ -12,7 +12,7 @@ let do_compile = ref false
 
 let get_global_value v =
   if !do_compile 
-  then Eval.L.eval_var (Compile.find v !compile_env)
+  then Eval.L.var (Compile.find v !compile_env)
   else Eval.find_value v !eval_env
 
 let get_global_type v =
@@ -119,17 +119,15 @@ let display ppf l =
       l
 
 let eval ppf e =
-  let e = Typer.expr !typing_env e in
-  let t = Typer.type_check !typing_env e Types.any true in
-  Typer.report_unused_branches ();
+  let (e,t) = Typer.type_expr !typing_env e in
   
   if not !quiet then
     Location.dump_loc ppf (e.Typed.exp_loc,`Full);
 
   let v =   
     if !do_compile then
-      let e = Compile.compile !compile_env false e in 
-      Eval.L.eval e
+      let e = Compile.compile_eval !compile_env e in 
+      Eval.L.expr e
     else
       Eval.eval !eval_env e
   in
@@ -139,36 +137,32 @@ let eval ppf e =
   v
   
 let let_decl ppf p e =
-  let decl = Typer.let_decl !typing_env p e in
-  let typs = Typer.type_let_decl !typing_env decl in
-  Typer.report_unused_branches ();
+  let (tenv,decl,typs) = Typer.type_let_decl !typing_env p e in
   
   let () =
     if !do_compile then
       let (env,decl) = Compile.compile_let_decl !compile_env decl in
-      Eval.L.eval_let_decl decl;
+      Eval.L.eval decl;
       compile_env := env
     else
       eval_env := Eval.eval_let_decl !eval_env decl
   in
-  typing_env := Typer.enter_values typs !typing_env;
+  typing_env := tenv;
   display ppf typs
   
 
 let let_funs ppf funs =
-  let funs = List.map (Typer.expr !typing_env) funs in
-  let typs = Typer.type_rec_funs !typing_env funs in
-  Typer.report_unused_branches ();
+  let (tenv,funs,typs) = Typer.type_let_funs !typing_env funs in
   
   let () =
     if !do_compile then
       let (env,funs) = Compile.compile_rec_funs !compile_env funs in
-      Eval.L.eval_rec_funs funs;
+      Eval.L.eval funs;
       compile_env := env;
     else 
       eval_env := Eval.eval_rec_funs !eval_env funs 
   in
-  typing_env := Typer.enter_values typs !typing_env;
+  typing_env := tenv;
   display ppf typs
 
 
@@ -259,31 +253,78 @@ let rec phrases ppf phs = match phs with
       phrases ppf rest
   | [] -> ()
 
+let catch_exn ppf_err = function
+  | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) 
+      as e -> 
+      raise e
+  | exn -> 
+      print_exn ppf_err exn;
+      Format.fprintf ppf_err "@."
+
+let parse rule input =
+  try Some (rule input)
+  with
+      | Stdpp.Exc_located (_, (Location _ as e)) ->
+	  Parser.sync (); raise e
+      | Stdpp.Exc_located ((i,j), e) -> 
+	  Parser.sync (); raise_loc i j e
+
 let run rule ppf ppf_err input =
-  Typer.clear_unused_branches ();
-  try 
-    let p = 
-      try rule input
-      with
-	| Stdpp.Exc_located (_, (Location _ as e)) ->
-	    Parser.sync (); raise e
-	| Stdpp.Exc_located ((i,j), e) -> 
-	    Parser.sync (); raise_loc i j e
-    in
-    phrases ppf p;
-    true
-  with 
-    | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) 
-	as e -> 
-	raise e
-    | exn -> 
-	print_exn ppf_err exn;
-	Format.fprintf ppf_err "@.";
-	false
+  try match parse rule input with
+    | Some phs -> phrases ppf phs; true
+    | None -> false
+  with exn -> catch_exn ppf_err exn; false
 
 let script = run Parser.prog
 let topinput = run Parser.top_phrases
 
+let comp_unit src = 
+  try 
+    let ic = open_in src in
+    Location.push_source (`File src);
+    let input = Stream.of_channel ic in
+    match parse Parser.prog input with
+      | Some p ->
+	  close_in ic;
+	  let argv = ident (U.mk "argv") in
+	  let (tenv,cenv,codes) = 
+	    Compile.comp_unit 
+	      (Typer.enter_value argv (Sequence.star Sequence.string)
+		 Builtin.env)
+	      (Compile.enter_global Compile.empty argv)
+	      p in
+	  codes
+      | None -> exit 1
+    with exn -> catch_exn Format.err_formatter exn; exit 1
+
+let run_code argv codes =
+  try
+    Eval.L.push argv;
+    List.iter Eval.L.eval codes
+  with exn -> catch_exn Format.err_formatter exn; exit 1
+
+
+let compile src =
+  let codes = comp_unit src in
+  let oc = open_out (src ^ ".out") in
+  let codes_s = Serialize.Put.run Lambda.Put.compunit codes in
+  output_string oc codes_s;
+  close_out oc;
+  exit 0
+  
+let compile_run src argv =
+  run_code argv (comp_unit src)
+
+let run obj argv =  
+  let ic = open_in obj in
+  let len = in_channel_length ic in
+  let codes = String.create len in
+  really_input ic codes 0 len;
+  close_in ic;
+  let codes = Serialize.Get.run Lambda.Get.compunit codes in
+  run_code argv codes
+
+
 let serialize_typing_env t () =
   Typer.serialize t !typing_env
 

driver/cduce.mli

@@ -10,3 +10,7 @@ val dump_env : Format.formatter -> unit
 
 val serialize_typing_env : Serialize.Put.t -> unit -> unit
 val deserialize_typing_env : Serialize.Get.t -> unit
+
+val compile: string -> unit
+val compile_run: string -> Value.t -> unit
+val run: string -> Value.t -> unit

driver/run.ml

@@ -8,6 +8,9 @@ let save_dump = ref None
 let src  = ref []
 let args = ref []
 
+let compile = ref false
+let run = ref false
+
 let version () =
   Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
   Printf.eprintf "built on %s\n" <:symbol<build_date>>;
@@ -32,8 +35,10 @@ let specs =
           "   specify persistency file for loading and saving";
     "--quiet", Arg.Set Cduce.quiet, 
            "  suppress normal output (typing, results)";
-    "--compile", Arg.Set Cduce.do_compile, 
-           "  activate compilation";
+    "--compile", Arg.Set compile,
+           "  compilate the given CDuce file";
+    "--run", Arg.Set run,
+           "  compilate the given CDuce file";
     "--stdin", Arg.Unit (fun () -> src := "" :: !src),
            "  read CDuce script on standard input";
     "--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
@@ -54,6 +59,7 @@ let ppf =
   else Format.std_formatter
 let ppf_err = Format.err_formatter
 
+
 let specs = 
   if Load_xml.expat_support then
     ("--expat", Arg.Unit (fun () -> Load_xml.use_parser := `Expat),
@@ -69,9 +75,33 @@ let specs =
     specs
 
 
-let () =
+let err s =
+  prerr_endline s;
+  exit 1
+
+let mode =
   Arg.parse specs (fun s -> src := s :: !src) 
-    "\nUsage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:"
+    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
+  match (!compile,!run,!src,!args) with
+    | false, false, [],  args   -> `Toplevel args
+    | false, false, [x], args   -> `Script (x,args)
+    | false,  false, _, _        ->
+	err "Only one CDuce program can be executed at a time"
+    | true,  false, [x], []     -> `Compile x
+    | true,  false, [], []      ->
+	err "Please specifiy the CDuce program to be compiled"
+    | true,  false, _, []       ->
+	err "Only one CDuce program can be compiled at a time"
+    | true,  false, _, _        ->
+	err "No argument can be passed to programs at compile time"
+    | false, true,  [x], args   -> `Run (x,args)
+    | false, true,  [], _       ->
+	err "Please specifiy the CDuce program to be executed"
+    | false, true,   _, _       ->
+	err "Only one CDuce program can be executed at a time"
+    | true, true,   _,  _       ->
+	err "The options --compile and --run are incompatible"
+	
 
 
 let bol = ref true
@@ -137,41 +167,51 @@ let do_stdin () =
 let run s =
   if s = "" then do_stdin () else do_file s
 
-let main () =
-  (match !load_dump with
-     | Some f ->
-	 (try 
-	    Format.fprintf ppf "Restoring state: ";
-	    let chan = open_in_bin f in
-	    let s = Marshal.from_channel chan in
-	    close_in chan;
-(*	    Serialize.Get.run Cduce.deserialize_typing_env s; *)
-	    State.set s; 
-	    Format.fprintf ppf "done ...@."
-	  with Sys_error _ ->  
-	    Format.fprintf ppf "failed ...@.")
-     | None -> 
-	 let l = List.rev_map Value.string_latin1 !args in
-	 let l = Value.sequence l in
-	 let t = Sequence.star Sequence.string in
-	 Cduce.enter_global_value (ident (U.mk "argv")) l t
-  );
-  (match !src with
-     | [] -> toploop ()
-     | l -> List.iter run l);
-  (match !save_dump with
-     | Some f ->
-	 Format.fprintf ppf "Saving state ...@\n";
-(*	 let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
-	 let s = State.get () in
-	 let chan = open_out_bin f in
-	 Marshal.to_channel chan s [ Marshal.Closures ];
-	 close_out chan
-     | None -> ())
-
-
-
-let () = 
+let argv args = 
+  Value.sequence (List.rev_map Value.string_latin1 args)
+
+let restore argv =
+  match !load_dump with
+    | Some f ->
+	(try 
+	   Format.fprintf ppf "Restoring state: ";
+	   let chan = open_in_bin f in
+	   let s = Marshal.from_channel chan in
+	   close_in chan;
+	   (*	    Serialize.Get.run Cduce.deserialize_typing_env s; *)
+	   State.set s; 
+	   Format.fprintf ppf "done ...@."
+	 with Sys_error _ ->  
+	   Format.fprintf ppf "failed ...@.")
+    | None -> 
+	let t = Sequence.star Sequence.string in
+	Cduce.enter_global_value (ident (U.mk "argv")) argv t
+
+let save () =
+  match !save_dump with
+    | Some f ->
+	Format.fprintf ppf "Saving state ...@\n";
+	(*	 let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
+	let s = State.get () in
+	let chan = open_out_bin f in
+	Marshal.to_channel chan s [ Marshal.Closures ];
+	close_out chan
+    | None -> ()
+
+let main () = 
+  match mode with
+    | `Toplevel args ->
+	restore (argv args);
+	toploop ();
+	save ()
+    | `Script (f,args) ->
+	Cduce.compile_run f (argv args)
+    | `Compile f ->
+	Cduce.compile f
+    | `Run (f,args) ->
+	Cduce.run f (argv args)
+	 
+let () =  
   at_exit (fun () -> Stats.dump Format.std_formatter);
   main ()
 

misc/bool.ml

@@ -32,8 +32,6 @@ struct
     | False
     | Split of int * elem * t * t * t
 
-  include Custom.Dummy
-
   let rec equal a b =
     (a == b) ||
     match (a,b) with
@@ -78,7 +76,7 @@ struct
 	(match p with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
 	(match i with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
 	(match n with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
-	check p; check i; check n
+	X.check x; check p; check i; check n
 
   let atom x =
     let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)

misc/custom.ml

@@ -21,7 +21,7 @@ module Dummy = struct
   let equal t1 t2 = failwith "equal not implemented"
   let hash t = failwith "hash not implemented"
   let compare t1 t2 = failwith "compare not implemented"
-  let serialize t = failwith "serialize not implemented"
+  let serialize t = failwith "serialize not implemented" 
   let deserialize t = failwith "deserialize not implemented"
 end
 

misc/serialize.ml

@@ -51,6 +51,7 @@ module Put = struct
 
 (* TODO: handle negative ints better !! *)
   let rec int t i =
+    assert (i >= 0);
     bits 4 t i;
     let i = i lsr 4 in
     if i <> 0 then (bool t true; int t i) else (bool t false)
@@ -64,6 +65,11 @@ module Put = struct
   let string t s =
     substring t s 0 (String.length s)
 
+  let magic t s =
+    for i = 0 to String.length s - 1 do
+      bits 8 t (Char.code (s.[i]))
+    done
+
   let rec list f t = function
     | [] -> bool t false
     | hd::tl -> bool t true; f t hd; list f t tl
@@ -140,6 +146,12 @@ module Get = struct
     done;
     s
 
+  let magic t s =
+    for i = 0 to String.length s - 1 do
+      let c = bits 8 t in
+      if (Char.code (s.[i]) != c) then failwith "Invalid magic code."
+    done
+
   let rec list f t =
     if bool t then let hd = f t in hd::(list f t)
     else []

misc/serialize.mli

@@ -7,6 +7,7 @@ module Put : sig