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