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