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