Tweak link order slightly to prefer user shared libs before system ones.
[ghc.git] / compiler / ghci / ByteCodeLink.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MagicHash #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE UnboxedTuples #-}
7 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
8 --
9 -- (c) The University of Glasgow 2002-2006
10 --
11
12 -- | ByteCodeLink: Bytecode assembler and linker
13 module ByteCodeLink (
14 ClosureEnv, emptyClosureEnv, extendClosureEnv,
15 linkBCO, lookupStaticPtr,
16 lookupIE,
17 nameToCLabel, linkFail
18 ) where
19
20 #include "HsVersions.h"
21
22 import GhcPrelude
23
24 import GHCi.RemoteTypes
25 import GHCi.ResolvedBCO
26 import GHCi.InfoTable
27 import GHCi.BreakArray
28 import SizedSeq
29
30 import GHCi
31 import ByteCodeTypes
32 import HscTypes
33 import Name
34 import NameEnv
35 import PrimOp
36 import Module
37 import FastString
38 import Panic
39 import Outputable
40 import Util
41
42 -- Standard libraries
43 import Data.Array.Unboxed
44 import Foreign.Ptr
45 import GHC.IO ( IO(..) )
46 import GHC.Exts
47
48 {-
49 Linking interpretables into something we can run
50 -}
51
52 type ClosureEnv = NameEnv (Name, ForeignHValue)
53
54 emptyClosureEnv :: ClosureEnv
55 emptyClosureEnv = emptyNameEnv
56
57 extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
58 extendClosureEnv cl_env pairs
59 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
60
61 {-
62 Linking interpretables into something we can run
63 -}
64
65 linkBCO
66 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
67 -> UnlinkedBCO
68 -> IO ResolvedBCO
69 linkBCO hsc_env ie ce bco_ix breakarray
70 (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
71 -- fromIntegral Word -> Word64 should be a no op if Word is Word64
72 -- otherwise it will result in a cast to longlong on 32bit systems.
73 lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)
74 ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
75 return (ResolvedBCO isLittleEndian arity insns bitmap
76 (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
77 (addListToSS emptySS ptrs))
78
79 lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
80 lookupLiteral _ _ (BCONPtrWord lit) = return lit
81 lookupLiteral hsc_env _ (BCONPtrLbl sym) = do
82 Ptr a# <- lookupStaticPtr hsc_env sym
83 return (W# (int2Word# (addr2Int# a#)))
84 lookupLiteral hsc_env ie (BCONPtrItbl nm) = do
85 Ptr a# <- lookupIE hsc_env ie nm
86 return (W# (int2Word# (addr2Int# a#)))
87 lookupLiteral _ _ (BCONPtrStr _) =
88 -- should be eliminated during assembleBCOs
89 panic "lookupLiteral: BCONPtrStr"
90
91 lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
92 lookupStaticPtr hsc_env addr_of_label_string = do
93 m <- lookupSymbol hsc_env addr_of_label_string
94 case m of
95 Just ptr -> return ptr
96 Nothing -> linkFail "ByteCodeLink: can't find label"
97 (unpackFS addr_of_label_string)
98
99 lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
100 lookupIE hsc_env ie con_nm =
101 case lookupNameEnv ie con_nm of
102 Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
103 Nothing -> do -- try looking up in the object files.
104 let sym_to_find1 = nameToCLabel con_nm "con_info"
105 m <- lookupSymbol hsc_env sym_to_find1
106 case m of
107 Just addr -> return addr
108 Nothing
109 -> do -- perhaps a nullary constructor?
110 let sym_to_find2 = nameToCLabel con_nm "static_info"
111 n <- lookupSymbol hsc_env sym_to_find2
112 case n of
113 Just addr -> return addr
114 Nothing -> linkFail "ByteCodeLink.lookupIE"
115 (unpackFS sym_to_find1 ++ " or " ++
116 unpackFS sym_to_find2)
117
118 lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
119 lookupPrimOp hsc_env primop = do
120 let sym_to_find = primopToCLabel primop "closure"
121 m <- lookupSymbol hsc_env (mkFastString sym_to_find)
122 case m of
123 Just p -> return (toRemotePtr p)
124 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
125
126 resolvePtr
127 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
128 -> BCOPtr
129 -> IO ResolvedBCOPtr
130 resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
131 | Just ix <- lookupNameEnv bco_ix nm =
132 return (ResolvedBCORef ix) -- ref to another BCO in this group
133 | Just (_, rhv) <- lookupNameEnv ce nm =
134 return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
135 | otherwise =
136 ASSERT2(isExternalName nm, ppr nm)
137 do let sym_to_find = nameToCLabel nm "closure"
138 m <- lookupSymbol hsc_env sym_to_find
139 case m of
140 Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
141 Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
142 resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
143 ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
144 resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
145 ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
146 resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
147 return (ResolvedBCOPtrBreakArray breakarray)
148
149 linkFail :: String -> String -> IO a
150 linkFail who what
151 = throwGhcExceptionIO (ProgramError $
152 unlines [ "",who
153 , "During interactive linking, GHCi couldn't find the following symbol:"
154 , ' ' : ' ' : what
155 , "This may be due to you not asking GHCi to load extra object files,"
156 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
157 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
158 , "flags, or simply by naming the relevant files on the GHCi command line."
159 , "Alternatively, this link failure might indicate a bug in GHCi."
160 , "If you suspect the latter, please send a bug report to:"
161 , " glasgow-haskell-bugs@haskell.org"
162 ])
163
164
165 nameToCLabel :: Name -> String -> FastString
166 nameToCLabel n suffix = mkFastString label
167 where
168 encodeZ = zString . zEncodeFS
169 (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
170 packagePart = encodeZ (unitIdFS pkgKey)
171 modulePart = encodeZ (moduleNameFS modName)
172 occPart = encodeZ (occNameFS (nameOccName n))
173
174 label = concat
175 [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
176 , modulePart
177 , '_':occPart
178 , '_':suffix
179 ]
180
181
182 primopToCLabel :: PrimOp -> String -> String
183 primopToCLabel primop suffix = concat
184 [ "ghczmprim_GHCziPrimopWrappers_"
185 , zString (zEncodeFS (occNameFS (primOpOcc primop)))
186 , '_':suffix
187 ]