reduced prominence of "permissive code generation"
authorhaftmann
Thu, 30 Jan 2014 16:09:04 +0100
changeset 55188 7ca0204ece66
parent 55187 6d0d93316daf
child 55189 2f829a3cf9bc
reduced prominence of "permissive code generation"
src/Tools/Code/code_runtime.ML
src/Tools/Code/code_target.ML
src/Tools/Code/code_thingol.ML
--- a/src/Tools/Code/code_runtime.ML	Thu Jan 30 16:09:03 2014 +0100
+++ b/src/Tools/Code/code_runtime.ML	Thu Jan 30 16:09:04 2014 +0100
@@ -196,7 +196,7 @@
 fun evaluation_code thy module_name tycos consts =
   let
     val ctxt = Proof_Context.init_global thy;
-    val program = Code_Thingol.consts_program thy false consts;
+    val program = Code_Thingol.consts_program thy consts;
     val (ml_modules, target_names) =
       Code_Target.produce_code_for thy
         target NONE module_name [] program (map Constant consts @ map Type_Constructor tycos);
--- a/src/Tools/Code/code_target.ML	Thu Jan 30 16:09:03 2014 +0100
+++ b/src/Tools/Code/code_target.ML	Thu Jan 30 16:09:04 2014 +0100
@@ -8,7 +8,6 @@
 sig
   val cert_tyco: theory -> string -> string
   val read_tyco: theory -> string -> string
-  val read_const_exprs: theory -> string list -> string list
 
   val export_code_for: theory -> Path.T option -> string -> int option -> string -> Token.T list
     -> Code_Thingol.program -> Code_Symbol.T list -> unit
@@ -458,44 +457,39 @@
 
 (* code generation *)
 
-fun read_const_exprs thy const_exprs =
-  let
-    val (cs1, cs2) = Code_Thingol.read_const_exprs thy const_exprs;
-    val program = Code_Thingol.consts_program thy true cs2;
-    val cs3 = Code_Thingol.implemented_deps program;
-  in union (op =) cs3 cs1 end;
-
 fun prep_destination "" = NONE
   | prep_destination s = SOME (Path.explode s);
 
 fun export_code thy cs seris =
   let
-    val program = Code_Thingol.consts_program thy false cs;
+    val program = Code_Thingol.consts_program thy cs;
     val _ = map (fn (((target, module_name), some_path), args) =>
       export_code_for thy some_path target NONE module_name args program (map Constant cs)) seris;
   in () end;
 
-fun export_code_cmd raw_cs seris thy = export_code thy (read_const_exprs thy raw_cs)
+fun export_code_cmd raw_cs seris thy = export_code thy
+  (Code_Thingol.read_const_exprs thy raw_cs)
   ((map o apfst o apsnd) prep_destination seris);
 
 fun produce_code thy cs target some_width some_module_name args =
   let
-    val program = Code_Thingol.consts_program thy false cs;
+    val program = Code_Thingol.consts_program thy cs;
   in produce_code_for thy target some_width some_module_name args program (map Constant cs) end;
 
 fun present_code thy cs syms target some_width some_module_name args =
   let
-    val program = Code_Thingol.consts_program thy false cs;
+    val program = Code_Thingol.consts_program thy cs;
   in present_code_for thy target some_width some_module_name args program (map Constant cs, syms) end;
 
 fun check_code thy cs seris =
   let
-    val program = Code_Thingol.consts_program thy false cs;
+    val program = Code_Thingol.consts_program thy cs;
     val _ = map (fn ((target, strict), args) =>
       check_code_for thy target strict args program (map Constant cs)) seris;
   in () end;
 
-fun check_code_cmd raw_cs seris thy = check_code thy (read_const_exprs thy raw_cs) seris;
+fun check_code_cmd raw_cs seris thy = check_code thy
+  (Code_Thingol.read_const_exprs thy raw_cs) seris;
 
 local
 
--- a/src/Tools/Code/code_thingol.ML	Thu Jan 30 16:09:03 2014 +0100
+++ b/src/Tools/Code/code_thingol.ML	Thu Jan 30 16:09:04 2014 +0100
@@ -83,8 +83,8 @@
     -> ((Code_Symbol.T * stmt) list * (Code_Symbol.T * stmt) list
       * ((Code_Symbol.T * stmt) list * (Code_Symbol.T * stmt) list)) list
 
-  val read_const_exprs: theory -> string list -> string list * string list
-  val consts_program: theory -> bool -> string list -> program
+  val read_const_exprs: theory -> string list -> string list
+  val consts_program: theory -> string list -> program
   val dynamic_conv: theory -> (program
     -> ((string * sort) list * typscheme) * iterm -> Code_Symbol.T list -> conv)
     -> conv
@@ -743,19 +743,25 @@
 
 (* program generation *)
 
-fun consts_program thy permissive consts =
+fun consts_program_internal thy permissive consts =
   let
-    fun project program =
-      if permissive then program
-      else Code_Symbol.Graph.restrict
-        (member (op =) (Code_Symbol.Graph.all_succs program
-          (map Constant consts))) program;
     fun generate_consts thy algebra eqngr =
       fold_map (ensure_const thy algebra eqngr permissive);
   in
     invoke_generation permissive thy (Code_Preproc.obtain false thy consts [])
       generate_consts consts
     |> snd
+  end;
+
+fun consts_program_permissive thy = consts_program_internal thy true;
+
+fun consts_program thy consts =
+  let
+    fun project program = Code_Symbol.Graph.restrict
+      (member (op =) (Code_Symbol.Graph.all_succs program
+        (map Constant consts))) program;
+  in
+    consts_program_internal thy false consts
     |> project
   end;
 
@@ -838,9 +844,9 @@
   Code_Preproc.static_value thy postproc consts (lift_evaluator thy evaluator consts);
 
 
-(** diagnostic commands **)
+(** constant expressions **)
 
-fun read_const_exprs thy =
+fun read_const_exprs_internal thy =
   let
     fun consts_of thy' = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
       ((snd o #constants o Consts.dest o Sign.consts_of) thy') [];
@@ -859,6 +865,17 @@
       | NONE => ([Code.read_const thy str], []));
   in pairself flat o split_list o map read_const_expr end;
 
+fun read_const_exprs_all thy = op @ o read_const_exprs_internal thy;
+
+fun read_const_exprs thy const_exprs =
+  let
+    val (consts, consts_permissive) = read_const_exprs_internal thy const_exprs;
+    val consts' = implemented_deps (consts_program_permissive thy consts_permissive);
+  in union (op =) consts' consts end;
+
+
+(** diagnostic commands **)
+
 fun code_depgr thy consts =
   let
     val (_, eqngr) = Code_Preproc.obtain true thy consts [];
@@ -888,8 +905,8 @@
 
 local
 
-fun code_thms_cmd thy = code_thms thy o op @ o read_const_exprs thy;
-fun code_deps_cmd thy = code_deps thy o op @ o read_const_exprs thy;
+fun code_thms_cmd thy = code_thms thy o read_const_exprs_all thy;
+fun code_deps_cmd thy = code_deps thy o read_const_exprs_all thy;
 
 in