[m-rev.] diff: rearrange compiler code
Simon Taylor
stayl at cs.mu.OZ.AU
Mon Mar 18 15:46:56 AEDT 2002
Estimated hours taken: 1.5
Branches: main
Rearrange some code after the `--make' change. This was not done
as part of that change for ease of reviewing.
compiler/mercury_compile.m:
compiler/compile_target_code.m:
compiler/make.m:
compiler/make.module_target.m:
compiler/make.program_target.m:
Move code to compile the generated code into compile_target_code.m.
compiler/make.util.m:
compiler/passes_aux.m:
compiler/process_util.m:
Move process and signal handling functionality into process_util.m.
compiler/Mmakefile:
Compile process_util.c with `--no-ansi' so that the declarations
of `struct sigaction' and `kill' are available on Linux.
compiler/notes/compiler_design.html:
Document compile_target_code.m and process_util.m.
Move timestamp.m into the "Miscellaneous" section (it's
used by make as well as smart recompilation).
Fix the documentation of options_file.m.
Index: Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Mmakefile,v
retrieving revision 1.51
diff -u -u -r1.51 Mmakefile
--- Mmakefile 12 Mar 2002 16:32:27 -0000 1.51
+++ Mmakefile 17 Mar 2002 15:55:35 -0000
@@ -100,9 +100,9 @@
CFLAGS-rl_code=-O1
-# make.util.m uses `kill' and `struct sigaction' from <signal.h>,
+# process_util.m uses `kill' and `struct sigaction' from <signal.h>,
# which are not available with `--ansi'.
-MGNUCFLAGS-make.util = --no-ansi
+MGNUCFLAGS-process_util = --no-ansi
# The c_code in the module gcc.m needs the header files from the GNU C
# distribution.
Index: compile_target_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.1
diff -u -u -r1.1 compile_target_code.m
--- compile_target_code.m 12 Mar 2002 16:32:28 -0000 1.1
+++ compile_target_code.m 17 Mar 2002 15:33:46 -0000
@@ -8,15 +8,86 @@
%
% Code to compile the generated `.c', `.s', `.o', etc, files.
%
-% XXX Code will be moved here from mercury_compile.m after the `mmc --make'
-% change has been reviewed.
%-----------------------------------------------------------------------------%
:- module compile_target_code.
:- interface.
-:- import_module prog_data.
-:- import_module bool, io, std_util.
+:- import_module modules, prog_data, prog_io.
+:- import_module bool, list, io, std_util.
+
+ % compile_c_file(ErrorStream, CFile, ObjFile, Succeeded).
+:- pred compile_c_file(io__output_stream, string, string, bool,
+ io__state, io__state).
+:- mode compile_c_file(in, in, in, out, di, uo) is det.
+
+ % compile_c_file(ErrorStream, ModuleName, Succeeded).
+:- pred compile_c_file(io__output_stream, module_name, bool,
+ io__state, io__state).
+:- mode compile_c_file(in, in, out, di, uo) is det.
+
+ % assemble(ErrorStream, ModuleName, Succeeded).
+:- pred assemble(io__output_stream, module_name, bool, io__state, io__state).
+:- mode assemble(in, in, out, di, uo) is det.
+
+ % compile_java_file(ErrorStream, ModuleName, Succeeded).
+:- pred compile_java_file(io__output_stream, module_name, bool,
+ io__state, io__state).
+:- mode compile_java_file(in, in, out, di, uo) is det.
+
+ % il_assemble(ErrorStream, ModuleName, HasMain, Succeeded).
+:- pred il_assemble(io__output_stream, module_name,
+ has_main, bool, io__state, io__state).
+:- mode il_assemble(in, in, in, out, di, uo) is det.
+
+ % il_assemble(ErrorStream, ILFile, DLLFile, HasMain, Succeeded).
+:- pred il_assemble(io__output_stream, file_name, file_name,
+ has_main, bool, io__state, io__state).
+:- mode il_assemble(in, in, in, in, out, di, uo) is det.
+
+ % il_assemble(ErrorStream, MCPPFile, DLLFile, HasMain, Succeeded).
+:- pred compile_managed_cplusplus_file(io__output_stream,
+ file_name, file_name, bool, io__state, io__state).
+:- mode compile_managed_cplusplus_file(in, in, in, out, di, uo) is det.
+
+ % il_assemble(ErrorStream, C#File, DLLFile, HasMain, Succeeded).
+:- pred compile_csharp_file(io__output_stream, file_name, file_name,
+ bool, io__state, io__state).
+:- mode compile_csharp_file(in, in, in, out, di, uo) is det.
+
+ % make_init_obj_file(ErrorStream, MainModuleName,
+ % AllModuleNames, MaybeInitObjFileName).
+:- pred make_init_obj_file(io__output_stream, module_name, list(module_name),
+ maybe(file_name), io__state, io__state).
+:- mode make_init_obj_file(in, in, in, out, di, uo) is det.
+
+:- type linked_target_type
+ ---> executable
+ ; static_library
+ ; shared_library
+ .
+
+ % link(TargetType, MainModuleName, ObjectFileNames, Succeeded).
+:- pred link(io__output_stream, linked_target_type, module_name,
+ list(string), bool, io__state, io__state).
+:- mode link(in, in, in, in, out, di, uo) is det.
+
+ % link_module_list(ModulesToLink, Succeeded).
+ %
+ % The elements of ModulesToLink are the output of
+ % `module_name_to_filename(ModuleName, "", no, ModuleToLink)'
+ % for each module in the program.
+:- pred link_module_list(list(string), bool, io__state, io__state).
+:- mode link_module_list(in, out, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+ % Code to deal with `--split-c-files'.
+
+ % split_c_to_obj(ErrorStream, ModuleName, NumChunks, Succeeded).
+ % Compile the `.c' files produced for a module with `--split-c-files'.
+:- pred split_c_to_obj(io__output_stream, module_name,
+ int, bool, io__state, io__state).
+:- mode split_c_to_obj(in, in, in, out, di, uo) is det.
% Write the number of `.c' files written by this
% compilation with `--split-c-files'.
@@ -39,8 +110,776 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module modules, globals, options.
-:- import_module int, string.
+:- import_module modules, globals, options, handle_options.
+:- import_module passes_aux, trace_params.
+:- import_module dir, int, require, string.
+
+il_assemble(ErrorStream, ModuleName,
+ HasMain, Succeeded) -->
+ module_name_to_file_name(ModuleName, ".il", no, IL_File),
+ ( { HasMain = has_main } ->
+ module_name_to_file_name(ModuleName, ".exe", no, TargetFile)
+ ;
+ module_name_to_file_name(ModuleName, ".dll", no, TargetFile)
+ ),
+ il_assemble(ErrorStream, IL_File, TargetFile,
+ HasMain, Succeeded).
+
+il_assemble(ErrorStream, IL_File, TargetFile,
+ HasMain, Succeeded) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(sign_assembly, SignAssembly),
+ maybe_write_string(Verbose, "% Assembling `"),
+ maybe_write_string(Verbose, IL_File),
+ maybe_write_string(Verbose, "':\n"),
+ globals__io_lookup_string_option(il_assembler, ILASM),
+ globals__io_lookup_accumulating_option(ilasm_flags, ILASMFlagsList),
+ { join_string_list(ILASMFlagsList, "", "", " ", ILASMFlags) },
+ { SignAssembly = yes ->
+ SignOpt = "/keyf=mercury.sn "
+ ;
+ SignOpt = ""
+ },
+ { Verbose = yes ->
+ VerboseOpt = ""
+ ;
+ VerboseOpt = "/quiet "
+ },
+ globals__io_lookup_bool_option(target_debug, Debug),
+ { Debug = yes ->
+ DebugOpt = "/debug "
+ ;
+ DebugOpt = ""
+ },
+ { HasMain = has_main ->
+ TargetOpt = ""
+ ;
+ TargetOpt = "/dll "
+ },
+ { string__append_list([ILASM, " ", SignOpt, VerboseOpt, DebugOpt,
+ TargetOpt, ILASMFlags, " /out=", TargetFile,
+ " ", IL_File], Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+compile_managed_cplusplus_file(ErrorStream,
+ MCPPFileName, DLLFileName, Succeeded) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Compiling `"),
+ maybe_write_string(Verbose, MCPPFileName),
+ maybe_write_string(Verbose, "':\n"),
+ globals__io_lookup_string_option(mcpp_compiler, MCPP),
+ globals__io_lookup_accumulating_option(mcpp_flags, MCPPFlagsList),
+ { join_string_list(MCPPFlagsList, "", "", " ", MCPPFlags) },
+ globals__io_lookup_bool_option(target_debug, Debug),
+ { Debug = yes ->
+ DebugOpt = "" % XXX
+ ;
+ DebugOpt = ""
+ },
+
+ % XXX Should we introduce a `--mcpp-include-directory' option?
+ globals__io_lookup_accumulating_option(c_include_directory,
+ C_Incl_Dirs),
+ { InclOpts = string__append_list(list__condense(list__map(
+ (func(C_INCL) = ["-I", C_INCL, " "]), C_Incl_Dirs))) },
+
+ % XXX Should we use a separate dll_directories options?
+ globals__io_lookup_accumulating_option(link_library_directories,
+ DLLDirs),
+ { DLLDirOpts = string__append_list(list__condense(list__map(
+ (func(DLLDir) = ["-AI", DLLDir, " "]), DLLDirs))) },
+
+ { string__append_list([MCPP, " -CLR ", DebugOpt, InclOpts,
+ DLLDirOpts, MCPPFlags, " ", MCPPFileName,
+ "-link -noentry mscoree.lib -dll -out:", DLLFileName],
+ Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+compile_csharp_file(ErrorStream,
+ CSharpFileName, DLLFileName, Succeeded) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Compiling `"),
+ maybe_write_string(Verbose, CSharpFileName),
+ maybe_write_string(Verbose, "':\n"),
+ globals__io_lookup_string_option(csharp_compiler, CSC),
+ globals__io_lookup_accumulating_option(csharp_flags, CSCFlagsList),
+ { join_string_list(CSCFlagsList, "", "", " ", CSCFlags) },
+ globals__io_lookup_bool_option(target_debug, Debug),
+ { Debug = yes ->
+ DebugOpt = "" % XXX
+ ;
+ DebugOpt = ""
+ },
+
+ % XXX Should we use a separate dll_directories options?
+ globals__io_lookup_accumulating_option(link_library_directories,
+ DLLDirs),
+ { DLLDirOpts = string__append_list(list__condense(list__map(
+ (func(DLLDir) = ["/lib:", DLLDir, " "]), DLLDirs))) },
+
+ { string__append_list([CSC, " -CLR ", DebugOpt,
+ " /t:library ", DLLDirOpts, CSCFlags, " ",
+ " /out:", DLLFileName, CSharpFileName], Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+%-----------------------------------------------------------------------------%
+
+split_c_to_obj(ErrorStream, ModuleName, NumChunks, Succeeded) -->
+ split_c_to_obj(ErrorStream, ModuleName, 0, NumChunks, Succeeded).
+
+ % compile each of the C files in `<module>.dir'
+:- pred split_c_to_obj(io__output_stream, module_name,
+ int, int, bool, io__state, io__state).
+:- mode split_c_to_obj(in, in, in, in, out, di, uo) is det.
+
+split_c_to_obj(ErrorStream, ModuleName,
+ Chunk, NumChunks, Succeeded) -->
+ ( { Chunk > NumChunks } ->
+ { Succeeded = yes }
+ ;
+ globals__io_lookup_string_option(object_file_extension, Obj),
+ module_name_to_split_c_file_name(ModuleName, Chunk,
+ ".c", C_File),
+ module_name_to_split_c_file_name(ModuleName, Chunk,
+ Obj, O_File),
+ compile_c_file(ErrorStream,
+ C_File, O_File, Succeeded0),
+ ( { Succeeded0 = no } ->
+ { Succeeded = no }
+ ;
+ { Chunk1 is Chunk + 1 },
+ split_c_to_obj(ErrorStream,
+ ModuleName, Chunk1, NumChunks, Succeeded)
+ )
+ ).
+
+% WARNING: The code here duplicates the functionality of scripts/mgnuc.in.
+% Any changes there may also require changes here, and vice versa.
+
+:- type compiler_type ---> gcc ; lcc ; unknown.
+
+compile_c_file(ErrorStream, ModuleName, Succeeded) -->
+ module_name_to_file_name(ModuleName, ".c", yes, C_File),
+ globals__io_lookup_string_option(object_file_extension, ObjExt),
+ module_name_to_file_name(ModuleName, ObjExt, yes, O_File),
+ compile_c_file(ErrorStream, C_File, O_File, Succeeded).
+
+compile_c_file(ErrorStream, C_File, O_File, Succeeded) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_string_option(c_flag_to_name_object_file,
+ NameObjectFile),
+ maybe_write_string(Verbose, "% Compiling `"),
+ maybe_write_string(Verbose, C_File),
+ maybe_write_string(Verbose, "':\n"),
+ globals__io_lookup_string_option(cc, CC),
+ globals__io_lookup_accumulating_option(cflags, C_Flags_List),
+ { join_string_list(C_Flags_List, "", "", " ", CFLAGS) },
+
+ globals__io_lookup_bool_option(use_subdirs, UseSubdirs),
+ globals__io_lookup_bool_option(split_c_files, SplitCFiles),
+ { (UseSubdirs = yes ; SplitCFiles = yes) ->
+ % the source file (foo.c) will be compiled in a subdirectory
+ % (either Mercury/cs, foo.dir, or Mercury/dirs/foo.dir,
+ % depending on which of these two options is set)
+ % so we need to add `-I.' so it can
+ % include header files in the source directory.
+ SubDirInclOpt = "-I. "
+ ;
+ SubDirInclOpt = ""
+ },
+ globals__io_lookup_accumulating_option(c_include_directory,
+ C_Incl_Dirs),
+ { InclOpt = string__append_list(list__condense(list__map(
+ (func(C_INCL) = ["-I", C_INCL, " "]), C_Incl_Dirs))) },
+ globals__io_lookup_bool_option(split_c_files, Split_C_Files),
+ { Split_C_Files = yes ->
+ SplitOpt = "-DMR_SPLIT_C_FILES "
+ ;
+ SplitOpt = ""
+ },
+ globals__io_lookup_bool_option(highlevel_code, HighLevelCode),
+ ( { HighLevelCode = yes } ->
+ { HighLevelCodeOpt = "-DMR_HIGHLEVEL_CODE " }
+ ;
+ { HighLevelCodeOpt = "" }
+ ),
+ globals__io_lookup_bool_option(gcc_nested_functions,
+ GCC_NestedFunctions),
+ ( { GCC_NestedFunctions = yes } ->
+ { NestedFunctionsOpt = "-DMR_USE_GCC_NESTED_FUNCTIONS " }
+ ;
+ { NestedFunctionsOpt = "" }
+ ),
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { HighLevelDataOpt = "-DMR_HIGHLEVEL_DATA " }
+ ;
+ { HighLevelDataOpt = "" }
+ ),
+ globals__io_lookup_bool_option(gcc_global_registers, GCC_Regs),
+ ( { GCC_Regs = yes } ->
+ globals__io_lookup_string_option(cflags_for_regs,
+ CFLAGS_FOR_REGS),
+ { RegOpt = "-DMR_USE_GCC_GLOBAL_REGISTERS " }
+ ;
+ { CFLAGS_FOR_REGS = "" },
+ { RegOpt = "" }
+ ),
+ globals__io_lookup_bool_option(gcc_non_local_gotos, GCC_Gotos),
+ ( { GCC_Gotos = yes } ->
+ { GotoOpt = "-DMR_USE_GCC_NONLOCAL_GOTOS " },
+ globals__io_lookup_string_option(cflags_for_gotos,
+ CFLAGS_FOR_GOTOS)
+ ;
+ { GotoOpt = "" },
+ { CFLAGS_FOR_GOTOS = "" }
+ ),
+ globals__io_lookup_bool_option(asm_labels, ASM_Labels),
+ { ASM_Labels = yes ->
+ AsmOpt = "-DMR_USE_ASM_LABELS "
+ ;
+ AsmOpt = ""
+ },
+ globals__io_lookup_bool_option(parallel, Parallel),
+ ( { Parallel = yes } ->
+ globals__io_lookup_string_option(cflags_for_threads,
+ CFLAGS_FOR_THREADS)
+ ;
+ { CFLAGS_FOR_THREADS = "" }
+ ),
+ globals__io_get_gc_method(GC_Method),
+ { GC_Method = conservative ->
+ GC_Opt = "-DMR_CONSERVATIVE_GC "
+ ; GC_Method = accurate ->
+ GC_Opt = "-DMR_NATIVE_GC "
+ ;
+ GC_Opt = ""
+ },
+ globals__io_lookup_bool_option(profile_calls, ProfileCalls),
+ { ProfileCalls = yes ->
+ ProfileCallsOpt = "-DMR_MPROF_PROFILE_CALLS "
+ ;
+ ProfileCallsOpt = ""
+ },
+ globals__io_lookup_bool_option(profile_time, ProfileTime),
+ { ProfileTime = yes ->
+ ProfileTimeOpt = "-DMR_MPROF_PROFILE_TIME "
+ ;
+ ProfileTimeOpt = ""
+ },
+ globals__io_lookup_bool_option(profile_memory, ProfileMemory),
+ { ProfileMemory = yes ->
+ ProfileMemoryOpt = "-DMR_MPROF_PROFILE_MEMORY "
+ ;
+ ProfileMemoryOpt = ""
+ },
+ globals__io_lookup_bool_option(profile_deep, ProfileDeep),
+ { ProfileDeep = yes ->
+ ProfileDeepOpt = "-DMR_DEEP_PROFILING "
+ ;
+ ProfileDeepOpt = ""
+ },
+ globals__io_lookup_bool_option(pic_reg, PIC_Reg),
+ { PIC_Reg = yes ->
+ PIC_Reg_Opt = "-DMR_PIC_REG "
+ ;
+ PIC_Reg_Opt = ""
+ },
+ globals__io_get_tags_method(Tags_Method),
+ { Tags_Method = high ->
+ TagsOpt = "-DMR_HIGHTAGS "
+ ;
+ TagsOpt = ""
+ },
+ globals__io_lookup_int_option(num_tag_bits, NumTagBits),
+ { string__int_to_string(NumTagBits, NumTagBitsString) },
+ { string__append_list(
+ ["-DMR_TAGBITS=", NumTagBitsString, " "], NumTagBitsOpt) },
+ globals__io_lookup_bool_option(require_tracing, RequireTracing),
+ { RequireTracing = yes ->
+ RequireTracingOpt = "-DMR_REQUIRE_TRACING "
+ ;
+ RequireTracingOpt = ""
+ },
+ globals__io_lookup_bool_option(stack_trace, StackTrace),
+ { StackTrace = yes ->
+ StackTraceOpt = "-DMR_STACK_TRACE "
+ ;
+ StackTraceOpt = ""
+ },
+ globals__io_lookup_bool_option(target_debug, Target_Debug),
+ { Target_Debug = yes ->
+ Target_DebugOpt = "-g "
+ ;
+ Target_DebugOpt = ""
+ },
+ globals__io_lookup_bool_option(low_level_debug, LL_Debug),
+ { LL_Debug = yes ->
+ LL_DebugOpt = "-DMR_LOW_LEVEL_DEBUG "
+ ;
+ LL_DebugOpt = ""
+ },
+ { string__sub_string_search(CC, "gcc", _) ->
+ CompilerType = gcc
+ ; string__sub_string_search(CC, "lcc", _) ->
+ CompilerType = lcc
+ ;
+ CompilerType = unknown
+ },
+ globals__io_lookup_bool_option(use_trail, UseTrail),
+ { UseTrail = yes ->
+ UseTrailOpt = "-DMR_USE_TRAIL "
+ ;
+ UseTrailOpt = ""
+ },
+ globals__io_lookup_bool_option(reserve_tag, ReserveTag),
+ { ReserveTag = yes ->
+ ReserveTagOpt = "-DMR_RESERVE_TAG "
+ ;
+ ReserveTagOpt = ""
+ },
+ globals__io_lookup_bool_option(use_minimal_model, MinimalModel),
+ { MinimalModel = yes ->
+ MinimalModelOpt = "-DMR_USE_MINIMAL_MODEL "
+ ;
+ MinimalModelOpt = ""
+ },
+ globals__io_lookup_bool_option(type_layout, TypeLayoutOption),
+ { TypeLayoutOption = no ->
+ TypeLayoutOpt = "-DMR_NO_TYPE_LAYOUT "
+ ;
+ TypeLayoutOpt = ""
+ },
+ globals__io_lookup_bool_option(c_optimize, C_optimize),
+ { C_optimize = yes ->
+ ( CompilerType = gcc ->
+ OptimizeOpt = "-O2 -fomit-frame-pointer "
+ ; CompilerType = lcc ->
+ OptimizeOpt = ""
+ ;
+ OptimizeOpt = "-O "
+ )
+ ;
+ OptimizeOpt = ""
+ },
+ globals__io_lookup_bool_option(inline_alloc, InlineAlloc),
+ { InlineAlloc = yes ->
+ InlineAllocOpt = "-DMR_INLINE_ALLOC -DSILENT "
+ ;
+ InlineAllocOpt = ""
+ },
+ { CompilerType = gcc ->
+ % We don't enable `-Wpointer-arith', because it causes
+ % too many complaints in system header files.
+ % This is fixed in gcc 3.0, though, so at some
+ % point we should re-enable this.
+ %
+ % If --inline-alloc is enabled, don't enable missing-prototype
+ % warnings, since gc_inline.h is missing lots of prototypes.
+ %
+ % For a full list of the other gcc warnings that we don't
+ % enable, and why, see scripts/mgnuc.in.
+ ( InlineAlloc = yes ->
+ WarningOpt = "-Wall -Wwrite-strings -Wshadow -Wmissing-prototypes -Wno-unused -Wno-uninitialized "
+ ;
+ WarningOpt = "-Wall -Wwrite-strings -Wshadow -Wmissing-prototypes -Wno-unused -Wno-uninitialized -Wstrict-prototypes "
+ )
+ ; CompilerType = lcc ->
+ WarningOpt = "-w "
+ ;
+ WarningOpt = ""
+ },
+ % Be careful with the order here! Some options override others,
+ % e.g. CFLAGS_FOR_REGS must come after OptimizeOpt so that
+ % it can override -fomit-frame-pointer with -fno-omit-frame-pointer.
+ % Also be careful that each option is separated by spaces.
+ { string__append_list([CC, " ", SubDirInclOpt, InclOpt,
+ SplitOpt, OptimizeOpt,
+ HighLevelCodeOpt, NestedFunctionsOpt, HighLevelDataOpt,
+ RegOpt, GotoOpt, AsmOpt,
+ CFLAGS_FOR_REGS, " ", CFLAGS_FOR_GOTOS, " ",
+ CFLAGS_FOR_THREADS, " ",
+ GC_Opt, ProfileCallsOpt, ProfileTimeOpt, ProfileMemoryOpt,
+ ProfileDeepOpt, PIC_Reg_Opt, TagsOpt, NumTagBitsOpt,
+ Target_DebugOpt, LL_DebugOpt,
+ StackTraceOpt, RequireTracingOpt,
+ UseTrailOpt, ReserveTagOpt, MinimalModelOpt, TypeLayoutOpt,
+ InlineAllocOpt, WarningOpt, CFLAGS,
+ " -c ", C_File, " ", NameObjectFile, O_File], Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+%-----------------------------------------------------------------------------%
+
+compile_java_file(ErrorStream, ModuleName, Succeeded) -->
+ module_name_to_file_name(ModuleName, ".java", no, JavaFile),
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Compiling `"),
+ maybe_write_string(Verbose, JavaFile),
+ maybe_write_string(Verbose, "':\n"),
+ globals__io_lookup_string_option(java_compiler, JavaCompiler),
+ globals__io_lookup_accumulating_option(java_flags, JavaFlagsList),
+ { join_string_list(JavaFlagsList, "", "", " ", JAVAFLAGS) },
+
+ globals__io_lookup_accumulating_option(java_classpath,
+ Java_Incl_Dirs),
+ ( { Java_Incl_Dirs = [] } ->
+ { InclOpt = "" }
+ ;
+ % XXX PathSeparator should be ";" on Windows
+ { PathSeparator = ":" },
+ { join_string_list(Java_Incl_Dirs, "", "",
+ PathSeparator, ClassPath) },
+ { InclOpt = string__append_list([
+ "-classpath ", ClassPath, " "]) }
+ ),
+ globals__io_lookup_bool_option(target_debug, Target_Debug),
+ { Target_Debug = yes ->
+ Target_DebugOpt = "-g "
+ ;
+ Target_DebugOpt = ""
+ },
+ % Be careful with the order here! Some options may override others.
+ % Also be careful that each option is separated by spaces.
+ { string__append_list([JavaCompiler, " ", InclOpt,
+ Target_DebugOpt, JAVAFLAGS, JavaFile], Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+%-----------------------------------------------------------------------------%
+
+assemble(ErrorStream, ModuleName, Succeeded) -->
+ globals__io_lookup_bool_option(pic, Pic),
+ { AsmExt = (Pic = yes -> ".pic_s" ; ".s") },
+ module_name_to_file_name(ModuleName, AsmExt, no, AsmFile),
+ globals__io_lookup_string_option(object_file_extension, Obj),
+ module_name_to_file_name(ModuleName, Obj, yes, ObjFile),
+
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Assembling `"),
+ maybe_write_string(Verbose, AsmFile),
+ maybe_write_string(Verbose, "':\n"),
+ % XXX should we use new asm_* options rather than
+ % reusing cc, cflags, c_flag_to_name_object_file?
+ globals__io_lookup_string_option(cc, CC),
+ globals__io_lookup_string_option(c_flag_to_name_object_file,
+ NameObjectFile),
+ globals__io_lookup_accumulating_option(cflags, C_Flags_List),
+ { join_string_list(C_Flags_List, "", "", " ", CFLAGS) },
+ % Be careful with the order here.
+ % Also be careful that each option is separated by spaces.
+ { string__append_list([CC, " ", CFLAGS,
+ " -c ", AsmFile, " ", NameObjectFile, ObjFile], Command) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ Command, Succeeded).
+
+%-----------------------------------------------------------------------------%
+
+link_module_list(Modules, Succeeded) -->
+ globals__io_lookup_string_option(output_file_name, OutputFileName0),
+ ( { OutputFileName0 = "" } ->
+ ( { Modules = [Module | _] } ->
+ { OutputFileName = Module }
+ ;
+ { error("link_module_list: no modules") }
+ )
+ ;
+ { OutputFileName = OutputFileName0 }
+ ),
+
+ { file_name_to_module_name(OutputFileName, MainModuleName) },
+
+ globals__io_lookup_string_option(object_file_extension, Obj),
+ globals__io_get_target(Target),
+ globals__io_lookup_bool_option(split_c_files, SplitFiles),
+ io__output_stream(OutputStream),
+ ( { Target = asm } ->
+ % for --target asm, we generate everything into a single object file
+ ( { Modules = [FirstModule | _] } ->
+ join_module_list([FirstModule], Obj, [], ObjectsList)
+ ;
+ { error("link_module_list: no modules") }
+ ),
+ { MakeLibCmdOK = yes }
+ ; { SplitFiles = yes } ->
+ globals__io_lookup_string_option(library_extension, LibExt),
+ module_name_to_file_name(MainModuleName, LibExt,
+ yes, SplitLibFileName),
+ { string__append(".dir/*", Obj, DirObj) },
+ join_module_list(Modules, DirObj, [], ObjectList),
+ create_archive(OutputStream, SplitLibFileName,
+ ObjectList, MakeLibCmdOK),
+ { ObjectsList = [SplitLibFileName] }
+ ;
+ { MakeLibCmdOK = yes },
+ join_module_list(Modules, Obj, [], ObjectsList)
+ ),
+ ( { MakeLibCmdOK = no } ->
+ { Succeeded = no }
+ ;
+ { list__map(
+ (pred(ModuleStr::in, ModuleName::out) is det :-
+ dir__basename(ModuleStr, ModuleStrBase),
+ file_name_to_module_name(ModuleStrBase, ModuleName)
+ ),
+ Modules, ModuleNames) },
+ { MustCompile = yes },
+ make_init_obj_file(OutputStream,
+ MustCompile, MainModuleName, ModuleNames, InitObjResult),
+ (
+ { InitObjResult = yes(InitObjFileName) },
+ globals__io_lookup_accumulating_option(link_objects,
+ ExtraLinkObjectsList),
+ link(OutputStream, executable, MainModuleName,
+ [InitObjFileName | ObjectsList] ++ ExtraLinkObjectsList,
+ Succeeded)
+ ;
+ { InitObjResult = no },
+ { Succeeded = no }
+ )
+ ).
+
+make_init_obj_file(ErrorStream,
+ ModuleName, ModuleNames, Result) -->
+ { MustCompile = no },
+ make_init_obj_file(ErrorStream,
+ MustCompile, ModuleName, ModuleNames, Result).
+
+:- pred make_init_obj_file(io__output_stream, bool,
+ module_name, list(module_name), maybe(file_name),
+ io__state, io__state).
+:- mode make_init_obj_file(in,
+ in, in, in, out, di, uo) is det.
+
+make_init_obj_file(ErrorStream, MustCompile, ModuleName,
+ ModuleNames, Result) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(statistics, Stats),
+ maybe_write_string(Verbose, "% Creating initialization file...\n"),
+
+ globals__io_get_trace_level(TraceLevel),
+ { trace_level_is_none(TraceLevel) = no ->
+ TraceOpt = "--trace "
+ ;
+ TraceOpt = ""
+ },
+ globals__io_get_globals(Globals),
+ { compute_grade(Globals, Grade) },
+
+ globals__io_lookup_string_option(object_file_extension, Obj),
+ { string__append("_init", Obj, InitObj) },
+ module_name_to_file_name(ModuleName, "_init.c", yes, InitCFileName),
+ module_name_to_file_name(ModuleName, InitObj, yes, InitObjFileName),
+
+ list__map_foldl(
+ (pred(ThisModuleName::in, CFileName::out, di, uo) is det -->
+ module_name_to_file_name(ThisModuleName, ".c", no,
+ CFileName)
+ ), ModuleNames, CFileNameList),
+ { join_string_list(CFileNameList, "", "", " ", CFileNames) },
+
+ globals__io_lookup_accumulating_option(link_flags, LinkFlagsList),
+ { join_string_list(LinkFlagsList, "", "", " ", LinkFlags) },
+
+ globals__io_lookup_accumulating_option(init_file_directories,
+ InitFileDirsList),
+ { join_string_list(InitFileDirsList, "-I ", "", " ", InitFileDirs) },
+
+ globals__io_lookup_accumulating_option(init_files, InitFileNamesList),
+ { join_string_list(InitFileNamesList, "", "", " ", InitFileNames) },
+
+ { TmpInitCFileName = InitCFileName ++ ".tmp" },
+ { MkInitCmd = string__append_list(
+ ["c2init --grade ", Grade, " ", TraceOpt, LinkFlags,
+ " --init-c-file ", TmpInitCFileName, " ",
+ InitFileDirs, " ", InitFileNames, " ", CFileNames]) },
+ invoke_shell_command(ErrorStream, verbose, MkInitCmd, MkInitOK0),
+ maybe_report_stats(Stats),
+ ( { MkInitOK0 = yes } ->
+ update_interface(InitCFileName, MkInitOK1),
+ (
+ { MkInitOK1 = yes },
+
+ (
+ { MustCompile = yes },
+ { Compile = yes }
+ ;
+ { MustCompile = no },
+ io__file_modification_time(InitCFileName,
+ InitCModTimeResult),
+ io__file_modification_time(InitObjFileName,
+ InitObjModTimeResult),
+ {
+ InitObjModTimeResult = ok(InitObjModTime),
+ InitCModTimeResult = ok(InitCModTime),
+ compare(TimeCompare, InitObjModTime, InitCModTime),
+ ( TimeCompare = (=)
+ ; TimeCompare = (>)
+ )
+ ->
+ Compile = no
+ ;
+ Compile = yes
+ }
+ ),
+
+ (
+ { Compile = yes },
+ maybe_write_string(Verbose,
+ "% Compiling initialization file...\n"),
+
+ compile_c_file(ErrorStream, InitCFileName,
+ InitObjFileName, CompileOK),
+ maybe_report_stats(Stats),
+ ( { CompileOK = no } ->
+ { Result = no }
+ ;
+ { Result = yes(InitObjFileName) }
+ )
+ ;
+ { Compile = no },
+ { Result = yes(InitObjFileName) }
+ )
+ ;
+ { MkInitOK1 = no },
+ { Result = no }
+ )
+ ;
+ { Result = no }
+ ).
+
+link(ErrorStream, LinkTargetType, ModuleName,
+ ObjectsList, Succeeded) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(statistics, Stats),
+
+ globals__io_get_trace_level(TraceLevel),
+ { trace_level_is_none(TraceLevel) = no ->
+ TraceOpt = "--trace "
+ ;
+ TraceOpt = ""
+ },
+ globals__io_get_globals(Globals),
+ { compute_grade(Globals, Grade) },
+
+ maybe_write_string(Verbose, "% Linking...\n"),
+ ( { LinkTargetType = static_library } ->
+ globals__io_lookup_string_option(library_extension, LibExt),
+ module_name_to_file_name(ModuleName, LibExt, yes, LibName),
+ create_archive(ErrorStream, LibName, ObjectsList, ArCmdOK),
+ maybe_report_stats(Stats),
+ ( { ArCmdOK = no } ->
+ { Succeeded = no }
+ ;
+ { Succeeded = yes }
+ )
+ ;
+ { LinkTargetType = shared_library ->
+ SharedLibOpt = "--make-shared-lib ",
+ FileExtOpt = shared_library_extension
+ ;
+ SharedLibOpt = "",
+ FileExtOpt = executable_file_extension
+ },
+ globals__io_lookup_string_option(FileExtOpt, OutputFileExt),
+ module_name_to_file_name(ModuleName, OutputFileExt,
+ yes, OutputFileName),
+ globals__io_lookup_bool_option(target_debug, Target_Debug),
+ { Target_Debug = yes ->
+ Target_Debug_Opt = "--no-strip "
+ ;
+ Target_Debug_Opt = ""
+ },
+ { join_string_list(ObjectsList, "", "", " ", Objects) },
+ globals__io_lookup_accumulating_option(link_flags,
+ LinkFlagsList),
+ { join_string_list(LinkFlagsList, "", "", " ", LinkFlags) },
+ globals__io_lookup_accumulating_option(
+ link_library_directories,
+ LinkLibraryDirectoriesList),
+ { join_string_list(LinkLibraryDirectoriesList, "-L", "",
+ " ", LinkLibraryDirectories) },
+ globals__io_lookup_accumulating_option(link_libraries,
+ LinkLibrariesList),
+ { join_string_list(LinkLibrariesList, "-l", "", " ",
+ LinkLibraries) },
+ { string__append_list(
+ ["ml --grade ", Grade, " ", SharedLibOpt,
+ Target_Debug_Opt, TraceOpt, LinkFlags,
+ " -o ", OutputFileName, " ", Objects, " ",
+ LinkLibraryDirectories, " ", LinkLibraries],
+ LinkCmd) },
+ invoke_shell_command(ErrorStream, verbose_commands,
+ LinkCmd, Succeeded),
+ maybe_report_stats(Stats)
+ ).
+
+:- pred create_archive(io__output_stream, file_name, list(file_name),
+ bool, io__state, io__state).
+:- mode create_archive(in, in, in, out, di, uo) is det.
+
+create_archive(ErrorStream, LibFileName, ObjectList, MakeLibCmdOK) -->
+ globals__io_lookup_string_option(create_archive_command, ArCmd),
+ globals__io_lookup_accumulating_option(
+ create_archive_command_flags, ArFlagsList),
+ { join_string_list(ArFlagsList, "", "", " ", ArFlags) },
+ globals__io_lookup_string_option(
+ create_archive_command_output_flag, ArOutputFlag),
+ globals__io_lookup_string_option(ranlib_command, RanLib),
+ { list__append(
+ [ArCmd, " ", ArFlags, " ", ArOutputFlag, " ",
+ LibFileName, " " | ObjectList],
+ [" && ", RanLib, " ", LibFileName],
+ MakeLibCmdList) },
+ { string__append_list(MakeLibCmdList, MakeLibCmd) },
+ invoke_system_command(ErrorStream, verbose_commands,
+ MakeLibCmd, MakeLibCmdOK).
+
+ % join_string_list(Strings, Prefix, Suffix, Serarator, Result)
+ %
+ % Appends the strings in the list `Strings' together into the
+ % string Result. Each string is prefixed by Prefix, suffixed by
+ % Suffix and separated by Separator.
+
+:- pred join_string_list(list(string), string, string, string, string).
+:- mode join_string_list(in, in, in, in, out) is det.
+
+join_string_list([], _Prefix, _Suffix, _Separator, "").
+join_string_list([String | Strings], Prefix, Suffix, Separator, Result) :-
+ ( Strings = [] ->
+ string__append_list([Prefix, String, Suffix], Result)
+ ;
+ join_string_list(Strings, Prefix, Suffix, Separator, Result0),
+ string__append_list([Prefix, String, Suffix, Separator,
+ Result0], Result)
+ ).
+
+ % join_module_list(ModuleNames, Extension, Terminator, Result)
+ %
+ % The list of strings `Result' is computed from the list of strings
+ % `ModuleNames', by removing any directory paths, and
+ % converting the strings to file names and then back,
+ % adding the specified Extension. (This conversion ensures
+ % that we follow the usual file naming conventions.)
+ % Each file name is separated by a space from the next one,
+ % and the result is followed by the list of strings `Terminator'.
+
+:- pred join_module_list(list(string), string, list(string), list(string),
+ io__state, io__state).
+:- mode join_module_list(in, in, in, out, di, uo) is det.
+
+join_module_list([], _Extension, Terminator, Terminator) --> [].
+join_module_list([Module | Modules], Extension, Terminator,
+ [FileName, " " | Rest]) -->
+ { dir__basename(Module, BaseName) },
+ { file_name_to_module_name(BaseName, ModuleName) },
+ module_name_to_file_name(ModuleName, Extension, no, FileName),
+ join_module_list(Modules, Extension, Terminator, Rest).
+
+%-----------------------------------------------------------------------------%
write_num_split_c_files(ModuleName, NumChunks, Succeeded) -->
module_name_to_file_name(ModuleName, ".num_split", yes,
@@ -123,3 +962,4 @@
[]
).
+%-----------------------------------------------------------------------------%
Index: make.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.m,v
retrieving revision 1.1
diff -u -u -r1.1 make.m
--- make.m 12 Mar 2002 16:32:34 -0000 1.1
+++ make.m 13 Mar 2002 06:04:47 -0000
@@ -48,6 +48,7 @@
:- import_module globals, options, handle_options, modules.
:- import_module prog_data, foreign, mercury_compile, mercury_to_mercury.
:- import_module prog_io, prog_out, prog_io_util, timestamp.
+:- import_module compile_target_code, process_util.
:- import_module assoc_list, bool, char, dir, exception, getopt, int, list.
:- import_module map, parser, require, set, std_util, string, term, term_io.
Index: make.module_target.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.module_target.m,v
retrieving revision 1.1
diff -u -u -r1.1 make.module_target.m
--- make.module_target.m 12 Mar 2002 16:32:34 -0000 1.1
+++ make.module_target.m 17 Mar 2002 15:54:07 -0000
@@ -283,13 +283,13 @@
io__state::di, io__state::uo) is det.
build_object_code(ModuleName, c, ErrorStream, _Imports, Succeeded) -->
- mercury_compile__compile_c_file(ErrorStream, ModuleName, Succeeded).
+ compile_target_code__compile_c_file(ErrorStream, ModuleName, Succeeded).
build_object_code(ModuleName, asm, ErrorStream, _Imports, Succeeded) -->
- mercury_compile__assemble(ErrorStream, ModuleName, Succeeded).
+ compile_target_code__assemble(ErrorStream, ModuleName, Succeeded).
build_object_code(ModuleName, java, ErrorStream, _Imports, Succeeded) -->
- mercury_compile__compile_java_file(ErrorStream, ModuleName, Succeeded).
+ compile_target_code__compile_java_file(ErrorStream, ModuleName, Succeeded).
build_object_code(ModuleName, il, ErrorStream, Imports, Succeeded) -->
- mercury_compile__il_assemble(ErrorStream, ModuleName,
+ compile_target_code__il_assemble(ErrorStream, ModuleName,
Imports ^ has_main, Succeeded).
:- pred compile_foreign_code_file(io__output_stream::in, foreign_code_file::in,
@@ -297,21 +297,21 @@
compile_foreign_code_file(ErrorStream, foreign_code_file(c, CFile, ObjFile),
Succeeded) -->
- mercury_compile__compile_c_file(ErrorStream,
+ compile_target_code__compile_c_file(ErrorStream,
CFile, ObjFile, Succeeded).
compile_foreign_code_file(ErrorStream, foreign_code_file(il, ILFile, DLLFile),
Succeeded) -->
- mercury_compile__il_assemble(ErrorStream, ILFile, DLLFile,
+ compile_target_code__il_assemble(ErrorStream, ILFile, DLLFile,
no_main, Succeeded).
compile_foreign_code_file(ErrorStream,
foreign_code_file(managed_cplusplus, MCPPFile, DLLFile),
Succeeded) -->
- mercury_compile__compile_managed_cplusplus_file(ErrorStream,
+ compile_target_code__compile_managed_cplusplus_file(ErrorStream,
MCPPFile, DLLFile, Succeeded).
compile_foreign_code_file(ErrorStream,
foreign_code_file(csharp, CSharpFile, DLLFile),
Succeeded) -->
- mercury_compile__compile_csharp_file(ErrorStream,
+ compile_target_code__compile_csharp_file(ErrorStream,
CSharpFile, DLLFile, Succeeded).
%-----------------------------------------------------------------------------%
Index: make.program_target.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.program_target.m,v
retrieving revision 1.1
diff -u -u -r1.1 make.program_target.m
--- make.program_target.m 12 Mar 2002 16:32:34 -0000 1.1
+++ make.program_target.m 17 Mar 2002 15:54:57 -0000
@@ -148,7 +148,7 @@
{ FileType = executable },
{ CompilationTarget = c ; CompilationTarget = asm }
->
- mercury_compile__make_init_obj_file(ErrorStream,
+ compile_target_code__make_init_obj_file(ErrorStream,
MainModuleName, AllModulesList, InitObjectResult),
(
{ InitObjectResult = yes(InitObject) },
@@ -235,16 +235,16 @@
% Run the link in a separate process so it can
% be killed if an interrupt is received.
call_in_forked_process(
- mercury_compile__link(ErrorStream, FileType,
- MainModuleName, AllObjects),
+ compile_target_code__link(ErrorStream,
+ FileType, MainModuleName, AllObjects),
Succeeded)
;
{ CompilationTarget = asm },
% Run the link in a separate process so it can
% be killed if an interrupt is received.
call_in_forked_process(
- mercury_compile__link(ErrorStream, FileType,
- MainModuleName, AllObjects),
+ compile_target_code__link(ErrorStream,
+ FileType, MainModuleName, AllObjects),
Succeeded)
;
%
Index: make.util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.util.m,v
retrieving revision 1.1
diff -u -u -r1.1 make.util.m
--- make.util.m 12 Mar 2002 16:32:34 -0000 1.1
+++ make.util.m 13 Mar 2002 06:00:18 -0000
@@ -42,35 +42,6 @@
IO::di, IO::uo) is det.
%-----------------------------------------------------------------------------%
- % Code to handle cleaning up when a signal is received.
-
-:- type build0 == pred(bool, make_info, make_info, io__state, io__state).
-:- inst build0 == (pred(out, in, out, di, uo) is det).
-
-:- type post_signal_cleanup ==
- pred(make_info, make_info, io__state, io__state).
-:- inst post_signal_cleanup == (pred(in, out, di, uo) is det).
-
- % build_with_check_for_interrupt(Build, Cleanup,
- % Succeeded, Info0, Info)
- %
- % Apply `Build' with signal handlers installed to check for signals
- % which would normally kill the process. If a signal occurs call
- % `Cleanup', then restore signal handlers to their defaults and
- % reraise the signal to kill the current process.
- % An action being performed in a child process by
- % call_in_forked_process will be killed if a fatal signal
- % (SIGINT, SIGTERM, SIGHUP or SIGQUIT) is received by the
- % current process.
- % An action being performed within the current process or by
- % system() will run to completion, with the interrupt being taken
- % immediately afterwards.
-:- pred build_with_check_for_interrupt(build0::in(build0),
- post_signal_cleanup::in(post_signal_cleanup),
- bool::out, make_info::in, make_info::out,
- io__state::di, io__state::uo) is det.
-
-%-----------------------------------------------------------------------------%
:- type build(T) == pred(T, bool, make_info, make_info, io__state, io__state).
:- inst build == (pred(in, out, in, out, di, uo) is det).
@@ -109,30 +80,6 @@
io__state::di, io__state::uo) is det.
%-----------------------------------------------------------------------------%
-
-:- type io_pred == pred(bool, io__state, io__state).
-:- inst io_pred == (pred(out, di, uo) is det).
-
- % call_in_forked_process(P, AltP, Succeeded)
- %
- % Execute `P' in a separate process.
- %
- % We prefer to use fork() rather than system() because
- % that will avoid shell and Mercury runtime startup overhead.
- % Interrupt handling will also work better (system() on Linux
- % ignores SIGINT).
- %
- % If fork() is not supported on the current architecture,
- % `AltP' will be called instead in the current process.
-:- pred call_in_forked_process(io_pred::in(io_pred), io_pred::in(io_pred),
- bool::out, io__state::di, io__state::uo) is det.
-
- % As above, but if fork() is not available, just call the
- % predicate in the current process.
-:- pred call_in_forked_process(io_pred::in(io_pred),
- bool::out, io__state::di, io__state::uo) is det.
-
-%-----------------------------------------------------------------------------%
% Timestamp handling.
% Find the timestamp updated when a target is produced.
@@ -285,333 +232,6 @@
{ Acc = Acc0 },
{ Info = Info0 }
).
-
-%-----------------------------------------------------------------------------%
-
-build_with_check_for_interrupt(Build, Cleanup, Succeeded, Info0, Info) -->
- setup_signal_handlers(MaybeSigIntHandler),
- Build(Succeeded0, Info0, Info1),
- restore_signal_handlers(MaybeSigIntHandler),
- check_for_signal(Signalled, Signal),
- ( { Signalled = 1 } ->
- { Succeeded = no },
- verbose_msg(
- (pred(di, uo) is det -->
- io__write_string("** Received signal "),
- io__write_int(Signal),
- io__write_string(", cleaning up.\n")
- )),
- Cleanup(Info1, Info),
-
- % The signal handler has been restored to the default,
- % so this should kill us.
- raise_signal(Signal)
- ;
- { Succeeded = Succeeded0 },
- { Info = Info1 }
- ).
-
-:- type signal_action ---> signal_action(c_pointer).
-
-:- pragma foreign_decl("C",
-"
-#ifdef MR_HAVE_UNISTD_H
- #include <unistd.h>
-#endif
-
-#ifdef MR_HAVE_SYS_TYPES_H
- #include <sys/types.h>
-#endif
-
-#ifdef MR_HAVE_SYS_WAIT_H
- #include <sys/wait.h>
-#endif
-
-#include <errno.h>
-
-#include ""mercury_signal.h""
-#include ""mercury_types.h""
-#include ""mercury_heap.h""
-#include ""mercury_misc.h""
-
-#if defined(MR_HAVE_FORK) && defined(MR_HAVE_WAIT) && defined(MR_HAVE_KILL)
- #define MC_CAN_FORK 1
-#endif
-
-#define MC_SETUP_SIGNAL_HANDLER(sig, handler) \
- MR_setup_signal(sig, (MR_Code *) handler, MR_FALSE, \
- ""mercury_compile: cannot install signal handler"");
-
- /* Have we received a signal. */
-volatile sig_atomic_t MC_signalled;
-
- /*
- ** Which signal did we receive.
- ** XXX This assumes a signal number will fit into a sig_atomic_t.
- */
-volatile sig_atomic_t MC_signal_received;
-
-void MC_mercury_compile_signal_handler(int sig);
-").
-
-:- pragma foreign_code("C",
-"
-volatile sig_atomic_t MC_signalled = MR_FALSE;
-volatile sig_atomic_t MC_signal_received = 0;
-
-void
-MC_mercury_compile_signal_handler(int sig)
-{
- MC_signalled = MR_TRUE;
- MC_signal_received = sig;
-}
-").
-
-:- pred setup_signal_handlers(maybe(signal_action)::out,
- io__state::di, io__state::uo) is det.
-
-setup_signal_handlers(MaybeSigIntHandler) -->
- ( { have_signal_handlers(1) } ->
- setup_signal_handlers_2(SigintHandler),
- { MaybeSigIntHandler = yes(SigintHandler) }
- ;
- { MaybeSigIntHandler = no }
- ).
-
- % Dummy argument to work around bug mixing Mercury and foreign clauses.
-:- pred have_signal_handlers(T::unused) is semidet.
-
-have_signal_handlers(_::unused) :- semidet_fail.
-
-:- pragma foreign_proc("C", have_signal_handlers(_T::unused),
- [will_not_call_mercury, promise_pure],
-"{
- SUCCESS_INDICATOR = MR_TRUE;
-}").
-
-:- pred setup_signal_handlers_2(signal_action::out,
- io__state::di, io__state::uo) is det.
-
-setup_signal_handlers_2(_::out, _::di, _::uo) :-
- error("setup_signal_handlers_2").
-
-:- pragma foreign_proc("C",
- setup_signal_handlers_2(SigintHandler::out, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure],
-"{
- IO = IO0;
- MC_signalled = MR_FALSE;
-
- MR_incr_hp_msg(SigintHandler,
- MR_bytes_to_words(sizeof(MR_signal_action)),
- MR_PROC_LABEL, ""make.util.signal_action/0"");
-
- /*
- ** mdb sets up a SIGINT handler, so we should restore
- ** it after we're done.
- */
- MR_get_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
- ""error getting SIGINT handler"");
- MC_SETUP_SIGNAL_HANDLER(SIGINT, MC_mercury_compile_signal_handler);
- MC_SETUP_SIGNAL_HANDLER(SIGTERM, MC_mercury_compile_signal_handler);
-#ifdef SIGHUP
- MC_SETUP_SIGNAL_HANDLER(SIGHUP, MC_mercury_compile_signal_handler);
-#endif
-#ifdef SIGQUIT
- MC_SETUP_SIGNAL_HANDLER(SIGQUIT, MC_mercury_compile_signal_handler);
-#endif
-}").
-
-:- pred restore_signal_handlers(maybe(signal_action)::in,
- io__state::di, io__state::uo) is det.
-
-restore_signal_handlers(no) --> [].
-restore_signal_handlers(yes(SigintHandler)) -->
- restore_signal_handlers_2(SigintHandler).
-
-:- pred restore_signal_handlers_2(signal_action::in,
- io__state::di, io__state::uo) is det.
-
-restore_signal_handlers_2(_::in, _::di, _::uo) :-
- error("restore_signal_handlers_2").
-
-:- pragma foreign_proc("C",
- restore_signal_handlers_2(SigintHandler::in, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure],
-"{
- IO = IO0;
- MR_set_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
- ""error resetting SIGINT handler"");
- MC_SETUP_SIGNAL_HANDLER(SIGTERM, SIG_DFL);
-#ifdef SIGHUP
- MC_SETUP_SIGNAL_HANDLER(SIGHUP, SIG_DFL);
-#endif
-#ifdef SIGQUIT
- MC_SETUP_SIGNAL_HANDLER(SIGQUIT, SIG_DFL);
-#endif
-}").
-
-:- pred check_for_signal(int::out, int::out,
- io__state::di, io__state::uo) is det.
-
-:- pragma foreign_proc("C",
- check_for_signal(Signalled::out, Signal::out, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure],
-"
- IO = IO0;
- Signalled = (MC_signalled ? 1 : 0);
- Signal = MC_signal_received;
-").
-
-:- pred raise_signal(int::in, io__state::di, io__state::uo) is det.
-
-:- pragma foreign_proc("C",
- raise_signal(Signal::in, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure],
-"
- IO = IO0;
- raise(Signal);
-").
-
-%-----------------------------------------------------------------------------%
-
-call_in_forked_process(P, Success) -->
- call_in_forked_process(P, P, Success).
-
-call_in_forked_process(P, AltP, Success) -->
- ( { can_fork(1) } ->
- debug_msg(io__write_string("call_in_forked_process\n")),
- call_in_forked_process_2(P, ForkStatus, CallStatus),
- { ForkStatus = 1 ->
- Success = no
- ;
- Status = io__handle_system_command_exit_status(
- CallStatus),
- Success = (Status = ok(exited(0)) -> yes ; no)
- },
- debug_msg(io__write_string(
- "finished call_in_forked_process\n"))
- ;
- AltP(Success)
- ).
-
- % Dummy argument to work around bug mixing Mercury and foreign clauses.
-:- pred can_fork(T::unused) is semidet.
-
-can_fork(_::unused) :- semidet_fail.
-
-:- pragma foreign_proc("C", can_fork(_T::unused),
- [will_not_call_mercury, thread_safe, promise_pure],
-"
-#ifdef MC_CAN_FORK
- SUCCESS_INDICATOR = MR_TRUE;
-#else
- SUCCESS_INDICATOR = MR_FALSE;
-#endif
-").
-
-:- pred call_in_forked_process_2(io_pred::in(io_pred), int::out, int::out,
- io__state::di, io__state::uo) is det.
-
-call_in_forked_process_2(_::in(io_pred), _::out, _::out, _::di, _::uo) :-
- error("call_in_forked_process_2").
-
-:- pragma foreign_proc("C",
- call_in_forked_process_2(Pred::in(io_pred),
- ForkStatus::out, Status::out, IO0::di, IO::uo),
- [may_call_mercury, promise_pure],
-"{
-#ifdef MC_CAN_FORK
- pid_t child_pid;
-
- IO = IO0;
- ForkStatus = 0;
- Status = 0;
-
- child_pid = fork();
- if (child_pid == -1) { /* error */
- MR_perror(""error in fork()"");
- ForkStatus = 1;
- } else if (child_pid == 0) { /* child */
- MR_Integer exit_status;
-
- MC_call_io_pred(Pred, &exit_status);
- exit(exit_status);
- } else { /* parent */
- int child_status;
- pid_t wait_status;
-
- /*
- ** Make sure the wait() is interrupted by the signals
- ** which cause us to exit.
- */
- MR_signal_should_restart(SIGINT, MR_FALSE);
- MR_signal_should_restart(SIGTERM, MR_FALSE);
-#ifdef SIGHUP
- MR_signal_should_restart(SIGHUP, MR_FALSE);
-#endif
-#ifdef SIGQUIT
- MR_signal_should_restart(SIGQUIT, MR_FALSE);
-#endif
-
- while (1) {
- wait_status = wait(&child_status);
- if (wait_status == child_pid) {
- Status = child_status;
- break;
- } else if (wait_status == -1) {
- if (errno == EINTR) {
- if (MC_signalled) {
- /*
- ** A normally fatal signal has been received,
- ** so kill the child immediately.
- ** Use SIGTERM, not MC_signal_received,
- ** because the child may be inside a call
- ** to system() which would cause SIGINT
- ** to be ignored on some systems (e.g. Linux).
- */
- kill(child_pid, SIGTERM);
- }
- } else {
- /*
- ** This should never happen.
- */
- MR_perror(""error in wait(): "");
- ForkStatus = 1;
- Status = 1;
- break;
- }
- }
- }
-
- /*
- ** Restore the system call signal behaviour.
- */
- MR_signal_should_restart(SIGINT, MR_TRUE);
- MR_signal_should_restart(SIGTERM, MR_TRUE);
-#ifdef SIGHUP
- MR_signal_should_restart(SIGHUP, MR_TRUE);
-#endif
-#ifdef SIGQUIT
- MR_signal_should_restart(SIGQUIT, MR_TRUE);
-#endif
-
- }
-#else /* ! MC_CAN_FORK */
- IO = IO0;
- ForkStatus = 1;
- Status = 1;
-#endif /* ! MC_CAN_FORK */
-}").
-
- % call_io_pred(P, ExitStatus).
-:- pred call_io_pred(io_pred::in(io_pred), int::out,
- io__state::di, io__state::uo) is det.
-:- pragma export(call_io_pred(in(io_pred), out, di, uo), "MC_call_io_pred").
-
-call_io_pred(P, Status) -->
- P(Success),
- { Status = ( Success = yes -> 0 ; 1 ) }.
%-----------------------------------------------------------------------------%
Index: mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.239
diff -u -u -r1.239 mercury_compile.m
--- mercury_compile.m 12 Mar 2002 16:32:42 -0000 1.239
+++ mercury_compile.m 17 Mar 2002 15:33:21 -0000
@@ -16,8 +16,7 @@
:- module mercury_compile.
:- interface.
-:- import_module modules, prog_io, prog_data.
-:- import_module bool, io, list, std_util.
+:- import_module io, list.
:- pred main(io__state, io__state).
:- mode main(di, uo) is det.
@@ -26,73 +25,6 @@
:- pred main(list(string), io__state, io__state).
:- mode main(in, di, uo) is det.
- % The predicates below are used by mercury_compile.m
- % and by make.m and its sub-modules.
- % XXX Move the following into compile_target_code.m.
-
- % mercury_compile__compile_c_file(ErrorStream, CFile,
- % ObjFile, Succeeded).
-:- pred mercury_compile__compile_c_file(io__output_stream, string, string,
- bool, io__state, io__state).
-:- mode mercury_compile__compile_c_file(in, in, in, out, di, uo) is det.
-
-:- pred mercury_compile__compile_c_file(io__output_stream, module_name,
- bool, io__state, io__state).
-:- mode mercury_compile__compile_c_file(in, in, out, di, uo) is det.
-
- % mercury_compile__split_c_to_obj(ErrorStream, ModuleName,
- % NumChunks, Succeeded).
- % Compile the `.c' files produced for a module with `--split-c-files'.
-:- pred mercury_compile__split_c_to_obj(io__output_stream, module_name,
- int, bool, io__state, io__state).
-:- mode mercury_compile__split_c_to_obj(in, in, in, out, di, uo) is det.
-
-:- pred mercury_compile__assemble(io__output_stream,
- module_name, bool, io__state, io__state).
-:- mode mercury_compile__assemble(in, in, out, di, uo) is det.
-
-:- pred mercury_compile__compile_java_file(io__output_stream,
- module_name, bool, io__state, io__state).
-:- mode mercury_compile__compile_java_file(in, in, out, di, uo) is det.
-
- % mercury_compile__il_assemble(ErrorStream,
- % ModuleName, HasMain, Succeeded).
-:- pred mercury_compile__il_assemble(io__output_stream, module_name,
- has_main, bool, io__state, io__state).
-:- mode mercury_compile__il_assemble(in, in, in, out, di, uo) is det.
-
-:- pred mercury_compile__il_assemble(io__output_stream, file_name, file_name,
- has_main, bool, io__state, io__state).
-:- mode mercury_compile__il_assemble(in, in, in, in, out, di, uo) is det.
-
-:- pred mercury_compile__compile_managed_cplusplus_file(io__output_stream,
- file_name, file_name, bool, io__state, io__state).
-:- mode mercury_compile__compile_managed_cplusplus_file(in, in, in,
- out, di, uo) is det.
-
-:- pred mercury_compile__compile_csharp_file(io__output_stream,
- file_name, file_name, bool, io__state, io__state).
-:- mode mercury_compile__compile_csharp_file(in, in, in, out, di, uo) is det.
-
- % mercury_compile__make_init_obj_file(ErrorStream,
- % MainModuleName, AllModuleNames, MaybeInitObjFileName).
-:- pred mercury_compile__make_init_obj_file(io__output_stream,
- module_name, list(module_name), maybe(file_name),
- io__state, io__state) is det.
-:- mode mercury_compile__make_init_obj_file(in, in, in, out, di, uo) is det.
-
-:- type linked_target_type
- ---> executable
- ; static_library
- ; shared_library
- .
-
- % mercury_compile__link(TargetType, MainModuleName,
- % ObjectFileNames, Succeeded).
-:- pred mercury_compile__link(io__output_stream, linked_target_type,
- module_name, list(string), bool, io__state, io__state).
-:- mode mercury_compile__link(in, in, in, in, out, di, uo) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -150,7 +82,7 @@
:- import_module layout, dependency_graph, prog_util, rl_dump, rl_file.
:- import_module options, globals, trace_params, passes_aux.
:- import_module recompilation, recompilation_usage, recompilation_check.
-:- import_module options_file, make, timestamp.
+:- import_module options_file, make, timestamp, compile_target_code.
% library modules
:- import_module int, list, map, set, std_util, require, string, bool, dir.
@@ -238,7 +170,7 @@
io__get_exit_status(ExitStatus),
( { ExitStatus = 0 } ->
( { Link = yes } ->
- mercury_compile__link_module_list(
+ compile_target_code__link_module_list(
ModulesToLink, _Succeeded)
;
[]
@@ -399,7 +331,7 @@
TargetCodeOnly),
( { Result = ok, TargetCodeOnly = no } ->
io__output_stream(OutputStream),
- mercury_compile__assemble(OutputStream,
+ compile_target_code__assemble(OutputStream,
ModuleName, _AssembleOK)
;
[]
@@ -1140,7 +1072,7 @@
MLDS) },
mercury_compile__mlds_to_il_assembler(MLDS),
io__output_stream(OutputStream),
- mercury_compile__il_assemble(OutputStream,
+ compile_target_code__il_assemble(OutputStream,
ModuleName, HasMain, _Succeeded)
)
; { Target = java } ->
@@ -1151,7 +1083,7 @@
[]
;
io__output_stream(OutputStream),
- mercury_compile__compile_java_file(
+ compile_target_code__compile_java_file(
OutputStream, ModuleName, _Succeeded)
)
; { Target = asm } ->
@@ -1184,7 +1116,7 @@
ForeignModuleName, Obj,
yes, CCode_O_File),
io__output_stream(OutputStream),
- mercury_compile__compile_c_file(
+ compile_target_code__compile_c_file(
OutputStream, CCode_C_File,
CCode_O_File, _CompileOK),
% add this object file to the list
@@ -1212,8 +1144,9 @@
module_name_to_file_name(ModuleName, Obj, yes,
O_File),
io__output_stream(OutputStream),
- mercury_compile__compile_c_file(OutputStream,
- C_File, O_File, _CompileOK)
+ compile_target_code__compile_c_file(
+ OutputStream, C_File, O_File,
+ _CompileOK)
)
;
mercury_compile__backend_pass(HLDS50, HLDS,
@@ -3326,6 +3259,23 @@
maybe_flush_output(Verbose),
maybe_report_stats(Stats).
+:- pred mercury_compile__c_to_obj(io__output_stream, module_name,
+ int, bool, io__state, io__state).
+:- mode mercury_compile__c_to_obj(in, in, in, out, di, uo) is det.
+
+mercury_compile__c_to_obj(ErrorStream, ModuleName, NumChunks, Succeeded) -->
+ globals__io_lookup_bool_option(split_c_files, SplitFiles),
+ ( { SplitFiles = yes } ->
+ compile_target_code__split_c_to_obj(ErrorStream, ModuleName,
+ NumChunks, Succeeded)
+ ;
+ globals__io_lookup_string_option(object_file_extension, Obj),
+ module_name_to_file_name(ModuleName, ".c", no, C_File),
+ module_name_to_file_name(ModuleName, Obj, yes, O_File),
+ compile_target_code__compile_c_file(ErrorStream,
+ C_File, O_File, Succeeded)
+ ).
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -3555,794 +3505,6 @@
mlds_to_ilasm__output_mlds(MLDS),
maybe_write_string(Verbose, "% Finished converting MLDS to IL.\n"),
maybe_report_stats(Stats).
-
-mercury_compile__il_assemble(ErrorStream, ModuleName,
- HasMain, Succeeded) -->
- module_name_to_file_name(ModuleName, ".il", no, IL_File),
- ( { HasMain = has_main } ->
- module_name_to_file_name(ModuleName, ".exe", no, TargetFile)
- ;
- module_name_to_file_name(ModuleName, ".dll", no, TargetFile)
- ),
- mercury_compile__il_assemble(ErrorStream, IL_File, TargetFile,
- HasMain, Succeeded).
-
-mercury_compile__il_assemble(ErrorStream, IL_File, TargetFile,
- HasMain, Succeeded) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- globals__io_lookup_bool_option(sign_assembly, SignAssembly),
- maybe_write_string(Verbose, "% Assembling `"),
- maybe_write_string(Verbose, IL_File),
- maybe_write_string(Verbose, "':\n"),
- globals__io_lookup_string_option(il_assembler, ILASM),
- globals__io_lookup_accumulating_option(ilasm_flags, ILASMFlagsList),
- { join_string_list(ILASMFlagsList, "", "", " ", ILASMFlags) },
- { SignAssembly = yes ->
- SignOpt = "/keyf=mercury.sn "
- ;
- SignOpt = ""
- },
- { Verbose = yes ->
- VerboseOpt = ""
- ;
- VerboseOpt = "/quiet "
- },
- globals__io_lookup_bool_option(target_debug, Debug),
- { Debug = yes ->
- DebugOpt = "/debug "
- ;
- DebugOpt = ""
- },
- { HasMain = has_main ->
- TargetOpt = ""
- ;
- TargetOpt = "/dll "
- },
- { string__append_list([ILASM, " ", SignOpt, VerboseOpt, DebugOpt,
- TargetOpt, ILASMFlags, " /out=", TargetFile,
- " ", IL_File], Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-mercury_compile__compile_managed_cplusplus_file(ErrorStream,
- MCPPFileName, DLLFileName, Succeeded) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- maybe_write_string(Verbose, "% Compiling `"),
- maybe_write_string(Verbose, MCPPFileName),
- maybe_write_string(Verbose, "':\n"),
- globals__io_lookup_string_option(mcpp_compiler, MCPP),
- globals__io_lookup_accumulating_option(mcpp_flags, MCPPFlagsList),
- { join_string_list(MCPPFlagsList, "", "", " ", MCPPFlags) },
- globals__io_lookup_bool_option(target_debug, Debug),
- { Debug = yes ->
- DebugOpt = "" % XXX
- ;
- DebugOpt = ""
- },
-
- % XXX Should we introduce a `--mcpp-include-directory' option?
- globals__io_lookup_accumulating_option(c_include_directory,
- C_Incl_Dirs),
- { InclOpts = string__append_list(list__condense(list__map(
- (func(C_INCL) = ["-I", C_INCL, " "]), C_Incl_Dirs))) },
-
- % XXX Should we use a separate dll_directories options?
- globals__io_lookup_accumulating_option(link_library_directories,
- DLLDirs),
- { DLLDirOpts = string__append_list(list__condense(list__map(
- (func(DLLDir) = ["-AI", DLLDir, " "]), DLLDirs))) },
-
- { string__append_list([MCPP, " -CLR ", DebugOpt, InclOpts,
- DLLDirOpts, MCPPFlags, " ", MCPPFileName,
- "-link -noentry mscoree.lib -dll -out:", DLLFileName],
- Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-mercury_compile__compile_csharp_file(ErrorStream,
- CSharpFileName, DLLFileName, Succeeded) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- maybe_write_string(Verbose, "% Compiling `"),
- maybe_write_string(Verbose, CSharpFileName),
- maybe_write_string(Verbose, "':\n"),
- globals__io_lookup_string_option(csharp_compiler, CSC),
- globals__io_lookup_accumulating_option(csharp_flags, CSCFlagsList),
- { join_string_list(CSCFlagsList, "", "", " ", CSCFlags) },
- globals__io_lookup_bool_option(target_debug, Debug),
- { Debug = yes ->
- DebugOpt = "" % XXX
- ;
- DebugOpt = ""
- },
-
- % XXX Should we use a separate dll_directories options?
- globals__io_lookup_accumulating_option(link_library_directories,
- DLLDirs),
- { DLLDirOpts = string__append_list(list__condense(list__map(
- (func(DLLDir) = ["/lib:", DLLDir, " "]), DLLDirs))) },
-
- { string__append_list([CSC, " -CLR ", DebugOpt,
- " /t:library ", DLLDirOpts, CSCFlags, " ",
- " /out:", DLLFileName, CSharpFileName], Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-%-----------------------------------------------------------------------------%
-
-:- pred mercury_compile__c_to_obj(io__output_stream, module_name,
- int, bool, io__state, io__state).
-:- mode mercury_compile__c_to_obj(in, in, in, out, di, uo) is det.
-
-mercury_compile__c_to_obj(ErrorStream, ModuleName, NumChunks, Succeeded) -->
- globals__io_lookup_bool_option(split_c_files, SplitFiles),
- ( { SplitFiles = yes } ->
- mercury_compile__split_c_to_obj(ErrorStream, ModuleName,
- NumChunks, Succeeded)
- ;
- globals__io_lookup_string_option(object_file_extension, Obj),
- module_name_to_file_name(ModuleName, ".c", no, C_File),
- module_name_to_file_name(ModuleName, Obj, yes, O_File),
- mercury_compile__compile_c_file(ErrorStream,
- C_File, O_File, Succeeded)
- ).
-
-mercury_compile__split_c_to_obj(ErrorStream, ModuleName,
- NumChunks, Succeeded) -->
- mercury_compile__split_c_to_obj(ErrorStream, ModuleName,
- 0, NumChunks, Succeeded).
-
- % compile each of the C files in `<module>.dir'
-:- pred mercury_compile__split_c_to_obj(io__output_stream, module_name,
- int, int, bool, io__state, io__state).
-:- mode mercury_compile__split_c_to_obj(in, in, in, in, out, di, uo) is det.
-
-mercury_compile__split_c_to_obj(ErrorStream, ModuleName,
- Chunk, NumChunks, Succeeded) -->
- ( { Chunk > NumChunks } ->
- { Succeeded = yes }
- ;
- globals__io_lookup_string_option(object_file_extension, Obj),
- module_name_to_split_c_file_name(ModuleName, Chunk,
- ".c", C_File),
- module_name_to_split_c_file_name(ModuleName, Chunk,
- Obj, O_File),
- mercury_compile__compile_c_file(ErrorStream,
- C_File, O_File, Succeeded0),
- ( { Succeeded0 = no } ->
- { Succeeded = no }
- ;
- { Chunk1 is Chunk + 1 },
- mercury_compile__split_c_to_obj(ErrorStream,
- ModuleName, Chunk1, NumChunks, Succeeded)
- )
- ).
-
-% WARNING: The code here duplicates the functionality of scripts/mgnuc.in.
-% Any changes there may also require changes here, and vice versa.
-
-:- type compiler_type ---> gcc ; lcc ; unknown.
-
-mercury_compile__compile_c_file(ErrorStream, ModuleName, Succeeded) -->
- module_name_to_file_name(ModuleName, ".c", yes, C_File),
- globals__io_lookup_string_option(object_file_extension, ObjExt),
- module_name_to_file_name(ModuleName, ObjExt, yes, O_File),
- compile_c_file(ErrorStream, C_File, O_File, Succeeded).
-
-mercury_compile__compile_c_file(ErrorStream, C_File, O_File, Succeeded) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- globals__io_lookup_string_option(c_flag_to_name_object_file,
- NameObjectFile),
- maybe_write_string(Verbose, "% Compiling `"),
- maybe_write_string(Verbose, C_File),
- maybe_write_string(Verbose, "':\n"),
- globals__io_lookup_string_option(cc, CC),
- globals__io_lookup_accumulating_option(cflags, C_Flags_List),
- { join_string_list(C_Flags_List, "", "", " ", CFLAGS) },
-
- globals__io_lookup_bool_option(use_subdirs, UseSubdirs),
- globals__io_lookup_bool_option(split_c_files, SplitCFiles),
- { (UseSubdirs = yes ; SplitCFiles = yes) ->
- % the source file (foo.c) will be compiled in a subdirectory
- % (either Mercury/cs, foo.dir, or Mercury/dirs/foo.dir,
- % depending on which of these two options is set)
- % so we need to add `-I.' so it can
- % include header files in the source directory.
- SubDirInclOpt = "-I. "
- ;
- SubDirInclOpt = ""
- },
- globals__io_lookup_accumulating_option(c_include_directory,
- C_Incl_Dirs),
- { InclOpt = string__append_list(list__condense(list__map(
- (func(C_INCL) = ["-I", C_INCL, " "]), C_Incl_Dirs))) },
- globals__io_lookup_bool_option(split_c_files, Split_C_Files),
- { Split_C_Files = yes ->
- SplitOpt = "-DMR_SPLIT_C_FILES "
- ;
- SplitOpt = ""
- },
- globals__io_lookup_bool_option(highlevel_code, HighLevelCode),
- ( { HighLevelCode = yes } ->
- { HighLevelCodeOpt = "-DMR_HIGHLEVEL_CODE " }
- ;
- { HighLevelCodeOpt = "" }
- ),
- globals__io_lookup_bool_option(gcc_nested_functions,
- GCC_NestedFunctions),
- ( { GCC_NestedFunctions = yes } ->
- { NestedFunctionsOpt = "-DMR_USE_GCC_NESTED_FUNCTIONS " }
- ;
- { NestedFunctionsOpt = "" }
- ),
- globals__io_lookup_bool_option(highlevel_data, HighLevelData),
- ( { HighLevelData = yes } ->
- { HighLevelDataOpt = "-DMR_HIGHLEVEL_DATA " }
- ;
- { HighLevelDataOpt = "" }
- ),
- globals__io_lookup_bool_option(gcc_global_registers, GCC_Regs),
- ( { GCC_Regs = yes } ->
- globals__io_lookup_string_option(cflags_for_regs,
- CFLAGS_FOR_REGS),
- { RegOpt = "-DMR_USE_GCC_GLOBAL_REGISTERS " }
- ;
- { CFLAGS_FOR_REGS = "" },
- { RegOpt = "" }
- ),
- globals__io_lookup_bool_option(gcc_non_local_gotos, GCC_Gotos),
- ( { GCC_Gotos = yes } ->
- { GotoOpt = "-DMR_USE_GCC_NONLOCAL_GOTOS " },
- globals__io_lookup_string_option(cflags_for_gotos,
- CFLAGS_FOR_GOTOS)
- ;
- { GotoOpt = "" },
- { CFLAGS_FOR_GOTOS = "" }
- ),
- globals__io_lookup_bool_option(asm_labels, ASM_Labels),
- { ASM_Labels = yes ->
- AsmOpt = "-DMR_USE_ASM_LABELS "
- ;
- AsmOpt = ""
- },
- globals__io_lookup_bool_option(parallel, Parallel),
- ( { Parallel = yes } ->
- globals__io_lookup_string_option(cflags_for_threads,
- CFLAGS_FOR_THREADS)
- ;
- { CFLAGS_FOR_THREADS = "" }
- ),
- globals__io_get_gc_method(GC_Method),
- { GC_Method = conservative ->
- GC_Opt = "-DMR_CONSERVATIVE_GC "
- ; GC_Method = accurate ->
- GC_Opt = "-DMR_NATIVE_GC "
- ;
- GC_Opt = ""
- },
- globals__io_lookup_bool_option(profile_calls, ProfileCalls),
- { ProfileCalls = yes ->
- ProfileCallsOpt = "-DMR_MPROF_PROFILE_CALLS "
- ;
- ProfileCallsOpt = ""
- },
- globals__io_lookup_bool_option(profile_time, ProfileTime),
- { ProfileTime = yes ->
- ProfileTimeOpt = "-DMR_MPROF_PROFILE_TIME "
- ;
- ProfileTimeOpt = ""
- },
- globals__io_lookup_bool_option(profile_memory, ProfileMemory),
- { ProfileMemory = yes ->
- ProfileMemoryOpt = "-DMR_MPROF_PROFILE_MEMORY "
- ;
- ProfileMemoryOpt = ""
- },
- globals__io_lookup_bool_option(profile_deep, ProfileDeep),
- { ProfileDeep = yes ->
- ProfileDeepOpt = "-DMR_DEEP_PROFILING "
- ;
- ProfileDeepOpt = ""
- },
- globals__io_lookup_bool_option(pic_reg, PIC_Reg),
- { PIC_Reg = yes ->
- PIC_Reg_Opt = "-DMR_PIC_REG "
- ;
- PIC_Reg_Opt = ""
- },
- globals__io_get_tags_method(Tags_Method),
- { Tags_Method = high ->
- TagsOpt = "-DMR_HIGHTAGS "
- ;
- TagsOpt = ""
- },
- globals__io_lookup_int_option(num_tag_bits, NumTagBits),
- { string__int_to_string(NumTagBits, NumTagBitsString) },
- { string__append_list(
- ["-DMR_TAGBITS=", NumTagBitsString, " "], NumTagBitsOpt) },
- globals__io_lookup_bool_option(require_tracing, RequireTracing),
- { RequireTracing = yes ->
- RequireTracingOpt = "-DMR_REQUIRE_TRACING "
- ;
- RequireTracingOpt = ""
- },
- globals__io_lookup_bool_option(stack_trace, StackTrace),
- { StackTrace = yes ->
- StackTraceOpt = "-DMR_STACK_TRACE "
- ;
- StackTraceOpt = ""
- },
- globals__io_lookup_bool_option(target_debug, Target_Debug),
- { Target_Debug = yes ->
- Target_DebugOpt = "-g "
- ;
- Target_DebugOpt = ""
- },
- globals__io_lookup_bool_option(low_level_debug, LL_Debug),
- { LL_Debug = yes ->
- LL_DebugOpt = "-DMR_LOW_LEVEL_DEBUG "
- ;
- LL_DebugOpt = ""
- },
- { string__sub_string_search(CC, "gcc", _) ->
- CompilerType = gcc
- ; string__sub_string_search(CC, "lcc", _) ->
- CompilerType = lcc
- ;
- CompilerType = unknown
- },
- globals__io_lookup_bool_option(use_trail, UseTrail),
- { UseTrail = yes ->
- UseTrailOpt = "-DMR_USE_TRAIL "
- ;
- UseTrailOpt = ""
- },
- globals__io_lookup_bool_option(reserve_tag, ReserveTag),
- { ReserveTag = yes ->
- ReserveTagOpt = "-DMR_RESERVE_TAG "
- ;
- ReserveTagOpt = ""
- },
- globals__io_lookup_bool_option(use_minimal_model, MinimalModel),
- { MinimalModel = yes ->
- MinimalModelOpt = "-DMR_USE_MINIMAL_MODEL "
- ;
- MinimalModelOpt = ""
- },
- globals__io_lookup_bool_option(type_layout, TypeLayoutOption),
- { TypeLayoutOption = no ->
- TypeLayoutOpt = "-DMR_NO_TYPE_LAYOUT "
- ;
- TypeLayoutOpt = ""
- },
- globals__io_lookup_bool_option(c_optimize, C_optimize),
- { C_optimize = yes ->
- ( CompilerType = gcc ->
- OptimizeOpt = "-O2 -fomit-frame-pointer "
- ; CompilerType = lcc ->
- OptimizeOpt = ""
- ;
- OptimizeOpt = "-O "
- )
- ;
- OptimizeOpt = ""
- },
- globals__io_lookup_bool_option(inline_alloc, InlineAlloc),
- { InlineAlloc = yes ->
- InlineAllocOpt = "-DMR_INLINE_ALLOC -DSILENT "
- ;
- InlineAllocOpt = ""
- },
- { CompilerType = gcc ->
- % We don't enable `-Wpointer-arith', because it causes
- % too many complaints in system header files.
- % This is fixed in gcc 3.0, though, so at some
- % point we should re-enable this.
- %
- % If --inline-alloc is enabled, don't enable missing-prototype
- % warnings, since gc_inline.h is missing lots of prototypes.
- %
- % For a full list of the other gcc warnings that we don't
- % enable, and why, see scripts/mgnuc.in.
- ( InlineAlloc = yes ->
- WarningOpt = "-Wall -Wwrite-strings -Wshadow -Wmissing-prototypes -Wno-unused -Wno-uninitialized "
- ;
- WarningOpt = "-Wall -Wwrite-strings -Wshadow -Wmissing-prototypes -Wno-unused -Wno-uninitialized -Wstrict-prototypes "
- )
- ; CompilerType = lcc ->
- WarningOpt = "-w "
- ;
- WarningOpt = ""
- },
- % Be careful with the order here! Some options override others,
- % e.g. CFLAGS_FOR_REGS must come after OptimizeOpt so that
- % it can override -fomit-frame-pointer with -fno-omit-frame-pointer.
- % Also be careful that each option is separated by spaces.
- { string__append_list([CC, " ", SubDirInclOpt, InclOpt,
- SplitOpt, OptimizeOpt,
- HighLevelCodeOpt, NestedFunctionsOpt, HighLevelDataOpt,
- RegOpt, GotoOpt, AsmOpt,
- CFLAGS_FOR_REGS, " ", CFLAGS_FOR_GOTOS, " ",
- CFLAGS_FOR_THREADS, " ",
- GC_Opt, ProfileCallsOpt, ProfileTimeOpt, ProfileMemoryOpt,
- ProfileDeepOpt, PIC_Reg_Opt, TagsOpt, NumTagBitsOpt,
- Target_DebugOpt, LL_DebugOpt,
- StackTraceOpt, RequireTracingOpt,
- UseTrailOpt, ReserveTagOpt, MinimalModelOpt, TypeLayoutOpt,
- InlineAllocOpt, WarningOpt, CFLAGS,
- " -c ", C_File, " ", NameObjectFile, O_File], Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-%-----------------------------------------------------------------------------%
-
-mercury_compile__compile_java_file(ErrorStream, ModuleName, Succeeded) -->
- module_name_to_file_name(ModuleName, ".java", no, JavaFile),
- globals__io_lookup_bool_option(verbose, Verbose),
- maybe_write_string(Verbose, "% Compiling `"),
- maybe_write_string(Verbose, JavaFile),
- maybe_write_string(Verbose, "':\n"),
- globals__io_lookup_string_option(java_compiler, JavaCompiler),
- globals__io_lookup_accumulating_option(java_flags, JavaFlagsList),
- { join_string_list(JavaFlagsList, "", "", " ", JAVAFLAGS) },
-
- globals__io_lookup_accumulating_option(java_classpath,
- Java_Incl_Dirs),
- ( { Java_Incl_Dirs = [] } ->
- { InclOpt = "" }
- ;
- % XXX PathSeparator should be ";" on Windows
- { PathSeparator = ":" },
- { join_string_list(Java_Incl_Dirs, "", "",
- PathSeparator, ClassPath) },
- { InclOpt = string__append_list([
- "-classpath ", ClassPath, " "]) }
- ),
- globals__io_lookup_bool_option(target_debug, Target_Debug),
- { Target_Debug = yes ->
- Target_DebugOpt = "-g "
- ;
- Target_DebugOpt = ""
- },
- % Be careful with the order here! Some options may override others.
- % Also be careful that each option is separated by spaces.
- { string__append_list([JavaCompiler, " ", InclOpt,
- Target_DebugOpt, JAVAFLAGS, JavaFile], Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-%-----------------------------------------------------------------------------%
-
-mercury_compile__assemble(ErrorStream, ModuleName, Succeeded) -->
- globals__io_lookup_bool_option(pic, Pic),
- { AsmExt = (Pic = yes -> ".pic_s" ; ".s") },
- module_name_to_file_name(ModuleName, AsmExt, no, AsmFile),
- globals__io_lookup_string_option(object_file_extension, Obj),
- module_name_to_file_name(ModuleName, Obj, yes, ObjFile),
-
- globals__io_lookup_bool_option(verbose, Verbose),
- maybe_write_string(Verbose, "% Assembling `"),
- maybe_write_string(Verbose, AsmFile),
- maybe_write_string(Verbose, "':\n"),
- % XXX should we use new asm_* options rather than
- % reusing cc, cflags, c_flag_to_name_object_file?
- globals__io_lookup_string_option(cc, CC),
- globals__io_lookup_string_option(c_flag_to_name_object_file,
- NameObjectFile),
- globals__io_lookup_accumulating_option(cflags, C_Flags_List),
- { join_string_list(C_Flags_List, "", "", " ", CFLAGS) },
- % Be careful with the order here.
- % Also be careful that each option is separated by spaces.
- { string__append_list([CC, " ", CFLAGS,
- " -c ", AsmFile, " ", NameObjectFile, ObjFile], Command) },
- invoke_system_command(ErrorStream, verbose_commands,
- Command, Succeeded).
-
-%-----------------------------------------------------------------------------%
-
-:- pred mercury_compile__link_module_list(list(string),
- bool, io__state, io__state).
-:- mode mercury_compile__link_module_list(in, out, di, uo) is det.
-
-mercury_compile__link_module_list(Modules, Succeeded) -->
- globals__io_lookup_string_option(output_file_name, OutputFileName0),
- ( { OutputFileName0 = "" } ->
- ( { Modules = [Module | _] } ->
- { OutputFileName = Module }
- ;
- { error("link_module_list: no modules") }
- )
- ;
- { OutputFileName = OutputFileName0 }
- ),
-
- { file_name_to_module_name(OutputFileName, MainModuleName) },
-
- globals__io_lookup_string_option(object_file_extension, Obj),
- globals__io_get_target(Target),
- globals__io_lookup_bool_option(split_c_files, SplitFiles),
- io__output_stream(OutputStream),
- ( { Target = asm } ->
- % for --target asm, we generate everything into a single object file
- ( { Modules = [FirstModule | _] } ->
- join_module_list([FirstModule], Obj, [], ObjectsList)
- ;
- { error("link_module_list: no modules") }
- ),
- { MakeLibCmdOK = yes }
- ; { SplitFiles = yes } ->
- globals__io_lookup_string_option(library_extension, LibExt),
- module_name_to_file_name(MainModuleName, LibExt,
- yes, SplitLibFileName),
- { string__append(".dir/*", Obj, DirObj) },
- join_module_list(Modules, DirObj, [], ObjectList),
- create_archive(OutputStream, SplitLibFileName,
- ObjectList, MakeLibCmdOK),
- { ObjectsList = [SplitLibFileName] }
- ;
- { MakeLibCmdOK = yes },
- join_module_list(Modules, Obj, [], ObjectsList)
- ),
- ( { MakeLibCmdOK = no } ->
- { Succeeded = no }
- ;
- { list__map(
- (pred(ModuleStr::in, ModuleName::out) is det :-
- dir__basename(ModuleStr, ModuleStrBase),
- file_name_to_module_name(ModuleStrBase, ModuleName)
- ),
- Modules, ModuleNames) },
- { MustCompile = yes },
- mercury_compile__make_init_obj_file(OutputStream,
- MustCompile, MainModuleName, ModuleNames, InitObjResult),
- (
- { InitObjResult = yes(InitObjFileName) },
- globals__io_lookup_accumulating_option(link_objects,
- ExtraLinkObjectsList),
- mercury_compile__link(OutputStream, executable, MainModuleName,
- [InitObjFileName | ObjectsList] ++ ExtraLinkObjectsList,
- Succeeded)
- ;
- { InitObjResult = no },
- { Succeeded = no }
- )
- ).
-
-mercury_compile__make_init_obj_file(ErrorStream,
- ModuleName, ModuleNames, Result) -->
- { MustCompile = no },
- mercury_compile__make_init_obj_file(ErrorStream,
- MustCompile, ModuleName, ModuleNames, Result).
-
-:- pred mercury_compile__make_init_obj_file(io__output_stream, bool,
- module_name, list(module_name), maybe(file_name),
- io__state, io__state).
-:- mode mercury_compile__make_init_obj_file(in,
- in, in, in, out, di, uo) is det.
-
-mercury_compile__make_init_obj_file(ErrorStream, MustCompile, ModuleName,
- ModuleNames, Result) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- globals__io_lookup_bool_option(statistics, Stats),
- maybe_write_string(Verbose, "% Creating initialization file...\n"),
-
- globals__io_get_trace_level(TraceLevel),
- { trace_level_is_none(TraceLevel) = no ->
- TraceOpt = "--trace "
- ;
- TraceOpt = ""
- },
- globals__io_get_globals(Globals),
- { compute_grade(Globals, Grade) },
-
- globals__io_lookup_string_option(object_file_extension, Obj),
- { string__append("_init", Obj, InitObj) },
- module_name_to_file_name(ModuleName, "_init.c", yes, InitCFileName),
- module_name_to_file_name(ModuleName, InitObj, yes, InitObjFileName),
-
- list__map_foldl(
- (pred(ThisModuleName::in, CFileName::out, di, uo) is det -->
- module_name_to_file_name(ThisModuleName, ".c", no,
- CFileName)
- ), ModuleNames, CFileNameList),
- { join_string_list(CFileNameList, "", "", " ", CFileNames) },
-
- globals__io_lookup_accumulating_option(link_flags, LinkFlagsList),
- { join_string_list(LinkFlagsList, "", "", " ", LinkFlags) },
-
- globals__io_lookup_accumulating_option(init_file_directories,
- InitFileDirsList),
- { join_string_list(InitFileDirsList, "-I ", "", " ", InitFileDirs) },
-
- globals__io_lookup_accumulating_option(init_files, InitFileNamesList),
- { join_string_list(InitFileNamesList, "", "", " ", InitFileNames) },
-
- { TmpInitCFileName = InitCFileName ++ ".tmp" },
- { MkInitCmd = string__append_list(
- ["c2init --grade ", Grade, " ", TraceOpt, LinkFlags,
- " --init-c-file ", TmpInitCFileName, " ",
- InitFileDirs, " ", InitFileNames, " ", CFileNames]) },
- invoke_shell_command(ErrorStream, verbose, MkInitCmd, MkInitOK0),
- maybe_report_stats(Stats),
- ( { MkInitOK0 = yes } ->
- update_interface(InitCFileName, MkInitOK1),
- (
- { MkInitOK1 = yes },
-
- (
- { MustCompile = yes },
- { Compile = yes }
- ;
- { MustCompile = no },
- io__file_modification_time(InitCFileName,
- InitCModTimeResult),
- io__file_modification_time(InitObjFileName,
- InitObjModTimeResult),
- {
- InitObjModTimeResult = ok(InitObjModTime),
- InitCModTimeResult = ok(InitCModTime),
- compare(TimeCompare, InitObjModTime, InitCModTime),
- ( TimeCompare = (=)
- ; TimeCompare = (>)
- )
- ->
- Compile = no
- ;
- Compile = yes
- }
- ),
-
- (
- { Compile = yes },
- maybe_write_string(Verbose,
- "% Compiling initialization file...\n"),
-
- compile_c_file(ErrorStream, InitCFileName,
- InitObjFileName, CompileOK),
- maybe_report_stats(Stats),
- ( { CompileOK = no } ->
- { Result = no }
- ;
- { Result = yes(InitObjFileName) }
- )
- ;
- { Compile = no },
- { Result = yes(InitObjFileName) }
- )
- ;
- { MkInitOK1 = no },
- { Result = no }
- )
- ;
- { Result = no }
- ).
-
-mercury_compile__link(ErrorStream, LinkTargetType, ModuleName,
- ObjectsList, Succeeded) -->
- globals__io_lookup_bool_option(verbose, Verbose),
- globals__io_lookup_bool_option(statistics, Stats),
-
- globals__io_get_trace_level(TraceLevel),
- { trace_level_is_none(TraceLevel) = no ->
- TraceOpt = "--trace "
- ;
- TraceOpt = ""
- },
- globals__io_get_globals(Globals),
- { compute_grade(Globals, Grade) },
-
- maybe_write_string(Verbose, "% Linking...\n"),
- ( { LinkTargetType = static_library } ->
- globals__io_lookup_string_option(library_extension, LibExt),
- module_name_to_file_name(ModuleName, LibExt, yes, LibName),
- create_archive(ErrorStream, LibName, ObjectsList, ArCmdOK),
- maybe_report_stats(Stats),
- ( { ArCmdOK = no } ->
- { Succeeded = no }
- ;
- { Succeeded = yes }
- )
- ;
- { LinkTargetType = shared_library ->
- SharedLibOpt = "--make-shared-lib ",
- FileExtOpt = shared_library_extension
- ;
- SharedLibOpt = "",
- FileExtOpt = executable_file_extension
- },
- globals__io_lookup_string_option(FileExtOpt, OutputFileExt),
- module_name_to_file_name(ModuleName, OutputFileExt,
- yes, OutputFileName),
- globals__io_lookup_bool_option(target_debug, Target_Debug),
- { Target_Debug = yes ->
- Target_Debug_Opt = "--no-strip "
- ;
- Target_Debug_Opt = ""
- },
- { join_string_list(ObjectsList, "", "", " ", Objects) },
- globals__io_lookup_accumulating_option(link_flags,
- LinkFlagsList),
- { join_string_list(LinkFlagsList, "", "", " ", LinkFlags) },
- globals__io_lookup_accumulating_option(
- link_library_directories,
- LinkLibraryDirectoriesList),
- { join_string_list(LinkLibraryDirectoriesList, "-L", "",
- " ", LinkLibraryDirectories) },
- globals__io_lookup_accumulating_option(link_libraries,
- LinkLibrariesList),
- { join_string_list(LinkLibrariesList, "-l", "", " ",
- LinkLibraries) },
- { string__append_list(
- ["ml --grade ", Grade, " ", SharedLibOpt,
- Target_Debug_Opt, TraceOpt, LinkFlags,
- " -o ", OutputFileName, " ", Objects, " ",
- LinkLibraryDirectories, " ", LinkLibraries],
- LinkCmd) },
- invoke_shell_command(ErrorStream, verbose_commands,
- LinkCmd, Succeeded),
- maybe_report_stats(Stats)
- ).
-
-:- pred create_archive(io__output_stream, file_name, list(file_name),
- bool, io__state, io__state).
-:- mode create_archive(in, in, in, out, di, uo) is det.
-
-create_archive(ErrorStream, LibFileName, ObjectList, MakeLibCmdOK) -->
- globals__io_lookup_string_option(create_archive_command, ArCmd),
- globals__io_lookup_accumulating_option(
- create_archive_command_flags, ArFlagsList),
- { join_string_list(ArFlagsList, "", "", " ", ArFlags) },
- globals__io_lookup_string_option(
- create_archive_command_output_flag, ArOutputFlag),
- globals__io_lookup_string_option(ranlib_command, RanLib),
- { list__append(
- [ArCmd, " ", ArFlags, " ", ArOutputFlag, " ",
- LibFileName, " " | ObjectList],
- [" && ", RanLib, " ", LibFileName],
- MakeLibCmdList) },
- { string__append_list(MakeLibCmdList, MakeLibCmd) },
- invoke_system_command(ErrorStream, verbose_commands,
- MakeLibCmd, MakeLibCmdOK).
-
- % join_string_list(Strings, Prefix, Suffix, Serarator, Result)
- %
- % Appends the strings in the list `Strings' together into the
- % string Result. Each string is prefixed by Prefix, suffixed by
- % Suffix and separated by Separator.
-
-:- pred join_string_list(list(string), string, string, string, string).
-:- mode join_string_list(in, in, in, in, out) is det.
-
-join_string_list([], _Prefix, _Suffix, _Separator, "").
-join_string_list([String | Strings], Prefix, Suffix, Separator, Result) :-
- ( Strings = [] ->
- string__append_list([Prefix, String, Suffix], Result)
- ;
- join_string_list(Strings, Prefix, Suffix, Separator, Result0),
- string__append_list([Prefix, String, Suffix, Separator,
- Result0], Result)
- ).
-
- % join_module_list(ModuleNames, Extension, Terminator, Result)
- %
- % The list of strings `Result' is computed from the list of strings
- % `ModuleNames', by removing any directory paths, and
- % converting the strings to file names and then back,
- % adding the specified Extension. (This conversion ensures
- % that we follow the usual file naming conventions.)
- % Each file name is separated by a space from the next one,
- % and the result is followed by the list of strings `Terminator'.
-
-:- pred join_module_list(list(string), string, list(string), list(string),
- io__state, io__state).
-:- mode join_module_list(in, in, in, out, di, uo) is det.
-
-join_module_list([], _Extension, Terminator, Terminator) --> [].
-join_module_list([Module | Modules], Extension, Terminator,
- [FileName, " " | Rest]) -->
- { dir__basename(Module, BaseName) },
- { file_name_to_module_name(BaseName, ModuleName) },
- module_name_to_file_name(ModuleName, Extension, no, FileName),
- join_module_list(Modules, Extension, Terminator, Rest).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: passes_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/passes_aux.m,v
retrieving revision 1.41
diff -u -u -r1.41 passes_aux.m
--- passes_aux.m 12 Mar 2002 16:32:54 -0000 1.41
+++ passes_aux.m 18 Mar 2002 04:03:31 -0000
@@ -207,17 +207,12 @@
% environment.
:- pred make_command_string(string::in, quote_char::in, string::out) is det.
- % raise_signal(Signal).
- % Send `Signal' to the current process.
- % XXX This belongs somewhere else.
-:- pred raise_signal(int::in, io__state::di, io__state::uo) is det.
-
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module options, globals, hlds_out, prog_out, mode_util.
-:- import_module mercury_to_mercury.
+:- import_module mercury_to_mercury, process_util.
:- import_module int, string, map, require, varset.
process_all_nonimported_procs(Task, ModuleInfo0, ModuleInfo) -->
@@ -533,18 +528,6 @@
++ io__error_message(TmpFileError))
),
io__remove_file(TmpFile, _).
-
-:- pragma foreign_decl("C", "#include <signal.h>").
-
-raise_signal(_::in, IO::di, IO::uo).
-
-:- pragma foreign_proc("C",
- raise_signal(Signal::in, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure],
-"
- IO = IO0;
- raise(Signal);
-").
make_command_string(String0, QuoteType, String) :-
( use_win32 ->
Index: process_util.m
===================================================================
RCS file: process_util.m
diff -N process_util.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ process_util.m 18 Mar 2002 04:26:56 -0000
@@ -0,0 +1,410 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: process_util.m
+% Main author: stayl
+%
+% Process and signal handling, mainly for use by make.m and its sub-modules.
+%-----------------------------------------------------------------------------%
+:- module process_util.
+
+:- interface.
+
+:- import_module bool, io.
+
+%-----------------------------------------------------------------------------%
+
+:- type build0(Info) == pred(bool, Info, Info, io__state, io__state).
+:- inst build0 == (pred(out, in, out, di, uo) is det).
+
+:- type post_signal_cleanup(Info) == pred(Info, Info, io__state, io__state).
+:- inst post_signal_cleanup == (pred(in, out, di, uo) is det).
+
+ % build_with_check_for_interrupt(Build, Cleanup,
+ % Succeeded, Info0, Info)
+ %
+ % Apply `Build' with signal handlers installed to check for signals
+ % which would normally kill the process. If a signal occurs call
+ % `Cleanup', then restore signal handlers to their defaults and
+ % reraise the signal to kill the current process.
+ % An action being performed in a child process by
+ % call_in_forked_process will be killed if a fatal signal
+ % (SIGINT, SIGTERM, SIGHUP or SIGQUIT) is received by the
+ % current process.
+ % An action being performed within the current process or by
+ % system() will run to completion, with the interrupt being taken
+ % immediately afterwards.
+:- pred build_with_check_for_interrupt(build0(Info)::in(build0),
+ post_signal_cleanup(Info)::in(post_signal_cleanup), bool::out,
+ Info::in, Info::out, io__state::di, io__state::uo) is det.
+
+ % raise_signal(Signal).
+ % Send `Signal' to the current process.
+:- pred raise_signal(int::in, io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- type io_pred == pred(bool, io__state, io__state).
+:- inst io_pred == (pred(out, di, uo) is det).
+
+ % call_in_forked_process(P, AltP, Succeeded)
+ %
+ % Execute `P' in a separate process.
+ %
+ % We prefer to use fork() rather than system() because
+ % that will avoid shell and Mercury runtime startup overhead.
+ % Interrupt handling will also work better (system() on Linux
+ % ignores SIGINT).
+ %
+ % If fork() is not supported on the current architecture,
+ % `AltP' will be called instead in the current process.
+:- pred call_in_forked_process(io_pred::in(io_pred), io_pred::in(io_pred),
+ bool::out, io__state::di, io__state::uo) is det.
+
+ % As above, but if fork() is not available, just call the
+ % predicate in the current process.
+:- pred call_in_forked_process(io_pred::in(io_pred),
+ bool::out, io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module globals, options.
+:- import_module std_util.
+
+build_with_check_for_interrupt(Build, Cleanup, Succeeded, Info0, Info) -->
+ setup_signal_handlers(MaybeSigIntHandler),
+ Build(Succeeded0, Info0, Info1),
+ restore_signal_handlers(MaybeSigIntHandler),
+ check_for_signal(Signalled, Signal),
+ ( { Signalled = 1 } ->
+ { Succeeded = no },
+ globals__io_lookup_bool_option(verbose_make, Verbose),
+ ( { Verbose = yes } ->
+ io__write_string("** Received signal "),
+ io__write_int(Signal),
+ io__write_string(", cleaning up.\n")
+ ;
+ []
+ ),
+ Cleanup(Info1, Info),
+
+ % The signal handler has been restored to the default,
+ % so this should kill us.
+ raise_signal(Signal)
+ ;
+ { Succeeded = Succeeded0 },
+ { Info = Info1 }
+ ).
+
+:- type signal_action ---> signal_action(c_pointer).
+
+:- pragma foreign_decl("C",
+"
+#ifdef MR_HAVE_UNISTD_H
+ #include <unistd.h>
+#endif
+
+#ifdef MR_HAVE_SYS_TYPES_H
+ #include <sys/types.h>
+#endif
+
+#ifdef MR_HAVE_SYS_WAIT_H
+ #include <sys/wait.h>
+#endif
+
+#include <errno.h>
+
+#include ""mercury_signal.h""
+#include ""mercury_types.h""
+#include ""mercury_heap.h""
+#include ""mercury_misc.h""
+
+#if defined(MR_HAVE_FORK) && defined(MR_HAVE_WAIT) && defined(MR_HAVE_KILL)
+ #define MC_CAN_FORK 1
+#endif
+
+#define MC_SETUP_SIGNAL_HANDLER(sig, handler) \
+ MR_setup_signal(sig, (MR_Code *) handler, MR_FALSE, \
+ ""mercury_compile: cannot install signal handler"");
+
+ /* Have we received a signal. */
+volatile sig_atomic_t MC_signalled;
+
+ /*
+ ** Which signal did we receive.
+ ** XXX This assumes a signal number will fit into a sig_atomic_t.
+ */
+volatile sig_atomic_t MC_signal_received;
+
+void MC_mercury_compile_signal_handler(int sig);
+").
+
+:- pragma foreign_code("C",
+"
+volatile sig_atomic_t MC_signalled = MR_FALSE;
+volatile sig_atomic_t MC_signal_received = 0;
+
+void
+MC_mercury_compile_signal_handler(int sig)
+{
+ MC_signalled = MR_TRUE;
+ MC_signal_received = sig;
+}
+").
+
+:- pred setup_signal_handlers(maybe(signal_action)::out,
+ io__state::di, io__state::uo) is det.
+
+setup_signal_handlers(MaybeSigIntHandler) -->
+ ( { have_signal_handlers(1) } ->
+ setup_signal_handlers_2(SigintHandler),
+ { MaybeSigIntHandler = yes(SigintHandler) }
+ ;
+ { MaybeSigIntHandler = no }
+ ).
+
+ % Dummy argument to work around bug mixing Mercury and foreign clauses.
+:- pred have_signal_handlers(T::unused) is semidet.
+
+have_signal_handlers(_::unused) :- semidet_fail.
+
+:- pragma foreign_proc("C", have_signal_handlers(_T::unused),
+ [will_not_call_mercury, promise_pure],
+"{
+ SUCCESS_INDICATOR = MR_TRUE;
+}").
+
+:- pred setup_signal_handlers_2(signal_action::out,
+ io__state::di, io__state::uo) is det.
+
+setup_signal_handlers_2(_::out, _::di, _::uo) :-
+ error("setup_signal_handlers_2").
+
+:- pragma foreign_proc("C",
+ setup_signal_handlers_2(SigintHandler::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ IO = IO0;
+ MC_signalled = MR_FALSE;
+
+ MR_incr_hp_msg(SigintHandler,
+ MR_bytes_to_words(sizeof(MR_signal_action)),
+ MR_PROC_LABEL, ""make.util.signal_action/0"");
+
+ /*
+ ** mdb sets up a SIGINT handler, so we should restore
+ ** it after we're done.
+ */
+ MR_get_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
+ ""error getting SIGINT handler"");
+ MC_SETUP_SIGNAL_HANDLER(SIGINT, MC_mercury_compile_signal_handler);
+ MC_SETUP_SIGNAL_HANDLER(SIGTERM, MC_mercury_compile_signal_handler);
+#ifdef SIGHUP
+ MC_SETUP_SIGNAL_HANDLER(SIGHUP, MC_mercury_compile_signal_handler);
+#endif
+#ifdef SIGQUIT
+ MC_SETUP_SIGNAL_HANDLER(SIGQUIT, MC_mercury_compile_signal_handler);
+#endif
+}").
+
+:- pred restore_signal_handlers(maybe(signal_action)::in,
+ io__state::di, io__state::uo) is det.
+
+restore_signal_handlers(no) --> [].
+restore_signal_handlers(yes(SigintHandler)) -->
+ restore_signal_handlers_2(SigintHandler).
+
+:- pred restore_signal_handlers_2(signal_action::in,
+ io__state::di, io__state::uo) is det.
+
+restore_signal_handlers_2(_::in, _::di, _::uo) :-
+ error("restore_signal_handlers_2").
+
+:- pragma foreign_proc("C",
+ restore_signal_handlers_2(SigintHandler::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ IO = IO0;
+ MR_set_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
+ ""error resetting SIGINT handler"");
+ MC_SETUP_SIGNAL_HANDLER(SIGTERM, SIG_DFL);
+#ifdef SIGHUP
+ MC_SETUP_SIGNAL_HANDLER(SIGHUP, SIG_DFL);
+#endif
+#ifdef SIGQUIT
+ MC_SETUP_SIGNAL_HANDLER(SIGQUIT, SIG_DFL);
+#endif
+}").
+
+:- pred check_for_signal(int::out, int::out,
+ io__state::di, io__state::uo) is det.
+
+check_for_signal(0::out, 0::out, _::di, _::uo).
+
+:- pragma foreign_proc("C",
+ check_for_signal(Signalled::out, Signal::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ IO = IO0;
+ Signalled = (MC_signalled ? 1 : 0);
+ Signal = MC_signal_received;
+").
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "#include <signal.h>").
+
+ % If this aborted it would cause partially built files
+ % to be left lying around with `--make'.
+raise_signal(_::in, IO::di, IO::uo).
+
+:- pragma foreign_proc("C",
+ raise_signal(Signal::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ IO = IO0;
+ raise(Signal);
+").
+
+%-----------------------------------------------------------------------------%
+
+call_in_forked_process(P, Success) -->
+ call_in_forked_process(P, P, Success).
+
+call_in_forked_process(P, AltP, Success) -->
+ ( { can_fork(1) } ->
+ call_in_forked_process_2(P, ForkStatus, CallStatus),
+ { ForkStatus = 1 ->
+ Success = no
+ ;
+ Status = io__handle_system_command_exit_status(
+ CallStatus),
+ Success = (Status = ok(exited(0)) -> yes ; no)
+ }
+ ;
+ AltP(Success)
+ ).
+
+ % Dummy argument to work around bug mixing Mercury and foreign clauses.
+:- pred can_fork(T::unused) is semidet.
+
+can_fork(_::unused) :- semidet_fail.
+
+:- pragma foreign_proc("C", can_fork(_T::unused),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+#ifdef MC_CAN_FORK
+ SUCCESS_INDICATOR = MR_TRUE;
+#else
+ SUCCESS_INDICATOR = MR_FALSE;
+#endif
+").
+
+:- pred call_in_forked_process_2(io_pred::in(io_pred), int::out, int::out,
+ io__state::di, io__state::uo) is det.
+
+call_in_forked_process_2(_::in(io_pred), _::out, _::out, _::di, _::uo) :-
+ error("call_in_forked_process_2").
+
+:- pragma foreign_proc("C",
+ call_in_forked_process_2(Pred::in(io_pred),
+ ForkStatus::out, Status::out, IO0::di, IO::uo),
+ [may_call_mercury, promise_pure],
+"{
+#ifdef MC_CAN_FORK
+ pid_t child_pid;
+
+ IO = IO0;
+ ForkStatus = 0;
+ Status = 0;
+
+ child_pid = fork();
+ if (child_pid == -1) { /* error */
+ MR_perror(""error in fork()"");
+ ForkStatus = 1;
+ } else if (child_pid == 0) { /* child */
+ MR_Integer exit_status;
+
+ MC_call_io_pred(Pred, &exit_status);
+ exit(exit_status);
+ } else { /* parent */
+ int child_status;
+ pid_t wait_status;
+
+ /*
+ ** Make sure the wait() is interrupted by the signals
+ ** which cause us to exit.
+ */
+ MR_signal_should_restart(SIGINT, MR_FALSE);
+ MR_signal_should_restart(SIGTERM, MR_FALSE);
+#ifdef SIGHUP
+ MR_signal_should_restart(SIGHUP, MR_FALSE);
+#endif
+#ifdef SIGQUIT
+ MR_signal_should_restart(SIGQUIT, MR_FALSE);
+#endif
+
+ while (1) {
+ wait_status = wait(&child_status);
+ if (wait_status == child_pid) {
+ Status = child_status;
+ break;
+ } else if (wait_status == -1) {
+ if (errno == EINTR) {
+ if (MC_signalled) {
+ /*
+ ** A normally fatal signal has been received,
+ ** so kill the child immediately.
+ ** Use SIGTERM, not MC_signal_received,
+ ** because the child may be inside a call
+ ** to system() which would cause SIGINT
+ ** to be ignored on some systems (e.g. Linux).
+ */
+ kill(child_pid, SIGTERM);
+ }
+ } else {
+ /*
+ ** This should never happen.
+ */
+ MR_perror(""error in wait(): "");
+ ForkStatus = 1;
+ Status = 1;
+ break;
+ }
+ }
+ }
+
+ /*
+ ** Restore the system call signal behaviour.
+ */
+ MR_signal_should_restart(SIGINT, MR_TRUE);
+ MR_signal_should_restart(SIGTERM, MR_TRUE);
+#ifdef SIGHUP
+ MR_signal_should_restart(SIGHUP, MR_TRUE);
+#endif
+#ifdef SIGQUIT
+ MR_signal_should_restart(SIGQUIT, MR_TRUE);
+#endif
+
+ }
+#else /* ! MC_CAN_FORK */
+ IO = IO0;
+ ForkStatus = 1;
+ Status = 1;
+#endif /* ! MC_CAN_FORK */
+}").
+
+ % call_io_pred(P, ExitStatus).
+:- pred call_io_pred(io_pred::in(io_pred), int::out,
+ io__state::di, io__state::uo) is det.
+:- pragma export(call_io_pred(in(io_pred), out, di, uo), "MC_call_io_pred").
+
+call_io_pred(P, Status) -->
+ P(Success),
+ { Status = ( Success = yes -> 0 ; 1 ) }.
+
+%-----------------------------------------------------------------------------%
Index: notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.74
diff -u -u -r1.74 compiler_design.html
--- notes/compiler_design.html 15 Mar 2002 07:32:06 -0000 1.74
+++ notes/compiler_design.html 18 Mar 2002 03:56:16 -0000
@@ -125,10 +125,6 @@
defined in options.m as arguments, to parse them. It then invokes
handle_options.m to postprocess the option set. The results are
stored in the io__state, using the type globals defined in globals.m.
-After the options are processed, the options files specified
-by the `--option-defaults-file' option is read by options_file.m.
-The options are then reprocessed with the options set in the options
-file.
<p>
@@ -166,6 +162,18 @@
<dd>
Utility predicates.
+<dt> options_file.m
+ <dd>
+ Read the options files specified by the `--options-file'
+ option. Also used by mercury_compile.m to collect the value
+ of DEFAULT_MCFLAGS, which contains the auto-configured flags
+ passed to the compiler.
+
+<dt> compile_target_code.m
+ <dd>
+ Invoke C, C#, IL, Java, etc. compilers and linkers to compile
+ the generated code.
+
</dl>
<p>
@@ -1134,9 +1142,6 @@
It uses the information written by recompilation_version.m and
recompilation_usage.m to work out whether the recompilation is
actually needed.
-
-<li> timestamp.m contains an ADT representing timestamps used
- by smart recompilation.
</ul>
<p>
@@ -1193,6 +1198,16 @@
<dt> error_util.m:
<dd>
Utility routines for printing nicely formatted error messages.
+
+ <dt> process_util.m:
+ <dd>
+ Predicates to deal with process creation and signal handling.
+ This module is mainly used by make.m and its sub-modules.
+
+ <dt> timestamp.m
+ <dd>
+ Contains an ADT representing timestamps used by smart
+ recompilation and `mmc --make'.
</dl>
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list