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