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