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