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

ByteCodeGen: Generate bytecode from Core
6 7

\begin{code}
8
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
9 10 11

#include "HsVersions.h"

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

18
import Outputable
19
import Name
20
import MkId
21
import Id
22 23 24
import ForeignCall
import HscTypes
import CoreUtils
25
import CoreSyn
26 27 28 29 30 31 32
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
import DataCon
import TyCon
33
-- import Type
34
import Util
35
-- import DataCon
36 37 38 39 40 41 42 43 44 45
import Var
import VarSet
import TysPrim
import DynFlags
import ErrUtils
import Unique
import FastString
import Panic
import SMRep
import Bitmap
46
import OrdList
47
import Constants
48

Ian Lynagh's avatar
Ian Lynagh committed
49
import Data.List
50
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
51
import Foreign.C
52

53
-- import GHC.Exts		( Int(..) )
54

55
import Control.Monad	( when )
Ian Lynagh's avatar
Ian Lynagh committed
56
import Data.Char
57

58 59 60 61 62 63
import UniqSupply
import BreakArray
import Data.Maybe
import Module 
import IdInfo 

64 65 66 67
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map

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

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

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

82
        us <- mkSplitUniqSupply 'y'  
Ian Lynagh's avatar
Ian Lynagh committed
83
        (BcM_State _us _final_ctr mallocd _, proto_bcos) 
84
           <- runBc us modBreaks (mapM schemeTopBind flatBinds)  
85

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

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

92
        assembleBCOs proto_bcos tycs
93
        
94 95
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
96

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

      -- 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
107
      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
108
          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
109
	  
110 111 112
      -- the uniques are needed to generate fresh variables when we introduce new
      -- let bindings for ticked expressions
      us <- mkSplitUniqSupply 'y'
Ian Lynagh's avatar
Ian Lynagh committed
113
      (BcM_State _us _final_ctr mallocd _ , proto_bco)  
114
         <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
115

sof's avatar
sof committed
116
      when (notNull mallocd)
117 118
           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

119
      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
120

121
      assembleBCO proto_bco
122 123


124 125
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
126 127 128

type BCInstrList = OrdList BCInstr

129
type Sequel = Word16 -- back off to this depth before ENTER
130 131 132

-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
133
type BCEnv = Map Id Word16 -- To find vars on the stack
134

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

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

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

194 195 196
        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)
197
           = PUSH_LL off1 (off2-1) : peep rest
198 199 200 201 202
        peep (i:rest)
           = i : peep rest
        peep []
           = []

203
argBits :: [CgRep] -> [Bool]
204 205
argBits [] = []
argBits (rep : args)
206 207
  | isFollowableArg rep = False : argBits args
  | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
208

209 210 211 212 213 214 215 216
-- -----------------------------------------------------------------------------
-- schemeTopBind

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

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


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

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

234

235 236
-- -----------------------------------------------------------------------------
-- schemeR
237

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

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

265 266 267 268 269 270
collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect (_, e) = go [] e
  where
    go xs e | Just e' <- bcView e = go xs e'
    go xs (AnnLam x (_,e))        = go (x:xs) e
    go xs not_lambda              = (reverse xs, not_lambda)
271

272
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) 
273
schemeR_wrk fvs nm original_body (args, body)
274 275 276
   = let 
	 all_args  = reverse args ++ fvs
	 arity     = length all_args
277
	 -- all_args are the args in reverse order.  We're compiling a function
278 279 280
	 -- \fv1..fvn x1..xn -> e 
	 -- i.e. the fvs come first

281
         szsw_args = map (fromIntegral . idSizeW) all_args
282
         szw_args  = sum szsw_args
283
         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
284 285

	 -- make the arg bitmap
286
	 bits = argBits (reverse (map idCgRep all_args))
287
	 bitmap_size = genericLength bits
288
	 bitmap = mkBitmap bits
289
     in do
290 291
     body_code <- schemeER_wrk szw_args p_init body   
 
292
     emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
293
		arity bitmap_size bitmap False{-not alts-})
294

295
-- introduce break instructions for ticked expressions
296
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
297 298 299 300
schemeER_wrk d p rhs
   | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do 
        code <- schemeE d 0 p newRhs 
        arr <- getBreakArray 
301
        let idOffSets = getVarOffSets d p tickInfo
302 303 304 305 306
        let tickNumber = tickInfo_number tickInfo
        let breakInfo = BreakInfo 
                        { breakInfo_module = tickInfo_module tickInfo
                        , breakInfo_number = tickNumber 
                        , breakInfo_vars = idOffSets
Simon Marlow's avatar
Simon Marlow committed
307
                        , breakInfo_resty = exprType (deAnnotate' newRhs)
308
                        }
309 310 311
        let breakInstr = case arr of
                         BA arr# ->
                             BRK_FUN arr# (fromIntegral tickNumber) breakInfo
312 313 314
        return $ breakInstr `consOL` code
   | otherwise = schemeE d 0 p rhs 

315
getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
316 317
getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals 

318
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
319
getOffSet d env id 
320
   = case lookupBCEnv_maybe id env of
321 322
        Nothing     -> Nothing 
        Just offset -> Just (id, d - offset)
323

324 325 326 327 328 329 330 331 332 333 334
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
fvsToEnv p fvs = [v | v <- varSetElems fvs, 
		      isId v,		-- Could be a type variable
335
		      v `Map.member` p]
336

337 338
-- -----------------------------------------------------------------------------
-- schemeE
339

340 341 342 343 344 345 346 347 348 349 350 351
data TickInfo 
   = TickInfo   
     { tickInfo_number :: Int     -- the (module) unique number of the tick
     , tickInfo_module :: Module  -- the origin of the ticked expression 
     , tickInfo_locals :: [Id]    -- the local vars in scope at the ticked expression
     } 

instance Outputable TickInfo where
   ppr info = text "TickInfo" <+> 
              parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
                      ppr (tickInfo_locals info))

352 353
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
354
schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
355

356 357 358 359
schemeE d s p e
   | Just e' <- bcView e
   = schemeE d s p e'

360
-- Delegate tail-calls to schemeT.
Ian Lynagh's avatar
Ian Lynagh committed
361
schemeE d s p e@(AnnApp _ _) 
362
   = schemeT d s p e
363

364
schemeE d s p e@(AnnVar v)
365 366
   | not (isUnLiftedType v_type)
   =  -- Lifted-type thing; push it in the normal way
367
     schemeT d s p e
368

369
   | otherwise
370 371 372 373
   = do -- Returning an unlifted value.  
        -- Heave it on the stack, SLIDE, and RETURN.
        (push, szw) <- pushAtom d p (AnnVar v)
        return (push 			-- value onto stack
374
                  `appOL`  mkSLIDE szw (d-s) -- clear to sequel
375
                  `snocOL` RETURN_UBX v_rep)	-- go
376
   where
377
      v_type = idType v
378
      v_rep = typeCgRep v_type
379

380
schemeE d s p (AnnLit literal)
381 382 383 384 385
   = do (push, szw) <- pushAtom d p (AnnLit literal)
        let l_rep = typeCgRep (literalType literal)
        return (push 			-- value onto stack
               `appOL`  mkSLIDE szw (d-s) 	-- clear to sequel
               `snocOL` RETURN_UBX l_rep)	-- go
386

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

-- General case for let.  Generates correct, if inefficient, code in
-- all situations.
400
schemeE d s p (AnnLet binds (_,body))
401 402
   = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                   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) rhs_fvs)) fvss
409 410

	 -- the arity of each rhs
411
	 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
418
         d'    = d + 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 427
	   where 
		mkap | arity == 0 = MKAP
		     | otherwise  = MKPAP
         build_thunk dd (fv:fvs) size bco off arity = do
428
              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) 
429
              more_push_code <- build_thunk (dd+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 434 435
	   where mkAlloc sz 0
                    | is_tick     = ALLOC_AP_NOUPD sz
                    | otherwise   = ALLOC_AP sz
436
		 mkAlloc sz arity = ALLOC_PAP arity sz
437

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

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

446
	 compile_binds = 
447 448 449
	    [ 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 451
	    ]
     in do
452
     body_code <- schemeE d' s p' body
453
     thunk_codes <- sequence compile_binds
454
     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
455

456 457 458 459 460 461
-- 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
462
schemeE d s p exp@(AnnCase {})
463
   | Just (_tickInfo, _rhs) <- isTickedExp' exp
464
   = if isUnLiftedType ty
465 466 467 468 469 470 471 472 473 474 475 476 477
        then do
          -- If the result type is unlifted, then we must generate
          --   let f = \s . case tick# of _ -> e 
          --   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)))
                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) 
                                                    (emptyVarSet, AnnVar realWorldPrimId)))
          schemeE d s p letExp
478 479 480 481 482 483 484 485
        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'
486

Ian Lynagh's avatar
Ian Lynagh committed
487
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
488
   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
489
	-- Convert 
490
	--	case .... of x { (# VoidArg'd-thing, a #) -> ... }
491 492 493 494 495 496 497
	-- 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.

498
   = --trace "automagic mashing of case alts (# VoidArg, a #)" $
499
     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
500

501 502
   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
   = --trace "automagic mashing of case alts (# a, VoidArg #)" $
503
     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
504

Ian Lynagh's avatar
Ian Lynagh committed
505
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
506
   | isUnboxedTupleCon dc
507 508 509 510
	-- Similarly, convert
	--	case .... of x { (# a #) -> ... }
	-- to
	--	case .... of a { DEFAULT -> ... }
511
   = --trace "automagic mashing of case alts (# a #)"  $
512
     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
513

514
schemeE d s p (AnnCase scrut bndr _ alts)
515
   = doCase d s p scrut bndr alts False{-not an unboxed tuple-} 
516

Ian Lynagh's avatar
Ian Lynagh committed
517
schemeE _ _ _ expr
518
   = pprPanic "ByteCodeGen.schemeE: unhandled case" 
Ian Lynagh's avatar
Ian Lynagh committed
519
               (pprCoreExpr (deAnnotate' expr))
520

521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564
{- 
   Ticked Expressions
   ------------------
  
   A ticked expression looks like this:

      case tick<n> var1 ... varN of DEFAULT -> e

   (*) <n> is the number of the tick, which is unique within a module
   (*) var1 ... varN are the local variables in scope at the tick site

   If we find a ticked expression we return:

      Just ((n, [var1 ... varN]), e)

  otherwise we return Nothing.

  The idea is that the "case tick<n> ..." is really just an annotation on 
  the code. When we find such a thing, we pull out the useful information,
  and then compile the code as if it was just the expression "e".

-}

isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
isTickedExp' (AnnCase scrut _bndr _type alts)
   | Just tickInfo <- isTickedScrut scrut,
     [(DEFAULT, _bndr, rhs)] <- alts 
     = Just (tickInfo, rhs)
   where
   isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo 
   isTickedScrut expr
      | Var id <- f,
        Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
           = Just $ TickInfo { tickInfo_number = tickNumber
                             , tickInfo_module = modName
                             , tickInfo_locals = idsOfArgs args
                             }
      | otherwise = Nothing
      where
      (f, args) = collectArgs $ deAnnotate expr
      idsOfArgs :: [Expr Id] -> [Id]
      idsOfArgs = catMaybes . map exprId 
      exprId :: Expr Id -> Maybe Id
      exprId (Var id) = Just id
Ian Lynagh's avatar
Ian Lynagh committed
565
      exprId _        = Nothing
566

Ian Lynagh's avatar
Ian Lynagh committed
567
isTickedExp' _ = Nothing
568

569 570 571 572 573
-- 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).
574
--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
575 576
--     The int will be on the stack.  Generate a code sequence
--     to convert it to the relevant constructor, SLIDE and ENTER.
577
--
578
-- 1.  The fn denotes a ccall.  Defer to generateCCall.
579
--
580
-- 2.  (Another nasty hack).  Spot (# a::VoidArg, b #) and treat
581
--     it simply as  b  -- since the representations are identical
582
--     (the VoidArg takes up zero stack space).  Also, spot
583
--     (# b #) and treat it as  b.
584
--
585
-- 3.  Application of a constructor, by defn saturated.
586 587 588
--     Split the args into ptrs and non-ptrs, and push the nonptrs, 
--     then the ptrs, and then do PACK and RETURN.
--
589
-- 4.  Otherwise, it must be a function call.  Push the args
590
--     right to left, SLIDE and ENTER.
591

592
schemeT :: Word16       -- Stack depth
593 594
        -> Sequel 	-- Sequel depth
        -> BCEnv 	-- stack env
595
        -> AnnExpr' Id VarSet 
596
        -> BcM BCInstrList
597

598
schemeT d s p app
599

600 601 602
--   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
--   = panic "schemeT ?!?!"

603
--   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
604 605
--   = error "?!?!" 

606
   -- Case 0
607
   | Just (arg, constr_names) <- maybe_is_tagToEnum_call
608 609 610 611 612
   = do (push, arg_words) <- pushAtom d p arg
        tagToId_sequence <- implement_tagToId constr_names
        return (push `appOL`  tagToId_sequence            
                       `appOL`  mkSLIDE 1 (d+arg_words-s)
                       `snocOL` ENTER)
613

614
   -- Case 1
615 616 617
   | Just (CCall ccall_spec) <- isFCallId_maybe fn
   = generateCCall d s p ccall_spec fn args_r_to_l

618
   -- Case 2: Constructor application
619
   | Just con <- maybe_saturated_dcon,
620 621
     isUnboxedTupleCon con
   = case args_r_to_l of
622
	[arg1,arg2] | isVoidArgAtom arg1 -> 
623
		  unboxedTupleReturn d s p arg2
624
	[arg1,arg2] | isVoidArgAtom arg2 -> 
625 626 627 628
		  unboxedTupleReturn d s p arg1
	_other -> unboxedTupleException

   -- Case 3: Ordinary data constructor
629
   | Just con <- maybe_saturated_dcon
630 631 632 633
   = do alloc_con <- mkConAppCode d s p con args_r_to_l
        return (alloc_con	 `appOL` 
                  mkSLIDE 1 (d - s) `snocOL`
                  ENTER)
634 635

   -- Case 4: Tail call of function 
636
   | otherwise
637
   = doTailCall d s p fn args_r_to_l
638

639 640 641 642
   where
      -- Detect and extract relevant info for the tagToEnum kludge.
      maybe_is_tagToEnum_call
         = let extract_constr_Names ty
643 644 645 646 647 648 649 650
		 | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
		   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
		   = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
           in
651
           case app of
652
              (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
653
                 -> case isPrimOpId_maybe v of
654
                       Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
Ian Lynagh's avatar
Ian Lynagh committed
655 656
		       _		-> Nothing
              _ -> Nothing
657

658 659 660 661
	-- Extract the args (R->L) and fn
	-- The function will necessarily be a variable, 
	-- because we are compiling a tail call
      (AnnVar fn, args_r_to_l) = splitApp app
662

663
      -- Only consider this to be a constructor application iff it is
664
      -- saturated.  Otherwise, we'll call the constructor wrapper.
665 666
      n_args = length args_r_to_l
      maybe_saturated_dcon  
667
	= case isDataConWorkId_maybe fn of
668 669
		Just con | dataConRepArity con == n_args -> Just con
		_ -> Nothing
670

671
-- -----------------------------------------------------------------------------
672 673 674
-- Generate code to build a constructor application, 
-- leaving it on top of the stack

675
mkConAppCode :: Word16 -> Sequel -> BCEnv
676 677 678 679
	     -> DataCon 		-- The data constructor
	     -> [AnnExpr' Id VarSet] 	-- Args, in *reverse* order
	     -> BcM BCInstrList

Ian Lynagh's avatar
Ian Lynagh committed
680
mkConAppCode _ _ _ con []	-- Nullary constructor
681
  = ASSERT( isNullaryRepDataCon con )
682
    return (unitOL (PUSH_G (getName (dataConWorkId con))))
683 684 685
	-- Instead of doing a PACK, which would allocate a fresh
	-- copy of this constructor, use the single shared version.

Ian Lynagh's avatar
Ian Lynagh committed
686
mkConAppCode orig_d _ p con args_r_to_l 
687 688
  = ASSERT( dataConRepArity con == length args_r_to_l )
    do_pushery orig_d (non_ptr_args ++ ptr_args)
689 690 691
 where
	-- 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.
692
      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
693 694

      do_pushery d (arg:args)
695 696 697
         = do (push, arg_words) <- pushAtom d p arg
              more_push_code <- do_pushery (d+arg_words) args
              return (push `appOL` more_push_code)
698
      do_pushery d []
699
         = return (unitOL (PACK con n_arg_words))
700 701 702
	 where
	   n_arg_words = d - orig_d

703 704 705 706 707 708 709 710 711

-- -----------------------------------------------------------------------------
-- 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
712
	:: Word16 -> Sequel -> BCEnv
713 714 715
	-> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
  (push, sz) <- pushAtom d p arg
716
  return (push `appOL`
717 718 719 720 721 722 723
	    mkSLIDE sz (d-s) `snocOL`
	    RETURN_UBX (atomRep arg))

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

doTailCall
724
	:: Word16 -> Sequel -> BCEnv
725 726 727
	-> Id -> [AnnExpr' Id VarSet]
	-> BcM BCInstrList
doTailCall init_d s p fn args
728
  = do_pushes init_d args (map atomRep args)
729 730
  where
  do_pushes d [] reps = do
731
	ASSERT( null reps ) return ()
732
        (push_fn, sz) <- pushAtom d p (AnnVar fn)
733
	ASSERT( sz == 1 ) return ()
734
	return (push_fn `appOL` (
735 736 737 738 739 740 741 742
		  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
		  unitOL ENTER))
  do_pushes d args reps = do
      let (push_apply, n, rest_of_reps) = findPushSeq reps
	  (these_args, rest_of_args) = splitAt n args
      (next_d, push_code) <- push_seq d these_args
      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps 
		--                ^^^ for the PUSH_APPLY_ instruction
743
      return (push_code `appOL` (push_apply `consOL` instrs))
744 745 746 747 748 749 750 751

  push_seq d [] = return (d, nilOL)
  push_seq d (arg:args) = do
    (push_code, sz) <- pushAtom d p arg 
    (final_d, more_push_code) <- push_seq (d+sz) args
    return (final_d, push_code `appOL` more_push_code)

-- v. similar to CgStackery.findMatch, ToDo: merge
Ian Lynagh's avatar
Ian Lynagh committed
752
findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep])
753
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
754
  = (PUSH_APPLY_PPPPPP, 6, rest)
755
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
756
  = (PUSH_APPLY_PPPPP, 5, rest)
757
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
758
  = (PUSH_APPLY_PPPP, 4, rest)
759
findPushSeq (PtrArg: PtrArg: PtrArg: rest)
760
  = (PUSH_APPLY_PPP, 3, rest)
761
findPushSeq (PtrArg: PtrArg: rest)
762
  = (PUSH_APPLY_PP, 2, rest)
763
findPushSeq (PtrArg: rest)
764
  = (PUSH_APPLY_P, 1, rest)
765
findPushSeq (VoidArg: rest)
766
  = (PUSH_APPLY_V, 1, rest)
767
findPushSeq (NonPtrArg: rest)
768
  = (PUSH_APPLY_N, 1, rest)
769
findPushSeq (FloatArg: rest)
770
  = (PUSH_APPLY_F, 1, rest)
771
findPushSeq (DoubleArg: rest)
772
  = (PUSH_APPLY_D, 1, rest)
773
findPushSeq (LongArg: rest)
774 775 776 777 778 779 780
  = (PUSH_APPLY_L, 1, rest)
findPushSeq _
  = panic "ByteCodeGen.findPushSeq"

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

781
doCase  :: Word16 -> Sequel -> BCEnv
782 783 784
	-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
	-> Bool  -- True <=> is an unboxed tuple case, don't enter the result
	-> BcM BCInstrList
785
doCase d s p (_,scrut) bndr alts is_unboxed_tuple 
786 787 788 789 790 791 792 793 794 795 796 797 798
  = 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.
        ret_frame_sizeW = 2

	-- An unlifted value gets an extra info table pushed on top
	-- when it is returned.
	unlifted_itbl_sizeW | isAlgCase = 0
	  		    | otherwise = 1

	-- depth of stack after the return value has been pushed
799
	d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
800 801 802 803 804 805 806 807

	-- 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.
        d_alts = d_bndr + unlifted_itbl_sizeW

        -- Env in which to compile the alts, not including
        -- any vars bound by the alts themselves
808
        p_alts = Map.insert bndr (d_bndr - 1) p
809 810 811 812 813

	bndr_ty = idType bndr
        isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple

        -- given an alt, return a discr and code for it.
Ian Lynagh's avatar
Ian Lynagh committed
814
	codeAlt (DEFAULT, _, (_,rhs))
815 816
	   = do rhs_code <- schemeE d_alts s p_alts rhs
	        return (NoDiscr, rhs_code)
817

Ian Lynagh's avatar
Ian Lynagh committed
818
        codeAlt alt@(_, bndrs, (_,rhs))
819 820 821
	   -- primitive or nullary constructor alt: no need to UNPACK
	   | null real_bndrs = do
		rhs_code <- schemeE d_alts s p_alts rhs
822
                return (my_discr alt, rhs_code)
823
	   -- algebraic alt with some binders
Ian Lynagh's avatar
Ian Lynagh committed
824
           | otherwise =
825
             let
826
		 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
827 828
		 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
		 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
829 830 831
		 bind_sizes   = ptr_sizes ++ nptrs_sizes
		 size         = sum ptr_sizes + sum nptrs_sizes
		 -- the UNPACK instruction unpacks in reverse order...
832
		 p' = Map.insertList
833 834
			(zip (reverse (ptrs ++ nptrs))
			  (mkStackOffsets d_alts (reverse bind_sizes)))
835
                        p_alts 
836
	     in do
Ian Lynagh's avatar
Ian Lynagh committed
837
             MASSERT(isAlgCase)
838 839 840
	     rhs_code <- schemeE (d_alts+size) s p' rhs
             return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
	   where
841
	     real_bndrs = filter (not.isTyCoVar) bndrs
842

Ian Lynagh's avatar
Ian Lynagh committed
843 844
        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
        my_discr (DataAlt dc, _, _) 
845 846 847
           | isUnboxedTupleCon dc
           = unboxedTupleException
           | otherwise
848
           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
Ian Lynagh's avatar
Ian Lynagh committed
849
        my_discr (LitAlt l, _, _)
850
           = case l of MachInt i     -> DiscrI (fromInteger i)
851
                       MachWord w    -> DiscrW (fromInteger w)
852 853
                       MachFloat r   -> DiscrF (fromRational r)
                       MachDouble r  -> DiscrD (fromRational r)
854
                       MachChar i    -> DiscrI (ord i)
855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870
                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)

        maybe_ncons 
           | not isAlgCase = Nothing
           | otherwise 
           = case [dc | (DataAlt dc, _, _) <- alts] of
                []     -> Nothing
                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))

	-- the bitmap is relative to stack depth d, i.e. before the
	-- BCO, info table and return value are pushed on.
	-- This bit of code is v. similar to buildLivenessMask in CgBindery,
	-- except that here we build the bitmap from the known bindings of
	-- things that are pointers, whereas in CgBindery the code builds the
	-- bitmap from the free slots and unboxed bindings.
	-- (ToDo: merge?)
Simon Marlow's avatar
Simon Marlow committed
871 872 873 874 875 876 877 878
        --
        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
        -- The bitmap must cover the portion of the stack up to the sequel only.
        -- Previously we were building a bitmap for the whole depth (d), but we
        -- really want a bitmap up to depth (d-s).  This affects compilation of
        -- case-of-case expressions, which is the only time we can be compiling a
        -- case expression with s /= 0.
        bitmap_size = d-s
879 880 881 882
        bitmap_size' :: Int
        bitmap_size' = fromIntegral bitmap_size
	bitmap = intsToReverseBitmap bitmap_size'{-size-}
                        (sortLe (<=) (filter (< bitmap_size') rel_slots))
883
	  where
884
	  binds = Map.toList p
885
	  rel_slots = map fromIntegral $ concat (map spread binds)
886
	  spread (id, offset)
887
		| isFollowableArg (idCgRep id) = [ rel_offset ]
888 889 890 891 892 893
		| otherwise = []
		where rel_offset = d - offset - 1

     in do
     alt_stuff <- mapM codeAlt alts
     alt_final <- mkMultiBranch maybe_ncons alt_stuff
894

895 896 897
     let 
         alt_bco_name = getName bndr
         alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
Simon Marlow's avatar
Simon Marlow committed
898
			0{-no arity-} bitmap_size bitmap True{-is alts-}
899 900 901 902 903 904 905
     -- in
--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--	     "\n      bitmap = " ++ show bitmap) $ do
     scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
     alt_bco' <- emitBc alt_bco
     let push_alts
	    | isAlgCase = PUSH_ALTS alt_bco'
906
	    | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
907
     return (push_alts `consOL` scrut_code)
908 909 910 911 912 913


-- -----------------------------------------------------------------------------
-- Deal with a CCall.

-- Taggedly push the args onto the stack R->L,
914 915
-- deferencing ForeignObj#s and adjusting addrs to point to
-- payloads in Ptr/Byte arrays.  Then, generate the marshalling
916 917 918
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.  

919
generateCCall :: Word16 -> Sequel 		-- stack and sequel depths
920
              -> BCEnv