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