[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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.