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