From b8384ce5da4738c0a6d3eaf11de03cab3ddd3cd6 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 20 Sep 2010 20:16:20 +0000 Subject: [PATCH] Implement archive loading for ghci --- compiler/ghc.mk | 6 ++ compiler/ghci/Linker.lhs | 41 ++++++-- compiler/ghci/ObjLink.lhs | 8 ++ ghc.mk | 2 + includes/rts/Linker.h | 3 + mk/config.mk.in | 2 + rts/Linker.c | 235 +++++++++++++++++++++++++++++++++++++------- rts/ghc.mk | 4 + rules/build-package-way.mk | 4 + 9 files changed, 262 insertions(+), 43 deletions(-) diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 7eaa158..f6530a6 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -136,6 +136,12 @@ ifeq "$(RelocatableBuild)" "YES" else @echo 'cRelocatableBuild = False' >> $@ endif + @echo 'cUseArchivesForGhci :: Bool' >> $@ +ifeq "$(UseArchivesForGhci)" "YES" + @echo 'cUseArchivesForGhci = True' >> $@ +else + @echo 'cUseArchivesForGhci = False' >> $@ +endif @echo 'cLibFFI :: Bool' >> $@ ifeq "$(UseLibFFIForAdjustors)" "YES" @echo 'cLibFFI = True' >> $@ diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 9fc22df..f7d925e 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -53,7 +53,7 @@ import qualified Maybes import UniqSet import Constants import FastString -import Config ( cProjectVersion ) +import Config -- Standard libraries import Control.Monad @@ -429,8 +429,13 @@ preloadLib dflags lib_paths framework_paths lib_spec Object static_ish -> do b <- preload_static lib_paths static_ish maybePutStrLn dflags (if b then "done" - else "not found") - + else "not found") + + Archive static_ish + -> do b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" + else "not found") + DLL dll_unadorned -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned case maybe_errstr of @@ -468,6 +473,10 @@ preloadLib dflags lib_paths framework_paths lib_spec = do b <- doesFileExist name if not b then return False else loadObj name >> return True + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else loadArchive name >> return True \end{code} @@ -929,6 +938,8 @@ data LibrarySpec -- file in all the directories specified in -- v_Library_paths before giving up. + | Archive FilePath -- Full path name of a .a file, including trailing .a + | DLL String -- "Unadorned" name of a .DLL/.so -- e.g. On unix "qt" denotes "libqt.so" -- On WinDoze "burble" denotes "burble.DLL" @@ -957,6 +968,7 @@ partOfGHCi showLS :: LibrarySpec -> String showLS (Object nm) = "(static) " ++ nm +showLS (Archive nm) = "(static archive) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm @@ -1039,6 +1051,7 @@ linkPackage dflags pkg -- Complication: all the .so's must be loaded before any of the .o's. let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") @@ -1060,6 +1073,7 @@ linkPackage dflags pkg -- Ordering isn't important here, because we do one final link -- step to resolve everything. mapM_ loadObj objs + mapM_ loadArchive archs maybePutStr dflags "linking ... " ok <- resolveObjs @@ -1094,10 +1108,22 @@ locateOneObj dirs lib | not isDynamicGhcLib -- When the GHC package was not compiled as dynamic library -- (=DYNAMIC not set), we search for .o libraries. - = do { mb_obj_path <- findFile mk_obj_path dirs - ; case mb_obj_path of - Just obj_path -> return (Object obj_path) - Nothing -> return (DLL lib) } + = do mb_libSpec <- if cUseArchivesForGhci + then do mb_arch_path <- findFile mk_arch_path dirs + case mb_arch_path of + Just arch_path -> + return (Just (Archive arch_path)) + Nothing -> + return Nothing + else do mb_obj_path <- findFile mk_obj_path dirs + case mb_obj_path of + Just obj_path -> + return (Just (Object obj_path)) + Nothing -> + return Nothing + case mb_libSpec of + Just ls -> return ls + Nothing -> return (DLL lib) | otherwise -- When the GHC package was compiled as dynamic library (=DYNAMIC set), @@ -1112,6 +1138,7 @@ locateOneObj dirs lib Nothing -> return (DLL lib) }} -- We assume where mk_obj_path dir = dir (lib <.> "o") + mk_arch_path dir = dir ("lib" ++ lib <.> "a") dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion mk_dyn_lib_path dir = dir mkSOName dyn_lib_name diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index ec91616..310ddb5 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -12,6 +12,7 @@ Primarily, this module consists of an interface to the C-land dynamic linker. module ObjLink ( initObjLinker, -- :: IO () loadDLL, -- :: String -> IO (Maybe String) + loadArchive, -- :: String -> IO () loadObj, -- :: String -> IO () unloadObj, -- :: String -> IO () insertSymbol, -- :: String -> String -> Ptr a -> IO () @@ -65,6 +66,12 @@ loadDLL str = do else do str <- peekCString maybe_errmsg return (Just str) +loadArchive :: String -> IO () +loadArchive str = do + withCString str $ \c_str -> do + r <- c_loadArchive c_str + when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) + loadObj :: String -> IO () loadObj str = do withCString str $ \c_str -> do @@ -90,6 +97,7 @@ foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString foreign import ccall unsafe "initLinker" initObjLinker :: IO () foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO () foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) +foreign import ccall unsafe "loadArchive" c_loadArchive :: CString -> IO Int foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int diff --git a/ghc.mk b/ghc.mk index 199e07a..0dfad2f 100644 --- a/ghc.mk +++ b/ghc.mk @@ -739,7 +739,9 @@ $(foreach pkg,$(BOOT_PKGS),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBo GHCI_LIBS = $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_GHCI_LIB)) \ $(compiler_stage2_GHCI_LIB) +ifeq "$(UseArchivesForGhci)" "NO" ghc/stage2/build/tmp/$(ghc_stage2_PROG) : $(GHCI_LIBS) +endif endif diff --git a/includes/rts/Linker.h b/includes/rts/Linker.h index 73d18ca..f7c8ce9 100644 --- a/includes/rts/Linker.h +++ b/includes/rts/Linker.h @@ -32,6 +32,9 @@ HsInt unloadObj( char *path ); /* add an obj (populate the global symbol table, but don't resolve yet) */ HsInt loadObj( char *path ); +/* add an arch (populate the global symbol table, but don't resolve yet) */ +HsInt loadArchive( char *path ); + /* resolve all the currently unlinked objects in memory */ HsInt resolveObjs( void ); diff --git a/mk/config.mk.in b/mk/config.mk.in index 3882c26..92b067f 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -190,6 +190,8 @@ else UseLibFFIForAdjustors=YES endif +UseArchivesForGhci = NO + # On Windows we normally want to make a relocatable bindist, to we # ignore flags like libdir ifeq "$(Windows)" "YES" diff --git a/rts/Linker.c b/rts/Linker.c index 6387ee1..cfec769 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -33,10 +33,8 @@ #include "posix/Signals.h" #endif -#if defined(mingw32_HOST_OS) // get protos for is*() #include -#endif #ifdef HAVE_SYS_TYPES_H #include @@ -120,6 +118,15 @@ static /*Str*/HashTable *stablehash; /* List of currently loaded objects */ ObjectCode *objects = NULL; /* initially empty */ +static HsInt loadOc( ObjectCode* oc ); +static ObjectCode* mkOc( char *path, char *image, int imageSize +#ifndef USE_MMAP +#ifdef darwin_HOST_OS + , int misalignment +#endif +#endif + ); + #if defined(OBJFORMAT_ELF) static int ocVerifyImage_ELF ( ObjectCode* oc ); static int ocGetNames_ELF ( ObjectCode* oc ); @@ -798,6 +805,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_isCurrentThreadBoundzh) \ SymI_HasProto(stg_isEmptyMVarzh) \ SymI_HasProto(stg_killThreadzh) \ + SymI_HasProto(loadArchive) \ SymI_HasProto(loadObj) \ SymI_HasProto(insertStableSymbol) \ SymI_HasProto(insertSymbol) \ @@ -1599,6 +1607,167 @@ mmap_again: } #endif // USE_MMAP +static ObjectCode* +mkOc( char *path, char *image, int imageSize +#ifndef USE_MMAP +#ifdef darwin_HOST_OS + , int misalignment +#endif +#endif + ) { + ObjectCode* oc; + + oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)"); + +# if defined(OBJFORMAT_ELF) + oc->formatName = "ELF"; +# elif defined(OBJFORMAT_PEi386) + oc->formatName = "PEi386"; +# elif defined(OBJFORMAT_MACHO) + oc->formatName = "Mach-O"; +# else + stgFree(oc); + barf("loadObj: not implemented on this platform"); +# endif + + oc->image = image; + /* sigh, strdup() isn't a POSIX function, so do it the long way */ + /* XXX What should this be for an archive? */ + oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" ); + strcpy(oc->fileName, path); + + oc->fileSize = imageSize; + oc->symbols = NULL; + oc->sections = NULL; + oc->proddables = NULL; + +#ifndef USE_MMAP +#ifdef darwin_HOST_OS + oc->misalignment = misalignment; +#endif +#endif + + /* chain it onto the list of objects */ + oc->next = objects; + objects = oc; + + return oc; +} + +#if defined(USE_ARCHIVES_FOR_GHCI) +HsInt +loadArchive( char *path ) +{ + ObjectCode* oc; + char *image; + int imageSize; + FILE *f; + int n; + char tmp[16]; + int isObject; + + f = fopen(path, "rb"); + if (!f) + barf("loadObj: can't read `%s'", path); + + n = fread ( tmp, 1, 8, f ); + if (strncmp(tmp, "!\n", 8) != 0) + barf("loadArchive: Not an archive: `%s'", path); + + while(1) { + n = fread ( tmp, 1, 16, f ); + if (n != 16) { + if (feof(f)) { + break; + } + else { + barf("loadArchive: Failed reading file name from `%s'", path); + } + } + /* Ignore special files */ + if ((0 == strncmp(tmp, "/ ", 16)) || + (0 == strncmp(tmp, "// ", 16))) { + isObject = 0; + } + else { + isObject = 1; + } + n = fread ( tmp, 1, 12, f ); + if (n != 12) + barf("loadArchive: Failed reading mod time from `%s'", path); + n = fread ( tmp, 1, 6, f ); + if (n != 6) + barf("loadArchive: Failed reading owner from `%s'", path); + n = fread ( tmp, 1, 6, f ); + if (n != 6) + barf("loadArchive: Failed reading group from `%s'", path); + n = fread ( tmp, 1, 8, f ); + if (n != 8) + barf("loadArchive: Failed reading mode from `%s'", path); + n = fread ( tmp, 1, 10, f ); + if (n != 10) + barf("loadArchive: Failed reading size from `%s'", path); + tmp[10] = '\0'; + for (n = 0; isdigit(tmp[n]); n++); + tmp[n] = '\0'; + imageSize = atoi(tmp); + n = fread ( tmp, 1, 2, f ); + if (strncmp(tmp, "\x60\x0A", 2) != 0) + barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); + + if (isObject) { + /* We can't mmap from the archive directly, as object + files need to be 8-byte aligned but files in .ar + archives are 2-byte aligned, and if we malloc the + memory then we can be given memory above 2^32, so we + mmap some anonymous memory and use that. We could + do better here. */ + image = mmapForLinker(imageSize, MAP_ANONYMOUS, -1); + n = fread ( image, 1, imageSize, f ); + if (n != imageSize) + barf("loadObj: error whilst reading `%s'", path); + oc = mkOc(path, image, imageSize +#ifndef USE_MMAP +#ifdef darwin_HOST_OS + , 0 +#endif +#endif + ); + if (0 == loadOc(oc)) { + return 0; + } + } + else { + n = fseek(f, imageSize, SEEK_CUR); + if (n != 0) + barf("loadArchive: error whilst seeking to %d in `%s'", + imageSize, path); + } + /* .ar files are 2-byte aligned */ + if (imageSize % 2) { + n = fread ( tmp, 1, 1, f ); + if (n != 1) { + if (feof(f)) { + break; + } + else { + barf("loadArchive: Failed reading padding from `%s'", path); + } + } + } + } + + fclose(f); + + return 1; +} +#else +HsInt GNU_ATTRIBUTE(__noreturn__) +loadArchive( char *path STG_UNUSED ) { + barf("loadArchive: not enabled"); +} +#endif + /* ----------------------------------------------------------------------------- * Load an obj (populate the global symbol table, but don't resolve yet) * @@ -1608,6 +1777,8 @@ HsInt loadObj( char *path ) { ObjectCode* oc; + char *image; + int fileSize; struct stat st; int r; #ifdef USE_MMAP @@ -1616,6 +1787,7 @@ loadObj( char *path ) FILE *f; #endif IF_DEBUG(linker, debugBelch("loadObj %s\n", path)); + initLinker(); /* debugBelch("loadObj %s\n", path ); */ @@ -1642,37 +1814,13 @@ loadObj( char *path ) } } - oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)"); - -# if defined(OBJFORMAT_ELF) - oc->formatName = "ELF"; -# elif defined(OBJFORMAT_PEi386) - oc->formatName = "PEi386"; -# elif defined(OBJFORMAT_MACHO) - oc->formatName = "Mach-O"; -# else - stgFree(oc); - barf("loadObj: not implemented on this platform"); -# endif - r = stat(path, &st); if (r == -1) { IF_DEBUG(linker, debugBelch("File doesn't exist\n")); return 0; } - /* sigh, strdup() isn't a POSIX function, so do it the long way */ - oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" ); - strcpy(oc->fileName, path); - - oc->fileSize = st.st_size; - oc->symbols = NULL; - oc->sections = NULL; - oc->proddables = NULL; - - /* chain it onto the list of objects */ - oc->next = objects; - objects = oc; + fileSize = st.st_size; #ifdef USE_MMAP /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */ @@ -1685,7 +1833,7 @@ loadObj( char *path ) if (fd == -1) barf("loadObj: can't open `%s'", path); - oc->image = mmapForLinker(oc->fileSize, 0, fd); + image = mmapForLinker(fileSize, 0, fd); close(fd); @@ -1698,7 +1846,7 @@ loadObj( char *path ) # if defined(mingw32_HOST_OS) // TODO: We would like to use allocateExec here, but allocateExec // cannot currently allocate blocks large enough. - oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT, + image = VirtualAlloc(NULL, fileSize, MEM_RESERVE | MEM_COMMIT, PAGE_EXECUTE_READWRITE); # elif defined(darwin_HOST_OS) // In a Mach-O .o file, all sections can and will be misaligned @@ -1708,24 +1856,39 @@ loadObj( char *path ) // as SSE (used by gcc for floating point) and Altivec require // 16-byte alignment. // We calculate the correct alignment from the header before - // reading the file, and then we misalign oc->image on purpose so + // reading the file, and then we misalign image on purpose so // that the actual sections end up aligned again. - oc->misalignment = machoGetMisalignment(f); - oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)"); - oc->image += oc->misalignment; + misalignment = machoGetMisalignment(f); + image = stgMallocBytes(fileSize + misalignment, "loadObj(image)"); + image += misalignment; # else - oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)"); + image = stgMallocBytes(fileSize, "loadObj(image)"); # endif { int n; - n = fread ( oc->image, 1, oc->fileSize, f ); - if (n != oc->fileSize) + n = fread ( image, 1, fileSize, f ); + if (n != fileSize) barf("loadObj: error whilst reading `%s'", path); } fclose(f); #endif /* USE_MMAP */ + oc = mkOc(path, image, fileSize +#ifndef USE_MMAP +#ifdef darwin_HOST_OS + , misalignment +#endif +#endif + ); + + return loadOc(oc); +} + +static HsInt +loadOc( ObjectCode* oc ) { + int r; + # if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)) r = ocAllocateSymbolExtras_MachO ( oc ); if (!r) { diff --git a/rts/ghc.mk b/rts/ghc.mk index dd9851a..c3fffcd 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -246,6 +246,10 @@ ifeq "$(UseLibFFIForAdjustors)" "YES" rts_CC_OPTS += -DUSE_LIBFFI_FOR_ADJUSTORS endif +ifeq "$(UseArchivesForGhci)" "YES" +rts_CC_OPTS += -DUSE_ARCHIVES_FOR_GHCI +endif + # Mac OS X: make sure we compile for the right OS version rts_CC_OPTS += $(MACOSX_DEPLOYMENT_CC_OPTS) rts_HC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index a1930b1..5752709 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -103,13 +103,17 @@ ifeq "$3" "v" $1_$2_GHCI_LIB = $1/$2/build/HS$$($1_PACKAGE)-$$($1_$2_VERSION).$$($3_osuf) # Don't put bootstrapping packages in the bindist ifneq "$4" "0" +ifeq "$$(UseArchivesForGhci)" "NO" BINDIST_LIBS += $$($1_$2_GHCI_LIB) endif +endif $$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS) +ifeq "$$(UseArchivesForGhci)" "NO" $(call all-target,$1_$2,$$($1_$2_GHCI_LIB)) endif +endif endef -- 1.7.10.4