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