compiler/ghci/ByteCodeGen.lhs

   1 %
   2 % (c) The University of Glasgow 2002
   3 %
   4 \section[ByteCodeGen]{Generate bytecode from Core}
   5
   6 \begin{code}
   7 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import ByteCodeInstr
  12 import ByteCodeFFI      ( mkMarshalCode, moan64 )
  13 import ByteCodeAsm      ( CompiledByteCode(..), UnlinkedBCO,
  14                           assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
  15 import ByteCodeLink     ( lookupStaticPtr )
  16
  17 import Outputable
  18 import Name             ( Name, getName, mkSystemVarName )
  19 import Id
  20 import FiniteMap
  21 import ForeignCall      ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
  22 import HscTypes         ( TypeEnv, typeEnvTyCons, typeEnvClasses )
  23 import CoreUtils        ( exprType )
  24 import CoreSyn
  25 import PprCore          ( pprCoreExpr )
  26 import Literal          ( Literal(..), literalType )
  27 import PrimOp           ( PrimOp(..) )
  28 import CoreFVs          ( freeVars )
  29 import Type             ( isUnLiftedType, splitTyConApp_maybe )
  30 import DataCon          ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
  31                           isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
  32                           dataConRepArity )
  33 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon,
  34                           tyConDataCons, isUnboxedTupleTyCon )
  35 import Class            ( Class, classTyCon )
  36 import Type             ( Type, repType, splitFunTys, dropForAlls, pprType )
  37 import Util
  38 import DataCon          ( dataConRepArity )
  39 import Var              ( isTyVar )
  40 import VarSet           ( VarSet, varSetElems )
  41 import TysPrim          ( arrayPrimTyCon, mutableArrayPrimTyCon,
  42                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon
  43                         )
  44 import DynFlags ( DynFlags, DynFlag(..) )
  45 import ErrUtils         ( showPass, dumpIfSet_dyn )
  46 import Unique           ( mkPseudoUniqueE )
  47 import FastString       ( FastString(..), unpackFS )
  48 import Panic            ( GhcException(..) )
  49 import SMRep            ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord,
  50                           CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
  51 import Bitmap           ( intsToReverseBitmap, mkBitmap )
  52 import OrdList
  53 import Constants        ( wORD_SIZE )
  54
  55 import Data.List        ( intersperse, sortBy, zip4, zip6, partition )
  56 import Foreign          ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
  57                           withForeignPtr )
  58 import Foreign.C        ( CInt )
  59 import Control.Exception        ( throwDyn )
  60
  61 import GHC.Exts         ( Int(..), ByteArray# )
  62
  63 import Control.Monad    ( when )
  64 import Data.Char        ( ord, chr )
  65
  66 -- -----------------------------------------------------------------------------
  67 -- Generating byte code for a complete module
  68
  69 byteCodeGen :: DynFlags
  70             -> [CoreBind]
  71             -> [TyCon]
  72             -> IO CompiledByteCode
  73 byteCodeGen dflags binds tycs
  74    = do showPass dflags "ByteCodeGen"
  75
  76         let flatBinds = [ (bndr, freeVars rhs)
  77                         | (bndr, rhs) <- flattenBinds binds]
  78
  79         (BcM_State final_ctr mallocd, proto_bcos)
  80            <- runBc (mapM schemeTopBind flatBinds)
  81
  82         when (notNull mallocd)
  83              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
  84
  85         dumpIfSet_dyn dflags Opt_D_dump_BCOs
  86            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
  87
  88         assembleBCOs proto_bcos tycs
  89
  90 -- -----------------------------------------------------------------------------
  91 -- Generating byte code for an expression
  92
  93 -- Returns: (the root BCO for this expression,
  94 --           a list of auxilary BCOs resulting from compiling closures)
  95 coreExprToBCOs :: DynFlags
  96                -> CoreExpr
  97                -> IO UnlinkedBCO
  98 coreExprToBCOs dflags expr
  99  = do showPass dflags "ByteCodeGen"
 100
 101       -- create a totally bogus name for the top-level BCO; this
 102       -- should be harmless, since it's never used for anything
 103       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
 104           invented_id    = mkLocalId invented_name (panic "invented_id's type")
 105
 106       (BcM_State final_ctr mallocd, proto_bco)
 107          <- runBc (schemeTopBind (invented_id, freeVars expr))
 108
 109       when (notNull mallocd)
 110            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
 111
 112       dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
 113
 114       assembleBCO proto_bco
 115
 116
 117 -- -----------------------------------------------------------------------------
 118 -- Compilation schema for the bytecode generator
 119
 120 type BCInstrList = OrdList BCInstr
 121
 122 type Sequel = Int       -- back off to this depth before ENTER
 123
 124 -- Maps Ids to the offset from the stack _base_ so we don't have
 125 -- to mess with it after each push/pop.
 126 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
 127
 128 ppBCEnv :: BCEnv -> SDoc
 129 ppBCEnv p
 130    = text "begin-env"
 131      $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
 132      $$ text "end-env"
 133      where
 134         pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
 135         cmp_snd x y = compare (snd x) (snd y)
 136
 137 -- Create a BCO and do a spot of peephole optimisation on the insns
 138 -- at the same time.
 139 mkProtoBCO
 140    :: name
 141    -> BCInstrList
 142    -> Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet)
 143    -> Int
 144    -> Int
 145    -> [StgWord]
 146    -> Bool      -- True <=> is a return point, rather than a function
 147    -> [Ptr ()]
 148    -> ProtoBCO name
 149 mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
 150   is_ret mallocd_blocks
 151    = ProtoBCO {
 152         protoBCOName = nm,
 153         protoBCOInstrs = maybe_with_stack_check,
 154         protoBCOBitmap = bitmap,
 155         protoBCOBitmapSize = bitmap_size,
 156         protoBCOArity = arity,
 157         protoBCOExpr = origin,
 158         protoBCOPtrs = mallocd_blocks
 159       }
 160      where
 161         -- Overestimate the stack usage (in words) of this BCO,
 162         -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
 163         -- stack check.  (The interpreter always does a stack check
 164         -- for iNTERP_STACK_CHECK_THRESH words at the start of each
 165         -- BCO anyway, so we only need to add an explicit on in the
 166         -- (hopefully rare) cases when the (overestimated) stack use
 167         -- exceeds iNTERP_STACK_CHECK_THRESH.
 168         maybe_with_stack_check
 169            | is_ret = peep_d
 170                 -- don't do stack checks at return points;
 171                 -- everything is aggregated up to the top BCO
 172                 -- (which must be a function)
 173            | stack_overest >= 65535
 174            = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
 175                       (int stack_overest)
 176            | stack_overest >= iNTERP_STACK_CHECK_THRESH
 177            = STKCHECK stack_overest : peep_d
 178            | otherwise
 179            = peep_d     -- the supposedly common case
 180
 181         stack_overest = sum (map bciStackUse peep_d)
 182
 183         -- Merge local pushes
 184         peep_d = peep (fromOL instrs_ordlist)
 185
 186         peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
 187            = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
 188         peep (PUSH_L off1 : PUSH_L off2 : rest)
 189            = PUSH_LL off1 (off2-1) : peep rest
 190         peep (i:rest)
 191            = i : peep rest
 192         peep []
 193            = []
 194
 195 argBits :: [CgRep] -> [Bool]
 196 argBits [] = []
 197 argBits (rep : args)
 198   | isFollowableArg rep = False : argBits args
 199   | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
 200
 201 -- -----------------------------------------------------------------------------
 202 -- schemeTopBind
 203
 204 -- Compile code for the right-hand side of a top-level binding
 205
 206 schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
 207
 208
 209 schemeTopBind (id, rhs)
 210   | Just data_con <- isDataConWorkId_maybe id,
 211     isNullaryRepDataCon data_con
 212   =     -- Special case for the worker of a nullary data con.
 213         -- It'll look like this:        Nil = /\a -> Nil a
 214         -- If we feed it into schemeR, we'll get
 215         --      Nil = Nil
 216         -- because mkConAppCode treats nullary constructor applications
 217         -- by just re-using the single top-level definition.  So
 218         -- for the worker itself, we must allocate it directly.
 219     emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
 220                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
 221
 222   | otherwise
 223   = schemeR [{- No free variables -}] (id, rhs)
 224
 225 -- -----------------------------------------------------------------------------
 226 -- schemeR
 227
 228 -- Compile code for a right-hand side, to give a BCO that,
 229 -- when executed with the free variables and arguments on top of the stack,
 230 -- will return with a pointer to the result on top of the stack, after
 231 -- removing the free variables and arguments.
 232 --
 233 -- Park the resulting BCO in the monad.  Also requires the
 234 -- variable to which this value was bound, so as to give the
 235 -- resulting BCO a name.
 236
 237 schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
 238                                 -- will appear in the thunk.  Empty for
 239                                 -- top-level things, which have no free vars.
 240         -> (Id, AnnExpr Id VarSet)
 241         -> BcM (ProtoBCO Name)
 242 schemeR fvs (nm, rhs)
 243 {-
 244    | trace (showSDoc (
 245               (char ' '
 246                $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
 247                $$ pprCoreExpr (deAnnotate rhs)
 248                $$ char ' '
 249               ))) False
 250    = undefined
 251    | otherwise
 252 -}
 253    = schemeR_wrk fvs nm rhs (collect [] rhs)
 254
 255 collect xs (_, AnnNote note e) = collect xs e
 256 collect xs (_, AnnLam x e)     = collect (if isTyVar x then xs else (x:xs)) e
 257 collect xs (_, not_lambda)     = (reverse xs, not_lambda)
 258
 259 schemeR_wrk fvs nm original_body (args, body)
 260    = let
 261          all_args  = reverse args ++ fvs
 262          arity     = length all_args
 263          -- all_args are the args in reverse order.  We're compiling a function
 264          -- \fv1..fvn x1..xn -> e
 265          -- i.e. the fvs come first
 266
 267          szsw_args = map idSizeW all_args
 268          szw_args  = sum szsw_args
 269          p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
 270
 271          -- make the arg bitmap
 272          bits = argBits (reverse (map idCgRep all_args))
 273          bitmap_size = length bits
 274          bitmap = mkBitmap bits
 275      in
 276      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 277      emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
 278                 arity bitmap_size bitmap False{-not alts-})
 279
 280
 281 fvsToEnv :: BCEnv -> VarSet -> [Id]
 282 -- Takes the free variables of a right-hand side, and
 283 -- delivers an ordered list of the local variables that will
 284 -- be captured in the thunk for the RHS
 285 -- The BCEnv argument tells which variables are in the local
 286 -- environment: these are the ones that should be captured
 287 --
 288 -- The code that constructs the thunk, and the code that executes
 289 -- it, have to agree about this layout
 290 fvsToEnv p fvs = [v | v <- varSetElems fvs,
 291                       isId v,           -- Could be a type variable
 292                       v `elemFM` p]
 293
 294 -- -----------------------------------------------------------------------------
 295 -- schemeE
 296
 297 -- Compile code to apply the given expression to the remaining args
 298 -- on the stack, returning a HNF.
 299 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 300
 301 -- Delegate tail-calls to schemeT.
 302 schemeE d s p e@(AnnApp f a)
 303    = schemeT d s p e
 304
 305 schemeE d s p e@(AnnVar v)
 306    | not (isUnLiftedType v_type)
 307    =  -- Lifted-type thing; push it in the normal way
 308      schemeT d s p e
 309
 310    | otherwise
 311    = -- Returning an unlifted value.
 312      -- Heave it on the stack, SLIDE, and RETURN.
 313      pushAtom d p (AnnVar v)    `thenBc` \ (push, szw) ->
 314      returnBc (push                     -- value onto stack
 315                `appOL`  mkSLIDE szw (d-s)       -- clear to sequel
 316                `snocOL` RETURN_UBX v_rep)       -- go
 317    where
 318       v_type = idType v
 319       v_rep = typeCgRep v_type
 320
 321 schemeE d s p (AnnLit literal)
 322    = pushAtom d p (AnnLit literal)      `thenBc` \ (push, szw) ->
 323      let l_rep = typeCgRep (literalType literal)
 324      in  returnBc (push                         -- value onto stack
 325                    `appOL`  mkSLIDE szw (d-s)   -- clear to sequel
 326                    `snocOL` RETURN_UBX l_rep)   -- go
 327
 328
 329 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
 330    | (AnnVar v, args_r_to_l) <- splitApp rhs,
 331      Just data_con <- isDataConWorkId_maybe v,
 332      dataConRepArity data_con == length args_r_to_l
 333    =    -- Special case for a non-recursive let whose RHS is a
 334         -- saturatred constructor application.
 335         -- Just allocate the constructor and carry on
 336      mkConAppCode d s p data_con args_r_to_l    `thenBc` \ alloc_code ->
 337      schemeE (d+1) s (addToFM p x d) body       `thenBc` \ body_code ->
 338      returnBc (alloc_code `appOL` body_code)
 339
 340 -- General case for let.  Generates correct, if inefficient, code in
 341 -- all situations.
 342 schemeE d s p (AnnLet binds (_,body))
 343    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 344                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 345          n_binds = length xs
 346
 347          fvss  = map (fvsToEnv p' . fst) rhss
 348
 349          -- Sizes of free vars
 350          sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
 351
 352          -- the arity of each rhs
 353          arities = map (length . fst . collect []) rhss
 354
 355          -- This p', d' defn is safe because all the items being pushed
 356          -- are ptrs, so all have size 1.  d' and p' reflect the stack
 357          -- after the closures have been allocated in the heap (but not
 358          -- filled in), and pointers to them parked on the stack.
 359          p'    = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n_binds 1)))
 360          d'    = d + n_binds
 361          zipE  = zipEqual "schemeE"
 362
 363          -- ToDo: don't build thunks for things with no free variables
 364          build_thunk dd [] size bco off arity
 365             = returnBc (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
 366            where
 367                 mkap | arity == 0 = MKAP
 368                      | otherwise  = MKPAP
 369          build_thunk dd (fv:fvs) size bco off arity = do
 370               (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
 371               more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
 372               returnBc (push_code `appOL` more_push_code)
 373
 374          alloc_code = toOL (zipWith mkAlloc sizes arities)
 375            where mkAlloc sz 0     = ALLOC_AP sz
 376                  mkAlloc sz arity = ALLOC_PAP arity sz
 377
 378          compile_bind d' fvs x rhs size arity off = do
 379                 bco <- schemeR fvs (x,rhs)
 380                 build_thunk d' fvs size bco off arity
 381
 382          compile_binds =
 383             [ compile_bind d' fvs x rhs size arity n
 384             | (fvs, x, rhs, size, arity, n) <-
 385                 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
 386             ]
 387      in do
 388      body_code <- schemeE d' s p' body
 389      thunk_codes <- sequence compile_binds
 390      returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 391
 392
 393
 394 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
 395    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
 396         -- Convert
 397         --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
 398         -- to
 399         --      case .... of a { DEFAULT -> ... }
 400         -- becuse the return convention for both are identical.
 401         --
 402         -- Note that it does not matter losing the void-rep thing from the
 403         -- envt (it won't be bound now) because we never look such things up.
 404
 405    = --trace "automagic mashing of case alts (# VoidArg, a #)" $
 406      doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 407
 408    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
 409    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
 410      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 411
 412 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
 413    | isUnboxedTupleCon dc
 414         -- Similarly, convert
 415         --      case .... of x { (# a #) -> ... }
 416         -- to
 417         --      case .... of a { DEFAULT -> ... }
 418    = --trace "automagic mashing of case alts (# a #)"  $
 419      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 420
 421 schemeE d s p (AnnCase scrut bndr _ alts)
 422    = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
 423
 424 schemeE d s p (AnnNote note (_, body))
 425    = schemeE d s p body
 426
 427 schemeE d s p (AnnCast (_, body) _)
 428    = schemeE d s p body
 429
 430 -- XXX - audreyt - After FC landed, this case of explicit eta-reduction
 431 --       seems needed to make "data D = D deriving Typeable" work in GHCi.
 432 --       however, how did AnnLam with a var (LocalId) survive until this place?
 433 schemeE d s p (AnnLam var (_, AnnApp (_, body) (_, AnnVar inner)))
 434    | var == inner
 435    = schemeE d s p body
 436
 437 schemeE d s p other
 438    = pprPanic "ByteCodeGen.schemeE: unhandled case"
 439                (pprCoreExpr (deAnnotate' other))
 440
 441
 442 -- Compile code to do a tail call.  Specifically, push the fn,
 443 -- slide the on-stack app back down to the sequel depth,
 444 -- and enter.  Four cases:
 445 --
 446 -- 0.  (Nasty hack).
 447 --     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
 448 --     The int will be on the stack.  Generate a code sequence
 449 --     to convert it to the relevant constructor, SLIDE and ENTER.
 450 --
 451 -- 1.  The fn denotes a ccall.  Defer to generateCCall.
 452 --
 453 -- 2.  (Another nasty hack).  Spot (# a::VoidArg, b #) and treat
 454 --     it simply as  b  -- since the representations are identical
 455 --     (the VoidArg takes up zero stack space).  Also, spot
 456 --     (# b #) and treat it as  b.
 457 --
 458 -- 3.  Application of a constructor, by defn saturated.
 459 --     Split the args into ptrs and non-ptrs, and push the nonptrs,
 460 --     then the ptrs, and then do PACK and RETURN.
 461 --
 462 -- 4.  Otherwise, it must be a function call.  Push the args
 463 --     right to left, SLIDE and ENTER.
 464
 465 schemeT :: Int          -- Stack depth
 466         -> Sequel       -- Sequel depth
 467         -> BCEnv        -- stack env
 468         -> AnnExpr' Id VarSet
 469         -> BcM BCInstrList
 470
 471 schemeT d s p app
 472
 473 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 474 --   = panic "schemeT ?!?!"
 475
 476 --   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
 477 --   = error "?!?!"
 478
 479    -- Case 0
 480    | Just (arg, constr_names) <- maybe_is_tagToEnum_call
 481    = pushAtom d p arg                   `thenBc` \ (push, arg_words) ->
 482      implement_tagToId constr_names     `thenBc` \ tagToId_sequence ->
 483      returnBc (push `appOL`  tagToId_sequence
 484                     `appOL`  mkSLIDE 1 (d+arg_words-s)
 485                     `snocOL` ENTER)
 486
 487    -- Case 1
 488    | Just (CCall ccall_spec) <- isFCallId_maybe fn
 489    = generateCCall d s p ccall_spec fn args_r_to_l
 490
 491    -- Case 2: Constructor application
 492    | Just con <- maybe_saturated_dcon,
 493      isUnboxedTupleCon con
 494    = case args_r_to_l of
 495         [arg1,arg2] | isVoidArgAtom arg1 ->
 496                   unboxedTupleReturn d s p arg2
 497         [arg1,arg2] | isVoidArgAtom arg2 ->
 498                   unboxedTupleReturn d s p arg1
 499         _other -> unboxedTupleException
 500
 501    -- Case 3: Ordinary data constructor
 502    | Just con <- maybe_saturated_dcon
 503    = mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con ->
 504      returnBc (alloc_con         `appOL`
 505                mkSLIDE 1 (d - s) `snocOL`
 506                ENTER)
 507
 508    -- Case 4: Tail call of function
 509    | otherwise
 510    = doTailCall d s p fn args_r_to_l
 511
 512    where
 513       -- Detect and extract relevant info for the tagToEnum kludge.
 514       maybe_is_tagToEnum_call
 515          = let extract_constr_Names ty
 516                  | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
 517                    isDataTyCon tyc
 518                    = map (getName . dataConWorkId) (tyConDataCons tyc)
 519                    -- NOTE: use the worker name, not the source name of
 520                    -- the DataCon.  See DataCon.lhs for details.
 521                  | otherwise
 522                    = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 523            in
 524            case app of
 525               (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 526                  -> case isPrimOpId_maybe v of
 527                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 528                        other            -> Nothing
 529               other -> Nothing
 530
 531         -- Extract the args (R->L) and fn
 532         -- The function will necessarily be a variable,
 533         -- because we are compiling a tail call
 534       (AnnVar fn, args_r_to_l) = splitApp app
 535
 536       -- Only consider this to be a constructor application iff it is
 537       -- saturated.  Otherwise, we'll call the constructor wrapper.
 538       n_args = length args_r_to_l
 539       maybe_saturated_dcon
 540         = case isDataConWorkId_maybe fn of
 541                 Just con | dataConRepArity con == n_args -> Just con
 542                 _ -> Nothing
 543
 544 -- -----------------------------------------------------------------------------
 545 -- Generate code to build a constructor application,
 546 -- leaving it on top of the stack
 547
 548 mkConAppCode :: Int -> Sequel -> BCEnv
 549              -> DataCon                 -- The data constructor
 550              -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
 551              -> BcM BCInstrList
 552
 553 mkConAppCode orig_d s p con []  -- Nullary constructor
 554   = ASSERT( isNullaryRepDataCon con )
 555     returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
 556         -- Instead of doing a PACK, which would allocate a fresh
 557         -- copy of this constructor, use the single shared version.
 558
 559 mkConAppCode orig_d s p con args_r_to_l
 560   = ASSERT( dataConRepArity con == length args_r_to_l )
 561     do_pushery orig_d (non_ptr_args ++ ptr_args)
 562  where
 563         -- The args are already in reverse order, which is the way PACK
 564         -- expects them to be.  We must push the non-ptrs after the ptrs.
 565       (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
 566
 567       do_pushery d (arg:args)
 568          = pushAtom d p arg                     `thenBc` \ (push, arg_words) ->
 569            do_pushery (d+arg_words) args        `thenBc` \ more_push_code ->
 570            returnBc (push `appOL` more_push_code)
 571       do_pushery d []
 572          = returnBc (unitOL (PACK con n_arg_words))
 573          where
 574            n_arg_words = d - orig_d
 575
 576
 577 -- -----------------------------------------------------------------------------
 578 -- Returning an unboxed tuple with one non-void component (the only
 579 -- case we can handle).
 580 --
 581 -- Remember, we don't want to *evaluate* the component that is being
 582 -- returned, even if it is a pointed type.  We always just return.
 583
 584 unboxedTupleReturn
 585         :: Int -> Sequel -> BCEnv
 586         -> AnnExpr' Id VarSet -> BcM BCInstrList
 587 unboxedTupleReturn d s p arg = do
 588   (push, sz) <- pushAtom d p arg
 589   returnBc (push `appOL`
 590             mkSLIDE sz (d-s) `snocOL`
 591             RETURN_UBX (atomRep arg))
 592
 593 -- -----------------------------------------------------------------------------
 594 -- Generate code for a tail-call
 595
 596 doTailCall
 597         :: Int -> Sequel -> BCEnv
 598         -> Id -> [AnnExpr' Id VarSet]
 599         -> BcM BCInstrList
 600 doTailCall init_d s p fn args
 601   = do_pushes init_d args (map atomRep args)
 602   where
 603   do_pushes d [] reps = do
 604         ASSERT( null reps ) return ()
 605         (push_fn, sz) <- pushAtom d p (AnnVar fn)
 606         ASSERT( sz == 1 ) return ()
 607         returnBc (push_fn `appOL` (
 608                   mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
 609                   unitOL ENTER))
 610   do_pushes d args reps = do
 611       let (push_apply, n, rest_of_reps) = findPushSeq reps
 612           (these_args, rest_of_args) = splitAt n args
 613       (next_d, push_code) <- push_seq d these_args
 614       instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
 615                 --                ^^^ for the PUSH_APPLY_ instruction
 616       returnBc (push_code `appOL` (push_apply `consOL` instrs))
 617
 618   push_seq d [] = return (d, nilOL)
 619   push_seq d (arg:args) = do
 620     (push_code, sz) <- pushAtom d p arg
 621     (final_d, more_push_code) <- push_seq (d+sz) args
 622     return (final_d, push_code `appOL` more_push_code)
 623
 624 -- v. similar to CgStackery.findMatch, ToDo: merge
 625 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
 626   = (PUSH_APPLY_PPPPPP, 6, rest)
 627 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
 628   = (PUSH_APPLY_PPPPP, 5, rest)
 629 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
 630   = (PUSH_APPLY_PPPP, 4, rest)
 631 findPushSeq (PtrArg: PtrArg: PtrArg: rest)
 632   = (PUSH_APPLY_PPP, 3, rest)
 633 findPushSeq (PtrArg: PtrArg: rest)
 634   = (PUSH_APPLY_PP, 2, rest)
 635 findPushSeq (PtrArg: rest)
 636   = (PUSH_APPLY_P, 1, rest)
 637 findPushSeq (VoidArg: rest)
 638   = (PUSH_APPLY_V, 1, rest)
 639 findPushSeq (NonPtrArg: rest)
 640   = (PUSH_APPLY_N, 1, rest)
 641 findPushSeq (FloatArg: rest)
 642   = (PUSH_APPLY_F, 1, rest)
 643 findPushSeq (DoubleArg: rest)
 644   = (PUSH_APPLY_D, 1, rest)
 645 findPushSeq (LongArg: rest)
 646   = (PUSH_APPLY_L, 1, rest)
 647 findPushSeq _
 648   = panic "ByteCodeGen.findPushSeq"
 649
 650 -- -----------------------------------------------------------------------------
 651 -- Case expressions
 652
 653 doCase  :: Int -> Sequel -> BCEnv
 654         -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
 655         -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
 656         -> BcM BCInstrList
 657 doCase d s p (_,scrut)
 658  bndr alts is_unboxed_tuple
 659   = let
 660         -- Top of stack is the return itbl, as usual.
 661         -- underneath it is the pointer to the alt_code BCO.
 662         -- When an alt is entered, it assumes the returned value is
 663         -- on top of the itbl.
 664         ret_frame_sizeW = 2
 665
 666         -- An unlifted value gets an extra info table pushed on top
 667         -- when it is returned.
 668         unlifted_itbl_sizeW | isAlgCase = 0
 669                             | otherwise = 1
 670
 671         -- depth of stack after the return value has been pushed
 672         d_bndr = d + ret_frame_sizeW + idSizeW bndr
 673
 674         -- depth of stack after the extra info table for an unboxed return
 675         -- has been pushed, if any.  This is the stack depth at the
 676         -- continuation.
 677         d_alts = d_bndr + unlifted_itbl_sizeW
 678
 679         -- Env in which to compile the alts, not including
 680         -- any vars bound by the alts themselves
 681         p_alts = addToFM p bndr (d_bndr - 1)
 682
 683         bndr_ty = idType bndr
 684         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 685
 686         -- given an alt, return a discr and code for it.
 687         codeALt alt@(DEFAULT, _, (_,rhs))
 688            = schemeE d_alts s p_alts rhs        `thenBc` \ rhs_code ->
 689              returnBc (NoDiscr, rhs_code)
 690         codeAlt alt@(discr, bndrs, (_,rhs))
 691            -- primitive or nullary constructor alt: no need to UNPACK
 692            | null real_bndrs = do
 693                 rhs_code <- schemeE d_alts s p_alts rhs
 694                 returnBc (my_discr alt, rhs_code)
 695            -- algebraic alt with some binders
 696            | ASSERT(isAlgCase) otherwise =
 697              let
 698                  (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
 699                  ptr_sizes    = map idSizeW ptrs
 700                  nptrs_sizes  = map idSizeW nptrs
 701                  bind_sizes   = ptr_sizes ++ nptrs_sizes
 702                  size         = sum ptr_sizes + sum nptrs_sizes
 703                  -- the UNPACK instruction unpacks in reverse order...
 704                  p' = addListToFM p_alts
 705                         (zip (reverse (ptrs ++ nptrs))
 706                           (mkStackOffsets d_alts (reverse bind_sizes)))
 707              in do
 708              rhs_code <- schemeE (d_alts+size) s p' rhs
 709              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
 710            where
 711              real_bndrs = filter (not.isTyVar) bndrs
 712
 713
 714         my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
 715         my_discr (DataAlt dc, binds, rhs)
 716            | isUnboxedTupleCon dc
 717            = unboxedTupleException
 718            | otherwise
 719            = DiscrP (dataConTag dc - fIRST_TAG)
 720         my_discr (LitAlt l, binds, rhs)
 721            = case l of MachInt i     -> DiscrI (fromInteger i)
 722                        MachFloat r   -> DiscrF (fromRational r)
 723                        MachDouble r  -> DiscrD (fromRational r)
 724                        MachChar i    -> DiscrI (ord i)
 725                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 726
 727         maybe_ncons
 728            | not isAlgCase = Nothing
 729            | otherwise
 730            = case [dc | (DataAlt dc, _, _) <- alts] of
 731                 []     -> Nothing
 732                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 733
 734         -- the bitmap is relative to stack depth d, i.e. before the
 735         -- BCO, info table and return value are pushed on.
 736         -- This bit of code is v. similar to buildLivenessMask in CgBindery,
 737         -- except that here we build the bitmap from the known bindings of
 738         -- things that are pointers, whereas in CgBindery the code builds the
 739         -- bitmap from the free slots and unboxed bindings.
 740         -- (ToDo: merge?)
 741         bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
 742           where
 743           binds = fmToList p
 744           rel_slots = concat (map spread binds)
 745           spread (id, offset)
 746                 | isFollowableArg (idCgRep id) = [ rel_offset ]
 747                 | otherwise = []
 748                 where rel_offset = d - offset - 1
 749
 750      in do
 751      alt_stuff <- mapM codeAlt alts
 752      alt_final <- mkMultiBranch maybe_ncons alt_stuff
 753      let
 754          alt_bco_name = getName bndr
 755          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
 756                         0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
 757      -- in
 758 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 759 --           "\n      bitmap = " ++ show bitmap) $ do
 760      scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
 761      alt_bco' <- emitBc alt_bco
 762      let push_alts
 763             | isAlgCase = PUSH_ALTS alt_bco'
 764             | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
 765      returnBc (push_alts `consOL` scrut_code)
 766
 767
 768 -- -----------------------------------------------------------------------------
 769 -- Deal with a CCall.
 770
 771 -- Taggedly push the args onto the stack R->L,
 772 -- deferencing ForeignObj#s and adjusting addrs to point to
 773 -- payloads in Ptr/Byte arrays.  Then, generate the marshalling
 774 -- (machine) code for the ccall, and create bytecodes to call that and
 775 -- then return in the right way.
 776
 777 generateCCall :: Int -> Sequel          -- stack and sequel depths
 778               -> BCEnv
 779               -> CCallSpec              -- where to call
 780               -> Id                     -- of target, for type info
 781               -> [AnnExpr' Id VarSet]   -- args (atoms)
 782               -> BcM BCInstrList
 783
 784 generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 785    = let
 786          -- useful constants
 787          addr_sizeW = cgRepSizeW NonPtrArg
 788
 789          -- Get the args on the stack, with tags and suitably
 790          -- dereferenced for the CCall.  For each arg, return the
 791          -- depth to the first word of the bits for that arg, and the
 792          -- CgRep of what was actually pushed.
 793
 794          pargs d [] = returnBc []
 795          pargs d (a:az)
 796             = let arg_ty = repType (exprType (deAnnotate' a))
 797
 798               in case splitTyConApp_maybe arg_ty of
 799                     -- Don't push the FO; instead push the Addr# it
 800                     -- contains.
 801                     Just (t, _)
 802                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
 803                        -> pargs (d + addr_sizeW) az     `thenBc` \ rest ->
 804                           parg_ArrayishRep arrPtrsHdrSize d p a
 805                                                         `thenBc` \ code ->
 806                           returnBc ((code,NonPtrArg):rest)
 807
 808                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
 809                        -> pargs (d + addr_sizeW) az     `thenBc` \ rest ->
 810                           parg_ArrayishRep arrWordsHdrSize d p a
 811                                                         `thenBc` \ code ->
 812                           returnBc ((code,NonPtrArg):rest)
 813
 814                     -- Default case: push taggedly, but otherwise intact.
 815                     other
 816                        -> pushAtom d p a                `thenBc` \ (code_a, sz_a) ->
 817                           pargs (d+sz_a) az             `thenBc` \ rest ->
 818                           returnBc ((code_a, atomRep a) : rest)
 819
 820          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
 821          -- the stack but then advance it over the headers, so as to
 822          -- point to the payload.
 823          parg_ArrayishRep hdrSize d p a
 824             = pushAtom d p a `thenBc` \ (push_fo, _) ->
 825               -- The ptr points at the header.  Advance it over the
 826               -- header and then pretend this is an Addr#.
 827               returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize)
 828
 829      in
 830          pargs d0 args_r_to_l                   `thenBc` \ code_n_reps ->
 831      let
 832          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
 833
 834          push_args    = concatOL pushs_arg
 835          d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l)
 836          a_reps_pushed_RAW
 837             | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg
 838             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
 839             | otherwise
 840             = reverse (tail a_reps_pushed_r_to_l)
 841
 842          -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
 843          -- push_args is the code to do that.
 844          -- d_after_args is the stack depth once the args are on.
 845
 846          -- Get the result rep.
 847          (returns_void, r_rep)
 848             = case maybe_getCCallReturnRep (idType fn) of
 849                  Nothing -> (True,  VoidArg)
 850                  Just rr -> (False, rr)
 851          {-
 852          Because the Haskell stack grows down, the a_reps refer to
 853          lowest to highest addresses in that order.  The args for the call
 854          are on the stack.  Now push an unboxed Addr# indicating
 855          the C function to call.  Then push a dummy placeholder for the
 856          result.  Finally, emit a CCALL insn with an offset pointing to the
 857          Addr# just pushed, and a literal field holding the mallocville
 858          address of the piece of marshalling code we generate.
 859          So, just prior to the CCALL insn, the stack looks like this
 860          (growing down, as usual):
 861
 862             <arg_n>
 863             ...
 864             <arg_1>
 865             Addr# address_of_C_fn
 866             <placeholder-for-result#> (must be an unboxed type)
 867
 868          The interpreter then calls the marshall code mentioned
 869          in the CCALL insn, passing it (& <placeholder-for-result#>),
 870          that is, the addr of the topmost word in the stack.
 871          When this returns, the placeholder will have been
 872          filled in.  The placeholder is slid down to the sequel
 873          depth, and we RETURN.
 874
 875          This arrangement makes it simple to do f-i-dynamic since the Addr#
 876          value is the first arg anyway.
 877
 878          The marshalling code is generated specifically for this
 879          call site, and so knows exactly the (Haskell) stack
 880          offsets of the args, fn address and placeholder.  It
 881          copies the args to the C stack, calls the stacked addr,
 882          and parks the result back in the placeholder.  The interpreter
 883          calls it as a normal C call, assuming it has a signature
 884             void marshall_code ( StgWord* ptr_to_top_of_stack )
 885          -}
 886          -- resolve static address
 887          get_target_info
 888             = case target of
 889                  DynamicTarget
 890                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
 891                  StaticTarget target
 892                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
 893                        returnBc (True, res)
 894      in
 895          get_target_info        `thenBc` \ (is_static, static_target_addr) ->
 896      let
 897
 898          -- Get the arg reps, zapping the leading Addr# in the dynamic case
 899          a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
 900                 | is_static = a_reps_pushed_RAW
 901                 | otherwise = if null a_reps_pushed_RAW
 902                               then panic "ByteCodeGen.generateCCall: dyn with no args"
 903                               else tail a_reps_pushed_RAW
 904
 905          -- push the Addr#
 906          (push_Addr, d_after_Addr)
 907             | is_static
 908             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
 909                d_after_args + addr_sizeW)
 910             | otherwise -- is already on the stack
 911             = (nilOL, d_after_args)
 912
 913          -- Push the return placeholder.  For a call returning nothing,
 914          -- this is a VoidArg (tag).
 915          r_sizeW   = cgRepSizeW r_rep
 916          d_after_r = d_after_Addr + r_sizeW
 917          r_lit     = mkDummyLiteral r_rep
 918          push_r    = (if   returns_void
 919                       then nilOL
 920                       else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
 921
 922          -- generate the marshalling code we're going to call
 923          r_offW       = 0
 924          addr_offW    = r_sizeW
 925          arg1_offW    = r_sizeW + addr_sizeW
 926          args_offW    = map (arg1_offW +)
 927                             (init (scanl (+) 0 (map cgRepSizeW a_reps)))
 928      in
 929          ioToBc (mkMarshalCode cconv
 930                     (r_offW, r_rep) addr_offW
 931                     (zip args_offW a_reps))     `thenBc` \ addr_of_marshaller ->
 932          recordMallocBc addr_of_marshaller      `thenBc_`
 933      let
 934          -- Offset of the next stack frame down the stack.  The CCALL
 935          -- instruction needs to describe the chunk of stack containing
 936          -- the ccall args to the GC, so it needs to know how large it
 937          -- is.  See comment in Interpreter.c with the CCALL instruction.
 938          stk_offset   = d_after_r - s
 939
 940          -- do the call
 941          do_call      = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
 942          -- slide and return
 943          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
 944                         `snocOL` RETURN_UBX r_rep
 945      in
 946          --trace (show (arg1_offW, args_offW  ,  (map cgRepSizeW a_reps) )) $
 947          returnBc (
 948          push_args `appOL`
 949          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
 950          )
 951
 952
 953 -- Make a dummy literal, to be used as a placeholder for FFI return
 954 -- values on the stack.
 955 mkDummyLiteral :: CgRep -> Literal
 956 mkDummyLiteral pr
 957    = case pr of
 958         NonPtrArg -> MachWord 0
 959         DoubleArg -> MachDouble 0
 960         FloatArg  -> MachFloat 0
 961         _         -> moan64 "mkDummyLiteral" (ppr pr)
 962
 963
 964 -- Convert (eg)
 965 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 966 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 967 --
 968 -- to  Just IntRep
 969 -- and check that an unboxed pair is returned wherein the first arg is VoidArg'd.
 970 --
 971 -- Alternatively, for call-targets returning nothing, convert
 972 --
 973 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 974 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
 975 --
 976 -- to  Nothing
 977
 978 maybe_getCCallReturnRep :: Type -> Maybe CgRep
 979 maybe_getCCallReturnRep fn_ty
 980    = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
 981          maybe_r_rep_to_go
 982             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
 983          (r_tycon, r_reps)
 984             = case splitTyConApp_maybe (repType r_ty) of
 985                       (Just (tyc, tys)) -> (tyc, map typeCgRep tys)
 986                       Nothing -> blargh
 987          ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps)
 988                 || r_reps == [VoidArg] )
 989               && isUnboxedTupleTyCon r_tycon
 990               && case maybe_r_rep_to_go of
 991                     Nothing    -> True
 992                     Just r_rep -> r_rep /= PtrArg
 993                                   -- if it was, it would be impossible
 994                                   -- to create a valid return value
 995                                   -- placeholder on the stack
 996          blargh = pprPanic "maybe_getCCallReturn: can't handle:"
 997                            (pprType fn_ty)
 998      in
 999      --trace (showSDoc (ppr (a_reps, r_reps))) $
1000      if ok then maybe_r_rep_to_go else blargh
1001
1002 -- Compile code which expects an unboxed Int on the top of stack,
1003 -- (call it i), and pushes the i'th closure in the supplied list
1004 -- as a consequence.
1005 implement_tagToId :: [Name] -> BcM BCInstrList
1006 implement_tagToId names
1007    = ASSERT( notNull names )
1008      getLabelsBc (length names)                 `thenBc` \ labels ->
1009      getLabelBc                                 `thenBc` \ label_fail ->
1010      getLabelBc                                 `thenBc` \ label_exit ->
1011      zip4 labels (tail labels ++ [label_fail])
1012                  [0 ..] names                   `bind`   \ infos ->
1013      map (mkStep label_exit) infos              `bind`   \ steps ->
1014      returnBc (concatOL steps
1015                `appOL`
1016                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
1017      where
1018         mkStep l_exit (my_label, next_label, n, name_for_n)
1019            = toOL [LABEL my_label,
1020                    TESTEQ_I n next_label,
1021                    PUSH_G name_for_n,
1022                    JMP l_exit]
1023
1024
1025 -- -----------------------------------------------------------------------------
1026 -- pushAtom
1027
1028 -- Push an atom onto the stack, returning suitable code & number of
1029 -- stack words used.
1030 --
1031 -- The env p must map each variable to the highest- numbered stack
1032 -- slot for it.  For example, if the stack has depth 4 and we
1033 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1034 -- the tag in stack[5], the stack will have depth 6, and p must map v
1035 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
1036 -- depth 6 stack has valid words 0 .. 5.
1037
1038 pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
1039
1040 pushAtom d p (AnnApp f (_, AnnType _))
1041    = pushAtom d p (snd f)
1042
1043 pushAtom d p (AnnNote note e)
1044    = pushAtom d p (snd e)
1045
1046 pushAtom d p (AnnLam x e)
1047    | isTyVar x
1048    = pushAtom d p (snd e)
1049
1050 pushAtom d p (AnnVar v)
1051
1052    | idCgRep v == VoidArg
1053    = returnBc (nilOL, 0)
1054
1055    | isFCallId v
1056    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1057
1058    | Just primop <- isPrimOpId_maybe v
1059    = returnBc (unitOL (PUSH_PRIMOP primop), 1)
1060
1061    | Just d_v <- lookupBCEnv_maybe p v  -- v is a local variable
1062    = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
1063          -- d - d_v                 the number of words between the TOS
1064          --                         and the 1st slot of the object
1065          --
1066          -- d - d_v - 1             the offset from the TOS of the 1st slot
1067          --
1068          -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot
1069          --                         of the object.
1070          --
1071          -- Having found the last slot, we proceed to copy the right number of
1072          -- slots on to the top of the stack.
1073
1074     | otherwise  -- v must be a global variable
1075     = ASSERT(sz == 1)
1076       returnBc (unitOL (PUSH_G (getName v)), sz)
1077
1078     where
1079          sz = idSizeW v
1080
1081
1082 pushAtom d p (AnnLit lit)
1083    = case lit of
1084         MachLabel fs _ -> code NonPtrArg
1085         MachWord w     -> code NonPtrArg
1086         MachInt i      -> code PtrArg
1087         MachFloat r    -> code FloatArg
1088         MachDouble r   -> code DoubleArg
1089         MachChar c     -> code NonPtrArg
1090         MachStr s      -> pushStr s
1091      where
1092         code rep
1093            = let size_host_words = cgRepSizeW rep
1094              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1095                            size_host_words)
1096
1097         pushStr s
1098            = let getMallocvilleAddr
1099                     = case s of
1100                          FastString _ n _ fp _ ->
1101                             -- we could grab the Ptr from the ForeignPtr,
1102                             -- but then we have no way to control its lifetime.
1103                             -- In reality it'll probably stay alive long enoungh
1104                             -- by virtue of the global FastString table, but
1105                             -- to be on the safe side we copy the string into
1106                             -- a malloc'd area of memory.
1107                                 ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
1108                                 recordMallocBc ptr         `thenBc_`
1109                                 ioToBc (
1110                                    withForeignPtr fp $ \p -> do
1111                                       memcpy ptr p (fromIntegral n)
1112                                       pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1113                                       return ptr
1114                                    )
1115              in
1116                 getMallocvilleAddr `thenBc` \ addr ->
1117                 -- Get the addr on the stack, untaggedly
1118                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1119
1120 pushAtom d p other
1121    = pprPanic "ByteCodeGen.pushAtom"
1122               (pprCoreExpr (deAnnotate (undefined, other)))
1123
1124 foreign import ccall unsafe "memcpy"
1125  memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
1126
1127
1128 -- -----------------------------------------------------------------------------
1129 -- Given a bunch of alts code and their discrs, do the donkey work
1130 -- of making a multiway branch using a switch tree.
1131 -- What a load of hassle!
1132
1133 mkMultiBranch :: Maybe Int      --  # datacons in tycon, if alg alt
1134                                 -- a hint; generates better code
1135                                 -- Nothing is always safe
1136               -> [(Discr, BCInstrList)]
1137               -> BcM BCInstrList
1138 mkMultiBranch maybe_ncons raw_ways
1139    = let d_way     = filter (isNoDiscr.fst) raw_ways
1140          notd_ways = sortLe
1141                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1142                         (filter (not.isNoDiscr.fst) raw_ways)
1143
1144          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1145          mkTree [] range_lo range_hi = returnBc the_default
1146
1147          mkTree [val] range_lo range_hi
1148             | range_lo `eqAlt` range_hi
1149             = returnBc (snd val)
1150             | otherwise
1151             = getLabelBc                                `thenBc` \ label_neq ->
1152               returnBc (mkTestEQ (fst val) label_neq
1153                         `consOL` (snd val
1154                         `appOL`   unitOL (LABEL label_neq)
1155                         `appOL`   the_default))
1156
1157          mkTree vals range_lo range_hi
1158             = let n = length vals `div` 2
1159                   vals_lo = take n vals
1160                   vals_hi = drop n vals
1161                   v_mid = fst (head vals_hi)
1162               in
1163               getLabelBc                                `thenBc` \ label_geq ->
1164               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1165               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1166               returnBc (mkTestLT v_mid label_geq
1167                         `consOL` (code_lo
1168                         `appOL`   unitOL (LABEL label_geq)
1169                         `appOL`   code_hi))
1170
1171          the_default
1172             = case d_way of [] -> unitOL CASEFAIL
1173                             [(_, def)] -> def
1174
1175          -- None of these will be needed if there are no non-default alts
1176          (mkTestLT, mkTestEQ, init_lo, init_hi)
1177             | null notd_ways
1178             = panic "mkMultiBranch: awesome foursome"
1179             | otherwise
1180             = case fst (head notd_ways) of {
1181               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1182                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1183                             DiscrI minBound,
1184                             DiscrI maxBound );
1185               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1186                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1187                             DiscrF minF,
1188                             DiscrF maxF );
1189               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1190                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1191                             DiscrD minD,
1192                             DiscrD maxD );
1193               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1194                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1195                             DiscrP algMinBound,
1196                             DiscrP algMaxBound )
1197               }
1198
1199          (algMinBound, algMaxBound)
1200             = case maybe_ncons of
1201                  Just n  -> (0, n - 1)
1202                  Nothing -> (minBound, maxBound)
1203
1204          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1205          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1206          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1207          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1208          NoDiscr     `eqAlt` NoDiscr     = True
1209          _           `eqAlt` _           = False
1210
1211          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1212          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1213          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1214          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1215          NoDiscr     `leAlt` NoDiscr     = True
1216          _           `leAlt` _           = False
1217
1218          isNoDiscr NoDiscr = True
1219          isNoDiscr _       = False
1220
1221          dec (DiscrI i) = DiscrI (i-1)
1222          dec (DiscrP i) = DiscrP (i-1)
1223          dec other      = other         -- not really right, but if you
1224                 -- do cases on floating values, you'll get what you deserve
1225
1226          -- same snotty comment applies to the following
1227          minF, maxF :: Float
1228          minD, maxD :: Double
1229          minF = -1.0e37
1230          maxF =  1.0e37
1231          minD = -1.0e308
1232          maxD =  1.0e308
1233      in
1234          mkTree notd_ways init_lo init_hi
1235
1236
1237 -- -----------------------------------------------------------------------------
1238 -- Supporting junk for the compilation schemes
1239
1240 -- Describes case alts
1241 data Discr
1242    = DiscrI Int
1243    | DiscrF Float
1244    | DiscrD Double
1245    | DiscrP Int
1246    | NoDiscr
1247
1248 instance Outputable Discr where
1249    ppr (DiscrI i) = int i
1250    ppr (DiscrF f) = text (show f)
1251    ppr (DiscrD d) = text (show d)
1252    ppr (DiscrP i) = int i
1253    ppr NoDiscr    = text "DEF"
1254
1255
1256 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1257 lookupBCEnv_maybe = lookupFM
1258
1259 idSizeW :: Id -> Int
1260 idSizeW id = cgRepSizeW (typeCgRep (idType id))
1261
1262 unboxedTupleException :: a
1263 unboxedTupleException
1264    = throwDyn
1265         (Panic
1266            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1267             "\tto foreign import/export decls in source.  Workaround:\n" ++
1268             "\tcompile this module to a .o file, then restart session."))
1269
1270
1271 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1272 bind x f    = f x
1273
1274 splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
1275         -- The arguments are returned in *right-to-left* order
1276 splitApp (AnnApp (_,f) (_,a))
1277                | isTypeAtom a = splitApp f
1278                | otherwise    = case splitApp f of
1279                                      (f', as) -> (f', a:as)
1280 splitApp (AnnNote n (_,e))    = splitApp e
1281 splitApp e                    = (e, [])
1282
1283
1284 isTypeAtom :: AnnExpr' id ann -> Bool
1285 isTypeAtom (AnnType _) = True
1286 isTypeAtom _           = False
1287
1288 isVoidArgAtom :: AnnExpr' id ann -> Bool
1289 isVoidArgAtom (AnnVar v)        = typeCgRep (idType v) == VoidArg
1290 isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
1291 isVoidArgAtom _                 = False
1292
1293 atomRep :: AnnExpr' Id ann -> CgRep
1294 atomRep (AnnVar v)    = typeCgRep (idType v)
1295 atomRep (AnnLit l)    = typeCgRep (literalType l)
1296 atomRep (AnnNote n b) = atomRep (snd b)
1297 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
1298 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
1299 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
1300
1301 isPtrAtom :: AnnExpr' Id ann -> Bool
1302 isPtrAtom e = atomRep e == PtrArg
1303
1304 -- Let szsw be the sizes in words of some items pushed onto the stack,
1305 -- which has initial depth d'.  Return the values which the stack environment
1306 -- should map these items to.
1307 mkStackOffsets :: Int -> [Int] -> [Int]
1308 mkStackOffsets original_depth szsw
1309    = map (subtract 1) (tail (scanl (+) original_depth szsw))
1310
1311 -- -----------------------------------------------------------------------------
1312 -- The bytecode generator's monad
1313
1314 data BcM_State
1315    = BcM_State {
1316         nextlabel :: Int,               -- for generating local labels
1317         malloced  :: [Ptr ()] }         -- ptrs malloced for current BCO
1318                                         -- Should be free()d when it is GCd
1319
1320 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1321
1322 ioToBc :: IO a -> BcM a
1323 ioToBc io = BcM $ \st -> do
1324   x <- io
1325   return (st, x)
1326
1327 runBc :: BcM r -> IO (BcM_State, r)
1328 runBc (BcM m) = m (BcM_State 0 [])
1329
1330 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1331 thenBc (BcM expr) cont = BcM $ \st0 -> do
1332   (st1, q) <- expr st0
1333   let BcM k = cont q
1334   (st2, r) <- k st1
1335   return (st2, r)
1336
1337 thenBc_ :: BcM a -> BcM b -> BcM b
1338 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1339   (st1, q) <- expr st0
1340   (st2, r) <- cont st1
1341   return (st2, r)
1342
1343 returnBc :: a -> BcM a
1344 returnBc result = BcM $ \st -> (return (st, result))
1345
1346 instance Monad BcM where
1347   (>>=) = thenBc
1348   (>>)  = thenBc_
1349   return = returnBc
1350
1351 emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1352 emitBc bco
1353   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
1354
1355 recordMallocBc :: Ptr a -> BcM ()
1356 recordMallocBc a
1357   = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
1358
1359 getLabelBc :: BcM Int
1360 getLabelBc
1361   = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1362
1363 getLabelsBc :: Int -> BcM [Int]
1364 getLabelsBc n
1365   = BcM $ \st -> let ctr = nextlabel st
1366                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1367 \end{code}