Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
169f5972
Commit
169f5972
authored
Sep 08, 2010
by
Ian Lynagh
Browse files
Remove "-dynload wrapper"; fixes trac
#4275
parent
a96a7536
Changes
5
Hide whitespace changes
Inline
Side-by-side
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
...
...
Herbert Valerio Riedel
🕺
@hvr
mentioned in commit
f3beed35
·
Apr 10, 2016
mentioned in commit
f3beed35
mentioned in commit f3beed35309e4e8b60aa3f11372d1e00324eb046
Toggle commit list
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment