Remote GHCi: Optimize the serialization/deserialization of byte code
[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 GHCi.RemoteTypes
23 import GHCi.ResolvedBCO
24 import GHCi.InfoTable
25 import GHCi.BreakArray
26 import SizedSeq
27
28 import GHCi
29 import ByteCodeTypes
30 import HscTypes
31 import DynFlags
32 import Name
33 import NameEnv
34 import PrimOp
35 import Module
36 import FastString
37 import Panic
38 import Outputable
39 import Util
40
41 -- Standard libraries
42 import Data.Array.Unboxed
43 import Data.Array.Base
44 import Data.Word
45 import Foreign.Ptr
46 import GHC.IO ( IO(..) )
47 import GHC.Exts
48
49 {-
50 Linking interpretables into something we can run
51 -}
52
53 type ClosureEnv = NameEnv (Name, ForeignHValue)
54
55 emptyClosureEnv :: ClosureEnv
56 emptyClosureEnv = emptyNameEnv
57
58 extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
59 extendClosureEnv cl_env pairs
60 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
61
62 {-
63 Linking interpretables into something we can run
64 -}
65
66 linkBCO
67 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
68 -> UnlinkedBCO
69 -> IO ResolvedBCO
70 linkBCO hsc_env ie ce bco_ix breakarray
71 (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
72 lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)
73 ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
74 let dflags = hsc_dflags hsc_env
75 return (ResolvedBCO arity (toWordArray dflags insns) bitmap
76 (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
77 (addListToSS emptySS ptrs))
78
79 -- Turn the insns array from a Word16 array into a Word array. The
80 -- latter is much faster to serialize/deserialize. Assumes the input
81 -- array is zero-indexed.
82 toWordArray :: DynFlags -> UArray Int Word16 -> UArray Int Word
83 toWordArray dflags (UArray _ _ n arr) = UArray 0 (n'-1) n' arr
84 where n' = (n + w16s_per_word - 1) `quot` w16s_per_word
85 w16s_per_word = wORD_SIZE dflags `quot` 2
86
87 lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
88 lookupLiteral _ _ (BCONPtrWord lit) = return lit
89 lookupLiteral hsc_env _ (BCONPtrLbl sym) = do
90 Ptr a# <- lookupStaticPtr hsc_env sym
91 return (W# (int2Word# (addr2Int# a#)))
92 lookupLiteral hsc_env ie (BCONPtrItbl nm) = do
93 Ptr a# <- lookupIE hsc_env ie nm
94 return (W# (int2Word# (addr2Int# a#)))
95 lookupLiteral hsc_env _ (BCONPtrStr bs) = do
96 fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs
97
98 lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
99 lookupStaticPtr hsc_env addr_of_label_string = do
100 m <- lookupSymbol hsc_env addr_of_label_string
101 case m of
102 Just ptr -> return ptr
103 Nothing -> linkFail "ByteCodeLink: can't find label"
104 (unpackFS addr_of_label_string)
105
106 lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
107 lookupIE hsc_env ie con_nm =
108 case lookupNameEnv ie con_nm of
109 Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
110 Nothing -> do -- try looking up in the object files.
111 let sym_to_find1 = nameToCLabel con_nm "con_info"
112 m <- lookupSymbol hsc_env sym_to_find1
113 case m of
114 Just addr -> return addr
115 Nothing
116 -> do -- perhaps a nullary constructor?
117 let sym_to_find2 = nameToCLabel con_nm "static_info"
118 n <- lookupSymbol hsc_env sym_to_find2
119 case n of
120 Just addr -> return addr
121 Nothing -> linkFail "ByteCodeLink.lookupIE"
122 (unpackFS sym_to_find1 ++ " or " ++
123 unpackFS sym_to_find2)
124
125 lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
126 lookupPrimOp hsc_env primop = do
127 let sym_to_find = primopToCLabel primop "closure"
128 m <- lookupSymbol hsc_env (mkFastString sym_to_find)
129 case m of
130 Just p -> return (toRemotePtr p)
131 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
132
133 resolvePtr
134 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
135 -> BCOPtr
136 -> IO ResolvedBCOPtr
137 resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
138 | Just ix <- lookupNameEnv bco_ix nm =
139 return (ResolvedBCORef ix) -- ref to another BCO in this group
140 | Just (_, rhv) <- lookupNameEnv ce nm =
141 return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
142 | otherwise =
143 ASSERT2(isExternalName nm, ppr nm)
144 do let sym_to_find = nameToCLabel nm "closure"
145 m <- lookupSymbol hsc_env sym_to_find
146 case m of
147 Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
148 Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
149 resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
150 ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
151 resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
152 ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
153 resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
154 return (ResolvedBCOPtrBreakArray breakarray)
155
156 linkFail :: String -> String -> IO a
157 linkFail who what
158 = throwGhcExceptionIO (ProgramError $
159 unlines [ "",who
160 , "During interactive linking, GHCi couldn't find the following symbol:"
161 , ' ' : ' ' : what
162 , "This may be due to you not asking GHCi to load extra object files,"
163 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
164 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
165 , "flags, or simply by naming the relevant files on the GHCi command line."
166 , "Alternatively, this link failure might indicate a bug in GHCi."
167 , "If you suspect the latter, please send a bug report to:"
168 , " glasgow-haskell-bugs@haskell.org"
169 ])
170
171
172 nameToCLabel :: Name -> String -> FastString
173 nameToCLabel n suffix = mkFastString label
174 where
175 encodeZ = zString . zEncodeFS
176 (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
177 packagePart = encodeZ (unitIdFS pkgKey)
178 modulePart = encodeZ (moduleNameFS modName)
179 occPart = encodeZ (occNameFS (nameOccName n))
180
181 label = concat
182 [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
183 , modulePart
184 , '_':occPart
185 , '_':suffix
186 ]
187
188
189 primopToCLabel :: PrimOp -> String -> String
190 primopToCLabel primop suffix = concat
191 [ "ghczmprim_GHCziPrimopWrappers_"
192 , zString (zEncodeFS (occNameFS (primOpOcc primop)))
193 , '_':suffix
194 ]