ByteCodeGen.lhs 61.6 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2002-2006
3
%
4 5

ByteCodeGen: Generate bytecode from Core
6 7

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
8 9 10 11 12 13 14
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

15
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
16 17 18

#include "HsVersions.h"

19
import ByteCodeInstr
20
import ByteCodeItbls
21 22
import ByteCodeAsm
import ByteCodeLink
23
import LibFFI
24

25
import Outputable
26
import Name
27
import MkId
28
import Id
29 30 31
import ForeignCall
import HscTypes
import CoreUtils
32
import CoreSyn
33 34 35 36 37 38 39
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
import DataCon
import TyCon
40
import Util
41 42 43 44 45 46 47 48
import VarSet
import TysPrim
import DynFlags
import ErrUtils
import Unique
import FastString
import Panic
import SMRep
49
import ClosureInfo
50
import Bitmap
51
import OrdList
52
import Constants
53

Ian Lynagh's avatar
Ian Lynagh committed
54
import Data.List
55
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
56
import Foreign.C
57

Ian Lynagh's avatar
Ian Lynagh committed
58
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
59
import Data.Char
60

61 62 63
import UniqSupply
import BreakArray
import Data.Maybe
64
import Module
65

66 67 68
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
69
import Data.Ord
70

71
-- -----------------------------------------------------------------------------
72
-- Generating byte code for a complete module
73

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

83 84
        let flatBinds = [ (bndr, freeVars rhs)
                        | (bndr, rhs) <- flattenBinds binds]
85

86
        us <- mkSplitUniqSupply 'y'
87 88
        (BcM_State _us _this_mod _final_ctr mallocd _, proto_bcos)
           <- runBc us this_mod modBreaks (mapM schemeTopBind flatBinds)
89

sof's avatar
sof committed
90
        when (notNull mallocd)
91 92
             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")

93
        dumpIfSet_dyn dflags Opt_D_dump_BCOs
94
           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
95

96
        assembleBCOs dflags proto_bcos tycs
97

98 99
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
100

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

      -- 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
112
      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
113
          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
114

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

sof's avatar
sof committed
122
      when (notNull mallocd)
123 124
           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

125
      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
126

127
      assembleBCO dflags proto_bco
128 129


130 131
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
132 133 134

type BCInstrList = OrdList BCInstr

pcapriotti's avatar
pcapriotti committed
135
type Sequel = Word -- back off to this depth before ENTER
136 137 138

-- 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
139
type BCEnv = Map Id Word -- To find vars on the stack
140

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

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

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

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

200 201 202
        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)
203
           = PUSH_LL off1 (off2-1) : peep rest
204 205 206 207 208
        peep (i:rest)
           = i : peep rest
        peep []
           = []

209
argBits :: [CgRep] -> [Bool]
210 211
argBits [] = []
argBits (rep : args)
212 213
  | isFollowableArg rep = False : argBits args
  | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
214

215 216 217 218 219 220 221 222
-- -----------------------------------------------------------------------------
-- schemeTopBind

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

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


223
schemeTopBind (id, rhs)
224
  | Just data_con <- isDataConWorkId_maybe id,
225
    isNullaryRepDataCon data_con = do
226 227 228 229 230 231 232
        -- 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.
233
    -- ioToBc (putStrLn $ "top level BCO")
234
    emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
235
                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
236 237 238 239

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

240

241 242
-- -----------------------------------------------------------------------------
-- schemeR
243

244 245 246 247 248
-- 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.
--
249 250
-- Park the resulting BCO in the monad.  Also requires the
-- variable to which this value was bound, so as to give the
251
-- resulting BCO a name.
252

253 254 255 256 257
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)
258
schemeR fvs (nm, rhs)
259
{-
260 261
   | trace (showSDoc (
              (char ' '
262
               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
263 264 265 266 267
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
   | otherwise
268
-}
269
   = schemeR_wrk fvs nm rhs (collect rhs)
270

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

282
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
283
schemeR_wrk fvs nm original_body (args, body)
284 285 286 287 288 289
   = let
         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
290

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

295 296 297 298
         -- make the arg bitmap
         bits = argBits (reverse (map idCgRep all_args))
         bitmap_size = genericLength bits
         bitmap = mkBitmap bits
299
     in do
300 301
     body_code <- schemeER_wrk szw_args p_init body

302
     emitBc (mkProtoBCO (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
358 359 360 361 362 363 364 365 366 367
                 -> AnnExpr' Id VarSet -> CgRep
                 -> 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

379 380
schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeCgRep (literalType lit))
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg
381

382
schemeE d s p e@(AnnVar v)
383 384
    | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdCgRep v)
    | 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
schemeE d s p (AnnLet binds (_,body))
400 401
   = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
402
         n_binds = genericLength xs
403

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

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

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

         -- 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.
416
         p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
pcapriotti's avatar
pcapriotti committed
417
         d'    = d + fromIntegral n_binds
418 419 420
         zipE  = zipEqual "schemeE"

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

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

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

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

445 446 447 448 449
         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]
            ]
450
     in do
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 495 496 497 498 499 500 501
        -- Convert
        --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
        -- 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
--
569
-- 2.  (Another nasty hack).  Spot (# a::VoidArg, b #) and treat
570
--     it simply as  b  -- since the representations are identical
571
--     (the VoidArg 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
   | Just (arg, constr_names) <- maybe_is_tagToEnum_call
597 598
   = do (push, arg_words) <- pushAtom d p arg
        tagToId_sequence <- implement_tagToId constr_names
599
        return (push `appOL`  tagToId_sequence
pcapriotti's avatar
pcapriotti committed
600
                       `appOL`  mkSLIDE 1 (d - s + fromIntegral arg_words)
601
                       `snocOL` ENTER)
602

603
   -- Case 1
604 605 606
   | Just (CCall ccall_spec) <- isFCallId_maybe fn
   = generateCCall d s p ccall_spec fn args_r_to_l

607
   -- Case 2: Constructor application
608
   | Just con <- maybe_saturated_dcon,
609 610
     isUnboxedTupleCon con
   = case args_r_to_l of
611 612 613 614 615
        [arg1,arg2] | isVoidArgAtom arg1 ->
                  unboxedTupleReturn d s p arg2
        [arg1,arg2] | isVoidArgAtom arg2 ->
                  unboxedTupleReturn d s p arg1
        _other -> unboxedTupleException
616 617

   -- Case 3: Ordinary data constructor
618
   | Just con <- maybe_saturated_dcon
619
   = do alloc_con <- mkConAppCode d s p con args_r_to_l
620 621 622
        return (alloc_con         `appOL`
                mkSLIDE 1 (d - s) `snocOL`
                ENTER)
623

624
   -- Case 4: Tail call of function
625
   | otherwise
626
   = doTailCall d s p fn args_r_to_l
627

628 629 630 631
   where
      -- Detect and extract relevant info for the tagToEnum kludge.
      maybe_is_tagToEnum_call
         = let extract_constr_Names ty
632 633
                 | UnaryRep rep_ty <- repType ty
                 , Just tyc <- tyConAppTyCon_maybe rep_ty,
634 635 636 637 638
                   isDataTyCon tyc
                   = map (getName . dataConWorkId) (tyConDataCons tyc)
                   -- NOTE: use the worker name, not the source name of
                   -- the DataCon.  See DataCon.lhs for details.
                 | otherwise
639
                   = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
640
           in
641
           case app of
642
              (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
643
                 -> case isPrimOpId_maybe v of
644
                       Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
645
                       _                -> Nothing
Ian Lynagh's avatar
Ian Lynagh committed
646
              _ -> Nothing
647

648 649 650
        -- Extract the args (R->L) and fn
        -- The function will necessarily be a variable,
        -- because we are compiling a tail call
651
      (AnnVar fn, args_r_to_l) = splitApp app
652

653
      -- Only consider this to be a constructor application iff it is
654
      -- saturated.  Otherwise, we'll call the constructor wrapper.
655
      n_args = length args_r_to_l
656 657 658 659
      maybe_saturated_dcon
        = case isDataConWorkId_maybe fn of
                Just con | dataConRepArity con == n_args -> Just con
                _ -> Nothing
660

661
-- -----------------------------------------------------------------------------
662
-- Generate code to build a constructor application,
663 664
-- leaving it on top of the stack

pcapriotti's avatar
pcapriotti committed
665
mkConAppCode :: Word -> Sequel -> BCEnv
666 667 668
             -> DataCon                 -- The data constructor
             -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
             -> BcM BCInstrList
669

670
mkConAppCode _ _ _ con []       -- Nullary constructor
671
  = ASSERT( isNullaryRepDataCon con )
672
    return (unitOL (PUSH_G (getName (dataConWorkId con))))
673 674
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.
675

676
mkConAppCode orig_d _ p con args_r_to_l
677 678
  = ASSERT( dataConRepArity con == length args_r_to_l )
    do_pushery orig_d (non_ptr_args ++ ptr_args)
679
 where
680 681
        -- 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.
682
      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
683 684

      do_pushery d (arg:args)
685
         = do (push, arg_words) <- pushAtom d p arg
pcapriotti's avatar
pcapriotti committed
686
              more_push_code <- do_pushery (d + fromIntegral arg_words) args
687
              return (push `appOL` more_push_code)
688
      do_pushery d []
689
         = return (unitOL (PACK con n_arg_words))
690
         where
pcapriotti's avatar
pcapriotti committed
691
           n_arg_words = trunc16 $ d - orig_d
692

693 694 695 696 697 698 699 700 701

-- -----------------------------------------------------------------------------
-- 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
702
        :: Word -> Sequel -> BCEnv
703
        -> AnnExpr' Id VarSet -> BcM BCInstrList
704
unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
705 706 707 708 709

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

doTailCall
pcapriotti's avatar
pcapriotti committed
710
        :: Word -> Sequel -> BCEnv
711 712
        -> Id -> [AnnExpr' Id VarSet]
        -> BcM BCInstrList
713
doTailCall init_d s p fn args
714
  = do_pushes init_d args (map atomRep args)
715 716
  where
  do_pushes d [] reps = do
717
        ASSERT( null reps ) return ()
718
        (push_fn, sz) <- pushAtom d p (AnnVar fn)
719 720
        ASSERT( sz == 1 ) return ()
        return (push_fn `appOL` (
pcapriotti's avatar
pcapriotti committed
721
                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
722
                  unitOL ENTER))
723 724
  do_pushes d args reps = do
      let (push_apply, n, rest_of_reps) = findPushSeq reps
725
          (these_args, rest_of_args) = splitAt n args
726
      (next_d, push_code) <- push_seq d these_args
727 728
      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
      --                          ^^^ for the PUSH_APPLY_ instruction
729
      return (push_code `appOL` (push_apply `consOL` instrs))
730 731 732

  push_seq d [] = return (d, nilOL)
  push_seq d (arg:args) = do
733
    (push_code, sz) <- pushAtom d p arg
pcapriotti's avatar
pcapriotti committed
734
    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
735 736 737
    return (final_d, push_code `appOL` more_push_code)

-- v. similar to CgStackery.findMatch, ToDo: merge
Ian Lynagh's avatar
Ian Lynagh committed
738
findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep])
739
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
740
  = (PUSH_APPLY_PPPPPP, 6, rest)
741
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
742
  = (PUSH_APPLY_PPPPP, 5, rest)
743
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
744
  = (PUSH_APPLY_PPPP, 4, rest)
745
findPushSeq (PtrArg: PtrArg: PtrArg: rest)
746
  = (PUSH_APPLY_PPP, 3, rest)
747
findPushSeq (PtrArg: PtrArg: rest)
748
  = (PUSH_APPLY_PP, 2, rest)
749
findPushSeq (PtrArg: rest)
750
  = (PUSH_APPLY_P, 1, rest)
751
findPushSeq (VoidArg: rest)
752
  = (PUSH_APPLY_V, 1, rest)
753
findPushSeq (NonPtrArg: rest)
754
  = (PUSH_APPLY_N, 1, rest)
755
findPushSeq (FloatArg: rest)
756
  = (PUSH_APPLY_F, 1, rest)
757
findPushSeq (DoubleArg: rest)
758
  = (PUSH_APPLY_D, 1, rest)
759
findPushSeq (LongArg: rest)
760 761 762 763 764 765 766
  = (PUSH_APPLY_L, 1, rest)
findPushSeq _
  = panic "ByteCodeGen.findPushSeq"

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

pcapriotti's avatar
pcapriotti committed
767
doCase  :: Word -> Sequel -> BCEnv
768
        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
769
        -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
770 771
        -> BcM BCInstrList
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
772 773 774
  | UbxTupleRep _ <- repType (idType bndr)
  = unboxedTupleException
  | otherwise
775 776 777 778 779
  = let
        -- 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
780
        ret_frame_sizeW :: Word
781 782
        ret_frame_sizeW = 2

783 784
        -- An unlifted value gets an extra info table pushed on top
        -- when it is returned.
pcapriotti's avatar
pcapriotti committed
785
        unlifted_itbl_sizeW :: Word
786 787
        unlifted_itbl_sizeW | isAlgCase = 0
                            | otherwise = 1
788

789 790
        -- depth of stack after the return value has been pushed
        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
791

792 793 794
        -- 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.
795 796 797 798
        d_alts = d_bndr + unlifted_itbl_sizeW

        -- Env in which to compile the alts, not including
        -- any vars bound by the alts themselves
799 800 801 802 803
        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
804

805
        bndr_ty = idType bndr
806
        isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple
807 808

        -- given an alt, return a discr and code for it.
809 810 811
        codeAlt (DEFAULT, _, (_,rhs))
           = do rhs_code <- schemeE d_alts s p_alts rhs
                return (NoDiscr, rhs_code)
812

Ian Lynagh's avatar
Ian Lynagh committed
813
        codeAlt alt@(_, bndrs, (_,rhs))
814 815 816
           -- primitive or nullary constructor alt: no need to UNPACK
           | null real_bndrs = do
                rhs_code <- schemeE d_alts s p_alts rhs
817
                return (my_discr alt, rhs_code)
818 819
           | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
           = unboxedTupleException
820
           -- algebraic alt with some binders
Ian Lynagh's avatar
Ian Lynagh committed
821
           | otherwise =
822
             let
823 824 825 826 827 828 829 830 831 832 833
                 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
                 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
                 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
                 bind_sizes   = ptr_sizes ++ nptrs_sizes
                 size         = sum ptr_sizes + sum nptrs_sizes
                 -- the UNPACK instruction unpacks in reverse order...
                 p' = Map.insertList
                        (zip (reverse (ptrs ++ nptrs))
                          (mkStackOffsets d_alts (reverse bind_sizes)))
                        p_alts
             in do
Ian Lynagh's avatar
Ian Lynagh committed
834
             MASSERT(isAlgCase)
pcapriotti's avatar
pcapriotti committed
835 836
             rhs_code <- schemeE (d_alts + size) s p' rhs
             return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
837
	   where
838
	     real_bndrs = filterOut isTyVar bndrs
839

Ian Lynagh's avatar
Ian Lynagh committed