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