compiler/ghci/ByteCodeGen.lhs

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