implementation module PmCleanSystem import StdEnv import System.File import System.FilePath import System.Directory import System.OSError import Data.Void from Data.Maybe import qualified ::Maybe(..) from System.Process import qualified callProcess import PmCompilerOptions import PmPath import PmTypes import Platform import StdPathname //import thread_message import UtilIO import UtilStrictLists import linkargs import WriteOptionsFile maketempdir :: Pathname -> Pathname maketempdir startupdir = startupdir +++ "\\Temp" :: CompilerProcessHandlesAndId = { compiler_thread_id :: !Int, compiler_thread_handle :: !Int, compiler_process_handle :: !Int } :: CompilerProcessIds :== [CompilerProcessHandlesAndId] NoCompilerProcessIds :: CompilerProcessIds NoCompilerProcessIds = [] instance == CompileOrCheckSyntax where // (==) :: !CompileOrCheckSyntax !CompileOrCheckSyntax -> Bool (==) SyntaxCheck SyntaxCheck = True (==) Compilation Compilation = True (==) _ _ = False instance FileEnv LogEnv where accFiles :: !.(*Files -> (.x,*Files)) !*LogEnv -> (!.x,!*LogEnv) accFiles accfun logenv # (r, world) = accFiles accfun logenv.world = (r, { logenv & world = world }) appFiles :: !.(*Files -> *Files) !*LogEnv -> *LogEnv appFiles appfun logenv = { logenv & world = appFiles appfun logenv.world } ExitCleanCompiler :: !(!CompilingInfo,*World) -> (!CompilingInfo,*World) /* ExitCleanCompiler prog=:(CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle), ps) # wm_number=get_message_number; # r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("exit\0") | /*trace_tn ("ExitCleanCompiler "+++toString r+++"\n") &&*/ r==0 = prog = (CompilingInfo NoCompiler,ps); */ ExitCleanCompiler prog = prog instance == CodeGenerateAsmOrCode where // (==) :: !CodeGenerateAsmOrCode !CodeGenerateAsmOrCode -> Bool (==) AsmGeneration AsmGeneration = True (==) CodeGeneration CodeGeneration = True (==) _ _ = False instance == CompilerMsg where (==) CompilerOK CompilerOK = True (==) SyntaxError SyntaxError = True (==) GlobalError GlobalError = True (==) _ _ = False mangleCompiler2 ccstring` startupdir # (ccstring`,rem) = splitOptions ccstring` # (opts,opts`) = splitOptions rem # (shortOK,ccstring) = GetShortPathName (startupdir +++ "\\" +++ ccstring` +++ "\0") | not shortOK # line = "Error: Unable to get short path name '" +++ (startupdir +++ "\\" +++ ccstring`) +++ "'." = (False,line,"","","") # cocl = ccstring % (0, size ccstring - 2) # cocldir = RemoveFilename cocl = (True,cocl,cocldir,opts,opts`) CompilePersistent :: !String !Bool !(WindowFun *LogEnv) !(WindowFun *LogEnv) !CompileOrCheckSyntax !Pathname !(List Pathname) !Bool !Bool !Bool !CompilerOptions !Pathname !CompilingInfo !*LogEnv -> (!CompilingInfo,!(!*LogEnv, !Pathname, !CompilerMsg)) CompilePersistent cocl` write_module_times errwin typewin compileOrCheckSyntax path paths projectHeapProfiling projectTimeProfiling projectEagerOrDynamic co=:{CompilerOptions | listTypes} startupdir cstate env # tooltempdir = maketempdir startupdir # (cocl_ok,cocl,cocl_dir,cocl_startup,options) = mangleCompiler2 cocl` startupdir // platform dependant mangling... | not cocl_ok # env = errwin [cocl] env = (cstate,(env,"",GlobalError)) # out_file_name = out_file_path tooltempdir dummy_slot errors_file_name = errors_file_path tooltempdir dummy_slot # cocl_arguments = [options] ++ write_module_times_string ++ CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax path paths projectHeapProfiling projectTimeProfiling projectEagerOrDynamic co # (res, world) = 'System.Process'.callProcess cocl cocl_arguments ('Data.Maybe'.Just cocl_dir) env.world # env = { env & world = world } # (compile_ok, exitcode,(cstate,env)) = case res of Ok exitcode = (True, exitcode, (cstate,env)) Error err = (False, 0, (cstate,env)) // # (compile_ok,exitcode,(cstate,env)) = compile_with_cache cocl cocl_dir cocl_startup cocl_arguments (cstate,env); | not compile_ok # env = errwin ["Error: Unable to run compiler: "+++cocl +++ " :"+++toString (snd (fromError res))] env = (cstate,(env,"",GlobalError)) # (path,mess,env) = CompileHandleExitCode exitcode cocl tooltempdir dummy_slot errwin typewin path listTypes env = (cstate,(env,path,mess)) where dummy_slot = 0 write_module_times_string = if write_module_times ["-wmt"] [] CompileBuildCommand :: !String !String !CompileOrCheckSyntax !Pathname !(List Pathname) !Bool !Bool !Bool !CompilerOptions -> [String] CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax path paths projectHeapProfiling projectTimeProfiling projectEagerOrDynamic co = MakeCompilerOptionsString compileOrCheckSyntax projectHeapProfiling projectTimeProfiling projectEagerOrDynamic co ++ [ path , "-P" , ConcatenatePath paths , "-RE" , errors_file_name , "-RO" , out_file_name ] CompileHandleExitCode :: !Int !String !String !Int !(WindowFun *LogEnv) !(WindowFun *LogEnv) !Pathname !ListTypes !*LogEnv -> (!Pathname,!CompilerMsg,!*LogEnv) CompileHandleExitCode exitcode cocl startupdir slot errwin typewin path listTypes ps # tooltempdir = startupdir # out_file_name = out_file_path tooltempdir slot errors_file_name = errors_file_path tooltempdir slot ((errors,errors_and_messages_not_empty,errors_and_messages),world) = ReadErrorsAndWarnings errors_file_name ps.world # ps = { ps & world = world } | exitcode <> 0 && not errors_and_messages_not_empty = // werkt dit ook voor persistent versie? ( "" , GlobalError , errwin ( [ "Error: Compiler crashed: "+++cocl : if (errors == CompilerOK) ["Unable to open Errors file"] [] ]) ps ) # abcpath = MakeABCSystemPathname path ps = (if errors_and_messages_not_empty (errwin (StrictListToList errors_and_messages)) id) ps errors = case exitcode of 0 -> CompilerOK _ -> errors = (abcpath,errors,ps) out_file_path :: String Int -> String out_file_path tooltempdir slot = file_path tooltempdir "out" slot errors_file_path :: String Int -> String errors_file_path tooltempdir slot = file_path tooltempdir "errors" slot file_path :: String String Int -> String file_path dir base_name slot = dir +++ DirSeparatorString +++ base_name +++ (if (slot == 0) "" (toString slot)) ConcatenatePath :: (List Pathname) -> String /* old version ConcatenatePath Nil = "" ConcatenatePath (path :! rest ) = path +++ ";" +++ ConcatenatePath rest */ ConcatenatePath ss # s = createArray (sSize ss) ';' = sUpdate 0 s ss where sSize Nil = 0 sSize (string :! Nil) = size string sSize (string :! rest) = size string + 1 + sSize rest sUpdate i s Nil = s sUpdate i s (string :! Nil) # (_,s) = sU (size string) i 0 s string = s sUpdate i s (string :! rest) # (i,s) = sU (size string) i 0 s string # i = inc i = sUpdate i s rest sU l i j s h | j >= l = (i,s) # s = update s i h.[j] = sU l (inc i) (inc j) s h CodeGen :: !String !(WindowFun *LogEnv) !CodeGenerateAsmOrCode !Pathname !Bool !CodeGenOptions !Processor !ApplicationOptions !Pathname !*LogEnv -> (!Pathname,!Bool,!*LogEnv) CodeGen cgen` wf genAsmOrCode path timeprofile cgo tp ao startupdir ps # tooltempdir = maketempdir startupdir # (cgen_ok,cgen,cgendir) = mangleGenerator cgen` startupdir | not cgen_ok # ps = wf [cgen] ps = ("",False,ps) # objpath = MakeObjSystemPathname tp path path_without_suffix = RemoveSuffix path args = MakeCodeGenOptionsString genAsmOrCode timeprofile cgo ++ [path_without_suffix] //TODO: restore error redirection to file errorsfilename = tooltempdir +++ DirSeparatorString +++ "errors" (res, world) = 'System.Process'.callProcess cgen args ('Data.Maybe'.Just cgendir) ps.world ps = { ps & world = world } | isError res = (objpath,False,wf [ "Error: Unable to run code generator: "+++cgen ] ps ) # exit_code = fromOk res # ((_, errors_not_empty, error_text),world) = ReadErrorsAndWarnings errorsfilename ps.world # ps = { ps & world = world } # ps = (if errors_not_empty (wf (StrictListToList error_text)) ( if (exit_code <> 0) (wf ["Error: Code generator failed for '" +++ path +++ "' with exit code: "+++toString exit_code,(quoted_string path_without_suffix)]) id ) ) ps = (objpath,exit_code==0,ps) :: StartedCodeGenerator = !{ scg_thread_handle :: !Int, scg_std_error_handle :: !Int, scg_abc_path :: !{#Char}, scg_path_without_suffix :: !{#Char}, scg_errors_file_name :: !{#Char} } mangleGenerator cgen` startupdir # (cgen`,opts) = splitOptions cgen` # (shortOK,cgen) = GetShortPathName (startupdir +++ "\\" +++ cgen` +++ "\0") | not shortOK # line = "Error: Unable to get short path name '" +++ (startupdir +++ "\\" +++ cgen`) +++ "'." = (False,line,"") # cgencom = cgen % (0, size cgen - 2) +++ opts # cgendir = RemoveFilename (cgen % (0, size cgen - 2)) = (True,cgencom,cgendir) MakeCodeGenOptionsString :: CodeGenerateAsmOrCode Bool CodeGenOptions -> [String] MakeCodeGenOptionsString genAsmOrCode timeprofile {ci,cs} = checkindex ++ checkstack ++ genasm where checkindex | ci = ["-ci"] = [] checkstack | cs = ["-os"] = [] genasm | genAsmOrCode == AsmGeneration = ["-a"] = [] /* Links the given file: */ Link :: !String !(WindowFun *LogEnv) !Pathname !ApplicationOptions !Pathname !(List Pathname) !(List Pathname) !(List Pathname) !Bool !Bool !Bool !Bool !String !Bool !String !Pathname !String !Processor !Bool !*LogEnv -> (!*LogEnv,!Bool) Link linker` winfun path applicationOptions=:{ss,hs,initial_heap_size,profiling,heap_size_multiple,o,memoryProfilingMinimumHeapSize=minheap} optionspathname library_file_names object_file_names static_libraries static gen_relocs gen_linkmap link_resources resource_path gen_dll dll_syms startupdir dynlstr _ use_64_bit_processor ps # tooltempdir = maketempdir startupdir # (ok,linker,linkerdir) = mangleLinker linker` startupdir | not ok # ps = winfun [linker] ps = (ps,False) # flags = ApplicationOptionsToFlags applicationOptions # optdirpath = RemoveFilename optionspathname # world = ps.LogEnv.world # (exists, world) = fileExists optdirpath world # (err, world) = if exists (False, world) ( case createDirectory optdirpath world of (Ok Void, world) = (False,world) (Error _, world) = (True, world) ) # ps = { ps & world = world } | err = (winfun ["Linker error: Unable to access or create: "+++optdirpath] ps,False) # (options_file_ok,ps) = accFiles (write_options_file optionspathname flags hs ss initial_heap_size heap_size_multiple minheap use_64_bit_processor) ps | not options_file_ok = (winfun ["Linker error: Could not write the options object file: "+++optionspathname] ps,False) # linkopts = { exe_path = path , res_path = resource_path , open_console = o <> NoConsole , static_link = static , gen_relocs = gen_relocs , gen_linkmap = gen_linkmap , link_resources = link_resources , object_paths = optionspathname :! (RemoveDup object_file_names) , dynamic_libs = RemoveDup library_file_names , static_libs = RemoveDup static_libraries , stack_size = ss , gen_dll = gen_dll , dll_names = dll_syms , dynamics_path = startupdir +++. DirSeparatorString +++. dynlstr } # linkerpath = RemoveFilename linker // # linkoptspath = MakeFullPathname linkerpath "linkopts" // # linkerrspath = MakeFullPathname linkerpath "linkerrs" # linkoptspath = MakeFullPathname tooltempdir "linkopts" # linkerrspath = MakeFullPathname tooltempdir "linkerrs" # (err,ps) = accFiles (WriteLinkOpts linkoptspath linkopts) ps | isJust err = (winfun (fromJust err) ps,False) # linkopts = ["-I", linkoptspath, "-O", linkerrspath] # (res, world) = 'System.Process'.callProcess linker linkopts ('Data.Maybe'.Just linkerdir) ps.world # ps = { ps & world = world } | isError res = (winfun ["Error: Unable to run linker: "+++linker] ps, False) # exit_code = fromOk res # link_ok = exit_code==0 # ((err,link_errors),ps) = accFiles (ReadLinkErrors linkerrspath) ps | isJust err = (winfun (fromJust err) ps,False) # (errtext,errlines) = (link_errors, length link_errors) | errlines<>0 = (winfun errtext ps,link_ok) = (ps,link_ok) mangleLinker linkstr` startupdir # (linkstr`,opts) = splitOptions linkstr` # (shortOK,linkstr) = GetShortPathName (startupdir +++ DirSeparatorString +++ linkstr` +++ "\0") | not shortOK # line = "Error: Unable to get short path name '" +++ (startupdir +++ DirSeparatorString +++ linkstr`) +++ "'." = (False,line,"") # linkcom = linkstr % (0, size linkstr - 2) +++ opts # linkdir = RemoveFilename (linkstr % (0, size linkstr - 2)) = (True,linkcom,linkdir) splitOptions str | first_q >= len_str = (str,"") = (first_str,last_str) where first_str = str%(0,dec first_q) last_str = str % (inc first_q, len_str) len_str = size str first_q = FindQuoteChar str len_str 0 FindQuoteChar str len pos = FindChar ':' str len pos; FindChar :: !Char !.String !.Int !Int -> Int; FindChar c line linelen pos | pos >= linelen = pos; | c == line.[pos] = pos; = FindChar c line linelen (inc pos); ReadErrorsAndWarnings :: !Pathname !*env -> ((!CompilerMsg, !Bool, !(List String)), !*env) | FileSystem env ReadErrorsAndWarnings path env # (opened,file,env) = fopen path FReadText env | not opened = ((CompilerOK,False,Nil),env) # (errors,errors_and_warnings_read,errlist,file`) = ReadErrorAndWarningMessages file (_,env) = fclose file` env = ((errors,errors_and_warnings_read,errlist),env) Strip "" = "" Strip s #! last = dec (size s) #! char = s.[last] | char == '\n' || char == '\r' = Strip (s % (0,dec last)) = s ReadErrorAndWarningMessages :: !*File -> (!CompilerMsg,!Bool,!List String,!*File) ReadErrorAndWarningMessages file #! (string, file1) = freadline file (eof,file2) = fend file1 | eof #! not_empty_or_newline = (size string)<>0 && string.[0]<>'\n' = (SyntaxError,not_empty_or_newline,Strip string :! Nil,file2) # (path_error,_,errlist,file3) = ReadErrorAndWarningMessages file2 = (path_error,True,Strip string:!errlist,file3) MakeCompilerOptionsString :: !CompileOrCheckSyntax !Bool !Bool !Bool !CompilerOptions -> [String] MakeCompilerOptionsString compileOrCheckSyntax projectMemoryProfiling projectTimeProfiling projectEagerOrDynamic {neverMemoryProfile, neverTimeProfile,sa,gw,gc,listTypes,attr,reuseUniqueNodes,fusion} = options where memoryProfileSwitch | (not neverMemoryProfile && projectMemoryProfiling) || projectEagerOrDynamic = ["-desc"] = [] timeProfileSwitch | not neverTimeProfile && projectTimeProfiling = ["-pt"] = [] dynamicLinkSwitch | projectEagerOrDynamic = ["-exl","-dynamics"] = [] strictness | sa = [] = ["-sa"] warnings | gw = [] = ["-w"] comments | gc = ["-d"] = [] listtypes | listTypes == InferredTypes = ["-lt"] | listTypes == AllTypes = ["-lat"] | listTypes == StrictExportTypes = ["-lset"] = [] show_attr | attr = [] = ["-lattr"] checksyntax | compileOrCheckSyntax == SyntaxCheck = ["-c"] = [] reuse | reuseUniqueNodes = ["-ou"] = [] add_fusion_option l = if fusion (l ++ ["-fusion"]) l; options = add_fusion_option (checksyntax ++ timeProfileSwitch ++ memoryProfileSwitch ++ dynamicLinkSwitch ++ strictness ++ warnings ++ comments ++listtypes++show_attr++reuse) /* start_compile_with_cache :: String Int String String String CompilerProcessIds *env -> (!Bool,!CompilerProcessIds,!*env) start_compile_with_cache path slot directory startup_arguments arguments compiler_process_ids ps | slot (!Bool,!CompilerProcessIds,!*env) start_compile_with_cache2 path {compiler_thread_id,compiler_thread_handle,compiler_process_handle} directory arguments compiler_process_ids ps # wm_number=get_message_number # r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("cocl "+++arguments+++"\0") | r==0 = (False,compiler_process_ids,ps) = (True,compiler_process_ids,ps) int_to_hex v = {hex_char i \\ i<-[0..7]}; where hex_char i # h=(v>>((7-i)<<2)) bitand 15; = toChar (if (h<10) (toInt '0'+h) ((toInt 'A'-10)+h)); */ InitCompilingInfo :: *CompilingInfo //InitCompilingInfo = NotCompiling InitCompilingInfo = CompilingInfo NoCompiler /* compile_with_cache :: String String String String (CompilingInfo,*LogEnv) -> (!Bool,!Int,!(CompilingInfo,*LogEnv)) compile_with_cache path directory startup_arguments arguments prog=:(CompilingInfo NoCompiler, ps) // # startup_arguments = "" # thread_id=get_current_thread_id; # begin_arguments=startup_arguments+++" -ide "+++int_to_hex thread_id; # (r,compiler_thread_id,compiler_thread_handle,compiler_process_handle) = start_compiler_process (path+++"\0") (directory+++"\0") (path+++" "+++begin_arguments+++"\0"); | r==0 = (False,0,prog) # (ok,s) = compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle; | ok # ci = CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle) = (ok,s,(ci,ps)); = (ok,s,prog); compile_with_cache path directory startup_arguments arguments prog=:(CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle),ps) # (ok,s) = compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle | ok = (ok,s,prog) = (ok,s,(CompilingInfo NoCompiler,ps)) compile_with_cache path directory startup_arguments arguments prog=:(NotCompiling,ps) # (res, world) = 'Process'.callProcess path [arguments] ('Maybe'.Just directory) ps.world # ps = { ps & world = world } | isError res = (False, 0, (NotCompiling, ps)) # exit_code = fromOk res = (True, exit_code, (NotCompiling, ps)) compile_with_cache2 :: {#.Char} {#.Char} {#.Char} Int Int Int -> (!Bool,!Int) compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle # wm_number=get_message_number # r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("cocl "+++arguments+++"\0") | r==0 = (False,0) # (r,a,s) =get_integers_from_thread_message wm_number compiler_thread_handle | r==0 = (False,s) = (True,s) */