diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-07-12 20:07:59 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-07-27 04:47:51 -0400 |
commit | 0e875c3f1d7373812ddae9962edfc9538465d2ed (patch) | |
tree | 49a86dcbe6b875c042dc3e21070114a8cd4d5471 | |
parent | 3b07d8270341725c862230d8aec213fe34bd9fb6 (diff) | |
download | haskell-0e875c3f1d7373812ddae9962edfc9538465d2ed.tar.gz |
rts: Introduce and use ExecPage abstraction
Here we introduce a very thin abstraction for allocating, filling, and
freezing executable pages to replace allocateExec.
-rw-r--r-- | compiler/GHC/Unit/Info.hs | 2 | ||||
-rw-r--r-- | hadrian/src/Rules/Rts.hs | 2 | ||||
-rw-r--r-- | includes/Rts.h | 1 | ||||
-rw-r--r-- | includes/rts/ExecPage.h | 18 | ||||
-rw-r--r-- | libraries/ghci/GHCi/InfoTable.hsc | 93 | ||||
-rw-r--r-- | rts/ExecPage.c | 24 | ||||
-rw-r--r-- | rts/RtsSymbols.c | 6 | ||||
-rw-r--r-- | rts/adjustor/NativeAlpha.c | 15 | ||||
-rw-r--r-- | rts/adjustor/NativeAmd64.c | 41 | ||||
-rw-r--r-- | rts/adjustor/NativePowerPC.c | 21 | ||||
-rw-r--r-- | rts/adjustor/NativeSparc.c | 15 | ||||
-rw-r--r-- | rts/adjustor/Nativei386.c | 36 | ||||
-rw-r--r-- | rts/ghc.mk | 2 | ||||
-rw-r--r-- | rts/package.conf.in | 2 | ||||
-rw-r--r-- | rts/rts.cabal.in | 4 | ||||
-rw-r--r-- | testsuite/tests/th/T10279.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/th/T10279.stderr | 6 |
17 files changed, 179 insertions, 113 deletions
diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 8e86c84db8..2f4a9a607c 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -246,7 +246,7 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar -- and handling specifically for the `rts` package for -- example in ghc-cabal. addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0.1" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs index c9d1915593..3e0c94f24d 100644 --- a/hadrian/src/Rules/Rts.hs +++ b/hadrian/src/Rules/Rts.hs @@ -158,7 +158,7 @@ needRtsSymLinks stage rtsWays prefix, versionlessPrefix :: String versionlessPrefix = "libHSrts" -prefix = versionlessPrefix ++ "-1.0.1" +prefix = versionlessPrefix ++ "-1.0.2" -- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so" -- == "a/libHSrts-ghc1.2.3.4.so" diff --git a/includes/Rts.h b/includes/Rts.h index 0f96ba2eca..5e657e07ce 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -223,6 +223,7 @@ void _assertFail(const char *filename, unsigned int linenum) #include "rts/ForeignExports.h" /* Other RTS external APIs */ +#include "rts/ExecPage.h" #include "rts/Parallel.h" #include "rts/Signals.h" #include "rts/BlockSignals.h" diff --git a/includes/rts/ExecPage.h b/includes/rts/ExecPage.h new file mode 100644 index 0000000000..4261b71259 --- /dev/null +++ b/includes/rts/ExecPage.h @@ -0,0 +1,18 @@ +/* + * Utilities for managing dynamically-allocated executable pages. + */ + +#pragma once + +typedef struct { + char contents; +} ExecPage; + +/* Allocate a writable page. */ +ExecPage *allocateExecPage(void); + +/* Make a page previously allocated by allocateExecPage. */ +void freezeExecPage(ExecPage *page); + +/* Free a page previously allocated by allocateExecPage. */ +void freeExecPage(ExecPage *page); diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index c5dd4f0db8..65989a6e5b 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -37,8 +37,8 @@ mkConInfoTable -> Int -- pointer tag -> ByteString -- con desc -> IO (Ptr StgInfoTable) - -- resulting info table is allocated with allocateExec(), and - -- should be freed with freeExec(). + -- resulting info table is allocated with allocateExecPage(), and + -- should be freed with freeExecPage(). mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do let entry_addr = interpConstrEntry !! ptrtag @@ -326,28 +326,18 @@ sizeOfEntryCode tables_next_to_code -- Note: Must return proper pointer for use in a closure newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ()) -newExecConItbl tables_next_to_code obj con_desc -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - = do -#else - = alloca $ \pcode -> do -#endif - sz0 <- sizeOfEntryCode tables_next_to_code - let lcon_desc = BS.length con_desc + 1{- null terminator -} - -- SCARY - -- This size represents the number of bytes in an StgConInfoTable. - sz = fromIntegral $ conInfoTableSizeB + sz0 - -- Note: we need to allocate the conDesc string next to the info - -- table, because on a 64-bit platform we reference this string - -- with a 32-bit offset relative to the info table, so if we - -- allocated the string separately it might be out of range. -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - wr_ptr <- _allocateWrite (sz + fromIntegral lcon_desc) - let ex_ptr = wr_ptr -#else - wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode - ex_ptr <- peek pcode -#endif +newExecConItbl tables_next_to_code obj con_desc = do + sz0 <- sizeOfEntryCode tables_next_to_code + let lcon_desc = BS.length con_desc + 1{- null terminator -} + -- SCARY + -- This size represents the number of bytes in an StgConInfoTable. + sz = fromIntegral $ conInfoTableSizeB + sz0 + -- Note: we need to allocate the conDesc string next to the info + -- table, because on a 64-bit platform we reference this string + -- with a 32-bit offset relative to the info table, so if we + -- allocated the string separately it might be out of range. + + ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz , infoTable = obj } pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo @@ -355,13 +345,37 @@ newExecConItbl tables_next_to_code obj con_desc copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len let null_off = fromIntegral sz + fromIntegral (BS.length con_desc) poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8) - _flushExec sz ex_ptr -- Cache flush (if needed) -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - _markExec (sz + fromIntegral lcon_desc) ex_ptr -#endif - pure $ if tables_next_to_code - then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB - else castPtrToFunPtr ex_ptr + + pure $ if tables_next_to_code + then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB + else castPtrToFunPtr ex_ptr + +-- | Allocate a buffer of a given size, use the given action to fill it with +-- data, and mark it as executable. The action is given a writable pointer and +-- the executable pointer. Returns a pointer to the executable code. +fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a) + +#if MIN_VERSION_rts(1,0,2) + +data ExecPage + +foreign import ccall unsafe "allocateExecPage" + _allocateExecPage :: IO (Ptr ExecPage) + +foreign import ccall unsafe "freezeExecPage" + _freezeExecPage :: Ptr ExecPage -> IO () + +fillExecBuffer sz cont + -- we can only allocate single pages. This assumes a 4k page size which + -- isn't strictly correct but is a reasonable conservative lower bound. + | sz > 4096 = fail "withExecBuffer: Too large" + | otherwise = do + pg <- _allocateExecPage + cont (castPtr pg) (castPtr pg) + _freezeExecPage pg + return (castPtr pg) + +#elif MIN_VERSION_rts(1,0,1) foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) @@ -369,12 +383,19 @@ foreign import ccall unsafe "allocateExec" foreign import ccall unsafe "flushExec" _flushExec :: CUInt -> Ptr a -> IO () -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) -foreign import ccall unsafe "allocateWrite" - _allocateWrite :: CUInt -> IO (Ptr a) -foreign import ccall unsafe "markExec" - _markExec :: CUInt -> Ptr a -> IO () +fillExecBuffer sz cont = alloca $ \pcode -> do + wr_ptr <- _allocateExec (fromIntegral sz) pcode + ex_ptr <- peek pcode + cont wr_ptr ex_ptr + _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed) + return (ex_ptr) + +#else + +#error hi + #endif + -- ----------------------------------------------------------------------------- -- Constants and config diff --git a/rts/ExecPage.c b/rts/ExecPage.c new file mode 100644 index 0000000000..6f5b6e281a --- /dev/null +++ b/rts/ExecPage.c @@ -0,0 +1,24 @@ +/* + * Utilities for managing dynamically-allocated executable pages. + * + * These are primarily used to back the adjustor code produced by the native + * adjustor implementations. + */ + +#include "Rts.h" +#include "LinkerInternals.h" +#include "sm/OSMem.h" + +ExecPage *allocateExecPage() { + ExecPage *page = (ExecPage *) mmapAnonForLinker(getPageSize()); + return page; +} + +void freezeExecPage(ExecPage *page) { + mmapForLinkerMarkExecutable(page, getPageSize()); + flushExec(getPageSize(), page); +} + +void freeExecPage(ExecPage *page) { + munmapForLinker(page, getPageSize(), "freeExecPage"); +} diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 993af91528..170655a48c 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -977,9 +977,9 @@ SymI_HasProto(large_alloc_lim) \ SymI_HasProto(g0) \ SymI_HasProto(allocate) \ - SymI_HasProto(allocateExec) \ - SymI_HasProto(flushExec) \ - SymI_HasProto(freeExec) \ + SymI_HasProto(allocateExecPage) \ + SymI_HasProto(freezeExecPage) \ + SymI_HasProto(freeExecPage) \ SymI_HasProto(getAllocations) \ SymI_HasProto(revertCAFs) \ SymI_HasProto(RtsFlags) \ diff --git a/rts/adjustor/NativeAlpha.c b/rts/adjustor/NativeAlpha.c index e36a38d9dc..46fe4c090d 100644 --- a/rts/adjustor/NativeAlpha.c +++ b/rts/adjustor/NativeAlpha.c @@ -21,9 +21,6 @@ createAdjustor(int cconv, StgStablePtr hptr, char *typeString STG_UNUSED ) { - void *adjustor = NULL; - void *code = NULL; - switch (cconv) { case 1: /* _ccall */ @@ -67,10 +64,10 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for 4 bytes), we should move the first three instructions above down by 4 bytes (getting rid of the nop), hence saving memory. [ccshan] */ - ASSERT(((StgWord64)wptr & 3) == 0); - adjustor = allocateExec(48,&code); { - StgWord64 *const code = (StgWord64 *)adjustor; + ASSERT(((StgWord64)wptr & 3) == 0); + ExecPage *page = allocateExecPage(); + StgWord64 *const code = (StgWord64 *) page; code[0] = 0x4610041246520414L; code[1] = 0x46730415a61b0020L; @@ -81,15 +78,15 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for code[4] = (StgWord64)hptr; code[5] = (StgWord64)wptr; + freezeExecPage(page); /* Ensure that instruction cache is consistent with our new code */ __asm__ volatile("call_pal %0" : : "i" (PAL_imb)); + return code; } default: barf("createAdjustor: Unsupported calling convention"); } - - return code; } void @@ -103,5 +100,5 @@ freeHaskellFunctionPtr(void* ptr) /* Free the stable pointer first..*/ freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10))); - freeExec(ptr); + freeExecPage((ExecPage *) ptr); } diff --git a/rts/adjustor/NativeAmd64.c b/rts/adjustor/NativeAmd64.c index f1a92eacc5..67efe7aa31 100644 --- a/rts/adjustor/NativeAmd64.c +++ b/rts/adjustor/NativeAmd64.c @@ -55,9 +55,6 @@ createAdjustor(int cconv, StgStablePtr hptr, char *typeString ) { - void *adjustor = NULL; - void *code = NULL; - switch (cconv) { case 1: /* _ccall */ @@ -140,8 +137,6 @@ createAdjustor(int cconv, StgStablePtr hptr, */ { - StgWord8 *adj_code; - // determine whether we have 4 or more integer arguments, // and therefore need to flush one to the stack. if ((typeString[0] == '\0') || @@ -149,8 +144,8 @@ createAdjustor(int cconv, StgStablePtr hptr, (typeString[2] == '\0') || (typeString[3] == '\0')) { - adjustor = allocateExec(0x38,&code); - adj_code = (StgWord8*)adjustor; + ExecPage *page = allocateExecPage(); + StgWord8 *adj_code = (StgWord8*) page; *(StgInt32 *)adj_code = 0x49c1894d; *(StgInt32 *)(adj_code+0x4) = 0x8948d089; @@ -164,14 +159,16 @@ createAdjustor(int cconv, StgStablePtr hptr, *(StgInt32 *)(adj_code+0x20) = 0x00000000; *(StgInt64 *)(adj_code+0x28) = (StgInt64)hptr; *(StgInt64 *)(adj_code+0x30) = (StgInt64)wptr; + + freezeExecPage(page); + return page; } else { - int fourthFloating; + bool fourthFloating = (typeString[3] == 'f' || typeString[3] == 'd'); + ExecPage *page = allocateExecPage(); + StgWord8 *adj_code = (StgWord8*) page; - fourthFloating = (typeString[3] == 'f' || typeString[3] == 'd'); - adjustor = allocateExec(0x58,&code); - adj_code = (StgWord8*)adjustor; *(StgInt32 *)adj_code = 0x08ec8348; *(StgInt32 *)(adj_code+0x4) = fourthFloating ? 0x5c110ff2 : 0x4c894c90; @@ -192,6 +189,9 @@ createAdjustor(int cconv, StgStablePtr hptr, *(StgInt64 *)(adj_code+0x40) = (StgInt64)obscure_ccall_ret_code; *(StgInt64 *)(adj_code+0x48) = (StgInt64)hptr; *(StgInt64 *)(adj_code+0x50) = (StgInt64)wptr; + + freezeExecPage(page); + return page; } } @@ -256,7 +256,6 @@ createAdjustor(int cconv, StgStablePtr hptr, { int i = 0; char *c; - StgWord8 *adj_code; // determine whether we have 6 or more integer arguments, // and therefore need to flush one to the stack. @@ -266,8 +265,8 @@ createAdjustor(int cconv, StgStablePtr hptr, } if (i < 6) { - adjustor = allocateExec(0x30,&code); - adj_code = (StgWord8*)adjustor; + ExecPage *page = allocateExecPage(); + StgWord8 *adj_code = (StgWord8*) page; *(StgInt32 *)adj_code = 0x49c1894d; *(StgInt32 *)(adj_code+0x4) = 0x8948c889; @@ -278,11 +277,14 @@ createAdjustor(int cconv, StgStablePtr hptr, *(StgInt32 *)(adj_code+0x18) = 0x0000000c; *(StgInt64 *)(adj_code+0x20) = (StgInt64)hptr; *(StgInt64 *)(adj_code+0x28) = (StgInt64)wptr; + + freezeExecPage(page); + return page; } else { - adjustor = allocateExec(0x40,&code); - adj_code = (StgWord8*)adjustor; + ExecPage *page = allocateExecPage(); + StgWord8 *adj_code = (StgWord8*) page; *(StgInt32 *)adj_code = 0x35ff5141; *(StgInt32 *)(adj_code+0x4) = 0x00000020; @@ -297,6 +299,9 @@ createAdjustor(int cconv, StgStablePtr hptr, *(StgInt64 *)(adj_code+0x28) = (StgInt64)obscure_ccall_ret_code; *(StgInt64 *)(adj_code+0x30) = (StgInt64)hptr; *(StgInt64 *)(adj_code+0x38) = (StgInt64)wptr; + + freezeExecPage(page); + return page; } } #endif /* defined(mingw32_HOST_OS) */ @@ -305,8 +310,6 @@ createAdjustor(int cconv, StgStablePtr hptr, barf("createAdjustor: Unsupported calling convention"); break; } - - return code; } void freeHaskellFunctionPtr(void* ptr) @@ -332,5 +335,5 @@ void freeHaskellFunctionPtr(void* ptr) return; } - freeExec(ptr); + freeExecPage((ExecPage *) ptr); } diff --git a/rts/adjustor/NativePowerPC.c b/rts/adjustor/NativePowerPC.c index 41da4588a5..2e5d60549a 100644 --- a/rts/adjustor/NativePowerPC.c +++ b/rts/adjustor/NativePowerPC.c @@ -59,9 +59,6 @@ createAdjustor(int cconv, StgStablePtr hptr, char *typeString ) { - void *adjustor = NULL; - void *code = NULL; - switch (cconv) { case 1: /* _ccall */ @@ -81,7 +78,6 @@ createAdjustor(int cconv, StgStablePtr hptr, int n = strlen(typeString),i; int src_locs[n], dst_locs[n]; int frameSize; - unsigned *code; /* Step 1: Calculate where the arguments should go. @@ -154,8 +150,8 @@ createAdjustor(int cconv, StgStablePtr hptr, */ // allocate space for at most 4 insns per parameter // plus 14 more instructions. - adjustor = allocateExec(4 * (4*n + 14),&code); - code = (unsigned*)adjustor; + ExecPage *page = allocateExecPage(); + unsigned *code = adjustor; *code++ = 0x48000008; // b *+8 // * Put the hptr in a place where freeHaskellFunctionPtr @@ -261,6 +257,8 @@ createAdjustor(int cconv, StgStablePtr hptr, // bctr *code++ = 0x4e800420; + freezeExecPage(page); + // Flush the Instruction cache: { unsigned *p = adjustor; @@ -304,7 +302,8 @@ createAdjustor(int cconv, StgStablePtr hptr, #if defined(FUNDESCS) adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor"); #else - adjustorStub = allocateExec(sizeof(AdjustorStub),&code); + ExecPage *page = allocateExecPage(); + adjustorStub = (AdjustorStub *) page; #endif /* defined(FUNDESCS) */ adjustor = adjustorStub; @@ -330,6 +329,8 @@ createAdjustor(int cconv, StgStablePtr hptr, adjustorStub->mtctr = 0x7c0903a6; // bctr adjustorStub->bctr = 0x4e800420; + + freezeExecPage(page); #else barf("adjustor creation not supported on this platform"); #endif /* defined(powerpc_HOST_ARCH) */ @@ -375,13 +376,13 @@ createAdjustor(int cconv, StgStablePtr hptr, adjustorStub->wptr = wptr; adjustorStub->negative_framesize = -total_sz; adjustorStub->extrawords_plus_one = extra_sz + 1; + + return code; } default: barf("createAdjustor: Unsupported calling convention"); } - - return code; } void @@ -401,5 +402,5 @@ freeHaskellFunctionPtr(void* ptr) freeStablePtr(((AdjustorStub*)ptr)->hptr); #endif - freeExec(ptr); + freeExecPage(ptr); } diff --git a/rts/adjustor/NativeSparc.c b/rts/adjustor/NativeSparc.c index 856f696813..059455d050 100644 --- a/rts/adjustor/NativeSparc.c +++ b/rts/adjustor/NativeSparc.c @@ -14,9 +14,6 @@ createAdjustor(int cconv, StgStablePtr hptr, char *typeString STG_UNUSED ) { - void *adjustor = NULL; - void *code = NULL; - switch (cconv) { case 1: /* _ccall */ @@ -49,9 +46,9 @@ createAdjustor(int cconv, StgStablePtr hptr, similarly, and local variables should be accessed via %fp, not %sp. In a nutshell: This should work! (Famous last words! :-) */ - adjustor = allocateExec(4*(11+1),&code); { - unsigned long *const adj_code = (unsigned long *)adjustor; + ExecPage *page = allocateExecPage(); + unsigned long *const adj_code = (unsigned long *) page; adj_code[ 0] = 0x9C23A008UL; /* sub %sp, 8, %sp */ adj_code[ 1] = 0xDA23A060UL; /* st %o5, [%sp + 96] */ @@ -71,6 +68,8 @@ createAdjustor(int cconv, StgStablePtr hptr, adj_code[11] = (unsigned long)hptr; + freezeExecPage(page); + /* flush cache */ asm("flush %0" : : "r" (adj_code )); asm("flush %0" : : "r" (adj_code + 2)); @@ -83,13 +82,13 @@ createAdjustor(int cconv, StgStablePtr hptr, asm("nop"); asm("nop"); asm("nop"); + + return page; } default: barf("createAdjustor: Unsupported calling convention"); } - - return code; } void @@ -103,5 +102,5 @@ freeHaskellFunctionPtr(void* ptr) /* Free the stable pointer first..*/ freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11))); - freeExec(ptr); + freeExecPage(ptr); } diff --git a/rts/adjustor/Nativei386.c b/rts/adjustor/Nativei386.c index c0e7e0a4d3..af6d842be8 100644 --- a/rts/adjustor/Nativei386.c +++ b/rts/adjustor/Nativei386.c @@ -34,9 +34,6 @@ createAdjustor(int cconv, StgStablePtr hptr, char *typeString STG_UNUSED ) { - void *adjustor = NULL; - void *code = NULL; - switch (cconv) { case 0: /* _stdcall */ @@ -55,20 +52,23 @@ createAdjustor(int cconv, StgStablePtr hptr, */ { - unsigned char adj_code[14]; - adj_code[0x00] = (unsigned char)0x58; /* popl %eax */ + ExecPage *page = allocateExecPage(); + uint8_t *adj_code = (uint8_t *) page; + adj_code[0x00] = 0x58; /* popl %eax */ - adj_code[0x01] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ + adj_code[0x01] = 0x68; /* pushl hptr (which is a dword immediate ) */ *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr; - adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */ + adj_code[0x06] = 0x50; /* pushl %eax */ - adj_code[0x07] = (unsigned char)0xb8; /* movl $wptr, %eax */ + adj_code[0x07] = 0xb8; /* movl $wptr, %eax */ *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr; - adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */ - adj_code[0x0d] = (unsigned char)0xe0; - adjustor = allocateExec(14, &adj_code); + adj_code[0x0c] = 0xff; /* jmp %eax */ + adj_code[0x0d] = 0xe0; + + freezeExecPage(page); + return page; } #endif /* !defined(darwin_HOST_OS) */ @@ -82,13 +82,12 @@ createAdjustor(int cconv, StgStablePtr hptr, We offload most of the work to AdjustorAsm.S. */ - AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code); - adjustor = adjustorStub; - + ExecPage *page = allocateExecPage(); + AdjustorStub *adjustorStub = (AdjustorStub *) page; int sz = totalArgumentSize(typeString); adjustorStub->call[0] = 0xe8; - *(long*)&adjustorStub->call[1] = ((char*)&adjustorCode) - ((char*)code + 5); + *(long*)&adjustorStub->call[1] = ((char*)&adjustorCode) - ((char*)page + 5); adjustorStub->hptr = hptr; adjustorStub->wptr = wptr; @@ -107,13 +106,14 @@ createAdjustor(int cconv, StgStablePtr hptr, // only count 2.) and 3.) as part of frame_size adjustorStub->frame_size -= 12; adjustorStub->argument_size = sz; + + freezeExecPage(page); + return page; } default: barf("createAdjustor: Unsupported calling convention"); } - - return code; } void @@ -130,5 +130,5 @@ freeHaskellFunctionPtr(void* ptr) freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02))); } - freeExec(ptr); + freeExecPage((ExecPage *) ptr); } diff --git a/rts/ghc.mk b/rts/ghc.mk index d3e533d1f7..24a4240c59 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -17,7 +17,7 @@ rts_dist_HC = $(GHC_STAGE1) rts_INSTALL_INFO = rts -rts_VERSION = 1.0.1 +rts_VERSION = 1.0.2 # Minimum supported Windows version. # These numbers can be found at: diff --git a/rts/package.conf.in b/rts/package.conf.in index f703feec06..9bc48d57ca 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -5,7 +5,7 @@ #include "MachDeps.h" name: rts -version: 1.0.1 +version: 1.0.2 id: rts key: rts license: BSD-3-Clause diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index 7c0f40dcfa..ded2f15509 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -1,6 +1,6 @@ cabal-version: 3.0 name: rts -version: 1.0.1 +version: 1.0.2 license: BSD-3-Clause maintainer: glasgow-haskell-users@haskell.org build-type: Simple @@ -145,6 +145,7 @@ library DerivedConstants.h ffi.h ffitarget.h -- ^ generated rts/Adjustor.h + rts/ExecPage.h rts/BlockSignals.h rts/Bytecodes.h rts/Config.h @@ -442,6 +443,7 @@ library asm-sources: StgCRunAsm.S c-sources: Adjustor.c + ExecPage.c Arena.c Capability.c CheckUnload.c diff --git a/testsuite/tests/th/T10279.hs b/testsuite/tests/th/T10279.hs index ea0d79de29..23195e6e06 100644 --- a/testsuite/tests/th/T10279.hs +++ b/testsuite/tests/th/T10279.hs @@ -2,9 +2,9 @@ module T10279 where import Language.Haskell.TH import Language.Haskell.TH.Syntax --- NB: rts-1.0.1 is used here because it doesn't change. +-- NB: rts-1.0.2 is used here because it doesn't change. -- You do need to pick the right version number, otherwise the -- error message doesn't recognize it as a source package ID, -- (This is OK, since it will look obviously wrong when they -- try to find the package in their package database.) -blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.1") (mkModName "A")))) +blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A")))) diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr index b66e5b4fba..45c17432e1 100644 --- a/testsuite/tests/th/T10279.stderr +++ b/testsuite/tests/th/T10279.stderr @@ -1,8 +1,8 @@ T10279.hs:10:9: error: • Failed to load interface for ‘A’ - no unit id matching ‘rts-1.0.1’ was found + no unit id matching ‘rts-1.0.2’ was found (This unit ID looks like the source package ID; the real unit ID is ‘rts’) - • In the expression: rts-1.0.1:A.Foo - In an equation for ‘blah’: blah = (rts-1.0.1:A.Foo) + • In the expression: rts-1.0.2:A.Foo + In an equation for ‘blah’: blah = (rts-1.0.2:A.Foo) |