-extendLinkEnv new_bindings
- = do pls <- readIORef v_PersistentLinkerState
- let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
-
-
-recoverDataCon :: a -> TcM Name
-recoverDataCon a = recoverDCInRTS a `recoverM` ioToTcRn (do
- mb_name <- recoverDCInDynEnv a
- maybe (fail "Linker.recoverDatacon: Name not found in Dyn Env")
- return
- mb_name)
-
--- | If a is a Constr closure, lookupDC returns either the Name of the DataCon or the
--- symbol if it is a nullary constructor
--- For instance, for a closure containing 'Just x' it would return the Name for Data.Maybe.Just
--- For a closure containing 'Nothing' it would return the String "DataziMaybe_Nothing_static_info"
-recoverDCInDynEnv :: a -> IO (Maybe Name)
-recoverDCInDynEnv a = do
- pls <- readIORef v_PersistentLinkerState
- let de = dtacons_env pls
- ctype <- getClosureType a
- if not (isConstr ctype)
- then putStrLn ("Not a Constr (" ++ show ctype ++ ")") >>
- return Nothing
- else do let infot = getInfoTablePtr a
- name = lookupAddressEnv de (castPtr$ infot `plusPtr` (wORD_SIZE*2))
- return name
-
-
-recoverDCInRTS :: a -> TcM Name
-recoverDCInRTS a = do
- ctype <- ioToTcRn$ getClosureType a
- if (not$ isConstr ctype)
- then fail "not Constr"
- else do
- Just symbol <- ioToTcRn$ lookupDataCon (getInfoTablePtr a)
- let (occ,mod) = (parse . lex) symbol
- lookupOrig mod occ
- where lex x = map zDecodeString . init . init . split '_' . removeLeadingUnderscore $ x
- parse [pkg, modName, occ] = (mkOccName OccName.dataName occ,
- mkModule (stringToPackageId pkg) (mkModuleName modName))
- parse [modName, occ] = (mkOccName OccName.dataName occ,
- mkModule mainPackageId (mkModuleName modName))
- split delim = let
- helper [] = Nothing
- helper x = Just . second (drop 1) . break (==delim) $ x
- in unfoldr helper
- removeLeadingUnderscore = if cLeadingUnderscore=="YES"
- then tail
- else id
-
-getHValue :: Name -> IO (Maybe HValue)
-getHValue name = do
- pls <- readIORef v_PersistentLinkerState
- case lookupNameEnv (closure_env pls) name of
- Just (_,x) -> return$ Just x
- _ -> return Nothing
-
-withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+extendLinkEnv new_bindings =
+ modifyMVar_ v_PersistentLinkerState $ \pls ->
+ let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
+ in return pls{ closure_env = new_closure_env }
+
+deleteFromLinkEnv :: [Name] -> IO ()
+deleteFromLinkEnv to_remove =
+ modifyMVar_ v_PersistentLinkerState $ \pls ->
+ let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+ in return pls{ closure_env = new_closure_env }
+
+-- | Given a data constructor in the heap, find its Name.
+-- The info tables for data constructors have a field which records
+-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
+-- string). The format is:
+--
+-- > Package:Module.Name
+--
+-- We use this string to lookup the interpreter's internal representation of the name
+-- using the lookupOrig.
+--
+dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
+dataConInfoPtrToName x = do
+ theString <- liftIO $ do
+ let ptr = castPtr x :: Ptr StgInfoTable
+ conDescAddress <- getConDescAddress ptr
+ peekArray0 0 conDescAddress
+ let (pkg, mod, occ) = parse theString
+ pkgFS = mkFastStringByteList pkg
+ modFS = mkFastStringByteList mod
+ occFS = mkFastStringByteList occ
+ occName = mkOccNameFS OccName.dataName occFS
+ modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
+ return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
+ `recoverM` (Right `fmap` lookupOrig modName occName)
+
+ where
+
+ {- To find the string in the constructor's info table we need to consider
+ the layout of info tables relative to the entry code for a closure.
+
+ An info table can be next to the entry code for the closure, or it can
+ be separate. The former (faster) is used in registerised versions of ghc,
+ and the latter (portable) is for non-registerised versions.
+
+ The diagrams below show where the string is to be found relative to
+ the normal info table of the closure.
+
+ 1) Code next to table:
+
+ --------------
+ | | <- pointer to the start of the string
+ --------------
+ | | <- the (start of the) info table structure
+ | |
+ | |
+ --------------
+ | entry code |
+ | .... |
+
+ In this case the pointer to the start of the string can be found in
+ the memory location _one word before_ the first entry in the normal info
+ table.
+
+ 2) Code NOT next to table:
+
+ --------------
+ info table structure -> | *------------------> --------------
+ | | | entry code |
+ | | | .... |
+ --------------
+ ptr to start of str -> | |
+ --------------
+
+ In this case the pointer to the start of the string can be found
+ in the memory location: info_table_ptr + info_table_size
+ -}
+
+ getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
+ getConDescAddress ptr
+ | ghciTablesNextToCode = do
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+ | otherwise =
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
+
+ -- parsing names is a little bit fiddly because we have a string in the form:
+ -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
+ -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
+ -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
+ -- this is not the conventional way of writing Haskell names. We stick with
+ -- convention, even though it makes the parsing code more troublesome.
+ -- Warning: this code assumes that the string is well formed.
+ parse :: [Word8] -> ([Word8], [Word8], [Word8])
+ parse input
+ = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
+ where
+ dot = fromIntegral (ord '.')
+ (pkg, rest1) = break (== fromIntegral (ord ':')) input
+ (mod, occ)
+ = (concat $ intersperse [dot] $ reverse modWords, occWord)
+ where
+ (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
+ parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
+ -- We only look for dots if str could start with a module name,
+ -- i.e. if it starts with an upper case character.
+ -- Otherwise we might think that "X.:->" is the module name in
+ -- "X.:->.+", whereas actually "X" is the module name and
+ -- ":->.+" is a constructor name.
+ parseModOcc acc str@(c : _)
+ | isUpper $ chr $ fromIntegral c
+ = case break (== dot) str of
+ (top, []) -> (acc, top)
+ (top, _ : bot) -> parseModOcc (top : acc) bot
+ parseModOcc acc str = (acc, str)
+
+-- | Get the 'HValue' associated with the given name.
+--
+-- May cause loading the module that contains the name.
+--
+-- Throws a 'ProgramError' if loading fails or the name cannot be found.
+getHValue :: HscEnv -> Name -> IO HValue
+getHValue hsc_env name = do
+ pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
+ if (isExternalName name) then do
+ (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
+ if (failed ok) then ghcError (ProgramError "")
+ else return (pls', pls')
+ else
+ return (pls, pls)
+ lookupName (closure_env pls) name
+
+linkDependencies :: HscEnv -> PersistentLinkerState
+ -> SrcSpan -> [Module]
+ -> IO (PersistentLinkerState, SuccessFlag)
+linkDependencies hsc_env pls span needed_mods = do
+ let hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ -- The interpreter and dynamic linker can only handle object code built
+ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
+ -- So here we check the build tag: if we're building a non-standard way
+ -- then we need to find & link object files built the "normal" way.
+ maybe_normal_osuf <- checkNonStdWay dflags span
+
+ -- Find what packages and linkables are required
+ (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
+ maybe_normal_osuf span needed_mods
+
+ -- Link the packages and modules required
+ pls1 <- linkPackages' dflags pkgs pls
+ linkModules dflags pls1 lnks
+
+
+-- | Temporarily extend the linker state.
+
+withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
+ [(Name,HValue)] -> m a -> m a