[m-rev.] for review: analysis file caching

Peter Wang novalazy at gmail.com
Wed Jul 23 17:49:39 AEST 2008


Branches: main

Add a caching feature for `mmc --make' so as to avoid reparsing the same
`.analysis' files repeatedly when many modules in the program or library
import similar sets of modules.

An `.analysis_cache' file contains a binary representation of the parsed
information in its corresponding `.analysis' file.  These can be faster to
load, under certain conditions.  Cache files are stored in
`Mercury/analysis_cache' or `Mercury/<grade>/<arch>/Mercury/analysis_cache'
for the duration of a single make target.  Afterwards the directory is
deleted.  This avoids stale cache files lying around which are incompatible
between different versions of the compiler, host platform, etc.

compiler/libs.m:
compiler/pickle.m:
	Add a module in libs to un/serialise arbitrary data structures.

compiler/options.m:
	Add `--analysis-file-cache' and `--analysis-file-cache-dir <dir>'
	(internal option).

compiler/analysis.file.m:
	Read and write analysis cache files if the cache directory is set.
	Cache files are written after `.analysis' files are written (if
	changed) or after an `.analysis' file is read (if it didn't exist).

compiler/make.program_target.m:
	For certain targets, set up the analysis cache directory before
	running the build procedure, and remove it afterwards.

compiler/module_cmds.m:
	Add a version of update_interface that returns whether the
	interface file changed.

doc/user_guide.texi:
	Add commented out documentation for `--analysis-file-cache'.

diff --git a/compiler/analysis.file.m b/compiler/analysis.file.m
index 03dafbc..f9fb1c7 100644
--- a/compiler/analysis.file.m
+++ b/compiler/analysis.file.m
@@ -36,7 +36,9 @@
     % read_module_analysis_results(AnalysisInfo, ModuleName, AnalysisResults,
     %   !IO)
     %
-    % Read the analysis results from a `.analysis' file.
+    % Read the analysis results from a `.analysis' file,
+    % or from the analysis file cache (if enabled, and the cache file is
+    % up-to-date). 
     %
 :- pred read_module_analysis_results(analysis_info::in, module_name::in,
     module_analysis_map(some_analysis_result)::out, io::di, io::uo) is det.
@@ -45,6 +47,7 @@
     %   !IO)
     %
     % Write the analysis results for a module to its `.analysis' file.
+    % Optionally, also write the cache copy of the analysis file.
     %
 :- pred write_module_analysis_results(analysis_info::in,
     module_name::in, module_analysis_map(some_analysis_result)::in,
@@ -98,13 +101,19 @@
 
 :- import_module bool.
 :- import_module char.
+:- import_module dir.
 :- import_module exception.
 :- import_module parser.
 :- import_module term.
 :- import_module term_io.
+:- import_module type_desc.
+:- import_module univ.
 :- import_module varset.
 
 :- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module libs.options.
+:- import_module libs.pickle.
 :- import_module parse_tree.
 :- import_module parse_tree.module_cmds.        % XXX unwanted dependency
 :- import_module parse_tree.prog_io.
@@ -255,8 +264,46 @@ read_module_analysis_results(Info, ModuleName, ModuleResults, !IO) :-
         analysis_registry_suffix, MaybeAnalysisFileName, !IO),
     (
         MaybeAnalysisFileName = ok(AnalysisFileName),
-        read_module_analysis_results_2(Compiler, AnalysisFileName,
-            ModuleResults, !IO)
+
+        % If analysis file caching is enabled, and the cache file exists and is
+        % up-to-date, then read from the cache instead.
+        globals.io_lookup_string_option(analysis_file_cache_dir, CacheDir,
+            !IO),
+        ( CacheDir \= "" ->
+            CacheFileName = make_cache_filename(CacheDir, AnalysisFileName),
+            io.file_modification_time(AnalysisFileName, AnalysisTimeResult,
+                !IO),
+            io.file_modification_time(CacheFileName, CacheTimeResult, !IO),
+            (
+                AnalysisTimeResult = ok(AnalysisTime),
+                CacheTimeResult = ok(CacheTime),
+                CacheTime @>= AnalysisTime
+            ->
+                Unpicklers = init_analysis_unpicklers(Compiler),
+                unpickle_from_file(Unpicklers, CacheFileName, UnpickleResult,
+                    !IO),
+                (
+                    UnpickleResult = ok(ModuleResults)
+                ;
+                    UnpickleResult = error(Error),
+                    io.write_string("Error reading ", !IO),
+                    io.write_string(CacheFileName, !IO),
+                    io.write_string(": ", !IO),
+                    io.write_string(io.error_message(Error), !IO),
+                    io.nl(!IO),
+                    read_module_analysis_results_2(Compiler, AnalysisFileName,
+                        ModuleResults, !IO),
+                    write_analysis_cache_file(CacheFileName, ModuleResults, !IO)
+                )
+            ;
+                read_module_analysis_results_2(Compiler, AnalysisFileName,
+                    ModuleResults, !IO),
+                write_analysis_cache_file(CacheFileName, ModuleResults, !IO)
+            )
+        ;
+            read_module_analysis_results_2(Compiler, AnalysisFileName,
+                ModuleResults, !IO)
+        )
     ;
         MaybeAnalysisFileName = error(_),
         ModuleResults = map.init
@@ -615,7 +662,20 @@ write_module_analysis_results(Info, ModuleName, ModuleResults, !IO) :-
     ToTmp = yes,
     write_analysis_file(Info ^ compiler, ModuleName, analysis_registry_suffix,
         ToTmp, write_result_entry, ModuleResults, FileName, !IO),
-    update_interface(FileName, !IO).
+    update_interface_return_changed(FileName, Result, !IO),
+
+    % If analysis file caching is turned on, write the internal represention of
+    % the module results to disk right now.
+    globals.io_lookup_string_option(analysis_file_cache_dir, CacheDir, !IO),
+    (
+        CacheDir \= "",
+        Result = interface_new_or_changed
+    ->
+        CacheFileName = make_cache_filename(CacheDir, FileName),
+        write_analysis_cache_file(CacheFileName, ModuleResults, !IO)
+    ;
+        true
+    ).
 
 :- pred write_result_entry
     `with_type` write_entry(some_analysis_result)
@@ -699,8 +759,8 @@ write_module_analysis_requests(Info, ModuleName, ModuleRequests, !IO) :-
 write_request_entry(Compiler, AnalysisName, FuncId, Request, !IO) :-
     Request = analysis_request(Call, CallerModule),
     (
-        analysis_type(_ : unit(Call), _ : unit(Answer)) =
-            analyses(Compiler, AnalysisName)
+        analysis_type(_ : unit(Call), _ : unit(Answer))
+            = analyses(Compiler, AnalysisName)
     ->
         VersionNumber = analysis_version_number(_ : Call, _ :  Answer)
     ;
@@ -854,5 +914,144 @@ empty_request_file(Info, ModuleName, !IO) :-
     io.remove_file(RequestFileName, _, !IO).
 
 %-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%
+% Analysis file caching
+%
+% An analysis cache file stores a binary representation of the parsed
+% information in the corresponding .analysis file.  In some cases, the binary
+% format can be faster to read than the usual representation.  The textual
+% analysis files are portable, more stable (doesn't depend on compiler
+% internals) and easier to debug, hence the reason we don't just use the
+% binary files exclusively.
+%
+
+:- func make_cache_filename(string, string) = string.
+
+make_cache_filename(Dir, FileName) = CacheFileName :-
+    Components = string.split_at_separator(dir_sep, FileName),
+    EscFileName = string.join_list(":", Components),
+    CacheFileName = Dir / EscFileName.
+
+:- pred dir_sep(char::in) is semidet.
+
+dir_sep(Char) :-
+    dir.is_directory_separator(Char).
+
+:- pred write_analysis_cache_file(string::in,
+    module_analysis_map(some_analysis_result)::in, io::di, io::uo) is det.
+
+write_analysis_cache_file(CacheFileName, ModuleResults, !IO) :-
+    % Write to a temporary file first and only move it into place once it is
+    % complete.
+    TmpFileName = CacheFileName ++ ".tmp",
+    io.tell_binary(TmpFileName, TellRes, !IO),
+    (
+        TellRes = ok,
+        pickle(init_analysis_picklers, ModuleResults, !IO),
+        io.told_binary(!IO),
+        io.rename_file(TmpFileName, CacheFileName, RenameRes, !IO),
+        (
+            RenameRes = ok
+        ;
+            RenameRes = error(Error),
+            io.write_string("Error renaming ", !IO),
+            io.write_string(CacheFileName, !IO),
+            io.write_string(": ", !IO),
+            io.write_string(io.error_message(Error), !IO),
+            io.nl(!IO),
+            io.remove_file(TmpFileName, _, !IO)
+        )
+    ;
+        TellRes = error(Error),
+        unexpected(this_file, "pickle_to_file: " ++ io.error_message(Error))
+    ).
+
+:- func init_analysis_picklers = picklers.
+
+init_analysis_picklers = Pickles :-
+    some [!Pickles] (
+        !:Pickles = init_picklers,
+        Dummy = 'new some_analysis_result'(any_call, dummy_answer, optimal),
+        Type = type_ctor(type_of(Dummy)),
+        register_pickler(Type, pickle_analysis_result, !Pickles),
+        Pickles = !.Pickles
+    ).
+
+:- pred pickle_analysis_result(picklers::in, univ::in, io::di, io::uo) is det.
+
+pickle_analysis_result(Pickles, Univ, !IO) :-
+    det_univ_to_type(Univ, some_analysis_result(Call, Answer, Status)),
+    Name = analysis_name(Call, Answer),
+    pickle(Pickles, Name, !IO),
+    pickle(Pickles, Call, !IO),
+    pickle(Pickles, Answer, !IO),
+    pickle(Pickles, Status, !IO).
+
+:- func init_analysis_unpicklers(Compiler) = unpicklers
+    <= compiler(Compiler).
+
+init_analysis_unpicklers(Compiler) = Unpicklers :-
+    some [!Unpicklers] (
+        !:Unpicklers = init_unpicklers,
+        Dummy = 'new some_analysis_result'(any_call, dummy_answer, optimal),
+        Type = type_ctor(type_of(Dummy)),
+        register_unpickler(Type, unpickle_analysis_result(Compiler),
+            !Unpicklers),
+        Unpicklers = !.Unpicklers
+    ).
+
+:- pred unpickle_analysis_result(Compiler::in, unpicklers::in,
+    unpickle_handle::in, type_desc::in, univ::out,
+    unpickle_state::di, unpickle_state::uo) is det
+    <= compiler(Compiler).
+
+unpickle_analysis_result(Compiler, Unpicklers, Handle, _Type, Univ, !State) :-
+    unpickle(Unpicklers, Handle, Name : string, !State),
+    (
+        analysis_type(_ : unit(Call), _ : unit(Answer))
+            = analyses(Compiler, Name)
+    ->
+        unpickle(Unpicklers, Handle, Call : Call, !State),
+        unpickle(Unpicklers, Handle, Answer : Answer, !State),
+        unpickle(Unpicklers, Handle, Status, !State),
+        Result = 'new some_analysis_result'(Call, Answer, Status),
+        type_to_univ(Result, Univ)
+    ;
+        unexpected(this_file, "unpickle_analysis_result: " ++ Name)
+    ).
+
+% This is only needed so we can get the type_ctor_desc of
+% `some_analysis_result' without referring to a real analysis.
+
+:- type dummy_answer
+    --->    dummy_answer.
+
+:- instance answer_pattern(no_func_info, dummy_answer) where [].
+:- instance partial_order(no_func_info, dummy_answer) where [
+    ( more_precise_than(no_func_info, _, _) :-
+        semidet_fail
+    ),
+    equivalent(no_func_info, dummy_answer, dummy_answer)
+].
+:- instance to_term(dummy_answer) where [
+    ( to_term(dummy_answer) = Term :-
+        Term = term.functor(atom("dummy"), [], context_init)
+    ),
+    ( from_term(Term, dummy_answer) :-
+        Term = term.functor(atom("dummy"), [], _)
+    )
+].
+
+:- instance analysis(no_func_info, any_call, dummy_answer) where [
+    analysis_name(_, _) = "dummy",
+    analysis_version_number(_, _) = 1,
+    preferred_fixpoint_type(_, _) = greatest_fixpoint,
+    bottom(_, _) = dummy_answer,
+    top(_, _) = dummy_answer,
+    get_func_info(_, _, _, _, _, no_func_info)
+].
+
+%-----------------------------------------------------------------------------%
 :- end_module analysis.file.
 %-----------------------------------------------------------------------------%
diff --git a/compiler/libs.m b/compiler/libs.m
index bcfc6bf..25ae3e0 100644
--- a/compiler/libs.m
+++ b/compiler/libs.m
@@ -26,6 +26,7 @@
 :- include_module atsort.
 :- include_module file_util.
 :- include_module graph_colour.
+:- include_module pickle.
 :- include_module tree.
 
 % OS interfaces not provided by the standard library.
diff --git a/compiler/make.program_target.m b/compiler/make.program_target.m
index 3786c99..61f5b89 100644
--- a/compiler/make.program_target.m
+++ b/compiler/make.program_target.m
@@ -60,7 +60,7 @@
 %-----------------------------------------------------------------------------%
 
 make_linked_target(LinkedTargetFile, LinkedTargetSucceeded, !Info, !IO) :-
-    LinkedTargetFile = linked_target_file(MainModuleName, FileType),
+    LinkedTargetFile = linked_target_file(_MainModuleName, FileType),
     (
         FileType = shared_library,
         ExtraOptions = ["--compile-to-shared-lib"]
@@ -93,41 +93,49 @@ make_linked_target(LinkedTargetFile, LinkedTargetSucceeded, !Info, !IO) :-
             LibgradeCheck = no,
             LibgradeCheckSucceeded = yes
         ),
-
         (
             LibgradeCheckSucceeded = yes,
-            % When using `--intermodule-analysis', perform an analysis pass
-            % first.  The analysis of one module may invalidate the results of
-            % a module we analysed earlier, so this step must be carried out
-            % until all the `.analysis' files are in a valid state before we
-            % can continue.
-            globals.io_lookup_bool_option(intermodule_analysis,
-                IntermodAnalysis, !IO),
-            (
-                IntermodAnalysis = yes,
-                make_misc_target_builder(
-                    MainModuleName - misc_target_build_analyses,
-                    ExtraOptions, IntermodAnalysisSucceeded, !Info, !IO)
-            ;
-                IntermodAnalysis = no,
-                IntermodAnalysisSucceeded = yes
-            )
-        ;
-            LibgradeCheckSucceeded = no,
-            IntermodAnalysisSucceeded = no
-        ),
-
-        (
-            IntermodAnalysisSucceeded = yes,
-            build_with_module_options(MainModuleName, ExtraOptions,
-                make_linked_target_2(LinkedTargetFile),
+            maybe_with_analysis_cache_dir(
+                make_linked_target_1(LinkedTargetFile, ExtraOptions),
                 LinkedTargetSucceeded, !Info, !IO)
         ;
-            IntermodAnalysisSucceeded = no,
+            LibgradeCheckSucceeded = no,
             LinkedTargetSucceeded = no
         )
     ).
 
+:- pred make_linked_target_1(linked_target_file::in, list(string)::in,
+    bool::out, make_info::in, make_info::out, io::di, io::uo) is det.
+
+make_linked_target_1(LinkedTargetFile, ExtraOptions, Succeeded, !Info, !IO) :-
+    LinkedTargetFile = linked_target_file(MainModuleName, _FileType),
+
+    % When using `--intermodule-analysis', perform an analysis pass
+    % first.  The analysis of one module may invalidate the results of
+    % a module we analysed earlier, so this step must be carried out
+    % until all the `.analysis' files are in a valid state before we
+    % can continue.
+    globals.io_lookup_bool_option(intermodule_analysis, IntermodAnalysis, !IO),
+    (
+        IntermodAnalysis = yes,
+        make_misc_target_builder(
+            MainModuleName - misc_target_build_analyses,
+            ExtraOptions, IntermodAnalysisSucceeded, !Info, !IO)
+    ;
+        IntermodAnalysis = no,
+        IntermodAnalysisSucceeded = yes
+    ),
+
+    (
+        IntermodAnalysisSucceeded = yes,
+        build_with_module_options(MainModuleName, ExtraOptions,
+            make_linked_target_2(LinkedTargetFile),
+            Succeeded, !Info, !IO)
+    ;
+        IntermodAnalysisSucceeded = no,
+        Succeeded = no
+    ).
+
 :- pred make_linked_target_2(linked_target_file::in, list(string)::in,
     bool::out, make_info::in, make_info::out, io::di, io::uo) is det.
 
@@ -663,22 +671,26 @@ make_misc_target_builder(MainModuleName - TargetType, _, Succeeded,
         ( Succeeded0 = no, KeepGoing = no ->
             Succeeded = no
         ;
-            foldl2_maybe_stop_at_error(KeepGoing,
-                make_module_target,
-                make_dependency_list(TargetModules, ModuleTargetType),
+            maybe_with_analysis_cache_dir(
+                foldl2_maybe_stop_at_error(KeepGoing,
+                    make_module_target,
+                    make_dependency_list(TargetModules, ModuleTargetType)),
                 Succeeded1, !Info, !IO),
             Succeeded = Succeeded0 `and` Succeeded1
         )
     ;
         TargetType = misc_target_build_analyses,
-        build_analysis_files(MainModuleName, AllModules, Succeeded0, Succeeded,
-            !Info, !IO)
+        maybe_with_analysis_cache_dir(
+            build_analysis_files(MainModuleName, AllModules, Succeeded0),
+            Succeeded, !Info, !IO)
     ;
         TargetType = misc_target_build_library,
         make_all_interface_files(AllModules, IntSucceeded, !Info, !IO),
         (
             IntSucceeded = yes,
-            build_library(MainModuleName, AllModules, Succeeded, !Info, !IO)
+            maybe_with_analysis_cache_dir(
+                build_library(MainModuleName, AllModules),
+                Succeeded, !Info, !IO)
         ;
             IntSucceeded = no,
             Succeeded = no
@@ -737,6 +749,98 @@ make_all_interface_files(AllModules, Succeeded, !Info, !IO) :-
 
 %-----------------------------------------------------------------------------%
 
+    % If `--analysis-file-cache' is enabled, create a temporary directory for
+    % holding analysis cache files and pass that to child processes.
+    % After P is finished, remove the cache directory completely.
+    %
+:- pred maybe_with_analysis_cache_dir(build0(make_info)::in(build0),
+    bool::out, make_info::in, make_info::out, io::di, io::uo) is det.
+
+maybe_with_analysis_cache_dir(P, Succeeded, !Info, !IO) :-
+    globals.io_lookup_bool_option(intermodule_analysis, IntermodAnalysis, !IO),
+    globals.io_lookup_bool_option(analysis_file_cache, Caching, !IO),
+    globals.io_lookup_string_option(analysis_file_cache_dir, CacheDir0, !IO),
+    CacheDirOption = "--analysis-file-cache-dir",
+    (
+        (
+            IntermodAnalysis = no
+        ;
+            Caching = no
+        ;
+            % Cache directory given on command line.
+            CacheDir0 \= ""
+        ;
+            % Analysis file cache directory already set up in a parent call.
+            list.member(CacheDirOption, !.Info ^ option_args)
+        )
+    ->
+        P(Succeeded, !Info, !IO)
+    ;
+        create_analysis_cache_dir(Succeeded0, CacheDir, !IO),
+        (
+            Succeeded0 = yes,
+            OrigOptionArgs = !.Info ^ option_args,
+            % Pass the name of the cache directory to child processes
+            !Info ^ option_args := OrigOptionArgs ++
+                [CacheDirOption, CacheDir],
+            build_with_check_for_interrupt(P, remove_cache_dir(CacheDir),
+                Succeeded, !Info, !IO),
+            remove_cache_dir(CacheDir, !Info, !IO),
+            !Info ^ option_args := OrigOptionArgs
+        ;
+            Succeeded0 = no,
+            Succeeded = no
+        )
+    ).
+
+:- pred create_analysis_cache_dir(bool::out, string::out, io::di, io::uo)   
+    is det.
+
+create_analysis_cache_dir(Succeeded, CacheDir, !IO) :-
+    choose_cache_dir_name(CacheDir, !IO),
+    verbose_msg(verbose_make,
+        io.format("Creating %s\n", [s(CacheDir)]), !IO),
+    dir.make_directory(CacheDir, MakeRes, !IO),
+    (
+        MakeRes = ok,
+        Succeeded = yes
+    ;
+        MakeRes = error(Error),
+        io.write_string("Error: making directory ", !IO),
+        io.write_string(CacheDir, !IO),
+        io.write_string(": ", !IO),
+        io.write_string(io.error_message(Error), !IO),
+        io.nl(!IO),
+        Succeeded = no
+    ).
+
+:- pred choose_cache_dir_name(string::out, io::di, io::uo) is det.
+
+choose_cache_dir_name(DirName, !IO) :-
+    globals.io_get_globals(Globals, !IO),
+    globals.lookup_bool_option(Globals, use_grade_subdirs, UseGradeSubdirs),
+    globals.lookup_string_option(Globals, fullarch, FullArch),
+    (
+        UseGradeSubdirs = yes,
+        grade_directory_component(Globals, Grade),
+        DirComponents = ["Mercury", Grade, FullArch, "Mercury",
+            "analysis_cache"]
+    ;
+        UseGradeSubdirs = no,
+        DirComponents = ["Mercury", "analysis_cache"]
+    ),
+    DirName = dir.relative_path_name_from_components(DirComponents).
+
+:- pred remove_cache_dir(string::in, make_info::in, make_info::out,
+    io::di, io::uo) is det.
+
+remove_cache_dir(CacheDir, !Info, !IO) :-
+    verbose_msg(verbose_make,
+        io.format("Removing %s\n", [s(CacheDir)]), !IO),
+    io.remove_file_recursively(CacheDir, _, !IO).
+
+%-----------------------------------------------------------------------------%
+
 :- pred build_analysis_files(module_name::in, list(module_name)::in,
     bool::in, bool::out, make_info::in, make_info::out, io::di, io::uo)
     is det.
diff --git a/compiler/module_cmds.m b/compiler/module_cmds.m
index 76c512e..7df9df1 100644
--- a/compiler/module_cmds.m
+++ b/compiler/module_cmds.m
@@ -25,11 +25,18 @@
 
 %-----------------------------------------------------------------------------%
 
-    % update_interface_return_succeeded(FileName, Succeeded):
+:- type update_interface_result
+    --->    interface_new_or_changed
+    ;       interface_unchanged
+    ;       interface_error.
+
+    % update_interface_return_changed(FileName, Result):
     %
-    % Call the shell script mercury_update_interface to update the
-    % interface file FileName from FileName.tmp if it has changed.
+    % Update the interface file FileName from FileName.tmp if it has changed.
     %
+:- pred update_interface_return_changed(file_name::in,
+    update_interface_result::out, io::di, io::uo) is det.
+
 :- pred update_interface_return_succeeded(file_name::in, bool::out,
     io::di, io::uo) is det.
 
@@ -186,6 +193,18 @@ update_interface(OutputFileName, !IO) :-
     ).
 
 update_interface_return_succeeded(OutputFileName, Succeeded, !IO) :-
+    update_interface_return_changed(OutputFileName, Result, !IO),
+    (
+        ( Result = interface_new_or_changed
+        ; Result = interface_unchanged
+        ),
+        Succeeded = yes
+    ;
+        Result = interface_error,
+        Succeeded = no
+    ).
+
+update_interface_return_changed(OutputFileName, Result, !IO) :-
     globals.io_lookup_bool_option(verbose, Verbose, !IO),
     maybe_write_string(Verbose, "% Updating interface:\n", !IO),
     TmpOutputFileName = OutputFileName ++ ".tmp",
@@ -201,7 +220,7 @@ update_interface_return_succeeded(OutputFileName, Succeeded, !IO) :-
             io.close_binary_input(TmpOutputFileStream, !IO),
             (
                 FilesDiffer = ok(ok(no)),
-                Succeeded = yes,
+                Result = interface_unchanged,
                 maybe_write_string(Verbose, "% ", !IO),
                 maybe_write_string(Verbose, OutputFileName, !IO),
                 maybe_write_string(Verbose, "' has not changed.\n", !IO),
@@ -209,10 +228,10 @@ update_interface_return_succeeded(OutputFileName, Succeeded, !IO) :-
             ;
                 FilesDiffer = ok(ok(yes)),
                 update_interface_create_file("CHANGED", OutputFileName,
-                    TmpOutputFileName, Succeeded, !IO)
+                    TmpOutputFileName, Result, !IO)
             ;
                 FilesDiffer = ok(error(TmpFileError)),
-                Succeeded = no,
+                Result = interface_error,
                 io.write_string("Error reading `", !IO),
                 io.write_string(TmpOutputFileName, !IO),
                 io.write_string("': ", !IO),
@@ -221,12 +240,12 @@ update_interface_return_succeeded(OutputFileName, Succeeded, !IO) :-
             ;
                 FilesDiffer = error(_, _),
                 update_interface_create_file("been CREATED", OutputFileName,
-                    TmpOutputFileName, Succeeded, !IO)
+                    TmpOutputFileName, Result, !IO)
             )
         ;
 
             TmpOutputFileRes = error(TmpOutputFileError),
-            Succeeded = no,
+            Result = interface_error,
             io.close_binary_input(OutputFileStream, !IO),
             io.write_string("Error creating `", !IO),
             io.write_string(OutputFileName, !IO),
@@ -237,13 +256,13 @@ update_interface_return_succeeded(OutputFileName, Succeeded, !IO) :-
     ;
         OutputFileRes = error(_),
         update_interface_create_file("been CREATED", OutputFileName,
-            TmpOutputFileName, Succeeded, !IO)
+            TmpOutputFileName, Result, !IO)
     ).
 
 :- pred update_interface_create_file(string::in, string::in, string::in,
-    bool::out, io::di, io::uo) is det.
+    update_interface_result::out, io::di, io::uo) is det.
 
-update_interface_create_file(Msg, OutputFileName, TmpOutputFileName, Succeeded,
+update_interface_create_file(Msg, OutputFileName, TmpOutputFileName, Result,
         !IO) :-
     globals.io_lookup_bool_option(verbose, Verbose, !IO),
     maybe_write_string(Verbose,
@@ -251,10 +270,10 @@ update_interface_create_file(Msg, OutputFileName, TmpOutputFileName, Succeeded,
     copy_file(TmpOutputFileName, OutputFileName, MoveRes, !IO),
     (
         MoveRes = ok,
-        Succeeded = yes
+        Result = interface_new_or_changed
     ;
         MoveRes = error(MoveError),
-        Succeeded = no,
+        Result = interface_error,
         io.write_string("Error creating `" ++ OutputFileName ++ "': " ++
             io.error_message(MoveError), !IO),
         io.nl(!IO)
diff --git a/compiler/options.m b/compiler/options.m
index a3668d0..eb22a41 100644
--- a/compiler/options.m
+++ b/compiler/options.m
@@ -533,6 +533,7 @@
     ;       transitive_optimization
     ;       intermodule_analysis
     ;       analysis_repeat
+    ;       analysis_file_cache
 
     %   - HLDS
     ;       allow_inlining
@@ -868,6 +869,7 @@
     ;       fullarch
     ;       cross_compiling
     ;       local_module_id
+    ;       analysis_file_cache_dir
     ;       compiler_sufficiently_recent
             % This option is used to test that the compiler is sufficiently
             % recent when no other test can easily be constructed in
@@ -1311,6 +1313,7 @@ option_defaults_2(special_optimization_option, [
     transitive_optimization             -   bool(no),
     intermodule_analysis                -   bool(no),
     analysis_repeat                     -   int(0),
+    analysis_file_cache                 -   bool(no),
     termination_check                   -   bool(no),
     verbose_check_termination           -   bool(no),
     structure_sharing_analysis          -   bool(no), 
@@ -1685,6 +1688,7 @@ option_defaults_2(miscellaneous_option, [
     fullarch                            -   string(""),
     cross_compiling                     -   bool(no),
     local_module_id                     -   accumulating([]),
+    analysis_file_cache_dir             -   string(""),
     compiler_sufficiently_recent        -   bool(no),
     experiment                          -   string(""),
     feedback_file                       -   string("")
@@ -2109,6 +2113,7 @@ long_option("transitive-intermodule-optimisation",
 long_option("trans-intermod-opt",   transitive_optimization).
 long_option("intermodule-analysis", intermodule_analysis).
 long_option("analysis-repeat",      analysis_repeat).
+long_option("analysis-file-cache",  analysis_file_cache).
 
 % HLDS->HLDS optimizations
 long_option("inlining",             inlining).
@@ -2539,6 +2544,7 @@ long_option("filenames-from-stdin", filenames_from_stdin).
 long_option("fullarch",             fullarch).
 long_option("cross-compiling",      cross_compiling).
 long_option("local-module-id",      local_module_id).
+long_option("analysis-file-cache-dir",  analysis_file_cache_dir).
 long_option("bug-intermod-2002-06-13",  compiler_sufficiently_recent).
 long_option("bug-intermod-2006-09-28",  compiler_sufficiently_recent).
 long_option("bug-foreign_import-2002-08-06", compiler_sufficiently_recent).
@@ -4372,6 +4378,10 @@ options_help_optimization -->
         "\tThe maximum number of times to repeat analyses of",
         "\tsuboptimal modules with `--intermodule-analysis'",
         "\t(default: 0)."
+        % This is commented out as this feature is still experimental.
+%       "--analysis-file-cache",
+%       "\tEnable caching of parsed analysis files. This may",
+%       "\timprove compile times with `--intermodule-analysis'."
     ]).
 
 :- pred options_help_hlds_hlds_optimization(io::di, io::uo) is det.
@@ -5191,6 +5201,8 @@ options_help_misc -->
         "\tplatform the compiler is running on.",
 
         % The `--local-module-id' option is used by `mmc --make'.
+        % The `--analysis-file-cache-dir' option is used by `mmc --make'.
+
         "--feedback-file",
         "\tUse the specified profiling feedback file which may currently",
         "\tonly be processed for implicit parallelism."
diff --git a/compiler/pickle.m b/compiler/pickle.m
new file mode 100644
index 0000000..f15c512
--- /dev/null
+++ b/compiler/pickle.m
@@ -0,0 +1,486 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2008 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: pickle.m
+% Main authors: petdr, wangp.
+%
+% This file contains routines to serialise arbitrary data structures into some
+% unspecified binary format which can be restored quickly.
+%
+% We don't preserve sharing in the pickled data structure.  This would be
+% possible but would introduce slowdowns in both the pickling and unpickling
+% processes.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module libs.pickle.
+:- interface.
+
+:- import_module io.
+:- import_module type_desc.
+:- import_module univ.
+
+%-----------------------------------------------------------------------------%
+
+    % A type which holds custom pickling predicates.
+    %
+:- type picklers.
+
+:- type pickler_pred == pred(picklers, univ, io, io).
+:- inst pickler_pred == (pred(in, in, di, uo) is det).
+
+    % Initialize the custom pickling predicates.
+    %
+:- func init_picklers = picklers.
+
+    % For the type described by the type_ctor_desc, add the supplied custom
+    % pickle predicate to the set of registered pickle predicates.
+    %
+:- pred register_pickler(type_ctor_desc::in, pickler_pred::in(pickler_pred),
+    picklers::in, picklers::out) is det.
+
+    % Serialise an arbitrary data structure into the current binary output
+    % stream, using the picklers given to override the default pickling method.
+    %
+    % Existential, foreign and higher-order types are not supported
+    % generically.  Register custom handlers to handle those types.
+    %
+:- pred pickle(picklers::in, T::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+    % A type which holds the custom unpickling predicates.
+    %
+:- type unpicklers.
+
+:- type unpickle_handle.
+
+:- type unpickle_state.
+
+:- type unpickler_pred == pred(unpicklers, unpickle_handle, type_desc, univ,
+                            unpickle_state, unpickle_state).
+:- inst unpickler_pred == (pred(in, in, in, out, di, uo) is det).
+
+    % Initialize the custom unpickling predicates.
+    %
+:- func init_unpicklers = unpicklers.
+
+    % For the type described by the type_ctor_desc, add the supplied custom
+    % unpickle predicate to the set of registered unpickle predicates.
+    %
+:- pred register_unpickler(type_ctor_desc::in,
+    unpickler_pred::in(unpickler_pred), unpicklers::in, unpicklers::out)
+    is det.
+
+    % Get a pickled type back out from the file, using the unpicklers to
+    % override the default unpickling method.
+    %
+:- pred unpickle_from_file(unpicklers::in, string::in, io.res(T)::out,
+    io::di, io::uo) is det.
+
+    % Unpickle a single value.
+    %
+:- pred unpickle(unpicklers::in, unpickle_handle::in, T::out,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module libs.compiler_util.
+
+:- import_module bitmap.
+:- import_module bool.
+:- import_module char.
+:- import_module construct.
+:- import_module deconstruct.
+:- import_module exception.
+:- import_module int.
+:- import_module io.
+:- import_module list.
+:- import_module map.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+
+:- type picklers
+    --->    picklers(
+                map(type_ctor_desc, pickler_pred)
+            ).
+
+:- type unpicklers
+    --->    unpicklers(
+                map(type_ctor_desc, unpickler_pred)
+            ).
+
+:- type unpickle_handle == bitmap.
+:- type unpickle_state  == int.         % offset into bitmap
+
+:- type get_byte_out_of_range
+    --->    get_byte_out_of_range(string).
+
+%-----------------------------------------------------------------------------%
+%
+% Pickling
+%
+
+init_picklers = picklers(map.init).
+
+register_pickler(TypeCtorDesc, Pickle, Pickles0, Pickles) :-
+    Pickles0 = picklers(Map0),
+    map.det_insert(Map0, TypeCtorDesc, Pickle, Map),
+    Pickles = picklers(Map).
+
+pickle(Pickles, T, !IO) :-
+    ( dynamic_cast(T, String) ->
+        pickle_string(String, !IO)
+    ; dynamic_cast(T, Int) ->
+        pickle_int32(Int, !IO)
+    ; dynamic_cast(T, Float) ->
+        pickle_float(Float, !IO)
+    ; dynamic_cast(T, Char) ->
+        pickle_char(Char, !IO)
+    ;
+        TypeDesc = type_of(T),
+        TypeCtorDesc = type_ctor(TypeDesc),
+        user_defined_pickler(Pickles, TypeCtorDesc, Pickle)
+    ->
+        Pickle(Pickles, univ(T), !IO)
+    ;
+        deconstruct.functor(T, do_not_allow, Functor, Arity),
+        pickle_string(Functor, !IO),
+        pickle_int32(Arity, !IO),
+        pickle_args(Pickles, 0, Arity, T, !IO)
+    ).
+
+:- pred pickle_args(picklers::in, int::in, int::in, T::in, io::di, io::uo)
+    is det.
+
+pickle_args(Pickles, N, Arity, T, !IO) :-
+    ( N = Arity ->
+        true
+    ;
+        ( deconstruct.arg(T, do_not_allow, N, Arg) ->
+            pickle(Pickles, Arg, !IO),
+            pickle_args(Pickles, N + 1, Arity, T, !IO)
+        ;
+            unexpected(this_file, "pickle_args: unable to deconstruct arg")
+        )
+    ).
+
+:- pred user_defined_pickler(picklers::in, type_ctor_desc::in,
+    pickler_pred::out(pickler_pred)) is semidet.
+
+user_defined_pickler(picklers(Pickles), TypeCtorDesc, Pickle) :-
+    map.search(Pickles, TypeCtorDesc, Pickle0),
+    pickler_inst_cast(Pickle0, Pickle).
+
+:- pred pickler_inst_cast(pickler_pred::in, pickler_pred::out(pickler_pred))
+    is det.
+
+:- pragma foreign_proc("C",
+    pickler_inst_cast(A::in, B::out(pickler_pred)),
+    [will_not_call_mercury, thread_safe, promise_pure],
+"
+    B = A;
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Unpickling
+%
+
+init_unpicklers = unpicklers(map.init).
+
+register_unpickler(TypeCtorDesc, Unpickle, Unpicklers0, Unpicklers) :-
+    Unpicklers0 = unpicklers(Map0),
+    map.det_insert(Map0, TypeCtorDesc, Unpickle, Map),
+    Unpicklers = unpicklers(Map).
+
+unpickle_from_file(Unpicklers, FileName, Result, !IO) :-
+    io.see_binary(FileName, SeeResult, !IO),
+    (
+        SeeResult = ok,
+        % Perform unpickling from an intermediate memory buffer, as it seems to
+        % be faster.
+        io.read_binary_file_as_bitmap(ReadResult, !IO),
+        io.seen_binary(!IO),
+        (
+            ReadResult = ok(Bitmap),
+            promise_equivalent_solutions [TryResult] (
+                try((pred(T0::out) is det :-
+                    unpickle(Unpicklers, Bitmap, T0, 0, _State)
+                ), TryResult)
+            ),
+            (
+                TryResult = succeeded(T),
+                Result = ok(T)
+            ;
+                TryResult = exception(Excp),
+                ( univ_to_type(Excp, get_byte_out_of_range(Msg)) ->
+                    Result = error(io.make_io_error(Msg))
+                ;
+                    rethrow(TryResult)
+                )
+            )
+        ;
+            ReadResult = error(Error),
+            Result = error(Error)
+        )
+    ;
+        SeeResult = error(Error),
+        Result = error(Error)
+    ).
+
+unpickle(Unpicklers, Handle, T, !State) :-
+    unpickle_2(Unpicklers, Handle, type_of(T), Univ, !State),
+    det_univ_to_type(Univ, T).
+
+:- pred unpickle_2(unpicklers::in, unpickle_handle::in,
+    type_desc::in, univ::out, unpickle_state::di, unpickle_state::uo)
+    is det.
+
+unpickle_2(Unpicklers, Handle, TypeDesc, Univ, !State) :-
+    ( TypeDesc = type_of(_ : string) ->
+        unpickle_string(Handle, String, !State),
+        Univ = univ(String)
+    ; TypeDesc = type_of(_ : int) ->
+        unpickle_int32(Handle, Int, !State),
+        Univ = univ(Int)
+    ; TypeDesc = type_of(_ : float) ->
+        unpickle_float(Handle, Float, !State),
+        Univ = univ(Float)
+    ; TypeDesc = type_of(_ : character) ->
+        unpickle_char(Handle, Char, !State),
+        Univ = univ(Char)
+    ; user_defined_unpickler(Unpicklers, type_ctor(TypeDesc), Unpickle) ->
+        Unpickle(Unpicklers, Handle, TypeDesc, Univ, !State)
+    ;
+        unpickle_string(Handle, Functor, !State),
+        unpickle_int32(Handle, Arity, !State),
+        (
+            ( Functor = "{}" ->
+                IsTuple = yes,
+                type_ctor_and_args(TypeDesc, _, ArgTypes),
+                N = 0
+            ;
+                IsTuple = no,
+                % XXX consider tabling this call
+                find_functor(TypeDesc, Functor, Arity, N, ArgTypes)
+            )
+        ->
+            list.map_foldl(unpickle_2(Unpicklers, Handle), ArgTypes, ArgUnivs,
+                !State),
+            (
+                IsTuple = yes,
+                Univ = construct_tuple(ArgUnivs)
+            ;
+                IsTuple = no,
+                ( Univ0 = construct(TypeDesc, N, ArgUnivs) ->
+                    Univ = Univ0
+                ;
+                    unexpected(this_file, "unpickle_2: unable to construct")
+                )
+            )
+        ;
+            unexpected(this_file, "unpickle_2: unable to unpickle")
+        )
+    ).
+
+:- pred user_defined_unpickler(unpicklers::in, type_ctor_desc::in,
+    unpickler_pred::out(unpickler_pred)) is semidet.
+
+user_defined_unpickler(unpicklers(Unpicklers), TypeCtorDesc, Unpickle) :-
+    map.search(Unpicklers, TypeCtorDesc, Unpickle0),
+    unpickler_inst_cast(Unpickle0, Unpickle).
+
+:- pred unpickler_inst_cast(unpickler_pred::in,
+    unpickler_pred::out(unpickler_pred)) is det.
+
+:- pragma foreign_proc("C",
+    unpickler_inst_cast(A::in, B::out(unpickler_pred)),
+    [will_not_call_mercury, thread_safe, promise_pure],
+"
+    B = A;
+").
+
+%-----------------------------------------------------------------------------%
+%
+% Basic types picklers/unpicklers
+%
+
+:- pred pickle_int32(int::in, io::di, io::uo) is det.
+
+pickle_int32(Int, !IO) :-
+    A = (Int >> 24) /\ 0xff,
+    B = (Int >> 16) /\ 0xff,
+    C = (Int >>  8) /\ 0xff,
+    D = (Int >>  0) /\ 0xff,
+    io.write_byte(A, !IO),
+    io.write_byte(B, !IO),
+    io.write_byte(C, !IO),
+    io.write_byte(D, !IO).
+
+:- pred unpickle_int32(unpickle_handle::in, int::out,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+unpickle_int32(Handle, Int, !State) :-
+    get_byte(Handle, A, !State),
+    get_byte(Handle, B, !State),
+    get_byte(Handle, C, !State),
+    get_byte(Handle, D, !State),
+    Int0 = (A `unchecked_left_shift` 24)
+        \/ (B `unchecked_left_shift` 16)
+        \/ (C `unchecked_left_shift`  8)
+        \/ (D `unchecked_left_shift`  0),
+    Int = sign_extend_32(Int0).
+
+:- func sign_extend_32(int) = int.
+
+sign_extend_32(X) = R :-
+    % http://graphics.stanford.edu/~seander/bithacks.html#FixedSignExtend
+    Mask = 1 `unchecked_left_shift` 31,
+    R = (X `xor` Mask) - Mask.
+
+:- pred pickle_char(char::in, io::di, io::uo) is det.
+
+pickle_char(Char, !IO) :-
+    char.to_int(Char, Int),
+    io.write_byte(Int, !IO).
+
+:- pred unpickle_char(unpickle_handle::in, char::out,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+unpickle_char(Handle, Char, !State) :-
+    get_byte(Handle, Byte, !State),
+    char.det_from_int(Byte, Char).
+
+:- pred pickle_string(string::in, io::di, io::uo) is det.
+
+pickle_string(String, !IO) :-
+    Length = string.length(String),
+    pickle_int32(Length, !IO),
+    string.foldl(pickle_char, String, !IO).
+
+:- pred unpickle_string(unpickle_handle::in, string::uo,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+unpickle_string(Handle, String, !State) :-
+    unpickle_int32(Handle, Length, !State),
+    allocate_string(Length, String0),
+    unpickle_string_2(Handle, 0, Length, String0, String, !State).
+
+:- pred unpickle_string_2(unpickle_handle::in, int::in, int::in,
+    string::di, string::uo, unpickle_state::di, unpickle_state::uo) is det.
+
+unpickle_string_2(Handle, Index, Length, !String, !State) :-
+    ( Index = Length ->
+        true
+    ;
+        unpickle_char(Handle, Char, !State),
+        local_unsafe_set_char(Char, Index, !String),
+        unpickle_string_2(Handle, Index + 1, Length, !String, !State)
+    ).
+
+:- pred allocate_string(int::in, string::uo) is det.
+
+:- pragma foreign_proc("C",
+    allocate_string(Length::in, Str::uo),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    MR_allocate_aligned_string_msg(Str, Length, ""pickle.allocate_string"");
+    Str[Length] = '\\0';
+").
+
+    % string.unsafe_set_char is disabled in the standard library so we need our
+    % own copy.
+:- pred local_unsafe_set_char(char::in, int::in, string::di, string::uo)
+    is det.
+
+:- pragma foreign_proc("C",
+    local_unsafe_set_char(Chr::in, Index::in, Str0::di, Str::uo),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    Str0[Index] = Chr;
+    Str = Str0;
+").
+
+:- pred pickle_float(float::in, io::di, io::uo) is det.
+
+pickle_float(Float, !IO) :-
+    reinterpret_float_as_ints(Float, A, B),
+    % We always write floats using 64 bits.  Single precision floats are not
+    % the default and the compiler hardly uses floats anyhow.
+    pickle_int32(A, !IO),
+    pickle_int32(B, !IO).
+
+:- pred reinterpret_float_as_ints(float::in, int::out, int::out)
+    is det.
+
+:- pragma foreign_proc("C",
+    reinterpret_float_as_ints(Flt::in, A::out, B::out),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    if (sizeof(MR_Float) == sizeof(float)) {
+        MR_uint_least32_t *p = (MR_uint_least32_t *) &Flt;
+        A = *p;
+        B = 0;
+    } else {
+        MR_uint_least64_t *p = (MR_uint_least64_t *) &Flt;
+        A = (*p >> 32) & 0xffffffff;
+        B = (*p >>  0) & 0xffffffff;
+    }
+").
+
+:- pred unpickle_float(unpickle_handle::in, float::out,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+unpickle_float(Handle, Float, !State) :-
+    unpickle_int32(Handle, A, !State),
+    unpickle_int32(Handle, B, !State),
+    reinterpret_ints_as_float(A, B, Float).
+
+:- pred reinterpret_ints_as_float(int::in, int::in, float::out) is det.
+
+:- pragma foreign_proc("C",
+    reinterpret_ints_as_float(A::in, B::in, Flt::out),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    if (sizeof(MR_Float) == sizeof(float)) {
+        MR_Float *p = (MR_Float *) &A;
+        Flt = *p;
+        (void) B;
+    } else {
+        MR_uint_least64_t tmp = (A << 32) | (B & 0xffffffff);
+        MR_Float *p = (MR_Float *) &tmp;
+        Flt = *p;
+    }
+").
+
+:- pred get_byte(unpickle_handle::in, int::out,
+    unpickle_state::di, unpickle_state::uo) is det.
+
+get_byte(Bitmap, Byte, Index, Index + 1) :-
+    ( bitmap.byte_in_range(Bitmap, Index) ->
+        Byte = Bitmap ^ unsafe_byte(Index)
+    ;
+        Msg = "byte " ++ string.from_int(Index) ++ " is out of range",
+        throw(get_byte_out_of_range(Msg))
+    ).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "libs.pickle".
+
+%-----------------------------------------------------------------------------%
+:- end_module libs.pickle.
+%-----------------------------------------------------------------------------%
diff --git a/doc/user_guide.texi b/doc/user_guide.texi
index 7970fae..d6f876f 100644
--- a/doc/user_guide.texi
+++ b/doc/user_guide.texi
@@ -8019,6 +8019,12 @@ The maximum number of times to repeat analyses of suboptimal modules with
 @samp{--intermodule-analyses} (default: 0).  This option only works with
 @samp{mmc --make}.
 
+ at c This feature is still experimental.
+ at c @item --analysis-file-cache
+ at c @findex --analysis-file-cache
+ at c Enable caching of parsed analysis files. This may
+ at c improve compile times with @samp{--intermodule-analysis}.
+
 @end table
 
 @node High-level (HLDS -> HLDS) optimization options


--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------



More information about the reviews mailing list