Commit 45ddebc0 authored by sewardj's avatar sewardj

[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.
parent 94667d2a
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -4,7 +4,7 @@
\section{Code output phase}
\begin{code}
module CodeOutput( codeOutput ) where
module CodeOutput( codeOutput, outputForeignStubs ) where
#include "HsVersions.h"
......
......@@ -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
......
......@@ -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
......
......@@ -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_`
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment