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