Remote GHCi: batch the creation of strings
[ghc.git] / compiler / ghci / ByteCodeGen.hs
1 {-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
2 --
3 -- (c) The University of Glasgow 2002-2006
4 --
5
6 -- | ByteCodeGen: Generate bytecode from Core
7 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
8
9 #include "HsVersions.h"
10
11 import ByteCodeInstr
12 import ByteCodeAsm
13 import ByteCodeTypes
14
15 import GHCi
16 import GHCi.FFI
17 import GHCi.RemoteTypes
18 import BasicTypes
19 import DynFlags
20 import Outputable
21 import Platform
22 import Name
23 import MkId
24 import Id
25 import ForeignCall
26 import HscTypes
27 import CoreUtils
28 import CoreSyn
29 import PprCore
30 import Literal
31 import PrimOp
32 import CoreFVs
33 import Type
34 import DataCon
35 import TyCon
36 import Util
37 import VarSet
38 import TysPrim
39 import ErrUtils
40 import Unique
41 import FastString
42 import Panic
43 import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW )
44 import SMRep
45 import Bitmap
46 import OrdList
47 import Maybes
48
49 import Data.List
50 import Foreign
51 import Control.Monad
52 import Data.Char
53
54 import UniqSupply
55 import Module
56 import Control.Arrow ( second )
57
58 import Data.Array
59 import Data.Map (Map)
60 import Data.IntMap (IntMap)
61 import qualified Data.Map as Map
62 import qualified Data.IntMap as IntMap
63 import qualified FiniteMap as Map
64 import Data.Ord
65 import GHC.Stack.CCS
66
67 -- -----------------------------------------------------------------------------
68 -- Generating byte code for a complete module
69
70 byteCodeGen :: HscEnv
71 -> Module
72 -> CoreProgram
73 -> [TyCon]
74 -> Maybe ModBreaks
75 -> IO CompiledByteCode
76 byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
77 = do let dflags = hsc_dflags hsc_env
78 showPass dflags "ByteCodeGen"
79
80 let flatBinds = [ (bndr, simpleFreeVars rhs)
81 | (bndr, rhs) <- flattenBinds binds]
82
83 us <- mkSplitUniqSupply 'y'
84 (BcM_State{..}, proto_bcos) <-
85 runBc hsc_env us this_mod mb_modBreaks $
86 mapM schemeTopBind flatBinds
87
88 when (notNull ffis)
89 (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
90
91 dumpIfSet_dyn dflags Opt_D_dump_BCOs
92 "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
93
94 assembleBCOs hsc_env proto_bcos tycs
95 (case modBreaks of
96 Nothing -> Nothing
97 Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
98
99 -- -----------------------------------------------------------------------------
100 -- Generating byte code for an expression
101
102 -- Returns: the root BCO for this expression
103 coreExprToBCOs :: HscEnv
104 -> Module
105 -> CoreExpr
106 -> IO UnlinkedBCO
107 coreExprToBCOs hsc_env this_mod expr
108 = do let dflags = hsc_dflags hsc_env
109 showPass dflags "ByteCodeGen"
110
111 -- create a totally bogus name for the top-level BCO; this
112 -- should be harmless, since it's never used for anything
113 let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
114 invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
115
116 -- the uniques are needed to generate fresh variables when we introduce new
117 -- let bindings for ticked expressions
118 us <- mkSplitUniqSupply 'y'
119 (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco)
120 <- runBc hsc_env us this_mod Nothing $
121 schemeTopBind (invented_id, simpleFreeVars expr)
122
123 when (notNull mallocd)
124 (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
125
126 dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
127
128 assembleOneBCO hsc_env proto_bco
129
130
131 -- The regular freeVars function gives more information than is useful to
132 -- us here. simpleFreeVars does the impedence matching.
133 simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
134 simpleFreeVars = go . freeVars
135 where
136 go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
137 go (ann, e) = (freeVarsOfAnn ann, go' e)
138
139 go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
140 go' (AnnVar id) = AnnVar id
141 go' (AnnLit lit) = AnnLit lit
142 go' (AnnLam bndr body) = AnnLam bndr (go body)
143 go' (AnnApp fun arg) = AnnApp (go fun) (go arg)
144 go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
145 go' (AnnLet bind body) = AnnLet (go_bind bind) (go body)
146 go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co)
147 go' (AnnTick tick body) = AnnTick tick (go body)
148 go' (AnnType ty) = AnnType ty
149 go' (AnnCoercion co) = AnnCoercion co
150
151 go_alt (con, args, expr) = (con, args, go expr)
152
153 go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
154 go_bind (AnnRec pairs) = AnnRec (map (second go) pairs)
155
156 -- -----------------------------------------------------------------------------
157 -- Compilation schema for the bytecode generator
158
159 type BCInstrList = OrdList BCInstr
160
161 type Sequel = Word -- back off to this depth before ENTER
162
163 -- Maps Ids to the offset from the stack _base_ so we don't have
164 -- to mess with it after each push/pop.
165 type BCEnv = Map Id Word -- To find vars on the stack
166
167 {-
168 ppBCEnv :: BCEnv -> SDoc
169 ppBCEnv p
170 = text "begin-env"
171 $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
172 $$ text "end-env"
173 where
174 pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
175 cmp_snd x y = compare (snd x) (snd y)
176 -}
177
178 -- Create a BCO and do a spot of peephole optimisation on the insns
179 -- at the same time.
180 mkProtoBCO
181 :: DynFlags
182 -> name
183 -> BCInstrList
184 -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
185 -> Int
186 -> Word16
187 -> [StgWord]
188 -> Bool -- True <=> is a return point, rather than a function
189 -> [FFIInfo]
190 -> ProtoBCO name
191 mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
192 = ProtoBCO {
193 protoBCOName = nm,
194 protoBCOInstrs = maybe_with_stack_check,
195 protoBCOBitmap = bitmap,
196 protoBCOBitmapSize = bitmap_size,
197 protoBCOArity = arity,
198 protoBCOExpr = origin,
199 protoBCOFFIs = ffis
200 }
201 where
202 -- Overestimate the stack usage (in words) of this BCO,
203 -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
204 -- stack check. (The interpreter always does a stack check
205 -- for iNTERP_STACK_CHECK_THRESH words at the start of each
206 -- BCO anyway, so we only need to add an explicit one in the
207 -- (hopefully rare) cases when the (overestimated) stack use
208 -- exceeds iNTERP_STACK_CHECK_THRESH.
209 maybe_with_stack_check
210 | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
211 -- don't do stack checks at return points,
212 -- everything is aggregated up to the top BCO
213 -- (which must be a function).
214 -- That is, unless the stack usage is >= AP_STACK_SPLIM,
215 -- see bug #1466.
216 | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
217 = STKCHECK stack_usage : peep_d
218 | otherwise
219 = peep_d -- the supposedly common case
220
221 -- We assume that this sum doesn't wrap
222 stack_usage = sum (map bciStackUse peep_d)
223
224 -- Merge local pushes
225 peep_d = peep (fromOL instrs_ordlist)
226
227 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
228 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
229 peep (PUSH_L off1 : PUSH_L off2 : rest)
230 = PUSH_LL off1 (off2-1) : peep rest
231 peep (i:rest)
232 = i : peep rest
233 peep []
234 = []
235
236 argBits :: DynFlags -> [ArgRep] -> [Bool]
237 argBits _ [] = []
238 argBits dflags (rep : args)
239 | isFollowableArg rep = False : argBits dflags args
240 | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
241
242 -- -----------------------------------------------------------------------------
243 -- schemeTopBind
244
245 -- Compile code for the right-hand side of a top-level binding
246
247 schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
248
249
250 schemeTopBind (id, rhs)
251 | Just data_con <- isDataConWorkId_maybe id,
252 isNullaryRepDataCon data_con = do
253 dflags <- getDynFlags
254 -- Special case for the worker of a nullary data con.
255 -- It'll look like this: Nil = /\a -> Nil a
256 -- If we feed it into schemeR, we'll get
257 -- Nil = Nil
258 -- because mkConAppCode treats nullary constructor applications
259 -- by just re-using the single top-level definition. So
260 -- for the worker itself, we must allocate it directly.
261 -- ioToBc (putStrLn $ "top level BCO")
262 emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
263 (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
264
265 | otherwise
266 = schemeR [{- No free variables -}] (id, rhs)
267
268
269 -- -----------------------------------------------------------------------------
270 -- schemeR
271
272 -- Compile code for a right-hand side, to give a BCO that,
273 -- when executed with the free variables and arguments on top of the stack,
274 -- will return with a pointer to the result on top of the stack, after
275 -- removing the free variables and arguments.
276 --
277 -- Park the resulting BCO in the monad. Also requires the
278 -- variable to which this value was bound, so as to give the
279 -- resulting BCO a name.
280
281 schemeR :: [Id] -- Free vars of the RHS, ordered as they
282 -- will appear in the thunk. Empty for
283 -- top-level things, which have no free vars.
284 -> (Id, AnnExpr Id DVarSet)
285 -> BcM (ProtoBCO Name)
286 schemeR fvs (nm, rhs)
287 {-
288 | trace (showSDoc (
289 (char ' '
290 $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
291 $$ pprCoreExpr (deAnnotate rhs)
292 $$ char ' '
293 ))) False
294 = undefined
295 | otherwise
296 -}
297 = schemeR_wrk fvs nm rhs (collect rhs)
298
299 collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
300 collect (_, e) = go [] e
301 where
302 go xs e | Just e' <- bcView e = go xs e'
303 go xs (AnnLam x (_,e))
304 | UbxTupleRep _ <- repType (idType x)
305 = unboxedTupleException
306 | otherwise
307 = go (x:xs) e
308 go xs not_lambda = (reverse xs, not_lambda)
309
310 schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)
311 schemeR_wrk fvs nm original_body (args, body)
312 = do
313 dflags <- getDynFlags
314 let
315 all_args = reverse args ++ fvs
316 arity = length all_args
317 -- all_args are the args in reverse order. We're compiling a function
318 -- \fv1..fvn x1..xn -> e
319 -- i.e. the fvs come first
320
321 szsw_args = map (fromIntegral . idSizeW dflags) all_args
322 szw_args = sum szsw_args
323 p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
324
325 -- make the arg bitmap
326 bits = argBits dflags (reverse (map bcIdArgRep all_args))
327 bitmap_size = genericLength bits
328 bitmap = mkBitmap dflags bits
329 body_code <- schemeER_wrk szw_args p_init body
330
331 emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
332 arity bitmap_size bitmap False{-not alts-})
333
334 -- introduce break instructions for ticked expressions
335 schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
336 schemeER_wrk d p rhs
337 | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
338 = do code <- schemeE (fromIntegral d) 0 p newRhs
339 cc_arr <- getCCArray
340 this_mod <- moduleName <$> getCurrentModule
341 let idOffSets = getVarOffSets d p fvs
342 let breakInfo = CgBreakInfo
343 { cgb_vars = idOffSets
344 , cgb_resty = exprType (deAnnotate' newRhs)
345 }
346 newBreakInfo tick_no breakInfo
347 dflags <- getDynFlags
348 let cc | interpreterProfiled dflags = cc_arr ! tick_no
349 | otherwise = toRemotePtr nullPtr
350 let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
351 return $ breakInstr `consOL` code
352 | otherwise = schemeE (fromIntegral d) 0 p rhs
353
354 getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
355 getVarOffSets d p = catMaybes . map (getOffSet d p)
356
357 getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
358 getOffSet d env id
359 = case lookupBCEnv_maybe id env of
360 Nothing -> Nothing
361 Just offset -> Just (id, trunc16 $ d - offset)
362
363 trunc16 :: Word -> Word16
364 trunc16 w
365 | w > fromIntegral (maxBound :: Word16)
366 = panic "stack depth overflow"
367 | otherwise
368 = fromIntegral w
369
370 fvsToEnv :: BCEnv -> DVarSet -> [Id]
371 -- Takes the free variables of a right-hand side, and
372 -- delivers an ordered list of the local variables that will
373 -- be captured in the thunk for the RHS
374 -- The BCEnv argument tells which variables are in the local
375 -- environment: these are the ones that should be captured
376 --
377 -- The code that constructs the thunk, and the code that executes
378 -- it, have to agree about this layout
379 fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
380 isId v, -- Could be a type variable
381 v `Map.member` p]
382
383 -- -----------------------------------------------------------------------------
384 -- schemeE
385
386 returnUnboxedAtom :: Word -> Sequel -> BCEnv
387 -> AnnExpr' Id DVarSet -> ArgRep
388 -> BcM BCInstrList
389 -- Returning an unlifted value.
390 -- Heave it on the stack, SLIDE, and RETURN.
391 returnUnboxedAtom d s p e e_rep
392 = do (push, szw) <- pushAtom d p e
393 return (push -- value onto stack
394 `appOL` mkSLIDE szw (d-s) -- clear to sequel
395 `snocOL` RETURN_UBX e_rep) -- go
396
397 -- Compile code to apply the given expression to the remaining args
398 -- on the stack, returning a HNF.
399 schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
400
401 schemeE d s p e
402 | Just e' <- bcView e
403 = schemeE d s p e'
404
405 -- Delegate tail-calls to schemeT.
406 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
407
408 schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
409 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
410
411 schemeE d s p e@(AnnVar v)
412 | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
413 | otherwise = schemeT d s p e
414
415 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
416 | (AnnVar v, args_r_to_l) <- splitApp rhs,
417 Just data_con <- isDataConWorkId_maybe v,
418 dataConRepArity data_con == length args_r_to_l
419 = do -- Special case for a non-recursive let whose RHS is a
420 -- saturatred constructor application.
421 -- Just allocate the constructor and carry on
422 alloc_code <- mkConAppCode d s p data_con args_r_to_l
423 body_code <- schemeE (d+1) s (Map.insert x d p) body
424 return (alloc_code `appOL` body_code)
425
426 -- General case for let. Generates correct, if inefficient, code in
427 -- all situations.
428 schemeE d s p (AnnLet binds (_,body)) = do
429 dflags <- getDynFlags
430 let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
431 AnnRec xs_n_rhss -> unzip xs_n_rhss
432 n_binds = genericLength xs
433
434 fvss = map (fvsToEnv p' . fst) rhss
435
436 -- Sizes of free vars
437 sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
438
439 -- the arity of each rhs
440 arities = map (genericLength . fst . collect) rhss
441
442 -- This p', d' defn is safe because all the items being pushed
443 -- are ptrs, so all have size 1. d' and p' reflect the stack
444 -- after the closures have been allocated in the heap (but not
445 -- filled in), and pointers to them parked on the stack.
446 p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
447 d' = d + fromIntegral n_binds
448 zipE = zipEqual "schemeE"
449
450 -- ToDo: don't build thunks for things with no free variables
451 build_thunk _ [] size bco off arity
452 = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
453 where
454 mkap | arity == 0 = MKAP
455 | otherwise = MKPAP
456 build_thunk dd (fv:fvs) size bco off arity = do
457 (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
458 more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
459 return (push_code `appOL` more_push_code)
460
461 alloc_code = toOL (zipWith mkAlloc sizes arities)
462 where mkAlloc sz 0
463 | is_tick = ALLOC_AP_NOUPD sz
464 | otherwise = ALLOC_AP sz
465 mkAlloc sz arity = ALLOC_PAP arity sz
466
467 is_tick = case binds of
468 AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
469 _other -> False
470
471 compile_bind d' fvs x rhs size arity off = do
472 bco <- schemeR fvs (x,rhs)
473 build_thunk d' fvs size bco off arity
474
475 compile_binds =
476 [ compile_bind d' fvs x rhs size arity n
477 | (fvs, x, rhs, size, arity, n) <-
478 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
479 ]
480 body_code <- schemeE d' s p' body
481 thunk_codes <- sequence compile_binds
482 return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
483
484 -- introduce a let binding for a ticked case expression. This rule
485 -- *should* only fire when the expression was not already let-bound
486 -- (the code gen for let bindings should take care of that). Todo: we
487 -- call exprFreeVars on a deAnnotated expression, this may not be the
488 -- best way to calculate the free vars but it seemed like the least
489 -- intrusive thing to do
490 schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
491 = if isUnliftedType ty
492 then do
493 -- If the result type is unlifted, then we must generate
494 -- let f = \s . tick<n> e
495 -- in f realWorld#
496 -- When we stop at the breakpoint, _result will have an unlifted
497 -- type and hence won't be bound in the environment, but the
498 -- breakpoint will otherwise work fine.
499 id <- newId (mkFunTy realWorldStatePrimTy ty)
500 st <- newId realWorldStatePrimTy
501 let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
502 (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
503 (emptyDVarSet, AnnVar realWorldPrimId)))
504 schemeE d s p letExp
505 else do
506 id <- newId ty
507 -- Todo: is emptyVarSet correct on the next line?
508 let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
509 schemeE d s p letExp
510 where exp' = deAnnotate' exp
511 fvs = exprFreeVarsDSet exp'
512 ty = exprType exp'
513
514 -- ignore other kinds of tick
515 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
516
517 schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
518 -- no alts: scrut is guaranteed to diverge
519
520 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
521 | isUnboxedTupleCon dc
522 , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2)
523 -- Convert
524 -- case .... of x { (# V'd-thing, a #) -> ... }
525 -- to
526 -- case .... of a { DEFAULT -> ... }
527 -- becuse the return convention for both are identical.
528 --
529 -- Note that it does not matter losing the void-rep thing from the
530 -- envt (it won't be bound now) because we never look such things up.
531 , Just res <- case () of
532 _ | VoidRep <- typePrimRep rep_ty1
533 -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
534 | VoidRep <- typePrimRep rep_ty2
535 -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
536 | otherwise
537 -> Nothing
538 = res
539
540 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
541 | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
542 -- Similarly, convert
543 -- case .... of x { (# a #) -> ... }
544 -- to
545 -- case .... of a { DEFAULT -> ... }
546 = --trace "automagic mashing of case alts (# a #)" $
547 doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
548
549 schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)])
550 | Just (tc, tys) <- splitTyConApp_maybe (idType bndr)
551 , isUnboxedTupleTyCon tc
552 , Just res <- case tys of
553 [ty] | UnaryRep _ <- repType ty
554 , let bind = bndr `setIdType` ty
555 -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
556 [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1
557 , UnaryRep rep_ty2 <- repType ty2
558 -> case () of
559 _ | VoidRep <- typePrimRep rep_ty1
560 , let bind2 = bndr `setIdType` ty2
561 -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
562 | VoidRep <- typePrimRep rep_ty2
563 , let bind1 = bndr `setIdType` ty1
564 -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
565 | otherwise
566 -> Nothing
567 _ -> Nothing
568 = res
569
570 schemeE d s p (AnnCase scrut bndr _ alts)
571 = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
572
573 schemeE _ _ _ expr
574 = pprPanic "ByteCodeGen.schemeE: unhandled case"
575 (pprCoreExpr (deAnnotate' expr))
576
577 {-
578 Ticked Expressions
579 ------------------
580
581 The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
582 the code. When we find such a thing, we pull out the useful information,
583 and then compile the code as if it was just the expression E.
584
585 -}
586
587 -- Compile code to do a tail call. Specifically, push the fn,
588 -- slide the on-stack app back down to the sequel depth,
589 -- and enter. Four cases:
590 --
591 -- 0. (Nasty hack).
592 -- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
593 -- The int will be on the stack. Generate a code sequence
594 -- to convert it to the relevant constructor, SLIDE and ENTER.
595 --
596 -- 1. The fn denotes a ccall. Defer to generateCCall.
597 --
598 -- 2. (Another nasty hack). Spot (# a::V, b #) and treat
599 -- it simply as b -- since the representations are identical
600 -- (the V takes up zero stack space). Also, spot
601 -- (# b #) and treat it as b.
602 --
603 -- 3. Application of a constructor, by defn saturated.
604 -- Split the args into ptrs and non-ptrs, and push the nonptrs,
605 -- then the ptrs, and then do PACK and RETURN.
606 --
607 -- 4. Otherwise, it must be a function call. Push the args
608 -- right to left, SLIDE and ENTER.
609
610 schemeT :: Word -- Stack depth
611 -> Sequel -- Sequel depth
612 -> BCEnv -- stack env
613 -> AnnExpr' Id DVarSet
614 -> BcM BCInstrList
615
616 schemeT d s p app
617
618 -- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
619 -- = panic "schemeT ?!?!"
620
621 -- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
622 -- = error "?!?!"
623
624 -- Case 0
625 | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
626 = implement_tagToId d s p arg constr_names
627
628 -- Case 1
629 | Just (CCall ccall_spec) <- isFCallId_maybe fn
630 = if isSupportedCConv ccall_spec
631 then generateCCall d s p ccall_spec fn args_r_to_l
632 else unsupportedCConvException
633
634
635 -- Case 2: Constructor application
636 | Just con <- maybe_saturated_dcon,
637 isUnboxedTupleCon con
638 = case args_r_to_l of
639 [arg1,arg2] | isVAtom arg1 ->
640 unboxedTupleReturn d s p arg2
641 [arg1,arg2] | isVAtom arg2 ->
642 unboxedTupleReturn d s p arg1
643 _other -> unboxedTupleException
644
645 -- Case 3: Ordinary data constructor
646 | Just con <- maybe_saturated_dcon
647 = do alloc_con <- mkConAppCode d s p con args_r_to_l
648 return (alloc_con `appOL`
649 mkSLIDE 1 (d - s) `snocOL`
650 ENTER)
651
652 -- Case 4: Tail call of function
653 | otherwise
654 = doTailCall d s p fn args_r_to_l
655
656 where
657 -- Extract the args (R->L) and fn
658 -- The function will necessarily be a variable,
659 -- because we are compiling a tail call
660 (AnnVar fn, args_r_to_l) = splitApp app
661
662 -- Only consider this to be a constructor application iff it is
663 -- saturated. Otherwise, we'll call the constructor wrapper.
664 n_args = length args_r_to_l
665 maybe_saturated_dcon
666 = case isDataConWorkId_maybe fn of
667 Just con | dataConRepArity con == n_args -> Just con
668 _ -> Nothing
669
670 -- -----------------------------------------------------------------------------
671 -- Generate code to build a constructor application,
672 -- leaving it on top of the stack
673
674 mkConAppCode :: Word -> Sequel -> BCEnv
675 -> DataCon -- The data constructor
676 -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
677 -> BcM BCInstrList
678
679 mkConAppCode _ _ _ con [] -- Nullary constructor
680 = ASSERT( isNullaryRepDataCon con )
681 return (unitOL (PUSH_G (getName (dataConWorkId con))))
682 -- Instead of doing a PACK, which would allocate a fresh
683 -- copy of this constructor, use the single shared version.
684
685 mkConAppCode orig_d _ p con args_r_to_l
686 = ASSERT( dataConRepArity con == length args_r_to_l )
687 do_pushery orig_d (non_ptr_args ++ ptr_args)
688 where
689 -- The args are already in reverse order, which is the way PACK
690 -- expects them to be. We must push the non-ptrs after the ptrs.
691 (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
692
693 do_pushery d (arg:args)
694 = do (push, arg_words) <- pushAtom d p arg
695 more_push_code <- do_pushery (d + fromIntegral arg_words) args
696 return (push `appOL` more_push_code)
697 do_pushery d []
698 = return (unitOL (PACK con n_arg_words))
699 where
700 n_arg_words = trunc16 $ d - orig_d
701
702
703 -- -----------------------------------------------------------------------------
704 -- Returning an unboxed tuple with one non-void component (the only
705 -- case we can handle).
706 --
707 -- Remember, we don't want to *evaluate* the component that is being
708 -- returned, even if it is a pointed type. We always just return.
709
710 unboxedTupleReturn
711 :: Word -> Sequel -> BCEnv
712 -> AnnExpr' Id DVarSet -> BcM BCInstrList
713 unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
714
715 -- -----------------------------------------------------------------------------
716 -- Generate code for a tail-call
717
718 doTailCall
719 :: Word -> Sequel -> BCEnv
720 -> Id -> [AnnExpr' Id DVarSet]
721 -> BcM BCInstrList
722 doTailCall init_d s p fn args
723 = do_pushes init_d args (map atomRep args)
724 where
725 do_pushes d [] reps = do
726 ASSERT( null reps ) return ()
727 (push_fn, sz) <- pushAtom d p (AnnVar fn)
728 ASSERT( sz == 1 ) return ()
729 return (push_fn `appOL` (
730 mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
731 unitOL ENTER))
732 do_pushes d args reps = do
733 let (push_apply, n, rest_of_reps) = findPushSeq reps
734 (these_args, rest_of_args) = splitAt n args
735 (next_d, push_code) <- push_seq d these_args
736 instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
737 -- ^^^ for the PUSH_APPLY_ instruction
738 return (push_code `appOL` (push_apply `consOL` instrs))
739
740 push_seq d [] = return (d, nilOL)
741 push_seq d (arg:args) = do
742 (push_code, sz) <- pushAtom d p arg
743 (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
744 return (final_d, push_code `appOL` more_push_code)
745
746 -- v. similar to CgStackery.findMatch, ToDo: merge
747 findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
748 findPushSeq (P: P: P: P: P: P: rest)
749 = (PUSH_APPLY_PPPPPP, 6, rest)
750 findPushSeq (P: P: P: P: P: rest)
751 = (PUSH_APPLY_PPPPP, 5, rest)
752 findPushSeq (P: P: P: P: rest)
753 = (PUSH_APPLY_PPPP, 4, rest)
754 findPushSeq (P: P: P: rest)
755 = (PUSH_APPLY_PPP, 3, rest)
756 findPushSeq (P: P: rest)
757 = (PUSH_APPLY_PP, 2, rest)
758 findPushSeq (P: rest)
759 = (PUSH_APPLY_P, 1, rest)
760 findPushSeq (V: rest)
761 = (PUSH_APPLY_V, 1, rest)
762 findPushSeq (N: rest)
763 = (PUSH_APPLY_N, 1, rest)
764 findPushSeq (F: rest)
765 = (PUSH_APPLY_F, 1, rest)
766 findPushSeq (D: rest)
767 = (PUSH_APPLY_D, 1, rest)
768 findPushSeq (L: rest)
769 = (PUSH_APPLY_L, 1, rest)
770 findPushSeq _
771 = panic "ByteCodeGen.findPushSeq"
772
773 -- -----------------------------------------------------------------------------
774 -- Case expressions
775
776 doCase :: Word -> Sequel -> BCEnv
777 -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
778 -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
779 -> BcM BCInstrList
780 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
781 | UbxTupleRep _ <- repType (idType bndr)
782 = unboxedTupleException
783 | otherwise
784 = do
785 dflags <- getDynFlags
786 let
787 profiling
788 | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
789 | otherwise = rtsIsProfiled
790
791 -- Top of stack is the return itbl, as usual.
792 -- underneath it is the pointer to the alt_code BCO.
793 -- When an alt is entered, it assumes the returned value is
794 -- on top of the itbl.
795 ret_frame_sizeW :: Word
796 ret_frame_sizeW = 2
797
798 -- The extra frame we push to save/restor the CCCS when profiling
799 save_ccs_sizeW | profiling = 2
800 | otherwise = 0
801
802 -- An unlifted value gets an extra info table pushed on top
803 -- when it is returned.
804 unlifted_itbl_sizeW :: Word
805 unlifted_itbl_sizeW | isAlgCase = 0
806 | otherwise = 1
807
808 -- depth of stack after the return value has been pushed
809 d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
810
811 -- depth of stack after the extra info table for an unboxed return
812 -- has been pushed, if any. This is the stack depth at the
813 -- continuation.
814 d_alts = d_bndr + unlifted_itbl_sizeW
815
816 -- Env in which to compile the alts, not including
817 -- any vars bound by the alts themselves
818 d_bndr' = fromIntegral d_bndr - 1
819 p_alts0 = Map.insert bndr d_bndr' p
820 p_alts = case is_unboxed_tuple of
821 Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
822 Nothing -> p_alts0
823
824 bndr_ty = idType bndr
825 isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
826
827 -- given an alt, return a discr and code for it.
828 codeAlt (DEFAULT, _, (_,rhs))
829 = do rhs_code <- schemeE d_alts s p_alts rhs
830 return (NoDiscr, rhs_code)
831
832 codeAlt alt@(_, bndrs, (_,rhs))
833 -- primitive or nullary constructor alt: no need to UNPACK
834 | null real_bndrs = do
835 rhs_code <- schemeE d_alts s p_alts rhs
836 return (my_discr alt, rhs_code)
837 | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
838 = unboxedTupleException
839 -- algebraic alt with some binders
840 | otherwise =
841 let
842 (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
843 ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs
844 nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs
845 bind_sizes = ptr_sizes ++ nptrs_sizes
846 size = sum ptr_sizes + sum nptrs_sizes
847 -- the UNPACK instruction unpacks in reverse order...
848 p' = Map.insertList
849 (zip (reverse (ptrs ++ nptrs))
850 (mkStackOffsets d_alts (reverse bind_sizes)))
851 p_alts
852 in do
853 MASSERT(isAlgCase)
854 rhs_code <- schemeE (d_alts + size) s p' rhs
855 return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
856 where
857 real_bndrs = filterOut isTyVar bndrs
858
859 my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
860 my_discr (DataAlt dc, _, _)
861 | isUnboxedTupleCon dc
862 = unboxedTupleException
863 | otherwise
864 = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
865 my_discr (LitAlt l, _, _)
866 = case l of MachInt i -> DiscrI (fromInteger i)
867 MachWord w -> DiscrW (fromInteger w)
868 MachFloat r -> DiscrF (fromRational r)
869 MachDouble r -> DiscrD (fromRational r)
870 MachChar i -> DiscrI (ord i)
871 _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
872
873 maybe_ncons
874 | not isAlgCase = Nothing
875 | otherwise
876 = case [dc | (DataAlt dc, _, _) <- alts] of
877 [] -> Nothing
878 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
879
880 -- the bitmap is relative to stack depth d, i.e. before the
881 -- BCO, info table and return value are pushed on.
882 -- This bit of code is v. similar to buildLivenessMask in CgBindery,
883 -- except that here we build the bitmap from the known bindings of
884 -- things that are pointers, whereas in CgBindery the code builds the
885 -- bitmap from the free slots and unboxed bindings.
886 -- (ToDo: merge?)
887 --
888 -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
889 -- The bitmap must cover the portion of the stack up to the sequel only.
890 -- Previously we were building a bitmap for the whole depth (d), but we
891 -- really want a bitmap up to depth (d-s). This affects compilation of
892 -- case-of-case expressions, which is the only time we can be compiling a
893 -- case expression with s /= 0.
894 bitmap_size = trunc16 $ d-s
895 bitmap_size' :: Int
896 bitmap_size' = fromIntegral bitmap_size
897 bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
898 (sort (filter (< bitmap_size') rel_slots))
899 where
900 binds = Map.toList p
901 -- NB: unboxed tuple cases bind the scrut binder to the same offset
902 -- as one of the alt binders, so we have to remove any duplicates here:
903 rel_slots = nub $ map fromIntegral $ concat (map spread binds)
904 spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
905 | otherwise = []
906 where rel_offset = trunc16 $ d - fromIntegral offset - 1
907
908 alt_stuff <- mapM codeAlt alts
909 alt_final <- mkMultiBranch maybe_ncons alt_stuff
910
911 let
912 alt_bco_name = getName bndr
913 alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
914 0{-no arity-} bitmap_size bitmap True{-is alts-}
915 -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
916 -- "\n bitmap = " ++ show bitmap) $ do
917
918 scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
919 (d + ret_frame_sizeW + save_ccs_sizeW)
920 p scrut
921 alt_bco' <- emitBc alt_bco
922 let push_alts
923 | isAlgCase = PUSH_ALTS alt_bco'
924 | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
925 return (push_alts `consOL` scrut_code)
926
927
928 -- -----------------------------------------------------------------------------
929 -- Deal with a CCall.
930
931 -- Taggedly push the args onto the stack R->L,
932 -- deferencing ForeignObj#s and adjusting addrs to point to
933 -- payloads in Ptr/Byte arrays. Then, generate the marshalling
934 -- (machine) code for the ccall, and create bytecodes to call that and
935 -- then return in the right way.
936
937 generateCCall :: Word -> Sequel -- stack and sequel depths
938 -> BCEnv
939 -> CCallSpec -- where to call
940 -> Id -- of target, for type info
941 -> [AnnExpr' Id DVarSet] -- args (atoms)
942 -> BcM BCInstrList
943
944 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
945 = do
946 dflags <- getDynFlags
947
948 let
949 -- useful constants
950 addr_sizeW :: Word16
951 addr_sizeW = fromIntegral (argRepSizeW dflags N)
952
953 -- Get the args on the stack, with tags and suitably
954 -- dereferenced for the CCall. For each arg, return the
955 -- depth to the first word of the bits for that arg, and the
956 -- ArgRep of what was actually pushed.
957
958 pargs _ [] = return []
959 pargs d (a:az)
960 = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
961
962 in case tyConAppTyCon_maybe arg_ty of
963 -- Don't push the FO; instead push the Addr# it
964 -- contains.
965 Just t
966 | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
967 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
968 code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
969 return ((code,AddrRep):rest)
970
971 | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
972 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
973 code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
974 return ((code,AddrRep):rest)
975
976 | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
977 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
978 code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
979 return ((code,AddrRep):rest)
980
981 -- Default case: push taggedly, but otherwise intact.
982 _
983 -> do (code_a, sz_a) <- pushAtom d p a
984 rest <- pargs (d + fromIntegral sz_a) az
985 return ((code_a, atomPrimRep a) : rest)
986
987 -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
988 -- the stack but then advance it over the headers, so as to
989 -- point to the payload.
990 parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
991 -> BcM BCInstrList
992 parg_ArrayishRep hdrSize d p a
993 = do (push_fo, _) <- pushAtom d p a
994 -- The ptr points at the header. Advance it over the
995 -- header and then pretend this is an Addr#.
996 return (push_fo `snocOL` SWIZZLE 0 hdrSize)
997
998 code_n_reps <- pargs d0 args_r_to_l
999 let
1000 (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
1001 a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
1002
1003 push_args = concatOL pushs_arg
1004 d_after_args = d0 + a_reps_sizeW
1005 a_reps_pushed_RAW
1006 | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
1007 = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
1008 | otherwise
1009 = reverse (tail a_reps_pushed_r_to_l)
1010
1011 -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
1012 -- push_args is the code to do that.
1013 -- d_after_args is the stack depth once the args are on.
1014
1015 -- Get the result rep.
1016 (returns_void, r_rep)
1017 = case maybe_getCCallReturnRep (idType fn) of
1018 Nothing -> (True, VoidRep)
1019 Just rr -> (False, rr)
1020 {-
1021 Because the Haskell stack grows down, the a_reps refer to
1022 lowest to highest addresses in that order. The args for the call
1023 are on the stack. Now push an unboxed Addr# indicating
1024 the C function to call. Then push a dummy placeholder for the
1025 result. Finally, emit a CCALL insn with an offset pointing to the
1026 Addr# just pushed, and a literal field holding the mallocville
1027 address of the piece of marshalling code we generate.
1028 So, just prior to the CCALL insn, the stack looks like this
1029 (growing down, as usual):
1030
1031 <arg_n>
1032 ...
1033 <arg_1>
1034 Addr# address_of_C_fn
1035 <placeholder-for-result#> (must be an unboxed type)
1036
1037 The interpreter then calls the marshall code mentioned
1038 in the CCALL insn, passing it (& <placeholder-for-result#>),
1039 that is, the addr of the topmost word in the stack.
1040 When this returns, the placeholder will have been
1041 filled in. The placeholder is slid down to the sequel
1042 depth, and we RETURN.
1043
1044 This arrangement makes it simple to do f-i-dynamic since the Addr#
1045 value is the first arg anyway.
1046
1047 The marshalling code is generated specifically for this
1048 call site, and so knows exactly the (Haskell) stack
1049 offsets of the args, fn address and placeholder. It
1050 copies the args to the C stack, calls the stacked addr,
1051 and parks the result back in the placeholder. The interpreter
1052 calls it as a normal C call, assuming it has a signature
1053 void marshall_code ( StgWord* ptr_to_top_of_stack )
1054 -}
1055 -- resolve static address
1056 maybe_static_target =
1057 case target of
1058 DynamicTarget -> Nothing
1059 StaticTarget _ _ _ False ->
1060 panic "generateCCall: unexpected FFI value import"
1061 StaticTarget _ target _ True ->
1062 Just (MachLabel target mb_size IsFunction)
1063 where
1064 mb_size
1065 | OSMinGW32 <- platformOS (targetPlatform dflags)
1066 , StdCallConv <- cconv
1067 = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
1068 | otherwise
1069 = Nothing
1070
1071 let
1072 is_static = isJust maybe_static_target
1073
1074 -- Get the arg reps, zapping the leading Addr# in the dynamic case
1075 a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
1076 | is_static = a_reps_pushed_RAW
1077 | otherwise = if null a_reps_pushed_RAW
1078 then panic "ByteCodeGen.generateCCall: dyn with no args"
1079 else tail a_reps_pushed_RAW
1080
1081 -- push the Addr#
1082 (push_Addr, d_after_Addr)
1083 | Just machlabel <- maybe_static_target
1084 = (toOL [PUSH_UBX machlabel addr_sizeW],
1085 d_after_args + fromIntegral addr_sizeW)
1086 | otherwise -- is already on the stack
1087 = (nilOL, d_after_args)
1088
1089 -- Push the return placeholder. For a call returning nothing,
1090 -- this is a V (tag).
1091 r_sizeW = fromIntegral (primRepSizeW dflags r_rep)
1092 d_after_r = d_after_Addr + fromIntegral r_sizeW
1093 r_lit = mkDummyLiteral r_rep
1094 push_r = (if returns_void
1095 then nilOL
1096 else unitOL (PUSH_UBX r_lit r_sizeW))
1097
1098 -- generate the marshalling code we're going to call
1099
1100 -- Offset of the next stack frame down the stack. The CCALL
1101 -- instruction needs to describe the chunk of stack containing
1102 -- the ccall args to the GC, so it needs to know how large it
1103 -- is. See comment in Interpreter.c with the CCALL instruction.
1104 stk_offset = trunc16 $ d_after_r - s
1105
1106 conv = case cconv of
1107 CCallConv -> FFICCall
1108 StdCallConv -> FFIStdCall
1109 _ -> panic "ByteCodeGen: unexpected calling convention"
1110
1111 -- the only difference in libffi mode is that we prepare a cif
1112 -- describing the call type by calling libffi, and we attach the
1113 -- address of this to the CCALL instruction.
1114
1115
1116 let ffires = primRepToFFIType dflags r_rep
1117 ffiargs = map (primRepToFFIType dflags) a_reps
1118 hsc_env <- getHscEnv
1119 token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
1120 recordFFIBc token
1121
1122 let
1123 -- do the call
1124 do_call = unitOL (CCALL stk_offset token
1125 (fromIntegral (fromEnum (playInterruptible safety))))
1126 -- slide and return
1127 wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
1128 `snocOL` RETURN_UBX (toArgRep r_rep)
1129 --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
1130 return (
1131 push_args `appOL`
1132 push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
1133 )
1134
1135 primRepToFFIType :: DynFlags -> PrimRep -> FFIType
1136 primRepToFFIType dflags r
1137 = case r of
1138 VoidRep -> FFIVoid
1139 IntRep -> signed_word
1140 WordRep -> unsigned_word
1141 Int64Rep -> FFISInt64
1142 Word64Rep -> FFIUInt64
1143 AddrRep -> FFIPointer
1144 FloatRep -> FFIFloat
1145 DoubleRep -> FFIDouble
1146 _ -> panic "primRepToFFIType"
1147 where
1148 (signed_word, unsigned_word)
1149 | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32)
1150 | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64)
1151 | otherwise = panic "primTyDescChar"
1152
1153 -- Make a dummy literal, to be used as a placeholder for FFI return
1154 -- values on the stack.
1155 mkDummyLiteral :: PrimRep -> Literal
1156 mkDummyLiteral pr
1157 = case pr of
1158 IntRep -> MachInt 0
1159 WordRep -> MachWord 0
1160 AddrRep -> MachNullAddr
1161 DoubleRep -> MachDouble 0
1162 FloatRep -> MachFloat 0
1163 Int64Rep -> MachInt64 0
1164 Word64Rep -> MachWord64 0
1165 _ -> panic "mkDummyLiteral"
1166
1167
1168 -- Convert (eg)
1169 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1170 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
1171 --
1172 -- to Just IntRep
1173 -- and check that an unboxed pair is returned wherein the first arg is V'd.
1174 --
1175 -- Alternatively, for call-targets returning nothing, convert
1176 --
1177 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1178 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
1179 --
1180 -- to Nothing
1181
1182 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
1183 maybe_getCCallReturnRep fn_ty
1184 = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
1185 maybe_r_rep_to_go
1186 = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
1187 r_reps = case repType r_ty of
1188 UbxTupleRep reps -> map typePrimRep reps
1189 UnaryRep _ -> blargh
1190 ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
1191 || r_reps == [VoidRep] )
1192 && case maybe_r_rep_to_go of
1193 Nothing -> True
1194 Just r_rep -> r_rep /= PtrRep
1195 -- if it was, it would be impossible
1196 -- to create a valid return value
1197 -- placeholder on the stack
1198
1199 blargh :: a -- Used at more than one type
1200 blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1201 (pprType fn_ty)
1202 in
1203 --trace (showSDoc (ppr (a_reps, r_reps))) $
1204 if ok then maybe_r_rep_to_go else blargh
1205
1206 maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
1207 -- Detect and extract relevant info for the tagToEnum kludge.
1208 maybe_is_tagToEnum_call app
1209 | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
1210 , Just TagToEnumOp <- isPrimOpId_maybe v
1211 = Just (snd arg, extract_constr_Names t)
1212 | otherwise
1213 = Nothing
1214 where
1215 extract_constr_Names ty
1216 | UnaryRep rep_ty <- repType ty
1217 , Just tyc <- tyConAppTyCon_maybe rep_ty,
1218 isDataTyCon tyc
1219 = map (getName . dataConWorkId) (tyConDataCons tyc)
1220 -- NOTE: use the worker name, not the source name of
1221 -- the DataCon. See DataCon.hs for details.
1222 | otherwise
1223 = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
1224
1225 {- -----------------------------------------------------------------------------
1226 Note [Implementing tagToEnum#]
1227 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1228 (implement_tagToId arg names) compiles code which takes an argument
1229 'arg', (call it i), and enters the i'th closure in the supplied list
1230 as a consequence. The [Name] is a list of the constructors of this
1231 (enumeration) type.
1232
1233 The code we generate is this:
1234 push arg
1235 push bogus-word
1236
1237 TESTEQ_I 0 L1
1238 PUSH_G <lbl for first data con>
1239 JMP L_Exit
1240
1241 L1: TESTEQ_I 1 L2
1242 PUSH_G <lbl for second data con>
1243 JMP L_Exit
1244 ...etc...
1245 Ln: TESTEQ_I n L_fail
1246 PUSH_G <lbl for last data con>
1247 JMP L_Exit
1248
1249 L_fail: CASEFAIL
1250
1251 L_exit: SLIDE 1 n
1252 ENTER
1253
1254 The 'bogus-word' push is because TESTEQ_I expects the top of the stack
1255 to have an info-table, and the next word to have the value to be
1256 tested. This is very weird, but it's the way it is right now. See
1257 Interpreter.c. We don't acutally need an info-table here; we just
1258 need to have the argument to be one-from-top on the stack, hence pushing
1259 a 1-word null. See Trac #8383.
1260 -}
1261
1262
1263 implement_tagToId :: Word -> Sequel -> BCEnv
1264 -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
1265 -- See Note [Implementing tagToEnum#]
1266 implement_tagToId d s p arg names
1267 = ASSERT( notNull names )
1268 do (push_arg, arg_words) <- pushAtom d p arg
1269 labels <- getLabelsBc (genericLength names)
1270 label_fail <- getLabelBc
1271 label_exit <- getLabelBc
1272 let infos = zip4 labels (tail labels ++ [label_fail])
1273 [0 ..] names
1274 steps = map (mkStep label_exit) infos
1275
1276 return (push_arg
1277 `appOL` unitOL (PUSH_UBX MachNullAddr 1)
1278 -- Push bogus word (see Note [Implementing tagToEnum#])
1279 `appOL` concatOL steps
1280 `appOL` toOL [ LABEL label_fail, CASEFAIL,
1281 LABEL label_exit ]
1282 `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)
1283 -- "+1" to account for bogus word
1284 -- (see Note [Implementing tagToEnum#])
1285 `appOL` unitOL ENTER)
1286 where
1287 mkStep l_exit (my_label, next_label, n, name_for_n)
1288 = toOL [LABEL my_label,
1289 TESTEQ_I n next_label,
1290 PUSH_G name_for_n,
1291 JMP l_exit]
1292
1293
1294 -- -----------------------------------------------------------------------------
1295 -- pushAtom
1296
1297 -- Push an atom onto the stack, returning suitable code & number of
1298 -- stack words used.
1299 --
1300 -- The env p must map each variable to the highest- numbered stack
1301 -- slot for it. For example, if the stack has depth 4 and we
1302 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1303 -- the tag in stack[5], the stack will have depth 6, and p must map v
1304 -- to 5 and not to 4. Stack locations are numbered from zero, so a
1305 -- depth 6 stack has valid words 0 .. 5.
1306
1307 pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
1308
1309 pushAtom d p e
1310 | Just e' <- bcView e
1311 = pushAtom d p e'
1312
1313 pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
1314 = return (nilOL, 0) -- treated just like a variable V
1315
1316 pushAtom d p (AnnVar v)
1317 | UnaryRep rep_ty <- repType (idType v)
1318 , V <- typeArgRep rep_ty
1319 = return (nilOL, 0)
1320
1321 | isFCallId v
1322 = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1323
1324 | Just primop <- isPrimOpId_maybe v
1325 = return (unitOL (PUSH_PRIMOP primop), 1)
1326
1327 | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
1328 = do dflags <- getDynFlags
1329 let sz :: Word16
1330 sz = fromIntegral (idSizeW dflags v)
1331 l = trunc16 $ d - d_v + fromIntegral sz - 2
1332 return (toOL (genericReplicate sz (PUSH_L l)), sz)
1333 -- d - d_v the number of words between the TOS
1334 -- and the 1st slot of the object
1335 --
1336 -- d - d_v - 1 the offset from the TOS of the 1st slot
1337 --
1338 -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
1339 -- of the object.
1340 --
1341 -- Having found the last slot, we proceed to copy the right number of
1342 -- slots on to the top of the stack.
1343
1344 | otherwise -- v must be a global variable
1345 = do dflags <- getDynFlags
1346 let sz :: Word16
1347 sz = fromIntegral (idSizeW dflags v)
1348 MASSERT(sz == 1)
1349 return (unitOL (PUSH_G (getName v)), sz)
1350
1351
1352 pushAtom _ _ (AnnLit lit) = do
1353 dflags <- getDynFlags
1354 let code rep
1355 = let size_host_words = fromIntegral (argRepSizeW dflags rep)
1356 in return (unitOL (PUSH_UBX lit size_host_words),
1357 size_host_words)
1358
1359 case lit of
1360 MachLabel _ _ _ -> code N
1361 MachWord _ -> code N
1362 MachInt _ -> code N
1363 MachWord64 _ -> code L
1364 MachInt64 _ -> code L
1365 MachFloat _ -> code F
1366 MachDouble _ -> code D
1367 MachChar _ -> code N
1368 MachNullAddr -> code N
1369 MachStr _ -> code N
1370 -- No LitInteger's should be left by the time this is called.
1371 -- CorePrep should have converted them all to a real core
1372 -- representation.
1373 LitInteger {} -> panic "pushAtom: LitInteger"
1374
1375 pushAtom _ _ expr
1376 = pprPanic "ByteCodeGen.pushAtom"
1377 (pprCoreExpr (deAnnotate (undefined, expr)))
1378
1379
1380 -- -----------------------------------------------------------------------------
1381 -- Given a bunch of alts code and their discrs, do the donkey work
1382 -- of making a multiway branch using a switch tree.
1383 -- What a load of hassle!
1384
1385 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
1386 -- a hint; generates better code
1387 -- Nothing is always safe
1388 -> [(Discr, BCInstrList)]
1389 -> BcM BCInstrList
1390 mkMultiBranch maybe_ncons raw_ways = do
1391 lbl_default <- getLabelBc
1392
1393 let
1394 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1395 mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
1396 -- shouldn't happen?
1397
1398 mkTree [val] range_lo range_hi
1399 | range_lo == range_hi
1400 = return (snd val)
1401 | null defaults -- Note [CASEFAIL]
1402 = do lbl <- getLabelBc
1403 return (testEQ (fst val) lbl
1404 `consOL` (snd val
1405 `appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
1406 | otherwise
1407 = return (testEQ (fst val) lbl_default `consOL` snd val)
1408
1409 -- Note [CASEFAIL] It may be that this case has no default
1410 -- branch, but the alternatives are not exhaustive - this
1411 -- happens for GADT cases for example, where the types
1412 -- prove that certain branches are impossible. We could
1413 -- just assume that the other cases won't occur, but if
1414 -- this assumption was wrong (because of a bug in GHC)
1415 -- then the result would be a segfault. So instead we
1416 -- emit an explicit test and a CASEFAIL instruction that
1417 -- causes the interpreter to barf() if it is ever
1418 -- executed.
1419
1420 mkTree vals range_lo range_hi
1421 = let n = length vals `div` 2
1422 vals_lo = take n vals
1423 vals_hi = drop n vals
1424 v_mid = fst (head vals_hi)
1425 in do
1426 label_geq <- getLabelBc
1427 code_lo <- mkTree vals_lo range_lo (dec v_mid)
1428 code_hi <- mkTree vals_hi v_mid range_hi
1429 return (testLT v_mid label_geq
1430 `consOL` (code_lo
1431 `appOL` unitOL (LABEL label_geq)
1432 `appOL` code_hi))
1433
1434 the_default
1435 = case defaults of
1436 [] -> nilOL
1437 [(_, def)] -> LABEL lbl_default `consOL` def
1438 _ -> panic "mkMultiBranch/the_default"
1439 instrs <- mkTree notd_ways init_lo init_hi
1440 return (instrs `appOL` the_default)
1441 where
1442 (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
1443 notd_ways = sortBy (comparing fst) not_defaults
1444
1445 testLT (DiscrI i) fail_label = TESTLT_I i fail_label
1446 testLT (DiscrW i) fail_label = TESTLT_W i fail_label
1447 testLT (DiscrF i) fail_label = TESTLT_F i fail_label
1448 testLT (DiscrD i) fail_label = TESTLT_D i fail_label
1449 testLT (DiscrP i) fail_label = TESTLT_P i fail_label
1450 testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
1451
1452 testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
1453 testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
1454 testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
1455 testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
1456 testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
1457 testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
1458
1459 -- None of these will be needed if there are no non-default alts
1460 (init_lo, init_hi)
1461 | null notd_ways
1462 = panic "mkMultiBranch: awesome foursome"
1463 | otherwise
1464 = case fst (head notd_ways) of
1465 DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
1466 DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
1467 DiscrF _ -> ( DiscrF minF, DiscrF maxF )
1468 DiscrD _ -> ( DiscrD minD, DiscrD maxD )
1469 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
1470 NoDiscr -> panic "mkMultiBranch NoDiscr"
1471
1472 (algMinBound, algMaxBound)
1473 = case maybe_ncons of
1474 -- XXX What happens when n == 0?
1475 Just n -> (0, fromIntegral n - 1)
1476 Nothing -> (minBound, maxBound)
1477
1478 isNoDiscr NoDiscr = True
1479 isNoDiscr _ = False
1480
1481 dec (DiscrI i) = DiscrI (i-1)
1482 dec (DiscrW w) = DiscrW (w-1)
1483 dec (DiscrP i) = DiscrP (i-1)
1484 dec other = other -- not really right, but if you
1485 -- do cases on floating values, you'll get what you deserve
1486
1487 -- same snotty comment applies to the following
1488 minF, maxF :: Float
1489 minD, maxD :: Double
1490 minF = -1.0e37
1491 maxF = 1.0e37
1492 minD = -1.0e308
1493 maxD = 1.0e308
1494
1495
1496 -- -----------------------------------------------------------------------------
1497 -- Supporting junk for the compilation schemes
1498
1499 -- Describes case alts
1500 data Discr
1501 = DiscrI Int
1502 | DiscrW Word
1503 | DiscrF Float
1504 | DiscrD Double
1505 | DiscrP Word16
1506 | NoDiscr
1507 deriving (Eq, Ord)
1508
1509 instance Outputable Discr where
1510 ppr (DiscrI i) = int i
1511 ppr (DiscrW w) = text (show w)
1512 ppr (DiscrF f) = text (show f)
1513 ppr (DiscrD d) = text (show d)
1514 ppr (DiscrP i) = ppr i
1515 ppr NoDiscr = text "DEF"
1516
1517
1518 lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
1519 lookupBCEnv_maybe = Map.lookup
1520
1521 idSizeW :: DynFlags -> Id -> Int
1522 idSizeW dflags = argRepSizeW dflags . bcIdArgRep
1523
1524 bcIdArgRep :: Id -> ArgRep
1525 bcIdArgRep = toArgRep . bcIdPrimRep
1526
1527 bcIdPrimRep :: Id -> PrimRep
1528 bcIdPrimRep = typePrimRep . bcIdUnaryType
1529
1530 isFollowableArg :: ArgRep -> Bool
1531 isFollowableArg P = True
1532 isFollowableArg _ = False
1533
1534 isVoidArg :: ArgRep -> Bool
1535 isVoidArg V = True
1536 isVoidArg _ = False
1537
1538 bcIdUnaryType :: Id -> UnaryType
1539 bcIdUnaryType x = case repType (idType x) of
1540 UnaryRep rep_ty -> rep_ty
1541 UbxTupleRep [rep_ty] -> rep_ty
1542 UbxTupleRep [rep_ty1, rep_ty2]
1543 | VoidRep <- typePrimRep rep_ty1 -> rep_ty2
1544 | VoidRep <- typePrimRep rep_ty2 -> rep_ty1
1545 _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
1546
1547 -- See bug #1257
1548 unboxedTupleException :: a
1549 unboxedTupleException = throwGhcException (ProgramError
1550 ("Error: bytecode compiler can't handle unboxed tuples.\n"++
1551 " Possibly due to foreign import/export decls in source.\n"++
1552 " Workaround: use -fobject-code, or compile this module to .o separately."))
1553
1554 -- | Indicate if the calling convention is supported
1555 isSupportedCConv :: CCallSpec -> Bool
1556 isSupportedCConv (CCallSpec _ cconv _) = case cconv of
1557 CCallConv -> True -- we explicitly pattern match on every
1558 StdCallConv -> True -- convention to ensure that a warning
1559 PrimCallConv -> False -- is triggered when a new one is added
1560 JavaScriptCallConv -> False
1561 CApiConv -> False
1562
1563 -- See bug #10462
1564 unsupportedCConvException :: a
1565 unsupportedCConvException = throwGhcException (ProgramError
1566 ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
1567 " Workaround: use -fobject-code, or compile this module to .o separately."))
1568
1569 mkSLIDE :: Word16 -> Word -> OrdList BCInstr
1570 mkSLIDE n d
1571 -- if the amount to slide doesn't fit in a word,
1572 -- generate multiple slide instructions
1573 | d > fromIntegral limit
1574 = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
1575 | d == 0
1576 = nilOL
1577 | otherwise
1578 = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
1579 where
1580 limit :: Word16
1581 limit = maxBound
1582
1583 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
1584 -- The arguments are returned in *right-to-left* order
1585 splitApp e | Just e' <- bcView e = splitApp e'
1586 splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
1587 (f', as) -> (f', a:as)
1588 splitApp e = (e, [])
1589
1590
1591 bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
1592 -- The "bytecode view" of a term discards
1593 -- a) type abstractions
1594 -- b) type applications
1595 -- c) casts
1596 -- d) ticks (but not breakpoints)
1597 -- Type lambdas *can* occur in random expressions,
1598 -- whereas value lambdas cannot; that is why they are nuked here
1599 bcView (AnnCast (_,e) _) = Just e
1600 bcView (AnnLam v (_,e)) | isTyVar v = Just e
1601 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
1602 bcView (AnnTick Breakpoint{} _) = Nothing
1603 bcView (AnnTick _other_tick (_,e)) = Just e
1604 bcView _ = Nothing
1605
1606 isVAtom :: AnnExpr' Var ann -> Bool
1607 isVAtom e | Just e' <- bcView e = isVAtom e'
1608 isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
1609 isVAtom (AnnCoercion {}) = True
1610 isVAtom _ = False
1611
1612 atomPrimRep :: AnnExpr' Id ann -> PrimRep
1613 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
1614 atomPrimRep (AnnVar v) = bcIdPrimRep v
1615 atomPrimRep (AnnLit l) = typePrimRep (literalType l)
1616 atomPrimRep (AnnCoercion {}) = VoidRep
1617 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
1618
1619 atomRep :: AnnExpr' Id ann -> ArgRep
1620 atomRep e = toArgRep (atomPrimRep e)
1621
1622 isPtrAtom :: AnnExpr' Id ann -> Bool
1623 isPtrAtom e = isFollowableArg (atomRep e)
1624
1625 -- Let szsw be the sizes in words of some items pushed onto the stack,
1626 -- which has initial depth d'. Return the values which the stack environment
1627 -- should map these items to.
1628 mkStackOffsets :: Word -> [Word] -> [Word]
1629 mkStackOffsets original_depth szsw
1630 = map (subtract 1) (tail (scanl (+) original_depth szsw))
1631
1632 typeArgRep :: Type -> ArgRep
1633 typeArgRep = toArgRep . typePrimRep
1634
1635 -- -----------------------------------------------------------------------------
1636 -- The bytecode generator's monad
1637
1638 data BcM_State
1639 = BcM_State
1640 { bcm_hsc_env :: HscEnv
1641 , uniqSupply :: UniqSupply -- for generating fresh variable names
1642 , thisModule :: Module -- current module (for breakpoints)
1643 , nextlabel :: Word16 -- for generating local labels
1644 , ffis :: [FFIInfo] -- ffi info blocks, to free later
1645 -- Should be free()d when it is GCd
1646 , modBreaks :: Maybe ModBreaks -- info about breakpoints
1647 , breakInfo :: IntMap CgBreakInfo
1648 }
1649
1650 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1651
1652 ioToBc :: IO a -> BcM a
1653 ioToBc io = BcM $ \st -> do
1654 x <- io
1655 return (st, x)
1656
1657 runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
1658 -> IO (BcM_State, r)
1659 runBc hsc_env us this_mod modBreaks (BcM m)
1660 = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
1661
1662 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1663 thenBc (BcM expr) cont = BcM $ \st0 -> do
1664 (st1, q) <- expr st0
1665 let BcM k = cont q
1666 (st2, r) <- k st1
1667 return (st2, r)
1668
1669 thenBc_ :: BcM a -> BcM b -> BcM b
1670 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1671 (st1, _) <- expr st0
1672 (st2, r) <- cont st1
1673 return (st2, r)
1674
1675 returnBc :: a -> BcM a
1676 returnBc result = BcM $ \st -> (return (st, result))
1677
1678 instance Functor BcM where
1679 fmap = liftM
1680
1681 instance Applicative BcM where
1682 pure = returnBc
1683 (<*>) = ap
1684 (*>) = thenBc_
1685
1686 instance Monad BcM where
1687 (>>=) = thenBc
1688 (>>) = (*>)
1689
1690 instance HasDynFlags BcM where
1691 getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
1692
1693 getHscEnv :: BcM HscEnv
1694 getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
1695
1696 emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1697 emitBc bco
1698 = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
1699
1700 recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
1701 recordFFIBc a
1702 = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
1703
1704 getLabelBc :: BcM Word16
1705 getLabelBc
1706 = BcM $ \st -> do let nl = nextlabel st
1707 when (nl == maxBound) $
1708 panic "getLabelBc: Ran out of labels"
1709 return (st{nextlabel = nl + 1}, nl)
1710
1711 getLabelsBc :: Word16 -> BcM [Word16]
1712 getLabelsBc n
1713 = BcM $ \st -> let ctr = nextlabel st
1714 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1715
1716 getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
1717 getCCArray = BcM $ \st ->
1718 let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
1719 return (st, modBreaks_ccs breaks)
1720
1721
1722 newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
1723 newBreakInfo ix info = BcM $ \st ->
1724 return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
1725
1726 newUnique :: BcM Unique
1727 newUnique = BcM $
1728 \st -> case takeUniqFromSupply (uniqSupply st) of
1729 (uniq, us) -> let newState = st { uniqSupply = us }
1730 in return (newState, uniq)
1731
1732 getCurrentModule :: BcM Module
1733 getCurrentModule = BcM $ \st -> return (st, thisModule st)
1734
1735 newId :: Type -> BcM Id
1736 newId ty = do
1737 uniq <- newUnique
1738 return $ mkSysLocal tickFS uniq ty
1739
1740 tickFS :: FastString
1741 tickFS = fsLit "ticked"