never executed always true always false
1 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE BangPatterns #-}
5 {-# LANGUAGE MagicHash #-}
6 {-# LANGUAGE UnboxedTuples #-}
7 {-# LANGUAGE RecordWildCards #-}
8
9 --
10 -- (c) The University of Glasgow 2002-2006
11 --
12
13 -- | Create real byte-code objects from 'ResolvedBCO's.
14 module GHCi.CreateBCO (createBCOs) where
15
16 import Prelude -- See note [Why do we import Prelude here?]
17 import GHCi.ResolvedBCO
18 import GHCi.RemoteTypes
19 import GHCi.BreakArray
20 import GHC.Data.SizedSeq
21
22 import System.IO (fixIO)
23 import Control.Monad
24 import Data.Array.Base
25 import Foreign hiding (newArray)
26 import Unsafe.Coerce (unsafeCoerce)
27 import GHC.Arr ( Array(..) )
28 import GHC.Exts
29 import GHC.IO
30 import Control.Exception ( ErrorCall(..) )
31
32 createBCOs :: [ResolvedBCO] -> IO [HValueRef]
33 createBCOs bcos = do
34 let n_bcos = length bcos
35 hvals <- fixIO $ \hvs -> do
36 let arr = listArray (0, n_bcos-1) hvs
37 mapM (createBCO arr) bcos
38 mapM mkRemoteRef hvals
39
40 createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
41 createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
42 = throwIO (ErrorCall $
43 unlines [ "The endianness of the ResolvedBCO does not match"
44 , "the systems endianness. Using ghc and iserv in a"
45 , "mixed endianness setup is not supported!"
46 ])
47 createBCO arr bco
48 = do linked_bco <- linkBCO' arr bco
49 -- Note [Updatable CAF BCOs]
50 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
51 -- Why do we need mkApUpd0 here? Otherwise top-level
52 -- interpreted CAFs don't get updated after evaluation. A
53 -- top-level BCO will evaluate itself and return its value
54 -- when entered, but it won't update itself. Wrapping the BCO
55 -- in an AP_UPD thunk will take care of the update for us.
56 --
57 -- Furthermore:
58 -- (a) An AP thunk *must* point directly to a BCO
59 -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
60 -- (c) An AP is always fully saturated, so we *can't* wrap
61 -- non-zero arity BCOs in an AP thunk.
62 --
63 -- See #17424.
64 if (resolvedBCOArity bco > 0)
65 then return (HValue (unsafeCoerce linked_bco))
66 else case mkApUpd0# linked_bco of { (# final_bco #) ->
67 return (HValue final_bco) }
68
69
70 toWordArray :: UArray Int Word64 -> UArray Int Word
71 toWordArray = amap fromIntegral
72
73 linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
74 linkBCO' arr ResolvedBCO{..} = do
75 let
76 ptrs = ssElts resolvedBCOPtrs
77 n_ptrs = sizeSS resolvedBCOPtrs
78
79 !(I# arity#) = resolvedBCOArity
80
81 !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
82
83 barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
84 insns_barr = barr resolvedBCOInstrs
85 bitmap_barr = barr (toWordArray resolvedBCOBitmap)
86 literals_barr = barr (toWordArray resolvedBCOLits)
87
88 PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
89 IO $ \s ->
90 case unsafeFreezeArray# marr s of { (# s, arr #) ->
91 case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
92 io s
93 }}
94
95
96 -- we recursively link any sub-BCOs while making the ptrs array
97 mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
98 mkPtrsArray arr n_ptrs ptrs = do
99 marr <- newPtrsArray (fromIntegral n_ptrs)
100 let
101 fill (ResolvedBCORef n) i =
102 writePtrsArrayHValue i (arr ! n) marr -- must be lazy!
103 fill (ResolvedBCOPtr r) i = do
104 hv <- localRef r
105 writePtrsArrayHValue i hv marr
106 fill (ResolvedBCOStaticPtr r) i = do
107 writePtrsArrayPtr i (fromRemotePtr r) marr
108 fill (ResolvedBCOPtrBCO bco) i = do
109 bco <- linkBCO' arr bco
110 writePtrsArrayBCO i bco marr
111 fill (ResolvedBCOPtrBreakArray r) i = do
112 BA mba <- localRef r
113 writePtrsArrayMBA i mba marr
114 zipWithM_ fill ptrs [0..]
115 return marr
116
117 data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
118
119 newPtrsArray :: Int -> IO PtrsArr
120 newPtrsArray (I# i) = IO $ \s ->
121 case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
122
123 writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
124 writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
125 case writeArray# arr i hv s of s' -> (# s', () #)
126
127 writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
128 writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
129 case writeArrayAddr# arr i a# s of s' -> (# s', () #)
130
131 -- This is rather delicate: convincing GHC to pass an Addr# as an Any but
132 -- without making a thunk turns out to be surprisingly tricky.
133 {-# NOINLINE writeArrayAddr# #-}
134 writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
135 writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
136
137 writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
138 writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
139 case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
140
141 writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
142 writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
143 case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
144
145 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
146 newBCO instrs lits ptrs arity bitmap = IO $ \s ->
147 newBCO# instrs lits ptrs arity bitmap s
148
149 {- Note [BCO empty array]
150 ~~~~~~~~~~~~~~~~~~~~~~
151 Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
152 they are 2-word heap objects. So let's make a single empty array and
153 share it between all BCOs.
154 -}
155
156 data EmptyArr = EmptyArr ByteArray#
157
158 {-# NOINLINE emptyArr #-}
159 emptyArr :: EmptyArr
160 emptyArr = unsafeDupablePerformIO $ IO $ \s ->
161 case newByteArray# 0# s of { (# s, arr #) ->
162 case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
163 (# s, EmptyArr farr #)
164 }}