2 % (c) The University of Glasgow, 2000
4 \section[CmLink]{Linker for GHCI}
7 module CmLink ( Linkable(..), Unlinked(..),
10 modname_of_linkable, is_package_linkable,
13 PersistentLinkerState{-abstractly!-}, emptyPLS )
18 import CmStaticInfo ( PackageConfigInfo, GhciMode(..) )
19 import Module ( ModuleName, PackageName )
20 import Outputable ( SDoc )
21 import Digraph ( SCC(..), flattenSCC )
23 import Panic ( panic )
25 #include "HsVersions.h"
29 data PersistentLinkerState
30 = PersistentLinkerState {
33 -- Current global mapping from RdrNames to closure addresses
34 closure_env :: ClosureEnv,
36 -- the current global mapping from RdrNames of DataCons to
37 -- info table addresses.
38 -- When a new Unlinked is linked into the running image, or an existing
39 -- module in the image is replaced, the itbl_env must be updated
43 -- notionally here, but really lives in the C part of the linker:
44 -- object_symtab :: FiniteMap String Addr
46 dummy :: () -- sigh, can't have an empty record
52 = LinkOK PersistentLinkerState
53 | LinkErrs PersistentLinkerState [SDoc]
59 | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, +
60 -- a mapping from DataCons to their itbls
62 instance Outputable Unlinked where
63 ppr (DotO path) = text "DotO" <+> text path
64 ppr (DotA path) = text "DotA" <+> text path
65 ppr (DotDLL path) = text "DotDLL" <+> text path
66 ppr (Trees binds _) = text "Trees" <+> ppr binds
69 isObject (DotO _) = True
70 isObject (DotA _) = True
71 isObject (DotDLL _) = True
74 nameOfObject (DotO fn) = fn
75 nameOfObject (DotA fn) = fn
76 nameOfObject (DotDLL fn) = fn
78 isInterpretable (Trees _ _) = True
79 isInterpretable _ = False
82 = LM ModuleName [Unlinked]
85 instance Outputable Linkable where
86 ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
87 ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm
89 findModuleLinkable :: [Linkable] -> ModuleName -> Linkable
90 findModuleLinkable lis mod
91 = case [LM nm us | LM nm us <- lis, nm == mod] of
93 other -> pprPanic "findModuleLinkable" (ppr mod)
96 emptyPLS :: IO PersistentLinkerState
98 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
101 emptyPLS = return (PersistentLinkerState {})
106 -- The first arg is supposed to be DriverPipeline.doLink.
107 -- Passed in here to avoid a hard-to-avoid circular dependency
108 -- between CmLink and DriverPipeline. Same deal as with
109 -- CmSummarise.summarise.
110 link :: ([String] -> IO ())
111 -> GhciMode -- interactive or batch
112 -> Bool -- attempt linking in batch mode?
113 -> [Linkable] -- only contains LMs, not LPs
114 -> PersistentLinkerState
118 --link = panic "CmLink.link: not implemented"
120 -- For the moment, in the batch linker, we don't bother to
121 -- tell doLink which packages to link -- it just tries all that
123 -- batch_attempt_linking should only be *looked at* in
124 -- batch mode. It should only be True if the upsweep was
125 -- successful and someone exports main, i.e., we have good
126 -- reason to believe that linking will succeed.
127 link doLink Batch batch_attempt_linking linkables pls1
128 | batch_attempt_linking
129 = do putStrLn "LINK(batch): linkables are ..."
130 putStrLn (showSDoc (vcat (map ppr linkables)))
131 let o_files = concatMap getOfiles linkables
133 -- doLink only returns if it succeeds
134 putStrLn "LINK(batch): done"
137 = do putStrLn "LINKER(batch): upsweep (partially?) failed OR main not exported;"
138 putStrLn " -- not doing linking"
141 getOfiles (LP _) = panic "link.getOfiles: shouldn't get package linkables"
142 getOfiles (LM _ us) = map nameOfObject (filter isObject us)
144 link doLink Interactive batch_attempt_linking linkables pls1
145 = do putStrLn "LINKER(interactive): not yet implemented"
149 ppLinkableSCC :: SCC Linkable -> SDoc
150 ppLinkableSCC = ppr . flattenSCC
155 link pci [] pls = return (LinkOK pls)
156 link pci (groupSCC:groups) pls = do
157 let group = flattenSCC groupSCC
158 -- the group is either all objects or all interpretable, for now
159 if all isObject group
160 then do mapM loadObj [ file | DotO file <- group ]
163 else if all isInterpretable group
164 then do (new_closure_env, new_itbl_env) <-
165 linkIModules (closure_env pls)
167 [ trees | Trees trees <- group ]
168 link pci groups (PersistentLinkerState{
169 closure_env=new_closure_env,
170 itbl_env=new_itbl_env})
172 return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
176 modname_of_linkable (LM nm _) = nm
177 modname_of_linkable (LP _) = panic "modname_of_linkable: package"
179 is_package_linkable (LP _) = True
180 is_package_linkable (LM _ _) = False
182 filterModuleLinkables :: (ModuleName -> Bool)
185 filterModuleLinkables p [] = []
186 filterModuleLinkables p (li:lis)
189 LM modnm _ -> if p modnm then retain else dump
191 dump = filterModuleLinkables p lis