{-# LANGUAGE CPP #-}moduleGHC.Vacuum.Internal(HValue,HalfWord,ItblCode,StgInfoTable(..),ghciTablesNextToCode,dataConInfoPtrToNames,wORD_SIZE,hALF_WORD_SIZE,S(..),get,gets,set,io,modify,runS)whereimportData.CharimportData.WordimportData.ListimportData.IORefimportData.Array.IArrayimportControl.MonadimportControl.Monad.FiximportForeignimportData.ListimportData.Map(Map)importData.Set(Set)importqualifiedData.SetasSimportqualifiedData.MapasMimportData.Monoid(Monoid(..))importGHC.PrimimportGHC.Exts#include "ghcplatform.h"#include "ghcautoconf.h"#define GHCI_TABLES_NEXT_TO_CODE-- is there somewhere to get this define?------------------------------------------------------------------------------- * Fabricate what we need to avoid the ghc pkg deptypeHValue=Any#if SIZEOF_VOID_P == 8typeHalfWord=Word32#elsetypeHalfWord=Word16#endif-- | From SMReptypeByteOff=Int-- | From SMReptypeWordOff=Int-- | From SMReptypeStgWord=Word-- hmmmmmm. Is there any way to tell this?opt_SccProfilingOn=False-- ghci> wORD_SIZE-- 8-- ghci> sizeOf (undefined :: Word)-- 8wORD_SIZE::IntwORD_SIZE=sizeOf(undefined::Word)hALF_WORD_SIZE::InthALF_WORD_SIZE=wORD_SIZE`div`2-- | This is currently always True since-- i'm not sure how to get at the CPP define-- \"GHCI_TABLES_NEXT_TO_CODE\" (or equiv) to tell.ghciTablesNextToCode::Bool#ifdef GHCI_TABLES_NEXT_TO_CODEghciTablesNextToCode=True#elseghciTablesNextToCode=False#endif-----------------------------------------------------------------------------dataStgInfoTable=StgInfoTable{#ifndef GHCI_TABLES_NEXT_TO_CODEentry::Ptr(),#endifptrs::HalfWord,nptrs::HalfWord,tipe::HalfWord,srtlen::HalfWord#ifdef GHCI_TABLES_NEXT_TO_CODE,code::[ItblCode]#endif}instanceStorableStgInfoTablewheresizeOfitbl=sum[#ifndef GHCI_TABLES_NEXT_TO_CODEfieldSzentryitbl,#endiffieldSzptrsitbl,fieldSznptrsitbl,fieldSztipeitbl,fieldSzsrtlenitbl#ifdef GHCI_TABLES_NEXT_TO_CODE,fieldSz(head.code)itbl*itblCodeLength#endif]alignmentitbl=SIZEOF_VOID_Ppokea0itbl=flipevalS(castPtra0)$do#ifndef GHCI_TABLES_NEXT_TO_CODEstore(entryitbl)#endifstore(ptrsitbl)store(nptrsitbl)store(tipeitbl)store(srtlenitbl)#ifdef GHCI_TABLES_NEXT_TO_CODEsequence_(mapstore(codeitbl))#endifpeeka0=flipevalS(castPtra0)$do#ifndef GHCI_TABLES_NEXT_TO_CODEentry<-load#endifptrs<-loadnptrs<-loadtipe<-loadsrtlen<-load#ifdef GHCI_TABLES_NEXT_TO_CODEcode<-sequence(replicateitblCodeLengthload)#endifreturnStgInfoTable{#ifndef GHCI_TABLES_NEXT_TO_CODEentry=entry,#endifptrs=ptrs,nptrs=nptrs,tipe=tipe,srtlen=srtlen#ifdef GHCI_TABLES_NEXT_TO_CODE,code=code#endif}fieldSz::(Storablea,Storableb)=>(a->b)->a->IntfieldSzselx=sizeOf(selx)typePtrIO=S(PtrWord8)advance::Storablea=>PtrIO(Ptra)advance=Sadvwhereadvkaddr=casecastPtraddrofaddrCast->kaddrCast(addr`plusPtr`sizeOfPointeeaddrCast)sizeOfPointee::(Storablea)=>Ptra->IntsizeOfPointeeaddr=sizeOf(typeHackaddr)wheretypeHack=undefined::Ptra->astore::Storablea=>a->PtrIO()storex=doaddr<-advanceio(pokeaddrx)load::Storablea=>PtrIOaload=doaddr<-advanceio(peekaddr)newtypeSsa=S{unS::forallo.(a->s->IOo)->s->IOo}instanceFunctor(Ss)wherefmapf(Sg)=S(\k->g(k.f))instanceMonad(Ss)wherereturna=S(\k->ka)Sg>>=f=S(\k->g(\a->unS(fa)k))instanceMonadFix(Ss)wheremfixf=S(\ks->uncurryk=<<mfix(\~(a,_)->-- the lazy pattern is ESSENTIAL, otherwise <<loop>>unS(fa)(\as->return(a,s))s))get::Sssget=S(\ks->kss)gets::(s->a)->Ssagetsf=S(\ks->k(fs)s)set::s->Ss()sets=S(\k_->k()s)io::IOa->Ssaiom=S(\ks->flipks=<<m)modify::(s->s)->Ss()modifyf=S(\k->k().f)runS::Ssa->s->IO(a,s)runS(Sg)=g(\a->return.(,)a)evalS::Ssa->s->IOaevalS(Sg)=g(\a_->returna)execS::Ssa->s->IOsexecS(Sg)=g(\_->return)------------------------------------------------------------------------------- VACUUM: All this just to get itblCodeLength.-- Make code which causes a jump to the given address. This is the-- only arch-dependent bit of the itbl story. The returned list is-- itblCodeLength elements (bytes) long.-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.-- #include "nativeGen/NCG.h"-- VACUUM: we get *_TARGET_ARCH from ghcplatform.h insteaditblCodeLength::IntitblCodeLength=length(mkJumpToAddrundefined)mkJumpToAddr::Ptr()->[ItblCode]ptrToInt(Ptra#)=I#(addr2Int#a#)#if sparc_TARGET_ARCH-- After some consideration, we'll try this, where-- 0x55555555 stands in for the address to jump to.-- According to ghc/includes/MachRegs.h, %g3 is very-- likely indeed to be baggable.---- 0000 07155555 sethi %hi(0x55555555), %g3-- 0004 8610E155 or %g3, %lo(0x55555555), %g3-- 0008 81C0C000 jmp %g3-- 000c 01000000 noptypeItblCode=Word32mkJumpToAddra=letw32=fromIntegral(ptrToInta)hi22,lo10::Word32->Word32lo10x=x.&.0x3FFhi22x=(x`shiftR`10).&.0x3FFFFin[0x07000000.|.(hi22w32),0x8610E000.|.(lo10w32),0x81C0C000,0x01000000]#elif powerpc_TARGET_ARCH-- We'll use r12, for no particular reason.-- 0xDEADBEEF stands for the adress:-- 3D80DEAD lis r12,0xDEAD-- 618CBEEF ori r12,r12,0xBEEF-- 7D8903A6 mtctr r12-- 4E800420 bctrtypeItblCode=Word32mkJumpToAddra=letw32=fromIntegral(ptrToInta)hi16x=(x`shiftR`16).&.0xFFFFlo16x=x.&.0xFFFFin[0x3D800000.|.hi16w32,0x618C0000.|.lo16w32,0x7D8903A6,0x4E800420]#elif i386_TARGET_ARCH-- Let the address to jump to be 0xWWXXYYZZ.-- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax-- which is-- B8 ZZ YY XX WW FF E0typeItblCode=Word8mkJumpToAddra=letw32=fromIntegral(ptrToInta)::Word32insnBytes::[Word8]insnBytes=[0xB8,byte0w32,byte1w32,byte2w32,byte3w32,0xFF,0xE0]ininsnBytes#elif x86_64_TARGET_ARCH-- Generates:-- jmpq *.L1(%rip)-- .align 8-- .L1:-- .quad <addr>---- We need a full 64-bit pointer (we can't assume the info table is-- allocated in low memory). Assuming the info pointer is aligned to-- an 8-byte boundary, the addr will also be aligned.typeItblCode=Word8mkJumpToAddra=letw64=fromIntegral(ptrToInta)::Word64insnBytes::[Word8]insnBytes=[0xff,0x25,0x02,0x00,0x00,0x00,0x00,0x00,byte0w64,byte1w64,byte2w64,byte3w64,byte4w64,byte5w64,byte6w64,byte7w64]ininsnBytes#elif alpha_TARGET_ARCHtypeItblCode=Word32mkJumpToAddra=[0xc3800000-- br at, .+4,0xa79c000c-- ldq at, 12(at),0x6bfc0000-- jmp (at) # with zero hint -- oh well,0x47ff041f-- nop,fromIntegral(w64.&.0x0000FFFF),fromIntegral((w64`shiftR`32).&.0x0000FFFF)]wherew64=fromIntegral(ptrToInta)::Word64#elsetypeItblCode=Word32mkJumpToAddra=undefined#endifbyte0,byte1,byte2,byte3,byte4,byte5,byte6,byte7::(Integralw,Bitsw)=>w->Word8byte0w=fromIntegralwbyte1w=fromIntegral(w`shiftR`8)byte2w=fromIntegral(w`shiftR`16)byte3w=fromIntegral(w`shiftR`24)byte4w=fromIntegral(w`shiftR`32)byte5w=fromIntegral(w`shiftR`40)byte6w=fromIntegral(w`shiftR`48)byte7w=fromIntegral(w`shiftR`56)--------------------------------------------------------------------------------- Info table offsets-------------------------------------------------------------------------------stdInfoTableSizeW::WordOff-- The size of a standard info table varies with profiling/ticky etc,-- so we can't get it from Constants-- It must vary in sync with mkStdInfoTablestdInfoTableSizeW=size_fixed+size_profwheresize_fixed=2-- layout, typesize_prof|opt_SccProfilingOn=2|otherwise=0stdInfoTableSizeB::ByteOffstdInfoTableSizeB=stdInfoTableSizeW*wORD_SIZEstdSrtBitmapOffset::ByteOff-- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_litstdSrtBitmapOffset=stdInfoTableSizeB-hALF_WORD_SIZEstdClosureTypeOffset::ByteOff-- Byte offset of the closure type half-word stdClosureTypeOffset=stdInfoTableSizeB-wORD_SIZEstdPtrsOffset,stdNonPtrsOffset::ByteOffstdPtrsOffset=stdInfoTableSizeB-2*wORD_SIZEstdNonPtrsOffset=stdInfoTableSizeB-2*wORD_SIZE+hALF_WORD_SIZE-------------------------------------------------- * This section is taken from Linker.lhs-- %-- % (c) The University of Glasgow 2005-2006-- %-- | Given a data constructor in the heap, find its Name.-- The info tables for data constructors have a field which records-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded-- string). The format is:---- Package:Module.Name---- We use this string to lookup the interpreter's internal representation of the name-- using the lookupOrig.b2s::[Word8]->Stringb2s=fmap(chr.fromIntegral)dataConInfoPtrToNames::Ptr()->IO(String,String,String)dataConInfoPtrToNamesx=doletptr=castPtrx::PtrStgInfoTableconDescAddress<-getConDescAddressptrtheString<-peekArray00conDescAddresslet(pkg,mod,occ)=parsetheStringreturn(b2spkg,b2smod,b2socc){- To find the string in the constructor's info table we need to consider
the layout of info tables relative to the entry code for a closure.
An info table can be next to the entry code for the closure, or it can
be separate. The former (faster) is used in registerised versions of ghc,
and the latter (portable) is for non-registerised versions.
The diagrams below show where the string is to be found relative to
the normal info table of the closure.
1) Code next to table:
--------------
| | <- pointer to the start of the string
--------------
| | <- the (start of the) info table structure
| |
| |
--------------
| entry code |
| .... |
In this case the pointer to the start of the string can be found in
the memory location _one word before_ the first entry in the normal info
table.
2) Code NOT next to table:
--------------
info table structure -> | *------------------> --------------
| | | entry code |
| | | .... |
--------------
ptr to start of str -> | |
--------------
In this case the pointer to the start of the string can be found
in the memory location: info_table_ptr + info_table_size
-}getConDescAddress::PtrStgInfoTable->IO(PtrWord8)getConDescAddressptr|ghciTablesNextToCode=dooffsetToString<-peek(ptr`plusPtr`(negatewORD_SIZE))return$(ptr`plusPtr`stdInfoTableSizeB)`plusPtr`(fromIntegral(offsetToString::StgWord))|otherwise=peek.intPtrToPtr.(+fromIntegralstdInfoTableSizeB).ptrToIntPtr$ptr-- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").-- Thus we split at the leftmost colon and the rightmost occurrence of the dot.-- It would be easier if the string was in the form pkg:A.B.C:foo, but alas-- this is not the conventional way of writing Haskell names. We stick with-- convention, even though it makes the parsing code more troublesome.-- Warning: this code assumes that the string is well formed. XXXXXXXXXXXXXXXXXXXparse::[Word8]->([Word8],[Word8],[Word8])parseinput=ifnot.all(>0).fmaplength$[pkg,mod,occ]then(error.concat)["getConDescAddress:parse:","(not . all (>0) . fmap le","ngth $ [pkg,mod,occ]"]else(pkg,mod,occ)-- = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) -- XXXXXXXXXXXXXXXXwhere(pkg,rest1)=break(==fromIntegral(ord':'))input(mod,occ)=(concat$intersperse[dot]$reversemodWords,occWord)where(modWords,occWord)=if(lengthrest1<1)-- XXXXXXXXx YUKXthenerror"getConDescAddress:parse:length rest1 < 1"elseparseModOcc[](tailrest1)-- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))dot=fromIntegral(ord'.')parseModOcc::[[Word8]]->[Word8]->([[Word8]],[Word8])parseModOccaccstr=casebreak(==dot)strof(top,[])->(acc,top)(top,_:bot)->parseModOcc(top:acc)bot------------------------------------------------