ghc/compiler/ghci/ByteCodeGen.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[ByteCodeGen]{Generate bytecode from Core}
   5
   6 \begin{code}
   7 module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
   8                      filterNameMap,
   9                      byteCodeGen, coreExprToBCOs
  10                    ) where
  11
  12 #include "HsVersions.h"
  13
  14 import Outputable
  15 import Name             ( Name, getName )
  16 import Id               ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
  17                           idPrimRep, mkSysLocal, idName, isFCallId_maybe )
  18 import ForeignCall      ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
  19 import OrdList          ( OrdList, consOL, snocOL, appOL, unitOL,
  20                           nilOL, toOL, concatOL, fromOL )
  21 import FiniteMap        ( FiniteMap, addListToFM, listToFM,
  22                           addToFM, lookupFM, fmToList )
  23 import CoreSyn
  24 import PprCore          ( pprCoreExpr )
  25 import Literal          ( Literal(..), literalPrimRep )
  26 import PrimRep          ( PrimRep(..) )
  27 import PrimOp           ( PrimOp(..)  )
  28 import CoreFVs          ( freeVars )
  29 import Type             ( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys )
  30 import DataCon          ( dataConTag, fIRST_TAG, dataConTyCon,
  31                           dataConWrapId, isUnboxedTupleCon )
  32 import TyCon            ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
  33                           isFunTyCon, isUnboxedTupleTyCon )
  34 import Class            ( Class, classTyCon )
  35 import Type             ( Type, repType, splitRepFunTys )
  36 import Util             ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
  37 import Var              ( isTyVar )
  38 import VarSet           ( VarSet, varSetElems )
  39 import PrimRep          ( getPrimRepSize, isFollowableRep )
  40 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  41 import ErrUtils         ( showPass, dumpIfSet_dyn )
  42 import Unique           ( mkPseudoUnique3 )
  43 import FastString       ( FastString(..) )
  44 import Panic            ( GhcException(..) )
  45 import PprType          ( pprType )
  46 import ByteCodeInstr    ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
  47 import ByteCodeItbls    ( ItblEnv, mkITbls )
  48 import ByteCodeLink     ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
  49                           ClosureEnv, HValue, filterNameMap,
  50                           iNTERP_STACK_CHECK_THRESH )
  51 import ByteCodeFFI      ( taggedSizeW, untaggedSizeW, mkMarshalCode )
  52 import Linker           ( lookupSymbol )
  53
  54 import List             ( intersperse, sortBy, zip4 )
  55 import Foreign          ( Ptr(..), mallocBytes )
  56 import Addr             ( Addr(..), nullAddr, addrToInt, writeCharOffAddr )
  57 import CTypes           ( CInt )
  58 import Exception        ( throwDyn )
  59
  60 import PrelBase         ( Int(..) )
  61 import PrelGHC          ( ByteArray# )
  62 import IOExts           ( unsafePerformIO )
  63 import PrelIOBase       ( IO(..) )
  64
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Functions visible from outside this module.}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74
  75 byteCodeGen :: DynFlags
  76             -> [CoreBind]
  77             -> [TyCon] -> [Class]
  78             -> IO ([UnlinkedBCO], ItblEnv)
  79 byteCodeGen dflags binds local_tycons local_classes
  80    = do showPass dflags "ByteCodeGen"
  81         let tycs = local_tycons ++ map classTyCon local_classes
  82         itblenv <- mkITbls tycs
  83
  84         let flatBinds = concatMap getBind binds
  85             getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
  86             getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
  87             final_state = runBc (BcM_State [] 0)
  88                                 (mapBc (schemeR True) flatBinds
  89                                         `thenBc_` returnBc ())
  90             (BcM_State proto_bcos final_ctr) = final_state
  91
  92         dumpIfSet_dyn dflags Opt_D_dump_BCOs
  93            "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
  94
  95         bcos <- mapM assembleBCO proto_bcos
  96
  97         return (bcos, itblenv)
  98
  99
 100 -- Returns: (the root BCO for this expression,
 101 --           a list of auxilary BCOs resulting from compiling closures)
 102 coreExprToBCOs :: DynFlags
 103                -> CoreExpr
 104                -> IO UnlinkedBCOExpr
 105 coreExprToBCOs dflags expr
 106  = do showPass dflags "ByteCodeGen"
 107
 108       -- create a totally bogus name for the top-level BCO; this
 109       -- should be harmless, since it's never used for anything
 110       let invented_id   = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
 111                                      (panic "invented_id's type")
 112       let invented_name = idName invented_id
 113
 114       let (BcM_State all_proto_bcos final_ctr)
 115              = runBc (BcM_State [] 0)
 116                      (schemeR True (invented_id, freeVars expr))
 117       dumpIfSet_dyn dflags Opt_D_dump_BCOs
 118          "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
 119
 120       let root_proto_bco
 121              = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
 122                   [root_bco] -> root_bco
 123           auxiliary_proto_bcos
 124              = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos
 125
 126       auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
 127       root_bco <- assembleBCO root_proto_bco
 128
 129       return (root_bco, auxiliary_bcos)
 130 \end{code}
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{Compilation schema for the bytecode generator.}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 \begin{code}
 139
 140 type BCInstrList = OrdList BCInstr
 141
 142 type Sequel = Int       -- back off to this depth before ENTER
 143
 144 -- Maps Ids to the offset from the stack _base_ so we don't have
 145 -- to mess with it after each push/pop.
 146 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
 147
 148 ppBCEnv :: BCEnv -> SDoc
 149 ppBCEnv p
 150    = text "begin-env"
 151      $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
 152      $$ text "end-env"
 153      where
 154         pp_one (var, offset) = int offset <> colon <+> ppr var
 155         cmp_snd x y = compare (snd x) (snd y)
 156
 157 -- Create a BCO and do a spot of peephole optimisation on the insns
 158 -- at the same time.
 159 mkProtoBCO nm instrs_ordlist origin
 160    = ProtoBCO nm maybe_with_stack_check origin
 161      where
 162         -- Overestimate the stack usage (in words) of this BCO,
 163         -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
 164         -- stack check.  (The interpreter always does a stack check
 165         -- for iNTERP_STACK_CHECK_THRESH words at the start of each
 166         -- BCO anyway, so we only need to add an explicit on in the
 167         -- (hopefully rare) cases when the (overestimated) stack use
 168         -- exceeds iNTERP_STACK_CHECK_THRESH.
 169         maybe_with_stack_check
 170            | stack_overest >= 65535
 171            = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
 172                       (int stack_overest)
 173            | stack_overest >= iNTERP_STACK_CHECK_THRESH
 174            = (STKCHECK stack_overest) : peep_d
 175            | otherwise
 176            = peep_d     -- the supposedly common case
 177
 178         stack_overest = sum (map bciStackUse peep_d)
 179                         + 10 {- just to be really really sure -}
 180
 181
 182         -- Merge local pushes
 183         peep_d = peep (fromOL instrs_ordlist)
 184
 185         peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
 186            = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
 187         peep (PUSH_L off1 : PUSH_L off2 : rest)
 188            = PUSH_LL off1 (off2-1) : peep rest
 189         peep (i:rest)
 190            = i : peep rest
 191         peep []
 192            = []
 193
 194
 195 -- Compile code for the right hand side of a let binding.
 196 -- Park the resulting BCO in the monad.  Also requires the
 197 -- variable to which this value was bound, so as to give the
 198 -- resulting BCO a name.  Bool indicates top-levelness.
 199
 200 schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM ()
 201 schemeR is_top (nm, rhs)
 202 {-
 203    | trace (showSDoc (
 204               (char ' '
 205                $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
 206                $$ pprCoreExpr (deAnnotate rhs)
 207                $$ char ' '
 208               ))) False
 209    = undefined
 210 -}
 211    | otherwise
 212    = schemeR_wrk is_top rhs nm (collect [] rhs)
 213
 214
 215 collect xs (_, AnnNote note e)
 216    = collect xs e
 217 collect xs (_, AnnLam x e)
 218    = collect (if isTyVar x then xs else (x:xs)) e
 219 collect xs not_lambda
 220    = (reverse xs, not_lambda)
 221
 222 schemeR_wrk is_top original_body nm (args, body)
 223    | Just dcon <- maybe_toplevel_null_con_rhs
 224    = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
 225      emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
 226                                      (Right original_body))
 227      --)
 228
 229    | otherwise
 230    = let fvs       = filter (not.isTyVar) (varSetElems (fst original_body))
 231          all_args  = reverse args ++ fvs
 232          szsw_args = map taggedIdSizeW all_args
 233          szw_args  = sum szsw_args
 234          p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
 235          argcheck  = unitOL (ARGCHECK szw_args)
 236      in
 237      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 238      emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code)
 239                                      (Right original_body))
 240
 241      where
 242         maybe_toplevel_null_con_rhs
 243            | is_top && null args
 244            = case snd body of
 245                 AnnVar v_wrk
 246                    -> case isDataConId_maybe v_wrk of
 247                          Nothing -> Nothing
 248                          Just dc_wrk |  nm == dataConWrapId dc_wrk
 249                                      -> Just dc_wrk
 250                                      |  otherwise
 251                                      -> Nothing
 252                 other -> Nothing
 253            | otherwise
 254            = Nothing
 255
 256 -- Let szsw be the sizes in words of some items pushed onto the stack,
 257 -- which has initial depth d'.  Return the values which the stack environment
 258 -- should map these items to.
 259 mkStackOffsets :: Int -> [Int] -> [Int]
 260 mkStackOffsets original_depth szsw
 261    = map (subtract 1) (tail (scanl (+) original_depth szsw))
 262
 263 -- Compile code to apply the given expression to the remaining args
 264 -- on the stack, returning a HNF.
 265 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 266
 267 -- Delegate tail-calls to schemeT.
 268 schemeE d s p e@(fvs, AnnApp f a)
 269    = schemeT d s p (fvs, AnnApp f a)
 270
 271 schemeE d s p e@(fvs, AnnVar v)
 272    | isFollowableRep v_rep
 273    =  -- Ptr-ish thing; push it in the normal way
 274      schemeT d s p (fvs, AnnVar v)
 275
 276    | otherwise
 277    = -- returning an unboxed value.  Heave it on the stack, SLIDE, and RETURN.
 278      let (push, szw) = pushAtom True d p (AnnVar v)
 279      in  returnBc (push                         -- value onto stack
 280                    `appOL`  mkSLIDE szw (d-s)   -- clear to sequel
 281                    `snocOL` RETURN v_rep)       -- go
 282    where
 283       v_rep = typePrimRep (idType v)
 284
 285 schemeE d s p (fvs, AnnLit literal)
 286    = let (push, szw) = pushAtom True d p (AnnLit literal)
 287          l_rep = literalPrimRep literal
 288      in  returnBc (push                         -- value onto stack
 289                    `appOL`  mkSLIDE szw (d-s)   -- clear to sequel
 290                    `snocOL` RETURN l_rep)       -- go
 291
 292 schemeE d s p (fvs, AnnLet binds b)
 293    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 294                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 295          n     = length xs
 296          fvss  = map (filter (not.isTyVar).varSetElems.fst) rhss
 297
 298          -- Sizes of tagged free vars, + 1 for the fn
 299          sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
 300
 301          -- This p', d' defn is safe because all the items being pushed
 302          -- are ptrs, so all have size 1.  d' and p' reflect the stack
 303          -- after the closures have been allocated in the heap (but not
 304          -- filled in), and pointers to them parked on the stack.
 305          p'    = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
 306          d'    = d + n
 307
 308          infos = zipE4 fvss sizes xs [n, n-1 .. 1]
 309          zipE  = zipEqual "schemeE"
 310          zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
 311
 312          -- ToDo: don't build thunks for things with no free variables
 313          buildThunk dd ([], size, id, off)
 314             = PUSH_G (Left (getName id))
 315               `consOL` unitOL (MKAP (off+size-1) size)
 316          buildThunk dd ((fv:fvs), size, id, off)
 317             = case pushAtom True dd p' (AnnVar fv) of
 318                  (push_code, pushed_szw)
 319                     -> push_code `appOL`
 320                        buildThunk (dd+pushed_szw) (fvs, size, id, off)
 321
 322          thunkCode = concatOL (map (buildThunk d') infos)
 323          allocCode = toOL (map ALLOC sizes)
 324      in
 325      schemeE d' s p' b                                  `thenBc`  \ bodyCode ->
 326      mapBc (schemeR False) (zip xs rhss)                `thenBc_`
 327      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 328
 329
 330
 331
 332
 333 schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
 334                                  [(DEFAULT, [], (fvs_rhs, rhs))])
 335
 336    | let isFunType var_type
 337             = case splitTyConApp_maybe var_type of
 338                  Just (tycon,_) | isFunTyCon tycon -> True
 339                  _ -> False
 340          ty_bndr = repType (idType bndr)
 341      in isFunType ty_bndr || isTyVarTy ty_bndr
 342
 343    -- Nasty hack; treat
 344    --     case scrut::suspect of bndr { DEFAULT -> rhs }
 345    --     as
 346    --     let bndr = scrut in rhs
 347    --     when suspect is polymorphic or arrowtyped
 348    -- So the required strictness properties are not observed.
 349    -- At some point, must fix this properly.
 350    = let new_expr
 351             = (fvs_case,
 352                AnnLet
 353                   (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
 354               )
 355
 356      in  trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
 357                 "   Possibly due to strict polymorphic/functional constructor args.\n" ++
 358                 "   Your program may leak space unexpectedly.\n")
 359                 -- ++ showSDoc (char ' ' $$ pprCoreExpr (deAnnotate new_expr) $$ char ' '))
 360          (schemeE d s p new_expr)
 361
 362
 363 schemeE d s p (fvs, AnnCase scrut bndr alts0)
 364    = let
 365         alts = case alts0 of
 366                   [(DataAlt dc, [bind1, bind2], rhs)]
 367                      | isUnboxedTupleCon dc
 368                        && VoidRep == typePrimRep (idType bind1)
 369                      ->  [(DEFAULT, [bind2], rhs)]
 370                   other
 371                      -> alts0
 372
 373         -- Top of stack is the return itbl, as usual.
 374         -- underneath it is the pointer to the alt_code BCO.
 375         -- When an alt is entered, it assumes the returned value is
 376         -- on top of the itbl.
 377         ret_frame_sizeW = 2
 378
 379         -- Env and depth in which to compile the alts, not including
 380         -- any vars bound by the alts themselves
 381         d' = d + ret_frame_sizeW + taggedIdSizeW bndr
 382         p' = addToFM p bndr (d' - 1)
 383
 384         scrut_primrep = typePrimRep (idType bndr)
 385         isAlgCase
 386            = case scrut_primrep of
 387                 CharRep -> False ; AddrRep -> False ; WordRep -> False
 388                 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
 389                 VoidRep -> False ;
 390                 PtrRep -> True
 391                 other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 392
 393         -- given an alt, return a discr and code for it.
 394         codeAlt alt@(discr, binds_f, rhs)
 395            | isAlgCase
 396            = let (unpack_code, d_after_unpack, p_after_unpack)
 397                     = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
 398              in  schemeE d_after_unpack s p_after_unpack rhs
 399                                         `thenBc` \ rhs_code ->
 400                  returnBc (my_discr alt, unpack_code `appOL` rhs_code)
 401            | otherwise
 402            = ASSERT(null binds_f)
 403              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 404              returnBc (my_discr alt, rhs_code)
 405
 406         my_discr (DEFAULT, binds, rhs) = NoDiscr
 407         my_discr (DataAlt dc, binds, rhs)
 408            | isUnboxedTupleCon dc
 409            = unboxedTupleException
 410            | otherwise
 411            = DiscrP (dataConTag dc - fIRST_TAG)
 412         my_discr (LitAlt l, binds, rhs)
 413            = case l of MachInt i     -> DiscrI (fromInteger i)
 414                        MachFloat r   -> DiscrF (fromRational r)
 415                        MachDouble r  -> DiscrD (fromRational r)
 416                        MachChar i    -> DiscrI i
 417                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 418
 419         maybe_ncons
 420            | not isAlgCase = Nothing
 421            | otherwise
 422            = case [dc | (DataAlt dc, _, _) <- alts] of
 423                 []     -> Nothing
 424                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 425
 426      in
 427      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 428      mkMultiBranch maybe_ncons alt_stuff                `thenBc` \ alt_final ->
 429      let
 430          alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
 431          alt_bco_name = getName bndr
 432          alt_bco      = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
 433      in
 434      schemeE (d + ret_frame_sizeW)
 435              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 436
 437      emitBc alt_bco                                     `thenBc_`
 438      returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
 439
 440
 441 schemeE d s p (fvs, AnnNote note body)
 442    = schemeE d s p body
 443
 444 schemeE d s p other
 445    = pprPanic "ByteCodeGen.schemeE: unhandled case"
 446                (pprCoreExpr (deAnnotate other))
 447
 448
 449 -- Compile code to do a tail call.  Specifically, push the fn,
 450 -- slide the on-stack app back down to the sequel depth,
 451 -- and enter.  Four cases:
 452 --
 453 -- 0.  (Nasty hack).
 454 --     An application "PrelGHC.tagToEnum# <type> unboxed-int".
 455 --     The int will be on the stack.  Generate a code sequence
 456 --     to convert it to the relevant constructor, SLIDE and ENTER.
 457 --
 458 -- 1.  A nullary constructor.  Push its closure on the stack
 459 --     and SLIDE and RETURN.
 460 --
 461 -- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
 462 --     it simply as  b  -- since the representations are identical
 463 --     (the VoidRep takes up zero stack space).
 464 --
 465 -- 3.  Application of a non-nullary constructor, by defn saturated.
 466 --     Split the args into ptrs and non-ptrs, and push the nonptrs,
 467 --     then the ptrs, and then do PACK and RETURN.
 468 --
 469 -- 4.  Otherwise, it must be a function call.  Push the args
 470 --     right to left, SLIDE and ENTER.
 471
 472 schemeT :: Int          -- Stack depth
 473         -> Sequel       -- Sequel depth
 474         -> BCEnv        -- stack env
 475         -> AnnExpr Id VarSet
 476         -> BcM BCInstrList
 477
 478 schemeT d s p app
 479 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 480 --   = panic "schemeT ?!?!"
 481
 482 --   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
 483 --   = error "?!?!"
 484
 485    -- Handle case 0
 486    | Just (arg, constr_names) <- maybe_is_tagToEnum_call
 487    = pushAtom True d p arg              `bind` \ (push, arg_words) ->
 488      implement_tagToId constr_names     `thenBc` \ tagToId_sequence ->
 489      returnBc (push `appOL`  tagToId_sequence
 490                     `appOL`  mkSLIDE 1 (d+arg_words-s)
 491                     `snocOL` ENTER)
 492
 493    -- Handle case 1
 494    | is_con_call && null args_r_to_l
 495    = returnBc (
 496         (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
 497         `snocOL` ENTER
 498      )
 499
 500    -- Handle case 2
 501    | let isVoidRepAtom (_, AnnVar v)    = VoidRep == typePrimRep (idType v)
 502          isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
 503      in  is_con_call && isUnboxedTupleCon con
 504          && length args_r_to_l == 2
 505          && isVoidRepAtom (last (args_r_to_l))
 506    = trace ("schemeT: unboxed pair with Void first component") (
 507      schemeT d s p (head args_r_to_l)
 508      )
 509
 510    -- Cases 3 and 4
 511    | otherwise
 512    = if   is_con_call && isUnboxedTupleCon con
 513      then returnBc unboxedTupleException
 514      else code `seq` returnBc code
 515
 516    where
 517       -- Detect and extract relevant info for the tagToEnum kludge.
 518       maybe_is_tagToEnum_call
 519          = let extract_constr_Names ty
 520                   = case splitTyConApp_maybe (repType ty) of
 521                        (Just (tyc, [])) |  isDataTyCon tyc
 522                                         -> map getName (tyConDataCons tyc)
 523                        other            -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 524            in
 525            case app of
 526               (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 527                  -> case isPrimOpId_maybe v of
 528                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 529                        other            -> Nothing
 530               other -> Nothing
 531
 532       -- Extract the args (R->L) and fn
 533       (args_r_to_l_raw, fn) = chomp app
 534       chomp expr
 535          = case snd expr of
 536               AnnVar v    -> ([], v)
 537               AnnApp f a  -> case chomp f of (az, f) -> (a:az, f)
 538               AnnNote n e -> chomp e
 539               other       -> pprPanic "schemeT"
 540                                 (ppr (deAnnotate (panic "schemeT.chomp", other)))
 541
 542       args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
 543       isTypeAtom (AnnType _) = True
 544       isTypeAtom _           = False
 545
 546       -- decide if this is a constructor call, and rearrange
 547       -- args appropriately.
 548       maybe_dcon  = isDataConId_maybe fn
 549       is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
 550       (Just con)  = maybe_dcon
 551
 552       args_final_r_to_l
 553          | not is_con_call
 554          = args_r_to_l
 555          | otherwise
 556          = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
 557            where isPtr = isFollowableRep . atomRep
 558
 559       -- make code to push the args and then do the SLIDE-ENTER thing
 560       code          = do_pushery d (map snd args_final_r_to_l)
 561       tag_when_push = not is_con_call
 562       narg_words    = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
 563       get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW
 564
 565       do_pushery d (arg:args)
 566          = let (push, arg_words) = pushAtom tag_when_push d p arg
 567            in  push `appOL` do_pushery (d+arg_words) args
 568       do_pushery d []
 569
 570          -- CCALL !
 571          | Just (CCall (CCallSpec (StaticTarget target)
 572                                   cconv safety)) <- isFCallId_maybe fn
 573          = let -- Get the arg and result reps.
 574                (a_reps, r_rep) = getCCallPrimReps (idType fn)
 575                tys_str = showSDoc (ppr (a_reps, r_rep))
 576                {-
 577                Because the Haskell stack grows down, the a_reps refer to
 578                lowest to highest addresses in that order.  The args for the call
 579                are on the stack.  Now push an unboxed, tagged Addr# indicating
 580                the C function to call.  Then push a dummy placeholder for the
 581                result.  Finally, emit a CCALL insn with an offset pointing to the
 582                Addr# just pushed, and a literal field holding the mallocville
 583                address of the piece of marshalling code we generate.
 584                So, just prior to the CCALL insn, the stack looks like this
 585                (growing down, as usual):
 586
 587                   <arg_n>
 588                   ...
 589                   <arg_1>
 590                   Addr# address_of_C_fn
 591                   <placeholder-for-result#> (must be an unboxed type)
 592
 593                The interpreter then calls the marshall code mentioned
 594                in the CCALL insn, passing it (& <placeholder-for-result#>),
 595                that is, the addr of the topmost word in the stack.
 596                When this returns, the placeholder will have been
 597                filled in.  The placeholder is slid down to the sequel
 598                depth, and we RETURN.
 599
 600                This arrangement makes it simple to do f-i-dynamic since the Addr#
 601                value is the first arg anyway.  It also has the virtue that the
 602                stack is GC-understandable at all times.
 603
 604                The marshalling code is generated specifically for this
 605                call site, and so knows exactly the (Haskell) stack
 606                offsets of the args, fn address and placeholder.  It
 607                copies the args to the C stack, calls the stacked addr,
 608                and parks the result back in the placeholder.  The interpreter
 609                calls it as a normal C call, assuming it has a signature
 610                   void marshall_code ( StgWord* ptr_to_top_of_stack )
 611                -}
 612
 613                -- resolve static address
 614                target_addr
 615                   = let unpacked = _UNPK_ target
 616                     in  case unsafePerformIO (lookupSymbol unpacked) of
 617                            Just aa -> case aa of Ptr a# -> A# a#
 618                            Nothing -> panic ("interpreted ccall: can't resolve: "
 619                                              ++ unpacked)
 620
 621                -- push the Addr#
 622                addr_usizeW  = untaggedSizeW AddrRep
 623                addr_tsizeW  = taggedSizeW AddrRep
 624                push_Addr    = toOL [PUSH_UBX (Right target_addr) addr_usizeW,
 625                                     PUSH_TAG addr_usizeW]
 626                d_after_Addr = d + addr_tsizeW
 627                -- push the return placeholder
 628                r_lit        = mkDummyLiteral r_rep
 629                r_usizeW     = untaggedSizeW r_rep
 630                r_tsizeW     = 1{-tag-} + r_usizeW
 631                push_r       = toOL [PUSH_UBX (Left r_lit) r_usizeW,
 632                                     PUSH_TAG r_usizeW]
 633                d_after_r    = d_after_Addr + r_tsizeW
 634                -- do the call
 635                do_call      = unitOL (CCALL addr_of_marshaller)
 636                -- slide and return
 637                wrapup       = mkSLIDE r_tsizeW
 638                                       (d_after_r - r_tsizeW - s)
 639                               `snocOL` RETURN r_rep
 640
 641                -- generate the marshalling code we're going to call
 642                r_offW       = 0
 643                addr_offW    = r_tsizeW
 644                arg1_offW    = r_tsizeW + addr_tsizeW
 645                args_offW    = map (arg1_offW +)
 646                                   (init (scanl (+) 0 (map taggedSizeW a_reps)))
 647                addr_of_marshaller
 648                             = mkMarshalCode (r_offW, r_rep) addr_offW
 649                                             (zip args_offW a_reps)
 650            in
 651                trace (show (arg1_offW, args_offW  ,  (map taggedSizeW a_reps) )) (
 652                target_addr
 653                `seq`
 654                (push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup)
 655                )
 656
 657          | otherwise
 658          = case maybe_dcon of
 659               Just con -> PACK con narg_words `consOL` (
 660                           mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
 661               Nothing
 662                  -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
 663                     in  push
 664                         `appOL` mkSLIDE (narg_words+arg_words)
 665                                         (d - s - narg_words)
 666                         `snocOL` ENTER
 667
 668 mkSLIDE n d
 669    = if d == 0 then nilOL else unitOL (SLIDE n d)
 670 bind x f
 671    = f x
 672
 673
 674 mkDummyLiteral :: PrimRep -> Literal
 675 mkDummyLiteral pr
 676    = case pr of
 677         IntRep -> MachInt 0
 678         _      -> pprPanic "mkDummyLiteral" (ppr pr)
 679
 680
 681 -- Convert (eg)
 682 --       PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
 683 --                    -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
 684 --
 685 -- to [IntRep] -> IntRep
 686 -- and check that the last arg is VoidRep'd and that an unboxed pair is
 687 -- returned wherein the first arg is VoidRep'd.
 688
 689 getCCallPrimReps :: Type -> ([PrimRep], PrimRep)
 690 getCCallPrimReps fn_ty
 691    = let (a_tys, r_ty) = splitRepFunTys fn_ty
 692          a_reps        = map typePrimRep a_tys
 693          (r_tycon, r_reps)
 694             = case splitTyConApp_maybe (repType r_ty) of
 695                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
 696                       Nothing -> blargh
 697          ok = length a_reps >= 1 && VoidRep == last a_reps
 698                && length r_reps == 2 && VoidRep == head r_reps
 699                && isUnboxedTupleTyCon r_tycon
 700                && PtrRep /= r_rep_to_go -- if it was, it would be impossible
 701                                         -- to create a valid return value
 702                                         -- placeholder on the stack
 703          a_reps_to_go = init a_reps
 704          r_rep_to_go  = r_reps !! 1
 705          blargh       = pprPanic "getCCallPrimReps: can't handle:"
 706                                  (pprType fn_ty)
 707      in
 708      --trace (showSDoc (ppr (a_reps, r_reps))) (
 709      if ok then (a_reps_to_go, r_rep_to_go) else blargh
 710      --)
 711
 712 atomRep (AnnVar v)    = typePrimRep (idType v)
 713 atomRep (AnnLit l)    = literalPrimRep l
 714 atomRep (AnnNote n b) = atomRep (snd b)
 715 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 716 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 717 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 718
 719
 720 -- Compile code which expects an unboxed Int on the top of stack,
 721 -- (call it i), and pushes the i'th closure in the supplied list
 722 -- as a consequence.
 723 implement_tagToId :: [Name] -> BcM BCInstrList
 724 implement_tagToId names
 725    = ASSERT(not (null names))
 726      getLabelsBc (length names)                 `thenBc` \ labels ->
 727      getLabelBc                                 `thenBc` \ label_fail ->
 728      getLabelBc                                 `thenBc` \ label_exit ->
 729      zip4 labels (tail labels ++ [label_fail])
 730                  [0 ..] names                   `bind`   \ infos ->
 731      map (mkStep label_exit) infos              `bind`   \ steps ->
 732      returnBc (concatOL steps
 733                `appOL`
 734                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
 735      where
 736         mkStep l_exit (my_label, next_label, n, name_for_n)
 737            = toOL [LABEL my_label,
 738                    TESTEQ_I n next_label,
 739                    PUSH_G (Left name_for_n),
 740                    JMP l_exit]
 741
 742
 743 -- Make code to unpack the top-of-stack constructor onto the stack,
 744 -- adding tags for the unboxed bits.  Takes the PrimReps of the
 745 -- constructor's arguments.  off_h and off_s are travelling offsets
 746 -- along the constructor and the stack.
 747 --
 748 -- Supposing a constructor in the heap has layout
 749 --
 750 --      Itbl p_1 ... p_i np_1 ... np_j
 751 --
 752 -- then we add to the stack, shown growing down, the following:
 753 --
 754 --    (previous stack)
 755 --         p_i
 756 --         ...
 757 --         p_1
 758 --         np_j
 759 --         tag_for(np_j)
 760 --         ..
 761 --         np_1
 762 --         tag_for(np_1)
 763 --
 764 -- so that in the common case (ptrs only) a single UNPACK instr can
 765 -- copy all the payload of the constr onto the stack with no further ado.
 766
 767 mkUnpackCode :: [Id]    -- constr args
 768              -> Int     -- depth before unpack
 769              -> BCEnv   -- env before unpack
 770              -> (BCInstrList, Int, BCEnv)
 771 mkUnpackCode vars d p
 772    = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
 773      --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
 774      --       ++ "\n") (
 775      (code_p `appOL` code_np, d', p')
 776      --)
 777      where
 778         -- vars with reps
 779         vreps = [(var, typePrimRep (idType var)) | var <- vars]
 780
 781         -- ptrs and nonptrs, forward
 782         vreps_p  = filter (isFollowableRep.snd) vreps
 783         vreps_np = filter (not.isFollowableRep.snd) vreps
 784
 785         -- the order in which we will augment the environment
 786         vreps_env = reverse vreps_p ++ reverse vreps_np
 787
 788         -- new env and depth
 789         vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
 790         p' = addListToFM p (zip (map fst vreps_env)
 791                                 (mkStackOffsets d vreps_env_tszsw))
 792         d' = d + sum vreps_env_tszsw
 793
 794         -- code to unpack the ptrs
 795         ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
 796         code_p | null vreps_p = nilOL
 797                | otherwise    = unitOL (UNPACK ptrs_szw)
 798
 799         -- code to unpack the nonptrs
 800         vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
 801         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
 802         do_nptrs off_h off_s [] = nilOL
 803         do_nptrs off_h off_s (npr:nprs)
 804            = case npr of
 805                 IntRep -> approved ; FloatRep -> approved
 806                 DoubleRep -> approved ; AddrRep -> approved
 807                 CharRep -> approved
 808                 _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
 809              where
 810                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
 811                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
 812                 usizeW   = untaggedSizeW npr
 813                 tsizeW   = taggedSizeW npr
 814
 815
 816 -- Push an atom onto the stack, returning suitable code & number of
 817 -- stack words used.  Pushes it either tagged or untagged, since
 818 -- pushAtom is used to set up the stack prior to copying into the
 819 -- heap for both APs (requiring tags) and constructors (which don't).
 820 --
 821 -- NB this means NO GC between pushing atoms for a constructor and
 822 -- copying them into the heap.  It probably also means that
 823 -- tail calls MUST be of the form atom{atom ... atom} since if the
 824 -- expression head was allowed to be arbitrary, there could be GC
 825 -- in between pushing the arg atoms and completing the head.
 826 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
 827 -- isn't a problem; but only if arbitrary graph construction for the
 828 -- head doesn't leave this BCO, since GC might happen at the start of
 829 -- each BCO (we consult doYouWantToGC there).
 830 --
 831 -- Blargh.  JRS 001206
 832 --
 833 -- NB (further) that the env p must map each variable to the highest-
 834 -- numbered stack slot for it.  For example, if the stack has depth 4
 835 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
 836 -- the tag in stack[5], the stack will have depth 6, and p must map v to
 837 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
 838 -- 6 stack has valid words 0 .. 5.
 839
 840 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
 841 pushAtom tagged d p (AnnVar v)
 842
 843    | idPrimRep v == VoidRep
 844    = ASSERT(tagged)
 845      (unitOL (PUSH_TAG 0), 1)
 846
 847    | isFCallId v
 848    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
 849
 850    | Just primop <- isPrimOpId_maybe v
 851    = (unitOL (PUSH_G (Right primop)), 1)
 852
 853    | otherwise
 854    = let  {-
 855           str = "\npushAtom " ++ showSDocDebug (ppr v)
 856                ++ " :: " ++ showSDocDebug (pprType (idType v))
 857                ++ ", depth = " ++ show d
 858                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
 859                showSDocDebug (ppBCEnv p)
 860                ++ " --> words: " ++ show (snd result) ++ "\n" ++
 861                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
 862                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
 863          -}
 864
 865          result
 866             = case lookupBCEnv_maybe p v of
 867                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
 868                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
 869
 870          nm = case isDataConId_maybe v of
 871                  Just c  -> getName c
 872                  Nothing -> getName v
 873
 874          sz_t   = taggedIdSizeW v
 875          sz_u   = untaggedIdSizeW v
 876          nwords = if tagged then sz_t else sz_u
 877      in
 878          result
 879
 880 pushAtom True d p (AnnLit lit)
 881    = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
 882      in  (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
 883
 884 pushAtom False d p (AnnLit lit)
 885    = case lit of
 886         MachWord w   -> code WordRep
 887         MachInt i    -> code IntRep
 888         MachFloat r  -> code FloatRep
 889         MachDouble r -> code DoubleRep
 890         MachChar c   -> code CharRep
 891         MachStr s    -> pushStr s
 892      where
 893         code rep
 894            = let size_host_words = untaggedSizeW rep
 895              in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words)
 896
 897         pushStr s
 898            = let mallocvilleAddr
 899                     = case s of
 900                          CharStr s i -> A# s
 901
 902                          FastString _ l ba ->
 903                             -- sigh, a string in the heap is no good to us.
 904                             -- We need a static C pointer, since the type of
 905                             -- a string literal is Addr#.  So, copy the string
 906                             -- into C land and introduce a memory leak
 907                             -- at the same time.
 908                             let n = I# l
 909                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
 910                             in  unsafePerformIO (
 911                                    do (Ptr a#) <- mallocBytes (n+1)
 912                                       strncpy (Ptr a#) ba (fromIntegral n)
 913                                       writeCharOffAddr (A# a#) n '\0'
 914                                       return (A# a#)
 915                                    )
 916                          _ -> panic "StgInterp.lit2expr: unhandled string constant type"
 917              in
 918                 -- Get the addr on the stack, untaggedly
 919                 (unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1)
 920
 921
 922
 923
 924
 925 pushAtom tagged d p (AnnApp f (_, AnnType _))
 926    = pushAtom tagged d p (snd f)
 927
 928 pushAtom tagged d p (AnnNote note e)
 929    = pushAtom tagged d p (snd e)
 930
 931 pushAtom tagged d p (AnnLam x e)
 932    | isTyVar x
 933    = pushAtom tagged d p (snd e)
 934
 935 pushAtom tagged d p other
 936    = pprPanic "ByteCodeGen.pushAtom"
 937               (pprCoreExpr (deAnnotate (undefined, other)))
 938
 939 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
 940
 941
 942 -- Given a bunch of alts code and their discrs, do the donkey work
 943 -- of making a multiway branch using a switch tree.
 944 -- What a load of hassle!
 945 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
 946                                 -- a hint; generates better code
 947                                 -- Nothing is always safe
 948               -> [(Discr, BCInstrList)]
 949               -> BcM BCInstrList
 950 mkMultiBranch maybe_ncons raw_ways
 951    = let d_way     = filter (isNoDiscr.fst) raw_ways
 952          notd_ways = naturalMergeSortLe
 953                         (\w1 w2 -> leAlt (fst w1) (fst w2))
 954                         (filter (not.isNoDiscr.fst) raw_ways)
 955
 956          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
 957          mkTree [] range_lo range_hi = returnBc the_default
 958
 959          mkTree [val] range_lo range_hi
 960             | range_lo `eqAlt` range_hi
 961             = returnBc (snd val)
 962             | otherwise
 963             = getLabelBc                                `thenBc` \ label_neq ->
 964               returnBc (mkTestEQ (fst val) label_neq
 965                         `consOL` (snd val
 966                         `appOL`   unitOL (LABEL label_neq)
 967                         `appOL`   the_default))
 968
 969          mkTree vals range_lo range_hi
 970             = let n = length vals `div` 2
 971                   vals_lo = take n vals
 972                   vals_hi = drop n vals
 973                   v_mid = fst (head vals_hi)
 974               in
 975               getLabelBc                                `thenBc` \ label_geq ->
 976               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
 977               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
 978               returnBc (mkTestLT v_mid label_geq
 979                         `consOL` (code_lo
 980                         `appOL`   unitOL (LABEL label_geq)
 981                         `appOL`   code_hi))
 982
 983          the_default
 984             = case d_way of [] -> unitOL CASEFAIL
 985                             [(_, def)] -> def
 986
 987          -- None of these will be needed if there are no non-default alts
 988          (mkTestLT, mkTestEQ, init_lo, init_hi)
 989             | null notd_ways
 990             = panic "mkMultiBranch: awesome foursome"
 991             | otherwise
 992             = case fst (head notd_ways) of {
 993               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
 994                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
 995                             DiscrI minBound,
 996                             DiscrI maxBound );
 997               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
 998                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
 999                             DiscrF minF,
1000                             DiscrF maxF );
1001               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1002                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1003                             DiscrD minD,
1004                             DiscrD maxD );
1005               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1006                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1007                             DiscrP algMinBound,
1008                             DiscrP algMaxBound )
1009               }
1010
1011          (algMinBound, algMaxBound)
1012             = case maybe_ncons of
1013                  Just n  -> (0, n - 1)
1014                  Nothing -> (minBound, maxBound)
1015
1016          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1017          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1018          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1019          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1020          NoDiscr     `eqAlt` NoDiscr     = True
1021          _           `eqAlt` _           = False
1022
1023          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1024          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1025          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1026          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1027          NoDiscr     `leAlt` NoDiscr     = True
1028          _           `leAlt` _           = False
1029
1030          isNoDiscr NoDiscr = True
1031          isNoDiscr _       = False
1032
1033          dec (DiscrI i) = DiscrI (i-1)
1034          dec (DiscrP i) = DiscrP (i-1)
1035          dec other      = other         -- not really right, but if you
1036                 -- do cases on floating values, you'll get what you deserve
1037
1038          -- same snotty comment applies to the following
1039          minF, maxF :: Float
1040          minD, maxD :: Double
1041          minF = -1.0e37
1042          maxF =  1.0e37
1043          minD = -1.0e308
1044          maxD =  1.0e308
1045      in
1046          mkTree notd_ways init_lo init_hi
1047
1048 \end{code}
1049
1050 %************************************************************************
1051 %*                                                                      *
1052 \subsection{Supporting junk for the compilation schemes}
1053 %*                                                                      *
1054 %************************************************************************
1055
1056 \begin{code}
1057
1058 -- Describes case alts
1059 data Discr
1060    = DiscrI Int
1061    | DiscrF Float
1062    | DiscrD Double
1063    | DiscrP Int
1064    | NoDiscr
1065
1066 instance Outputable Discr where
1067    ppr (DiscrI i) = int i
1068    ppr (DiscrF f) = text (show f)
1069    ppr (DiscrD d) = text (show d)
1070    ppr (DiscrP i) = int i
1071    ppr NoDiscr    = text "DEF"
1072
1073
1074 -- Find things in the BCEnv (the what's-on-the-stack-env)
1075 -- See comment preceding pushAtom for precise meaning of env contents
1076 --lookupBCEnv :: BCEnv -> Id -> Int
1077 --lookupBCEnv env nm
1078 --   = case lookupFM env nm of
1079 --        Nothing -> pprPanic "lookupBCEnv"
1080 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
1081 --        Just xx -> xx
1082
1083 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1084 lookupBCEnv_maybe = lookupFM
1085
1086
1087 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
1088 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
1089 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
1090
1091 unboxedTupleException :: a
1092 unboxedTupleException
1093    = throwDyn
1094         (Panic
1095            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1096             "\tto foreign import/export decls in source.  Workaround:\n" ++
1097             "\tcompile this module to a .o file, then restart session."))
1098
1099 \end{code}
1100
1101 %************************************************************************
1102 %*                                                                      *
1103 \subsection{The bytecode generator's monad}
1104 %*                                                                      *
1105 %************************************************************************
1106
1107 \begin{code}
1108 data BcM_State
1109    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
1110                  nextlabel :: Int }             -- for generating local labels
1111
1112 type BcM result = BcM_State -> (result, BcM_State)
1113
1114 runBc :: BcM_State -> BcM () -> BcM_State
1115 runBc init_st m = case m init_st of { (r,st) -> st }
1116
1117 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1118 thenBc expr cont st
1119   = case expr st of { (result, st') -> cont result st' }
1120
1121 thenBc_ :: BcM a -> BcM b -> BcM b
1122 thenBc_ expr cont st
1123   = case expr st of { (result, st') -> cont st' }
1124
1125 returnBc :: a -> BcM a
1126 returnBc result st = (result, st)
1127
1128 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
1129 mapBc f []     = returnBc []
1130 mapBc f (x:xs)
1131   = f x          `thenBc` \ r  ->
1132     mapBc f xs   `thenBc` \ rs ->
1133     returnBc (r:rs)
1134
1135 emitBc :: ProtoBCO Name -> BcM ()
1136 emitBc bco st
1137    = ((), st{bcos = bco : bcos st})
1138
1139 getLabelBc :: BcM Int
1140 getLabelBc st
1141    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
1142
1143 getLabelsBc :: Int -> BcM [Int]
1144 getLabelsBc n st
1145    = let ctr = nextlabel st
1146      in  ([ctr .. ctr+n-1], st{nextlabel = ctr+n})
1147
1148 \end{code}