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