ByteCodeGen.hs 64 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash #-}
2 3 4 5 6
--
--  (c) The University of Glasgow 2002-2006
--

-- | ByteCodeGen: Generate bytecode from Core
7
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
8 9 10

#include "HsVersions.h"

11
import ByteCodeInstr
12
import ByteCodeItbls
13 14
import ByteCodeAsm
import ByteCodeLink
15
import LibFFI
16

ian@well-typed.com's avatar
ian@well-typed.com committed
17
import DynFlags
18
import Outputable
ian@well-typed.com's avatar
ian@well-typed.com committed
19
import Platform
20
import Name
21
import MkId
22
import Id
23 24 25
import ForeignCall
import HscTypes
import CoreUtils
26
import CoreSyn
27 28 29 30 31 32 33
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
import DataCon
import TyCon
34
import Util
35 36 37 38 39 40
import VarSet
import TysPrim
import ErrUtils
import Unique
import FastString
import Panic
Simon Marlow's avatar
Simon Marlow committed
41
import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
42 43
import SMRep
import Bitmap
44
import OrdList
45

Ian Lynagh's avatar
Ian Lynagh committed
46
import Data.List
47
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
48
import Foreign.C
49

50
#if __GLASGOW_HASKELL__ < 709
Austin Seipp's avatar
Austin Seipp committed
51
import Control.Applicative (Applicative(..))
52
#endif
Ian Lynagh's avatar
Ian Lynagh committed
53
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
54
import Data.Char
55

56 57 58
import UniqSupply
import BreakArray
import Data.Maybe
59
import Module
60

61 62
import qualified Data.ByteString        as BS
import qualified Data.ByteString.Unsafe as BS
63 64 65
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
66
import Data.Ord
67

68
-- -----------------------------------------------------------------------------
69
-- Generating byte code for a complete module
70

71
byteCodeGen :: DynFlags
72
            -> Module
73
            -> CoreProgram
74 75
            -> [TyCon]
            -> ModBreaks
76
            -> IO CompiledByteCode
77
byteCodeGen dflags this_mod binds tycs modBreaks
78 79
   = do showPass dflags "ByteCodeGen"

80 81
        let flatBinds = [ (bndr, freeVars rhs)
                        | (bndr, rhs) <- flattenBinds binds]
82

83
        us <- mkSplitUniqSupply 'y'
84 85
        (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
           <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
86

sof's avatar
sof committed
87
        when (notNull mallocd)
88 89
             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")

90
        dumpIfSet_dyn dflags Opt_D_dump_BCOs
91
           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
92

93
        assembleBCOs dflags proto_bcos tycs
94

95 96
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
97

98
-- Returns: (the root BCO for this expression,
99 100
--           a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
101
               -> Module
102
               -> CoreExpr
103
               -> IO UnlinkedBCO
104
coreExprToBCOs dflags this_mod expr
105
 = do showPass dflags "ByteCodeGen"
106 107 108

      -- create a totally bogus name for the top-level BCO; this
      -- should be harmless, since it's never used for anything
Ian Lynagh's avatar
Ian Lynagh committed
109
      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
110
          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
111

112 113 114
      -- the uniques are needed to generate fresh variables when we introduce new
      -- let bindings for ticked expressions
      us <- mkSplitUniqSupply 'y'
115 116
      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
         <- runBc dflags us this_mod emptyModBreaks $
117
              schemeTopBind (invented_id, freeVars expr)
118

sof's avatar
sof committed
119
      when (notNull mallocd)
120 121
           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

122
      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
123

124
      assembleBCO dflags proto_bco
125 126


127 128
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
129 130 131

type BCInstrList = OrdList BCInstr

pcapriotti's avatar
pcapriotti committed
132
type Sequel = Word -- back off to this depth before ENTER
133 134 135

-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
pcapriotti's avatar
pcapriotti committed
136
type BCEnv = Map Id Word -- To find vars on the stack
137

Ian Lynagh's avatar
Ian Lynagh committed
138
{-
139 140 141
ppBCEnv :: BCEnv -> SDoc
ppBCEnv p
   = text "begin-env"
142
     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
143 144
     $$ text "end-env"
     where
Simon Marlow's avatar
Simon Marlow committed
145
        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
146
        cmp_snd x y = compare (snd x) (snd y)
Ian Lynagh's avatar
Ian Lynagh committed
147
-}
148

149 150
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
151
mkProtoBCO
152 153
   :: DynFlags
   -> name
154 155 156
   -> BCInstrList
   -> Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet)
   -> Int
157
   -> Word16
158
   -> [StgWord]
159
   -> Bool      -- True <=> is a return point, rather than a function
160
   -> [BcPtr]
161
   -> ProtoBCO name
162
mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
163
   = ProtoBCO {
164
        protoBCOName = nm,
165
        protoBCOInstrs = maybe_with_stack_check,
166 167 168 169 170
        protoBCOBitmap = bitmap,
        protoBCOBitmapSize = bitmap_size,
        protoBCOArity = arity,
        protoBCOExpr = origin,
        protoBCOPtrs = mallocd_blocks
171
      }
172
     where
173 174 175 176
        -- Overestimate the stack usage (in words) of this BCO,
        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
        -- stack check.  (The interpreter always does a stack check
        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
Thomas Schilling's avatar
Thomas Schilling committed
177
        -- BCO anyway, so we only need to add an explicit one in the
178 179
        -- (hopefully rare) cases when the (overestimated) stack use
        -- exceeds iNTERP_STACK_CHECK_THRESH.
180
        maybe_with_stack_check
181
           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
182 183 184
                -- don't do stack checks at return points,
                -- everything is aggregated up to the top BCO
                -- (which must be a function).
185 186
                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
                -- see bug #1466.
187
           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
188
           = STKCHECK stack_usage : peep_d
189
           | otherwise
190 191
           = peep_d     -- the supposedly common case

192
        -- We assume that this sum doesn't wrap
193
        stack_usage = sum (map bciStackUse peep_d)
194 195 196 197

        -- Merge local pushes
        peep_d = peep (fromOL instrs_ordlist)

198 199 200
        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
        peep (PUSH_L off1 : PUSH_L off2 : rest)
201
           = PUSH_LL off1 (off2-1) : peep rest
202 203 204 205 206
        peep (i:rest)
           = i : peep rest
        peep []
           = []

Simon Marlow's avatar
Simon Marlow committed
207
argBits :: DynFlags -> [ArgRep] -> [Bool]
208 209
argBits _      [] = []
argBits dflags (rep : args)
Simon Marlow's avatar
Simon Marlow committed
210 211
  | isFollowableArg rep  = False : argBits dflags args
  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
212

213 214 215 216 217 218 219 220
-- -----------------------------------------------------------------------------
-- schemeTopBind

-- Compile code for the right-hand side of a top-level binding

schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)


221
schemeTopBind (id, rhs)
222
  | Just data_con <- isDataConWorkId_maybe id,
223
    isNullaryRepDataCon data_con = do
224
    dflags <- getDynFlags
225 226 227 228 229 230 231
        -- Special case for the worker of a nullary data con.
        -- It'll look like this:        Nil = /\a -> Nil a
        -- If we feed it into schemeR, we'll get
        --      Nil = Nil
        -- because mkConAppCode treats nullary constructor applications
        -- by just re-using the single top-level definition.  So
        -- for the worker itself, we must allocate it directly.
232
    -- ioToBc (putStrLn $ "top level BCO")
233
    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
234
                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
235 236 237 238

  | otherwise
  = schemeR [{- No free variables -}] (id, rhs)

239

240 241
-- -----------------------------------------------------------------------------
-- schemeR
242

243 244 245 246 247
-- Compile code for a right-hand side, to give a BCO that,
-- when executed with the free variables and arguments on top of the stack,
-- will return with a pointer to the result on top of the stack, after
-- removing the free variables and arguments.
--
248 249
-- Park the resulting BCO in the monad.  Also requires the
-- variable to which this value was bound, so as to give the
250
-- resulting BCO a name.
251

252 253 254 255 256
schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                -- will appear in the thunk.  Empty for
                                -- top-level things, which have no free vars.
        -> (Id, AnnExpr Id VarSet)
        -> BcM (ProtoBCO Name)
257
schemeR fvs (nm, rhs)
258
{-
259 260
   | trace (showSDoc (
              (char ' '
261
               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
262 263 264 265 266
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
   | otherwise
267
-}
268
   = schemeR_wrk fvs nm rhs (collect rhs)
269

270 271 272 273
collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect (_, e) = go [] e
  where
    go xs e | Just e' <- bcView e = go xs e'
274
    go xs (AnnLam x (_,e))
275 276 277 278 279
      | UbxTupleRep _ <- repType (idType x)
      = unboxedTupleException
      | otherwise
      = go (x:xs) e
    go xs not_lambda = (reverse xs, not_lambda)
280

281
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
282
schemeR_wrk fvs nm original_body (args, body)
283 284 285
   = do
     dflags <- getDynFlags
     let
286 287 288 289 290
         all_args  = reverse args ++ fvs
         arity     = length all_args
         -- all_args are the args in reverse order.  We're compiling a function
         -- \fv1..fvn x1..xn -> e
         -- i.e. the fvs come first
291

292
         szsw_args = map (fromIntegral . idSizeW dflags) all_args
293
         szw_args  = sum szsw_args
294
         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
295

296
         -- make the arg bitmap
Simon Marlow's avatar
Simon Marlow committed
297
         bits = argBits dflags (reverse (map bcIdArgRep all_args))
298
         bitmap_size = genericLength bits
299
         bitmap = mkBitmap dflags bits
300 301
     body_code <- schemeER_wrk szw_args p_init body

302
     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
303
                 arity bitmap_size bitmap False{-not alts-})
304

305
-- introduce break instructions for ticked expressions
pcapriotti's avatar
pcapriotti committed
306
schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
307
schemeER_wrk d p rhs
308
  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
pcapriotti's avatar
pcapriotti committed
309
  = do  code <- schemeE (fromIntegral d) 0 p newRhs
310
        arr <- getBreakArray
311 312
        this_mod <- getCurrentModule
        let idOffSets = getVarOffSets d p fvs
313
        let breakInfo = BreakInfo
314 315
                        { breakInfo_module = this_mod
                        , breakInfo_number = tick_no
316
                        , breakInfo_vars = idOffSets
Simon Marlow's avatar
Simon Marlow committed
317
                        , breakInfo_resty = exprType (deAnnotate' newRhs)
318
                        }
319 320
        let breakInstr = case arr of
                         BA arr# ->
321
                             BRK_FUN arr# (fromIntegral tick_no) breakInfo
322
        return $ breakInstr `consOL` code
pcapriotti's avatar
pcapriotti committed
323
   | otherwise = schemeE (fromIntegral d) 0 p rhs
324

pcapriotti's avatar
pcapriotti committed
325
getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
326
getVarOffSets d p = catMaybes . map (getOffSet d p)
327

pcapriotti's avatar
pcapriotti committed
328
getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
329
getOffSet d env id
330
   = case lookupBCEnv_maybe id env of
331
        Nothing     -> Nothing
pcapriotti's avatar
pcapriotti committed
332 333 334 335 336 337 338 339
        Just offset -> Just (id, trunc16 $ d - offset)

trunc16 :: Word -> Word16
trunc16 w
    | w > fromIntegral (maxBound :: Word16)
    = panic "stack depth overflow"
    | otherwise
    = fromIntegral w
340

341 342 343 344 345 346 347 348 349
fvsToEnv :: BCEnv -> VarSet -> [Id]
-- Takes the free variables of a right-hand side, and
-- delivers an ordered list of the local variables that will
-- be captured in the thunk for the RHS
-- The BCEnv argument tells which variables are in the local
-- environment: these are the ones that should be captured
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
350 351 352
fvsToEnv p fvs = [v | v <- varSetElems fvs,
                      isId v,           -- Could be a type variable
                      v `Map.member` p]
353

354 355
-- -----------------------------------------------------------------------------
-- schemeE
356

pcapriotti's avatar
pcapriotti committed
357
returnUnboxedAtom :: Word -> Sequel -> BCEnv
Simon Marlow's avatar
Simon Marlow committed
358
                 -> AnnExpr' Id VarSet -> ArgRep
359 360 361 362 363 364 365 366 367
                 -> BcM BCInstrList
-- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
returnUnboxedAtom d s p e e_rep
   = do (push, szw) <- pushAtom d p e
        return (push                       -- value onto stack
                `appOL`  mkSLIDE szw (d-s) -- clear to sequel
                `snocOL` RETURN_UBX e_rep) -- go

368 369
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
pcapriotti's avatar
pcapriotti committed
370
schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
371

372 373 374 375
schemeE d s p e
   | Just e' <- bcView e
   = schemeE d s p e'

376
-- Delegate tail-calls to schemeT.
377
schemeE d s p e@(AnnApp _ _) = schemeT d s p e
378

Simon Marlow's avatar
Simon Marlow committed
379 380
schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
381

382
schemeE d s p e@(AnnVar v)
Simon Marlow's avatar
Simon Marlow committed
383
    | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
384
    | otherwise                 = schemeT d s p e
385

386 387
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
   | (AnnVar v, args_r_to_l) <- splitApp rhs,
388
     Just data_con <- isDataConWorkId_maybe v,
389
     dataConRepArity data_con == length args_r_to_l
390 391 392
   = do -- Special case for a non-recursive let whose RHS is a
        -- saturatred constructor application.
        -- Just allocate the constructor and carry on
393
        alloc_code <- mkConAppCode d s p data_con args_r_to_l
394
        body_code <- schemeE (d+1) s (Map.insert x d p) body
395
        return (alloc_code `appOL` body_code)
396 397 398

-- General case for let.  Generates correct, if inefficient, code in
-- all situations.
399 400 401
schemeE d s p (AnnLet binds (_,body)) = do
     dflags <- getDynFlags
     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
402
                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
403
         n_binds = genericLength xs
404

405
         fvss  = map (fvsToEnv p' . fst) rhss
406

sof's avatar
sof committed
407
         -- Sizes of free vars
408
         sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
409

410 411
         -- the arity of each rhs
         arities = map (genericLength . fst . collect) rhss
412 413 414 415 416

         -- This p', d' defn is safe because all the items being pushed
         -- are ptrs, so all have size 1.  d' and p' reflect the stack
         -- after the closures have been allocated in the heap (but not
         -- filled in), and pointers to them parked on the stack.
417
         p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
pcapriotti's avatar
pcapriotti committed
418
         d'    = d + fromIntegral n_binds
419 420 421
         zipE  = zipEqual "schemeE"

         -- ToDo: don't build thunks for things with no free variables
Ian Lynagh's avatar
Ian Lynagh committed
422
         build_thunk _ [] size bco off arity
423
            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
424 425 426
           where
                mkap | arity == 0 = MKAP
                     | otherwise  = MKPAP
427
         build_thunk dd (fv:fvs) size bco off arity = do
428
              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
pcapriotti's avatar
pcapriotti committed
429
              more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
430
              return (push_code `appOL` more_push_code)
431

432
         alloc_code = toOL (zipWith mkAlloc sizes arities)
433
           where mkAlloc sz 0
434 435
                    | is_tick     = ALLOC_AP_NOUPD sz
                    | otherwise   = ALLOC_AP sz
436
                 mkAlloc sz arity = ALLOC_PAP arity sz
437

438
         is_tick = case binds of
439 440 441
                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
                     _other -> False

442 443 444
         compile_bind d' fvs x rhs size arity off = do
                bco <- schemeR fvs (x,rhs)
                build_thunk d' fvs size bco off arity
445

446 447 448 449 450
         compile_binds =
            [ compile_bind d' fvs x rhs size arity n
            | (fvs, x, rhs, size, arity, n) <-
                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
            ]
451
     body_code <- schemeE d' s p' body
452
     thunk_codes <- sequence compile_binds
453
     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
454

455 456 457 458 459 460
-- introduce a let binding for a ticked case expression. This rule
-- *should* only fire when the expression was not already let-bound
-- (the code gen for let bindings should take care of that).  Todo: we
-- call exprFreeVars on a deAnnotated expression, this may not be the
-- best way to calculate the free vars but it seemed like the least
-- intrusive thing to do
461
schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
462
   = if isUnLiftedType ty
463 464
        then do
          -- If the result type is unlifted, then we must generate
465
          --   let f = \s . tick<n> e
466 467 468 469 470 471 472
          --   in  f realWorld#
          -- When we stop at the breakpoint, _result will have an unlifted
          -- type and hence won't be bound in the environment, but the
          -- breakpoint will otherwise work fine.
          id <- newId (mkFunTy realWorldStatePrimTy ty)
          st <- newId realWorldStatePrimTy
          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
473
                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
474 475
                                                    (emptyVarSet, AnnVar realWorldPrimId)))
          schemeE d s p letExp
476 477 478 479 480 481 482 483
        else do
          id <- newId ty
          -- Todo: is emptyVarSet correct on the next line?
          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
          schemeE d s p letExp
   where exp' = deAnnotate' exp
         fvs  = exprFreeVars exp'
         ty   = exprType exp'
484

485 486 487
-- ignore other kinds of tick
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs

488 489 490
schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
        -- no alts: scrut is guaranteed to diverge

491 492 493
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
   | isUnboxedTupleCon dc
   , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2)
494
        -- Convert
Simon Marlow's avatar
Simon Marlow committed
495
        --      case .... of x { (# V'd-thing, a #) -> ... }
496 497 498 499 500 501
        -- to
        --      case .... of a { DEFAULT -> ... }
        -- becuse the return convention for both are identical.
        --
        -- Note that it does not matter losing the void-rep thing from the
        -- envt (it won't be bound now) because we never look such things up.
502 503 504 505 506 507 508 509 510 511
   , Just res <- case () of
                   _ | VoidRep <- typePrimRep rep_ty1
                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
                     | VoidRep <- typePrimRep rep_ty2
                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
                     | otherwise
                     -> Nothing
   = res

schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
512
   | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
513 514 515 516
        -- Similarly, convert
        --      case .... of x { (# a #) -> ... }
        -- to
        --      case .... of a { DEFAULT -> ... }
517
   = --trace "automagic mashing of case alts (# a #)"  $
518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}

schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)])
   | Just (tc, tys) <- splitTyConApp_maybe (idType bndr)
   , isUnboxedTupleTyCon tc
   , Just res <- case tys of
        [ty]       | UnaryRep _ <- repType ty
                   , let bind = bndr `setIdType` ty
                   -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
        [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1
                   , UnaryRep rep_ty2 <- repType ty2
                   -> case () of
                       _ | VoidRep <- typePrimRep rep_ty1
                         , let bind2 = bndr `setIdType` ty2
                         -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
                         | VoidRep <- typePrimRep rep_ty2
                         , let bind1 = bndr `setIdType` ty1
                         -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
                         | otherwise
                         -> Nothing
        _ -> Nothing
   = res
540

541
schemeE d s p (AnnCase scrut bndr _ alts)
542
   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
543

Ian Lynagh's avatar
Ian Lynagh committed
544
schemeE _ _ _ expr
545
   = pprPanic "ByteCodeGen.schemeE: unhandled case"
Ian Lynagh's avatar
Ian Lynagh committed
546
               (pprCoreExpr (deAnnotate' expr))
547

548
{-
549 550
   Ticked Expressions
   ------------------
551

552
  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
553
  the code. When we find such a thing, we pull out the useful information,
554
  and then compile the code as if it was just the expression E.
555 556 557

-}

558 559 560 561 562
-- Compile code to do a tail call.  Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-- and enter.  Four cases:
--
-- 0.  (Nasty hack).
563
--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
564 565
--     The int will be on the stack.  Generate a code sequence
--     to convert it to the relevant constructor, SLIDE and ENTER.
566
--
567
-- 1.  The fn denotes a ccall.  Defer to generateCCall.
568
--
Simon Marlow's avatar
Simon Marlow committed
569
-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat
570
--     it simply as  b  -- since the representations are identical
Simon Marlow's avatar
Simon Marlow committed
571
--     (the V takes up zero stack space).  Also, spot
572
--     (# b #) and treat it as  b.
573
--
574
-- 3.  Application of a constructor, by defn saturated.
575
--     Split the args into ptrs and non-ptrs, and push the nonptrs,
576 577
--     then the ptrs, and then do PACK and RETURN.
--
578
-- 4.  Otherwise, it must be a function call.  Push the args
579
--     right to left, SLIDE and ENTER.
580

pcapriotti's avatar
pcapriotti committed
581
schemeT :: Word         -- Stack depth
582 583 584
        -> Sequel       -- Sequel depth
        -> BCEnv        -- stack env
        -> AnnExpr' Id VarSet
585
        -> BcM BCInstrList
586

587
schemeT d s p app
588

589 590 591
--   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
--   = panic "schemeT ?!?!"

592
--   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
593
--   = error "?!?!"
594

595
   -- Case 0
596 597
   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
   = implement_tagToId d s p arg constr_names
598

599
   -- Case 1
600 601 602
   | Just (CCall ccall_spec) <- isFCallId_maybe fn
   = generateCCall d s p ccall_spec fn args_r_to_l

603
   -- Case 2: Constructor application
604
   | Just con <- maybe_saturated_dcon,
605 606
     isUnboxedTupleCon con
   = case args_r_to_l of
Simon Marlow's avatar
Simon Marlow committed
607
        [arg1,arg2] | isVAtom arg1 ->
608
                  unboxedTupleReturn d s p arg2
Simon Marlow's avatar
Simon Marlow committed
609
        [arg1,arg2] | isVAtom arg2 ->
610 611
                  unboxedTupleReturn d s p arg1
        _other -> unboxedTupleException
612 613

   -- Case 3: Ordinary data constructor
614
   | Just con <- maybe_saturated_dcon
615
   = do alloc_con <- mkConAppCode d s p con args_r_to_l
616 617 618
        return (alloc_con         `appOL`
                mkSLIDE 1 (d - s) `snocOL`
                ENTER)
619

620
   -- Case 4: Tail call of function
621
   | otherwise
622
   = doTailCall d s p fn args_r_to_l
623

624
   where
625 626 627
        -- Extract the args (R->L) and fn
        -- The function will necessarily be a variable,
        -- because we are compiling a tail call
628
      (AnnVar fn, args_r_to_l) = splitApp app
629

630
      -- Only consider this to be a constructor application iff it is
631
      -- saturated.  Otherwise, we'll call the constructor wrapper.
632
      n_args = length args_r_to_l
633 634 635 636
      maybe_saturated_dcon
        = case isDataConWorkId_maybe fn of
                Just con | dataConRepArity con == n_args -> Just con
                _ -> Nothing
637

638
-- -----------------------------------------------------------------------------
639
-- Generate code to build a constructor application,
640 641
-- leaving it on top of the stack

pcapriotti's avatar
pcapriotti committed
642
mkConAppCode :: Word -> Sequel -> BCEnv
643 644 645
             -> DataCon                 -- The data constructor
             -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
             -> BcM BCInstrList
646

647
mkConAppCode _ _ _ con []       -- Nullary constructor
648
  = ASSERT( isNullaryRepDataCon con )
649
    return (unitOL (PUSH_G (getName (dataConWorkId con))))
650 651
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.
652

653
mkConAppCode orig_d _ p con args_r_to_l
654 655
  = ASSERT( dataConRepArity con == length args_r_to_l )
    do_pushery orig_d (non_ptr_args ++ ptr_args)
656
 where
657 658
        -- The args are already in reverse order, which is the way PACK
        -- expects them to be.  We must push the non-ptrs after the ptrs.
659
      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
660 661

      do_pushery d (arg:args)
662
         = do (push, arg_words) <- pushAtom d p arg
pcapriotti's avatar
pcapriotti committed
663
              more_push_code <- do_pushery (d + fromIntegral arg_words) args
664
              return (push `appOL` more_push_code)
665
      do_pushery d []
666
         = return (unitOL (PACK con n_arg_words))
667
         where
pcapriotti's avatar
pcapriotti committed
668
           n_arg_words = trunc16 $ d - orig_d
669

670 671 672 673 674 675 676 677 678

-- -----------------------------------------------------------------------------
-- Returning an unboxed tuple with one non-void component (the only
-- case we can handle).
--
-- Remember, we don't want to *evaluate* the component that is being
-- returned, even if it is a pointed type.  We always just return.

unboxedTupleReturn
pcapriotti's avatar
pcapriotti committed
679
        :: Word -> Sequel -> BCEnv
680
        -> AnnExpr' Id VarSet -> BcM BCInstrList
681
unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
682 683 684 685 686

-- -----------------------------------------------------------------------------
-- Generate code for a tail-call

doTailCall
pcapriotti's avatar
pcapriotti committed
687
        :: Word -> Sequel -> BCEnv
688 689
        -> Id -> [AnnExpr' Id VarSet]
        -> BcM BCInstrList
690
doTailCall init_d s p fn args
691
  = do_pushes init_d args (map atomRep args)
692 693
  where
  do_pushes d [] reps = do
694
        ASSERT( null reps ) return ()
695
        (push_fn, sz) <- pushAtom d p (AnnVar fn)
696 697
        ASSERT( sz == 1 ) return ()
        return (push_fn `appOL` (
pcapriotti's avatar
pcapriotti committed
698
                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
699
                  unitOL ENTER))
700 701
  do_pushes d args reps = do
      let (push_apply, n, rest_of_reps) = findPushSeq reps
702
          (these_args, rest_of_args) = splitAt n args
703
      (next_d, push_code) <- push_seq d these_args
704 705
      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
      --                          ^^^ for the PUSH_APPLY_ instruction
706
      return (push_code `appOL` (push_apply `consOL` instrs))
707 708 709

  push_seq d [] = return (d, nilOL)
  push_seq d (arg:args) = do
710
    (push_code, sz) <- pushAtom d p arg
pcapriotti's avatar
pcapriotti committed
711
    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
712 713 714
    return (final_d, push_code `appOL` more_push_code)

-- v. similar to CgStackery.findMatch, ToDo: merge
Simon Marlow's avatar
Simon Marlow committed
715 716
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (P: P: P: P: P: P: rest)
717
  = (PUSH_APPLY_PPPPPP, 6, rest)
Simon Marlow's avatar
Simon Marlow committed
718
findPushSeq (P: P: P: P: P: rest)
719
  = (PUSH_APPLY_PPPPP, 5, rest)
Simon Marlow's avatar
Simon Marlow committed
720
findPushSeq (P: P: P: P: rest)
721
  = (PUSH_APPLY_PPPP, 4, rest)
Simon Marlow's avatar
Simon Marlow committed
722
findPushSeq (P: P: P: rest)
723
  = (PUSH_APPLY_PPP, 3, rest)
Simon Marlow's avatar
Simon Marlow committed
724
findPushSeq (P: P: rest)
725
  = (PUSH_APPLY_PP, 2, rest)
Simon Marlow's avatar
Simon Marlow committed
726
findPushSeq (P: rest)
727
  = (PUSH_APPLY_P, 1, rest)
Simon Marlow's avatar
Simon Marlow committed
728
findPushSeq (V: rest)
729
  = (PUSH_APPLY_V, 1, rest)
Simon Marlow's avatar
Simon Marlow committed
730
findPushSeq (N: rest)
731
  = (PUSH_APPLY_N, 1, rest)
Simon Marlow's avatar
Simon Marlow committed
732
findPushSeq (F: rest)
733
  = (PUSH_APPLY_F, 1, rest)
Simon Marlow's avatar
Simon Marlow committed
734
findPushSeq (D: rest)
735
  = (PUSH_APPLY_D, 1, rest)
Simon Marlow's avatar
Simon Marlow committed
736
findPushSeq (L: rest)
737 738 739 740 741 742 743
  = (PUSH_APPLY_L, 1, rest)
findPushSeq _
  = panic "ByteCodeGen.findPushSeq"

-- -----------------------------------------------------------------------------
-- Case expressions

pcapriotti's avatar
pcapriotti committed
744
doCase  :: Word -> Sequel -> BCEnv
745
        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
746
        -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
747 748
        -> BcM BCInstrList
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
749 750 751
  | UbxTupleRep _ <- repType (idType bndr)
  = unboxedTupleException
  | otherwise
752 753 754
  = do
     dflags <- getDynFlags
     let
755 756 757 758
        -- Top of stack is the return itbl, as usual.
        -- underneath it is the pointer to the alt_code BCO.
        -- When an alt is entered, it assumes the returned value is
        -- on top of the itbl.
pcapriotti's avatar
pcapriotti committed
759
        ret_frame_sizeW :: Word
760 761
        ret_frame_sizeW = 2

762 763
        -- An unlifted value gets an extra info table pushed on top
        -- when it is returned.
pcapriotti's avatar
pcapriotti committed
764
        unlifted_itbl_sizeW :: Word
765 766
        unlifted_itbl_sizeW | isAlgCase = 0
                            | otherwise = 1
767

768
        -- depth of stack after the return value has been pushed
769
        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
770

771 772 773
        -- depth of stack after the extra info table for an unboxed return
        -- has been pushed, if any.  This is the stack depth at the
        -- continuation.
774 775 776 777
        d_alts = d_bndr + unlifted_itbl_sizeW

        -- Env in which to compile the alts, not including
        -- any vars bound by the alts themselves
778 779 780 781 782
        d_bndr' = fromIntegral d_bndr - 1
        p_alts0 = Map.insert bndr d_bndr' p
        p_alts = case is_unboxed_tuple of
                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
                   Nothing       -> p_alts0
783

784
        bndr_ty = idType bndr
785
        isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple