| ... |
... |
@@ -20,7 +20,6 @@ import Prelude -- See note [Why do we import Prelude here?] |
|
20
|
20
|
import GHCi.ResolvedBCO
|
|
21
|
21
|
import GHCi.RemoteTypes
|
|
22
|
22
|
import GHCi.BreakArray
|
|
23
|
|
-import GHCi.InfoTable
|
|
24
|
23
|
import GHC.Data.SizedSeq
|
|
25
|
24
|
|
|
26
|
25
|
import System.IO (fixIO)
|
| ... |
... |
@@ -33,8 +32,6 @@ import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) |
|
33
|
32
|
import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# )
|
|
34
|
33
|
import GHC.IO
|
|
35
|
34
|
import Control.Exception ( ErrorCall(..) )
|
|
36
|
|
-import Data.Kind
|
|
37
|
|
-import Data.Maybe
|
|
38
|
35
|
|
|
39
|
36
|
createBCOs :: [ResolvedBCO] -> IO [HValueRef]
|
|
40
|
37
|
createBCOs bcos = do
|
| ... |
... |
@@ -54,7 +51,7 @@ createBCO _ obj | resolvedBCOIsLE obj /= isLittleEndian |
|
54
|
51
|
createBCO arr bco
|
|
55
|
52
|
= do linked_thing <- linkBCO' arr bco
|
|
56
|
53
|
case linked_thing of
|
|
57
|
|
- Left linked_bco -> do
|
|
|
54
|
+ LinkedBCO bco_arity linked_bco -> do
|
|
58
|
55
|
-- Note [Updatable CAF BCOs]
|
|
59
|
56
|
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
60
|
57
|
-- Why do we need mkApUpd0 here? Otherwise top-level
|
| ... |
... |
@@ -70,14 +67,18 @@ createBCO arr bco |
|
70
|
67
|
-- non-zero arity BCOs in an AP thunk.
|
|
71
|
68
|
--
|
|
72
|
69
|
-- See #17424.
|
|
73
|
|
- if (resolvedBCOArity bco > 0)
|
|
|
70
|
+ if (bco_arity > 0)
|
|
74
|
71
|
then return (HValue (unsafeCoerce linked_bco))
|
|
75
|
72
|
else case mkApUpd0# linked_bco of { (# final_bco #) ->
|
|
76
|
73
|
return (HValue final_bco) }
|
|
77
|
|
- Right linked_static_con -> do
|
|
|
74
|
+ LinkedStaticCon linked_static_con -> do
|
|
78
|
75
|
return linked_static_con
|
|
79
|
76
|
|
|
80
|
|
-linkBCO' :: Array Int HValue -> ResolvedBCO -> IO (Either BCO HValue)
|
|
|
77
|
+data LinkedBCO
|
|
|
78
|
+ = LinkedBCO !Int{-BCO arity-} BCO
|
|
|
79
|
+ | LinkedStaticCon HValue
|
|
|
80
|
+
|
|
|
81
|
+linkBCO' :: Array Int HValue -> ResolvedBCO -> IO LinkedBCO
|
|
81
|
82
|
linkBCO' arr resolved_obj =
|
|
82
|
83
|
case resolved_obj of
|
|
83
|
84
|
ResolvedBCO{..} -> do
|
| ... |
... |
@@ -94,7 +95,8 @@ linkBCO' arr resolved_obj = |
|
94
|
95
|
PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
|
|
95
|
96
|
IO $ \s ->
|
|
96
|
97
|
case unsafeFreezeArray# marr s of { (# s, arr #) ->
|
|
97
|
|
- case Left <$> newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
|
|
|
98
|
+ case LinkedBCO resolvedBCOArity <$>
|
|
|
99
|
+ newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
|
|
98
|
100
|
io s
|
|
99
|
101
|
}}
|
|
100
|
102
|
ResolvedStaticCon{..} -> do
|
| ... |
... |
@@ -114,7 +116,7 @@ linkBCO' arr resolved_obj = |
|
114
|
116
|
IO $ \s ->
|
|
115
|
117
|
case unsafeFreezeArray# marr s of { (# s, arr #) ->
|
|
116
|
118
|
case newConAppObj# itbl_ptr# literals_barr arr data_size# s of
|
|
117
|
|
- (# s, hval #) -> (# s, Right (HValue hval) #)
|
|
|
119
|
+ (# s, hval #) -> (# s, LinkedStaticCon (HValue hval) #)
|
|
118
|
120
|
}
|
|
119
|
121
|
where
|
|
120
|
122
|
!(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
|
| ... |
... |
@@ -141,9 +143,9 @@ mkPtrsArray arr n_ptrs ptrs = do |
|
141
|
143
|
fill (ResolvedBCOPtrBCO bco) i = do
|
|
142
|
144
|
obj <- linkBCO' arr bco
|
|
143
|
145
|
case obj of
|
|
144
|
|
- Left bco ->
|
|
|
146
|
+ LinkedBCO _ bco ->
|
|
145
|
147
|
writePtrsArrayBCO i bco marr
|
|
146
|
|
- Right !linked_static_con ->
|
|
|
148
|
+ LinkedStaticCon !linked_static_con ->
|
|
147
|
149
|
writePtrsArrayHValue i linked_static_con marr
|
|
148
|
150
|
fill (ResolvedBCOPtrBreakArray r) i = do
|
|
149
|
151
|
BA mba <- localRef r
|