Skip to content

GHC
GHC
Commit 169f5972 authored by Ian Lynagh's avatar Ian Lynagh
1 Browse files
Options

Remove "-dynload wrapper"; fixes trac #4275

parent a96a7536
Hide whitespace changes
Inline Side-by-side
Showing with 3 additions and 464 deletions
compiler/main/DriverPipeline.hs
View file @ 169f5972
......@@ -1336,8 +1336,8 @@ runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL
runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool
runPhase_MoveBinary dflags input_fn dep_packages
runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
runPhase_MoveBinary dflags input_fn
| WayPar `elem` (wayNames dflags) && not opt_Static =
panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
| WayPar `elem` (wayNames dflags) = do
......@@ -1354,43 +1354,8 @@ runPhase_MoveBinary dflags input_fn dep_packages
-- generate a wrapper script for running a parallel prg under PVM
writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
return True
| not opt_Static =
case (dynLibLoader dflags) of
Wrapped wrapmode ->
do
let (o_base, o_ext) = splitExtension input_fn
let wrapped_executable | o_ext == "exe" = (o_base ++ ".dyn") <.> o_ext
| otherwise = input_fn ++ ".dyn"
behaviour <- wrapper_behaviour dflags wrapmode dep_packages
-- THINKME isn't this possible to do a bit nicer?
let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
renameFile input_fn wrapped_executable
let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
(md_c_flags, _) = machdepCCOpts dflags
SysTools.runCc dflags
([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
, SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
, SysTools.Option "-o"
, SysTools.FileOption "" input_fn] ++
map (SysTools.FileOption "-I") (includeDirs rtsDetails) ++
map Option md_c_flags)
return True
_ -> return True
| otherwise = return True
wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
wrapper_behaviour dflags mode dep_packages =
let seperateBySemiColon strs = tail $ concatMap (';':) strs
in case mode of
Nothing -> do
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
return ('H' : (seperateBySemiColon pkg_lib_paths))
Just s -> do
allpkg <- getPreloadPackagesAnd dflags dep_packages
putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
mkExtraCObj :: DynFlags -> [String] -> IO FilePath
mkExtraCObj dflags xs
= do cFile <- newTempName dflags "c"
......@@ -1621,7 +1586,7 @@ linkBinary dflags o_files dep_packages = do
))
-- parallel only: move binary to another dir -- HWL
success <- runPhase_MoveBinary dflags output_fn dep_packages
success <- runPhase_MoveBinary dflags output_fn
if success then return ()
else ghcError (InstallationError ("cannot move binary"))
......
compiler/main/DynFlags.hs
View file @ 169f5972
......@@ -601,7 +601,6 @@ defaultObjectTarget
data DynLibLoader
= Deployable
| Wrapped (Maybe String)
| SystemDependent
deriving Eq
......@@ -933,9 +932,6 @@ parseDynLibLoaderMode f d =
case splitAt 8 f of
("deploy", "") -> d{ dynLibLoader = Deployable }
("sysdep", "") -> d{ dynLibLoader = SystemDependent }
("wrapped", "") -> d{ dynLibLoader = Wrapped Nothing }
("wrapped:", "hard") -> d{ dynLibLoader = Wrapped Nothing }
("wrapped:", flex) -> d{ dynLibLoader = Wrapped (Just flex) }
_ -> ghcError (CmdLineError ("Unknown dynlib loader: " ++ f))
setDumpPrefixForce f d = d { dumpPrefixForce = f}
......
docs/users_guide/shared_libs.xml
View file @ 169f5972
......@@ -218,17 +218,6 @@ ghc -dynamic -shared Foo.o -o libfoo.so
</para>
</listitem>
</varlistentry>
<varlistentry>
<term>wrapped</term>
<listitem>
<para>
This mode generates a wrapper program which in turn calls the
real program (in the same directory but with a .dyn extension)
in such a way that it can find the shared libraries that it
needs. At the current time this mode is somewhat experimental.
</para>
</listitem>
</varlistentry>
</variablelist>
To use relative paths for dependent libraries on Linux and Solaris you
can use the <literal>deploy</literal> mode and pass suitable a -rpath
......
rts/dyn-wrapper.c deleted 100644 → 0
View file @ a96a7536
/* This is the wrapper for dynamically linked executables
*
* Have mercy with this creature born in cross-platform wasteland.
*/
#include <sys/types.h>
#include <unistd.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <ghcplatform.h>
#include <shell-tools.c>
/* All defining behavior string */
char behaviour[]=BEHAVIOUR;
#define REAL_EXT ".dyn"
#define REAL_EXT_S (sizeof(REAL_EXT)-1)
void *smalloc(size_t size);
#if defined(mingw32_HOST_OS)
#include <wtypes.h>
#include <winbase.h>
#define ENV_NAME "PATH"
#define ENV_SEP ';'
#define EXEEXT ".exe"
#define SET_ENV(n,v) SetEnvironmentVariable(n,v)
#define GET_ENV(n) getEnvWrapper(n)
#define FREE_GET_ENV(x) free(x)
#define DIR_SEP '\\'
char *getEnvWrapper(const char *name) {
int len=GetEnvironmentVariableA(name,NULL,0);
char *value;
if(!len) return NULL;
value=smalloc(len);
GetEnvironmentVariableA(name,value,len);
return value;
}
#define CONVERT_PATH(x) replace(x,'/','\\')
#elif defined(linux_HOST_OS)
#define ENV_NAME "LD_LIBRARY_PATH"
#define ENV_SEP ':'
#define EXEEXT ""
#define SET_ENV(n,v) setenv(n,v,1)
#define GET_ENV(n) getenv(n)
#define FREE_GET_ENV(x)
#define CONVERT_PATH(x)
#define DIR_SEP '/'
#elif defined(darwin_HOST_OS)
#define ENV_NAME "DYLD_LIBRARY_PATH"
#define ENV_SEP ':'
#define EXEEXT ""
#define SET_ENV(n,v) setenv(n,v,1)
#define GET_ENV(n) getenv(n)
#define FREE_GET_ENV(x)
#define CONVERT_PATH(x)
#define DIR_SEP '/'
#else
#error no OS interface defined
#endif
#define EXEEXT_S (sizeof(EXEEXT)-1)
/* Utility functions */
/* Like strtok_r but omitting the first arg and allowing only one delimiter */
char *stringTokenizer (char **this, const char delim)
{
char *oldthis=*this;
char *matched;
if(!this || !(*this)) return NULL;
matched=strchr(*this, delim);
if(matched) {
*matched=0;
*this=matched+1;
return oldthis;
} else {
*this=NULL;
return oldthis;
}
}
/* Replaces all occourances of character 'from' with 'to' in 'x' */
void replace(char *x, char from, char to) {
while(*x) {
if(*x == from)
*x=to;
x++;
}
}
/* Non-failing malloc -- will die on failure */
void *smalloc(size_t size)
{
void *ret=malloc(size);
if(!ret) {
fprintf(stderr,"Can not allocate %d bytes",size);
perror("");
exit(-1);
}
return ret;
}
/* String Cons (scons) -- basically a linked list */
struct scons {
char *value;
struct scons *next;
};
/* Free up a linked list */
void freescons(struct scons *root) {
while(root) {
struct scons *c=root;
root=root->next;
free(c->value);
free(c);
}
}
/* Removes duplicates among the string cons */
struct scons *unique(struct scons *in) {
struct scons *ret=NULL;
struct scons *ci;
for(ci=in; ci!=NULL; ci=ci->next) {
struct scons *cj;
struct scons *nextscons;
for(cj = ret; cj != NULL; cj=cj->next) {
if(!strcmp(ci->value,cj->value))
break;
}
if(cj!=NULL) continue;
nextscons=smalloc(sizeof(struct scons));
nextscons->next=ret;
nextscons->value=strdup(ci->value);
ret=nextscons;
}
return ret;
}
/* Tries to get a single line from the input stream really _inefficently_ */
char *afgets(FILE *input) {
int bufsize=0;
char *buf=(char *)malloc(bufsize);
do {
bufsize+=1;
buf=realloc(buf,bufsize);
} while(fread(buf+bufsize-1,1,1,input)==1 && buf[bufsize-1]!='\n');
buf[bufsize-1]=0;
return buf;
}
/* Computes the real binaries' name from argv0 */
char *real_binary_name(char *argv0) {
int arg0len=strlen(argv0);
char *alterego;
alterego=strdup(argv0);
if(!strcmp(alterego+arg0len-EXEEXT_S,EXEEXT)) {
alterego[arg0len-EXEEXT_S]=0;
arg0len-=EXEEXT_S;
}
alterego=realloc(alterego,arg0len+REAL_EXT_S+EXEEXT_S+1);
sprintf(alterego+arg0len,"%s%s",REAL_EXT,EXEEXT);
return alterego;
}
/* Gets a field for a GHC package
* This method can't deal with multiline fields
*/
#warning FIXME - getGhcPkgField can not deal with multline fields
char *getGhcPkgField(char *ghcpkg, char *package, char *field) {
char *command;
char *line;
FILE *input;
int fieldLn=strlen(field);
/* Format ghc-pkg command */
command=smalloc(strlen(ghcpkg)+strlen(package)+fieldLn+9);
sprintf(command,"%s field %s %s",ghcpkg,package,field);
/* Run */
input=popen(command,"r");
if(!input) {
fprintf(stderr,"Failed to invoke %s", command);
perror("");
free(command);
exit(-1);
}
line=afgets(input);
pclose(input);
free(command);
/* Check for validity */
if(strncmp(line,field,fieldLn)) {
/* Failed */
free(line);
return NULL;
}
/* Cut off "<field>: " in the output and return */
strcpy(line,line+fieldLn+2);
return line;
}
/* Prepends a prefix to an environment variable.
If it is set already, it puts a separator in between */
void prependenv(char *name, char *prefix, char sep)
{
char *orig=GET_ENV(name);
if(orig) {
char *new;
int prefixlength=strlen(prefix);
new=(char *)smalloc(strlen(orig)+prefixlength+2);
strcpy(new,prefix);
new[prefixlength]=sep;
strcpy(new+prefixlength+1,orig);
SET_ENV(name,new);
free(new);
} else {
SET_ENV(name,prefix);
}
FREE_GET_ENV(orig);
}
/* This function probes the library-dirs of all package dependencies,
removes duplicates and adds it to the environment ENV_NAME */
void withghcpkg(char *ghcpkg, char *packages)
{
struct scons *rootlist=NULL;
struct scons *uniqueRootlist=NULL;
struct scons *c;
/* Save pointers for strtok */
char *packageParse;
char *libParse;
char *curpack;
while(curpack=stringTokenizer(&packages,';')) {
#warning We should query for a dynamic-library field not library-dirs.
char *line=getGhcPkgField(ghcpkg, curpack,"library-dirs");
char *line_p=line; /* need to retain original line for freeing */
char *curlib;
if(!line) {
fprintf(stderr,"Can not query ghc-pkg for fields of packages %s",curpack);
perror("");
exit(-1);
}
while(curlib=stringTokenizer(&line_p,' ')) {
c=smalloc(sizeof(struct scons));
c->next=rootlist;
c->value=strdup(curlib);
rootlist=c;
}
free(line);
}
uniqueRootlist=unique(rootlist);
for(c = uniqueRootlist; c != NULL; c=c->next) {
CONVERT_PATH(c->value);
prependenv(ENV_NAME,c->value,ENV_SEP);
}
freescons(rootlist);
freescons(uniqueRootlist);
}
void add_to(char **base, int *base_size, char **target, const char *src, int src_size) {
if((*target)-(*base)+src_size > *base_size) {
*base=realloc(*base,*base_size+src_size);
*base_size=*base_size+src_size;
}
memcpy(*target,src,src_size);
*target=*target+src_size;
}
/* Scans str and constructs */
char *expandFlexiblePath(char *str)
{
int buffersize=strlen(str)+1;
char *base=smalloc(buffersize);
char *current=base;
while(*str && *str!=';') {
if(*str=='$' && *(str+1)=='{') {
char *start;
char *envcont;
str+=2;
start=str;
while(*str && *str != '}') {
str++;
}
if(!str) {
fprintf(stderr,"End of string while scanning environment variable. Wrapper broken\n");
exit(-1);
}
*str='\0';
str++;
envcont=GET_ENV(start);
if(!envcont) {
fprintf(stderr,"Referenced environment variable %s not set.",start);
exit(-1);
}
add_to(&base,&buffersize,&current,envcont,strlen(envcont));
FREE_GET_ENV(envcont);
} else {
add_to(&base,&buffersize,&current,str,1);
str++;
}
}
return base;
}
char *getBasename(const char *path) {
int i;
char *ret;
for(i=strlen(path); i>=0; i--) {
if(path[i]==DIR_SEP) break;
}
ret=smalloc(i+1);
strncpy(ret,path,i);
}
char *agetcwd() {
char *cwd;
int size=100;
cwd=malloc(size);
while(!getcwd(cwd,size)) {
size+=100;
cwd=realloc(cwd,size);
}
return cwd;
}
int main(int argc, char **argv) {
char *alterego;
int arg0len=strlen(argv[0]);
switch(behaviour[0]) {
case 'H': /* hard paths */
replace(behaviour+1,';',ENV_SEP);
CONVERT_PATH(behaviour+1);
prependenv(ENV_NAME,behaviour+1,ENV_SEP);
break;
case 'F':
{ /* flexible paths based on ghc-pkg in $GHC_PKG */
char *expanded;
char *arg0base=getBasename(argv[0]);
char *ghc_pkg=behaviour+1;
char *packages;
char *oldwd=agetcwd();
packages=strchr(behaviour+1,';');
*packages=0;
packages++;
expanded=expandFlexiblePath(ghc_pkg);
#warning Will this also change drive on windows? WINDOWS IS SO BROKEN.
chdir(arg0base);
withghcpkg(expanded,packages);
chdir(oldwd);
free(oldwd);
free(expanded);
}
break;
default:
printf("unset wrapper called\n");
exit(-1);
}
alterego=real_binary_name(argv[0]);
return run(argv[0],alterego,argc,argv);
}
rts/ghc.mk
View file @ 169f5972
......@@ -37,7 +37,6 @@ endif
EXCLUDED_SRCS += rts/Main.c
EXCLUDED_SRCS += rts/parallel/SysMan.c
EXCLUDED_SRCS += rts/dyn-wrapper.c
EXCLUDED_SRCS += $(wildcard rts/Vis*.c)
rts_C_SRCS = $(filter-out $(EXCLUDED_SRCS),$(wildcard rts/*.c $(foreach dir,$(ALL_DIRS),rts/$(dir)/*.c)))
......@@ -437,14 +436,6 @@ rts_HC_OPTS += -Ilibffi/build/include
rts_HSC2HS_OPTS += -Ilibffi/build/include
rts_LD_OPTS += -Llibffi/build/include
# -----------------------------------------------------------------------------
# compile generic patchable dyn-wrapper
DYNWRAPPER_SRC = rts/dyn-wrapper.c
DYNWRAPPER_PROG = rts/dyn-wrapper$(exeext)
$(DYNWRAPPER_PROG): $(DYNWRAPPER_SRC)
"$(HC)" -cpp -optc-include -optcdyn-wrapper-patchable-behaviour.h $(INPLACE_EXTRA_FLAGS) $< -o $@
# -----------------------------------------------------------------------------
# compile dtrace probes if dtrace is supported
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment