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 )
  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          ( 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(..), writeCharOffAddr )
  57 import CTypes           ( CInt )
  58 import Exception        ( throwDyn )
  59
  60 import PrelBase         ( Int(..) )
  61 import PrelGHC          ( ByteArray# )
  62 import PrelIOBase       ( IO(..) )
  63
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection{Functions visible from outside this module.}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73
  74 byteCodeGen :: DynFlags
  75             -> [CoreBind]
  76             -> [TyCon] -> [Class]
  77             -> IO ([UnlinkedBCO], ItblEnv)
  78 byteCodeGen dflags binds local_tycons local_classes
  79    = do showPass dflags "ByteCodeGen"
  80         let tycs = local_tycons ++ map classTyCon local_classes
  81         itblenv <- mkITbls tycs
  82
  83         let flatBinds = concatMap getBind binds
  84             getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
  85             getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
  86
  87         (BcM_State proto_bcos final_ctr, ())
  88            <- runBc (BcM_State [] 0)
  89                     (mapBc (schemeR True) flatBinds `thenBc_` returnBc ())
  90
  91         dumpIfSet_dyn dflags Opt_D_dump_BCOs
  92            "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
  93
  94         bcos <- mapM assembleBCO proto_bcos
  95
  96         return (bcos, itblenv)
  97
  98
  99 -- Returns: (the root BCO for this expression,
 100 --           a list of auxilary BCOs resulting from compiling closures)
 101 coreExprToBCOs :: DynFlags
 102                -> CoreExpr
 103                -> IO UnlinkedBCOExpr
 104 coreExprToBCOs dflags expr
 105  = do showPass dflags "ByteCodeGen"
 106
 107       -- create a totally bogus name for the top-level BCO; this
 108       -- should be harmless, since it's never used for anything
 109       let invented_id   = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
 110                                      (panic "invented_id's type")
 111       let invented_name = idName invented_id
 112
 113       (BcM_State all_proto_bcos final_ctr, ())
 114          <- runBc (BcM_State [] 0)
 115                   (schemeR True (invented_id, freeVars expr))
 116
 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      pushAtom True d p (AnnVar v)       `thenBc` \ (push, szw) ->
 279      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    = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) ->
 287      let 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             = returnBc (PUSH_G (Left (getName id))
 315                         `consOL` unitOL (MKAP (off+size-1) size))
 316          buildThunk dd ((fv:fvs), size, id, off)
 317             = pushAtom True dd p' (AnnVar fv)
 318                                         `thenBc` \ (push_code, pushed_szw) ->
 319               buildThunk (dd+pushed_szw) (fvs, size, id, off)
 320                                         `thenBc` \ more_push_code ->
 321               returnBc (push_code `appOL` more_push_code)
 322
 323          genThunkCode = mapBc (buildThunk d') infos     `thenBc` \ tcodes ->
 324                         returnBc (concatOL tcodes)
 325
 326          allocCode = toOL (map ALLOC sizes)
 327      in
 328      schemeE d' s p' b                                  `thenBc`  \ bodyCode ->
 329      mapBc (schemeR False) (zip xs rhss)                `thenBc_`
 330      genThunkCode                                       `thenBc` \ thunkCode ->
 331      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 332
 333
 334
 335
 336
 337 schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
 338                                  [(DEFAULT, [], (fvs_rhs, rhs))])
 339
 340    | let isFunType var_type
 341             = case splitTyConApp_maybe var_type of
 342                  Just (tycon,_) | isFunTyCon tycon -> True
 343                  _ -> False
 344          ty_bndr = repType (idType bndr)
 345      in isFunType ty_bndr || isTyVarTy ty_bndr
 346
 347    -- Nasty hack; treat
 348    --     case scrut::suspect of bndr { DEFAULT -> rhs }
 349    --     as
 350    --     let bndr = scrut in rhs
 351    --     when suspect is polymorphic or arrowtyped
 352    -- So the required strictness properties are not observed.
 353    -- At some point, must fix this properly.
 354    = let new_expr
 355             = (fvs_case,
 356                AnnLet
 357                   (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
 358               )
 359
 360      in  trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
 361                 "   Possibly due to strict polymorphic/functional constructor args.\n" ++
 362                 "   Your program may leak space unexpectedly.\n")
 363          (schemeE d s p new_expr)
 364
 365
 366
 367 {- Convert case .... of (# VoidRep'd-thing, a #) -> ...
 368       as
 369    case .... of a -> ...
 370    Use  a  as the name of the binder too.
 371
 372    Also    case .... of (# a #) -> ...
 373       to
 374    case .... of a -> ...
 375 -}
 376 schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
 377    | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
 378    = --trace "automagic mashing of case alts (# VoidRep, a #)" (
 379      schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
 380      --)
 381
 382 schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
 383    | isUnboxedTupleCon dc
 384    = --trace "automagic mashing of case alts (# a #)" (
 385      schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)])
 386      --)
 387
 388 schemeE d s p (fvs, AnnCase scrut bndr alts)
 389    = let
 390         -- Top of stack is the return itbl, as usual.
 391         -- underneath it is the pointer to the alt_code BCO.
 392         -- When an alt is entered, it assumes the returned value is
 393         -- on top of the itbl.
 394         ret_frame_sizeW = 2
 395
 396         -- Env and depth in which to compile the alts, not including
 397         -- any vars bound by the alts themselves
 398         d' = d + ret_frame_sizeW + taggedIdSizeW bndr
 399         p' = addToFM p bndr (d' - 1)
 400
 401         scrut_primrep = typePrimRep (idType bndr)
 402         isAlgCase
 403            | scrut_primrep == PtrRep
 404            = True
 405            | scrut_primrep `elem`
 406              [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep,
 407               VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep,
 408               Word8Rep, Word16Rep, Word32Rep, Word64Rep]
 409            = False
 410            | otherwise
 411            =  pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep)
 412
 413         -- given an alt, return a discr and code for it.
 414         codeAlt alt@(discr, binds_f, rhs)
 415            | isAlgCase
 416            = let (unpack_code, d_after_unpack, p_after_unpack)
 417                     = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
 418              in  schemeE d_after_unpack s p_after_unpack rhs
 419                                         `thenBc` \ rhs_code ->
 420                  returnBc (my_discr alt, unpack_code `appOL` rhs_code)
 421            | otherwise
 422            = ASSERT(null binds_f)
 423              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 424              returnBc (my_discr alt, rhs_code)
 425
 426         my_discr (DEFAULT, binds, rhs) = NoDiscr
 427         my_discr (DataAlt dc, binds, rhs)
 428            | isUnboxedTupleCon dc
 429            = unboxedTupleException
 430            | otherwise
 431            = DiscrP (dataConTag dc - fIRST_TAG)
 432         my_discr (LitAlt l, binds, rhs)
 433            = case l of MachInt i     -> DiscrI (fromInteger i)
 434                        MachFloat r   -> DiscrF (fromRational r)
 435                        MachDouble r  -> DiscrD (fromRational r)
 436                        MachChar i    -> DiscrI i
 437                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 438
 439         maybe_ncons
 440            | not isAlgCase = Nothing
 441            | otherwise
 442            = case [dc | (DataAlt dc, _, _) <- alts] of
 443                 []     -> Nothing
 444                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 445
 446      in
 447      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 448      mkMultiBranch maybe_ncons alt_stuff                `thenBc` \ alt_final ->
 449      let
 450          alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
 451          alt_bco_name = getName bndr
 452          alt_bco      = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
 453      in
 454      schemeE (d + ret_frame_sizeW)
 455              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 456
 457      emitBc alt_bco                                     `thenBc_`
 458      returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
 459
 460
 461 schemeE d s p (fvs, AnnNote note body)
 462    = schemeE d s p body
 463
 464 schemeE d s p other
 465    = pprPanic "ByteCodeGen.schemeE: unhandled case"
 466                (pprCoreExpr (deAnnotate other))
 467
 468
 469 -- Compile code to do a tail call.  Specifically, push the fn,
 470 -- slide the on-stack app back down to the sequel depth,
 471 -- and enter.  Four cases:
 472 --
 473 -- 0.  (Nasty hack).
 474 --     An application "PrelGHC.tagToEnum# <type> unboxed-int".
 475 --     The int will be on the stack.  Generate a code sequence
 476 --     to convert it to the relevant constructor, SLIDE and ENTER.
 477 --
 478 -- 1.  A nullary constructor.  Push its closure on the stack
 479 --     and SLIDE and RETURN.
 480 --
 481 -- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
 482 --     it simply as  b  -- since the representations are identical
 483 --     (the VoidRep takes up zero stack space).  Also, spot
 484 --     (# b #) and treat it as  b.
 485 --
 486 -- 3.  Application of a non-nullary constructor, by defn saturated.
 487 --     Split the args into ptrs and non-ptrs, and push the nonptrs,
 488 --     then the ptrs, and then do PACK and RETURN.
 489 --
 490 -- 4.  Otherwise, it must be a function call.  Push the args
 491 --     right to left, SLIDE and ENTER.
 492
 493 schemeT :: Int          -- Stack depth
 494         -> Sequel       -- Sequel depth
 495         -> BCEnv        -- stack env
 496         -> AnnExpr Id VarSet
 497         -> BcM BCInstrList
 498
 499 schemeT d s p app
 500
 501 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 502 --   = panic "schemeT ?!?!"
 503
 504 --   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
 505 --   = error "?!?!"
 506
 507    -- Handle case 0
 508    | Just (arg, constr_names) <- maybe_is_tagToEnum_call
 509    = pushAtom True d p arg              `thenBc` \ (push, arg_words) ->
 510      implement_tagToId constr_names     `thenBc` \ tagToId_sequence ->
 511      returnBc (push `appOL`  tagToId_sequence
 512                     `appOL`  mkSLIDE 1 (d+arg_words-s)
 513                     `snocOL` ENTER)
 514
 515    -- Handle case 1
 516    | is_con_call && null args_r_to_l
 517    = returnBc (
 518         (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
 519         `snocOL` ENTER
 520      )
 521
 522    -- Handle case 2
 523    | let isVoidRepAtom (_, AnnVar v)    = VoidRep == typePrimRep (idType v)
 524          isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
 525      in  is_con_call && isUnboxedTupleCon con
 526          && ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l)))
 527               || (length args_r_to_l == 1)
 528             )
 529    = --trace (if length args_r_to_l == 1
 530      --       then "schemeT: unboxed singleton"
 531      --       else "schemeT: unboxed pair with Void first component") (
 532      schemeT d s p (head args_r_to_l)
 533      --)
 534
 535    | Just (CCall ccall_spec) <- isFCallId_maybe fn
 536    = generateCCall d s p ccall_spec fn args_r_to_l
 537
 538    -- Cases 3 and 4
 539    | otherwise
 540    = if   is_con_call && isUnboxedTupleCon con
 541      then unboxedTupleException
 542      else do_pushery d (map snd args_final_r_to_l)
 543
 544    where
 545       -- Detect and extract relevant info for the tagToEnum kludge.
 546       maybe_is_tagToEnum_call
 547          = let extract_constr_Names ty
 548                   = case splitTyConApp_maybe (repType ty) of
 549                        (Just (tyc, [])) |  isDataTyCon tyc
 550                                         -> map getName (tyConDataCons tyc)
 551                        other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 552            in
 553            case app of
 554               (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 555                  -> case isPrimOpId_maybe v of
 556                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 557                        other            -> Nothing
 558               other -> Nothing
 559
 560       -- Extract the args (R->L) and fn
 561       (args_r_to_l_raw, fn) = chomp app
 562       chomp expr
 563          = case snd expr of
 564               AnnVar v    -> ([], v)
 565               AnnApp f a  -> case chomp f of (az, f) -> (a:az, f)
 566               AnnNote n e -> chomp e
 567               other       -> pprPanic "schemeT"
 568                                 (ppr (deAnnotate (panic "schemeT.chomp", other)))
 569
 570       args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
 571       isTypeAtom (AnnType _) = True
 572       isTypeAtom _           = False
 573
 574       -- decide if this is a constructor call, and rearrange
 575       -- args appropriately.
 576       maybe_dcon  = isDataConId_maybe fn
 577       is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
 578       (Just con)  = maybe_dcon
 579
 580       args_final_r_to_l
 581          | not is_con_call
 582          = args_r_to_l
 583          | otherwise
 584          = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
 585            where isPtr = isFollowableRep . atomRep
 586
 587       -- make code to push the args and then do the SLIDE-ENTER thing
 588       tag_when_push = not is_con_call
 589       narg_words    = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
 590       get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW
 591
 592       do_pushery d (arg:args)
 593          = pushAtom tag_when_push d p arg       `thenBc` \ (push, arg_words) ->
 594            do_pushery (d+arg_words) args        `thenBc` \ more_push_code ->
 595            returnBc (push `appOL` more_push_code)
 596       do_pushery d []
 597          | Just (CCall ccall_spec) <- isFCallId_maybe fn
 598          = panic "schemeT.do_pushery: unexpected ccall"
 599          | otherwise
 600          = case maybe_dcon of
 601               Just con -> returnBc (
 602                              (PACK con narg_words `consOL`
 603                               mkSLIDE 1 (d - narg_words - s)) `snocOL`
 604                               ENTER
 605                           )
 606               Nothing
 607                  -> pushAtom True d p (AnnVar fn)
 608                                                 `thenBc` \ (push, arg_words) ->
 609                     returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
 610                                                    (d - s - narg_words)
 611                               `snocOL` ENTER)
 612
 613
 614
 615 {- Deal with a CCall.  Taggedly push the args onto the stack R->L,
 616    deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
 617    payloads in Ptr/Byte arrays).  Then, generate the marshalling
 618    (machine) code for the ccall, and create bytecodes to call that and
 619    then return in the right way.
 620 -}
 621 generateCCall :: Int -> Sequel          -- stack and sequel depths
 622               -> BCEnv
 623               -> CCallSpec              -- where to call
 624               -> Id                     -- of target, for type info
 625               -> [AnnExpr Id VarSet]    -- args (atoms)
 626               -> BcM BCInstrList
 627
 628 generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 629    = let
 630          -- useful constants
 631          addr_usizeW = untaggedSizeW AddrRep
 632          addr_tsizeW = taggedSizeW AddrRep
 633
 634          -- Get the args on the stack, with tags and suitably
 635          -- dereferenced for the CCall.  For each arg, return the
 636          -- depth to the first word of the bits for that arg, and the
 637          -- PrimRep of what was actually pushed.
 638
 639          pargs d [] = returnBc []
 640          pargs d ((_,a):az)
 641             = let rep_arg = atomRep a
 642               in case rep_arg of
 643                     -- Don't push the FO; instead push the Addr# it
 644                     -- contains.
 645                     ForeignObjRep
 646                        -> pushAtom False{-irrelevant-} d p a
 647                                                         `thenBc` \ (push_fo, _) ->
 648                           let foro_szW = taggedSizeW ForeignObjRep
 649                               d_now    = d + addr_tsizeW
 650                               code     = push_fo `appOL` toOL [
 651                                             UPK_TAG addr_usizeW 0 0,
 652                                             SLIDE addr_tsizeW foro_szW
 653                                          ]
 654                           in  pargs d_now az            `thenBc` \ rest ->
 655                               returnBc ((code, AddrRep) : rest)
 656                     -- Default case: push taggedly, but otherwise intact.
 657                     other
 658                        -> pushAtom True d p a           `thenBc` \ (code_a, sz_a) ->
 659                           pargs (d+sz_a) az             `thenBc` \ rest ->
 660                           returnBc ((code_a, rep_arg) : rest)
 661      in
 662          pargs d0 args_r_to_l                           `thenBc` \ code_n_reps ->
 663      let
 664          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
 665
 666          push_args    = concatOL pushs_arg
 667          d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
 668          a_reps_pushed_RAW
 669             | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
 670             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
 671             | otherwise
 672             = reverse (tail a_reps_pushed_r_to_l)
 673
 674          -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
 675          -- push_args is the code to do that.
 676          -- d_after_args is the stack depth once the args are on.
 677
 678          -- Get the result rep.
 679          (returns_void, r_rep)
 680             = case maybe_getCCallReturnRep (idType fn) of
 681                  Nothing -> (True,  VoidRep)
 682                  Just rr -> (False, rr)
 683          {-
 684          Because the Haskell stack grows down, the a_reps refer to
 685          lowest to highest addresses in that order.  The args for the call
 686          are on the stack.  Now push an unboxed, tagged Addr# indicating
 687          the C function to call.  Then push a dummy placeholder for the
 688          result.  Finally, emit a CCALL insn with an offset pointing to the
 689          Addr# just pushed, and a literal field holding the mallocville
 690          address of the piece of marshalling code we generate.
 691          So, just prior to the CCALL insn, the stack looks like this
 692          (growing down, as usual):
 693
 694             <arg_n>
 695             ...
 696             <arg_1>
 697             Addr# address_of_C_fn
 698             <placeholder-for-result#> (must be an unboxed type)
 699
 700          The interpreter then calls the marshall code mentioned
 701          in the CCALL insn, passing it (& <placeholder-for-result#>),
 702          that is, the addr of the topmost word in the stack.
 703          When this returns, the placeholder will have been
 704          filled in.  The placeholder is slid down to the sequel
 705          depth, and we RETURN.
 706
 707          This arrangement makes it simple to do f-i-dynamic since the Addr#
 708          value is the first arg anyway.  It also has the virtue that the
 709          stack is GC-understandable at all times.
 710
 711          The marshalling code is generated specifically for this
 712          call site, and so knows exactly the (Haskell) stack
 713          offsets of the args, fn address and placeholder.  It
 714          copies the args to the C stack, calls the stacked addr,
 715          and parks the result back in the placeholder.  The interpreter
 716          calls it as a normal C call, assuming it has a signature
 717             void marshall_code ( StgWord* ptr_to_top_of_stack )
 718          -}
 719          -- resolve static address
 720          get_target_info
 721             = case target of
 722                  DynamicTarget
 723                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
 724                  StaticTarget target
 725                     -> ioToBc (lookupSymbol (_UNPK_ target)) `thenBc` \res ->
 726                        case res of
 727                            Just aa -> case aa of Ptr a# -> returnBc (True, A# a#)
 728                            Nothing -> returnBc invalid
 729                  CasmTarget _
 730                     -> returnBc invalid
 731                  where
 732                     invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable "
 733                                         ++ "symbol or otherwise invalid target")
 734                                        (ppr ccall_spec)
 735      in
 736          get_target_info        `thenBc` \ (is_static, static_target_addr) ->
 737      let
 738
 739          -- Get the arg reps, zapping the leading Addr# in the dynamic case
 740          a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
 741                 | is_static = a_reps_pushed_RAW
 742                 | otherwise = if null a_reps_pushed_RAW
 743                               then panic "ByteCodeGen.generateCCall: dyn with no args"
 744                               else tail a_reps_pushed_RAW
 745
 746          -- push the Addr#
 747          (push_Addr, d_after_Addr)
 748             | is_static
 749             = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
 750                      PUSH_TAG addr_usizeW],
 751                d_after_args + addr_tsizeW)
 752             | otherwise -- is already on the stack
 753             = (nilOL, d_after_args)
 754
 755          -- Push the return placeholder.  For a call returning nothing,
 756          -- this is a VoidRep (tag).
 757          r_usizeW  = untaggedSizeW r_rep
 758          r_tsizeW  = taggedSizeW r_rep
 759          d_after_r = d_after_Addr + r_tsizeW
 760          r_lit     = mkDummyLiteral r_rep
 761          push_r    = (if   returns_void
 762                       then nilOL
 763                       else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
 764                       `appOL`
 765                       unitOL (PUSH_TAG r_usizeW)
 766
 767          -- generate the marshalling code we're going to call
 768          r_offW       = 0
 769          addr_offW    = r_tsizeW
 770          arg1_offW    = r_tsizeW + addr_tsizeW
 771          args_offW    = map (arg1_offW +)
 772                             (init (scanl (+) 0 (map taggedSizeW a_reps)))
 773      in
 774          ioToBc (mkMarshalCode cconv
 775                     (r_offW, r_rep) addr_offW
 776                     (zip args_offW a_reps))     `thenBc` \ addr_of_marshaller ->
 777      let
 778          -- do the call
 779          do_call      = unitOL (CCALL addr_of_marshaller)
 780          -- slide and return
 781          wrapup       = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
 782                         `snocOL` RETURN r_rep
 783      in
 784          --trace (show (arg1_offW, args_offW  ,  (map taggedSizeW a_reps) )) (
 785          returnBc (
 786          push_args `appOL`
 787          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
 788          )
 789          --)
 790
 791
 792 -- Make a dummy literal, to be used as a placeholder for FFI return
 793 -- values on the stack.
 794 mkDummyLiteral :: PrimRep -> Literal
 795 mkDummyLiteral pr
 796    = case pr of
 797         IntRep    -> MachInt 0
 798         DoubleRep -> MachDouble 0
 799         FloatRep  -> MachFloat 0
 800         AddrRep   | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
 801         _         -> pprPanic "mkDummyLiteral" (ppr pr)
 802
 803
 804 -- Convert (eg)
 805 --     PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
 806 --                   -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
 807 --
 808 -- to  Just IntRep
 809 -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
 810 --
 811 -- Alternatively, for call-targets returning nothing, convert
 812 --
 813 --     PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
 814 --                   -> (# PrelGHC.State# PrelGHC.RealWorld #)
 815 --
 816 -- to  Nothing
 817
 818 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 819 maybe_getCCallReturnRep fn_ty
 820    = let (a_tys, r_ty) = splitRepFunTys fn_ty
 821          maybe_r_rep_to_go
 822             = if length r_reps == 1 then Nothing else Just (r_reps !! 1)
 823          (r_tycon, r_reps)
 824             = case splitTyConApp_maybe (repType r_ty) of
 825                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
 826                       Nothing -> blargh
 827          ok = ( (length r_reps == 2 && VoidRep == head r_reps)
 828                 || r_reps == [VoidRep] )
 829               && isUnboxedTupleTyCon r_tycon
 830               && case maybe_r_rep_to_go of
 831                     Nothing    -> True
 832                     Just r_rep -> r_rep /= PtrRep
 833                                   -- if it was, it would be impossible
 834                                   -- to create a valid return value
 835                                   -- placeholder on the stack
 836          blargh = pprPanic "maybe_getCCallReturn: can't handle:"
 837                            (pprType fn_ty)
 838      in
 839      --trace (showSDoc (ppr (a_reps, r_reps))) (
 840      if ok then maybe_r_rep_to_go else blargh
 841      --)
 842
 843 atomRep (AnnVar v)    = typePrimRep (idType v)
 844 atomRep (AnnLit l)    = literalPrimRep l
 845 atomRep (AnnNote n b) = atomRep (snd b)
 846 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 847 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 848 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 849
 850
 851 -- Compile code which expects an unboxed Int on the top of stack,
 852 -- (call it i), and pushes the i'th closure in the supplied list
 853 -- as a consequence.
 854 implement_tagToId :: [Name] -> BcM BCInstrList
 855 implement_tagToId names
 856    = ASSERT(not (null names))
 857      getLabelsBc (length names)                 `thenBc` \ labels ->
 858      getLabelBc                                 `thenBc` \ label_fail ->
 859      getLabelBc                                 `thenBc` \ label_exit ->
 860      zip4 labels (tail labels ++ [label_fail])
 861                  [0 ..] names                   `bind`   \ infos ->
 862      map (mkStep label_exit) infos              `bind`   \ steps ->
 863      returnBc (concatOL steps
 864                `appOL`
 865                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
 866      where
 867         mkStep l_exit (my_label, next_label, n, name_for_n)
 868            = toOL [LABEL my_label,
 869                    TESTEQ_I n next_label,
 870                    PUSH_G (Left name_for_n),
 871                    JMP l_exit]
 872
 873
 874 -- Make code to unpack the top-of-stack constructor onto the stack,
 875 -- adding tags for the unboxed bits.  Takes the PrimReps of the
 876 -- constructor's arguments.  off_h and off_s are travelling offsets
 877 -- along the constructor and the stack.
 878 --
 879 -- Supposing a constructor in the heap has layout
 880 --
 881 --      Itbl p_1 ... p_i np_1 ... np_j
 882 --
 883 -- then we add to the stack, shown growing down, the following:
 884 --
 885 --    (previous stack)
 886 --         p_i
 887 --         ...
 888 --         p_1
 889 --         np_j
 890 --         tag_for(np_j)
 891 --         ..
 892 --         np_1
 893 --         tag_for(np_1)
 894 --
 895 -- so that in the common case (ptrs only) a single UNPACK instr can
 896 -- copy all the payload of the constr onto the stack with no further ado.
 897
 898 mkUnpackCode :: [Id]    -- constr args
 899              -> Int     -- depth before unpack
 900              -> BCEnv   -- env before unpack
 901              -> (BCInstrList, Int, BCEnv)
 902 mkUnpackCode vars d p
 903    = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
 904      --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
 905      --       ++ "\n") (
 906      (code_p `appOL` code_np, d', p')
 907      --)
 908      where
 909         -- vars with reps
 910         vreps = [(var, typePrimRep (idType var)) | var <- vars]
 911
 912         -- ptrs and nonptrs, forward
 913         vreps_p  = filter (isFollowableRep.snd) vreps
 914         vreps_np = filter (not.isFollowableRep.snd) vreps
 915
 916         -- the order in which we will augment the environment
 917         vreps_env = reverse vreps_p ++ reverse vreps_np
 918
 919         -- new env and depth
 920         vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
 921         p' = addListToFM p (zip (map fst vreps_env)
 922                                 (mkStackOffsets d vreps_env_tszsw))
 923         d' = d + sum vreps_env_tszsw
 924
 925         -- code to unpack the ptrs
 926         ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
 927         code_p | null vreps_p = nilOL
 928                | otherwise    = unitOL (UNPACK ptrs_szw)
 929
 930         -- code to unpack the nonptrs
 931         vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
 932         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
 933         do_nptrs off_h off_s [] = nilOL
 934         do_nptrs off_h off_s (npr:nprs)
 935            | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep]
 936            = approved
 937            | otherwise
 938            = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
 939              where
 940                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
 941                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
 942                 usizeW   = untaggedSizeW npr
 943                 tsizeW   = taggedSizeW npr
 944
 945
 946 -- Push an atom onto the stack, returning suitable code & number of
 947 -- stack words used.  Pushes it either tagged or untagged, since
 948 -- pushAtom is used to set up the stack prior to copying into the
 949 -- heap for both APs (requiring tags) and constructors (which don't).
 950 --
 951 -- NB this means NO GC between pushing atoms for a constructor and
 952 -- copying them into the heap.  It probably also means that
 953 -- tail calls MUST be of the form atom{atom ... atom} since if the
 954 -- expression head was allowed to be arbitrary, there could be GC
 955 -- in between pushing the arg atoms and completing the head.
 956 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
 957 -- isn't a problem; but only if arbitrary graph construction for the
 958 -- head doesn't leave this BCO, since GC might happen at the start of
 959 -- each BCO (we consult doYouWantToGC there).
 960 --
 961 -- Blargh.  JRS 001206
 962 --
 963 -- NB (further) that the env p must map each variable to the highest-
 964 -- numbered stack slot for it.  For example, if the stack has depth 4
 965 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
 966 -- the tag in stack[5], the stack will have depth 6, and p must map v to
 967 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
 968 -- 6 stack has valid words 0 .. 5.
 969
 970 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
 971 pushAtom tagged d p (AnnVar v)
 972
 973    | idPrimRep v == VoidRep
 974    = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
 975                else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
 976
 977    | isFCallId v
 978    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
 979
 980    | Just primop <- isPrimOpId_maybe v
 981    = returnBc (unitOL (PUSH_G (Right primop)), 1)
 982
 983    | otherwise
 984    = let  {-
 985           str = "\npushAtom " ++ showSDocDebug (ppr v)
 986                ++ " :: " ++ showSDocDebug (pprType (idType v))
 987                ++ ", depth = " ++ show d
 988                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
 989                showSDocDebug (ppBCEnv p)
 990                ++ " --> words: " ++ show (snd result) ++ "\n" ++
 991                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
 992                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
 993          -}
 994
 995          result
 996             = case lookupBCEnv_maybe p v of
 997                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
 998                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
 999
1000          nm = case isDataConId_maybe v of
1001                  Just c  -> getName c
1002                  Nothing -> getName v
1003
1004          sz_t   = taggedIdSizeW v
1005          sz_u   = untaggedIdSizeW v
1006          nwords = if tagged then sz_t else sz_u
1007      in
1008          returnBc result
1009
1010 pushAtom True d p (AnnLit lit)
1011    = pushAtom False d p (AnnLit lit)            `thenBc` \ (ubx_code, ubx_size) ->
1012      returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
1013
1014 pushAtom False d p (AnnLit lit)
1015    = case lit of
1016         MachWord w   -> code WordRep
1017         MachInt i    -> code IntRep
1018         MachFloat r  -> code FloatRep
1019         MachDouble r -> code DoubleRep
1020         MachChar c   -> code CharRep
1021         MachStr s    -> pushStr s
1022      where
1023         code rep
1024            = let size_host_words = untaggedSizeW rep
1025              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1026                            size_host_words)
1027
1028         pushStr s
1029            = let getMallocvilleAddr
1030                     = case s of
1031                          CharStr s i -> returnBc (A# s)
1032
1033                          FastString _ l ba ->
1034                             -- sigh, a string in the heap is no good to us.
1035                             -- We need a static C pointer, since the type of
1036                             -- a string literal is Addr#.  So, copy the string
1037                             -- into C land and introduce a memory leak
1038                             -- at the same time.
1039                             let n = I# l
1040                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
1041                             in  ioToBc (
1042                                    do (Ptr a#) <- mallocBytes (n+1)
1043                                       strncpy (Ptr a#) ba (fromIntegral n)
1044                                       writeCharOffAddr (A# a#) n '\0'
1045                                       return (A# a#)
1046                                    )
1047                          other -> panic "ByteCodeGen.pushAtom.pushStr"
1048              in
1049                 getMallocvilleAddr `thenBc` \ addr ->
1050                 -- Get the addr on the stack, untaggedly
1051                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1052
1053
1054
1055
1056
1057 pushAtom tagged d p (AnnApp f (_, AnnType _))
1058    = pushAtom tagged d p (snd f)
1059
1060 pushAtom tagged d p (AnnNote note e)
1061    = pushAtom tagged d p (snd e)
1062
1063 pushAtom tagged d p (AnnLam x e)
1064    | isTyVar x
1065    = pushAtom tagged d p (snd e)
1066
1067 pushAtom tagged d p other
1068    = pprPanic "ByteCodeGen.pushAtom"
1069               (pprCoreExpr (deAnnotate (undefined, other)))
1070
1071 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1072
1073
1074 -- Given a bunch of alts code and their discrs, do the donkey work
1075 -- of making a multiway branch using a switch tree.
1076 -- What a load of hassle!
1077 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
1078                                 -- a hint; generates better code
1079                                 -- Nothing is always safe
1080               -> [(Discr, BCInstrList)]
1081               -> BcM BCInstrList
1082 mkMultiBranch maybe_ncons raw_ways
1083    = let d_way     = filter (isNoDiscr.fst) raw_ways
1084          notd_ways = naturalMergeSortLe
1085                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1086                         (filter (not.isNoDiscr.fst) raw_ways)
1087
1088          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1089          mkTree [] range_lo range_hi = returnBc the_default
1090
1091          mkTree [val] range_lo range_hi
1092             | range_lo `eqAlt` range_hi
1093             = returnBc (snd val)
1094             | otherwise
1095             = getLabelBc                                `thenBc` \ label_neq ->
1096               returnBc (mkTestEQ (fst val) label_neq
1097                         `consOL` (snd val
1098                         `appOL`   unitOL (LABEL label_neq)
1099                         `appOL`   the_default))
1100
1101          mkTree vals range_lo range_hi
1102             = let n = length vals `div` 2
1103                   vals_lo = take n vals
1104                   vals_hi = drop n vals
1105                   v_mid = fst (head vals_hi)
1106               in
1107               getLabelBc                                `thenBc` \ label_geq ->
1108               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1109               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1110               returnBc (mkTestLT v_mid label_geq
1111                         `consOL` (code_lo
1112                         `appOL`   unitOL (LABEL label_geq)
1113                         `appOL`   code_hi))
1114
1115          the_default
1116             = case d_way of [] -> unitOL CASEFAIL
1117                             [(_, def)] -> def
1118
1119          -- None of these will be needed if there are no non-default alts
1120          (mkTestLT, mkTestEQ, init_lo, init_hi)
1121             | null notd_ways
1122             = panic "mkMultiBranch: awesome foursome"
1123             | otherwise
1124             = case fst (head notd_ways) of {
1125               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1126                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1127                             DiscrI minBound,
1128                             DiscrI maxBound );
1129               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1130                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1131                             DiscrF minF,
1132                             DiscrF maxF );
1133               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1134                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1135                             DiscrD minD,
1136                             DiscrD maxD );
1137               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1138                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1139                             DiscrP algMinBound,
1140                             DiscrP algMaxBound )
1141               }
1142
1143          (algMinBound, algMaxBound)
1144             = case maybe_ncons of
1145                  Just n  -> (0, n - 1)
1146                  Nothing -> (minBound, maxBound)
1147
1148          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1149          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1150          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1151          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1152          NoDiscr     `eqAlt` NoDiscr     = True
1153          _           `eqAlt` _           = False
1154
1155          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1156          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1157          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1158          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1159          NoDiscr     `leAlt` NoDiscr     = True
1160          _           `leAlt` _           = False
1161
1162          isNoDiscr NoDiscr = True
1163          isNoDiscr _       = False
1164
1165          dec (DiscrI i) = DiscrI (i-1)
1166          dec (DiscrP i) = DiscrP (i-1)
1167          dec other      = other         -- not really right, but if you
1168                 -- do cases on floating values, you'll get what you deserve
1169
1170          -- same snotty comment applies to the following
1171          minF, maxF :: Float
1172          minD, maxD :: Double
1173          minF = -1.0e37
1174          maxF =  1.0e37
1175          minD = -1.0e308
1176          maxD =  1.0e308
1177      in
1178          mkTree notd_ways init_lo init_hi
1179
1180 \end{code}
1181
1182 %************************************************************************
1183 %*                                                                      *
1184 \subsection{Supporting junk for the compilation schemes}
1185 %*                                                                      *
1186 %************************************************************************
1187
1188 \begin{code}
1189
1190 -- Describes case alts
1191 data Discr
1192    = DiscrI Int
1193    | DiscrF Float
1194    | DiscrD Double
1195    | DiscrP Int
1196    | NoDiscr
1197
1198 instance Outputable Discr where
1199    ppr (DiscrI i) = int i
1200    ppr (DiscrF f) = text (show f)
1201    ppr (DiscrD d) = text (show d)
1202    ppr (DiscrP i) = int i
1203    ppr NoDiscr    = text "DEF"
1204
1205
1206 -- Find things in the BCEnv (the what's-on-the-stack-env)
1207 -- See comment preceding pushAtom for precise meaning of env contents
1208 --lookupBCEnv :: BCEnv -> Id -> Int
1209 --lookupBCEnv env nm
1210 --   = case lookupFM env nm of
1211 --        Nothing -> pprPanic "lookupBCEnv"
1212 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
1213 --        Just xx -> xx
1214
1215 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1216 lookupBCEnv_maybe = lookupFM
1217
1218
1219 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
1220 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
1221 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
1222
1223 unboxedTupleException :: a
1224 unboxedTupleException
1225    = throwDyn
1226         (Panic
1227            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1228             "\tto foreign import/export decls in source.  Workaround:\n" ++
1229             "\tcompile this module to a .o file, then restart session."))
1230
1231
1232 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1233 bind x f    = f x
1234
1235 \end{code}
1236
1237 %************************************************************************
1238 %*                                                                      *
1239 \subsection{The bytecode generator's monad}
1240 %*                                                                      *
1241 %************************************************************************
1242
1243 \begin{code}
1244 data BcM_State
1245    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
1246                  nextlabel :: Int }             -- for generating local labels
1247
1248 type BcM r = BcM_State -> IO (BcM_State, r)
1249
1250 ioToBc :: IO a -> BcM a
1251 ioToBc io st = do x <- io
1252                   return (st, x)
1253
1254 runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
1255 runBc st0 m = do (st1, res) <- m st0
1256                  return (st1, res)
1257
1258 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1259 thenBc expr cont st0
1260    = do (st1, q) <- expr st0
1261         (st2, r) <- cont q st1
1262         return (st2, r)
1263
1264 thenBc_ :: BcM a -> BcM b -> BcM b
1265 thenBc_ expr cont st0
1266    = do (st1, q) <- expr st0
1267         (st2, r) <- cont st1
1268         return (st2, r)
1269
1270 returnBc :: a -> BcM a
1271 returnBc result st = return (st, result)
1272
1273
1274 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
1275 mapBc f []     = returnBc []
1276 mapBc f (x:xs)
1277   = f x          `thenBc` \ r  ->
1278     mapBc f xs   `thenBc` \ rs ->
1279     returnBc (r:rs)
1280
1281 emitBc :: ProtoBCO Name -> BcM ()
1282 emitBc bco st
1283    = return (st{bcos = bco : bcos st}, ())
1284
1285 getLabelBc :: BcM Int
1286 getLabelBc st
1287    = return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1288
1289 getLabelsBc :: Int -> BcM [Int]
1290 getLabelsBc n st
1291    = let ctr = nextlabel st
1292      in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1293
1294 \end{code}