From 45ddebc0dc20f013eff011a157b42acb37ea7598 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 18 Feb 2002 12:41:03 +0000 Subject: [PATCH] [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. --- ghc/compiler/compMan/CmLink.lhs | 3 +- ghc/compiler/compMan/CmTypes.lhs | 18 ++++++++++-- ghc/compiler/deSugar/DsForeign.lhs | 12 ++++---- ghc/compiler/ghci/ByteCodeGen.lhs | 4 ++- ghc/compiler/ghci/ByteCodeLink.lhs | 51 +++++++++++++++++++++++++--------- ghc/compiler/main/CodeOutput.lhs | 2 +- ghc/compiler/main/DriverPipeline.hs | 1 - ghc/compiler/main/HscMain.lhs | 9 ++++-- ghc/compiler/typecheck/TcForeign.lhs | 2 +- 9 files changed, 74 insertions(+), 28 deletions(-) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index c7ac67e..151099b 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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_` -- 1.7.10.4