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