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                  | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
 514                    isDataTyCon tyc
 515                    = map (getName . dataConWorkId) (tyConDataCons tyc)
 516                    -- NOTE: use the worker name, not the source name of
 517                    -- the DataCon.  See DataCon.lhs for details.
 518                  | otherwise
 519                    = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 520            in
 521            case app of
 522               (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 523                  -> case isPrimOpId_maybe v of
 524                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 525                        other            -> Nothing
 526               other -> Nothing
 527
 528         -- Extract the args (R->L) and fn
 529         -- The function will necessarily be a variable,
 530         -- because we are compiling a tail call
 531       (AnnVar fn, args_r_to_l) = splitApp app
 532
 533       -- Only consider this to be a constructor application iff it is
 534       -- saturated.  Otherwise, we'll call the constructor wrapper.
 535       n_args = length args_r_to_l
 536       maybe_saturated_dcon
 537         = case isDataConWorkId_maybe fn of
 538                 Just con | dataConRepArity con == n_args -> Just con
 539                 _ -> Nothing
 540
 541 -- -----------------------------------------------------------------------------
 542 -- Generate code to build a constructor application,
 543 -- leaving it on top of the stack
 544
 545 mkConAppCode :: Int -> Sequel -> BCEnv
 546              -> DataCon                 -- The data constructor
 547              -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
 548              -> BcM BCInstrList
 549
 550 mkConAppCode orig_d s p con []  -- Nullary constructor
 551   = ASSERT( isNullaryDataCon con )
 552     returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
 553         -- Instead of doing a PACK, which would allocate a fresh
 554         -- copy of this constructor, use the single shared version.
 555
 556 mkConAppCode orig_d s p con args_r_to_l
 557   = ASSERT( dataConRepArity con == length args_r_to_l )
 558     do_pushery orig_d (non_ptr_args ++ ptr_args)
 559  where
 560         -- The args are already in reverse order, which is the way PACK
 561         -- expects them to be.  We must push the non-ptrs after the ptrs.
 562       (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
 563
 564       do_pushery d (arg:args)
 565          = pushAtom d p arg                     `thenBc` \ (push, arg_words) ->
 566            do_pushery (d+arg_words) args        `thenBc` \ more_push_code ->
 567            returnBc (push `appOL` more_push_code)
 568       do_pushery d []
 569          = returnBc (unitOL (PACK con n_arg_words))
 570          where
 571            n_arg_words = d - orig_d
 572
 573
 574 -- -----------------------------------------------------------------------------
 575 -- Returning an unboxed tuple with one non-void component (the only
 576 -- case we can handle).
 577 --
 578 -- Remember, we don't want to *evaluate* the component that is being
 579 -- returned, even if it is a pointed type.  We always just return.
 580
 581 unboxedTupleReturn
 582         :: Int -> Sequel -> BCEnv
 583         -> AnnExpr' Id VarSet -> BcM BCInstrList
 584 unboxedTupleReturn d s p arg = do
 585   (push, sz) <- pushAtom d p arg
 586   returnBc (push `appOL`
 587             mkSLIDE sz (d-s) `snocOL`
 588             RETURN_UBX (atomRep arg))
 589
 590 -- -----------------------------------------------------------------------------
 591 -- Generate code for a tail-call
 592
 593 doTailCall
 594         :: Int -> Sequel -> BCEnv
 595         -> Id -> [AnnExpr' Id VarSet]
 596         -> BcM BCInstrList
 597 doTailCall init_d s p fn args
 598   = do_pushes init_d args (map (primRepToArgRep.atomRep) args)
 599   where
 600   do_pushes d [] reps = do
 601         ASSERTM( null reps )
 602         (push_fn, sz) <- pushAtom d p (AnnVar fn)
 603         ASSERTM( sz == 1 )
 604         returnBc (push_fn `appOL` (
 605                   mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
 606                   unitOL ENTER))
 607   do_pushes d args reps = do
 608       let (push_apply, n, rest_of_reps) = findPushSeq reps
 609           (these_args, rest_of_args) = splitAt n args
 610       (next_d, push_code) <- push_seq d these_args
 611       instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
 612                 --                ^^^ for the PUSH_APPLY_ instruction
 613       returnBc (push_code `appOL` (push_apply `consOL` instrs))
 614
 615   push_seq d [] = return (d, nilOL)
 616   push_seq d (arg:args) = do
 617     (push_code, sz) <- pushAtom d p arg
 618     (final_d, more_push_code) <- push_seq (d+sz) args
 619     return (final_d, push_code `appOL` more_push_code)
 620
 621 -- v. similar to CgStackery.findMatch, ToDo: merge
 622 findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest)
 623   = (PUSH_APPLY_PPPPPPP, 7, rest)
 624 findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest)
 625   = (PUSH_APPLY_PPPPPP, 6, rest)
 626 findPushSeq (RepP: RepP: RepP: RepP: RepP: rest)
 627   = (PUSH_APPLY_PPPPP, 5, rest)
 628 findPushSeq (RepP: RepP: RepP: RepP: rest)
 629   = (PUSH_APPLY_PPPP, 4, rest)
 630 findPushSeq (RepP: RepP: RepP: rest)
 631   = (PUSH_APPLY_PPP, 3, rest)
 632 findPushSeq (RepP: RepP: rest)
 633   = (PUSH_APPLY_PP, 2, rest)
 634 findPushSeq (RepP: rest)
 635   = (PUSH_APPLY_P, 1, rest)
 636 findPushSeq (RepV: rest)
 637   = (PUSH_APPLY_V, 1, rest)
 638 findPushSeq (RepN: rest)
 639   = (PUSH_APPLY_N, 1, rest)
 640 findPushSeq (RepF: rest)
 641   = (PUSH_APPLY_F, 1, rest)
 642 findPushSeq (RepD: rest)
 643   = (PUSH_APPLY_D, 1, rest)
 644 findPushSeq (RepL: rest)
 645   = (PUSH_APPLY_L, 1, rest)
 646 findPushSeq _
 647   = panic "ByteCodeGen.findPushSeq"
 648
 649 -- -----------------------------------------------------------------------------
 650 -- Case expressions
 651
 652 doCase  :: Int -> Sequel -> BCEnv
 653         -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
 654         -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
 655         -> BcM BCInstrList
 656 doCase d s p (_,scrut)
 657  bndr alts is_unboxed_tuple
 658   = let
 659         -- Top of stack is the return itbl, as usual.
 660         -- underneath it is the pointer to the alt_code BCO.
 661         -- When an alt is entered, it assumes the returned value is
 662         -- on top of the itbl.
 663         ret_frame_sizeW = 2
 664
 665         -- An unlifted value gets an extra info table pushed on top
 666         -- when it is returned.
 667         unlifted_itbl_sizeW | isAlgCase = 0
 668                             | otherwise = 1
 669
 670         -- depth of stack after the return value has been pushed
 671         d_bndr = d + ret_frame_sizeW + idSizeW bndr
 672
 673         -- depth of stack after the extra info table for an unboxed return
 674         -- has been pushed, if any.  This is the stack depth at the
 675         -- continuation.
 676         d_alts = d_bndr + unlifted_itbl_sizeW
 677
 678         -- Env in which to compile the alts, not including
 679         -- any vars bound by the alts themselves
 680         p_alts = addToFM p bndr (d_bndr - 1)
 681
 682         bndr_ty = idType bndr
 683         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 684
 685         -- given an alt, return a discr and code for it.
 686         codeALt alt@(DEFAULT, _, (_,rhs))
 687            = schemeE d_alts s p_alts rhs        `thenBc` \ rhs_code ->
 688              returnBc (NoDiscr, rhs_code)
 689         codeAlt alt@(discr, bndrs, (_,rhs))
 690            -- primitive or nullary constructor alt: no need to UNPACK
 691            | null real_bndrs = do
 692                 rhs_code <- schemeE d_alts s p_alts rhs
 693                 returnBc (my_discr alt, rhs_code)
 694            -- algebraic alt with some binders
 695            | ASSERT(isAlgCase) otherwise =
 696              let
 697                  (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs
 698                  ptr_sizes    = map idSizeW ptrs
 699                  nptrs_sizes  = map idSizeW nptrs
 700                  bind_sizes   = ptr_sizes ++ nptrs_sizes
 701                  size         = sum ptr_sizes + sum nptrs_sizes
 702                  -- the UNPACK instruction unpacks in reverse order...
 703                  p' = addListToFM p_alts
 704                         (zip (reverse (ptrs ++ nptrs))
 705                           (mkStackOffsets d_alts (reverse bind_sizes)))
 706              in do
 707              rhs_code <- schemeE (d_alts+size) s p' rhs
 708              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
 709            where
 710              real_bndrs = filter (not.isTyVar) bndrs
 711
 712
 713         my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
 714         my_discr (DataAlt dc, binds, rhs)
 715            | isUnboxedTupleCon dc
 716            = unboxedTupleException
 717            | otherwise
 718            = DiscrP (dataConTag dc - fIRST_TAG)
 719         my_discr (LitAlt l, binds, rhs)
 720            = case l of MachInt i     -> DiscrI (fromInteger i)
 721                        MachFloat r   -> DiscrF (fromRational r)
 722                        MachDouble r  -> DiscrD (fromRational r)
 723                        MachChar i    -> DiscrI i
 724                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 725
 726         maybe_ncons
 727            | not isAlgCase = Nothing
 728            | otherwise
 729            = case [dc | (DataAlt dc, _, _) <- alts] of
 730                 []     -> Nothing
 731                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 732
 733         -- the bitmap is relative to stack depth d, i.e. before the
 734         -- BCO, info table and return value are pushed on.
 735         -- This bit of code is v. similar to buildLivenessMask in CgBindery,
 736         -- except that here we build the bitmap from the known bindings of
 737         -- things that are pointers, whereas in CgBindery the code builds the
 738         -- bitmap from the free slots and unboxed bindings.
 739         -- (ToDo: merge?)
 740         bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
 741           where
 742           binds = fmToList p
 743           rel_slots = concat (map spread binds)
 744           spread (id, offset)
 745                 | isFollowableRep (idPrimRep id) = [ rel_offset ]
 746                 | otherwise = []
 747                 where rel_offset = d - offset - 1
 748
 749      in do
 750      alt_stuff <- mapM codeAlt alts
 751      alt_final <- mkMultiBranch maybe_ncons alt_stuff
 752      let
 753          alt_bco_name = getName bndr
 754          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
 755                         0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
 756      -- in
 757 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 758 --           "\n      bitmap = " ++ show bitmap) $ do
 759      scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
 760      alt_bco' <- emitBc alt_bco
 761      let push_alts
 762             | isAlgCase = PUSH_ALTS alt_bco'
 763             | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty)
 764      returnBc (push_alts `consOL` scrut_code)
 765
 766
 767 -- -----------------------------------------------------------------------------
 768 -- Deal with a CCall.
 769
 770 -- Taggedly push the args onto the stack R->L,
 771 -- deferencing ForeignObj#s and adjusting addrs to point to
 772 -- payloads in Ptr/Byte arrays.  Then, generate the marshalling
 773 -- (machine) code for the ccall, and create bytecodes to call that and
 774 -- then return in the right way.
 775
 776 generateCCall :: Int -> Sequel          -- stack and sequel depths
 777               -> BCEnv
 778               -> CCallSpec              -- where to call
 779               -> Id                     -- of target, for type info
 780               -> [AnnExpr' Id VarSet]   -- args (atoms)
 781               -> BcM BCInstrList
 782
 783 generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 784    = let
 785          -- useful constants
 786          addr_sizeW = getPrimRepSize AddrRep
 787
 788          -- Get the args on the stack, with tags and suitably
 789          -- dereferenced for the CCall.  For each arg, return the
 790          -- depth to the first word of the bits for that arg, and the
 791          -- PrimRep of what was actually pushed.
 792
 793          pargs d [] = returnBc []
 794          pargs d (a:az)
 795             = let arg_ty = repType (exprType (deAnnotate' a))
 796
 797               in case splitTyConApp_maybe arg_ty of
 798                     -- Don't push the FO; instead push the Addr# it
 799                     -- contains.
 800                     Just (t, _)
 801                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
 802                        -> pargs (d + addr_sizeW) az     `thenBc` \ rest ->
 803                           parg_ArrayishRep arrPtrsHdrSize d p a
 804                                                         `thenBc` \ code ->
 805                           returnBc ((code,AddrRep):rest)
 806
 807                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
 808                        -> pargs (d + addr_sizeW) az     `thenBc` \ rest ->
 809                           parg_ArrayishRep arrWordsHdrSize d p a
 810                                                         `thenBc` \ code ->
 811                           returnBc ((code,AddrRep):rest)
 812
 813                     -- Default case: push taggedly, but otherwise intact.
 814                     other
 815                        -> pushAtom d p a                `thenBc` \ (code_a, sz_a) ->
 816                           pargs (d+sz_a) az             `thenBc` \ rest ->
 817                           returnBc ((code_a, atomRep a) : rest)
 818
 819          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
 820          -- the stack but then advance it over the headers, so as to
 821          -- point to the payload.
 822          parg_ArrayishRep hdrSizeW d p a
 823             = pushAtom d p a `thenBc` \ (push_fo, _) ->
 824               -- The ptr points at the header.  Advance it over the
 825               -- header and then pretend this is an Addr#.
 826               returnBc (push_fo `snocOL`
 827                         SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep
 828                                             * wORD_SIZE))
 829
 830      in
 831          pargs d0 args_r_to_l                   `thenBc` \ code_n_reps ->
 832      let
 833          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
 834
 835          push_args    = concatOL pushs_arg
 836          d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l)
 837          a_reps_pushed_RAW
 838             | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
 839             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
 840             | otherwise
 841             = reverse (tail a_reps_pushed_r_to_l)
 842
 843          -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
 844          -- push_args is the code to do that.
 845          -- d_after_args is the stack depth once the args are on.
 846
 847          -- Get the result rep.
 848          (returns_void, r_rep)
 849             = case maybe_getCCallReturnRep (idType fn) of
 850                  Nothing -> (True,  VoidRep)
 851                  Just rr -> (False, rr)
 852          {-
 853          Because the Haskell stack grows down, the a_reps refer to
 854          lowest to highest addresses in that order.  The args for the call
 855          are on the stack.  Now push an unboxed Addr# indicating
 856          the C function to call.  Then push a dummy placeholder for the
 857          result.  Finally, emit a CCALL insn with an offset pointing to the
 858          Addr# just pushed, and a literal field holding the mallocville
 859          address of the piece of marshalling code we generate.
 860          So, just prior to the CCALL insn, the stack looks like this
 861          (growing down, as usual):
 862
 863             <arg_n>
 864             ...
 865             <arg_1>
 866             Addr# address_of_C_fn
 867             <placeholder-for-result#> (must be an unboxed type)
 868
 869          The interpreter then calls the marshall code mentioned
 870          in the CCALL insn, passing it (& <placeholder-for-result#>),
 871          that is, the addr of the topmost word in the stack.
 872          When this returns, the placeholder will have been
 873          filled in.  The placeholder is slid down to the sequel
 874          depth, and we RETURN.
 875
 876          This arrangement makes it simple to do f-i-dynamic since the Addr#
 877          value is the first arg anyway.
 878
 879          The marshalling code is generated specifically for this
 880          call site, and so knows exactly the (Haskell) stack
 881          offsets of the args, fn address and placeholder.  It
 882          copies the args to the C stack, calls the stacked addr,
 883          and parks the result back in the placeholder.  The interpreter
 884          calls it as a normal C call, assuming it has a signature
 885             void marshall_code ( StgWord* ptr_to_top_of_stack )
 886          -}
 887          -- resolve static address
 888          get_target_info
 889             = case target of
 890                  DynamicTarget
 891                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
 892                  StaticTarget target
 893                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
 894                        returnBc (True, res)
 895                  CasmTarget _
 896                     -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
 897      in
 898          get_target_info        `thenBc` \ (is_static, static_target_addr) ->
 899      let
 900
 901          -- Get the arg reps, zapping the leading Addr# in the dynamic case
 902          a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
 903                 | is_static = a_reps_pushed_RAW
 904                 | otherwise = if null a_reps_pushed_RAW
 905                               then panic "ByteCodeGen.generateCCall: dyn with no args"
 906                               else tail a_reps_pushed_RAW
 907
 908          -- push the Addr#
 909          (push_Addr, d_after_Addr)
 910             | is_static
 911             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
 912                d_after_args + addr_sizeW)
 913             | otherwise -- is already on the stack
 914             = (nilOL, d_after_args)
 915
 916          -- Push the return placeholder.  For a call returning nothing,
 917          -- this is a VoidRep (tag).
 918          r_sizeW   = getPrimRepSize r_rep
 919          d_after_r = d_after_Addr + r_sizeW
 920          r_lit     = mkDummyLiteral r_rep
 921          push_r    = (if   returns_void
 922                       then nilOL
 923                       else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
 924
 925          -- generate the marshalling code we're going to call
 926          r_offW       = 0
 927          addr_offW    = r_sizeW
 928          arg1_offW    = r_sizeW + addr_sizeW
 929          args_offW    = map (arg1_offW +)
 930                             (init (scanl (+) 0 (map getPrimRepSize a_reps)))
 931      in
 932          ioToBc (mkMarshalCode cconv
 933                     (r_offW, r_rep) addr_offW
 934                     (zip args_offW a_reps))     `thenBc` \ addr_of_marshaller ->
 935          recordMallocBc addr_of_marshaller      `thenBc_`
 936      let
 937          -- Offset of the next stack frame down the stack.  The CCALL
 938          -- instruction needs to describe the chunk of stack containing
 939          -- the ccall args to the GC, so it needs to know how large it
 940          -- is.  See comment in Interpreter.c with the CCALL instruction.
 941          stk_offset   = d_after_r - s
 942
 943          -- do the call
 944          do_call      = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
 945          -- slide and return
 946          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
 947                         `snocOL` RETURN_UBX r_rep
 948      in
 949          --trace (show (arg1_offW, args_offW  ,  (map getPrimRepSize a_reps) )) $
 950          returnBc (
 951          push_args `appOL`
 952          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
 953          )
 954
 955
 956 -- Make a dummy literal, to be used as a placeholder for FFI return
 957 -- values on the stack.
 958 mkDummyLiteral :: PrimRep -> Literal
 959 mkDummyLiteral pr
 960    = case pr of
 961         CharRep   -> MachChar 0
 962         IntRep    -> MachInt 0
 963         WordRep   -> MachWord 0
 964         DoubleRep -> MachDouble 0
 965         FloatRep  -> MachFloat 0
 966         AddrRep   | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0
 967         _         -> moan64 "mkDummyLiteral" (ppr pr)
 968
 969
 970 -- Convert (eg)
 971 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 972 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 973 --
 974 -- to  Just IntRep
 975 -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
 976 --
 977 -- Alternatively, for call-targets returning nothing, convert
 978 --
 979 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 980 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
 981 --
 982 -- to  Nothing
 983
 984 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 985 maybe_getCCallReturnRep fn_ty
 986    = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
 987          maybe_r_rep_to_go
 988             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
 989          (r_tycon, r_reps)
 990             = case splitTyConApp_maybe (repType r_ty) of
 991                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
 992                       Nothing -> blargh
 993          ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
 994                 || r_reps == [VoidRep] )
 995               && isUnboxedTupleTyCon r_tycon
 996               && case maybe_r_rep_to_go of
 997                     Nothing    -> True
 998                     Just r_rep -> r_rep /= PtrRep
 999                                   -- if it was, it would be impossible
1000                                   -- to create a valid return value
1001                                   -- placeholder on the stack
1002          blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1003                            (pprType fn_ty)
1004      in
1005      --trace (showSDoc (ppr (a_reps, r_reps))) $
1006      if ok then maybe_r_rep_to_go else blargh
1007
1008 -- Compile code which expects an unboxed Int on the top of stack,
1009 -- (call it i), and pushes the i'th closure in the supplied list
1010 -- as a consequence.
1011 implement_tagToId :: [Name] -> BcM BCInstrList
1012 implement_tagToId names
1013    = ASSERT( notNull names )
1014      getLabelsBc (length names)                 `thenBc` \ labels ->
1015      getLabelBc                                 `thenBc` \ label_fail ->
1016      getLabelBc                                 `thenBc` \ label_exit ->
1017      zip4 labels (tail labels ++ [label_fail])
1018                  [0 ..] names                   `bind`   \ infos ->
1019      map (mkStep label_exit) infos              `bind`   \ steps ->
1020      returnBc (concatOL steps
1021                `appOL`
1022                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
1023      where
1024         mkStep l_exit (my_label, next_label, n, name_for_n)
1025            = toOL [LABEL my_label,
1026                    TESTEQ_I n next_label,
1027                    PUSH_G name_for_n,
1028                    JMP l_exit]
1029
1030
1031 -- -----------------------------------------------------------------------------
1032 -- pushAtom
1033
1034 -- Push an atom onto the stack, returning suitable code & number of
1035 -- stack words used.
1036 --
1037 -- The env p must map each variable to the highest- numbered stack
1038 -- slot for it.  For example, if the stack has depth 4 and we
1039 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1040 -- the tag in stack[5], the stack will have depth 6, and p must map v
1041 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
1042 -- depth 6 stack has valid words 0 .. 5.
1043
1044 pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
1045
1046 pushAtom d p (AnnApp f (_, AnnType _))
1047    = pushAtom d p (snd f)
1048
1049 pushAtom d p (AnnNote note e)
1050    = pushAtom d p (snd e)
1051
1052 pushAtom d p (AnnLam x e)
1053    | isTyVar x
1054    = pushAtom d p (snd e)
1055
1056 pushAtom d p (AnnVar v)
1057
1058    | idPrimRep v == VoidRep
1059    = returnBc (nilOL, 0)
1060
1061    | isFCallId v
1062    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1063
1064    | Just primop <- isPrimOpId_maybe v
1065    = returnBc (unitOL (PUSH_PRIMOP primop), 1)
1066
1067    | Just d_v <- lookupBCEnv_maybe p v  -- v is a local variable
1068    = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
1069          -- d - d_v                 the number of words between the TOS
1070          --                         and the 1st slot of the object
1071          --
1072          -- d - d_v - 1             the offset from the TOS of the 1st slot
1073          --
1074          -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot
1075          --                         of the object.
1076          --
1077          -- Having found the last slot, we proceed to copy the right number of
1078          -- slots on to the top of the stack.
1079
1080     | otherwise  -- v must be a global variable
1081     = ASSERT(sz == 1)
1082       returnBc (unitOL (PUSH_G (getName v)), sz)
1083
1084     where
1085          sz = idSizeW v
1086
1087
1088 pushAtom d p (AnnLit lit)
1089    = case lit of
1090         MachLabel fs _ -> code CodePtrRep
1091         MachWord w     -> code WordRep
1092         MachInt i      -> code IntRep
1093         MachFloat r    -> code FloatRep
1094         MachDouble r   -> code DoubleRep
1095         MachChar c     -> code CharRep
1096         MachStr s      -> pushStr s
1097      where
1098         code rep
1099            = let size_host_words = getPrimRepSize rep
1100              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1101                            size_host_words)
1102
1103         pushStr s
1104            = let getMallocvilleAddr
1105                     = case s of
1106                          FastString _ l ba ->
1107                             -- sigh, a string in the heap is no good to us.
1108                             -- We need a static C pointer, since the type of
1109                             -- a string literal is Addr#.  So, copy the string
1110                             -- into C land and remember the pointer so we can
1111                             -- free it later.
1112                             let n = I# l
1113                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
1114                             in  ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
1115                                 recordMallocBc ptr         `thenBc_`
1116                                 ioToBc (
1117                                    do memcpy ptr ba (fromIntegral n)
1118                                       pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1119                                       return ptr
1120                                    )
1121                          other -> panic "ByteCodeGen.pushAtom.pushStr"
1122              in
1123                 getMallocvilleAddr `thenBc` \ addr ->
1124                 -- Get the addr on the stack, untaggedly
1125                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1126
1127 pushAtom d p other
1128    = pprPanic "ByteCodeGen.pushAtom"
1129               (pprCoreExpr (deAnnotate (undefined, other)))
1130
1131 foreign import ccall unsafe "memcpy"
1132  memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1133
1134
1135 -- -----------------------------------------------------------------------------
1136 -- Given a bunch of alts code and their discrs, do the donkey work
1137 -- of making a multiway branch using a switch tree.
1138 -- What a load of hassle!
1139
1140 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
1141                                 -- a hint; generates better code
1142                                 -- Nothing is always safe
1143               -> [(Discr, BCInstrList)]
1144               -> BcM BCInstrList
1145 mkMultiBranch maybe_ncons raw_ways
1146    = let d_way     = filter (isNoDiscr.fst) raw_ways
1147          notd_ways = naturalMergeSortLe
1148                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1149                         (filter (not.isNoDiscr.fst) raw_ways)
1150
1151          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1152          mkTree [] range_lo range_hi = returnBc the_default
1153
1154          mkTree [val] range_lo range_hi
1155             | range_lo `eqAlt` range_hi
1156             = returnBc (snd val)
1157             | otherwise
1158             = getLabelBc                                `thenBc` \ label_neq ->
1159               returnBc (mkTestEQ (fst val) label_neq
1160                         `consOL` (snd val
1161                         `appOL`   unitOL (LABEL label_neq)
1162                         `appOL`   the_default))
1163
1164          mkTree vals range_lo range_hi
1165             = let n = length vals `div` 2
1166                   vals_lo = take n vals
1167                   vals_hi = drop n vals
1168                   v_mid = fst (head vals_hi)
1169               in
1170               getLabelBc                                `thenBc` \ label_geq ->
1171               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1172               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1173               returnBc (mkTestLT v_mid label_geq
1174                         `consOL` (code_lo
1175                         `appOL`   unitOL (LABEL label_geq)
1176                         `appOL`   code_hi))
1177
1178          the_default
1179             = case d_way of [] -> unitOL CASEFAIL
1180                             [(_, def)] -> def
1181
1182          -- None of these will be needed if there are no non-default alts
1183          (mkTestLT, mkTestEQ, init_lo, init_hi)
1184             | null notd_ways
1185             = panic "mkMultiBranch: awesome foursome"
1186             | otherwise
1187             = case fst (head notd_ways) of {
1188               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1189                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1190                             DiscrI minBound,
1191                             DiscrI maxBound );
1192               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1193                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1194                             DiscrF minF,
1195                             DiscrF maxF );
1196               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1197                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1198                             DiscrD minD,
1199                             DiscrD maxD );
1200               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1201                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1202                             DiscrP algMinBound,
1203                             DiscrP algMaxBound )
1204               }
1205
1206          (algMinBound, algMaxBound)
1207             = case maybe_ncons of
1208                  Just n  -> (0, n - 1)
1209                  Nothing -> (minBound, maxBound)
1210
1211          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1212          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1213          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1214          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1215          NoDiscr     `eqAlt` NoDiscr     = True
1216          _           `eqAlt` _           = False
1217
1218          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1219          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1220          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1221          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1222          NoDiscr     `leAlt` NoDiscr     = True
1223          _           `leAlt` _           = False
1224
1225          isNoDiscr NoDiscr = True
1226          isNoDiscr _       = False
1227
1228          dec (DiscrI i) = DiscrI (i-1)
1229          dec (DiscrP i) = DiscrP (i-1)
1230          dec other      = other         -- not really right, but if you
1231                 -- do cases on floating values, you'll get what you deserve
1232
1233          -- same snotty comment applies to the following
1234          minF, maxF :: Float
1235          minD, maxD :: Double
1236          minF = -1.0e37
1237          maxF =  1.0e37
1238          minD = -1.0e308
1239          maxD =  1.0e308
1240      in
1241          mkTree notd_ways init_lo init_hi
1242
1243
1244 -- -----------------------------------------------------------------------------
1245 -- Supporting junk for the compilation schemes
1246
1247 -- Describes case alts
1248 data Discr
1249    = DiscrI Int
1250    | DiscrF Float
1251    | DiscrD Double
1252    | DiscrP Int
1253    | NoDiscr
1254
1255 instance Outputable Discr where
1256    ppr (DiscrI i) = int i
1257    ppr (DiscrF f) = text (show f)
1258    ppr (DiscrD d) = text (show d)
1259    ppr (DiscrP i) = int i
1260    ppr NoDiscr    = text "DEF"
1261
1262
1263 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1264 lookupBCEnv_maybe = lookupFM
1265
1266 idSizeW :: Id -> Int
1267 idSizeW id = getPrimRepSize (typePrimRep (idType id))
1268
1269 unboxedTupleException :: a
1270 unboxedTupleException
1271    = throwDyn
1272         (Panic
1273            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1274             "\tto foreign import/export decls in source.  Workaround:\n" ++
1275             "\tcompile this module to a .o file, then restart session."))
1276
1277
1278 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1279 bind x f    = f x
1280
1281 splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
1282         -- The arguments are returned in *right-to-left* order
1283 splitApp (AnnApp (_,f) (_,a))
1284                | isTypeAtom a = splitApp f
1285                | otherwise    = case splitApp f of
1286                                      (f', as) -> (f', a:as)
1287 splitApp (AnnNote n (_,e))    = splitApp e
1288 splitApp e                    = (e, [])
1289
1290
1291 isTypeAtom :: AnnExpr' id ann -> Bool
1292 isTypeAtom (AnnType _) = True
1293 isTypeAtom _           = False
1294
1295 isVoidRepAtom :: AnnExpr' id ann -> Bool
1296 isVoidRepAtom (AnnVar v)        = typePrimRep (idType v) == VoidRep
1297 isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
1298 isVoidRepAtom _                 = False
1299
1300 atomRep :: AnnExpr' Id ann -> PrimRep
1301 atomRep (AnnVar v)    = typePrimRep (idType v)
1302 atomRep (AnnLit l)    = literalPrimRep l
1303 atomRep (AnnNote n b) = atomRep (snd b)
1304 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
1305 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
1306 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
1307
1308 isPtrAtom :: AnnExpr' Id ann -> Bool
1309 isPtrAtom e = isFollowableRep (atomRep e)
1310
1311 -- Let szsw be the sizes in words of some items pushed onto the stack,
1312 -- which has initial depth d'.  Return the values which the stack environment
1313 -- should map these items to.
1314 mkStackOffsets :: Int -> [Int] -> [Int]
1315 mkStackOffsets original_depth szsw
1316    = map (subtract 1) (tail (scanl (+) original_depth szsw))
1317
1318 -- -----------------------------------------------------------------------------
1319 -- The bytecode generator's monad
1320
1321 data BcM_State
1322    = BcM_State {
1323         nextlabel :: Int,               -- for generating local labels
1324         malloced  :: [Ptr ()] }         -- ptrs malloced for current BCO
1325                                         -- Should be free()d when it is GCd
1326
1327 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1328
1329 ioToBc :: IO a -> BcM a
1330 ioToBc io = BcM $ \st -> do
1331   x <- io
1332   return (st, x)
1333
1334 runBc :: BcM r -> IO (BcM_State, r)
1335 runBc (BcM m) = m (BcM_State 0 [])
1336
1337 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1338 thenBc (BcM expr) cont = BcM $ \st0 -> do
1339   (st1, q) <- expr st0
1340   let BcM k = cont q
1341   (st2, r) <- k st1
1342   return (st2, r)
1343
1344 thenBc_ :: BcM a -> BcM b -> BcM b
1345 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1346   (st1, q) <- expr st0
1347   (st2, r) <- cont st1
1348   return (st2, r)
1349
1350 returnBc :: a -> BcM a
1351 returnBc result = BcM $ \st -> (return (st, result))
1352
1353 instance Monad BcM where
1354   (>>=) = thenBc
1355   (>>)  = thenBc_
1356   return = returnBc
1357
1358 emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1359 emitBc bco
1360   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
1361
1362 recordMallocBc :: Ptr a -> BcM ()
1363 recordMallocBc a
1364   = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
1365
1366 getLabelBc :: BcM Int
1367 getLabelBc
1368   = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1369
1370 getLabelsBc :: Int -> BcM [Int]
1371 getLabelsBc n
1372   = BcM $ \st -> let ctr = nextlabel st
1373                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1374 \end{code}