ByteCodeGen: Generate machine-code sequences for foreign import
\begin{code}
-module ByteCodeFFI ( mkMarshalCode, moan64 ) where
+module ByteCodeFFI ( mkMarshalCode, moan64, newExec ) where
#include "HsVersions.h"
-- there is ifdeffery below
import Control.Exception ( throwDyn )
import Data.Bits ( Bits(..), shiftR, shiftL )
-import Foreign ( newArray, Ptr )
import Data.List ( mapAccumL )
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 ( hPutStrLn, stderr )
-- import Debug.Trace ( trace )
-}
mkMarshalCode :: CCallConv
-> (Int, CgRep) -> Int -> [(Int, CgRep)]
- -> IO (Ptr Word8)
+ -> IO (FunPtr ())
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
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
-> (Int, CgRep) -> Int -> [(Int, CgRep)]
#include "HsVersions.h"
import ByteCodeInstr
+import ByteCodeItbls
import ByteCodeFFI
import ByteCodeAsm
import ByteCodeLink
import Data.List ( intersperse, sortBy, zip4, zip6, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
- withForeignPtr )
+ withForeignPtr, castFunPtrToPtr )
import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
-> Int
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
- -> [Ptr ()]
+ -> [BcPtr]
-> ProtoBCO name
mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
is_ret mallocd_blocks
ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
- recordMallocBc addr_of_marshaller `thenBc_`
+ recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) `thenBc_`
let
-- Offset of the next stack frame down the stack. The CCALL
-- instruction needs to describe the chunk of stack containing
stk_offset = d_after_r - s
-- 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
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX r_rep
-- to be on the safe side we copy the string into
-- a malloc'd area of memory.
ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
- recordMallocBc ptr `thenBc_`
+ recordMallocBc ptr `thenBc_`
ioToBc (
withForeignPtr fp $ \p -> do
memcpy ptr p (fromIntegral n)
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
+type BcPtr = Either ItblPtr (Ptr ())
+
data BcM_State
= BcM_State {
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
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
(>>) = thenBc_
return = returnBc
-emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
recordMallocBc :: Ptr a -> BcM ()
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
#include "HsVersions.h"
#include "../includes/MachDeps.h"
+import ByteCodeItbls ( ItblPtr )
+
import Outputable
import Name
import Id
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
-- malloc'd pointers
- protoBCOPtrs :: [Ptr ()]
+ protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
type LocalLabel = Int
\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
+module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls ) where
#include "HsVersions.h"
+import ByteCodeFFI ( newExec )
import Name ( Name, getName )
import NameEnv
import SMRep ( typeCgRep )
%************************************************************************
\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)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
-- This is the only arch-dependent bit.
code = mkJumpToAddr entry_addr
in
- do addr <- malloc_exec (sizeOf itbl)
+ do addr <- newExec [itbl]
--putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
--putStrLn ("# ptrs of itbl is " ++ show ptrs)
--putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
- poke addr itbl
- return (getName dcon, addr
-#ifdef GHCI_TABLES_NEXT_TO_CODE
- `plusPtr` (2 * wORD_SIZE)
-#endif
- )
+ return (getName dcon, ItblPtr (castFunPtrToPtr addr))
-- Make code which causes a jump to the given address. This is the
load = do addr <- advance
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}
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
-import GHC.Ptr ( Ptr(..) )
+import GHC.Ptr ( Ptr(..), castPtr )
import GHC.Base ( writeArray#, RealWorld, Int(..) )
\end{code}
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
itbls_arr = listArray (0, n_itbls-1) linked_itbls
- :: UArray Int ItblPtr
+
itbls_barr = case itbls_arr of UArray lo hi barr -> barr
literals_arr = listArray (0, n_literals-1) linked_literals
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
= case lookupNameEnv ie con_nm of
- Just (_, Ptr a) -> return (Ptr a)
+ Just (_, a) -> return (castPtr (itblCode a))
Nothing
-> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
#include "PosixSource.h"
#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>.
*/
#ifdef __linux__
void *map_addr = NULL;
#else
FILE *f;
- int misalignment;
#endif
initLinker();
/* 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 */
{
ObjectCode *o;
#define EXTRA_MAP_FLAGS 0
#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);
if (oc->image == MAP_FAILED)
barf("loadObj: can't map `%s'", path);
if (!f)
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
// if the total size of the headers is not a multiple of the
// desired alignment. This is fine for .o files that only serve
// We calculate the correct alignment from the header before
// reading the file, and then we misalign oc->image on purpose so
// that the actual sections end up aligned again.
- misalignment = machoGetMisalignment(f);
- oc->misalignment = misalignment;
-#else
- misalignment = 0;
-#endif
-
+ oc->misalignment = machoGetMisalignment(f);
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 );
if (n != oc->fileSize)
barf("loadObj: error whilst reading `%s'", path);
prev->next = oc->next;
}
- /* We're going to leave this in place, in case there are
- any pointers from the heap into it: */
- /* stgFree(oc->image); */
+ // We're going to leave this in place, in case there are
+ // any pointers from the heap into it:
+ // #ifdef mingw32_HOST_OS
+ // VirtualFree(oc->image);
+ // #else
+ // stgFree(oc->image);
+ // #endif
stgFree(oc->fileName);
stgFree(oc->symbols);
stgFree(oc->sections);
/*
ocAllocateJumpIslands
-
+
Allocate additional space at the end of the object file image to make room
for jump islands.
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
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;
projects / ghc-hetmet.git / commitdiff