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