-- 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
-- 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"
))
-- 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"))
+++ /dev/null
-/* 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,¤t,envcont,strlen(envcont));
- FREE_GET_ENV(envcont);
- } else {
- add_to(&base,&buffersize,¤t,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);
-}
projects / ghc-hetmet.git / commitdiff