[m-rev.] for review: erlang external procs and mmc --make support
Peter Wang
wangp at students.csse.unimelb.edu.au
Wed May 30 13:03:59 AEST 2007
Estimated hours taken: 25
Branches: main
Add support for :- external procedures to the Erlang backend.
Add Erlang support to mmc --make.
compiler/elds.m:
Extend the ELDS for definitions of external procedures.
compiler/elds_to_erlang.m:
Move the logic for mapping a module name to a file name into
module_name_to_file_name, as it is needed for mmc --make as well.
Similarly move erlang_module_name to modules.m.
Output export annotations for :- external procedures which are
exported.
Conform to changes in the ELDS.
compiler/erl_call_gen.m:
Don't generate assignment statements between variables of dummy types.
compiler/erl_code_gen.m:
Generate skeleton ELDS definitions for external procedures.
Fix more cases where success expressions could be inserted after
`erroneous' goals. The Erlang compiler would complain about unbound
variables appearing in success expressions following erroneous goals,
because it doesn't know that the erroneous goal would throw an
exception.
Handle some special cases with `erroneous' and `failure' goals where we
used to generate code that the Erlang compiler would complain about
references to unbound variables, or variables being bound in one branch
of a conditional statement but not another, etc.
- handle a special case where the goal inside a commit scope has
determinism `failure', i.e. it would never actually commit;
- handle a special case where the condition of an if-then-else is
`erroneous', so the Then branch can't be reached;
- handle a special case where a disjunct has determinism `failure',
so later disjuncts will always be evaluated.
Generate code for promise_solutions and exist_quant scopes.
Wrap large success expressions in closures instead of duplicating them
into each disjunct, in the same way that we do for switches.
Disable duplicating of small success expressions into branches of
switches and disjunctions for now, as the implmentation is buggy.
compiler/handle_options.m:
Remove the LLDS and MLDS options from the grade_component_table entry
for the "erlang" grade. They caused compute_grade to return "none" if
only --target erlang was used (because --target erlang didn't imply the
same set of meaningless options).
compiler/hlds_pred.m:
Fix the implementations of `status_is_exported' and
`status_defined_in_this_module' for external procedures.
compiler/compile_target_code.m:
compiler/make.dependencies.m:
compiler/make.m:
compiler/make.module_target.m:
compiler/make.program_target.m:
compiler/make.util.m:
compiler/modules.m:
Add Erlang support to mmc --make. It can build "libraries" (we just
use directories called libFOO.beams containing Erlang .beam bytecode
files), install them and executables (which are just shell scripts
which invoke the Erlang runtime system).
Refactor some code and fix a few assumptions in places that we were
building for the C backends.
Replace some calls to io.remove_file by io.remove_file_recursively as
our Erlang "libraries" are actually directories.
Unrelated bugfix: for mmc --make --use-grade-subdirs foo.realclean,
remove the symlink created for foo.init in the current directory.
Delete module_name_to_file_name_sep as it is no longer used.
compiler/options.m:
Add options --erlang-interpreter, --erlang-object-file-extension
adn --install-command-dir-option.
doc/user_guide.texi:
Document --install-command-dir-option.
tests/mmc_make/Mmakefile:
Generate TEST_FLAGS *after* start_runtests_local as
start_runtests_local runs make realclean_local, which deletes
TEST_FLAGS.
library/io.m:
Add io.remove_file_recursively which can remove non-empty directories.
Fix the fallback implmentation io.buffer_to_string which was calling a
non-existent `from_char_list_semidet' predicate.
NEWS:
Mention io.remove_file_recursively.
Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.460
diff -u -r1.460 NEWS
--- NEWS 10 May 2007 05:55:37 -0000 1.460
+++ NEWS 30 May 2007 03:00:01 -0000
@@ -156,6 +156,9 @@
This means stream.get/4 can be used to efficiently read lines
and files as string.
+* We have added a predicate io.remove_file_recursively/4
+ which can remove non-empty directories.
+
Changes to the Mercury compiler:
* In parallel grades we now support thread-local trailing.
Index: compiler/compile_target_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.107
diff -u -r1.107 compile_target_code.m
--- compiler/compile_target_code.m 7 May 2007 05:21:29 -0000 1.107
+++ compiler/compile_target_code.m 30 May 2007 03:00:01 -0000
@@ -80,10 +80,10 @@
:- pred compile_csharp_file(io.output_stream::in, module_imports::in,
file_name::in, file_name::in, bool::out, io::di, io::uo) is det.
- % compile_erlang_file(ErrorStream, ErlangFile, BeamFile, Succeeded)
+ % compile_erlang_file(ErrorStream, ErlangFile, Succeeded)
%
-:- pred compile_erlang_file(io.output_stream::in,
- file_name::in, file_name::in, bool::out, io::di, io::uo) is det.
+:- pred compile_erlang_file(io.output_stream::in, file_name::in,
+ bool::out, io::di, io::uo) is det.
% make_init_file(ErrorStream, MainModuleName, ModuleNames, Succeeded):
%
@@ -102,7 +102,8 @@
---> executable
; static_library
; shared_library
- ; java_archive.
+ ; java_archive
+ ; erlang_archive.
% link(TargetType, MainModuleName, ObjectFileNames, Succeeded)
%
@@ -905,8 +906,42 @@
%-----------------------------------------------------------------------------%
-compile_erlang_file(_ErrorStream, _ErlangFile, _BeamFile, _Succeeded, !IO) :-
- sorry(this_file, "compile_erlang_file").
+compile_erlang_file(ErrorStream, ErlangFile, Succeeded, !IO) :-
+ globals.io_lookup_bool_option(verbose, Verbose, !IO),
+ maybe_write_string(Verbose, "% Compiling `", !IO),
+ maybe_write_string(Verbose, ErlangFile, !IO),
+ maybe_write_string(Verbose, "':\n", !IO),
+ globals.io_lookup_string_option(erlang_compiler, ErlangCompiler, !IO),
+ globals.io_lookup_accumulating_option(erlang_flags, ErlangFlagsList, !IO),
+ ERLANGFLAGS = string.join_list(" ", ErlangFlagsList),
+
+ globals.io_lookup_bool_option(use_subdirs, UseSubdirs, !IO),
+ globals.io_lookup_bool_option(use_grade_subdirs, UseGradeSubdirs, !IO),
+ globals.io_lookup_string_option(fullarch, FullArch, !IO),
+ globals.io_get_globals(Globals, !IO),
+ (
+ UseSubdirs = yes,
+ (
+ UseGradeSubdirs = yes,
+ grade_directory_component(Globals, Grade),
+ DirName = "Mercury"/Grade/FullArch/"Mercury"/"beams"
+ ;
+ UseGradeSubdirs = no,
+ DirName = "Mercury"/"beams"
+ ),
+ % Create the destination directory.
+ dir.make_directory(DirName, _, !IO),
+ % Set destination directory for .beam files.
+ DestDir = "-o " ++ DirName ++ " "
+ ;
+ UseSubdirs = no,
+ DestDir = ""
+ ),
+
+ string.append_list([ErlangCompiler, " ", DestDir, ERLANGFLAGS, " ",
+ ErlangFile], Command),
+ invoke_system_command(ErrorStream, cmd_verbose_commands, Command,
+ Succeeded, !IO).
%-----------------------------------------------------------------------------%
@@ -1247,229 +1282,34 @@
link(ErrorStream, LinkTargetType, ModuleName, ObjectsList, Succeeded, !IO) :-
globals.io_lookup_bool_option(verbose, Verbose, !IO),
globals.io_lookup_bool_option(statistics, Stats, !IO),
+ globals.io_get_target(Target, !IO),
maybe_write_string(Verbose, "% Linking...\n", !IO),
link_output_filename(LinkTargetType, ModuleName, _Ext, OutputFileName, !IO),
- ( LinkTargetType = static_library ->
+ (
+ LinkTargetType = static_library,
create_archive(ErrorStream, OutputFileName, yes, ObjectsList,
LinkSucceeded, !IO)
- ; LinkTargetType = java_archive ->
+ ;
+ LinkTargetType = java_archive,
create_java_archive(ErrorStream, ModuleName, OutputFileName,
ObjectsList, LinkSucceeded, !IO)
;
- (
- LinkTargetType = shared_library,
- CommandOpt = link_shared_lib_command,
- RpathFlagOpt = shlib_linker_rpath_flag,
- RpathSepOpt = shlib_linker_rpath_separator,
- LDFlagsOpt = ld_libflags,
- ThreadFlagsOpt = shlib_linker_thread_flags,
- DebugFlagsOpt = shlib_linker_debug_flags,
- TraceFlagsOpt = shlib_linker_trace_flags,
- globals.io_lookup_bool_option(allow_undefined, AllowUndef, !IO),
- (
- AllowUndef = yes,
- globals.io_lookup_string_option(
- linker_allow_undefined_flag, UndefOpt, !IO)
- ;
- AllowUndef = no,
- globals.io_lookup_string_option(
- linker_error_undefined_flag, UndefOpt, !IO)
- )
- ;
- LinkTargetType = executable,
- CommandOpt = link_executable_command,
- RpathFlagOpt = linker_rpath_flag,
- RpathSepOpt = linker_rpath_separator,
- LDFlagsOpt = ld_flags,
- ThreadFlagsOpt = linker_thread_flags,
- DebugFlagsOpt = linker_debug_flags,
- TraceFlagsOpt = linker_trace_flags,
- UndefOpt = ""
- ;
- LinkTargetType = static_library,
- unexpected(this_file, "compile_target_code.link")
- ;
- LinkTargetType = java_archive,
- unexpected(this_file, "compile_target_code.link")
- ),
-
- % Should the executable be stripped?
- globals.io_lookup_bool_option(strip, Strip, !IO),
- (
- LinkTargetType = executable,
- Strip = yes
- ->
- globals.io_lookup_string_option(linker_strip_flag, StripOpt, !IO)
- ;
- StripOpt = ""
- ),
-
- globals.io_lookup_bool_option(target_debug, TargetDebug, !IO),
- (
- TargetDebug = yes,
- globals.io_lookup_string_option(DebugFlagsOpt, DebugOpts, !IO)
- ;
- TargetDebug = no,
- DebugOpts = ""
- ),
-
- % Should the executable be statically linked?
- globals.io_lookup_string_option(linkage, Linkage, !IO),
- (
- LinkTargetType = executable,
- Linkage = "static"
- ->
- globals.io_lookup_string_option(linker_static_flags, StaticOpts,
- !IO)
- ;
- StaticOpts = ""
- ),
-
- % Are the thread libraries needed?
- use_thread_libs(UseThreadLibs, !IO),
- (
- UseThreadLibs = yes,
- globals.io_lookup_string_option(ThreadFlagsOpt, ThreadOpts, !IO)
- ;
- UseThreadLibs = no,
- ThreadOpts = ""
- ),
-
- % Find the Mercury standard libraries.
- globals.io_lookup_maybe_string_option(
- mercury_standard_library_directory, MaybeStdLibDir, !IO),
- (
- MaybeStdLibDir = yes(StdLibDir),
- get_mercury_std_libs(LinkTargetType, StdLibDir, MercuryStdLibs,
- !IO)
- ;
- MaybeStdLibDir = no,
- MercuryStdLibs = ""
- ),
-
- % Find which system libraries are needed.
- get_system_libs(LinkTargetType, SystemLibs, !IO),
-
- join_quoted_string_list(ObjectsList, "", "", " ", Objects),
- globals.io_lookup_accumulating_option(LDFlagsOpt, LDFlagsList, !IO),
- join_string_list(LDFlagsList, "", "", " ", LDFlags),
- globals.io_lookup_accumulating_option(link_library_directories,
- LinkLibraryDirectoriesList, !IO),
- globals.io_lookup_string_option(linker_path_flag, LinkerPathFlag,
- !IO),
- join_quoted_string_list(LinkLibraryDirectoriesList, LinkerPathFlag, "",
- " ", LinkLibraryDirectories),
-
- % Set up the runtime library path.
- globals.io_lookup_bool_option(shlib_linker_use_install_name,
- UseInstallName, !IO),
- shared_libraries_supported(SharedLibsSupported, !IO),
- (
- UseInstallName = no,
- SharedLibsSupported = yes,
- ( Linkage = "shared"
- ; LinkTargetType = shared_library
- )
- ->
- globals.io_lookup_accumulating_option(
- runtime_link_library_directories, RpathDirs, !IO),
- (
- RpathDirs = [],
- RpathOpts = ""
- ;
- RpathDirs = [_|_],
- globals.io_lookup_string_option(RpathSepOpt, RpathSep, !IO),
- globals.io_lookup_string_option(RpathFlagOpt, RpathFlag, !IO),
- RpathOpts0 = string.join_list(RpathSep, RpathDirs),
- RpathOpts = RpathFlag ++ RpathOpts0
- )
- ;
- RpathOpts = ""
- ),
-
- % Set up the install name for shared libraries.
- (
- UseInstallName = yes,
- LinkTargetType = shared_library
- ->
- % NOTE: `ShLibFileName' must *not* be prefixed with a directory.
- % get_install_name_option will prefix it with the correct
- % directory which is the one where the library is going to
- % be installed, *not* where it is going to be built.
- %
- BaseFileName = sym_name_to_string(ModuleName),
- globals.io_lookup_string_option(shared_library_extension,
- SharedLibExt, !IO),
- ShLibFileName = "lib" ++ BaseFileName ++ SharedLibExt,
- get_install_name_option(ShLibFileName, InstallNameOpt, !IO)
- ;
- InstallNameOpt = ""
- ),
-
- globals.io_get_trace_level(TraceLevel, !IO),
- ( given_trace_level_is_none(TraceLevel) = yes ->
- TraceOpts = ""
- ;
- globals.io_lookup_string_option(TraceFlagsOpt, TraceOpts, !IO)
- ),
-
- % Pass either `-llib' or `PREFIX/lib/GRADE/liblib.a',
- % depending on whether we are linking with static or shared
- % Mercury libraries.
-
- globals.io_lookup_accumulating_option(
- mercury_library_directories, MercuryLibDirs0, !IO),
- globals.io_get_globals(Globals, !IO),
- grade_directory_component(Globals, GradeDir),
- MercuryLibDirs = list.map(
- (func(LibDir) = LibDir/"lib"/GradeDir),
- MercuryLibDirs0),
- globals.io_lookup_accumulating_option(link_libraries,
- LinkLibrariesList0, !IO),
- list.map_foldl2(process_link_library(MercuryLibDirs),
- LinkLibrariesList0, LinkLibrariesList, yes,
- LibrariesSucceeded, !IO),
-
- globals.io_lookup_string_option(linker_opt_separator,
- LinkOptSep, !IO),
- (
- LibrariesSucceeded = yes,
- join_quoted_string_list(LinkLibrariesList, "", "", " ",
- LinkLibraries),
-
- % Note that LDFlags may contain `-l' options so it should come
- % after Objects.
- globals.io_lookup_string_option(CommandOpt, Command, !IO),
- string.append_list(
- [Command, " ",
- StaticOpts, " ", StripOpt, " ", UndefOpt, " ",
- ThreadOpts, " ", TraceOpts, " ",
- " -o ", OutputFileName, " ", Objects, " ",
- LinkOptSep, " ", LinkLibraryDirectories, " ",
- RpathOpts, " ", InstallNameOpt, " ", DebugOpts,
- " ", LDFlags, " ", LinkLibraries, " ",
- MercuryStdLibs, " ", SystemLibs],
- LinkCmd),
-
- globals.io_lookup_bool_option(demangle, Demangle, !IO),
- (
- Demangle = yes,
- globals.io_lookup_string_option(demangle_command,
- DemangleCmd, !IO),
- MaybeDemangleCmd = yes(DemangleCmd)
- ;
- Demangle = no,
- MaybeDemangleCmd = no
- ),
-
- invoke_system_command_maybe_filter_output(ErrorStream,
- cmd_verbose_commands, LinkCmd, MaybeDemangleCmd, LinkSucceeded,
- !IO)
+ LinkTargetType = erlang_archive,
+ create_erlang_archive(ErrorStream, ModuleName, OutputFileName,
+ ObjectsList, LinkSucceeded, !IO)
+ ;
+ LinkTargetType = executable,
+ ( Target = target_erlang ->
+ create_erlang_shell_script(ModuleName, LinkSucceeded, !IO)
;
- LibrariesSucceeded = no,
- LinkSucceeded = no
+ link_exe_or_shared_lib(ErrorStream, LinkTargetType, ModuleName,
+ OutputFileName, ObjectsList, LinkSucceeded, !IO)
)
+ ;
+ LinkTargetType = shared_library,
+ link_exe_or_shared_lib(ErrorStream, LinkTargetType, ModuleName,
+ OutputFileName, ObjectsList, LinkSucceeded, !IO)
),
maybe_report_stats(Stats, !IO),
(
@@ -1500,11 +1340,231 @@
Ext = ".jar",
module_name_to_file_name(ModuleName, Ext, yes, OutputFileName, !IO)
;
+ LinkTargetType = erlang_archive,
+ Ext = ".beams",
+ module_name_to_lib_file_name("lib", ModuleName, Ext, yes,
+ OutputFileName, !IO)
+ ;
LinkTargetType = executable,
globals.io_lookup_string_option(executable_file_extension, Ext, !IO),
module_name_to_file_name(ModuleName, Ext, yes, OutputFileName, !IO)
).
+:- pred link_exe_or_shared_lib(io.output_stream::in,
+ linked_target_type::in(bound(executable ; shared_library)),
+ module_name::in, file_name::in, list(string)::in, bool::out,
+ io::di, io::uo) is det.
+
+link_exe_or_shared_lib(ErrorStream, LinkTargetType, ModuleName,
+ OutputFileName, ObjectsList, LinkSucceeded, !IO) :-
+ (
+ LinkTargetType = shared_library,
+ CommandOpt = link_shared_lib_command,
+ RpathFlagOpt = shlib_linker_rpath_flag,
+ RpathSepOpt = shlib_linker_rpath_separator,
+ LDFlagsOpt = ld_libflags,
+ ThreadFlagsOpt = shlib_linker_thread_flags,
+ DebugFlagsOpt = shlib_linker_debug_flags,
+ TraceFlagsOpt = shlib_linker_trace_flags,
+ globals.io_lookup_bool_option(allow_undefined, AllowUndef, !IO),
+ (
+ AllowUndef = yes,
+ globals.io_lookup_string_option(
+ linker_allow_undefined_flag, UndefOpt, !IO)
+ ;
+ AllowUndef = no,
+ globals.io_lookup_string_option(
+ linker_error_undefined_flag, UndefOpt, !IO)
+ )
+ ;
+ LinkTargetType = executable,
+ CommandOpt = link_executable_command,
+ RpathFlagOpt = linker_rpath_flag,
+ RpathSepOpt = linker_rpath_separator,
+ LDFlagsOpt = ld_flags,
+ ThreadFlagsOpt = linker_thread_flags,
+ DebugFlagsOpt = linker_debug_flags,
+ TraceFlagsOpt = linker_trace_flags,
+ UndefOpt = ""
+ ),
+
+ % Should the executable be stripped?
+ globals.io_lookup_bool_option(strip, Strip, !IO),
+ (
+ LinkTargetType = executable,
+ Strip = yes
+ ->
+ globals.io_lookup_string_option(linker_strip_flag, StripOpt, !IO)
+ ;
+ StripOpt = ""
+ ),
+
+ globals.io_lookup_bool_option(target_debug, TargetDebug, !IO),
+ (
+ TargetDebug = yes,
+ globals.io_lookup_string_option(DebugFlagsOpt, DebugOpts, !IO)
+ ;
+ TargetDebug = no,
+ DebugOpts = ""
+ ),
+
+ % Should the executable be statically linked?
+ globals.io_lookup_string_option(linkage, Linkage, !IO),
+ (
+ LinkTargetType = executable,
+ Linkage = "static"
+ ->
+ globals.io_lookup_string_option(linker_static_flags, StaticOpts,
+ !IO)
+ ;
+ StaticOpts = ""
+ ),
+
+ % Are the thread libraries needed?
+ use_thread_libs(UseThreadLibs, !IO),
+ (
+ UseThreadLibs = yes,
+ globals.io_lookup_string_option(ThreadFlagsOpt, ThreadOpts, !IO)
+ ;
+ UseThreadLibs = no,
+ ThreadOpts = ""
+ ),
+
+ % Find the Mercury standard libraries.
+ globals.io_lookup_maybe_string_option(
+ mercury_standard_library_directory, MaybeStdLibDir, !IO),
+ (
+ MaybeStdLibDir = yes(StdLibDir),
+ get_mercury_std_libs(LinkTargetType, StdLibDir, MercuryStdLibs,
+ !IO)
+ ;
+ MaybeStdLibDir = no,
+ MercuryStdLibs = ""
+ ),
+
+ % Find which system libraries are needed.
+ get_system_libs(LinkTargetType, SystemLibs, !IO),
+
+ join_quoted_string_list(ObjectsList, "", "", " ", Objects),
+ globals.io_lookup_accumulating_option(LDFlagsOpt, LDFlagsList, !IO),
+ join_string_list(LDFlagsList, "", "", " ", LDFlags),
+ globals.io_lookup_accumulating_option(link_library_directories,
+ LinkLibraryDirectoriesList, !IO),
+ globals.io_lookup_string_option(linker_path_flag, LinkerPathFlag,
+ !IO),
+ join_quoted_string_list(LinkLibraryDirectoriesList, LinkerPathFlag, "",
+ " ", LinkLibraryDirectories),
+
+ % Set up the runtime library path.
+ globals.io_lookup_bool_option(shlib_linker_use_install_name,
+ UseInstallName, !IO),
+ shared_libraries_supported(SharedLibsSupported, !IO),
+ (
+ UseInstallName = no,
+ SharedLibsSupported = yes,
+ ( Linkage = "shared"
+ ; LinkTargetType = shared_library
+ )
+ ->
+ globals.io_lookup_accumulating_option(
+ runtime_link_library_directories, RpathDirs, !IO),
+ (
+ RpathDirs = [],
+ RpathOpts = ""
+ ;
+ RpathDirs = [_|_],
+ globals.io_lookup_string_option(RpathSepOpt, RpathSep, !IO),
+ globals.io_lookup_string_option(RpathFlagOpt, RpathFlag, !IO),
+ RpathOpts0 = string.join_list(RpathSep, RpathDirs),
+ RpathOpts = RpathFlag ++ RpathOpts0
+ )
+ ;
+ RpathOpts = ""
+ ),
+
+ % Set up the install name for shared libraries.
+ (
+ UseInstallName = yes,
+ LinkTargetType = shared_library
+ ->
+ % NOTE: `ShLibFileName' must *not* be prefixed with a directory.
+ % get_install_name_option will prefix it with the correct
+ % directory which is the one where the library is going to
+ % be installed, *not* where it is going to be built.
+ %
+ BaseFileName = sym_name_to_string(ModuleName),
+ globals.io_lookup_string_option(shared_library_extension,
+ SharedLibExt, !IO),
+ ShLibFileName = "lib" ++ BaseFileName ++ SharedLibExt,
+ get_install_name_option(ShLibFileName, InstallNameOpt, !IO)
+ ;
+ InstallNameOpt = ""
+ ),
+
+ globals.io_get_trace_level(TraceLevel, !IO),
+ ( given_trace_level_is_none(TraceLevel) = yes ->
+ TraceOpts = ""
+ ;
+ globals.io_lookup_string_option(TraceFlagsOpt, TraceOpts, !IO)
+ ),
+
+ % Pass either `-llib' or `PREFIX/lib/GRADE/liblib.a',
+ % depending on whether we are linking with static or shared
+ % Mercury libraries.
+
+ globals.io_lookup_accumulating_option(
+ mercury_library_directories, MercuryLibDirs0, !IO),
+ globals.io_get_globals(Globals, !IO),
+ grade_directory_component(Globals, GradeDir),
+ MercuryLibDirs = list.map(
+ (func(LibDir) = LibDir/"lib"/GradeDir),
+ MercuryLibDirs0),
+ globals.io_lookup_accumulating_option(link_libraries,
+ LinkLibrariesList0, !IO),
+ list.map_foldl2(process_link_library(MercuryLibDirs),
+ LinkLibrariesList0, LinkLibrariesList, yes,
+ LibrariesSucceeded, !IO),
+
+ globals.io_lookup_string_option(linker_opt_separator,
+ LinkOptSep, !IO),
+ (
+ LibrariesSucceeded = yes,
+ join_quoted_string_list(LinkLibrariesList, "", "", " ",
+ LinkLibraries),
+
+ % Note that LDFlags may contain `-l' options so it should come
+ % after Objects.
+ globals.io_lookup_string_option(CommandOpt, Command, !IO),
+ string.append_list(
+ [Command, " ",
+ StaticOpts, " ", StripOpt, " ", UndefOpt, " ",
+ ThreadOpts, " ", TraceOpts, " ",
+ " -o ", OutputFileName, " ", Objects, " ",
+ LinkOptSep, " ", LinkLibraryDirectories, " ",
+ RpathOpts, " ", InstallNameOpt, " ", DebugOpts,
+ " ", LDFlags, " ", LinkLibraries, " ",
+ MercuryStdLibs, " ", SystemLibs],
+ LinkCmd),
+
+ globals.io_lookup_bool_option(demangle, Demangle, !IO),
+ (
+ Demangle = yes,
+ globals.io_lookup_string_option(demangle_command,
+ DemangleCmd, !IO),
+ MaybeDemangleCmd = yes(DemangleCmd)
+ ;
+ Demangle = no,
+ MaybeDemangleCmd = no
+ ),
+
+ invoke_system_command_maybe_filter_output(ErrorStream,
+ cmd_verbose_commands, LinkCmd, MaybeDemangleCmd, LinkSucceeded,
+ !IO)
+ ;
+ LibrariesSucceeded = no,
+ LinkSucceeded = no
+ ).
+
% Find the standard Mercury libraries, and the system
% libraries needed by them.
%
@@ -1513,7 +1573,19 @@
get_mercury_std_libs(TargetType, StdLibDir, StdLibs, !IO) :-
globals.io_get_gc_method(GCMethod, !IO),
- globals.io_lookup_string_option(library_extension, LibExt, !IO),
+ (
+ ( TargetType = executable
+ ; TargetType = static_library
+ ; TargetType = shared_library
+ ),
+ globals.io_lookup_string_option(library_extension, LibExt, !IO)
+ ;
+ TargetType = java_archive,
+ unexpected(this_file, "get_mercury_std_libs: java_archive")
+ ;
+ TargetType = erlang_archive,
+ unexpected(this_file, "get_mercury_std_libs: erlang_archive")
+ ),
globals.io_get_globals(Globals, !IO),
grade_directory_component(Globals, GradeDir),
@@ -1617,23 +1689,28 @@
make_link_lib(TargetType, LibName, LinkOpt, !IO) :-
(
- TargetType = executable,
- LinkLibFlag = linker_link_lib_flag,
- LinkLibSuffix = linker_link_lib_suffix
- ;
- TargetType = shared_library,
- LinkLibFlag = shlib_linker_link_lib_flag,
- LinkLibSuffix = shlib_linker_link_lib_suffix
+ (
+ TargetType = executable,
+ LinkLibFlag = linker_link_lib_flag,
+ LinkLibSuffix = linker_link_lib_suffix
+ ;
+ TargetType = shared_library,
+ LinkLibFlag = shlib_linker_link_lib_flag,
+ LinkLibSuffix = shlib_linker_link_lib_suffix
+ ),
+ globals.io_lookup_string_option(LinkLibFlag, LinkLibOpt, !IO),
+ globals.io_lookup_string_option(LinkLibSuffix, Suffix, !IO),
+ LinkOpt = quote_arg(LinkLibOpt ++ LibName ++ Suffix)
;
TargetType = java_archive,
unexpected(this_file, "make_link_lib: java_archive")
;
+ TargetType = erlang_archive,
+ unexpected(this_file, "make_link_lib: erlang_archive")
+ ;
TargetType = static_library,
unexpected(this_file, "make_link_lib: static_library")
- ),
- globals.io_lookup_string_option(LinkLibFlag, LinkLibOpt, !IO),
- globals.io_lookup_string_option(LinkLibSuffix, Suffix, !IO),
- LinkOpt = quote_arg(LinkLibOpt ++ LibName ++ Suffix).
+ ).
:- pred get_system_libs(linked_target_type::in, string::out, io::di, io::uo)
is det.
@@ -1677,6 +1754,9 @@
TargetType = java_archive,
unexpected(this_file, "get_std_libs: java archive")
;
+ TargetType = erlang_archive,
+ unexpected(this_file, "get_std_libs: erlang archive")
+ ;
TargetType = executable,
globals.io_lookup_string_option(math_lib, OtherSystemLibs, !IO)
),
@@ -1708,6 +1788,7 @@
( LinkTargetType = static_library
; LinkTargetType = shared_library
; LinkTargetType = java_archive
+ ; LinkTargetType = erlang_archive
),
module_name_to_lib_file_name("lib", ModuleName, Ext, no,
UserDirFileName, !IO)
@@ -1724,7 +1805,7 @@
SameTimestamp = no,
io.set_output_stream(ErrorStream, OutputStream, !IO),
% Remove the target of the symlink/copy in case it already exists.
- io.remove_file(UserDirFileName, _, !IO),
+ io.remove_file_recursively(UserDirFileName, _, !IO),
make_symlink_or_copy_file(OutputFileName, UserDirFileName,
Succeeded, !IO),
io.set_output_stream(OutputStream, _, !IO),
@@ -1858,6 +1939,56 @@
invoke_system_command(ErrorStream, cmd_verbose_commands, Cmd, Succeeded,
!IO).
+%-----------------------------------------------------------------------------%
+
+ % Create an "Erlang archive", which is simply a directory containing
+ % `.beam' files.
+ %
+:- pred create_erlang_archive(io.output_stream::in, module_name::in,
+ file_name::in, list(file_name)::in, bool::out, io::di, io::uo) is det.
+
+create_erlang_archive(ErrorStream, _ModuleName, ErlangArchiveFileName,
+ ObjectList, Succeeded, !IO) :-
+ % Delete anything in the way first.
+ io.remove_file_recursively(ErlangArchiveFileName, _, !IO),
+ dir.make_directory(ErlangArchiveFileName, Res, !IO),
+ (
+ Res = ok,
+ copy_erlang_archive_files(ErrorStream, ErlangArchiveFileName,
+ ObjectList, Succeeded, !IO)
+ ;
+ Res = error(Error),
+ io.write_string(ErrorStream, "Error creating `", !IO),
+ io.write_string(ErrorStream, ErlangArchiveFileName, !IO),
+ io.write_string(ErrorStream, "': ", !IO),
+ io.write_string(ErrorStream, io.error_message(Error), !IO),
+ io.nl(ErrorStream, !IO),
+ Succeeded = no
+ ).
+
+:- pred copy_erlang_archive_files(io.output_stream::in, file_name::in,
+ list(file_name)::in, bool::out, io::di, io::uo) is det.
+
+copy_erlang_archive_files(_ErrorStream, _ErlangArchiveFileName, [], yes, !IO).
+copy_erlang_archive_files(ErrorStream, ErlangArchiveFileName, [Obj | Objs],
+ Succeeded, !IO) :-
+ copy_file(Obj, ErlangArchiveFileName, Res, !IO),
+ (
+ Res = ok,
+ copy_erlang_archive_files(ErrorStream, ErlangArchiveFileName, Objs,
+ Succeeded, !IO)
+ ;
+ Res = error(Error),
+ io.write_string(ErrorStream, "Error copying `", !IO),
+ io.write_string(ErrorStream, Obj, !IO),
+ io.write_string(ErrorStream, "': ", !IO),
+ io.write_string(ErrorStream, io.error_message(Error), !IO),
+ io.nl(ErrorStream, !IO),
+ Succeeded = no
+ ).
+
+%-----------------------------------------------------------------------------%
+
get_object_code_type(FileType, ObjectCodeType, !IO) :-
globals.io_lookup_string_option(pic_object_file_extension, PicObjExt, !IO),
globals.io_lookup_string_option(link_with_pic_object_file_extension,
@@ -1875,15 +2006,15 @@
;
PIC = no,
(
- FileType = static_library,
+ ( FileType = static_library
+ ; FileType = java_archive
+ ; FileType = erlang_archive
+ ),
ObjectCodeType = non_pic
;
FileType = shared_library,
ObjectCodeType = ( if PicObjExt = ObjExt then non_pic else pic )
;
- FileType = java_archive,
- ObjectCodeType = non_pic
- ;
FileType = executable,
( MercuryLinkage = "shared" ->
(
Index: compiler/elds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds.m,v
retrieving revision 1.4
diff -u -r1.4 elds.m
--- compiler/elds.m 28 May 2007 03:13:51 -0000 1.4
+++ compiler/elds.m 30 May 2007 03:00:01 -0000
@@ -63,9 +63,15 @@
---> elds_defn(
defn_proc_id :: pred_proc_id,
defn_varset :: prog_varset,
- defn_clause :: elds_clause
+ defn_body :: elds_body
).
+:- type elds_body
+ ---> body_defined_here(elds_clause)
+ % The body is to be defined by the user in some other way,
+ % e.g. foreign code.
+ ; body_external(arity).
+
% Foreign exported function definition.
%
:- type elds_foreign_export_defn
@@ -308,6 +314,8 @@
%
:- func det_expr(maybe(elds_expr)) = elds_expr.
+:- func elds_body_arity(elds_body) = arity.
+
:- func elds_clause_arity(elds_clause) = arity.
%-----------------------------------------------------------------------------%
@@ -382,6 +390,9 @@
det_expr(no) = _ :-
unexpected(this_file, "det_expr: no expression").
+elds_body_arity(body_defined_here(Clause)) = elds_clause_arity(Clause).
+elds_body_arity(body_external(Arity)) = Arity.
+
elds_clause_arity(elds_clause(Args, _Expr)) = list.length(Args).
%-----------------------------------------------------------------------------%
Index: compiler/elds_to_erlang.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds_to_erlang.m,v
retrieving revision 1.4
diff -u -r1.4 elds_to_erlang.m
--- compiler/elds_to_erlang.m 28 May 2007 03:13:51 -0000 1.4
+++ compiler/elds_to_erlang.m 30 May 2007 03:00:02 -0000
@@ -68,12 +68,7 @@
%-----------------------------------------------------------------------------%
output_elds(ModuleInfo, ELDS, !IO) :-
- %
- % The Erlang interactive shell doesn't like "." in filenames so we use "__"
- % instead.
- %
- ModuleName = erlang_module_name(ELDS ^ elds_name),
- module_name_to_file_name_sep(ModuleName, "__", ".erl", yes,
+ module_name_to_file_name(ELDS ^ elds_name, ".erl", yes,
SourceFileName, !IO),
output_to_file(SourceFileName, output_erl_file(ModuleInfo, ELDS,
SourceFileName), !IO).
@@ -128,7 +123,7 @@
bool::in, bool::out, io::di, io::uo) is det.
output_export_ann(ModuleInfo, Defn, !NeedComma, !IO) :-
- Defn = elds_defn(PredProcId, _, Clause),
+ Defn = elds_defn(PredProcId, _, Body),
PredProcId = proc(PredId, _ProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_import_status(PredInfo, ImportStatus),
@@ -139,7 +134,7 @@
nl_indent_line(1, !IO),
output_pred_proc_id(ModuleInfo, PredProcId, !IO),
io.write_char('/', !IO),
- io.write_int(elds_clause_arity(Clause), !IO),
+ io.write_int(elds_body_arity(Body), !IO),
!:NeedComma = yes
;
IsExported = no
@@ -182,10 +177,15 @@
%-----------------------------------------------------------------------------%
output_defn(ModuleInfo, Defn, !IO) :-
- Defn = elds_defn(PredProcId, VarSet, Clause),
- io.nl(!IO),
- output_pred_proc_id(ModuleInfo, PredProcId, !IO),
- output_toplevel_clause(ModuleInfo, VarSet, Clause, !IO).
+ Defn = elds_defn(PredProcId, VarSet, Body),
+ (
+ Body = body_defined_here(Clause),
+ io.nl(!IO),
+ output_pred_proc_id(ModuleInfo, PredProcId, !IO),
+ output_toplevel_clause(ModuleInfo, VarSet, Clause, !IO)
+ ;
+ Body = body_external(_Arity)
+ ).
:- pred output_foreign_export_defn(module_info::in,
elds_foreign_export_defn::in, io::di, io::uo) is det.
@@ -553,9 +553,19 @@
RttiProcName = rtti_proc_label(PredOrFunc, ThisModule, PredModule,
PredName, PredArity, _ArgTypes, _PredId, _ProcId,
_HeadVarsWithNames, _ArgModes, _Detism,
- PredIsImported, _PredIsPseudoImported,
+ PredIsImported0, _PredIsPseudoImported,
Origin, _ProcIsExported, _ProcIsImported),
+ % XXX I think pred_info_is_imported is wrong for status_external
+ % procedures
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_import_status(PredInfo, ImportStatus),
+ ( ImportStatus = status_external(_) ->
+ PredIsImported = no
+ ;
+ PredIsImported = PredIsImported0
+ ),
+
( Origin = origin_special_pred(SpecialPred) ->
erlang_special_proc_name(ThisModule, PredName, ProcId, SpecialPred,
MaybeExtModule, ProcNameStr)
@@ -659,19 +669,6 @@
erlang_module_name_to_str(ModuleName) =
sym_name_to_string_sep(erlang_module_name(ModuleName), "__").
-:- func erlang_module_name(module_name) = module_name.
-
-erlang_module_name(ModuleName) =
- % To avoid namespace collisions between Mercury standard modules and
- % Erlang standard modules, we pretend the Mercury standard modules are
- % in a "mercury" supermodule.
- %
- (if mercury_std_library_module_name(ModuleName) then
- add_outermost_qualifier("mercury", ModuleName)
- else
- ModuleName
- ).
-
%-----------------------------------------------------------------------------%
:- pred output_atom(string::in, io::di, io::uo) is det.
Index: compiler/erl_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_call_gen.m,v
retrieving revision 1.4
diff -u -r1.4 erl_call_gen.m
--- compiler/erl_call_gen.m 28 May 2007 03:13:51 -0000 1.4
+++ compiler/erl_call_gen.m 30 May 2007 03:00:02 -0000
@@ -374,11 +374,18 @@
CodeModel = model_det,
(
SimpleCode = assign(Lval, SimpleExpr),
- % XXX do we need to avoid generating assignments to dummy variables
- % introduced for types such as io.state here?
- Rval = erl_gen_simple_expr(SimpleExpr),
- Assign = elds.elds_eq(elds.expr_from_var(Lval), Rval),
- Statement = maybe_join_exprs(Assign, MaybeSuccessExpr)
+ (
+ % We need to avoid generating assignments to dummy variables
+ % introduced for types such as io.state.
+ erl_variable_type(!.Info, Lval, LvalType),
+ is_dummy_argument_type(ModuleInfo, LvalType)
+ ->
+ Statement = expr_or_void(MaybeSuccessExpr)
+ ;
+ Rval = erl_gen_simple_expr(SimpleExpr),
+ Assign = elds.elds_eq(elds.expr_from_var(Lval), Rval),
+ Statement = maybe_join_exprs(Assign, MaybeSuccessExpr)
+ )
;
SimpleCode = ref_assign(_AddrLval, _ValueLval),
unexpected(this_file, "ref_assign not supported in Erlang backend")
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.4
diff -u -r1.4 erl_code_gen.m
--- compiler/erl_code_gen.m 28 May 2007 03:13:51 -0000 1.4
+++ compiler/erl_code_gen.m 30 May 2007 03:00:02 -0000
@@ -23,8 +23,7 @@
% TODO: (this is incomplete)
% - contexts are ignored at the moment
% - RTTI
-% - type classes
-% - many scope types not yet supported
+% - some scope types not yet supported
% - trace runtime conditions
%
%-----------------------------------------------------------------------------%
@@ -50,6 +49,7 @@
:- implementation.
:- import_module backend_libs.foreign.
+:- import_module check_hlds.type_util.
:- import_module erl_backend.erl_call_gen.
:- import_module erl_backend.erl_code_util.
:- import_module erl_backend.erl_unify_gen.
@@ -191,16 +191,16 @@
proc_info::in, list(elds_defn)::in, list(elds_defn)::out) is det.
erl_gen_proc(ModuleInfo, PredId, ProcId, _PredInfo, _ProcInfo, !Defns) :-
- erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcClause),
- ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet, ProcClause),
+ erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcBody),
+ ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet, ProcBody),
!:Defns = [ProcDefn | !.Defns].
% Generate an ELDS definition for the specified procedure.
%
:- pred erl_gen_proc_defn(module_info::in, pred_id::in, proc_id::in,
- prog_varset::out, elds_clause::out) is det.
+ prog_varset::out, elds_body::out) is det.
-erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcClause) :-
+erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcBody) :-
module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
pred_info_get_import_status(PredInfo, ImportStatus),
proc_info_interface_code_model(ProcInfo, CodeModel),
@@ -227,10 +227,16 @@
!:Info = erl_gen_info_init(ModuleInfo, PredId, ProcId),
( ImportStatus = status_external(_) ->
- sorry(this_file, "external procedures in Erlang backend")
+ % This procedure is externally defined.
+ pred_info_get_arg_types(PredInfo, ArgTypes),
+ proc_info_get_argmodes(ProcInfo, ArgModes),
+ erl_gen_arg_list(ModuleInfo, opt_dummy_args,
+ HeadVars, ArgTypes, ArgModes, InputArgs, _OutputArgs),
+ ProcBody = body_external(list.length(InputArgs))
;
erl_gen_proc_body(CodeModel, InstMap0, Goal, ProcClause,
- !Info)
+ !Info),
+ ProcBody = body_defined_here(ProcClause)
),
erl_gen_info_get_varset(!.Info, ProcVarSet)
@@ -240,7 +246,6 @@
elds_clause::out, erl_gen_info::in, erl_gen_info::out) is det.
erl_gen_proc_body(CodeModel, InstMap0, Goal, ProcClause, !Info) :-
- Goal = hlds_goal(_, GoalInfo),
erl_gen_info_get_input_vars(!.Info, InputVars),
erl_gen_info_get_output_vars(!.Info, OutputVars),
OutputVarsExprs = exprs_from_vars(OutputVars),
@@ -252,14 +257,7 @@
%
% On success, the procedure returns a tuple of its output variables.
%
- goal_info_get_determinism(GoalInfo, Detism),
- ( Detism = detism_erroneous ->
- % This procedure can't succeed.
- MaybeSuccessExpr = no
- ;
- SuccessExpr = elds_term(elds_tuple(OutputVarsExprs)),
- MaybeSuccessExpr = yes(SuccessExpr)
- )
+ SuccessExpr = elds_term(elds_tuple(OutputVarsExprs))
;
CodeModel = model_non,
%
@@ -270,10 +268,9 @@
erl_gen_info_new_named_var("SucceedHeadVar", SucceedVar, !Info),
InputVarsTerms = terms_from_vars(InputVars ++ [SucceedVar]),
SuccessExpr = elds_call(elds_call_ho(expr_from_var(SucceedVar)),
- OutputVarsExprs),
- MaybeSuccessExpr = yes(SuccessExpr)
+ OutputVarsExprs)
),
- erl_gen_goal(CodeModel, InstMap0, Goal, MaybeSuccessExpr, Statement,
+ erl_gen_goal(CodeModel, InstMap0, Goal, yes(SuccessExpr), Statement,
!Info),
ProcClause = elds_clause(InputVarsTerms, Statement).
@@ -294,7 +291,7 @@
% On failure, model_semi code returns the atom `fail'.
% On failure, model_non code may return anything.
%
-erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExpr, Code, !Info) :-
+erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExpr0, Code, !Info) :-
Goal = hlds_goal(GoalExpr, GoalInfo),
goal_info_get_context(GoalInfo, Context),
goal_info_get_code_model(GoalInfo, GoalCodeModel),
@@ -312,20 +309,32 @@
->
unexpected(this_file, "erl_gen_goal: code model mismatch")
;
- erl_gen_goal_expr(GoalExpr, GoalCodeModel, InstMap, Context,
- MaybeSuccessExpr, Code, !Info)
+ goal_info_get_determinism(GoalInfo, Determinism),
+ (
+ Determinism = detism_erroneous
+ ->
+ % This goal can't succeed. Don't pass a success expression
+ % which, if inserted into the generated code, could contain
+ % references to unbound variables (since the goal may have
+ % aborted before binding them).
+ MaybeSuccessExpr = no
+ ;
+ MaybeSuccessExpr = MaybeSuccessExpr0
+ ),
+ erl_gen_goal_expr(GoalExpr, GoalCodeModel, Determinism, InstMap,
+ Context, MaybeSuccessExpr, Code, !Info)
).
%-----------------------------------------------------------------------------%
% Generate code for a commit.
%
-:- pred erl_gen_commit(hlds_goal::in, code_model::in, instmap::in,
- prog_context::in, maybe(elds_expr)::in, elds_expr::out,
+:- pred erl_gen_commit(hlds_goal::in, code_model::in, determinism::in,
+ instmap::in, prog_context::in, maybe(elds_expr)::in, elds_expr::out,
erl_gen_info::in, erl_gen_info::out) is det.
-erl_gen_commit(Goal, CodeModel, InstMap, Context, MaybeSuccessExpr,
- Statement, !Info) :-
+erl_gen_commit(Goal, CodeModel, ScopeDetism, InstMap, Context,
+ MaybeSuccessExpr, Statement, !Info) :-
Goal = hlds_goal(_, GoalInfo),
goal_info_get_code_model(GoalInfo, GoalCodeModel),
goal_info_get_context(GoalInfo, _GoalContext),
@@ -334,30 +343,46 @@
GoalCodeModel = model_non,
CodeModel = model_semi
->
- % model_non in semi context:
- % <succeeded = Goal>
- % ===>
- %
- % let Throw = ``throw({'MERCURY_COMMIT', {NonLocals, ...})''
- % where NonLocals are variables bound by Goal.
- %
- % try
- % <Goal && Throw()>
- % of
- % _ -> fail
- % catch
- % throw: {'MERCURY_COMMIT', {NonLocals, ...}} ->
- % SuccessExpr
- % end
-
- erl_gen_commit_pieces(Goal, InstMap, Context, no,
- GoalStatement, PackedNonLocals, !Info),
-
- Statement = elds_try(GoalStatement, [AnyCase], Catch),
- AnyCase = elds_case(elds_anon_var, elds_term(elds_fail)),
- Catch = elds_catch(elds_throw_atom,
- elds_tuple([elds_commit_marker, PackedNonLocals]),
- det_expr(MaybeSuccessExpr))
+ ( ScopeDetism = detism_failure ->
+ % If the scope has determinism `failure' then Goal can't succeed.
+ % The code is probably implementing a failure driven loop or
+ % something similar. No commit is required.
+ %
+ % model_non in failure context:
+ % <succeeded = Goal>
+ % ===>
+ % <Goal && SUCCEED()>,
+ % fail
+ %
+ erl_gen_goal(GoalCodeModel, InstMap, Goal, MaybeSuccessExpr,
+ GoalStatement, !Info),
+ Statement = join_exprs(GoalStatement, elds_term(elds_fail))
+ ;
+ % model_non in semi context:
+ % <succeeded = Goal>
+ % ===>
+ %
+ % let Throw = ``throw({'MERCURY_COMMIT', {NonLocals, ...})''
+ % where NonLocals are variables bound by Goal.
+ %
+ % try
+ % <Goal && Throw()>
+ % of
+ % _ -> fail
+ % catch
+ % throw: {'MERCURY_COMMIT', {NonLocals, ...}} ->
+ % SuccessExpr
+ % end
+
+ erl_gen_commit_pieces(Goal, InstMap, Context, no,
+ GoalStatement, PackedNonLocals, !Info),
+
+ Statement = elds_try(GoalStatement, [AnyCase], Catch),
+ AnyCase = elds_case(elds_anon_var, elds_term(elds_fail)),
+ Catch = elds_catch(elds_throw_atom,
+ elds_tuple([elds_commit_marker, PackedNonLocals]),
+ det_expr(MaybeSuccessExpr))
+ )
;
GoalCodeModel = model_non,
CodeModel = model_det
@@ -426,74 +451,73 @@
% Generate ELDS code for the different kinds of HLDS goals.
%
-:- pred erl_gen_goal_expr(hlds_goal_expr::in, code_model::in, instmap::in,
- prog_context::in, maybe(elds_expr)::in, elds_expr::out,
- erl_gen_info::in, erl_gen_info::out) is det.
+:- pred erl_gen_goal_expr(hlds_goal_expr::in, code_model::in, determinism::in,
+ instmap::in, prog_context::in, maybe(elds_expr)::in,
+ elds_expr::out, erl_gen_info::in, erl_gen_info::out) is det.
-erl_gen_goal_expr(switch(Var, CanFail, CasesList), CodeModel, InstMap,
- Context, MaybeSuccessExpr, Statement, !Info) :-
+erl_gen_goal_expr(switch(Var, CanFail, CasesList), CodeModel, _Detism,
+ InstMap, Context, MaybeSuccessExpr, Statement, !Info) :-
erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap,
Context, MaybeSuccessExpr, Statement, !Info).
-erl_gen_goal_expr(scope(ScopeReason, Goal), CodeModel, InstMap, Context,
- MaybeSuccessExpr, Statement, !Info) :-
+erl_gen_goal_expr(scope(ScopeReason, Goal), CodeModel, Detism, InstMap,
+ Context, MaybeSuccessExpr, Statement, !Info) :-
(
- ScopeReason = exist_quant(_),
- sorry(this_file, "exist_quant scope in erlang code generator")
- ;
- ScopeReason = promise_solutions(_, _),
- sorry(this_file, "promise_solutions scope in erlang code generator")
- ;
ScopeReason = trace_goal(_, _, _, _, _),
sorry(this_file, "trace_goal scope in erlang code generator")
;
- ScopeReason = commit(_),
- erl_gen_commit(Goal, CodeModel, InstMap, Context,
+ ( ScopeReason = promise_solutions(_, _)
+ ; ScopeReason = commit(_)
+ ),
+ erl_gen_commit(Goal, CodeModel, Detism, InstMap, Context,
MaybeSuccessExpr, Statement, !Info)
;
- ( ScopeReason = promise_purity(_, _)
+ ( ScopeReason = exist_quant(_)
+ ; ScopeReason = promise_purity(_, _)
; ScopeReason = barrier(_)
; ScopeReason = from_ground_term(_)
),
- Goal = hlds_goal(GoalExpr, _),
- erl_gen_goal_expr(GoalExpr, CodeModel, InstMap, Context,
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ goal_info_get_determinism(GoalInfo, GoalDetism),
+ erl_gen_goal_expr(GoalExpr, CodeModel, GoalDetism, InstMap, Context,
MaybeSuccessExpr, Statement, !Info)
).
-erl_gen_goal_expr(if_then_else(_Vars, Cond, Then, Else), CodeModel,
+erl_gen_goal_expr(if_then_else(_Vars, Cond, Then, Else), CodeModel, _Detism,
InstMap, Context, MaybeSuccessExpr, Statement, !Info) :-
erl_gen_ite(CodeModel, InstMap, Cond, Then, Else, Context,
MaybeSuccessExpr, Statement, !Info).
-erl_gen_goal_expr(negation(Goal), CodeModel, InstMap, Context,
+erl_gen_goal_expr(negation(Goal), CodeModel, _Detism, InstMap, Context,
MaybeSuccessExpr, Statement, !Info) :-
erl_gen_negation(Goal, CodeModel, InstMap, Context, MaybeSuccessExpr,
Statement, !Info).
-erl_gen_goal_expr(conj(_ConjType, Goals), CodeModel, InstMap, Context,
+erl_gen_goal_expr(conj(_ConjType, Goals), CodeModel, _Detism, InstMap, Context,
MaybeSuccessExpr, Statement, !Info) :-
% XXX Currently we treat parallel conjunction the same as
% sequential conjunction -- parallelism is not yet implemented.
erl_gen_conj(Goals, CodeModel, InstMap, Context, MaybeSuccessExpr,
Statement, !Info).
-erl_gen_goal_expr(disj(Goals), CodeModel, InstMap, Context,
+erl_gen_goal_expr(disj(Goals), CodeModel, _Detism, InstMap, Context,
MaybeSuccessExpr, Statement, !Info) :-
erl_gen_disj(Goals, CodeModel, InstMap, Context, MaybeSuccessExpr,
Statement, !Info).
-erl_gen_goal_expr(generic_call(GenericCall, Vars, Modes, Detism),
- CodeModel, _InstMap, Context, MaybeSuccessExpr, Statement, !Info) :-
- determinism_to_code_model(Detism, CallCodeModel),
+erl_gen_goal_expr(generic_call(GenericCall, Vars, Modes, CallDetism),
+ CodeModel, _Detism, _InstMap, Context, MaybeSuccessExpr, Statement,
+ !Info) :-
+ determinism_to_code_model(CallDetism, CallCodeModel),
expect(unify(CodeModel, CallCodeModel), this_file,
"erl_gen_generic_call: code model mismatch"),
(
GenericCall = higher_order(_, _, _, _),
- erl_gen_higher_order_call(GenericCall, Vars, Modes, Detism,
+ erl_gen_higher_order_call(GenericCall, Vars, Modes, CallDetism,
Context, MaybeSuccessExpr, Statement, !Info)
;
GenericCall = class_method(_, _, _, _),
- erl_gen_class_method_call(GenericCall, Vars, Modes, Detism,
+ erl_gen_class_method_call(GenericCall, Vars, Modes, CallDetism,
Context, MaybeSuccessExpr, Statement, !Info)
;
GenericCall = event_call(_),
@@ -504,7 +528,8 @@
).
erl_gen_goal_expr(plain_call(PredId, ProcId, ArgVars, BuiltinState, _, _),
- CodeModel, _InstMap, Context, MaybeSuccessExpr, Statement, !Info) :-
+ CodeModel, _Detism, _InstMap, Context, MaybeSuccessExpr, Statement,
+ !Info) :-
(
BuiltinState = not_builtin,
erl_variable_types(!.Info, ArgVars, ActualArgTypes),
@@ -520,18 +545,19 @@
).
erl_gen_goal_expr(unify(_LHS, _RHS, _Mode, Unification, _UnifyContext),
- CodeModel, _InstMap, Context, MaybeSuccessExpr, Statement, !Info) :-
+ CodeModel, _Detism, _InstMap, Context, MaybeSuccessExpr, Statement,
+ !Info) :-
erl_gen_unification(Unification, CodeModel, Context, MaybeSuccessExpr,
Statement, !Info).
erl_gen_goal_expr(
call_foreign_proc(_Attributes, _PredId, _ProcId, Args, _ExtraArgs,
- MaybeTraceRuntimeCond, PragmaImpl), CodeModel, _InstMap,
+ MaybeTraceRuntimeCond, PragmaImpl), CodeModel, _Detism, _InstMap,
OuterContext, MaybeSuccessExpr, Statement, !Info) :-
erl_gen_foreign_code_call(Args, MaybeTraceRuntimeCond, PragmaImpl,
CodeModel, OuterContext, MaybeSuccessExpr, Statement, !Info).
-erl_gen_goal_expr(shorthand(_), _, _, _, _, _, !Info) :-
+erl_gen_goal_expr(shorthand(_), _, _, _, _, _, _, !Info) :-
% these should have been expanded out by now
unexpected(this_file, "erl_gen_goal_expr: unexpected shorthand").
@@ -542,7 +568,13 @@
:- func duplicate_expr_limit = int.
-duplicate_expr_limit = 10. % XXX arbitrary
+ % XXX duplicating expressions into branches of disjunctions and switches
+ % is currently disabled. The problem is that the duplicated expression
+ % may bind local variables. These would need to be renamed apart when
+ % the expression is duplicated.
+ %
+duplicate_expr_limit = 0.
+%duplicate_expr_limit = 10. % XXX arbitrary
:- pred erl_gen_switch(prog_var::in, can_fail::in, list(hlds_goal.case)::in,
code_model::in, instmap::in, prog_context::in, maybe(elds_expr)::in,
@@ -578,36 +610,16 @@
% _ -> fail
%
- % Get the union of all variables bound in all cases.
+ % Get the union of all nonlocal variables bound in all cases.
erl_gen_info_get_module_info(!.Info, ModuleInfo),
CasesGoals = list.map((func(case(_, Goal)) = Goal), CasesList),
union_bound_nonlocals_in_goals(ModuleInfo, InstMap, CasesGoals,
NonLocalsBoundInCases),
- (if
- MaybeSuccessExpr0 = yes(SuccessExpr0),
- erl_expr_size(SuccessExpr0) > duplicate_expr_limit
- then
- erl_gen_info_new_named_var("SuccessClosure", ClosureVar, !Info),
- ClosureVarExpr = expr_from_var(ClosureVar),
- ClosureArgs = set.to_sorted_list(NonLocalsBoundInCases),
- ClosureArgsTerms = terms_from_vars(ClosureArgs),
- ClosureArgsExprs = exprs_from_vars(ClosureArgs),
-
- % ``SuccessClosure = fun(ClosureArgs, ...) -> SuccessExpr0 end''
- MakeClosure = elds_eq(ClosureVarExpr, ClosureFun),
- ClosureFun = elds_fun(elds_clause(ClosureArgsTerms, SuccessExpr0)),
-
- % ``SuccessClosure(ClosureArgs, ...)''
- CallClosure = elds_call(elds_call_ho(ClosureVarExpr),
- ClosureArgsExprs),
-
- MaybeMakeClosure = yes(MakeClosure),
- MaybeSuccessExpr = yes(CallClosure)
- else
- MaybeMakeClosure = no,
- MaybeSuccessExpr = MaybeSuccessExpr0
- ),
+ % Create a closure for the success expression if it is too large to
+ % duplicate into the disjuncts.
+ maybe_create_closure_for_success_expr(NonLocalsBoundInCases,
+ MaybeSuccessExpr0, MaybeMakeClosure, MaybeSuccessExpr, !Info),
% Generate code for each case.
list.map_foldl(erl_gen_case(CodeModel, InstMap, NonLocalsBoundInCases,
@@ -632,14 +644,6 @@
Statement = CaseExpr
).
-:- pred union_bound_nonlocals_in_goals(module_info::in, instmap::in,
- hlds_goals::in, set(prog_var)::out) is det.
-
-union_bound_nonlocals_in_goals(ModuleInfo, InstMap, Goals, NonLocalsUnion) :-
- IsBound = erl_bound_nonlocals_in_goal(ModuleInfo, InstMap),
- list.map(IsBound, Goals, NonLocalsLists),
- NonLocalsUnion = set.union_list(NonLocalsLists).
-
:- pred erl_gen_case(code_model::in, instmap::in, set(prog_var)::in,
maybe(elds_expr)::in, hlds_goal.case::in, elds_case::out,
erl_gen_info::in, erl_gen_info::out) is det.
@@ -670,6 +674,59 @@
ELDSCase = elds_case(Pattern, Statement).
%-----------------------------------------------------------------------------%
+% This code is shared by disjunctions and switches.
+
+:- pred union_bound_nonlocals_in_goals(module_info::in, instmap::in,
+ hlds_goals::in, set(prog_var)::out) is det.
+
+union_bound_nonlocals_in_goals(ModuleInfo, InstMap, Goals, NonLocalsUnion) :-
+ IsBound = erl_bound_nonlocals_in_goal(ModuleInfo, InstMap),
+ list.map(IsBound, Goals, NonLocalsLists),
+ NonLocalsUnion = set.union_list(NonLocalsLists).
+
+:- pred maybe_create_closure_for_success_expr(set(prog_var)::in,
+ maybe(elds_expr)::in, maybe(elds_expr)::out, maybe(elds_expr)::out,
+ erl_gen_info::in, erl_gen_info::out) is det.
+
+maybe_create_closure_for_success_expr(NonLocals, MaybeSuccessExpr0,
+ MaybeMakeClosure, MaybeSuccessExpr, !Info) :-
+ (if
+ MaybeSuccessExpr0 = yes(SuccessExpr0),
+ erl_expr_size(SuccessExpr0) > duplicate_expr_limit
+ then
+ erl_gen_info_new_named_var("SuccessClosure", ClosureVar, !Info),
+ ClosureVarExpr = expr_from_var(ClosureVar),
+ ClosureArgs0 = set.to_sorted_list(NonLocals),
+
+ % Ignore dummy variables.
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ erl_variable_types(!.Info, ClosureArgs0, ClosureArgsTypes),
+ ClosureArgs = list.filter_map_corresponding(non_dummy_var(ModuleInfo),
+ ClosureArgs0, ClosureArgsTypes),
+ ClosureArgsTerms = terms_from_vars(ClosureArgs),
+ ClosureArgsExprs = exprs_from_vars(ClosureArgs),
+
+ % ``SuccessClosure = fun(ClosureArgs, ...) -> SuccessExpr0 end''
+ MakeClosure = elds_eq(ClosureVarExpr, ClosureFun),
+ ClosureFun = elds_fun(elds_clause(ClosureArgsTerms, SuccessExpr0)),
+
+ % ``SuccessClosure(ClosureArgs, ...)''
+ CallClosure = elds_call(elds_call_ho(ClosureVarExpr),
+ ClosureArgsExprs),
+
+ MaybeMakeClosure = yes(MakeClosure),
+ MaybeSuccessExpr = yes(CallClosure)
+ else
+ MaybeMakeClosure = no,
+ MaybeSuccessExpr = MaybeSuccessExpr0
+ ).
+
+:- func non_dummy_var(module_info, prog_var, mer_type) = prog_var is semidet.
+
+non_dummy_var(ModuleInfo, Var, Type) = Var :-
+ not is_dummy_argument_type(ModuleInfo, Type).
+
+%-----------------------------------------------------------------------------%
%
% Code for if-then-else
%
@@ -692,10 +749,16 @@
CondCodeModel = model_det,
erl_gen_goal(model_det, InstMap0, Cond, no, CondStatement, !Info),
- update_instmap(Cond, InstMap0, CondInstMap),
- erl_gen_goal(CodeModel, CondInstMap, Then, MaybeSuccessExpr,
- ThenStatement, !Info),
- Statement = join_exprs(CondStatement, ThenStatement)
+ goal_info_get_determinism(CondGoalInfo, CondDeterminism),
+ ( CondDeterminism = detism_erroneous ->
+ % The `Then' code is unreachable.
+ Statement = CondStatement
+ ;
+ update_instmap(Cond, InstMap0, CondInstMap),
+ erl_gen_goal(CodeModel, CondInstMap, Then, MaybeSuccessExpr,
+ ThenStatement, !Info),
+ Statement = join_exprs(CondStatement, ThenStatement)
+ )
;
% model_semi cond:
% <(Cond -> Then ; Else)>
@@ -1003,9 +1066,49 @@
erl_gen_goal(CodeModel, InstMap, SingleGoal, MaybeSuccessExpr,
Statement, !Info).
-erl_gen_disj([First | Rest], CodeModel, InstMap, Context, MaybeSuccessExpr,
+erl_gen_disj([First | Rest], CodeModel, InstMap, Context, MaybeSuccessExpr0,
Statement, !Info) :-
Rest = [_ | _],
+
+ % Get the union of all nonlocal variables bound in all disjuncts.
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ union_bound_nonlocals_in_goals(ModuleInfo, InstMap, [First | Rest],
+ NonLocalsBoundInGoals),
+
+ % Create a closure for the success expression if it is too large to
+ % duplicate into the disjuncts.
+ maybe_create_closure_for_success_expr(NonLocalsBoundInGoals,
+ MaybeSuccessExpr0, MaybeMakeClosure, MaybeSuccessExpr, !Info),
+
+ erl_gen_disjunct([First | Rest], CodeModel, InstMap, Context,
+ MaybeSuccessExpr, DisjStatement, !Info),
+ (
+ MaybeMakeClosure = no,
+ Statement = DisjStatement
+ ;
+ MaybeMakeClosure = yes(MakeClosure1),
+ Statement = join_exprs(MakeClosure1, DisjStatement)
+ ).
+
+:- pred erl_gen_disjunct(hlds_goals::in, code_model::in, instmap::in,
+ prog_context::in, maybe(elds_expr)::in, elds_expr::out,
+ erl_gen_info::in, erl_gen_info::out) is det.
+
+erl_gen_disjunct([], CodeModel, _InstMap, _Context,
+ _MaybeSuccessExpr, Statement, !Info) :-
+ % Handle empty disjunctions (a.ka. `fail').
+ (
+ CodeModel = model_det,
+ unexpected(this_file, "erl_gen_disj: `fail' has determinism `det'")
+ ;
+ ( CodeModel = model_semi
+ ; CodeModel = model_non
+ ),
+ Statement = elds_term(elds_fail)
+ ).
+
+erl_gen_disjunct([First | Rest], CodeModel, InstMap, Context,
+ MaybeSuccessExpr, Statement, !Info) :-
(
( CodeModel = model_det
; CodeModel = model_semi
@@ -1034,6 +1137,7 @@
First = hlds_goal(_, FirstGoalInfo),
goal_info_get_code_model(FirstGoalInfo, FirstCodeModel),
+ goal_info_get_determinism(FirstGoalInfo, FirstDeterminism),
(
FirstCodeModel = model_det,
erl_gen_goal(model_det, InstMap, First, MaybeSuccessExpr,
@@ -1041,10 +1145,16 @@
;
FirstCodeModel = model_semi,
- erl_gen_goal(CodeModel, InstMap, First, MaybeSuccessExpr,
+ % If the outer code model is model_det then we might not have a
+ % success expression. Then make up one while generating the
+ % model_semi first goal. It doesn't matter what the value is,
+ % otherwise MaybeSuccessExpr wouldn't have been `no'.
+ %
+ SuccessExpr = expr_or_void(MaybeSuccessExpr),
+ erl_gen_goal(model_semi, InstMap, First, yes(SuccessExpr),
FirstStatement0, !Info),
- erl_gen_disj(Rest, CodeModel, InstMap, Context, MaybeSuccessExpr,
- RestStatement, !Info),
+ erl_gen_disjunct(Rest, CodeModel, InstMap, Context,
+ MaybeSuccessExpr, RestStatement, !Info),
% Need to do some renaming otherwise FirstStatement and
% RestStatement end up binding the same variables which triggers a
@@ -1057,10 +1167,22 @@
erl_create_renaming(FirstVars, Subn, !Info),
erl_rename_vars_in_expr(Subn, FirstStatement0, FirstStatement),
- erl_gen_info_new_named_var("Any", AnyVar, !Info),
- Statement = elds_case_expr(FirstStatement, [FailCase, OtherCase]),
- FailCase = elds_case(elds_fail, RestStatement),
- OtherCase = elds_case(term_from_var(AnyVar), expr_from_var(AnyVar))
+ ( FirstDeterminism = detism_failure ->
+ % Special case the situation when the first disjunct has
+ % determinism `failure'. This can avoid some spurious
+ % warnings from the Erlang compiler about "unsafe" variables
+ % (it doesn't know that a particular branch of a case
+ % statement will always be taken and therefore it doesn't
+ % matter that some variables aren't bound in other branches).
+ Statement = join_exprs(FirstStatement0, RestStatement)
+ ;
+ erl_gen_info_new_named_var("Any", AnyVar, !Info),
+ Statement = elds_case_expr(FirstStatement,
+ [FailCase, OtherCase]),
+ FailCase = elds_case(elds_fail, RestStatement),
+ OtherCase = elds_case(term_from_var(AnyVar),
+ expr_from_var(AnyVar))
+ )
;
FirstCodeModel = model_non,
% simplify.m should get wrap commits around these.
@@ -1090,7 +1212,7 @@
erl_rename_vars_in_expr(Subst, FirstStatement0, FirstStatement),
% Generate the rest of the disjunction.
- erl_gen_disj(Rest, model_non, InstMap, Context, MaybeSuccessExpr,
+ erl_gen_disjunct(Rest, model_non, InstMap, Context, MaybeSuccessExpr,
RestStatements, !Info),
Statement = join_exprs(FirstStatement, RestStatements)
@@ -1118,8 +1240,8 @@
(
search_elds_defn(ProcDefns, PredProcId, TargetProc)
->
- TargetProc = elds_defn(_TargetPPId, _TargetVarSet, TargetClause),
- Arity = elds_clause_arity(TargetClause),
+ TargetProc = elds_defn(_TargetPPId, _TargetVarSet, TargetBody),
+ Arity = elds_body_arity(TargetBody),
% ``Name(Vars, ...) -> PredProcId(Vars, ...)''
varset.new_vars(varset.init, Arity, Vars, VarSet),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.299
diff -u -r1.299 handle_options.m
--- compiler/handle_options.m 7 May 2007 06:59:23 -0000 1.299
+++ compiler/handle_options.m 30 May 2007 03:00:02 -0000
@@ -2380,13 +2380,7 @@
highlevel_code - bool(yes),
highlevel_data - bool(yes)],
yes([string("java")]), yes).
-grade_component_table("erlang", comp_gcc_ext, [
- asm_labels - bool(no),
- gcc_non_local_gotos - bool(no),
- gcc_global_registers - bool(no),
- gcc_nested_functions - bool(no),
- highlevel_code - bool(no),
- highlevel_data - bool(no)],
+grade_component_table("erlang", comp_gcc_ext, [],
yes([string("erlang")]), yes).
% Parallelism/multithreading components.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.225
diff -u -r1.225 hlds_pred.m
--- compiler/hlds_pred.m 17 May 2007 03:52:43 -0000 1.225
+++ compiler/hlds_pred.m 30 May 2007 03:00:02 -0000
@@ -854,7 +854,8 @@
proc_id_to_int(ModeId, ModeInt).
status_is_exported(status_imported(_)) = no.
-status_is_exported(status_external(_)) = no.
+status_is_exported(status_external(Status)) =
+ status_is_exported(Status).
status_is_exported(status_abstract_imported) = no.
status_is_exported(status_pseudo_imported) = no.
status_is_exported(status_opt_imported) = no.
@@ -878,7 +879,8 @@
status_is_imported(Status) = bool.not(status_defined_in_this_module(Status)).
status_defined_in_this_module(status_imported(_)) = no.
-status_defined_in_this_module(status_external(_)) = no.
+status_defined_in_this_module(status_external(Status)) =
+ status_defined_in_this_module(Status).
status_defined_in_this_module(status_abstract_imported) = no.
status_defined_in_this_module(status_pseudo_imported) = no.
status_defined_in_this_module(status_opt_imported) = no.
Index: compiler/make.dependencies.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.dependencies.m,v
retrieving revision 1.37
diff -u -r1.37 make.dependencies.m
--- compiler/make.dependencies.m 18 May 2007 03:03:31 -0000 1.37
+++ compiler/make.dependencies.m 30 May 2007 03:00:02 -0000
@@ -200,6 +200,12 @@
]).
target_dependencies(Globals, module_target_java_code) =
compiled_code_dependencies(Globals).
+target_dependencies(Globals, module_target_erlang_code) =
+ compiled_code_dependencies(Globals).
+target_dependencies(_, module_target_erlang_beam_code) =
+ combine_deps_list([
+ module_target_erlang_code `of` self
+ ]).
target_dependencies(Globals, module_target_asm_code(_)) =
compiled_code_dependencies(Globals).
target_dependencies(Globals, module_target_object_code(PIC)) = Deps :-
Index: compiler/make.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.m,v
retrieving revision 1.46
diff -u -r1.46 make.m
--- compiler/make.m 4 Mar 2007 23:37:57 -0000 1.46
+++ compiler/make.m 30 May 2007 03:00:02 -0000
@@ -177,6 +177,8 @@
; module_target_il_code
; module_target_il_asm
; module_target_java_code
+ ; module_target_erlang_code
+ ; module_target_erlang_beam_code
; module_target_asm_code(pic)
; module_target_object_code(pic)
; module_target_foreign_il_asm(foreign_language)
@@ -398,6 +400,12 @@
ModuleNameStr = ModuleNameStr0,
TargetType = linked_target(executable)
;
+ Suffix = ".beams",
+ string.append("lib", ModuleNameStr1, ModuleNameStr0)
+ ->
+ ModuleNameStr = ModuleNameStr1,
+ TargetType = linked_target(erlang_archive)
+ ;
string.append(Suffix1, "s", Suffix),
yes(Suffix1) = target_extension(Globals, ModuleTargetType),
% Not yet implemented. `build_all' targets are only used by
Index: compiler/make.module_target.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_target.m,v
retrieving revision 1.54
diff -u -r1.54 make.module_target.m
--- compiler/make.module_target.m 7 May 2007 05:21:31 -0000 1.54
+++ compiler/make.module_target.m 30 May 2007 03:00:02 -0000
@@ -473,9 +473,11 @@
build_object_code(_ModuleName, target_x86_64, _, _ErrorStream, _Imports,
_Succeeded, _, _) :-
sorry(this_file, "NYI mmc --make and target x86_64").
-build_object_code(_ModuleName, target_erlang, _, _ErrorStream, _Imports,
- _Succeeded, _, _) :-
- sorry(this_file, "NYI mmc --make and target erlang").
+build_object_code(ModuleName, target_erlang, _, ErrorStream, _Imports,
+ Succeeded, !IO) :-
+ module_name_to_file_name(ModuleName, ".erl", yes, ErlangFile, !IO),
+ compile_target_code.compile_erlang_file(ErrorStream, ErlangFile,
+ Succeeded, !IO).
:- pred compile_foreign_code_file(io.output_stream::in, pic::in,
module_imports::in, foreign_code_file::in, bool::out,
@@ -504,8 +506,8 @@
compile_target_code.compile_csharp_file(ErrorStream, Imports,
CSharpFile, DLLFile, Succeeded, !IO).
compile_foreign_code_file(ErrorStream, _, _Imports,
- foreign_code_file(lang_erlang, ErlFile, BeamFile), Succeeded, !IO) :-
- compile_target_code.compile_erlang_file(ErrorStream, ErlFile, BeamFile,
+ foreign_code_file(lang_erlang, ErlFile, _BeamFile), Succeeded, !IO) :-
+ compile_target_code.compile_erlang_file(ErrorStream, ErlFile,
Succeeded, !IO).
:- func forkable_module_compilation_task_type(module_compilation_task_type)
@@ -724,6 +726,10 @@
target_code_to_object_code(non_pic) - [].
compilation_task(_, module_target_java_code) =
process_module(task_compile_to_target_code) - ["--java-only"].
+compilation_task(_, module_target_erlang_code) =
+ process_module(task_compile_to_target_code) - ["--erlang-only"].
+compilation_task(_, module_target_erlang_beam_code) =
+ target_code_to_object_code(non_pic) - [].
compilation_task(_, module_target_asm_code(PIC)) =
process_module(task_compile_to_target_code) -
( PIC = pic -> ["--pic"] ; [] ).
@@ -842,14 +848,12 @@
;
( CompilationTarget = target_il
; CompilationTarget = target_java
+ ; CompilationTarget = target_erlang
),
HeaderTargets0 = []
;
CompilationTarget = target_x86_64,
sorry(this_file, "NYI mmc --make and target x86_64")
- ;
- CompilationTarget = target_erlang,
- sorry(this_file, "NYI mmc --make and target erlang")
),
(
Index: compiler/make.program_target.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.program_target.m,v
retrieving revision 1.72
diff -u -r1.72 make.program_target.m
--- compiler/make.program_target.m 23 May 2007 10:09:18 -0000 1.72
+++ compiler/make.program_target.m 30 May 2007 03:00:02 -0000
@@ -63,6 +63,7 @@
;
( FileType = executable
; FileType = java_archive
+ ; FileType = erlang_archive
; FileType = static_library
),
ExtraOptions = []
@@ -97,8 +98,7 @@
(
Succeeded0 = yes,
build_with_module_options(MainModuleName, ExtraOptions,
- make_linked_target_2(
- linked_target_file(MainModuleName, FileType)),
+ make_linked_target_2(LinkedTargetFile),
Succeeded, !Info, !IO)
;
Succeeded0 = no,
@@ -147,7 +147,8 @@
sorry(this_file, "mmc --make and target x86_64")
;
CompilationTarget = target_erlang,
- sorry(this_file, "mmc --make and target erlang")
+ IntermediateTargetType = module_target_erlang_code,
+ ObjectTargetType = module_target_erlang_beam_code
),
AllModulesList = set.to_sorted_list(AllModules),
@@ -460,7 +461,24 @@
(func(foreign_code_file(_, _, ObjFile)) = ObjFile),
list.condense(ExtraForeignFiles)),
- maybe_pic_object_file_extension(PIC, ObjExtToUse, !IO),
+ (
+ ( CompilationTarget = target_c
+ ; CompilationTarget = target_asm
+ ; CompilationTarget = target_x86_64
+ ),
+ maybe_pic_object_file_extension(PIC, ObjExtToUse, !IO)
+ ;
+ CompilationTarget = target_il,
+ ObjExtToUse = ".dll"
+ ;
+ CompilationTarget = target_java,
+ globals.io_lookup_string_option(java_object_file_extension,
+ ObjExtToUse, !IO)
+ ;
+ CompilationTarget = target_erlang,
+ globals.io_lookup_string_option(erlang_object_file_extension,
+ ObjExtToUse, !IO)
+ ),
list.map_foldl(
(pred(ObjModule::in, ObjToLink::out, !.IO::di, !:IO::uo) is det :-
module_name_to_file_name(ObjModule,
@@ -473,6 +491,7 @@
(
( CompilationTarget = target_c
; CompilationTarget = target_asm
+ ; CompilationTarget = target_erlang
),
% Run the link in a separate process so it can be killed
% if an interrupt is received.
@@ -484,9 +503,6 @@
CompilationTarget = target_x86_64,
sorry(this_file, "mmc --make and target x86_64")
;
- CompilationTarget = target_erlang,
- sorry(this_file, "mmc --make and target erlang")
- ;
CompilationTarget = target_il,
Succeeded = yes
;
@@ -607,37 +623,7 @@
make_all_interface_files(AllModules, IntSucceeded, !Info, !IO),
(
IntSucceeded = yes,
- make_linked_target(
- linked_target_file(MainModuleName, static_library),
- StaticSucceeded, !Info, !IO),
- shared_libraries_supported(SharedLibsSupported, !IO),
- (
- StaticSucceeded = yes,
- (
- SharedLibsSupported = yes,
- make_linked_target(
- linked_target_file(MainModuleName, shared_library),
- SharedLibsSucceeded, !Info, !IO)
- ;
- SharedLibsSupported = no,
- SharedLibsSucceeded = yes
- ),
- % We can only build the .init file if we have succesfully
- % built the .c files.
- (
- SharedLibsSucceeded = yes,
- % Errors while making the .init file should be very rare.
- io.output_stream(ErrorStream, !IO),
- make_init_file(ErrorStream, MainModuleName,
- AllModules, Succeeded, !IO)
- ;
- SharedLibsSucceeded = no,
- Succeeded = no
- )
- ;
- StaticSucceeded = no,
- Succeeded = no
- )
+ build_library(MainModuleName, AllModules, Succeeded, !Info, !IO)
;
IntSucceeded = no,
Succeeded = no
@@ -864,6 +850,84 @@
%-----------------------------------------------------------------------------%
+:- pred build_library(module_name::in, list(module_name)::in, bool::out,
+ make_info::in, make_info::out, io::di, io::uo) is det.
+
+build_library(MainModuleName, AllModules, Succeeded, !Info, !IO) :-
+ globals.io_get_target(Target, !IO),
+ (
+ ( Target = target_c
+ ; Target = target_asm
+ ),
+ build_c_library(MainModuleName, AllModules, Succeeded, !Info, !IO)
+ ;
+ Target = target_il,
+ sorry(this_file, "build_library: target IL not supported yet")
+ ;
+ Target = target_java,
+ build_java_library(MainModuleName, Succeeded, !Info, !IO)
+ ;
+ Target = target_x86_64,
+ sorry(this_file, "build_library: target x86_64 not supported yet")
+ ;
+ Target = target_erlang,
+ build_erlang_library(MainModuleName, Succeeded, !Info, !IO)
+ ).
+
+:- pred build_c_library(module_name::in, list(module_name)::in, bool::out,
+ make_info::in, make_info::out, io::di, io::uo) is det.
+
+build_c_library(MainModuleName, AllModules, Succeeded, !Info, !IO) :-
+ make_linked_target(
+ linked_target_file(MainModuleName, static_library),
+ StaticSucceeded, !Info, !IO),
+ shared_libraries_supported(SharedLibsSupported, !IO),
+ (
+ StaticSucceeded = yes,
+ (
+ SharedLibsSupported = yes,
+ make_linked_target(
+ linked_target_file(MainModuleName, shared_library),
+ SharedLibsSucceeded, !Info, !IO)
+ ;
+ SharedLibsSupported = no,
+ SharedLibsSucceeded = yes
+ ),
+ % We can only build the .init file if we have succesfully
+ % built the .c files.
+ (
+ SharedLibsSucceeded = yes,
+ % Errors while making the .init file should be very rare.
+ io.output_stream(ErrorStream, !IO),
+ make_init_file(ErrorStream, MainModuleName,
+ AllModules, Succeeded, !IO)
+ ;
+ SharedLibsSucceeded = no,
+ Succeeded = no
+ )
+ ;
+ StaticSucceeded = no,
+ Succeeded = no
+ ).
+
+:- pred build_java_library(module_name::in, bool::out,
+ make_info::in, make_info::out, io::di, io::uo) is det.
+
+build_java_library(MainModuleName, Succeeded, !Info, !IO) :-
+ make_linked_target(
+ linked_target_file(MainModuleName, java_archive),
+ Succeeded, !Info, !IO).
+
+:- pred build_erlang_library(module_name::in, bool::out,
+ make_info::in, make_info::out, io::di, io::uo) is det.
+
+build_erlang_library(MainModuleName, Succeeded, !Info, !IO) :-
+ make_linked_target(
+ linked_target_file(MainModuleName, erlang_archive),
+ Succeeded, !Info, !IO).
+
+%-----------------------------------------------------------------------------%
+
:- pred install_library(module_name::in, bool::out,
make_info::in, make_info::out, io::di, io::uo) is det.
@@ -1059,8 +1123,8 @@
Succeeded = no
).
- % Install the `.a', `.so', `.jar', `.opt' and `.mih' files for the current
- % grade.
+ % Install the `.a', `.so', `.jar', `.beams', `.opt' and `.mih' files for
+ % the current grade.
%
% NOTE: changes here may require changes to
% modules.get_install_name_option/4.
@@ -1079,12 +1143,21 @@
linked_target_file_name(ModuleName, shared_library, SharedLibFileName,
!IO),
linked_target_file_name(ModuleName, java_archive, JarFileName, !IO),
+ linked_target_file_name(ModuleName, erlang_archive,
+ ErlangArchiveFileName, !IO),
globals.io_lookup_string_option(install_prefix, Prefix, !IO),
( GradeDir = "java" ->
GradeLibDir = Prefix/"lib"/"mercury"/"lib"/"java",
- install_file(JarFileName, GradeLibDir, LibsSucceeded, !IO)
+ install_file(JarFileName, GradeLibDir, LibsSucceeded, !IO),
+ InitSucceeded = yes
+ ; GradeDir = "erlang" ->
+ GradeLibDir = Prefix/"lib"/"mercury"/"lib"/"erlang",
+ % Our "Erlang archives" are actually directories.
+ install_directory(ErlangArchiveFileName, GradeLibDir,
+ LibsSucceeded, !IO),
+ InitSucceeded = yes
;
GradeLibDir = Prefix/"lib"/"mercury"/"lib"/GradeDir,
maybe_install_library_file("static", LibFileName, GradeLibDir,
@@ -1095,16 +1168,15 @@
maybe_install_library_file("shared", SharedLibFileName,
GradeLibDir, SharedLibSuccess, !IO),
LibsSucceeded = LibSuccess `and` SharedLibSuccess
- )
+ ),
+ install_grade_init(GradeDir, ModuleName, InitSucceeded, !IO)
),
- install_grade_init(GradeDir, ModuleName, InitSucceded, !IO),
-
list.map_foldl2(
install_grade_ints_and_headers(LinkSucceeded, GradeDir),
AllModules, IntsHeadersSucceeded, !Info, !IO),
- Succeeded =
- bool.and_list([LibsSucceeded, InitSucceded | IntsHeadersSucceeded])
+ Succeeded = bool.and_list(
+ [LibsSucceeded, InitSucceeded | IntsHeadersSucceeded])
;
DirResult = no,
Succeeded = no
@@ -1257,6 +1329,26 @@
io.output_stream(OutputStream, !IO),
invoke_system_command(OutputStream, cmd_verbose, Command, Succeeded, !IO).
+:- pred install_directory(dir_name::in, dir_name::in, bool::out,
+ io::di, io::uo) is det.
+
+install_directory(SourceDirName, InstallDir, Succeeded, !IO) :-
+ verbose_msg(
+ (pred(!.IO::di, !:IO::uo) is det :-
+ io.write_string("Installing directory ", !IO),
+ io.write_string(SourceDirName, !IO),
+ io.write_string(" in ", !IO),
+ io.write_string(InstallDir, !IO),
+ io.nl(!IO)
+ ), !IO),
+ globals.io_lookup_string_option(install_command, InstallCommand, !IO),
+ globals.io_lookup_string_option(install_command_dir_option,
+ InstallCommandDirOption, !IO),
+ Command = string.join_list(" ", list.map(quote_arg,
+ [InstallCommand, InstallCommandDirOption, SourceDirName, InstallDir])),
+ io.output_stream(OutputStream, !IO),
+ invoke_system_command(OutputStream, cmd_verbose, Command, Succeeded, !IO).
+
:- pred make_install_dirs(bool::out, bool::out, io::di, io::uo) is det.
make_install_dirs(Result, LinkResult, !IO) :-
@@ -1417,6 +1509,8 @@
linked_target_file_name(ModuleName, shared_library, SharedLibFileName,
!IO),
linked_target_file_name(ModuleName, java_archive, JarFileName, !IO),
+ linked_target_file_name(ModuleName, erlang_archive,
+ ErlangArchiveFileName, !IO),
% Remove the symlinks created for `--use-grade-subdirs'.
globals.io_lookup_bool_option(use_grade_subdirs, UseGradeSubdirs, !IO),
@@ -1427,12 +1521,19 @@
linked_target_file_name(ModuleName, shared_library,
ThisDirSharedLibFileName, !IO),
linked_target_file_name(ModuleName, java_archive, ThisDirJarFileName, !IO),
+ linked_target_file_name(ModuleName, erlang_archive,
+ ThisDirErlangArchiveFileName, !IO),
+ % XXX this symlink should not be necessary anymore for `mmc --make'
+ module_name_to_file_name(ModuleName, ".init", no,
+ ThisDirInitFileName, !IO),
globals.io_set_option(use_grade_subdirs, bool(UseGradeSubdirs), !IO),
list.foldl2(make_remove_file(very_verbose),
[ExeFileName, LibFileName, SharedLibFileName, JarFileName,
+ ErlangArchiveFileName,
ThisDirExeFileName, ThisDirLibFileName,
- ThisDirSharedLibFileName, ThisDirJarFileName],
+ ThisDirSharedLibFileName, ThisDirJarFileName,
+ ThisDirErlangArchiveFileName, ThisDirInitFileName],
!Info, !IO),
make_remove_file(very_verbose, ModuleName, ".init", !Info, !IO),
remove_init_files(very_verbose, ModuleName, !Info, !IO).
@@ -1465,7 +1566,8 @@
list.foldl2(make_remove_target_file(very_verbose, ModuleName),
[module_target_errors, module_target_c_code,
module_target_c_header(header_mih), module_target_il_code,
- module_target_java_code], !Info, !IO),
+ module_target_java_code, module_target_erlang_code,
+ module_target_erlang_beam_code], !Info, !IO),
list.foldl2(make_remove_file(very_verbose, ModuleName),
[".used", ".prof"], !Info, !IO),
Index: compiler/make.util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.util.m,v
retrieving revision 1.46
diff -u -r1.46 make.util.m
--- compiler/make.util.m 7 May 2007 06:59:23 -0000 1.46
+++ compiler/make.util.m 30 May 2007 03:00:02 -0000
@@ -965,7 +965,7 @@
make_remove_file(VerboseOption, FileName, !Info, !IO) :-
verbose_msg(VerboseOption, report_remove_file(FileName), !IO),
- io.remove_file(FileName, _, !IO),
+ io.remove_file_recursively(FileName, _, !IO),
!:Info = !.Info ^ file_timestamps :=
map.delete(!.Info ^ file_timestamps, FileName).
@@ -1004,6 +1004,8 @@
% XXX ".exe" if the module contains main.
target_extension(_, module_target_il_asm) = yes(".dll").
target_extension(_, module_target_java_code) = yes(".java").
+target_extension(_, module_target_erlang_code) = yes(".erl").
+target_extension(_, module_target_erlang_beam_code) = yes(".beam").
target_extension(_, module_target_asm_code(non_pic)) = yes(".s").
target_extension(_, module_target_asm_code(link_with_pic)) = yes(".s").
target_extension(_, module_target_asm_code(pic)) = yes(".pic_s").
@@ -1027,6 +1029,9 @@
module_name_to_lib_file_name("lib", ModuleName, Ext, no, FileName, !IO).
linked_target_file_name(ModuleName, java_archive, FileName, !IO) :-
module_name_to_file_name(ModuleName, ".jar", no, FileName, !IO).
+linked_target_file_name(ModuleName, erlang_archive, FileName, !IO) :-
+ module_name_to_lib_file_name("lib", ModuleName, ".beams", no, FileName,
+ !IO).
:- pred module_target_to_file_name(module_name::in, module_target_type::in,
bool::in, file_name::out, io::di, io::uo) is det.
@@ -1114,6 +1119,7 @@
module_target_asm_code(non_pic) ; module_target_c_code)).
timestamp_extension(_, module_target_il_code) = ".il_date".
timestamp_extension(_, module_target_java_code) = ".java_date".
+timestamp_extension(_, module_target_erlang_code) = ".erl_date".
timestamp_extension(_, module_target_asm_code(non_pic)) = ".s_date".
timestamp_extension(_, module_target_asm_code(pic)) = ".pic_s_date".
@@ -1137,6 +1143,8 @@
search_for_file_type(module_target_il_code) = no.
search_for_file_type(module_target_il_asm) = no.
search_for_file_type(module_target_java_code) = no.
+search_for_file_type(module_target_erlang_code) = no.
+search_for_file_type(module_target_erlang_beam_code) = no.
search_for_file_type(module_target_asm_code(_)) = no.
search_for_file_type(module_target_object_code(_)) = no.
search_for_file_type(module_target_foreign_object(_, _)) = no.
@@ -1169,6 +1177,8 @@
; Target = module_target_il_code
; Target = module_target_il_asm
; Target = module_target_java_code
+ ; Target = module_target_erlang_code
+ ; Target = module_target_erlang_beam_code
; Target = module_target_asm_code(_)
; Target = module_target_object_code(_)
; Target = module_target_foreign_object(_, _)
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.425
diff -u -r1.425 modules.m
--- compiler/modules.m 27 May 2007 00:59:32 -0000 1.425
+++ compiler/modules.m 30 May 2007 03:00:02 -0000
@@ -81,13 +81,6 @@
:- pred module_name_to_file_name(module_name::in, string::in, bool::in,
file_name::out, io::di, io::uo) is det.
- % module_name_to_file_name_sep(Module, Sep, Extension, Mkdir, FileName):
- %
- % As above but module qualifiers are separated by Sep instead of ".".
- %
-:- pred module_name_to_file_name_sep(module_name::in, string::in, string::in,
- bool::in, file_name::out, io::di, io::uo) is det.
-
% module_name_to_search_file_name(Module, Extension, FileName):
%
% As above, but for a file which might be in an installed library,
@@ -786,6 +779,28 @@
%
:- pred get_env_classpath(string::out, io::di, io::uo) is det.
+%-----------------------------------------------------------------------------%
+%
+% Erlang utilities
+%
+
+ % To avoid namespace collisions between Mercury standard modules and
+ % Erlang standard modules, we pretend the Mercury standard modules are in
+ % a "mercury" supermodule. This function returns ModuleName with the
+ % extra qualifier if it is a standard library module. Otherwise it
+ % returns it unchanged.
+ %
+:- func erlang_module_name(module_name) = module_name.
+
+ % Create a shell script with the same name as the given module to invoke
+ % the Erlang runtime system and execute the main/2 predicate in that
+ % module.
+ %
+:- pred create_erlang_shell_script(module_name::in, bool::out, io::di, io::uo)
+ is det.
+
+%-----------------------------------------------------------------------------%
+
% get_install_name_option(FileName, Option, !IO):
%
% Get the option string for setting the install-name of the shared library
@@ -844,25 +859,34 @@
mercury_std_library_module(ModuleNameStr).
module_name_to_search_file_name(ModuleName, Ext, FileName, !IO) :-
- module_name_to_file_name_sep(ModuleName, ".", Ext, yes, no, FileName, !IO).
+ module_name_to_file_name_2(ModuleName, Ext, yes, no, FileName, !IO).
module_name_to_file_name(ModuleName, Ext, MkDir, FileName, !IO) :-
- module_name_to_file_name_sep(ModuleName, ".", Ext, no, MkDir, FileName,
+ module_name_to_file_name_2(ModuleName, Ext, no, MkDir, FileName,
!IO).
-module_name_to_file_name_sep(ModuleName, Sep, Ext, MkDir, FileName, !IO) :-
- module_name_to_file_name_sep(ModuleName, Sep, Ext, no, MkDir, FileName,
- !IO).
-
-:- pred module_name_to_file_name_sep(module_name::in, string::in, string::in,
+:- pred module_name_to_file_name_2(module_name::in, string::in,
bool::in, bool::in, file_name::out, io::di, io::uo) is det.
-module_name_to_file_name_sep(ModuleName, Sep, Ext, Search, MkDir, FileName,
- !IO) :-
+module_name_to_file_name_2(ModuleName0, Ext, Search, MkDir, FileName, !IO) :-
( Ext = ".m" ->
% Look up the module in the module->file mapping.
- source_file_map.lookup_module_source_file(ModuleName, FileName, !IO)
+ source_file_map.lookup_module_source_file(ModuleName0, FileName, !IO)
;
+ (
+ ( Ext = ".erl"
+ ; Ext = ".beam"
+ )
+ ->
+ % Erlang uses `.' as a package separator and expects a module
+ % `a.b.c' to be in a file `a/b/c.erl'. Rather than that, we use
+ % a flat namespace with `__' as module separators.
+ Sep = "__",
+ ModuleName = erlang_module_name(ModuleName0)
+ ;
+ Sep = ".",
+ ModuleName = ModuleName0
+ ),
string.append(sym_name_to_string_sep(ModuleName, Sep), Ext, BaseName),
choose_file_name(ModuleName, BaseName, Ext, Search, MkDir, FileName,
!IO)
@@ -941,6 +965,7 @@
; Ext = ".dylib"
; Ext = ".$(EXT_FOR_SHARED_LIB)"
; Ext = ".jar"
+ ; Ext = ".beams"
; Ext = ".init"
% mercury_update_interface
% requires the `.init.tmp' files to
@@ -981,6 +1006,8 @@
; Ext = ".ils"
; Ext = ".javas"
; Ext = ".classes"
+ ; Ext = ".erls"
+ ; Ext = ".beams"
; Ext = ".opts"
; Ext = ".trans_opts"
)
@@ -1075,7 +1102,7 @@
globals.io_lookup_bool_option(use_symlinks, UseSymLinks, !IO),
(
UseSymLinks = yes,
- io.remove_file(LinkName, _, !IO),
+ io.remove_file_recursively(LinkName, _, !IO),
io.make_symlink(LinkTarget, LinkName, LinkResult, !IO),
Result = ( if LinkResult = ok then yes else no )
;
@@ -1249,6 +1276,10 @@
file_is_arch_or_grade_dependent_2(".java").
file_is_arch_or_grade_dependent_2(".java_date").
file_is_arch_or_grade_dependent_2(".class").
+file_is_arch_or_grade_dependent_2(".erl").
+file_is_arch_or_grade_dependent_2(".erl_date").
+file_is_arch_or_grade_dependent_2(".beam").
+file_is_arch_or_grade_dependent_2(".beams").
file_is_arch_or_grade_dependent_2(".dir").
file_is_arch_or_grade_dependent_2(".dll").
file_is_arch_or_grade_dependent_2(".$A").
@@ -8135,6 +8166,148 @@
).
%-----------------------------------------------------------------------------%
+%
+% Erlang utilities
+%
+
+erlang_module_name(ModuleName) =
+ (if mercury_std_library_module_name(ModuleName) then
+ add_outermost_qualifier("mercury", ModuleName)
+ else
+ ModuleName
+ ).
+
+create_erlang_shell_script(MainModuleName, Succeeded, !IO) :-
+ module_name_to_file_name(MainModuleName, ScriptFileName),
+ globals.io_get_globals(Globals, !IO),
+ grade_directory_component(Globals, GradeDir),
+
+ globals.io_lookup_bool_option(verbose, Verbose, !IO),
+ maybe_write_string(Verbose, "% Generating shell script `" ++
+ ScriptFileName ++ "'...\n", !IO),
+
+ globals.io_lookup_string_option(erlang_object_file_extension, BeamExt,
+ !IO),
+ module_name_to_file_name(MainModuleName, BeamExt, no, BeamFileName, !IO),
+ BeamDirName = dir.dirname(BeamFileName),
+ module_name_to_file_name(MainModuleName, BeamBaseNameNoExt),
+
+ % Add `-pa <dir>' option to find the standard library.
+ % (-pa adds the directory to the beginning of the list of paths to search
+ % for .beam files)
+ globals.io_lookup_maybe_string_option(
+ mercury_standard_library_directory, MaybeStdLibDir, !IO),
+ (
+ MaybeStdLibDir = yes(StdLibDir),
+ StdLibBeamsPath = StdLibDir/"lib"/GradeDir/"libmer_std.beams",
+ SearchStdLib = pa_option(yes, StdLibBeamsPath)
+ ;
+ MaybeStdLibDir = no,
+ SearchStdLib = ""
+ ),
+
+ % Add `-pa <dir>' options to find any other libraries specified by the user.
+ globals.io_lookup_accumulating_option(
+ mercury_library_directories, MercuryLibDirs0, !IO),
+ MercuryLibDirs = list.map((func(LibDir) = LibDir/"lib"/GradeDir),
+ MercuryLibDirs0),
+ globals.io_lookup_accumulating_option(link_libraries,
+ LinkLibrariesList0, !IO),
+ list.map_foldl2(find_erlang_library_path(MercuryLibDirs),
+ LinkLibrariesList0, LinkLibrariesList, yes, LibrariesSucceeded,
+ !IO),
+ (
+ LibrariesSucceeded = yes,
+ % Remove symlink in the way, if any.
+ io.remove_file(ScriptFileName, _, !IO),
+ io.open_output(ScriptFileName, OpenResult, !IO),
+ (
+ OpenResult = ok(ShellScript),
+
+ globals.io_lookup_string_option(erlang_interpreter, Erlang, !IO),
+ SearchLibs = string.append_list(list.map(pa_option(yes),
+ list.sort_and_remove_dups(LinkLibrariesList))),
+
+ % XXX main_2_p_0 is not necessarily in the main module itself and
+ % could be in a submodule. We don't handle that yet.
+ SearchProg = pa_option(no, """$DIR""/" ++ quote_arg(BeamDirName)),
+
+ % Write the shell script.
+ io.write_strings(ShellScript, [
+ "#!/bin/sh\n",
+ "# Generated by the Mercury compiler.\n",
+ "DIR=`dirname ""$0""`\n",
+ "exec ", Erlang, " -noshell \\\n",
+ SearchStdLib, SearchLibs, SearchProg,
+ " -s ", BeamBaseNameNoExt, " main_2_p_0",
+ " -s init stop -- ""$@""\n"
+ ], !IO),
+ io.close_output(ShellScript, !IO),
+
+ % Set executable bit.
+ io.call_system("chmod a+x " ++ ScriptFileName, ChmodResult, !IO),
+ (
+ ChmodResult = ok(Status),
+ ( Status = 0 ->
+ Succeeded = yes,
+ maybe_write_string(Verbose, "% done.\n", !IO)
+ ;
+ unexpected(this_file, "chmod exit status != 0"),
+ Succeeded = no
+ )
+ ;
+ ChmodResult = error(Message),
+ unexpected(this_file, io.error_message(Message)),
+ Succeeded = no
+ )
+ ;
+ OpenResult = error(Message),
+ unexpected(this_file, io.error_message(Message)),
+ Succeeded = no
+ )
+ ;
+ LibrariesSucceeded = no,
+ Succeeded = no
+ ).
+
+:- pred find_erlang_library_path(list(dir_name)::in, string::in, string::out,
+ bool::in, bool::out, io::di, io::uo) is det.
+
+find_erlang_library_path(MercuryLibDirs, LibName, LibPath, !Succeeded, !IO) :-
+ globals.io_lookup_bool_option(use_grade_subdirs, UseGradeSubdirs, !IO),
+ file_name_to_module_name(LibName, LibModuleName),
+ globals.io_set_option(use_grade_subdirs, bool(no), !IO),
+ module_name_to_lib_file_name("lib", LibModuleName, ".beams", no,
+ LibFileName, !IO),
+ globals.io_set_option(use_grade_subdirs, bool(UseGradeSubdirs), !IO),
+
+ io.input_stream(InputStream, !IO),
+ search_for_file_returning_dir(MercuryLibDirs, LibFileName,
+ SearchResult, !IO),
+ (
+ SearchResult = ok(DirName),
+ LibPath = DirName/LibFileName,
+ io.set_input_stream(InputStream, LibInputStream, !IO),
+ io.close_input(LibInputStream, !IO)
+ ;
+ SearchResult = error(Error),
+ LibPath = "",
+ write_error_pieces_maybe_with_context(no, 0, [words(Error)], !IO),
+ !:Succeeded = no
+ ).
+
+:- func pa_option(bool, dir_name) = string.
+
+pa_option(Quote, Dir0) = " -pa " ++ Dir ++ " \\\n" :-
+ (
+ Quote = yes,
+ Dir = quote_arg(Dir0)
+ ;
+ Quote = no,
+ Dir = Dir0
+ ).
+
+%-----------------------------------------------------------------------------%
% Changes to the following predicate may require similar changes to
% make.program_target.install_library_grade_files/9.
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.562
diff -u -r1.562 options.m
--- compiler/options.m 24 May 2007 01:37:44 -0000 1.562
+++ compiler/options.m 30 May 2007 03:00:02 -0000
@@ -694,8 +694,10 @@
% Erlang
; erlang_compiler
+ ; erlang_interpreter
; erlang_flags
; quoted_erlang_flag
+ ; erlang_object_file_extension
% Link options
; output_file_name
@@ -785,6 +787,7 @@
; mercury_configuration_directory
; mercury_configuration_directory_special
; install_command
+ ; install_command_dir_option
; libgrades
; lib_linkages
; flags_file
@@ -1448,8 +1451,10 @@
% Erlang
erlang_compiler - string("erlc"),
+ erlang_interpreter - string("erl"),
erlang_flags - accumulating([]),
- quoted_erlang_flag - string_special
+ quoted_erlang_flag - string_special,
+ erlang_object_file_extension - string(".beam")
]).
option_defaults_2(link_option, [
% Link Options
@@ -1552,6 +1557,7 @@
mercury_configuration_directory_special - string_special,
mercury_configuration_directory - maybe_string(no),
install_command - string("cp"),
+ install_command_dir_option - string("-r"),
libgrades - accumulating([]),
lib_linkages - accumulating([]),
flags_file - file_special,
@@ -2254,6 +2260,7 @@
long_option("erlang-compiler", erlang_compiler).
long_option("erlang-flags", erlang_flags).
long_option("erlang-flag", quoted_erlang_flag).
+long_option("erlang-object-file-extension", erlang_object_file_extension).
% link options
long_option("output-file", output_file_name).
@@ -2347,6 +2354,7 @@
mercury_configuration_directory_special).
long_option("install-prefix", install_prefix).
long_option("install-command", install_command).
+long_option("install-command-dir-option", install_command_dir_option).
long_option("use-symlinks", use_symlinks).
long_option("library-grade", libgrades).
long_option("libgrade", libgrades).
@@ -4784,6 +4792,11 @@
"\tMercury libraries. The given command will be invoked as",
"\t`<command> <source> <target>' to install each file",
"\tin a Mercury library. The default command is `cp'.",
+ "--install-command-dir-option <option>",
+ "\tSpecify the flag to pass to the install command to install",
+ "\ta directory. The given command will be invoked as",
+ "\t`<command> <option> <source> <target>'",
+ "\tto install each directory. The default option is `-r'.",
"--libgrade <grade>",
"\tAdd <grade> to the list of compilation grades in",
"\twhich a library to be installed should be built.",
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.520
diff -u -r1.520 user_guide.texi
--- doc/user_guide.texi 24 May 2007 01:37:47 -0000 1.520
+++ doc/user_guide.texi 30 May 2007 03:00:02 -0000
@@ -8515,6 +8515,14 @@
The default command is @samp{cp}.
@sp 1
+ at item --install-command-dir-option @var{option}
+ at findex --install-command-dir-command
+Specify the flag to pass to the install command to install
+a directory. The given command will be invoked as
+ at code{@var{command} @var{option} @var{source} @var{target}}
+to install each directory. The default option is @samp{-r}.
+
+ at sp 1
@item --libgrade @var{grade}
@findex --libgrade
Add @var{grade} to the list of compilation grades in
Index: library/io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.382
diff -u -r1.382 io.m
--- library/io.m 15 May 2007 02:38:23 -0000 1.382
+++ library/io.m 30 May 2007 03:00:02 -0000
@@ -1297,6 +1297,18 @@
%
:- pred io.remove_file(string::in, io.res::out, io::di, io::uo) is det.
+ % io.remove_file_recursively(FileName, Result, !IO) attempts to remove
+ % the file `FileName', binding Result to ok/0 if it succeeds, or error/1
+ % if it fails. If `FileName' names a file that is currently open, the
+ % behaviour is implementation-dependent.
+ %
+ % Unlike `io.remove_file', this predicate will attempt to remove non-empty
+ % directories (recursively). If it fails, some of the directory elements
+ % may already have been removed.
+ %
+:- pred remove_file_recursively(string::in, io.res::out, io::di, io::uo)
+ is det.
+
% io.rename_file(OldFileName, NewFileName, Result, !IO).
%
% Attempts to rename the file `OldFileName' as `NewFileName', binding
@@ -3561,8 +3573,9 @@
}
}").
-io.buffer_to_string(buffer(Array), Len, from_char_list_semidet(List)) :-
- array.fetch_items(Array, min(Array), min(Array) + Len - 1, List).
+io.buffer_to_string(buffer(Array), Len, String) :-
+ array.fetch_items(Array, min(Array), min(Array) + Len - 1, List),
+ string.semidet_from_char_list(List, String).
:- pred io.read_into_buffer(stream::in, buffer::buffer_di, buffer::buffer_uo,
int::in, int::out, int::in, io::di, io::uo) is det.
@@ -8836,6 +8849,49 @@
}
").
+remove_file_recursively(FileName, Res, !IO) :-
+ FollowSymLinks = no,
+ io.file_type(FollowSymLinks, FileName, ResFileType, !IO),
+ (
+ ResFileType = ok(FileType),
+ ( FileType = directory ->
+ dir.foldl2(remove_directory_entry, FileName, ok, Res0, !IO),
+ (
+ Res0 = ok(MaybeError),
+ (
+ MaybeError = ok,
+ io.remove_file(FileName, Res, !IO)
+ ;
+ MaybeError = error(Error),
+ Res = error(Error)
+ )
+ ;
+ Res0 = error(_, Error),
+ Res = error(Error)
+ )
+ ;
+ io.remove_file(FileName, Res, !IO)
+ )
+ ;
+ ResFileType = error(Error),
+ Res = error(Error)
+ ).
+
+:- pred remove_directory_entry(string::in, string::in, file_type::in,
+ bool::out, io.res::in, io.res::out, io::di, io::uo) is det.
+
+remove_directory_entry(DirName, FileName, _FileType, Continue, _, Res, !IO) :-
+ remove_file_recursively(DirName / FileName, Res0, !IO),
+ (
+ Res0 = ok,
+ Res = ok,
+ Continue = yes
+ ;
+ Res0 = error(_),
+ Res = Res0,
+ Continue = no
+ ).
+
io.rename_file(OldFileName, NewFileName, Result, IO0, IO) :-
io.rename_file_2(OldFileName, NewFileName, Res, ResString, IO0, IO),
( Res \= 0 ->
Index: tests/mmc_make/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/mmc_make/Mmakefile,v
retrieving revision 1.4
diff -u -r1.4 Mmakefile
--- tests/mmc_make/Mmakefile 11 Jan 2006 05:36:57 -0000 1.4
+++ tests/mmc_make/Mmakefile 30 May 2007 03:00:02 -0000
@@ -42,14 +42,16 @@
build_object.runtest: build_object.o
.PHONY: install_libs
-install_libs: TESTS_FLAGS start_runtests_local
+install_libs: start_runtests_local
+ $(MMAKE) TESTS_FLAGS
( cd lib; \
$(MCM) --no-libgrade --install-prefix $(shell pwd)/install \
libcomplex_numbers.install ) \
|| touch complex_test.failed
.PHONY: install_libs_linkage_test2
-install_libs_linkage_test2: TESTS_FLAGS start_runtests_local
+install_libs_linkage_test2: start_runtests_local
+ $(MMAKE) TESTS_FLAGS
( cd lib; \
$(MCM) --no-libgrade --install-prefix $(shell pwd)/install \
liblinkage_test2.install --lib-linkage static ) \
--------------------------------------------------------------------------
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