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