{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}---- (c) The University of Glasgow 2002-2006---- | ByteCodeLink: Bytecode assembler and linkermoduleByteCodeAsm(assembleBCOs ,assembleOneBCO ,bcoFreeNames ,SizedSeq ,sizeSS ,ssElts ,iNTERP_STACK_CHECK_THRESH )where#include "HsVersions.h"
importGhcPrelude importByteCodeInstr importByteCodeItbls importByteCodeTypes importGHCi.RemoteTypes importGHCi importHscTypes importName importNameSet importLiteral importTyCon importFastString importStgCmmLayout (ArgRep (..))importSMRep importDynFlags importOutputable importPlatform importUtil importUnique importUniqDSet -- From iservimportSizedSeq importControl.MonadimportControl.Monad.ST(runST)importControl.Monad.Trans.ClassimportControl.Monad.Trans.State.StrictimportData.Array.MArrayimportqualifiedData.Array.UnboxedasArrayimportData.Array.Base(UArray(..))importData.Array.Unsafe(castSTUArray)importForeignimportData.Char(ord)importData.ListimportData.Map(Map)importData.Maybe(fromMaybe)importqualifiedData.MapasMap-- ------------------------------------------------------------------------------- Unlinked BCOs-- CompiledByteCode represents the result of byte-code-- compiling a bunch of functions and data types-- | Finds external references. Remember to remove the names-- defined by this group of BCOs themselvesbcoFreeNames::UnlinkedBCO ->UniqDSet Name bcoFreeNames bco =bco_refs bco `uniqDSetMinusUniqSet `mkNameSet [unlinkedBCONamebco ]wherebco_refs (UnlinkedBCO ____nonptrs ptrs )=unionManyUniqDSets (mkUniqDSet [n |BCOPtrName n <-ssElts ptrs ]:mkUniqDSet [n |BCONPtrItbl n <-ssElts nonptrs ]:mapbco_refs [bco |BCOPtrBCO bco <-ssElts ptrs ])-- ------------------------------------------------------------------------------- The bytecode assembler-- The object format for bytecodes is: 16 bits for the opcode, and 16-- for each field -- so the code can be considered a sequence of-- 16-bit ints. Each field denotes either a stack offset or number of-- items on the stack (eg SLIDE), and index into the pointer table (eg-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a-- bytecode address in this BCO.-- Top level assembler fn.assembleBCOs::HscEnv ->[ProtoBCO Name ]->[TyCon ]->[RemotePtr ()]->MaybeModBreaks ->IOCompiledByteCode assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks =doitblenv <-mkITbls hsc_env tycons bcos <-mapM(assembleBCO (hsc_dflagshsc_env ))proto_bcos (bcos' ,ptrs )<-mallocStrings hsc_env bcos returnCompiledByteCode {bc_bcos=bcos' ,bc_itbls=itblenv ,bc_ffis=concat(mapprotoBCOFFIsproto_bcos ),bc_strs=top_strs ++ptrs ,bc_breaks=modbreaks }-- Find all the literal strings and malloc them together. We want to-- do this because:---- a) It should be done when we compile the module, not each time we relink it-- b) For -fexternal-interpreter It's more efficient to malloc the strings-- as a single batch message, especially when compiling in parallel.--mallocStrings::HscEnv ->[UnlinkedBCO ]->IO([UnlinkedBCO ],[RemotePtr ()])mallocStrings hsc_env ulbcos =doletbytestrings =reverse(execState(mapM_collect ulbcos )[])ptrs <-iservCmd hsc_env (MallocStrings bytestrings )return(evalState(mapMsplice ulbcos )ptrs ,ptrs )wheresplice bco @UnlinkedBCO {..}=dolits <-mapMspliceLit unlinkedBCOLits ptrs <-mapMsplicePtr unlinkedBCOPtrs returnbco {unlinkedBCOLits=lits ,unlinkedBCOPtrs=ptrs }spliceLit (BCONPtrStr _)=dorptrs <-getcaserptrs of(RemotePtr p :rest )->doputrest return(BCONPtrWord (fromIntegralp ))_->panic "mallocStrings:spliceLit"spliceLitother =returnother splicePtr (BCOPtrBCO bco )=BCOPtrBCO <$>splice bco splicePtrother =returnother collect UnlinkedBCO {..}=domapM_collectLit unlinkedBCOLits mapM_collectPtr unlinkedBCOPtrs collectLit (BCONPtrStr bs )=dostrs <-getput(bs :strs )collectLit_=return()collectPtr (BCOPtrBCO bco )=collect bco collectPtr_=return()assembleOneBCO::HscEnv ->ProtoBCO Name ->IOUnlinkedBCO assembleOneBCO hsc_env pbco =doubco <-assembleBCO (hsc_dflagshsc_env )pbco ([ubco' ],_ptrs )<-mallocStrings hsc_env [ubco ]returnubco' assembleBCO::DynFlags ->ProtoBCO Name ->IOUnlinkedBCO assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced )=do-- pass 1: collect up the offsets of the local labels.letasm =mapM_(assembleI dflags )instrs initial_offset =0-- Jump instructions are variable-sized, there are long and short variants-- depending on the magnitude of the offset. However, we can't tell what-- size instructions we will need until we have calculated the offsets of-- the labels, which depends on the size of the instructions... So we-- first create the label environment assuming that all jumps are short,-- and if the final size is indeed small enough for short jumps, we are-- done. Otherwise, we repeat the calculation, and we force all jumps in-- this BCO to be long.(n_insns0 ,lbl_map0 )=inspectAsm dflags Falseinitial_offset asm ((n_insns ,lbl_map ),long_jumps )|isLarge n_insns0 =(inspectAsm dflags Trueinitial_offset asm ,True)|otherwise=((n_insns0 ,lbl_map0 ),False)env::Word16->Wordenv lbl =fromMaybe(pprPanic "assembleBCO.findLabel"(ppr lbl ))(Map.lookuplbl lbl_map )-- pass 2: run assembler and generate instructions, literals and pointersletinitial_state =(emptySS ,emptySS ,emptySS )(final_insns ,final_lits ,final_ptrs )<-flipexecStateTinitial_state $runAsm dflags long_jumps env asm -- precomputed size should be equal to final sizeASSERT(n_insns==sizeSSfinal_insns)return()letasm_insns =ssElts final_insns insns_arr =Array.listArray(0,fromIntegraln_insns -1)asm_insns bitmap_arr =mkBitmapArray bsize bitmap ul_bco =UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive-- objects, since they might get run too early. Disable this until-- we figure out what to do.-- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))returnul_bco mkBitmapArray::Word16->[StgWord ]->UArrayIntWord64-- Here the return type must be an array of Words, not StgWords,-- because the underlying ByteArray# will end up as a component-- of a BCO object.mkBitmapArray bsize bitmap =Array.listArray(0,lengthbitmap )$fromIntegralbsize :map(fromInteger.fromStgWord )bitmap -- instrs nonptrs ptrstypeAsmState =(SizedSeq Word16,SizedSeq BCONPtr ,SizedSeq BCOPtr )dataOperand =Op Word|SmallOp Word16|LabelOp Word16-- (unused) | LargeOp WorddataAssembler a =AllocPtr (IOBCOPtr )(Word->Assembler a )|AllocLit [BCONPtr ](Word->Assembler a )|AllocLabel Word16(Assembler a )|Emit Word16[Operand ](Assembler a )|NullAsm a instanceFunctorAssembler wherefmap =liftMinstanceApplicativeAssembler wherepure =NullAsm (<*> )=apinstanceMonadAssembler whereNullAsm x >>= f =f x AllocPtr p k >>=f =AllocPtr p (k >=>f )AllocLit l k >>=f =AllocLit l (k >=>f )AllocLabel lbl k >>=f =AllocLabel lbl (k >>=f )Emit w ops k >>=f =Emit w ops (k >>=f )ioptr::IOBCOPtr ->Assembler Wordioptr p =AllocPtr p returnptr::BCOPtr ->Assembler Wordptr =ioptr .returnlit::[BCONPtr ]->Assembler Wordlit l =AllocLit l returnlabel::Word16->Assembler ()labelw =AllocLabel w (return())emit::Word16->[Operand ]->Assembler ()emit w ops =Emit w ops (return())typeLabelEnv =Word16->WordlargeOp::Bool->Operand ->BoollargeOp long_jumps op =caseop ofSmallOp _->FalseOp w ->isLarge w LabelOp _->long_jumps -- LargeOp _ -> TruerunAsm::DynFlags ->Bool->LabelEnv ->Assembler a ->StateTAsmState IOa runAsm dflags long_jumps e =go wherego (NullAsm x )=returnx go(AllocPtr p_io k )=dop <-liftp_io w <-state$\(st_i0 ,st_l0 ,st_p0 )->letst_p1 =addToSS st_p0 p in(sizeSS st_p0 ,(st_i0 ,st_l0 ,st_p1 ))go $k w go(AllocLit lits k )=dow <-state$\(st_i0 ,st_l0 ,st_p0 )->letst_l1 =addListToSS st_l0 lits in(sizeSS st_l0 ,(st_i0 ,st_l1 ,st_p0 ))go $k w go(AllocLabel _k )=go k go(Emit w ops k )=doletlargeOps =any(largeOp long_jumps )ops opcode |largeOps =largeArgInstr w |otherwise=w words =concatMapexpand ops expand (SmallOp w )=[w ]expand(LabelOp w )=expand (Op (e w ))expand(Op w )=iflargeOps thenlargeArg dflags w else[fromIntegralw ]-- expand (LargeOp w) = largeArg dflags wstate$\(st_i0 ,st_l0 ,st_p0 )->letst_i1 =addListToSS st_i0 (opcode :words )in((),(st_i1 ,st_l0 ,st_p0 ))go k typeLabelEnvMap =MapWord16WorddataInspectState =InspectState {instrCount ::!Word,ptrCount ::!Word,litCount ::!Word,lblEnv ::LabelEnvMap }inspectAsm::DynFlags ->Bool->Word->Assembler a ->(Word,LabelEnvMap )inspectAsm dflags long_jumps initial_offset =go (InspectState initial_offset 00Map.empty)wherego s (NullAsm _)=(instrCounts ,lblEnvs )gos (AllocPtr _k )=go (s {ptrCount=n +1})(k n )wheren =ptrCounts gos (AllocLit ls k )=go (s {litCount=n +genericLengthls })(k n )wheren =litCounts gos (AllocLabel lbl k )=go s' k wheres' =s {lblEnv=Map.insertlbl (instrCounts )(lblEnvs )}gos (Emit _ops k )=go s' k wheres' =s {instrCount=instrCounts +size }size =sum(mapcount ops )+1largeOps =any(largeOp long_jumps )ops count (SmallOp _)=1count(LabelOp _)=count (Op 0)count(Op _)=iflargeOps thenlargeArg16s dflags else1-- count (LargeOp _) = largeArg16s dflags-- Bring in all the bci_ bytecode constants.#include "rts/Bytecodes.h"
largeArgInstr::Word16->Word16largeArgInstr bci =bci_FLAG_LARGE_ARGS.|.bcilargeArg::DynFlags ->Word->[Word16]largeArg dflags w |wORD_SIZE_IN_BITS dflags ==64=[fromIntegral(w `shiftR`48),fromIntegral(w `shiftR`32),fromIntegral(w `shiftR`16),fromIntegralw ]|wORD_SIZE_IN_BITS dflags ==32=[fromIntegral(w `shiftR`16),fromIntegralw ]|otherwise=error"wORD_SIZE_IN_BITS not 32 or 64?"largeArg16s::DynFlags ->WordlargeArg16s dflags |wORD_SIZE_IN_BITS dflags ==64=4|otherwise=2assembleI::DynFlags ->BCInstr ->Assembler ()assembleI dflags i =casei ofSTKCHECK n ->emit bci_STKCHECK[Opn]PUSH_L o1 ->emit bci_PUSH_L[SmallOpo1]PUSH_LL o1 o2 ->emit bci_PUSH_LL[SmallOpo1,SmallOpo2]PUSH_LLL o1 o2 o3 ->emit bci_PUSH_LLL[SmallOpo1,SmallOpo2,SmallOpo3]PUSH8 o1 ->emit bci_PUSH8[SmallOpo1]PUSH16 o1 ->emit bci_PUSH16[SmallOpo1]PUSH32 o1 ->emit bci_PUSH32[SmallOpo1]PUSH8_W o1 ->emit bci_PUSH8_W[SmallOpo1]PUSH16_W o1 ->emit bci_PUSH16_W[SmallOpo1]PUSH32_W o1 ->emit bci_PUSH32_W[SmallOpo1]PUSH_G nm ->dop <-ptr (BCOPtrName nm )emit bci_PUSH_G[Opp]PUSH_PRIMOP op ->dop <-ptr (BCOPtrPrimOp op )emit bci_PUSH_G[Opp]PUSH_BCO proto ->doletul_bco =assembleBCO dflags proto p <-ioptr (liftMBCOPtrBCO ul_bco )emit bci_PUSH_G[Opp]PUSH_ALTS proto ->doletul_bco =assembleBCO dflags proto p <-ioptr (liftMBCOPtrBCO ul_bco )emit bci_PUSH_ALTS[Opp]PUSH_ALTS_UNLIFTED proto pk ->doletul_bco =assembleBCO dflags proto p <-ioptr (liftMBCOPtrBCO ul_bco )emit (push_alts pk )[Op p ]PUSH_PAD8 ->emit bci_PUSH_PAD8[]PUSH_PAD16 ->emit bci_PUSH_PAD16[]PUSH_PAD32 ->emit bci_PUSH_PAD32[]PUSH_UBX8 lit ->donp <-literal lit emit bci_PUSH_UBX8[Opnp]PUSH_UBX16 lit ->donp <-literal lit emit bci_PUSH_UBX16[Opnp]PUSH_UBX32 lit ->donp <-literal lit emit bci_PUSH_UBX32[Opnp]PUSH_UBX lit nws ->donp <-literal lit emit bci_PUSH_UBX[Op np,SmallOpnws]PUSH_APPLY_N ->emit bci_PUSH_APPLY_N[]PUSH_APPLY_V ->emit bci_PUSH_APPLY_V[]PUSH_APPLY_F ->emit bci_PUSH_APPLY_F[]PUSH_APPLY_D ->emit bci_PUSH_APPLY_D[]PUSH_APPLY_L ->emit bci_PUSH_APPLY_L[]PUSH_APPLY_P ->emit bci_PUSH_APPLY_P[]PUSH_APPLY_PP ->emit bci_PUSH_APPLY_PP[]PUSH_APPLY_PPP ->emit bci_PUSH_APPLY_PPP[]PUSH_APPLY_PPPP ->emit bci_PUSH_APPLY_PPPP[]PUSH_APPLY_PPPPP ->emit bci_PUSH_APPLY_PPPPP[]PUSH_APPLY_PPPPPP ->emit bci_PUSH_APPLY_PPPPPP[]SLIDE n by ->emit bci_SLIDE[SmallOpn ,SmallOpby]ALLOC_AP n ->emit bci_ALLOC_AP[SmallOpn]ALLOC_AP_NOUPD n ->emit bci_ALLOC_AP_NOUPD[SmallOpn]ALLOC_PAP arity n ->emit bci_ALLOC_PAP[SmallOparity,SmallOpn]MKAP off sz ->emit bci_MKAP[SmallOpoff ,SmallOpsz]MKPAP off sz ->emit bci_MKPAP[SmallOpoff ,SmallOpsz]UNPACK n ->emit bci_UNPACK[SmallOpn]PACK dcon sz ->doitbl_no <-lit [BCONPtrItbl (getName dcon )]emit bci_PACK[Op itbl_no,SmallOpsz]LABEL lbl ->labellbl TESTLT_I i l ->donp <-int i emit bci_TESTLT_I[Op np,LabelOpl]TESTEQ_I i l ->donp <-int i emit bci_TESTEQ_I[Op np,LabelOpl]TESTLT_W w l ->donp <-word w emit bci_TESTLT_W[Op np,LabelOpl]TESTEQ_W w l ->donp <-word w emit bci_TESTEQ_W[Op np,LabelOpl]TESTLT_F f l ->donp <-float f emit bci_TESTLT_F[Op np,LabelOpl]TESTEQ_F f l ->donp <-float f emit bci_TESTEQ_F[Op np,LabelOpl]TESTLT_D d l ->donp <-double d emit bci_TESTLT_D[Op np,LabelOpl]TESTEQ_D d l ->donp <-double d emit bci_TESTEQ_D[Op np,LabelOpl]TESTLT_P i l ->emit bci_TESTLT_P[SmallOpi,LabelOpl]TESTEQ_P i l ->emit bci_TESTEQ_P[SmallOpi,LabelOpl]CASEFAIL ->emit bci_CASEFAIL[]SWIZZLE stkoff n ->emit bci_SWIZZLE[SmallOpstkoff ,SmallOpn]JMP l ->emit bci_JMP[LabelOpl]ENTER ->emit bci_ENTER[]RETURN ->emit bci_RETURN[]RETURN_UBX rep ->emit (return_ubx rep )[]CCALL off m_addr i ->donp <-addr m_addr emit bci_CCALL[SmallOpoff,Op np ,SmallOpi]BRK_FUN index uniq cc ->dop1 <-ptr BCOPtrBreakArray q <-int (getKey uniq )np <-addr cc emit bci_BRK_FUN[Op p1 ,SmallOpindex,Op q ,Op np ]whereliteral (LitLabel fs (Justsz )_)|platformOS(targetPlatform dflags )==OSMinGW32 =litlabel (appendFS fs (mkFastString ('@':showsz )))-- On Windows, stdcall labels have a suffix indicating the no. of-- arg words, e.g. foo@8. testcase: ffi012(ghci)literal(LitLabel fs __)=litlabel fs literalLitNullAddr =int 0literal(LitFloat r )=float (fromRationalr )literal(LitDouble r )=double (fromRationalr )literal(LitChar c )=int (ordc )literal(LitString bs )=lit [BCONPtrStr bs ]-- LitString requires a zero-terminator when emittedliteral(LitNumber nt i _)=casent ofLitNumInt ->int (fromIntegrali )LitNumWord ->int (fromIntegrali )LitNumInt64 ->int64 (fromIntegrali )LitNumWord64 ->int64 (fromIntegrali )LitNumInteger ->panic "ByteCodeAsm.literal: LitNumInteger"LitNumNatural ->panic "ByteCodeAsm.literal: LitNumNatural"-- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most-- likely to elicit a crash (rather than corrupt memory) in case absence-- analysis messed up.literalLitRubbish =int 0litlabel fs =lit [BCONPtrLbl fs ]addr (RemotePtr a )=words [fromIntegrala ]float =words .mkLitF double =words .mkLitD dflags int =words .mkLitI int64 =words .mkLitI64 dflags words ws =lit (mapBCONPtrWord ws )word w =words [w ]isLarge::Word->BoolisLarge n =n >65535push_alts::ArgRep ->Word16push_alts V =bci_PUSH_ALTS_Vpush_altsP =bci_PUSH_ALTS_Ppush_altsN =bci_PUSH_ALTS_Npush_altsL =bci_PUSH_ALTS_Lpush_altsF =bci_PUSH_ALTS_Fpush_altsD =bci_PUSH_ALTS_Dpush_altsV16 =error"push_alts: vector"push_altsV32 =error"push_alts: vector"push_altsV64 =error"push_alts: vector"return_ubx::ArgRep ->Word16return_ubx V =bci_RETURN_Vreturn_ubxP =bci_RETURN_Preturn_ubxN =bci_RETURN_Nreturn_ubxL =bci_RETURN_Lreturn_ubxF =bci_RETURN_Freturn_ubxD =bci_RETURN_Dreturn_ubxV16 =error"return_ubx: vector"return_ubxV32 =error"return_ubx: vector"return_ubxV64 =error"return_ubx: vector"-- Make lists of host-sized words for literals, so that when the-- words are placed in memory at increasing addresses, the-- bit pattern is correct for the host's word size and endianness.mkLitI::Int->[Word]mkLitF::Float->[Word]mkLitD::DynFlags ->Double->[Word]mkLitI64::DynFlags ->Int64->[Word]mkLitF f =runST(doarr <-newArray_((0::Int),0)writeArrayarr 0f f_arr <-castSTUArrayarr w0 <-readArrayf_arr 0return[w0 ::Word])mkLitD dflags d |wORD_SIZE dflags ==4=runST(doarr <-newArray_((0::Int),1)writeArrayarr 0d d_arr <-castSTUArrayarr w0 <-readArrayd_arr 0w1 <-readArrayd_arr 1return[w0 ::Word,w1 ])|wORD_SIZE dflags ==8=runST(doarr <-newArray_((0::Int),0)writeArrayarr 0d d_arr <-castSTUArrayarr w0 <-readArrayd_arr 0return[w0 ::Word])|otherwise=panic "mkLitD: Bad wORD_SIZE"mkLitI64 dflags ii |wORD_SIZE dflags ==4=runST(doarr <-newArray_((0::Int),1)writeArrayarr 0ii d_arr <-castSTUArrayarr w0 <-readArrayd_arr 0w1 <-readArrayd_arr 1return[w0 ::Word,w1 ])|wORD_SIZE dflags ==8=runST(doarr <-newArray_((0::Int),0)writeArrayarr 0ii d_arr <-castSTUArrayarr w0 <-readArrayd_arr 0return[w0 ::Word])|otherwise=panic "mkLitI64: Bad wORD_SIZE"mkLitI i =[fromIntegrali ::Word]iNTERP_STACK_CHECK_THRESH::IntiNTERP_STACK_CHECK_THRESH =INTERP_STACK_CHECK_THRESH