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
 364 {- Convert case .... of (# VoidRep'd-thing, a #) -> ...
 365       as
 366    case .... of a -> ...
 367    Use  a  as the name of the binder too.
 368 -}
 369 schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
 370    | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
 371    = trace "automagic mashing of case alts (# VoidRep, a #)" (
 372      schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
 373      )
 374
 375 schemeE d s p (fvs, AnnCase scrut bndr alts)
 376    = let
 377         -- Top of stack is the return itbl, as usual.
 378         -- underneath it is the pointer to the alt_code BCO.
 379         -- When an alt is entered, it assumes the returned value is
 380         -- on top of the itbl.
 381         ret_frame_sizeW = 2
 382
 383         -- Env and depth in which to compile the alts, not including
 384         -- any vars bound by the alts themselves
 385         d' = d + ret_frame_sizeW + taggedIdSizeW bndr
 386         p' = addToFM p bndr (d' - 1)
 387
 388         scrut_primrep = typePrimRep (idType bndr)
 389         isAlgCase
 390            | scrut_primrep == PtrRep
 391            = True
 392            | scrut_primrep `elem`
 393              [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep,
 394               VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep,
 395               Word8Rep, Word16Rep, Word32Rep, Word64Rep]
 396            = False
 397            | otherwise
 398            =  pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep)
 399
 400         -- given an alt, return a discr and code for it.
 401         codeAlt alt@(discr, binds_f, rhs)
 402            | isAlgCase
 403            = let (unpack_code, d_after_unpack, p_after_unpack)
 404                     = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
 405              in  schemeE d_after_unpack s p_after_unpack rhs
 406                                         `thenBc` \ rhs_code ->
 407                  returnBc (my_discr alt, unpack_code `appOL` rhs_code)
 408            | otherwise
 409            = ASSERT(null binds_f)
 410              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 411              returnBc (my_discr alt, rhs_code)
 412
 413         my_discr (DEFAULT, binds, rhs) = NoDiscr
 414         my_discr (DataAlt dc, binds, rhs)
 415            | isUnboxedTupleCon dc
 416            = unboxedTupleException
 417            | otherwise
 418            = DiscrP (dataConTag dc - fIRST_TAG)
 419         my_discr (LitAlt l, binds, rhs)
 420            = case l of MachInt i     -> DiscrI (fromInteger i)
 421                        MachFloat r   -> DiscrF (fromRational r)
 422                        MachDouble r  -> DiscrD (fromRational r)
 423                        MachChar i    -> DiscrI i
 424                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 425
 426         maybe_ncons
 427            | not isAlgCase = Nothing
 428            | otherwise
 429            = case [dc | (DataAlt dc, _, _) <- alts] of
 430                 []     -> Nothing
 431                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 432
 433      in
 434      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 435      mkMultiBranch maybe_ncons alt_stuff                `thenBc` \ alt_final ->
 436      let
 437          alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
 438          alt_bco_name = getName bndr
 439          alt_bco      = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
 440      in
 441      schemeE (d + ret_frame_sizeW)
 442              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 443
 444      emitBc alt_bco                                     `thenBc_`
 445      returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
 446
 447
 448 schemeE d s p (fvs, AnnNote note body)
 449    = schemeE d s p body
 450
 451 schemeE d s p other
 452    = pprPanic "ByteCodeGen.schemeE: unhandled case"
 453                (pprCoreExpr (deAnnotate other))
 454
 455
 456 -- Compile code to do a tail call.  Specifically, push the fn,
 457 -- slide the on-stack app back down to the sequel depth,
 458 -- and enter.  Four cases:
 459 --
 460 -- 0.  (Nasty hack).
 461 --     An application "PrelGHC.tagToEnum# <type> unboxed-int".
 462 --     The int will be on the stack.  Generate a code sequence
 463 --     to convert it to the relevant constructor, SLIDE and ENTER.
 464 --
 465 -- 1.  A nullary constructor.  Push its closure on the stack
 466 --     and SLIDE and RETURN.
 467 --
 468 -- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
 469 --     it simply as  b  -- since the representations are identical
 470 --     (the VoidRep takes up zero stack space).
 471 --
 472 -- 3.  Application of a non-nullary constructor, by defn saturated.
 473 --     Split the args into ptrs and non-ptrs, and push the nonptrs,
 474 --     then the ptrs, and then do PACK and RETURN.
 475 --
 476 -- 4.  Otherwise, it must be a function call.  Push the args
 477 --     right to left, SLIDE and ENTER.
 478
 479 schemeT :: Int          -- Stack depth
 480         -> Sequel       -- Sequel depth
 481         -> BCEnv        -- stack env
 482         -> AnnExpr Id VarSet
 483         -> BcM BCInstrList
 484
 485 schemeT d s p app
 486 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 487 --   = panic "schemeT ?!?!"
 488
 489 --   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
 490 --   = error "?!?!"
 491
 492    -- Handle case 0
 493    | Just (arg, constr_names) <- maybe_is_tagToEnum_call
 494    = pushAtom True d p arg              `bind` \ (push, arg_words) ->
 495      implement_tagToId constr_names     `thenBc` \ tagToId_sequence ->
 496      returnBc (push `appOL`  tagToId_sequence
 497                     `appOL`  mkSLIDE 1 (d+arg_words-s)
 498                     `snocOL` ENTER)
 499
 500    -- Handle case 1
 501    | is_con_call && null args_r_to_l
 502    = returnBc (
 503         (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
 504         `snocOL` ENTER
 505      )
 506
 507    -- Handle case 2
 508    | let isVoidRepAtom (_, AnnVar v)    = VoidRep == typePrimRep (idType v)
 509          isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
 510      in  is_con_call && isUnboxedTupleCon con
 511          && length args_r_to_l == 2
 512          && isVoidRepAtom (last (args_r_to_l))
 513    = trace ("schemeT: unboxed pair with Void first component") (
 514      schemeT d s p (head args_r_to_l)
 515      )
 516
 517    -- Cases 3 and 4
 518    | otherwise
 519    = if   is_con_call && isUnboxedTupleCon con
 520      then returnBc unboxedTupleException
 521      else code `seq` returnBc code
 522
 523    where
 524       -- Detect and extract relevant info for the tagToEnum kludge.
 525       maybe_is_tagToEnum_call
 526          = let extract_constr_Names ty
 527                   = case splitTyConApp_maybe (repType ty) of
 528                        (Just (tyc, [])) |  isDataTyCon tyc
 529                                         -> map getName (tyConDataCons tyc)
 530                        other            -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 531            in
 532            case app of
 533               (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 534                  -> case isPrimOpId_maybe v of
 535                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 536                        other            -> Nothing
 537               other -> Nothing
 538
 539       -- Extract the args (R->L) and fn
 540       (args_r_to_l_raw, fn) = chomp app
 541       chomp expr
 542          = case snd expr of
 543               AnnVar v    -> ([], v)
 544               AnnApp f a  -> case chomp f of (az, f) -> (a:az, f)
 545               AnnNote n e -> chomp e
 546               other       -> pprPanic "schemeT"
 547                                 (ppr (deAnnotate (panic "schemeT.chomp", other)))
 548
 549       args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
 550       isTypeAtom (AnnType _) = True
 551       isTypeAtom _           = False
 552
 553       -- decide if this is a constructor call, and rearrange
 554       -- args appropriately.
 555       maybe_dcon  = isDataConId_maybe fn
 556       is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
 557       (Just con)  = maybe_dcon
 558
 559       args_final_r_to_l
 560          | not is_con_call
 561          = args_r_to_l
 562          | otherwise
 563          = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
 564            where isPtr = isFollowableRep . atomRep
 565
 566       -- make code to push the args and then do the SLIDE-ENTER thing
 567       code          = do_pushery d (map snd args_final_r_to_l)
 568       tag_when_push = not is_con_call
 569       narg_words    = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
 570       get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW
 571
 572       do_pushery d (arg:args)
 573          = let (push, arg_words) = pushAtom tag_when_push d p arg
 574            in  push `appOL` do_pushery (d+arg_words) args
 575       do_pushery d []
 576
 577          -- CCALL !
 578          | Just (CCall (CCallSpec (StaticTarget target)
 579                                   cconv safety)) <- isFCallId_maybe fn
 580          = let -- Get the arg and result reps.
 581                (a_reps, r_rep) = getCCallPrimReps (idType fn)
 582                tys_str = showSDoc (ppr (a_reps, r_rep))
 583                {-
 584                Because the Haskell stack grows down, the a_reps refer to
 585                lowest to highest addresses in that order.  The args for the call
 586                are on the stack.  Now push an unboxed, tagged Addr# indicating
 587                the C function to call.  Then push a dummy placeholder for the
 588                result.  Finally, emit a CCALL insn with an offset pointing to the
 589                Addr# just pushed, and a literal field holding the mallocville
 590                address of the piece of marshalling code we generate.
 591                So, just prior to the CCALL insn, the stack looks like this
 592                (growing down, as usual):
 593
 594                   <arg_n>
 595                   ...
 596                   <arg_1>
 597                   Addr# address_of_C_fn
 598                   <placeholder-for-result#> (must be an unboxed type)
 599
 600                The interpreter then calls the marshall code mentioned
 601                in the CCALL insn, passing it (& <placeholder-for-result#>),
 602                that is, the addr of the topmost word in the stack.
 603                When this returns, the placeholder will have been
 604                filled in.  The placeholder is slid down to the sequel
 605                depth, and we RETURN.
 606
 607                This arrangement makes it simple to do f-i-dynamic since the Addr#
 608                value is the first arg anyway.  It also has the virtue that the
 609                stack is GC-understandable at all times.
 610
 611                The marshalling code is generated specifically for this
 612                call site, and so knows exactly the (Haskell) stack
 613                offsets of the args, fn address and placeholder.  It
 614                copies the args to the C stack, calls the stacked addr,
 615                and parks the result back in the placeholder.  The interpreter
 616                calls it as a normal C call, assuming it has a signature
 617                   void marshall_code ( StgWord* ptr_to_top_of_stack )
 618                -}
 619
 620                -- resolve static address
 621                target_addr
 622                   = let unpacked = _UNPK_ target
 623                     in  case unsafePerformIO (lookupSymbol unpacked) of
 624                            Just aa -> case aa of Ptr a# -> A# a#
 625                            Nothing -> panic ("interpreted ccall: can't resolve: "
 626                                              ++ unpacked)
 627
 628                -- push the Addr#
 629                addr_usizeW  = untaggedSizeW AddrRep
 630                addr_tsizeW  = taggedSizeW AddrRep
 631                push_Addr    = toOL [PUSH_UBX (Right target_addr) addr_usizeW,
 632                                     PUSH_TAG addr_usizeW]
 633                d_after_Addr = d + addr_tsizeW
 634                -- push the return placeholder
 635                r_lit        = mkDummyLiteral r_rep
 636                r_usizeW     = untaggedSizeW r_rep
 637                r_tsizeW     = 1{-tag-} + r_usizeW
 638                push_r       = toOL [PUSH_UBX (Left r_lit) r_usizeW,
 639                                     PUSH_TAG r_usizeW]
 640                d_after_r    = d_after_Addr + r_tsizeW
 641                -- do the call
 642                do_call      = unitOL (CCALL addr_of_marshaller)
 643                -- slide and return
 644                wrapup       = mkSLIDE r_tsizeW
 645                                       (d_after_r - r_tsizeW - s)
 646                               `snocOL` RETURN r_rep
 647
 648                -- generate the marshalling code we're going to call
 649                r_offW       = 0
 650                addr_offW    = r_tsizeW
 651                arg1_offW    = r_tsizeW + addr_tsizeW
 652                args_offW    = map (arg1_offW +)
 653                                   (init (scanl (+) 0 (map taggedSizeW a_reps)))
 654                addr_of_marshaller
 655                             = mkMarshalCode (r_offW, r_rep) addr_offW
 656                                             (zip args_offW a_reps)
 657            in
 658                --trace (show (arg1_offW, args_offW  ,  (map taggedSizeW a_reps) )) (
 659                target_addr
 660                `seq`
 661                (push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup)
 662                --)
 663
 664          | otherwise
 665          = case maybe_dcon of
 666               Just con -> PACK con narg_words `consOL` (
 667                           mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
 668               Nothing
 669                  -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
 670                     in  push
 671                         `appOL` mkSLIDE (narg_words+arg_words)
 672                                         (d - s - narg_words)
 673                         `snocOL` ENTER
 674
 675 mkSLIDE n d
 676    = if d == 0 then nilOL else unitOL (SLIDE n d)
 677 bind x f
 678    = f x
 679
 680
 681 mkDummyLiteral :: PrimRep -> Literal
 682 mkDummyLiteral pr
 683    = case pr of
 684         IntRep    -> MachInt 0
 685         DoubleRep -> MachDouble 0
 686         FloatRep  -> MachFloat 0
 687         AddrRep   | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
 688         _         -> pprPanic "mkDummyLiteral" (ppr pr)
 689
 690
 691 -- Convert (eg)
 692 --       PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
 693 --                    -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
 694 --
 695 -- to [IntRep] -> IntRep
 696 -- and check that the last arg is VoidRep'd and that an unboxed pair is
 697 -- returned wherein the first arg is VoidRep'd.
 698
 699 getCCallPrimReps :: Type -> ([PrimRep], PrimRep)
 700 getCCallPrimReps fn_ty
 701    = let (a_tys, r_ty) = splitRepFunTys fn_ty
 702          a_reps        = map typePrimRep a_tys
 703          (r_tycon, r_reps)
 704             = case splitTyConApp_maybe (repType r_ty) of
 705                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
 706                       Nothing -> blargh
 707          ok = length a_reps >= 1 && VoidRep == last a_reps
 708                && length r_reps == 2 && VoidRep == head r_reps
 709                && isUnboxedTupleTyCon r_tycon
 710                && PtrRep /= r_rep_to_go -- if it was, it would be impossible
 711                                         -- to create a valid return value
 712                                         -- placeholder on the stack
 713          a_reps_to_go = init a_reps
 714          r_rep_to_go  = r_reps !! 1
 715          blargh       = pprPanic "getCCallPrimReps: can't handle:"
 716                                  (pprType fn_ty)
 717      in
 718      --trace (showSDoc (ppr (a_reps, r_reps))) (
 719      if ok then (a_reps_to_go, r_rep_to_go) else blargh
 720      --)
 721
 722 atomRep (AnnVar v)    = typePrimRep (idType v)
 723 atomRep (AnnLit l)    = literalPrimRep l
 724 atomRep (AnnNote n b) = atomRep (snd b)
 725 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 726 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 727 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 728
 729
 730 -- Compile code which expects an unboxed Int on the top of stack,
 731 -- (call it i), and pushes the i'th closure in the supplied list
 732 -- as a consequence.
 733 implement_tagToId :: [Name] -> BcM BCInstrList
 734 implement_tagToId names
 735    = ASSERT(not (null names))
 736      getLabelsBc (length names)                 `thenBc` \ labels ->
 737      getLabelBc                                 `thenBc` \ label_fail ->
 738      getLabelBc                                 `thenBc` \ label_exit ->
 739      zip4 labels (tail labels ++ [label_fail])
 740                  [0 ..] names                   `bind`   \ infos ->
 741      map (mkStep label_exit) infos              `bind`   \ steps ->
 742      returnBc (concatOL steps
 743                `appOL`
 744                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
 745      where
 746         mkStep l_exit (my_label, next_label, n, name_for_n)
 747            = toOL [LABEL my_label,
 748                    TESTEQ_I n next_label,
 749                    PUSH_G (Left name_for_n),
 750                    JMP l_exit]
 751
 752
 753 -- Make code to unpack the top-of-stack constructor onto the stack,
 754 -- adding tags for the unboxed bits.  Takes the PrimReps of the
 755 -- constructor's arguments.  off_h and off_s are travelling offsets
 756 -- along the constructor and the stack.
 757 --
 758 -- Supposing a constructor in the heap has layout
 759 --
 760 --      Itbl p_1 ... p_i np_1 ... np_j
 761 --
 762 -- then we add to the stack, shown growing down, the following:
 763 --
 764 --    (previous stack)
 765 --         p_i
 766 --         ...
 767 --         p_1
 768 --         np_j
 769 --         tag_for(np_j)
 770 --         ..
 771 --         np_1
 772 --         tag_for(np_1)
 773 --
 774 -- so that in the common case (ptrs only) a single UNPACK instr can
 775 -- copy all the payload of the constr onto the stack with no further ado.
 776
 777 mkUnpackCode :: [Id]    -- constr args
 778              -> Int     -- depth before unpack
 779              -> BCEnv   -- env before unpack
 780              -> (BCInstrList, Int, BCEnv)
 781 mkUnpackCode vars d p
 782    = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
 783      --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
 784      --       ++ "\n") (
 785      (code_p `appOL` code_np, d', p')
 786      --)
 787      where
 788         -- vars with reps
 789         vreps = [(var, typePrimRep (idType var)) | var <- vars]
 790
 791         -- ptrs and nonptrs, forward
 792         vreps_p  = filter (isFollowableRep.snd) vreps
 793         vreps_np = filter (not.isFollowableRep.snd) vreps
 794
 795         -- the order in which we will augment the environment
 796         vreps_env = reverse vreps_p ++ reverse vreps_np
 797
 798         -- new env and depth
 799         vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
 800         p' = addListToFM p (zip (map fst vreps_env)
 801                                 (mkStackOffsets d vreps_env_tszsw))
 802         d' = d + sum vreps_env_tszsw
 803
 804         -- code to unpack the ptrs
 805         ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
 806         code_p | null vreps_p = nilOL
 807                | otherwise    = unitOL (UNPACK ptrs_szw)
 808
 809         -- code to unpack the nonptrs
 810         vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
 811         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
 812         do_nptrs off_h off_s [] = nilOL
 813         do_nptrs off_h off_s (npr:nprs)
 814            | npr `elem` [IntRep, FloatRep, DoubleRep, CharRep, AddrRep]
 815            = approved
 816            | otherwise
 817            = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
 818              where
 819                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
 820                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
 821                 usizeW   = untaggedSizeW npr
 822                 tsizeW   = taggedSizeW npr
 823
 824
 825 -- Push an atom onto the stack, returning suitable code & number of
 826 -- stack words used.  Pushes it either tagged or untagged, since
 827 -- pushAtom is used to set up the stack prior to copying into the
 828 -- heap for both APs (requiring tags) and constructors (which don't).
 829 --
 830 -- NB this means NO GC between pushing atoms for a constructor and
 831 -- copying them into the heap.  It probably also means that
 832 -- tail calls MUST be of the form atom{atom ... atom} since if the
 833 -- expression head was allowed to be arbitrary, there could be GC
 834 -- in between pushing the arg atoms and completing the head.
 835 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
 836 -- isn't a problem; but only if arbitrary graph construction for the
 837 -- head doesn't leave this BCO, since GC might happen at the start of
 838 -- each BCO (we consult doYouWantToGC there).
 839 --
 840 -- Blargh.  JRS 001206
 841 --
 842 -- NB (further) that the env p must map each variable to the highest-
 843 -- numbered stack slot for it.  For example, if the stack has depth 4
 844 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
 845 -- the tag in stack[5], the stack will have depth 6, and p must map v to
 846 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
 847 -- 6 stack has valid words 0 .. 5.
 848
 849 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
 850 pushAtom tagged d p (AnnVar v)
 851
 852    | idPrimRep v == VoidRep
 853    = ASSERT(tagged)
 854      (unitOL (PUSH_TAG 0), 1)
 855
 856    | isFCallId v
 857    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
 858
 859    | Just primop <- isPrimOpId_maybe v
 860    = (unitOL (PUSH_G (Right primop)), 1)
 861
 862    | otherwise
 863    = let  {-
 864           str = "\npushAtom " ++ showSDocDebug (ppr v)
 865                ++ " :: " ++ showSDocDebug (pprType (idType v))
 866                ++ ", depth = " ++ show d
 867                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
 868                showSDocDebug (ppBCEnv p)
 869                ++ " --> words: " ++ show (snd result) ++ "\n" ++
 870                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
 871                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
 872          -}
 873
 874          result
 875             = case lookupBCEnv_maybe p v of
 876                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
 877                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
 878
 879          nm = case isDataConId_maybe v of
 880                  Just c  -> getName c
 881                  Nothing -> getName v
 882
 883          sz_t   = taggedIdSizeW v
 884          sz_u   = untaggedIdSizeW v
 885          nwords = if tagged then sz_t else sz_u
 886      in
 887          result
 888
 889 pushAtom True d p (AnnLit lit)
 890    = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
 891      in  (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
 892
 893 pushAtom False d p (AnnLit lit)
 894    = case lit of
 895         MachWord w   -> code WordRep
 896         MachInt i    -> code IntRep
 897         MachFloat r  -> code FloatRep
 898         MachDouble r -> code DoubleRep
 899         MachChar c   -> code CharRep
 900         MachStr s    -> pushStr s
 901      where
 902         code rep
 903            = let size_host_words = untaggedSizeW rep
 904              in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words)
 905
 906         pushStr s
 907            = let mallocvilleAddr
 908                     = case s of
 909                          CharStr s i -> A# s
 910
 911                          FastString _ l ba ->
 912                             -- sigh, a string in the heap is no good to us.
 913                             -- We need a static C pointer, since the type of
 914                             -- a string literal is Addr#.  So, copy the string
 915                             -- into C land and introduce a memory leak
 916                             -- at the same time.
 917                             let n = I# l
 918                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
 919                             in  unsafePerformIO (
 920                                    do (Ptr a#) <- mallocBytes (n+1)
 921                                       strncpy (Ptr a#) ba (fromIntegral n)
 922                                       writeCharOffAddr (A# a#) n '\0'
 923                                       return (A# a#)
 924                                    )
 925                          _ -> panic "StgInterp.lit2expr: unhandled string constant type"
 926              in
 927                 -- Get the addr on the stack, untaggedly
 928                 (unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1)
 929
 930
 931
 932
 933
 934 pushAtom tagged d p (AnnApp f (_, AnnType _))
 935    = pushAtom tagged d p (snd f)
 936
 937 pushAtom tagged d p (AnnNote note e)
 938    = pushAtom tagged d p (snd e)
 939
 940 pushAtom tagged d p (AnnLam x e)
 941    | isTyVar x
 942    = pushAtom tagged d p (snd e)
 943
 944 pushAtom tagged d p other
 945    = pprPanic "ByteCodeGen.pushAtom"
 946               (pprCoreExpr (deAnnotate (undefined, other)))
 947
 948 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
 949
 950
 951 -- Given a bunch of alts code and their discrs, do the donkey work
 952 -- of making a multiway branch using a switch tree.
 953 -- What a load of hassle!
 954 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
 955                                 -- a hint; generates better code
 956                                 -- Nothing is always safe
 957               -> [(Discr, BCInstrList)]
 958               -> BcM BCInstrList
 959 mkMultiBranch maybe_ncons raw_ways
 960    = let d_way     = filter (isNoDiscr.fst) raw_ways
 961          notd_ways = naturalMergeSortLe
 962                         (\w1 w2 -> leAlt (fst w1) (fst w2))
 963                         (filter (not.isNoDiscr.fst) raw_ways)
 964
 965          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
 966          mkTree [] range_lo range_hi = returnBc the_default
 967
 968          mkTree [val] range_lo range_hi
 969             | range_lo `eqAlt` range_hi
 970             = returnBc (snd val)
 971             | otherwise
 972             = getLabelBc                                `thenBc` \ label_neq ->
 973               returnBc (mkTestEQ (fst val) label_neq
 974                         `consOL` (snd val
 975                         `appOL`   unitOL (LABEL label_neq)
 976                         `appOL`   the_default))
 977
 978          mkTree vals range_lo range_hi
 979             = let n = length vals `div` 2
 980                   vals_lo = take n vals
 981                   vals_hi = drop n vals
 982                   v_mid = fst (head vals_hi)
 983               in
 984               getLabelBc                                `thenBc` \ label_geq ->
 985               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
 986               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
 987               returnBc (mkTestLT v_mid label_geq
 988                         `consOL` (code_lo
 989                         `appOL`   unitOL (LABEL label_geq)
 990                         `appOL`   code_hi))
 991
 992          the_default
 993             = case d_way of [] -> unitOL CASEFAIL
 994                             [(_, def)] -> def
 995
 996          -- None of these will be needed if there are no non-default alts
 997          (mkTestLT, mkTestEQ, init_lo, init_hi)
 998             | null notd_ways
 999             = panic "mkMultiBranch: awesome foursome"
1000             | otherwise
1001             = case fst (head notd_ways) of {
1002               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1003                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1004                             DiscrI minBound,
1005                             DiscrI maxBound );
1006               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1007                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1008                             DiscrF minF,
1009                             DiscrF maxF );
1010               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1011                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1012                             DiscrD minD,
1013                             DiscrD maxD );
1014               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1015                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1016                             DiscrP algMinBound,
1017                             DiscrP algMaxBound )
1018               }
1019
1020          (algMinBound, algMaxBound)
1021             = case maybe_ncons of
1022                  Just n  -> (0, n - 1)
1023                  Nothing -> (minBound, maxBound)
1024
1025          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1026          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1027          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1028          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1029          NoDiscr     `eqAlt` NoDiscr     = True
1030          _           `eqAlt` _           = False
1031
1032          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1033          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1034          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1035          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1036          NoDiscr     `leAlt` NoDiscr     = True
1037          _           `leAlt` _           = False
1038
1039          isNoDiscr NoDiscr = True
1040          isNoDiscr _       = False
1041
1042          dec (DiscrI i) = DiscrI (i-1)
1043          dec (DiscrP i) = DiscrP (i-1)
1044          dec other      = other         -- not really right, but if you
1045                 -- do cases on floating values, you'll get what you deserve
1046
1047          -- same snotty comment applies to the following
1048          minF, maxF :: Float
1049          minD, maxD :: Double
1050          minF = -1.0e37
1051          maxF =  1.0e37
1052          minD = -1.0e308
1053          maxD =  1.0e308
1054      in
1055          mkTree notd_ways init_lo init_hi
1056
1057 \end{code}
1058
1059 %************************************************************************
1060 %*                                                                      *
1061 \subsection{Supporting junk for the compilation schemes}
1062 %*                                                                      *
1063 %************************************************************************
1064
1065 \begin{code}
1066
1067 -- Describes case alts
1068 data Discr
1069    = DiscrI Int
1070    | DiscrF Float
1071    | DiscrD Double
1072    | DiscrP Int
1073    | NoDiscr
1074
1075 instance Outputable Discr where
1076    ppr (DiscrI i) = int i
1077    ppr (DiscrF f) = text (show f)
1078    ppr (DiscrD d) = text (show d)
1079    ppr (DiscrP i) = int i
1080    ppr NoDiscr    = text "DEF"
1081
1082
1083 -- Find things in the BCEnv (the what's-on-the-stack-env)
1084 -- See comment preceding pushAtom for precise meaning of env contents
1085 --lookupBCEnv :: BCEnv -> Id -> Int
1086 --lookupBCEnv env nm
1087 --   = case lookupFM env nm of
1088 --        Nothing -> pprPanic "lookupBCEnv"
1089 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
1090 --        Just xx -> xx
1091
1092 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1093 lookupBCEnv_maybe = lookupFM
1094
1095
1096 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
1097 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
1098 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
1099
1100 unboxedTupleException :: a
1101 unboxedTupleException
1102    = throwDyn
1103         (Panic
1104            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1105             "\tto foreign import/export decls in source.  Workaround:\n" ++
1106             "\tcompile this module to a .o file, then restart session."))
1107
1108 \end{code}
1109
1110 %************************************************************************
1111 %*                                                                      *
1112 \subsection{The bytecode generator's monad}
1113 %*                                                                      *
1114 %************************************************************************
1115
1116 \begin{code}
1117 data BcM_State
1118    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
1119                  nextlabel :: Int }             -- for generating local labels
1120
1121 type BcM result = BcM_State -> (result, BcM_State)
1122
1123 runBc :: BcM_State -> BcM () -> BcM_State
1124 runBc init_st m = case m init_st of { (r,st) -> st }
1125
1126 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1127 thenBc expr cont st
1128   = case expr st of { (result, st') -> cont result st' }
1129
1130 thenBc_ :: BcM a -> BcM b -> BcM b
1131 thenBc_ expr cont st
1132   = case expr st of { (result, st') -> cont st' }
1133
1134 returnBc :: a -> BcM a
1135 returnBc result st = (result, st)
1136
1137 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
1138 mapBc f []     = returnBc []
1139 mapBc f (x:xs)
1140   = f x          `thenBc` \ r  ->
1141     mapBc f xs   `thenBc` \ rs ->
1142     returnBc (r:rs)
1143
1144 emitBc :: ProtoBCO Name -> BcM ()
1145 emitBc bco st
1146    = ((), st{bcos = bco : bcos st})
1147
1148 getLabelBc :: BcM Int
1149 getLabelBc st
1150    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
1151
1152 getLabelsBc :: Int -> BcM [Int]
1153 getLabelsBc n st
1154    = let ctr = nextlabel st
1155      in  ([ctr .. ctr+n-1], st{nextlabel = ctr+n})
1156
1157 \end{code}