| ... |
... |
@@ -154,6 +154,57 @@ notSupportedJS :: Message a -> b |
|
154
|
154
|
notSupportedJS m = error ("Message not supported with the JavaScript interpreter: " ++ show m)
|
|
155
|
155
|
#endif
|
|
156
|
156
|
|
|
|
157
|
+-- Malloc and copy the bytes. We don't have any way to monitor the
|
|
|
158
|
+-- lifetime of this memory, so it just leaks.
|
|
|
159
|
+mkString :: ByteString -> IO (RemotePtr ())
|
|
|
160
|
+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
|
|
|
161
|
+ ptr <- mallocBytes len
|
|
|
162
|
+ copyBytes ptr cstr len
|
|
|
163
|
+ return (castRemotePtr (toRemotePtr ptr))
|
|
|
164
|
+
|
|
|
165
|
+mkString0 :: ByteString -> IO (RemotePtr ())
|
|
|
166
|
+mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
|
|
|
167
|
+ ptr <- mallocBytes (len+1)
|
|
|
168
|
+ copyBytes ptr cstr len
|
|
|
169
|
+ pokeElemOff (ptr :: Ptr CChar) len 0
|
|
|
170
|
+ return (castRemotePtr (toRemotePtr ptr))
|
|
|
171
|
+
|
|
|
172
|
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
|
|
|
173
|
+#if defined(PROFILING)
|
|
|
174
|
+mkCostCentres mod ccs = do
|
|
|
175
|
+ let c_module = fromRemotePtr $ castRemotePtr mod
|
|
|
176
|
+ mapM (mk_one c_module) ccs
|
|
|
177
|
+ where
|
|
|
178
|
+ mk_one c_module (decl_path,srcspan) = do
|
|
|
179
|
+ c_name <- newCStringFromSBS decl_path
|
|
|
180
|
+ c_srcspan <- newCStringFromSBS srcspan
|
|
|
181
|
+ toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
|
|
|
182
|
+
|
|
|
183
|
+foreign import ccall unsafe "mkCostCentre"
|
|
|
184
|
+ c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
|
|
|
185
|
+#else
|
|
|
186
|
+mkCostCentres _ _ = return []
|
|
|
187
|
+#endif
|
|
|
188
|
+
|
|
|
189
|
+getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
|
|
|
190
|
+getIdValFromApStack apStack (I# stackDepth) = do
|
|
|
191
|
+ case getApStackVal# apStack stackDepth of
|
|
|
192
|
+ (# ok, result #) ->
|
|
|
193
|
+ case ok of
|
|
|
194
|
+ 0# -> return Nothing -- AP_STACK not found
|
|
|
195
|
+ _ -> return (Just (unsafeCoerce# result))
|
|
|
196
|
+
|
|
|
197
|
+-- Exceptions can't be marshaled because they're dynamically typed, so
|
|
|
198
|
+-- everything becomes a String.
|
|
|
199
|
+tryEval :: IO a -> IO (EvalResult a)
|
|
|
200
|
+tryEval io = do
|
|
|
201
|
+ e <- try io
|
|
|
202
|
+ case e of
|
|
|
203
|
+ Left ex -> return (EvalException (toSerializableException ex))
|
|
|
204
|
+ Right a -> return (EvalSuccess a)
|
|
|
205
|
+
|
|
|
206
|
+--------------------------------------------------------------------------------
|
|
|
207
|
+
|
|
157
|
208
|
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
|
|
158
|
209
|
evalStmt opts expr = do
|
|
159
|
210
|
io <- mkIO expr
|
| ... |
... |
@@ -186,6 +237,9 @@ evalStringToString r str = do |
|
186
|
237
|
r <- (unsafeCoerce io :: String -> IO String) str
|
|
187
|
238
|
evaluate (force r)
|
|
188
|
239
|
|
|
|
240
|
+
|
|
|
241
|
+--------------------------------------------------------------------------------
|
|
|
242
|
+
|
|
189
|
243
|
-- | Process the Seq message to force a value. #2950
|
|
190
|
244
|
-- If during this processing a breakpoint is hit, return
|
|
191
|
245
|
-- an EvalBreak value in the EvalStatus to the UI process,
|
| ... |
... |
@@ -315,15 +369,6 @@ measureAlloc io = do |
|
315
|
369
|
let allocs = negate $ fromIntegral ctr
|
|
316
|
370
|
return (EvalComplete allocs a)
|
|
317
|
371
|
|
|
318
|
|
--- Exceptions can't be marshaled because they're dynamically typed, so
|
|
319
|
|
--- everything becomes a String.
|
|
320
|
|
-tryEval :: IO a -> IO (EvalResult a)
|
|
321
|
|
-tryEval io = do
|
|
322
|
|
- e <- try io
|
|
323
|
|
- case e of
|
|
324
|
|
- Left ex -> return (EvalException (toSerializableException ex))
|
|
325
|
|
- Right a -> return (EvalSuccess a)
|
|
326
|
|
-
|
|
327
|
372
|
-- This function sets up the interpreter for catching breakpoints, and
|
|
328
|
373
|
-- resets everything when the computation has stopped running. This
|
|
329
|
374
|
-- is a not-very-good way to ensure that only the interactive
|
| ... |
... |
@@ -423,43 +468,3 @@ noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction |
|
423
|
468
|
noBreakAction :: BreakpointCallback
|
|
424
|
469
|
noBreakAction _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
|
|
425
|
470
|
noBreakAction _ _ _ True _ = return () -- exception: just continue |
|
426
|
|
-
|
|
427
|
|
--- Malloc and copy the bytes. We don't have any way to monitor the
|
|
428
|
|
--- lifetime of this memory, so it just leaks.
|
|
429
|
|
-mkString :: ByteString -> IO (RemotePtr ())
|
|
430
|
|
-mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
|
|
431
|
|
- ptr <- mallocBytes len
|
|
432
|
|
- copyBytes ptr cstr len
|
|
433
|
|
- return (castRemotePtr (toRemotePtr ptr))
|
|
434
|
|
-
|
|
435
|
|
-mkString0 :: ByteString -> IO (RemotePtr ())
|
|
436
|
|
-mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
|
|
437
|
|
- ptr <- mallocBytes (len+1)
|
|
438
|
|
- copyBytes ptr cstr len
|
|
439
|
|
- pokeElemOff (ptr :: Ptr CChar) len 0
|
|
440
|
|
- return (castRemotePtr (toRemotePtr ptr))
|
|
441
|
|
-
|
|
442
|
|
-mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
|
|
443
|
|
-#if defined(PROFILING)
|
|
444
|
|
-mkCostCentres mod ccs = do
|
|
445
|
|
- let c_module = fromRemotePtr $ castRemotePtr mod
|
|
446
|
|
- mapM (mk_one c_module) ccs
|
|
447
|
|
- where
|
|
448
|
|
- mk_one c_module (decl_path,srcspan) = do
|
|
449
|
|
- c_name <- newCStringFromSBS decl_path
|
|
450
|
|
- c_srcspan <- newCStringFromSBS srcspan
|
|
451
|
|
- toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
|
|
452
|
|
-
|
|
453
|
|
-foreign import ccall unsafe "mkCostCentre"
|
|
454
|
|
- c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
|
|
455
|
|
-#else
|
|
456
|
|
-mkCostCentres _ _ = return []
|
|
457
|
|
-#endif
|
|
458
|
|
-
|
|
459
|
|
-getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
|
|
460
|
|
-getIdValFromApStack apStack (I# stackDepth) = do
|
|
461
|
|
- case getApStackVal# apStack stackDepth of
|
|
462
|
|
- (# ok, result #) ->
|
|
463
|
|
- case ok of
|
|
464
|
|
- 0# -> return Nothing -- AP_STACK not found
|
|
465
|
|
- _ -> return (Just (unsafeCoerce# result)) |