Commit 7cca410a authored by Simon Marlow's avatar Simon Marlow

MERGE: Fix Windows DEP violations (bug #885)

Original patch by brianlsmith@gmail.com
parent c667b12e
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
ByteCodeGen: Generate machine-code sequences for foreign import ByteCodeGen: Generate machine-code sequences for foreign import
\begin{code} \begin{code}
module ByteCodeFFI ( mkMarshalCode, moan64 ) where module ByteCodeFFI ( mkMarshalCode, moan64, newExec ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -18,10 +18,12 @@ import Panic ...@@ -18,10 +18,12 @@ import Panic
-- there is ifdeffery below -- there is ifdeffery below
import Control.Exception ( throwDyn ) import Control.Exception ( throwDyn )
import Data.Bits ( Bits(..), shiftR, shiftL ) import Data.Bits ( Bits(..), shiftR, shiftL )
import Foreign ( newArray, Ptr )
import Data.List ( mapAccumL ) import Data.List ( mapAccumL )
import Data.Word ( Word8, Word32 ) import Data.Word ( Word8, Word32 )
import Foreign ( Ptr, FunPtr, castPtrToFunPtr,
Storable, sizeOf, pokeArray )
import Foreign.C ( CUInt )
import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( hPutStrLn, stderr ) import System.IO ( hPutStrLn, stderr )
-- import Debug.Trace ( trace ) -- import Debug.Trace ( trace )
...@@ -70,14 +72,23 @@ we don't clear our own (single) arg off the C stack. ...@@ -70,14 +72,23 @@ we don't clear our own (single) arg off the C stack.
-} -}
mkMarshalCode :: CCallConv mkMarshalCode :: CCallConv
-> (Int, CgRep) -> Int -> [(Int, CgRep)] -> (Int, CgRep) -> Int -> [(Int, CgRep)]
-> IO (Ptr Word8) -> IO (FunPtr ())
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep) = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
addr_offW arg_offs_n_reps addr_offW arg_offs_n_reps
in Foreign.newArray bytes in newExec bytes
newExec :: Storable a => [a] -> IO (FunPtr ())
newExec code
= do ptr <- _allocateExec (fromIntegral $ codeSize undefined code)
pokeArray ptr code
return (castPtrToFunPtr ptr)
where
codeSize :: Storable a => a -> [a] -> Int
codeSize dummy array = sizeOf(dummy) * length array
foreign import ccall unsafe "allocateExec"
_allocateExec :: CUInt -> IO (Ptr a)
mkMarshalCode_wrk :: CCallConv mkMarshalCode_wrk :: CCallConv
-> (Int, CgRep) -> Int -> [(Int, CgRep)] -> (Int, CgRep) -> Int -> [(Int, CgRep)]
......
...@@ -10,6 +10,7 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where ...@@ -10,6 +10,7 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h" #include "HsVersions.h"
import ByteCodeInstr import ByteCodeInstr
import ByteCodeItbls
import ByteCodeFFI import ByteCodeFFI
import ByteCodeAsm import ByteCodeAsm
import ByteCodeLink import ByteCodeLink
...@@ -48,7 +49,7 @@ import Constants ...@@ -48,7 +49,7 @@ import Constants
import Data.List ( intersperse, sortBy, zip4, zip6, partition ) import Data.List ( intersperse, sortBy, zip4, zip6, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
withForeignPtr ) withForeignPtr, castFunPtrToPtr )
import Foreign.C ( CInt ) import Foreign.C ( CInt )
import Control.Exception ( throwDyn ) import Control.Exception ( throwDyn )
...@@ -138,7 +139,7 @@ mkProtoBCO ...@@ -138,7 +139,7 @@ mkProtoBCO
-> Int -> Int
-> [StgWord] -> [StgWord]
-> Bool -- True <=> is a return point, rather than a function -> Bool -- True <=> is a return point, rather than a function
-> [Ptr ()] -> [BcPtr]
-> ProtoBCO name -> ProtoBCO name
mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
is_ret mallocd_blocks is_ret mallocd_blocks
...@@ -926,7 +927,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l ...@@ -926,7 +927,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
ioToBc (mkMarshalCode cconv ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW (r_offW, r_rep) addr_offW
(zip args_offW a_reps)) `thenBc` \ addr_of_marshaller -> (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
recordMallocBc addr_of_marshaller `thenBc_` recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) `thenBc_`
let let
-- Offset of the next stack frame down the stack. The CCALL -- Offset of the next stack frame down the stack. The CCALL
-- instruction needs to describe the chunk of stack containing -- instruction needs to describe the chunk of stack containing
...@@ -935,7 +936,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l ...@@ -935,7 +936,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
stk_offset = d_after_r - s stk_offset = d_after_r - s
-- do the call -- do the call
do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller)) do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
-- slide and return -- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX r_rep `snocOL` RETURN_UBX r_rep
...@@ -1102,7 +1103,7 @@ pushAtom d p (AnnLit lit) ...@@ -1102,7 +1103,7 @@ pushAtom d p (AnnLit lit)
-- to be on the safe side we copy the string into -- to be on the safe side we copy the string into
-- a malloc'd area of memory. -- a malloc'd area of memory.
ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
recordMallocBc ptr `thenBc_` recordMallocBc ptr `thenBc_`
ioToBc ( ioToBc (
withForeignPtr fp $ \p -> do withForeignPtr fp $ \p -> do
memcpy ptr p (fromIntegral n) memcpy ptr p (fromIntegral n)
...@@ -1314,10 +1315,12 @@ mkStackOffsets original_depth szsw ...@@ -1314,10 +1315,12 @@ mkStackOffsets original_depth szsw
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The bytecode generator's monad -- The bytecode generator's monad
type BcPtr = Either ItblPtr (Ptr ())
data BcM_State data BcM_State
= BcM_State { = BcM_State {
nextlabel :: Int, -- for generating local labels nextlabel :: Int, -- for generating local labels
malloced :: [Ptr ()] } -- ptrs malloced for current BCO malloced :: [BcPtr] } -- thunks malloced for current BCO
-- Should be free()d when it is GCd -- Should be free()d when it is GCd
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
...@@ -1351,13 +1354,17 @@ instance Monad BcM where ...@@ -1351,13 +1354,17 @@ instance Monad BcM where
(>>) = thenBc_ (>>) = thenBc_
return = returnBc return = returnBc
emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco emitBc bco
= BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
recordMallocBc :: Ptr a -> BcM () recordMallocBc :: Ptr a -> BcM ()
recordMallocBc a recordMallocBc a
= BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ()) = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
recordItblMallocBc :: ItblPtr -> BcM ()
recordItblMallocBc a
= BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
getLabelBc :: BcM Int getLabelBc :: BcM Int
getLabelBc getLabelBc
......
...@@ -11,6 +11,8 @@ module ByteCodeInstr ( ...@@ -11,6 +11,8 @@ module ByteCodeInstr (
#include "HsVersions.h" #include "HsVersions.h"
#include "../includes/MachDeps.h" #include "../includes/MachDeps.h"
import ByteCodeItbls ( ItblPtr )
import Outputable import Outputable
import Name import Name
import Id import Id
...@@ -38,7 +40,7 @@ data ProtoBCO a ...@@ -38,7 +40,7 @@ data ProtoBCO a
-- what the BCO came from -- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
-- malloc'd pointers -- malloc'd pointers
protoBCOPtrs :: [Ptr ()] protoBCOPtrs :: [Either ItblPtr (Ptr ())]
} }
type LocalLabel = Int type LocalLabel = Int
......
...@@ -6,10 +6,11 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes ...@@ -6,10 +6,11 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
\begin{code} \begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls ) where
#include "HsVersions.h" #include "HsVersions.h"
import ByteCodeFFI ( newExec )
import Name ( Name, getName ) import Name ( Name, getName )
import NameEnv import NameEnv
import SMRep ( typeCgRep ) import SMRep ( typeCgRep )
...@@ -35,7 +36,15 @@ import GHC.Ptr ( Ptr(..) ) ...@@ -35,7 +36,15 @@ import GHC.Ptr ( Ptr(..) )
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
type ItblPtr = Ptr StgInfoTable newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
itblCode :: ItblPtr -> Ptr ()
itblCode (ItblPtr ptr)
= (castPtr ptr)
#ifdef GHCI_TABLES_NEXT_TO_CODE
`plusPtr` (wORD_SIZE * 2)
#endif
type ItblEnv = NameEnv (Name, ItblPtr) type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which -- We need the Name in the range so we know which
-- elements to filter out when unloading a module -- elements to filter out when unloading a module
...@@ -107,16 +116,11 @@ make_constr_itbls cons ...@@ -107,16 +116,11 @@ make_constr_itbls cons
-- This is the only arch-dependent bit. -- This is the only arch-dependent bit.
code = mkJumpToAddr entry_addr code = mkJumpToAddr entry_addr
in in
do addr <- malloc_exec (sizeOf itbl) do addr <- newExec [itbl]
--putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
--putStrLn ("# ptrs of itbl is " ++ show ptrs) --putStrLn ("# ptrs of itbl is " ++ show ptrs)
--putStrLn ("# nptrs of itbl is " ++ show nptrs_really) --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
poke addr itbl return (getName dcon, ItblPtr (castFunPtrToPtr addr))
return (getName dcon, addr
#ifdef GHCI_TABLES_NEXT_TO_CODE
`plusPtr` (2 * wORD_SIZE)
#endif
)
-- Make code which causes a jump to the given address. This is the -- Make code which causes a jump to the given address. This is the
...@@ -390,10 +394,4 @@ load :: Storable a => PtrIO a ...@@ -390,10 +394,4 @@ load :: Storable a => PtrIO a
load = do addr <- advance load = do addr <- advance
lift (peek addr) lift (peek addr)
foreign import ccall unsafe "allocateExec"
_allocateExec :: CUInt -> IO (Ptr a)
malloc_exec :: Int -> IO (Ptr a)
malloc_exec bytes = _allocateExec (fromIntegral bytes)
\end{code} \end{code}
...@@ -46,7 +46,7 @@ import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#, ...@@ -46,7 +46,7 @@ import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
import GHC.Arr ( Array(..) ) import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) ) import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) ) import GHC.Ptr ( Ptr(..), castPtr )
import GHC.Base ( writeArray#, RealWorld, Int(..) ) import GHC.Base ( writeArray#, RealWorld, Int(..) )
\end{code} \end{code}
...@@ -124,7 +124,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS ...@@ -124,7 +124,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
itbls_arr = listArray (0, n_itbls-1) linked_itbls itbls_arr = listArray (0, n_itbls-1) linked_itbls
:: UArray Int ItblPtr
itbls_barr = case itbls_arr of UArray lo hi barr -> barr itbls_barr = case itbls_arr of UArray lo hi barr -> barr
literals_arr = listArray (0, n_literals-1) linked_literals literals_arr = listArray (0, n_literals-1) linked_literals
...@@ -222,7 +222,7 @@ lookupName ce nm ...@@ -222,7 +222,7 @@ lookupName ce nm
lookupIE :: ItblEnv -> Name -> IO (Ptr a) lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm lookupIE ie con_nm
= case lookupNameEnv ie con_nm of = case lookupNameEnv ie con_nm of
Just (_, Ptr a) -> return (Ptr a) Just (_, a) -> return (castPtr (itblCode a))
Nothing Nothing
-> do -- try looking up in the object files. -> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info" let sym_to_find1 = nameToCLabel con_nm "con_info"
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
#include "PosixSource.h" #include "PosixSource.h"
#endif #endif
/* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and
MREMAP_MAYMOVE from <sys/mman.h>. MREMAP_MAYMOVE from <sys/mman.h>.
*/ */
#ifdef __linux__ #ifdef __linux__
...@@ -1161,13 +1161,12 @@ loadObj( char *path ) ...@@ -1161,13 +1161,12 @@ loadObj( char *path )
void *map_addr = NULL; void *map_addr = NULL;
#else #else
FILE *f; FILE *f;
int misalignment;
#endif #endif
initLinker(); initLinker();
/* debugBelch("loadObj %s\n", path ); */ /* debugBelch("loadObj %s\n", path ); */
/* Check that we haven't already loaded this object. /* Check that we haven't already loaded this object.
Ignore requests to load multiple times */ Ignore requests to load multiple times */
{ {
ObjectCode *o; ObjectCode *o;
...@@ -1257,7 +1256,7 @@ loadObj( char *path ) ...@@ -1257,7 +1256,7 @@ loadObj( char *path )
#define EXTRA_MAP_FLAGS 0 #define EXTRA_MAP_FLAGS 0
#endif #endif
oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE, oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,
MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0); MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
if (oc->image == MAP_FAILED) if (oc->image == MAP_FAILED)
barf("loadObj: can't map `%s'", path); barf("loadObj: can't map `%s'", path);
...@@ -1271,7 +1270,12 @@ loadObj( char *path ) ...@@ -1271,7 +1270,12 @@ loadObj( char *path )
if (!f) if (!f)
barf("loadObj: can't read `%s'", path); barf("loadObj: can't read `%s'", path);
#ifdef darwin_HOST_OS # 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,
PAGE_EXECUTE_READWRITE);
# elif defined(darwin_HOST_OS)
// In a Mach-O .o file, all sections can and will be misaligned // In a Mach-O .o file, all sections can and will be misaligned
// if the total size of the headers is not a multiple of the // if the total size of the headers is not a multiple of the
// desired alignment. This is fine for .o files that only serve // desired alignment. This is fine for .o files that only serve
...@@ -1281,15 +1285,12 @@ loadObj( char *path ) ...@@ -1281,15 +1285,12 @@ loadObj( char *path )
// We calculate the correct alignment from the header before // 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 oc->image on purpose so
// that the actual sections end up aligned again. // that the actual sections end up aligned again.
misalignment = machoGetMisalignment(f); oc->misalignment = machoGetMisalignment(f);
oc->misalignment = misalignment;
#else
misalignment = 0;
#endif
oc->image = stgMallocBytes(oc->fileSize + misalignment, "loadObj(image)"); oc->image = stgMallocBytes(oc->fileSize + misalignment, "loadObj(image)");
oc->image += misalignment; # else
oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
# endif
n = fread ( oc->image, 1, oc->fileSize, f ); n = fread ( oc->image, 1, oc->fileSize, f );
if (n != oc->fileSize) if (n != oc->fileSize)
barf("loadObj: error whilst reading `%s'", path); barf("loadObj: error whilst reading `%s'", path);
...@@ -1402,9 +1403,13 @@ unloadObj( char *path ) ...@@ -1402,9 +1403,13 @@ unloadObj( char *path )
prev->next = oc->next; prev->next = oc->next;
} }
/* We're going to leave this in place, in case there are // We're going to leave this in place, in case there are
any pointers from the heap into it: */ // any pointers from the heap into it:
/* stgFree(oc->image); */ // #ifdef mingw32_HOST_OS
// VirtualFree(oc->image);
// #else
// stgFree(oc->image);
// #endif
stgFree(oc->fileName); stgFree(oc->fileName);
stgFree(oc->symbols); stgFree(oc->symbols);
stgFree(oc->sections); stgFree(oc->sections);
...@@ -1479,7 +1484,7 @@ static void addSection ( ObjectCode* oc, SectionKind kind, ...@@ -1479,7 +1484,7 @@ static void addSection ( ObjectCode* oc, SectionKind kind,
/* /*
ocAllocateJumpIslands ocAllocateJumpIslands
Allocate additional space at the end of the object file image to make room Allocate additional space at the end of the object file image to make room
for jump islands. for jump islands.
......
...@@ -979,6 +979,11 @@ calcNeeded(void) ...@@ -979,6 +979,11 @@ calcNeeded(void)
in the page, and when the page is emptied (all objects on the page in the page, and when the page is emptied (all objects on the page
are free) we free the page again, not forgetting to make it are free) we free the page again, not forgetting to make it
non-executable. non-executable.
TODO: The inability to handle objects bigger than BLOCK_SIZE_W means that
the linker cannot use allocateExec for loading object code files
on Windows. Once allocateExec can handle larger objects, the linker
should be modified to use allocateExec instead of VirtualAlloc.
------------------------------------------------------------------------- */ ------------------------------------------------------------------------- */
static bdescr *exec_block; static bdescr *exec_block;
......
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