Sun Oct 24 22:23:26 GMT Daylight Time 2010 Max Bolingbroke * Iterate towards making things less broken Sat Oct 23 21:23:07 GMT Daylight Time 2010 Max Bolingbroke * First cut at using __attribute__((constructor)) to initialise modules and the RTS for better linking diff -rN old-ghc.init/compiler/codeGen/CodeGen.lhs new-ghc.init/compiler/codeGen/CodeGen.lhs 167,178d166 < < -- When compiling the module in which the 'main' function lives, < -- (that is, this_mod == main_mod) < -- we inject an extra stg_init procedure for stg_init_ZCMain, for the < -- RTS to invoke. We must consult the -main-is flag in case the < -- user specified a different function to Main.main < < -- Notice that the recursive descent is optional, depending on what options < -- are enabled. < < ; whenC (this_mod == main_mod) < (emitSimpleProc plain_main_init_lbl rec_descent_init) 192d179 < plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN 213,215c200,203 < < ; mapCs (registerModuleImport way) < (imported_mods++extra_imported_mods) --- > > -- We specifically do not register imported modules as imported in > -- order to ensure that the linker only drags in precisely those modules > -- that we actually refer to symbols of 223,227d210 < < < rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info < then jump_to_init < else ret_code diff -rN old-ghc.init/compiler/main/CodeOutput.lhs new-ghc.init/compiler/main/CodeOutput.lhs 26a27 > import CLabel ( mkPlainModuleInitLabel ) 54c55 < -> Module --- > -> Maybe Module -- Nothing if we are outputting code for a C-- file 213c214 < outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs --- > outputForeignStubs :: DynFlags -> Maybe Module -> ModLocation -> ForeignStubs 216,269c217,281 < outputForeignStubs dflags mod location stubs < = case stubs of < NoStubs -> do < -- When compiling External Core files, may need to use stub < -- files from a previous compilation < stub_c_exists <- doesFileExist stub_c < stub_h_exists <- doesFileExist stub_h < return (stub_h_exists, stub_c_exists) < < ForeignStubs h_code c_code -> do < let < stub_c_output_d = pprCode CStyle c_code < stub_c_output_w = showSDoc stub_c_output_d < < -- Header file protos for "foreign export"ed functions. < stub_h_output_d = pprCode CStyle h_code < stub_h_output_w = showSDoc stub_h_output_d < -- in < < createDirectoryHierarchy (takeDirectory stub_c) < < dumpIfSet_dyn dflags Opt_D_dump_foreign < "Foreign export header file" stub_h_output_d < < -- we need the #includes from the rts package for the stub files < let rts_includes = < let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in < concatMap mk_include (includes rts_pkg) < mk_include i = "#include \"" ++ i ++ "\"\n" < < -- wrapper code mentions the ffi_arg type, which comes from ffi.h < ffi_includes | cLibFFI = "#include \"ffi.h\"\n" < | otherwise = "" < < stub_h_file_exists < <- outputForeignStubs_help stub_h stub_h_output_w < ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr < < dumpIfSet_dyn dflags Opt_D_dump_foreign < "Foreign export stubs" stub_c_output_d < < stub_c_file_exists < <- outputForeignStubs_help stub_c stub_c_output_w < ("#define IN_STG_CODE 0\n" ++ < "#include \"Rts.h\"\n" ++ < rts_includes ++ < ffi_includes ++ < cplusplus_hdr) < cplusplus_ftr < -- We're adding the default hc_header to the stub file, but this < -- isn't really HC code, so we need to define IN_STG_CODE==0 to < -- avoid the register variables etc. being enabled. < < return (stub_h_file_exists, stub_c_file_exists) --- > outputForeignStubs _ Nothing _ _ = return (False, False) -- C-- files (without modules) never have stubs or initialisers > outputForeignStubs dflags (Just mod) location stubs > = do (stub_h_file_exists, foreign_stub_c_code) <- case stubs of > NoStubs -> do > -- When compiling External Core files, may need to use stub > -- files from a previous compilation > stub_h_exists <- doesFileExist stub_h > return (stub_h_exists, empty) > > ForeignStubs h_code c_code -> do > let > -- Header file protos for "foreign export"ed functions. > stub_h_output_d = pprCode CStyle h_code > stub_h_output_w = showSDoc stub_h_output_d > -- in > > createDirectoryHierarchy (takeDirectory stub_c) > > dumpIfSet_dyn dflags Opt_D_dump_foreign > "Foreign export header file" stub_h_output_d > > stub_h_file_exists > <- outputForeignStubs_help stub_h stub_h_output_w > ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr > > dumpIfSet_dyn dflags Opt_D_dump_foreign > "Foreign export stubs" (pprCode CStyle c_code) > > return (stub_h_file_exists, c_code) > > let > init_lbl = mkPlainModuleInitLabel mod > init_c_code = vcat [ text "extern void" <+> ppr init_lbl <> text "(void);" > , text "static void stginit_auto_" <> ppr mod > <> text "(void) __attribute__((constructor (2000)));" > , text "static void stginit_auto_" <> ppr mod <> text "(void)" > , braces (text "hs_init_one_module" > <> parens (ppr init_lbl) > <> semi) > ] > > stub_c_output_d = pprCode CStyle (foreign_stub_c_code $$ init_c_code) > stub_c_output_w = showSDoc stub_c_output_d > > -- we need the #includes from the rts package for the stub files > rts_includes = concatMap mk_include (includes rts_pkg) > where rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId > mk_include i = "#include \"" ++ i ++ "\"\n" > > -- wrapper code mentions the ffi_arg type, which comes from ffi.h > ffi_includes | cLibFFI = "#include \"ffi.h\"\n" > | otherwise = "" > > stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w > ("#define IN_STG_CODE 0\n" ++ > "#include \"Rts.h\"\n" ++ > rts_includes ++ > ffi_includes ++ > cplusplus_hdr) > cplusplus_ftr > -- We're adding the default hc_header to the stub file, but this > -- isn't really HC code, so we need to define IN_STG_CODE==0 to > -- avoid the register variables etc. being enabled. > > return (stub_h_file_exists, stub_c_file_exists) diff -rN old-ghc.init/compiler/main/DriverPipeline.hs new-ghc.init/compiler/main/DriverPipeline.hs 167,168c167,168 < let getStubLinkable False = return [] < getStubLinkable True --- > let getStubObject False = return Nothing > getStubObject True 170c170 < return [ DotO stub_o ] --- > return (Just stub_o) 184,185c184 < = do stub_unlinked <- getStubLinkable hasStub < (hs_unlinked, unlinked_time) <- --- > = do (hs_unlinked, unlinked_time) <- 191,194c190,207 < -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) < (Just basename) < Persistent < (Just location) --- > -> do stub_unlinked_o <- getStubObject hasStub > let output_o = runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) > > -- If we had a stub file, we have to use ld to make it part of exactly the same > -- object as the module from which it originated. The reason is that the stub file > -- contains a module initialiser marked with __attribute__((constructor)), and we need > -- that initialiser to run before anything in the module is referenced. > -- > -- GCC's linker will ensure that happens as long as the symbols that you can't reference > -- before calling the constructor occur in the **same object file** as that constructor. > -- Hence this song and dance to mash the two object files (if any) together: > case stub_unlinked_o of > Nothing -> output_o Persistent (Just location) >> return () > Just unlinked_o -> do > temp_o_fn <- liftIO $ newTempName dflags' (objectSuf dflags') > _ <- output_o (SpecificFile temp_o_fn) Nothing > liftIO $ runLinkToCombineObjects dflags' [unlinked_o, temp_o_fn] object_filename > 198,199c211 < let linkable = LM unlinked_time this_mod < (hs_unlinked ++ stub_unlinked) --- > let linkable = LM unlinked_time this_mod hs_unlinked 209c221 < = do stub_unlinked <- getStubLinkable hasStub --- > = do stub_unlinked_o <- getStubObject hasStub 219c231 < (hs_unlinked ++ stub_unlinked) --- > (hs_unlinked ++ maybeToList (fmap DotO stub_unlinked_o)) -- FIXME: must find some way to call initialiser if we refer to any symbol in the BCO? 1217,1236c1229 < let ld_r args = SysTools.runLink dflags ([ < SysTools.Option "-nostdlib", < SysTools.Option "-nodefaultlibs", < SysTools.Option "-Wl,-r", < SysTools.Option ld_x_flag, < SysTools.Option "-o", < SysTools.FileOption "" output_fn ] < ++ map SysTools.Option md_c_flags < ++ args) < ld_x_flag | null cLD_X = "" < | otherwise = "-Wl,-x" < < if cLdIsGNULd == "YES" < then do < let script = split_odir "ld.script" < writeFile script $ < "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" < ld_r [SysTools.FileOption "" script] < else do < ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) --- > runLinkToCombineObjects dflags (map split_obj [1..n]) output_fn 1351a1345,1366 > > runLinkToCombineObjects :: DynFlags -> [FilePath] -> FilePath -> IO () > runLinkToCombineObjects dflags [input] output_fn = copy dflags "copying instead of linking to do a trivial combination" input output_fn > runLinkToCombineObjects dflags inputs output_fn > | cLdIsGNULd == "YES" = do script <- newTempName dflags "script" > writeFile script $ "INPUT(" ++ unwords inputs ++ ")" > ld_r [SysTools.FileOption "" script] > | otherwise = ld_r (map (SysTools.FileOption "") inputs) > where > ld_r args = SysTools.runLink dflags ([ > SysTools.Option "-nostdlib", > SysTools.Option "-nodefaultlibs", > SysTools.Option "-Wl,-r", > SysTools.Option ld_x_flag, > SysTools.Option "-o", > SysTools.FileOption "" output_fn ] > ++ map SysTools.Option md_c_flags > ++ args) > > (md_c_flags, _) = machdepCCOpts dflags > ld_x_flag | null cLD_X = "" > | otherwise = "-Wl,-x" diff -rN old-ghc.init/compiler/main/HscMain.lhs new-ghc.init/compiler/main/HscMain.lhs 730c730 < <- codeOutput dflags this_mod location foreign_stubs --- > <- codeOutput dflags (Just this_mod) location foreign_stubs 764c764 < <- outputForeignStubs dflags this_mod location foreign_stubs --- > <- outputForeignStubs dflags (Just this_mod) location foreign_stubs 780c780 < _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms --- > _ <- liftIO $ codeOutput dflags Nothing no_loc NoStubs [] rawCmms 783d782 < no_mod = panic "hscCmmFile: no_mod" diff -rN old-ghc.init/includes/HsFFI.h new-ghc.init/includes/HsFFI.h 152a153 > extern void hs_init_one_module (void (*init_root)(void)); diff -rN old-ghc.init/rts/Hpc.c new-ghc.init/rts/Hpc.c 277,290d276 < /* This is called after all the modules have registered their local tixboxes, < * and does a sanity check: are we good to go? < */ < < void < startupHpc(void) { < debugTrace(DEBUG_hpc,"startupHpc"); < < if (hpc_inited == 0) { < return; < } < } < < diff -rN old-ghc.init/rts/Main.c new-ghc.init/rts/Main.c 18c18 < /* The symbol for the Haskell Main module's init function. It is safe to refer --- > /* The symbol for the Haskell Main module's ZCMain_main_closure. It is safe to refer 22,24d21 < extern void __stginit_ZCMain(void); < < /* Similarly, we can refer to the ZCMain_main_closure here */ 29c26 < return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure); --- > return hs_main(argc, argv, &ZCMain_main_closure); diff -rN old-ghc.init/rts/RtsMain.c new-ghc.init/rts/RtsMain.c 37d36 < static void (*progmain_init)(void); /* This will be __stginit_ZCMain */ 50c49 < startupHaskell(progargc,progargv,progmain_init); --- > startupHaskell(progargc,progargv,NULL); 103c102 < int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure) --- > int hs_main(int argc, char *argv[],StgClosure *main_closure) 109d107 < progmain_init = main_init; diff -rN old-ghc.init/rts/RtsMain.h new-ghc.init/rts/RtsMain.h 16c16 < int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure); --- > int hs_main(int argc, char *argv[], StgClosure *main_closure); diff -rN old-ghc.init/rts/RtsStartup.c new-ghc.init/rts/RtsStartup.c 37a38 > void obtainArgv( void (*kontinue)(int argc, char **argv) ); // This is exported by some CommandLine.c but not used anywhere else 70a72,84 > // Priority levels (range from 101 to 65535 inclusive, see http://gcc.gnu.org/onlinedocs/gcc/C_002b_002b-Attributes.html#C_002b_002b-Attributes): > // 1000: runtime system initialisation (used for hs_init/hs_exit and hence first-stage profiling (de)initialisation) > // 1500: just before Haskell modules > // 2000: Haskell modules (generated in CodeOutput.lhs) > // 2500: after Haskell modules (used for second-stage profiling initialisation) > > void rts_auto_init(void) __attribute__((constructor (1000))); > void pre_mod_auto_init(void) __attribute__((constructor (1500))); > void post_mod_auto_init(void) __attribute__((constructor (2500))); > > void rts_auto_exit(void) __attribute__((destructor (1000))); > > 103,104c117,118 < void < hs_init(int *argc, char **argv[]) --- > static void > init_with_args(int *argc, char **argv[]) 106,111d119 < hs_init_count++; < if (hs_init_count > 1) { < // second and subsequent inits are ignored < return; < } < 230a239,266 > static void > init_with_exact_args(int argc, char *argv[]) > { > init_with_args(&argc, &argv); > } > > static void > hs_init_(void) // TODO: make non-static? Might be useful to others. > { > hs_init_count++; > if (hs_init_count > 1) { > // second and subsequent inits are ignored > return; > } > > obtainArgv(init_with_exact_args); > } > > // Deprecated: you can just rely on auto initialisation to do the work of initialisation > void > hs_init(int *argc, char **argv[]) > { > (void) argc; // > (void) argv; // Suppress spurious warning > > hs_init_(); > } > 240d275 < 269c304,306 < static StgFunPtr *init_stack = NULL; --- > > static Capability *init_cap; > static bdescr *init_bd; 272c309 < hs_add_root(void (*init_root)(void)) --- > pre_mod_auto_init(void) 274,279c311,312 < bdescr *bd; < nat init_sp; < Capability *cap; < < cap = rts_lock(); < --- > init_cap = rts_lock(); > 282a316,319 > > // Allocate memory for the initialisation stack > init_bd = allocGroup_lock(INIT_STACK_BLOCKS); > } 283a321,326 > void > hs_init_one_module(void (*init_root)(void)) > { > StgFunPtr *init_stack; > nat init_sp; > 287,288c330,332 < bd = allocGroup_lock(INIT_STACK_BLOCKS); < init_stack = (StgFunPtr *)bd->start; --- > > // Use the pre-allocated memory to build an initialisation stack for this init_root > init_stack = (StgFunPtr *)init_bd->start; 291c335 < init_stack[--init_sp] = (StgFunPtr)init_root; --- > init_stack[--init_sp] = (StgFunPtr)init_root; 293,295d336 < < cap->r.rSp = (P_)(init_stack + init_sp); < StgRun((StgFunPtr)stg_init, &cap->r); 297c338,339 < freeGroup_lock(bd); --- > // Assign the stack to the pre-initialised capability > init_cap->r.rSp = (P_)(init_stack + init_sp); 299c341,342 < startupHpc(); --- > StgRun((StgFunPtr)stg_init, &init_cap->r); > } 300a344,348 > void > post_mod_auto_init(void) > { > freeGroup_lock(init_bd); > 302c350,352 < // ToDo: make this work in the presence of multiple hs_add_root()s. --- > // This doesn't work in the presence of multiple hs_add_root()s, but users shouldn't be > // calling that anyway, because the __attribute__((constructor)) stuff will ensure that all necessary > // modules are added as roots before this function is invoked for the first time. 304,306c354,356 < < rts_unlock(cap); < --- > > rts_unlock(init_cap); > 308,310c358,369 < #if defined(THREADED_RTS) < ioManagerStart(); < #endif --- > #if defined(THREADED_RTS) > ioManagerStart(); > #endif > } > > void > hs_add_root(void (*init_root)(void)) > { > /* Deprecated: the __attribute__((constructor)) stuff will have ensured initialisation */ > pre_mod_auto_init(); > hs_init_one_module(init_root); > post_mod_auto_init(); 502a562,575 > > /* Automatic startup/teardown of the RTS */ > > void > rts_auto_init(void) > { > hs_init_(); > } > > void > rts_auto_exit(void) > { > hs_exit(); > } \ No newline at end of file diff -rN old-ghc.init/rts/posix/CommandLine.c new-ghc.init/rts/posix/CommandLine.c 0a1,28 > #include "Rts.h" > > void obtainArgv(void (*kontinue)(int, char**)); > > // Obtain the arguments to the process by scanning the stack for them. Super grody! Confirmed to work on OS X 10.6 and at least some Linux variant. > // See http://www.facebook.com/notes/linux-game-publishing/argv-and-argc-and-just-how-to-get-them/151271758468 > // It might be cleaner to use __libc_argc and __libc_argv, but they are private symbols > void obtainArgv(void (*kontinue)(int argc, char **argv)) > { > extern char **environ; > char ***argvp; > void *p; > > #ifdef x86_64_HOST_ARCH > asm ("mov %%rsp, %0" : "=r" (p)); > #else > asm ("mov %%esp, %0" : "=r" (p)); > #endif > argvp = p; > > // Scan the stack: we assume that the stacks grows downward and that argv and argc > // are located adjacent to an occurrence of the environ pointer > while (*argvp != environ) > argvp++; > argvp--; > > kontinue(*(((int*)argvp)-1), *argvp); > } diff -rN old-ghc.init/rts/win32/CommandLine.c new-ghc.init/rts/win32/CommandLine.c 0a1,109 > #include > > void obtainArgv(void (*kontinue)(int, char**)); > > // Windows only provides CommandLineToArgvW, but we need an ANSI version. Bah! > // See http://alter.org.ua/docs/win/args/ > static PCHAR* > CommandLineToArgvA( > PCHAR CmdLine, > int* _argc > ) > { > PCHAR* argv; > PCHAR _argv; > ULONG len; > ULONG argc; > CHAR a; > ULONG i, j; > > BOOLEAN in_QM; > BOOLEAN in_TEXT; > BOOLEAN in_SPACE; > > len = strlen(CmdLine); > i = ((len+2)/2)*sizeof(PVOID) + sizeof(PVOID); > > argv = (PCHAR*)LocalAlloc(LMEM_FIXED, > i + (len+2)*sizeof(CHAR)); > > if (argv == NULL) { > return NULL; > } > > _argv = (PCHAR)(((PUCHAR)argv)+i); > > argc = 0; > argv[argc] = _argv; > in_QM = FALSE; > in_TEXT = FALSE; > in_SPACE = TRUE; > i = 0; > j = 0; > > while( a = CmdLine[i] ) { > if(in_QM) { > if(a == '\"') { > in_QM = FALSE; > } else { > _argv[j] = a; > j++; > } > } else { > switch(a) { > case '\"': > in_QM = TRUE; > in_TEXT = TRUE; > if(in_SPACE) { > argv[argc] = _argv+j; > argc++; > } > in_SPACE = FALSE; > break; > case ' ': > case '\t': > case '\n': > case '\r': > if(in_TEXT) { > _argv[j] = '\0'; > j++; > } > in_TEXT = FALSE; > in_SPACE = TRUE; > break; > default: > in_TEXT = TRUE; > if(in_SPACE) { > argv[argc] = _argv+j; > argc++; > } > _argv[j] = a; > j++; > in_SPACE = FALSE; > break; > } > } > i++; > } > _argv[j] = '\0'; > argv[argc] = NULL; > > (*_argc) = argc; > return argv; > } > > // On Windows, we can obtain the arguments to the process in a somewhat sane manner as there is a published API for this purpose > void obtainArgv(void (*kontinue)(int argc, char **argv)) > { > int argc; > char **argv; > > argv = CommandLineToArgvA(GetCommandLineA(), &argc); > if (argv == NULL) { > sysErrorBelch("obtainArgv: CommandLineToArgvA failed to allocate memory"); > stg_exit(EXIT_FAILURE); > } > > kontinue(argc, argv); > LocalFree(argv); > }