src/Tools/cache_io.ML
changeset 40425 c9b5e0fcee31
parent 37740 9bb4a74cff4e
child 40538 b8482ff0bc92
equal deleted inserted replaced
40424:7550b2cba1cb 40425:c9b5e0fcee31
     4 Cache for output of external processes.
     4 Cache for output of external processes.
     5 *)
     5 *)
     6 
     6 
     7 signature CACHE_IO =
     7 signature CACHE_IO =
     8 sig
     8 sig
       
     9   (*IO wrapper*)
     9   val with_tmp_file: string -> (Path.T -> 'a) -> 'a
    10   val with_tmp_file: string -> (Path.T -> 'a) -> 'a
    10   val with_tmp_dir: string -> (Path.T -> 'a) -> 'a
    11   val with_tmp_dir: string -> (Path.T -> 'a) -> 'a
    11   val run: (Path.T -> Path.T -> string) -> string -> string list * string list
    12   val run: (Path.T -> Path.T -> string) -> string ->
       
    13     {output: string list, redirected_output: string list, return_code: int}
    12 
    14 
       
    15   (*cache*)
    13   type cache
    16   type cache
    14   val make: Path.T -> cache
    17   val make: Path.T -> cache
    15   val cache_path_of: cache -> Path.T
    18   val cache_path_of: cache -> Path.T
    16   val lookup: cache -> string -> (string list * string list) option * string
    19   val lookup: cache -> string -> (string list * string list) option * string
    17   val run_and_cache: cache -> string -> (Path.T -> Path.T -> string) ->
    20   val run_and_cache: cache -> string -> (Path.T -> Path.T -> string) ->
    20     string list * string list
    23     string list * string list
    21 end
    24 end
    22 
    25 
    23 structure Cache_IO : CACHE_IO =
    26 structure Cache_IO : CACHE_IO =
    24 struct
    27 struct
       
    28 
       
    29 (* IO wrapper *)
    25 
    30 
    26 val cache_io_prefix = "cache-io-"
    31 val cache_io_prefix = "cache-io-"
    27 
    32 
    28 fun with_tmp_file name f =
    33 fun with_tmp_file name f =
    29   let
    34   let
    43 fun run make_cmd str =
    48 fun run make_cmd str =
    44   with_tmp_file cache_io_prefix (fn in_path =>
    49   with_tmp_file cache_io_prefix (fn in_path =>
    45   with_tmp_file cache_io_prefix (fn out_path =>
    50   with_tmp_file cache_io_prefix (fn out_path =>
    46     let
    51     let
    47       val _ = File.write in_path str
    52       val _ = File.write in_path str
    48       val (out2, _) = bash_output (make_cmd in_path out_path)
    53       val (out2, rc) = bash_output (make_cmd in_path out_path)
    49       val out1 = the_default [] (try (rev o File.fold_lines cons out_path) [])
    54       val out1 = the_default [] (try (rev o File.fold_lines cons out_path) [])
    50     in (out1, split_lines out2) end))
    55     in {output=split_lines out2, redirected_output=out1, return_code=rc} end))
    51 
    56 
    52 
    57 
       
    58 (* cache *)
    53 
    59 
    54 abstype cache = Cache of {
    60 abstype cache = Cache of {
    55   path: Path.T,
    61   path: Path.T,
    56   table: (int * (int * int * int) Symtab.table) Synchronized.var }
    62   table: (int * (int * int * int) Symtab.table) Synchronized.var }
    57 with
    63 with
    58 
    64 
    59 
       
    60 fun cache_path_of (Cache {path, ...}) = path
    65 fun cache_path_of (Cache {path, ...}) = path
    61 
       
    62 
    66 
    63 fun load cache_path =
    67 fun load cache_path =
    64   let
    68   let
    65     fun err () = error ("Cache IO: corrupted cache file: " ^
    69     fun err () = error ("Cache IO: corrupted cache file: " ^
    66       File.shell_path cache_path)
    70       File.shell_path cache_path)
    85 
    89 
    86 fun make path =
    90 fun make path =
    87   let val table = if File.exists path then load path else (1, Symtab.empty)
    91   let val table = if File.exists path then load path else (1, Symtab.empty)
    88   in Cache {path=path, table=Synchronized.var (Path.implode path) table} end
    92   in Cache {path=path, table=Synchronized.var (Path.implode path) table} end
    89 
    93 
    90 
       
    91 fun load_cached_result cache_path (p, len1, len2) =
    94 fun load_cached_result cache_path (p, len1, len2) =
    92   let
    95   let
    93     fun load line (i, xsp) =
    96     fun load line (i, xsp) =
    94       if i < p then (i+1, xsp)
    97       if i < p then (i+1, xsp)
    95       else if i < p + len1 then (i+1, apfst (cons line) xsp)
    98       else if i < p + len1 then (i+1, apfst (cons line) xsp)
    96       else if i < p + len2 then (i+1, apsnd (cons line) xsp)
    99       else if i < p + len2 then (i+1, apsnd (cons line) xsp)
    97       else (i, xsp)
   100       else (i, xsp)
    98   in pairself rev (snd (File.fold_lines load cache_path (1, ([], [])))) end
   101   in pairself rev (snd (File.fold_lines load cache_path (1, ([], [])))) end
    99 
   102 
   100 
       
   101 fun lookup (Cache {path=cache_path, table}) str =
   103 fun lookup (Cache {path=cache_path, table}) str =
   102   let val key = SHA1.digest str
   104   let val key = SHA1.digest str
   103   in
   105   in
   104     (case Symtab.lookup (snd (Synchronized.value table)) key of
   106     (case Symtab.lookup (snd (Synchronized.value table)) key of
   105       NONE => (NONE, key)
   107       NONE => (NONE, key)
   106     | SOME pos => (SOME (load_cached_result cache_path pos), key))
   108     | SOME pos => (SOME (load_cached_result cache_path pos), key))
   107   end
   109   end
   108 
   110 
   109 
       
   110 fun run_and_cache (Cache {path=cache_path, table}) key make_cmd str =
   111 fun run_and_cache (Cache {path=cache_path, table}) key make_cmd str =
   111   let
   112   let
   112     val res as (out, err) = run make_cmd str
   113     val {output=err, redirected_output=out, ...} = run make_cmd str
       
   114     val res = (out, err)
   113     val (l1, l2) = pairself length res
   115     val (l1, l2) = pairself length res
   114     val header = key ^ " " ^ string_of_int l1 ^ " " ^ string_of_int l2
   116     val header = key ^ " " ^ string_of_int l1 ^ " " ^ string_of_int l2
   115     val lines = map (suffix "\n") (header :: out @ err)
   117     val lines = map (suffix "\n") (header :: out @ err)
   116 
   118 
   117     val _ = Synchronized.change table (fn (p, tab) =>
   119     val _ = Synchronized.change table (fn (p, tab) =>
   119       else
   121       else
   120         let val _ = File.append_list cache_path lines
   122         let val _ = File.append_list cache_path lines
   121         in (p+l1+l2+1, Symtab.update (key, (p+1, l1, l2)) tab) end)
   123         in (p+l1+l2+1, Symtab.update (key, (p+1, l1, l2)) tab) end)
   122   in res end
   124   in res end
   123 
   125 
   124 
       
   125 fun run_cached cache make_cmd str =
   126 fun run_cached cache make_cmd str =
   126   (case lookup cache str of
   127   (case lookup cache str of
   127     (NONE, key) => run_and_cache cache key make_cmd str
   128     (NONE, key) => run_and_cache cache key make_cmd str
   128   | (SOME output, _) => output)
   129   | (SOME output, _) => output)
   129 
   130 
   130 end
   131 end
       
   132 
   131 end
   133 end