[project @ 2002-02-18 12:41:01 by sewardj]

Make foreign export dynamic work in GHCi.  Main changes:

* Allow literal labels to propagate through the bytecode generator
  and eventually be linked by the runtime linker.

* Minor mods to driver plumbing so that GHCi produces the relevant
  *_stub.[ch] files, compiles them with gcc, and loads the resulting .o's

* Dereference the stable pointer in the generated C stub, rather
  than passing it to a Haskell-world helper.  This seems simpler and
  removes the need to have a H-world helper, which in turn means the
  stub .o doesn't refer to any H-world entities.  This is important
  because our linker can't deal with mutual recursion between
  BCOs and loaded objects.

Still ToDo:

* Make it thread/GC safe.  (Sigbjorn?)

* Get rid of the bits of code in DsForeign which generate the
  Haskell helper.  I had a go but it wasn't obvious how to do it,
  so have deferred.

diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index c7ac67e..151099b 100644 (file)
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -262,7 +262,8 @@ link' Interactive dflags batch_attempt_linking linkables pls
 
            -- Always load objects first.  Objects aren't allowed to
            -- depend on BCOs.
-           let (objs, bcos) = partition isObjectLinkable linkables
+           let (objs, bcos) = partition isObjectLinkable 
+                                  (concatMap partitionLinkable linkables)
 
            objs_loaded  <- readIORef v_ObjectsLoaded
            objs_loaded' <- linkObjs objs objs_loaded

diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs
index 90123e0..fd3cbfc 100644 (file)
--- a/ghc/compiler/compMan/CmTypes.lhs
+++ b/ghc/compiler/compMan/CmTypes.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module CmTypes ( 
    Unlinked(..),  isObject, nameOfObject, isInterpretable,
-   Linkable(..), isObjectLinkable, 
+   Linkable(..), isObjectLinkable, partitionLinkable,
    ModSummary(..), ms_allimps, pprSummaryTime, modSummaryName,
   ) where
 
@@ -40,8 +40,7 @@ nameOfObject (DotO fn)   = fn
 nameOfObject (DotA fn)   = fn
 nameOfObject (DotDLL fn) = fn
 
-isInterpretable (BCOs _ _) = True
-isInterpretable _          = False
+isInterpretable = not . isObject
 
 data Linkable = LM {
   linkableTime     :: ClockTime,
@@ -52,6 +51,19 @@ data Linkable = LM {
 isObjectLinkable :: Linkable -> Bool
 isObjectLinkable l = all isObject (linkableUnlinked l)
 
+-- HACK to support f-x-dynamic in the interpreter; no other purpose
+partitionLinkable :: Linkable -> [Linkable]
+partitionLinkable li
+   = let li_uls = linkableUnlinked li
+         li_uls_obj = filter isObject li_uls
+         li_uls_bco = filter isInterpretable li_uls
+     in 
+         case (li_uls_obj, li_uls_bco) of
+            (objs@(_:_), bcos@(_:_)) 
+               -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
+            other
+               -> [li]
+
 instance Outputable Linkable where
    ppr (LM when_made mod unlinkeds)
       = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 9bb1d3a..8d83f56 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -470,15 +470,19 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
              parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
 
   c_bits =
-    externDecl $$
     fun_proto  $$
     vcat 
      [ lbrace
      ,   text "SchedulerStatus rc;"
      ,   declareResult
          -- create the application + perform it.
-     ,   text "rc=rts_evalIO" <> 
-                  parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi
+     ,   text "rc=rts_evalIO" 
+         <> parens (foldl appArg (text "(StgClosure*)deRefStablePtr(a0)") 
+                                 (tail (zip args c_args))
+                    <> comma 
+                    <> text "&ret"
+                   ) 
+         <> semi
      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm)
                                                <> comma <> text "rc") <> semi
      ,   text "return" <> return_what <> semi
@@ -501,8 +505,6 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
      
   declareResult  = text "HaskellObj ret;"
 
-  externDecl     = mkExtern (text "HaskellObj") h_nm
-
   mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
 
   return_what | res_ty_is_unit = empty

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index f6cf787..6d587bb 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -1092,7 +1092,8 @@ mkUnpackCode vars d p
         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
         do_nptrs off_h off_s [] = nilOL
         do_nptrs off_h off_s (npr:nprs)
-           | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep]
+           | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, 
+                         CharRep, AddrRep, StablePtrRep]
            = approved
            | otherwise
            = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr)
@@ -1173,6 +1174,7 @@ pushAtom True d p (AnnLit lit)
 
 pushAtom False d p (AnnLit lit)
    = case lit of
+        MachLabel fs -> code CodePtrRep
         MachWord w   -> code WordRep
         MachInt i    -> code IntRep
         MachFloat r  -> code FloatRep

diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 76b56d6..054da42 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -122,7 +122,10 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos
 data UnlinkedBCO
    = UnlinkedBCO Name
                  (SizedSeq Word16)              -- insns
-                 (SizedSeq Word)                -- literals
+                 (SizedSeq (Either Word FAST_STRING))   -- literals
+                       -- Either literal words or a pointer to a asciiz
+                       -- string, denoting a label whose *address* should
+                       -- be determined at link time
                  (SizedSeq (Either Name PrimOp)) -- ptrs
                  (SizedSeq Name)                -- itbl refs
 
@@ -191,7 +194,7 @@ assembleBCO (ProtoBCO nm instrs origin malloced)
      in
      do  -- pass 2: generate the instruction, ptr and nonptr bits
          insns <- return emptySS :: IO (SizedSeq Word16)
-         lits  <- return emptySS :: IO (SizedSeq Word)
+         lits  <- return emptySS :: IO (SizedSeq (Either Word FAST_STRING))
          ptrs  <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
          itbls <- return emptySS :: IO (SizedSeq Name)
          let init_asm_state = (insns,lits,ptrs,itbls)
@@ -211,8 +214,10 @@ assembleBCO (ProtoBCO nm instrs origin malloced)
                            free ptr
 
 -- instrs nonptrs ptrs itbls
-type AsmState = (SizedSeq Word16, SizedSeq Word, 
-                 SizedSeq (Either Name PrimOp), SizedSeq Name)
+type AsmState = (SizedSeq Word16, 
+                 SizedSeq (Either Word FAST_STRING),
+                 SizedSeq (Either Name PrimOp), 
+                 SizedSeq Name)
 
 data SizedSeq a = SizedSeq !Int [a]
 emptySS = SizedSeq 0 []
@@ -311,27 +316,31 @@ mkBits findLabel st proto_insns
 
        float (st_i0,st_l0,st_p0,st_I0) f
           = do let ws = mkLitF f
-               st_l1 <- addListToSS st_l0 ws
+               st_l1 <- addListToSS st_l0 (map Left ws)
                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 
        double (st_i0,st_l0,st_p0,st_I0) d
           = do let ws = mkLitD d
-               st_l1 <- addListToSS st_l0 ws
+               st_l1 <- addListToSS st_l0 (map Left ws)
                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 
        int (st_i0,st_l0,st_p0,st_I0) i
           = do let ws = mkLitI i
-               st_l1 <- addListToSS st_l0 ws
+               st_l1 <- addListToSS st_l0 (map Left ws)
                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 
        int64 (st_i0,st_l0,st_p0,st_I0) i
           = do let ws = mkLitI64 i
-               st_l1 <- addListToSS st_l0 ws
+               st_l1 <- addListToSS st_l0 (map Left ws)
                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 
        addr (st_i0,st_l0,st_p0,st_I0) a
           = do let ws = mkLitPtr a
-               st_l1 <- addListToSS st_l0 ws
+               st_l1 <- addListToSS st_l0 (map Left ws)
+               return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+       litlabel (st_i0,st_l0,st_p0,st_I0) fs
+          = do st_l1 <- addListToSS st_l0 [Right fs]
                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 
        ptr (st_i0,st_l0,st_p0,st_I0) p
@@ -342,6 +351,7 @@ mkBits findLabel st proto_insns
           = do st_I1 <- addToSS st_I0 (getName dcon)
                return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
 
+       literal st (MachLabel fs)  = litlabel st fs
        literal st (MachWord w)    = int st (fromIntegral w)
        literal st (MachInt j)     = int st (fromIntegral j)
        literal st (MachFloat r)   = float st (fromRational r)
@@ -431,7 +441,7 @@ instrSize16s instr
 mkLitI   :: Int    -> [Word]
 mkLitF   :: Float  -> [Word]
 mkLitD   :: Double -> [Word]
-mkLitPtr :: Ptr ()   -> [Word]
+mkLitPtr :: Ptr () -> [Word]
 mkLitI64 :: Int64  -> [Word]
 
 mkLitF f
@@ -521,8 +531,9 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
         ptrs     <- listFromSS ptrsSS
         itbls    <- listFromSS itblsSS
 
-        linked_ptrs  <- mapM (lookupCE ce) ptrs
-        linked_itbls <- mapM (lookupIE ie) itbls
+        linked_ptrs     <- mapM (lookupCE ce) ptrs
+        linked_itbls    <- mapM (lookupIE ie) itbls
+        linked_literals <- mapM lookupLiteral literals
 
         let n_insns    = sizeSS insnsSS
             n_literals = sizeSS literalsSS
@@ -545,7 +556,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
                         :: UArray Int Word16
             insns_barr = case insns_arr of UArray lo hi barr -> barr
 
-            literals_arr = array (0, n_literals-1) (indexify literals)
+            literals_arr = array (0, n_literals-1) (indexify linked_literals)
                            :: UArray Int Word
             literals_barr = case literals_arr of UArray lo hi barr -> barr
 
@@ -566,6 +577,20 @@ newBCO a b c d
    = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
 
 
+lookupLiteral :: Either Word FAST_STRING -> IO Word
+lookupLiteral (Left w) = return w
+lookupLiteral (Right addr_of_label_string)
+   = do let label_to_find = _UNPK_ addr_of_label_string
+        m <- lookupSymbol label_to_find 
+        case m of
+           -- Can't be bothered to find the official way to convert Addr# to Word#;
+           -- the FFI/Foreign designers make it too damn difficult
+           -- Hence we apply the Blunt Instrument, which works correctly
+           -- on all reasonable architectures anyway
+           Just (Ptr addr) -> return (W# (unsafeCoerce# addr))
+           Nothing         -> linkFail "ByteCodeLink: can't find label" 
+                                       label_to_find
+
 lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
 lookupCE ce (Right primop)
    = do let sym_to_find = primopToCLabel primop "closure"

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 3953410..9e0dada 100644 (file)
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -4,7 +4,7 @@
 \section{Code output phase}
 
 \begin{code}
-module CodeOutput( codeOutput ) where
+module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
 

diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index e0b0097..07b0780 100644 (file)
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1115,7 +1115,6 @@ compile ghci_mode summary source_unchanged have_object
 
       HscRecomp pcs details iface
        stub_h_exists stub_c_exists maybe_interpreted_code -> do
-          
           let 
           maybe_stub_o <- compileStub dyn_flags' stub_c_exists
           let stub_unlinked = case maybe_stub_o of

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 5f82eaf..8c41409 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -66,7 +66,7 @@ import StgSyn
 import CoreToStg       ( coreToStg )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
-import CodeOutput      ( codeOutput )
+import CodeOutput      ( codeOutput, outputForeignStubs )
 
 import Module          ( ModuleName, moduleName, mkHomeModule )
 import CmdLineOpts
@@ -368,7 +368,12 @@ hscRecomp ghci_mode dflags have_object
                          mkFinalIface ghci_mode dflags location 
                                    maybe_checked_iface new_iface tidy_details
 
-                   return ( False, False, Just (bcos,itbl_env), final_iface )
+                   ------------------ Create f-x-dynamic C-side stuff ---
+                    (istub_h_exists, istub_c_exists) 
+                       <- outputForeignStubs dflags c_code h_code
+
+                   return ( istub_h_exists, istub_c_exists, 
+                             Just (bcos,itbl_env), final_iface )
 #else
                then error "GHC not compiled with interpreter"
 #endif

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 65a1457..7aa6f74 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -108,7 +108,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper)
        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
        -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
        -- is DEPRECATED, though.
-    checkCg checkCOrAsm                `thenNF_Tc_`
+    checkCg checkCOrAsmOrInterp                `thenNF_Tc_`
     case arg_tys of
        [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
                     checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`