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 )
22 import Digraph ( SCC(..), flattenSCC )
24 import Panic ( panic )
26 #include "HsVersions.h"
30 data PersistentLinkerState
31 = PersistentLinkerState {
34 -- Current global mapping from RdrNames to closure addresses
35 closure_env :: ClosureEnv,
37 -- the current global mapping from RdrNames of DataCons to
38 -- info table addresses.
39 -- When a new Unlinked is linked into the running image, or an existing
40 -- module in the image is replaced, the itbl_env must be updated
44 -- notionally here, but really lives in the C part of the linker:
45 -- object_symtab :: FiniteMap String Addr
47 dummy :: () -- sigh, can't have an empty record
53 = LinkOK PersistentLinkerState
54 | LinkErrs PersistentLinkerState [SDoc]
60 | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, +
61 -- a mapping from DataCons to their itbls
63 instance Outputable Unlinked where
64 ppr (DotO path) = text "DotO" <+> text path
65 ppr (DotA path) = text "DotA" <+> text path
66 ppr (DotDLL path) = text "DotDLL" <+> text path
67 ppr (Trees binds _) = text "Trees" <+> ppr binds
70 isObject (DotO _) = True
71 isObject (DotA _) = True
72 isObject (DotDLL _) = True
75 nameOfObject (DotO fn) = fn
76 nameOfObject (DotA fn) = fn
77 nameOfObject (DotDLL fn) = fn
79 isInterpretable (Trees _ _) = True
80 isInterpretable _ = False
83 = LM ModuleName [Unlinked]
86 instance Outputable Linkable where
87 ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
88 ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm
90 findModuleLinkable :: [Linkable] -> ModuleName -> Linkable
91 findModuleLinkable lis mod
92 = case [LM nm us | LM nm us <- lis, nm == mod] of
94 other -> pprPanic "findModuleLinkable" (ppr mod)
97 emptyPLS :: IO PersistentLinkerState
99 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
100 itbl_env = emptyFM })
102 emptyPLS = return (PersistentLinkerState {})
107 -- The first arg is supposed to be DriverPipeline.doLink.
108 -- Passed in here to avoid a hard-to-avoid circular dependency
109 -- between CmLink and DriverPipeline. Same deal as with
110 -- CmSummarise.summarise.
111 link :: ([String] -> IO ())
112 -> GhciMode -- interactive or batch
113 -> Bool -- attempt linking in batch mode?
114 -> [Linkable] -- only contains LMs, not LPs
115 -> PersistentLinkerState
119 --link = panic "CmLink.link: not implemented"
121 -- For the moment, in the batch linker, we don't bother to
122 -- tell doLink which packages to link -- it just tries all that
124 -- batch_attempt_linking should only be *looked at* in
125 -- batch mode. It should only be True if the upsweep was
126 -- successful and someone exports main, i.e., we have good
127 -- reason to believe that linking will succeed.
128 link doLink Batch batch_attempt_linking linkables pls1
129 | batch_attempt_linking
130 = do putStrLn "LINK(batch): linkables are ..."
131 putStrLn (showSDoc (vcat (map ppr linkables)))
132 let o_files = concatMap getOfiles linkables
134 -- doLink only returns if it succeeds
135 putStrLn "LINK(batch): done"
138 = do putStrLn "LINKER(batch): upsweep (partially?) failed OR main not exported;"
139 putStrLn " -- not doing linking"
142 getOfiles (LP _) = panic "link.getOfiles: shouldn't get package linkables"
143 getOfiles (LM _ us) = map nameOfObject (filter isObject us)
145 link doLink Interactive batch_attempt_linking linkables pls1
146 = 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