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