From: wolfgang Date: Tue, 11 Feb 2003 11:53:52 +0000 (+0000) Subject: [project @ 2003-02-11 11:53:51 by wolfgang] X-Git-Tag: Approx_11550_changesets_converted~1182 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5819de0c5d78effa16e4c59987268eadb96b8d1d [project @ 2003-02-11 11:53:51 by wolfgang] Mac OS X: Add support for dynamic linker "symbol stubs". For every function that might be imported from a dynamic library, we have to generate a short piece of assembly code. Extend the NatM monad to keep track of the list of imports (for which stubs will be generated later). Fix a bug concerning 64 bit ints (hi and low words were swapped in one place). --- diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index b1e0d47..92a8bc2 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -25,11 +25,16 @@ import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..), liftStrings, initNat, mkNatM_State, - uniqOfNatM_State, deltaOfNatM_State ) + uniqOfNatM_State, deltaOfNatM_State, + importsOfNatM_State ) import UniqSupply ( returnUs, thenUs, initUs, UniqSM, UniqSupply, lazyMapUs ) import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) +#if darwin_TARGET_OS +import PprMach ( pprDyldSymbolStub ) +import List ( group, sort ) +#endif import qualified Pretty import Outputable @@ -92,13 +97,22 @@ So, here we go: nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, Pretty.Doc) nativeCodeGen absC us = let absCstmts = mkAbsCStmtList absC - (sdoc_pairs, us1) = initUs us (lazyMapUs absCtoNat absCstmts) - stix_sdocs = map fst sdoc_pairs - insn_sdocs = map snd sdoc_pairs + (results, us1) = initUs us (lazyMapUs absCtoNat absCstmts) + stix_sdocs = [ stix | (stix, insn, imports) <- results ] + insn_sdocs = [ insn | (stix, insn, imports) <- results ] + imports = [ imports | (stix, insn, imports) <- results ] - insn_sdoc = my_vcat insn_sdocs + insn_sdoc = my_vcat insn_sdocs IF_OS_darwin(Pretty.$$ dyld_stubs,) stix_sdoc = vcat stix_sdocs +#if darwin_TARGET_OS + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + + dyld_stubs = Pretty.vcat $ map pprDyldSymbolStub $ + map head $ group $ sort $ concat imports +#endif + # ifdef NCG_DEBUG my_trace m x = trace m x my_vcat sds = Pretty.vcat ( @@ -118,18 +132,18 @@ nativeCodeGen absC us (stix_sdoc, insn_sdoc) -absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc) +absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc, [FastString]) absCtoNat absC = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted -> - _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ pre_regalloc -> + _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ (pre_regalloc, imports) -> _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> _scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc -> returnUs ({-\_ -> Pretty.vcat (map pprInstr almost_final),-} - stix_sdoc, final_sdoc) + stix_sdoc, final_sdoc, imports) where bind f x = x f @@ -157,16 +171,17 @@ Switching between the two monads whilst carrying along the same Unique supply breaks abstraction. Is that bad? \begin{code} -genMachCode :: [StixStmt] -> UniqSM InstrBlock +genMachCode :: [StixStmt] -> UniqSM (InstrBlock, [FastString]) genMachCode stmts initial_us = let initial_st = mkNatM_State initial_us 0 (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts) final_us = uniqOfNatM_State final_st final_delta = deltaOfNatM_State final_st + final_imports = importsOfNatM_State final_st in if final_delta == 0 - then (instr_list, final_us) + then ((instr_list, final_imports), final_us) else pprPanic "genMachCode: nonzero final delta" (int final_delta) \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index ffb603e..e9fbdf4 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -41,6 +41,7 @@ import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat, getUniqueNat, + IF_OS_darwin(addImportNat COMMA,) ncgPrimopMoan, ncg_target_is_32bit ) @@ -512,8 +513,8 @@ iselExpr64 (StCall fn cconv kind args) = genCCall fn cconv kind args `thenNat` \ call -> getNewRegNCG IntRep `thenNat` \ r_dst_lo -> let r_dst_hi = getHiVRegFromLo r_dst_lo - mov_lo = MR r_dst_lo r3 - mov_hi = MR r_dst_hi r4 + mov_lo = MR r_dst_lo r4 + mov_hi = MR r_dst_hi r3 in returnNat ( ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) @@ -3491,8 +3492,14 @@ genCCall fn cconv kind args `appOL` moveFinalCode in case fn of - Left lbl -> returnNat ( passArguments - `snocOL` BL (ImmLab False (ftext lbl)) usedRegs + Left lbl -> + addImportNat lbl `thenNat` \ _ -> + returnNat (passArguments + `snocOL` BL (ImmLit $ ftext + (FSLIT("L_") + `appendFS` lbl + `appendFS` FSLIT("$stub"))) + usedRegs `appOL` move_sp_up) Right dyn -> getRegister dyn `thenNat` \ dynReg -> diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 1265384..3bab396 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -10,7 +10,7 @@ We start with the @pprXXX@s with some cross-platform commonality \begin{code} #include "nativeGen/NCG.h" -module PprMach ( pprInstr, pprSize, pprUserReg ) where +module PprMach ( pprInstr, pprSize, pprUserReg IF_OS_darwin(COMMA pprDyldSymbolStub, ) ) where #include "HsVersions.h" @@ -2037,6 +2037,34 @@ pprRI (RIImm r) = pprImm r pprFSize DF = empty pprFSize F = char 's' +{- + The Mach-O object file format used in Darwin/Mac OS X needs a so-called + "symbol stub" for every function that might be imported from a dynamic + library. + The stubs are always the same, and they are all output at the end of the + generated assembly (see AsmCodeGen.lhs), so we don't use the Instr datatype. + Instead, we just pretty-print it directly. +-} + +#if darwin_TARGET_OS +pprDyldSymbolStub fn = + vcat [ + ptext SLIT(".symbol_stub"), + ptext SLIT("L_") <> ftext fn <> ptext SLIT("$stub:"), + ptext SLIT("\t.indirect_symbol _") <> ftext fn, + ptext SLIT("\tlis r11,ha16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"), + ptext SLIT("\tlwz r12,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)(r11)"), + ptext SLIT("\tmtctr r12"), + ptext SLIT("\taddi r11,r11,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"), + ptext SLIT("\tbctr"), + ptext SLIT(".lazy_symbol_pointer"), + ptext SLIT("L_") <> ftext fn <> ptext SLIT("$lazy_ptr:"), + ptext SLIT("\t.indirect_symbol _") <> ftext fn, + ptext SLIT("\t.long dyld_stub_binding_helper") + ] +#endif + + #endif {-powerpc_TARGET_ARCH-} \end{code} diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 60ed674..9f4a5ea 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -21,7 +21,8 @@ module Stix ( mapNat, mapAndUnzipNat, mapAccumLNat, getUniqueNat, getDeltaNat, setDeltaNat, NatM_State, mkNatM_State, - uniqOfNatM_State, deltaOfNatM_State, + uniqOfNatM_State, deltaOfNatM_State, importsOfNatM_State, + addImportNat, getUniqLabelNCG, getNatLabelNCG, ncgPrimopMoan, @@ -527,16 +528,20 @@ liftStrings_wrk [] acc_stix acc_strs The NCG's monad. +The monad keeps a UniqSupply, the current stack delta and +a list of imported entities, which is only used for +Darwin (Mac OS X). + \begin{code} -data NatM_State = NatM_State UniqSupply Int +data NatM_State = NatM_State UniqSupply Int [FastString] type NatM result = NatM_State -> (result, NatM_State) mkNatM_State :: UniqSupply -> Int -> NatM_State -mkNatM_State = NatM_State - -uniqOfNatM_State (NatM_State us delta) = us -deltaOfNatM_State (NatM_State us delta) = delta +mkNatM_State us delta = NatM_State us delta [] +uniqOfNatM_State (NatM_State us delta imports) = us +deltaOfNatM_State (NatM_State us delta imports) = delta +importsOfNatM_State (NatM_State us delta imports) = imports initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case m init_st of { (r,st) -> (r,st) } @@ -576,17 +581,21 @@ mapAccumLNat f b (x:xs) getUniqueNat :: NatM Unique -getUniqueNat (NatM_State us delta) +getUniqueNat (NatM_State us delta imports) = case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta)) + (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports)) getDeltaNat :: NatM Int -getDeltaNat st@(NatM_State us delta) +getDeltaNat st@(NatM_State us delta imports) = (delta, st) setDeltaNat :: Int -> NatM () -setDeltaNat delta (NatM_State us _) - = ((), NatM_State us delta) +setDeltaNat delta (NatM_State us _ imports) + = ((), NatM_State us delta imports) + +addImportNat :: FastString -> NatM () +addImportNat imp (NatM_State us delta imports) + = ((), NatM_State us delta (imp:imports)) \end{code} Giving up in a not-too-inelegant way.