{-# LANGUAGE BangPatterns #-}{-# LANGUAGE CPP #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE MagicHash #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE UnboxedTuples #-}{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}---- (c) The University of Glasgow 2002-2006---- | ByteCodeLink: Bytecode assembler and linkermoduleByteCodeLink(ClosureEnv ,emptyClosureEnv ,extendClosureEnv ,linkBCO ,lookupStaticPtr ,lookupIE ,nameToCLabel ,linkFail )where#include "HsVersions.h"
importGhcPrelude importGHCi.RemoteTypes importGHCi.ResolvedBCO importGHCi.BreakArray importSizedSeq importGHCi importByteCodeTypes importHscTypes importName importNameEnv importPrimOp importModule importFastString importPanic importOutputable importUtil -- Standard librariesimportData.Array.UnboxedimportForeign.PtrimportGHC.Exts{-
 Linking interpretables into something we can run
-}typeClosureEnv =NameEnv (Name ,ForeignHValue )emptyClosureEnv::ClosureEnv emptyClosureEnv =emptyNameEnv extendClosureEnv::ClosureEnv ->[(Name ,ForeignHValue )]->ClosureEnv extendClosureEnv cl_env pairs =extendNameEnvList cl_env [(n ,(n ,v ))|(n ,v )<-pairs ]{-
 Linking interpretables into something we can run
-}linkBCO::HscEnv ->ItblEnv ->ClosureEnv ->NameEnv Int->RemoteRef BreakArray ->UnlinkedBCO ->IOResolvedBCO linkBCO hsc_env ie ce bco_ix breakarray (UnlinkedBCO _arity insns bitmap lits0 ptrs0 )=do-- fromIntegral Word -> Word64 should be a no op if Word is Word64-- otherwise it will result in a cast to longlong on 32bit systems.lits <-mapM(fmapfromIntegral.lookupLiteral hsc_env ie )(ssElts lits0 )ptrs <-mapM(resolvePtr hsc_env ie ce bco_ix breakarray )(ssElts ptrs0 )return(ResolvedBCO isLittleEndian arity insns bitmap (listArray(0,fromIntegral(sizeSS lits0 )-1)lits )(addListToSS emptySS ptrs ))lookupLiteral::HscEnv ->ItblEnv ->BCONPtr ->IOWordlookupLiteral __(BCONPtrWord lit )=returnlit lookupLiteralhsc_env _(BCONPtrLbl sym )=doPtra# <-lookupStaticPtr hsc_env sym return(W#(int2Word#(addr2Int#a# )))lookupLiteralhsc_env ie (BCONPtrItbl nm )=doPtra# <-lookupIE hsc_env ie nm return(W#(int2Word#(addr2Int#a# )))lookupLiteral__(BCONPtrStr _)=-- should be eliminated during assembleBCOspanic "lookupLiteral: BCONPtrStr"lookupStaticPtr::HscEnv ->FastString ->IO(Ptr())lookupStaticPtr hsc_env addr_of_label_string =dom <-lookupSymbol hsc_env addr_of_label_string casem ofJustptr ->returnptr Nothing->linkFail "ByteCodeLink: can't find label"(unpackFS addr_of_label_string )lookupIE::HscEnv ->ItblEnv ->Name ->IO(Ptr())lookupIE hsc_env ie con_nm =caselookupNameEnv ie con_nm ofJust(_,ItblPtr a )->return(fromRemotePtr (castRemotePtr a ))Nothing->do-- try looking up in the object files.letsym_to_find1 =nameToCLabel con_nm "con_info"m <-lookupSymbol hsc_env sym_to_find1 casem ofJustaddr ->returnaddr Nothing->do-- perhaps a nullary constructor?letsym_to_find2 =nameToCLabel con_nm "static_info"n <-lookupSymbol hsc_env sym_to_find2 casen ofJustaddr ->returnaddr Nothing->linkFail "ByteCodeLink.lookupIE"(unpackFS sym_to_find1 ++" or "++unpackFS sym_to_find2 )lookupPrimOp::HscEnv ->PrimOp ->IO(RemotePtr ())lookupPrimOp hsc_env primop =doletsym_to_find =primopToCLabel primop "closure"m <-lookupSymbol hsc_env (mkFastString sym_to_find )casem ofJustp ->return(toRemotePtr p )Nothing->linkFail "ByteCodeLink.lookupCE(primop)"sym_to_find resolvePtr::HscEnv ->ItblEnv ->ClosureEnv ->NameEnv Int->RemoteRef BreakArray ->BCOPtr ->IOResolvedBCOPtr resolvePtr hsc_env _ie ce bco_ix _(BCOPtrName nm )|Justix <-lookupNameEnv bco_ix nm =return(ResolvedBCORef ix )-- ref to another BCO in this group|Just(_,rhv )<-lookupNameEnv ce nm =return(ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv ))|otherwise=ASSERT2(isExternalNamenm ,ppr nm )doletsym_to_find =nameToCLabel nm "closure"m <-lookupSymbol hsc_env sym_to_find casem ofJustp ->return(ResolvedBCOStaticPtr (toRemotePtr p ))Nothing->linkFail "ByteCodeLink.lookupCE"(unpackFS sym_to_find )resolvePtrhsc_env ____(BCOPtrPrimOp op )=ResolvedBCOStaticPtr <$>lookupPrimOp hsc_env op resolvePtrhsc_env ie ce bco_ix breakarray (BCOPtrBCO bco )=ResolvedBCOPtrBCO <$>linkBCO hsc_env ie ce bco_ix breakarray bco resolvePtr____breakarray BCOPtrBreakArray =return(ResolvedBCOPtrBreakArray breakarray )linkFail::String->String->IOa linkFail who what =throwGhcExceptionIO (ProgramError $unlines["",who ,"During interactive linking, GHCi couldn't find the following symbol:",' ':' ':what ,"This may be due to you not asking GHCi to load extra object files,","archives or DLLs needed by your current session. Restart GHCi, specifying","the missing library using the -L/path/to/object/dir and -lmissinglibname","flags, or simply by naming the relevant files on the GHCi command line.","Alternatively, this link failure might indicate a bug in GHCi.","If you suspect the latter, please send a bug report to:"," glasgow-haskell-bugs@haskell.org"])nameToCLabel::Name ->String->FastString nameToCLabel n suffix =mkFastString labelwhereencodeZ =zString .zEncodeFS (Module pkgKey modName )=ASSERT(isExternalNamen )nameModulenpackagePart =encodeZ (unitIdFS pkgKey )modulePart =encodeZ (moduleNameFS modName )occPart =encodeZ (occNameFS(nameOccName n ))label=concat[ifpkgKey ==mainUnitId then""elsepackagePart ++"_",modulePart ,'_':occPart ,'_':suffix ]primopToCLabel::PrimOp ->String->StringprimopToCLabel primop suffix =concat["ghczmprim_GHCziPrimopWrappers_",zString (zEncodeFS (occNameFS(primOpOcc primop ))),'_':suffix ]