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                      linkIModules, linkIExpr
  11                    ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Outputable
  16 import Name             ( Name, getName, mkSysLocalName )
  17 import Id               ( Id, idType, isDataConId_maybe, mkVanillaId )
  18 import OrdList          ( OrdList, consOL, snocOL, appOL, unitOL,
  19                           nilOL, toOL, concatOL, fromOL )
  20 import FiniteMap        ( FiniteMap, addListToFM, listToFM,
  21                           addToFM, lookupFM, fmToList, plusFM )
  22 import CoreSyn
  23 import PprCore          ( pprCoreExpr )
  24 import Literal          ( Literal(..), literalPrimRep )
  25 import PrimRep          ( PrimRep(..) )
  26 import CoreFVs          ( freeVars )
  27 import Type             ( typePrimRep )
  28 import DataCon          ( dataConTag, fIRST_TAG, dataConTyCon )
  29 import TyCon            ( TyCon, tyConFamilySize )
  30 import Class            ( Class, classTyCon )
  31 import Util             ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
  32 import Var              ( isTyVar )
  33 import VarSet           ( VarSet, varSetElems )
  34 import PrimRep          ( getPrimRepSize, isFollowableRep )
  35 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  36 import ErrUtils         ( showPass, dumpIfSet_dyn )
  37 import Unique           ( mkPseudoUnique3 )
  38 import FastString       ( FastString(..) )
  39 import PprType          ( pprType )
  40 import ByteCodeInstr    ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO )
  41 import ByteCodeItbls    ( ItblEnv, mkITbls )
  42 import ByteCodeLink     ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
  43                           ClosureEnv, HValue, linkSomeBCOs, filterNameMap )
  44
  45 import List             ( intersperse, sortBy )
  46 import Foreign          ( Ptr(..), mallocBytes )
  47 import Addr             ( addrToInt, writeCharOffAddr )
  48 import CTypes           ( CInt )
  49
  50 import PrelBase         ( Int(..) )
  51 import PrelAddr         ( Addr(..) )
  52 import PrelGHC          ( ByteArray# )
  53 import IOExts           ( unsafePerformIO )
  54 import PrelIOBase       ( IO(..) )
  55
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Functions visible from outside this module.}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65
  66 byteCodeGen :: DynFlags
  67             -> [CoreBind]
  68             -> [TyCon] -> [Class]
  69             -> IO ([UnlinkedBCO], ItblEnv)
  70 byteCodeGen dflags binds local_tycons local_classes
  71    = do showPass dflags "ByteCodeGen"
  72         let tycs = local_tycons ++ map classTyCon local_classes
  73         itblenv <- mkITbls tycs
  74
  75         let flatBinds = concatMap getBind binds
  76             getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
  77             getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
  78             final_state = runBc (BcM_State [] 0)
  79                                 (mapBc schemeR flatBinds `thenBc_` returnBc ())
  80             (BcM_State proto_bcos final_ctr) = final_state
  81
  82         dumpIfSet_dyn dflags Opt_D_dump_BCOs
  83            "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
  84
  85         bcos <- mapM assembleBCO proto_bcos
  86
  87         return (bcos, itblenv)
  88
  89
  90 -- Returns: (the root BCO for this expression,
  91 --           a list of auxilary BCOs resulting from compiling closures)
  92 coreExprToBCOs :: DynFlags
  93                -> CoreExpr
  94                -> IO UnlinkedBCOExpr
  95 coreExprToBCOs dflags expr
  96  = do showPass dflags "ByteCodeGen"
  97
  98       -- create a totally bogus name for the top-level BCO; this
  99       -- should be harmless, since it's never used for anything
 100       let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level")
 101       let invented_id   = mkVanillaId invented_name (panic "invented_id's type")
 102
 103       let (BcM_State all_proto_bcos final_ctr)
 104              = runBc (BcM_State [] 0)
 105                      (schemeR (invented_id, freeVars expr))
 106       dumpIfSet_dyn dflags Opt_D_dump_BCOs
 107          "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
 108
 109       let root_proto_bco
 110              = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
 111                   [root_bco] -> root_bco
 112           auxiliary_proto_bcos
 113              = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos
 114
 115       auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
 116       root_bco <- assembleBCO root_proto_bco
 117
 118       return (root_bco, auxiliary_bcos)
 119
 120
 121 -- Linking stuff
 122 linkIModules :: ItblEnv    -- incoming global itbl env; returned updated
 123              -> ClosureEnv -- incoming global closure env; returned updated
 124              -> [([UnlinkedBCO], ItblEnv)]
 125              -> IO ([HValue], ItblEnv, ClosureEnv)
 126 linkIModules gie gce mods
 127    = do let (bcoss, ies) = unzip mods
 128             bcos = concat bcoss
 129             final_gie = foldr plusFM gie ies
 130         (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
 131         return (linked_bcos, final_gie, final_gce)
 132
 133
 134 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
 135           -> IO HValue    -- IO BCO# really
 136 linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
 137    = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
 138         (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
 139         return root_bco
 140 \end{code}
 141
 142 %************************************************************************
 143 %*                                                                      *
 144 \subsection{Compilation schema for the bytecode generator.}
 145 %*                                                                      *
 146 %************************************************************************
 147
 148 \begin{code}
 149
 150 type BCInstrList = OrdList BCInstr
 151
 152 type Sequel = Int       -- back off to this depth before ENTER
 153
 154 -- Maps Ids to the offset from the stack _base_ so we don't have
 155 -- to mess with it after each push/pop.
 156 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
 157
 158 ppBCEnv :: BCEnv -> SDoc
 159 ppBCEnv p
 160    = text "begin-env"
 161      $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
 162      $$ text "end-env"
 163      where
 164         pp_one (var, offset) = int offset <> colon <+> ppr var
 165         cmp_snd x y = compare (snd x) (snd y)
 166
 167 -- Create a BCO and do a spot of peephole optimisation on the insns
 168 -- at the same time.
 169 mkProtoBCO nm instrs_ordlist origin
 170    = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
 171      where
 172         peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
 173            = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
 174         peep (PUSH_L off1 : PUSH_L off2 : rest)
 175            = PUSH_LL off1 off2 : peep rest
 176         peep (i:rest)
 177            = i : peep rest
 178         peep []
 179            = []
 180
 181
 182 -- Compile code for the right hand side of a let binding.
 183 -- Park the resulting BCO in the monad.  Also requires the
 184 -- variable to which this value was bound, so as to give the
 185 -- resulting BCO a name.
 186 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
 187 schemeR (nm, rhs)
 188 {-
 189    | trace (showSDoc (
 190               (char ' '
 191                $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
 192                $$ pprCoreExpr (deAnnotate rhs)
 193                $$ char ' '
 194               ))) False
 195    = undefined
 196 -}
 197    | otherwise
 198    = schemeR_wrk rhs nm (collect [] rhs)
 199
 200
 201 collect xs (_, AnnNote note e)
 202    = collect xs e
 203 collect xs (_, AnnLam x e)
 204    = collect (if isTyVar x then xs else (x:xs)) e
 205 collect xs not_lambda
 206    = (reverse xs, not_lambda)
 207
 208 schemeR_wrk original_body nm (args, body)
 209    = let fvs       = filter (not.isTyVar) (varSetElems (fst original_body))
 210          all_args  = reverse args ++ fvs
 211          szsw_args = map taggedIdSizeW all_args
 212          szw_args  = sum szsw_args
 213          p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
 214          argcheck  = unitOL (ARGCHECK szw_args)
 215      in
 216      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 217      emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
 218
 219 -- Let szsw be the sizes in words of some items pushed onto the stack,
 220 -- which has initial depth d'.  Return the values which the stack environment
 221 -- should map these items to.
 222 mkStackOffsets :: Int -> [Int] -> [Int]
 223 mkStackOffsets original_depth szsw
 224    = map (subtract 1) (tail (scanl (+) original_depth szsw))
 225
 226 -- Compile code to apply the given expression to the remaining args
 227 -- on the stack, returning a HNF.
 228 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 229
 230 -- Delegate tail-calls to schemeT.
 231 schemeE d s p e@(fvs, AnnApp f a)
 232    = returnBc (schemeT d s p (fvs, AnnApp f a))
 233 schemeE d s p e@(fvs, AnnVar v)
 234    | isFollowableRep v_rep
 235    = returnBc (schemeT d s p (fvs, AnnVar v))
 236
 237    | otherwise
 238    = -- returning an unboxed value.  Heave it on the stack, SLIDE, and RETURN.
 239      let (push, szw) = pushAtom True d p (AnnVar v)
 240      in  returnBc (push                         -- value onto stack
 241                    `appOL`  mkSLIDE szw (d-s)   -- clear to sequel
 242                    `snocOL` RETURN v_rep)       -- go
 243    where
 244       v_rep = typePrimRep (idType v)
 245
 246 schemeE d s p (fvs, AnnLit literal)
 247    = let (push, szw) = pushAtom True d p (AnnLit literal)
 248          l_rep = literalPrimRep literal
 249      in  returnBc (push                         -- value onto stack
 250                    `appOL`  mkSLIDE szw (d-s)   -- clear to sequel
 251                    `snocOL` RETURN l_rep)       -- go
 252
 253 schemeE d s p (fvs, AnnLet binds b)
 254    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 255                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 256          n     = length xs
 257          fvss  = map (filter (not.isTyVar).varSetElems.fst) rhss
 258
 259          -- Sizes of tagged free vars, + 1 for the fn
 260          sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
 261
 262          -- This p', d' defn is safe because all the items being pushed
 263          -- are ptrs, so all have size 1.  d' and p' reflect the stack
 264          -- after the closures have been allocated in the heap (but not
 265          -- filled in), and pointers to them parked on the stack.
 266          p'    = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
 267          d'    = d + n
 268
 269          infos = zipE4 fvss sizes xs [n, n-1 .. 1]
 270          zipE  = zipEqual "schemeE"
 271          zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
 272
 273          -- ToDo: don't build thunks for things with no free variables
 274          buildThunk dd ([], size, id, off)
 275             = PUSH_G (getName id)
 276               `consOL` unitOL (MKAP (off+size-1) size)
 277          buildThunk dd ((fv:fvs), size, id, off)
 278             = case pushAtom True dd p' (AnnVar fv) of
 279                  (push_code, pushed_szw)
 280                     -> push_code `appOL`
 281                        buildThunk (dd+pushed_szw) (fvs, size, id, off)
 282
 283          thunkCode = concatOL (map (buildThunk d') infos)
 284          allocCode = toOL (map ALLOC sizes)
 285      in
 286      schemeE d' s p' b                                  `thenBc`  \ bodyCode ->
 287      mapBc schemeR (zip xs rhss)                        `thenBc_`
 288      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 289
 290
 291 schemeE d s p (fvs, AnnCase scrut bndr alts)
 292    = let
 293         -- Top of stack is the return itbl, as usual.
 294         -- underneath it is the pointer to the alt_code BCO.
 295         -- When an alt is entered, it assumes the returned value is
 296         -- on top of the itbl.
 297         ret_frame_sizeW = 2
 298
 299         -- Env and depth in which to compile the alts, not including
 300         -- any vars bound by the alts themselves
 301         d' = d + ret_frame_sizeW + taggedIdSizeW bndr
 302         p' = addToFM p bndr (d' - 1)
 303
 304         scrut_primrep = typePrimRep (idType bndr)
 305         isAlgCase
 306            = case scrut_primrep of
 307                 CharRep -> False ; AddrRep -> False
 308                 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
 309                 PtrRep -> True
 310                 other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 311
 312         -- given an alt, return a discr and code for it.
 313         codeAlt alt@(discr, binds_f, rhs)
 314            | isAlgCase
 315            = let (unpack_code, d_after_unpack, p_after_unpack)
 316                     = mkUnpackCode binds_f d' p'
 317              in  schemeE d_after_unpack s p_after_unpack rhs
 318                                         `thenBc` \ rhs_code ->
 319                  returnBc (my_discr alt, unpack_code `appOL` rhs_code)
 320            | otherwise
 321            = ASSERT(null binds_f)
 322              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 323              returnBc (my_discr alt, rhs_code)
 324
 325         my_discr (DEFAULT, binds, rhs)  = NoDiscr
 326         my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
 327         my_discr (LitAlt l, binds, rhs)
 328            = case l of MachInt i     -> DiscrI (fromInteger i)
 329                        MachFloat r   -> DiscrF (fromRational r)
 330                        MachDouble r  -> DiscrD (fromRational r)
 331
 332         maybe_ncons
 333            | not isAlgCase = Nothing
 334            | otherwise
 335            = case [dc | (DataAlt dc, _, _) <- alts] of
 336                 []     -> Nothing
 337                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 338
 339      in
 340      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 341      mkMultiBranch maybe_ncons alt_stuff                `thenBc` \ alt_final ->
 342      let
 343          alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
 344          alt_bco_name = getName bndr
 345          alt_bco      = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
 346      in
 347      schemeE (d + ret_frame_sizeW)
 348              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 349
 350      emitBc alt_bco                                     `thenBc_`
 351      returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
 352
 353
 354 schemeE d s p (fvs, AnnNote note body)
 355    = schemeE d s p body
 356
 357 schemeE d s p other
 358    = pprPanic "ByteCodeGen.schemeE: unhandled case"
 359                (pprCoreExpr (deAnnotate other))
 360
 361
 362 -- Compile code to do a tail call.  If the function eventually
 363 -- to be called is a constructor, split the args into ptrs and
 364 -- non-ptrs, and push the nonptrs, then the ptrs, and then do PACK.
 365 -- *** This assumes that the root expression passed in represents
 366 -- a saturated constructor call.  ***
 367 --
 368 -- Otherwise, just push the args right-to-left, SLIDE and ENTER.
 369
 370 schemeT :: Int          -- Stack depth
 371         -> Sequel       -- Sequel depth
 372         -> BCEnv        -- stack env
 373         -> AnnExpr Id VarSet
 374         -> BCInstrList
 375
 376 schemeT d s p app
 377    = --trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) (
 378      code
 379      --)
 380      where
 381          -- Extract the args (R->L) and fn
 382          (args_r_to_l_raw, fn) = chomp app
 383          chomp expr
 384             = case snd expr of
 385                  AnnVar v   -> ([], v)
 386                  AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
 387                  other      -> pprPanic "schemeT"
 388                                   (ppr (deAnnotate (panic "schemeT.chomp", other)))
 389
 390          args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw
 391          isTypeAtom (AnnType _) = True
 392          isTypeAtom _           = False
 393
 394          -- decide if this is a constructor call, and rearrange
 395          -- args appropriately.
 396          maybe_dcon  = isDataConId_maybe fn
 397          is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
 398
 399          args_final_r_to_l
 400             | not is_con_call
 401             = args_r_to_l
 402             | otherwise
 403             = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l
 404               where isPtr = isFollowableRep . atomRep
 405
 406          -- make code to push the args and then do the SLIDE-ENTER thing
 407          code = do_pushery d args_final_r_to_l
 408
 409          tag_when_push = not is_con_call
 410          narg_words    = sum (map (get_arg_szw . atomRep) args_r_to_l)
 411          get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW
 412
 413          do_pushery d (arg:args)
 414             = let (push, arg_words) = pushAtom tag_when_push d p arg
 415               in  push `appOL` do_pushery (d+arg_words) args
 416          do_pushery d []
 417             = case maybe_dcon of
 418                  Just con -> PACK con narg_words `consOL` (
 419                              mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
 420                  Nothing
 421                     -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
 422                        in  push
 423                            `appOL` mkSLIDE (narg_words+arg_words)
 424                                            (d - s - narg_words)
 425                            `snocOL` ENTER
 426
 427 mkSLIDE n d
 428    = if d == 0 then nilOL else unitOL (SLIDE n d)
 429
 430 atomRep (AnnVar v)    = typePrimRep (idType v)
 431 atomRep (AnnLit l)    = literalPrimRep l
 432 atomRep (AnnNote n b) = atomRep (snd b)
 433 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 434 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 435
 436
 437 -- Make code to unpack the top-of-stack constructor onto the stack,
 438 -- adding tags for the unboxed bits.  Takes the PrimReps of the
 439 -- constructor's arguments.  off_h and off_s are travelling offsets
 440 -- along the constructor and the stack.
 441 --
 442 -- Supposing a constructor in the heap has layout
 443 --
 444 --      Itbl p_1 ... p_i np_1 ... np_j
 445 --
 446 -- then we add to the stack, shown growing down, the following:
 447 --
 448 --    (previous stack)
 449 --         p_i
 450 --         ...
 451 --         p_1
 452 --         np_j
 453 --         tag_for(np_j)
 454 --         ..
 455 --         np_1
 456 --         tag_for(np_1)
 457 --
 458 -- so that in the common case (ptrs only) a single UNPACK instr can
 459 -- copy all the payload of the constr onto the stack with no further ado.
 460
 461 mkUnpackCode :: [Id]    -- constr args
 462              -> Int     -- depth before unpack
 463              -> BCEnv   -- env before unpack
 464              -> (BCInstrList, Int, BCEnv)
 465 mkUnpackCode vars d p
 466    = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
 467      --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
 468      --       ++ "\n") (
 469      (code_p `appOL` code_np, d', p')
 470      --)
 471      where
 472         -- vars with reps
 473         vreps = [(var, typePrimRep (idType var)) | var <- vars]
 474
 475         -- ptrs and nonptrs, forward
 476         vreps_p  = filter (isFollowableRep.snd) vreps
 477         vreps_np = filter (not.isFollowableRep.snd) vreps
 478
 479         -- the order in which we will augment the environment
 480         vreps_env = reverse vreps_p ++ reverse vreps_np
 481
 482         -- new env and depth
 483         vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
 484         p' = addListToFM p (zip (map fst vreps_env)
 485                                 (mkStackOffsets d vreps_env_tszsw))
 486         d' = d + sum vreps_env_tszsw
 487
 488         -- code to unpack the ptrs
 489         ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
 490         code_p | null vreps_p = nilOL
 491                | otherwise    = unitOL (UNPACK ptrs_szw)
 492
 493         -- code to unpack the nonptrs
 494         vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
 495         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
 496         do_nptrs off_h off_s [] = nilOL
 497         do_nptrs off_h off_s (npr:nprs)
 498            = case npr of
 499                 IntRep -> approved ; FloatRep -> approved
 500                 DoubleRep -> approved ; AddrRep -> approved
 501                 _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
 502              where
 503                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
 504                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
 505                 usizeW   = untaggedSizeW npr
 506                 tsizeW   = taggedSizeW npr
 507
 508
 509 -- Push an atom onto the stack, returning suitable code & number of
 510 -- stack words used.  Pushes it either tagged or untagged, since
 511 -- pushAtom is used to set up the stack prior to copying into the
 512 -- heap for both APs (requiring tags) and constructors (which don't).
 513 --
 514 -- NB this means NO GC between pushing atoms for a constructor and
 515 -- copying them into the heap.  It probably also means that
 516 -- tail calls MUST be of the form atom{atom ... atom} since if the
 517 -- expression head was allowed to be arbitrary, there could be GC
 518 -- in between pushing the arg atoms and completing the head.
 519 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
 520 -- isn't a problem; but only if arbitrary graph construction for the
 521 -- head doesn't leave this BCO, since GC might happen at the start of
 522 -- each BCO (we consult doYouWantToGC there).
 523 --
 524 -- Blargh.  JRS 001206
 525 --
 526 -- NB (further) that the env p must map each variable to the highest-
 527 -- numbered stack slot for it.  For example, if the stack has depth 4
 528 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
 529 -- the tag in stack[5], the stack will have depth 6, and p must map v to
 530 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
 531 -- 6 stack has valid words 0 .. 5.
 532
 533 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
 534 pushAtom tagged d p (AnnVar v)
 535    = let str = "\npushAtom " ++ showSDocDebug (ppr v)
 536                ++ " :: " ++ showSDocDebug (pprType (idType v))
 537                ++ ", depth = " ++ show d
 538                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
 539                showSDocDebug (ppBCEnv p)
 540                ++ " --> words: " ++ show (snd result) ++ "\n" ++
 541                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
 542                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
 543                   where
 544                      cmp_snd x y = compare (snd x) (snd y)
 545          str' = if str == str then str else str
 546
 547          result
 548             = case lookupBCEnv_maybe p v of
 549                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
 550                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), nwords)
 551
 552          nm = case isDataConId_maybe v of
 553                  Just c  -> getName c
 554                  Nothing -> getName v
 555
 556          sz_t   = taggedIdSizeW v
 557          sz_u   = untaggedIdSizeW v
 558          nwords = if tagged then sz_t else sz_u
 559      in
 560          --trace str'
 561          result
 562
 563 pushAtom True d p (AnnLit lit)
 564    = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
 565      in  (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
 566
 567 pushAtom False d p (AnnLit lit)
 568    = case lit of
 569         MachInt i    -> code IntRep
 570         MachFloat r  -> code FloatRep
 571         MachDouble r -> code DoubleRep
 572         MachChar c   -> code CharRep
 573         MachStr s    -> pushStr s
 574      where
 575         code rep
 576            = let size_host_words = untaggedSizeW rep
 577              in (unitOL (PUSH_UBX lit size_host_words), size_host_words)
 578
 579         pushStr s
 580            = let mallocvilleAddr
 581                     = case s of
 582                          CharStr s i -> A# s
 583
 584                          FastString _ l ba ->
 585                             -- sigh, a string in the heap is no good to us.
 586                             -- We need a static C pointer, since the type of
 587                             -- a string literal is Addr#.  So, copy the string
 588                             -- into C land and introduce a memory leak
 589                             -- at the same time.
 590                             let n = I# l
 591                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
 592                             in  unsafePerformIO (
 593                                    do a@(Ptr addr) <- mallocBytes (n+1)
 594                                       strncpy a ba (fromIntegral n)
 595                                       writeCharOffAddr addr n '\0'
 596                                       return addr
 597                                    )
 598                          _ -> panic "StgInterp.lit2expr: unhandled string constant type"
 599
 600                  addrLit
 601                     = MachInt (toInteger (addrToInt mallocvilleAddr))
 602              in
 603                 -- Get the addr on the stack, untaggedly
 604                 (unitOL (PUSH_UBX addrLit 1), 1)
 605
 606
 607
 608
 609
 610 pushAtom tagged d p (AnnApp f (_, AnnType _))
 611    = pushAtom tagged d p (snd f)
 612
 613 pushAtom tagged d p (AnnNote note e)
 614    = pushAtom tagged d p (snd e)
 615
 616 pushAtom tagged d p other
 617    = pprPanic "ByteCodeGen.pushAtom"
 618               (pprCoreExpr (deAnnotate (undefined, other)))
 619
 620 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
 621
 622
 623 -- Given a bunch of alts code and their discrs, do the donkey work
 624 -- of making a multiway branch using a switch tree.
 625 -- What a load of hassle!
 626 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
 627                                 -- a hint; generates better code
 628                                 -- Nothing is always safe
 629               -> [(Discr, BCInstrList)]
 630               -> BcM BCInstrList
 631 mkMultiBranch maybe_ncons raw_ways
 632    = let d_way     = filter (isNoDiscr.fst) raw_ways
 633          notd_ways = naturalMergeSortLe
 634                         (\w1 w2 -> leAlt (fst w1) (fst w2))
 635                         (filter (not.isNoDiscr.fst) raw_ways)
 636
 637          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
 638          mkTree [] range_lo range_hi = returnBc the_default
 639
 640          mkTree [val] range_lo range_hi
 641             | range_lo `eqAlt` range_hi
 642             = returnBc (snd val)
 643             | otherwise
 644             = getLabelBc                                `thenBc` \ label_neq ->
 645               returnBc (mkTestEQ (fst val) label_neq
 646                         `consOL` (snd val
 647                         `appOL`   unitOL (LABEL label_neq)
 648                         `appOL`   the_default))
 649
 650          mkTree vals range_lo range_hi
 651             = let n = length vals `div` 2
 652                   vals_lo = take n vals
 653                   vals_hi = drop n vals
 654                   v_mid = fst (head vals_hi)
 655               in
 656               getLabelBc                                `thenBc` \ label_geq ->
 657               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
 658               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
 659               returnBc (mkTestLT v_mid label_geq
 660                         `consOL` (code_lo
 661                         `appOL`   unitOL (LABEL label_geq)
 662                         `appOL`   code_hi))
 663
 664          the_default
 665             = case d_way of [] -> unitOL CASEFAIL
 666                             [(_, def)] -> def
 667
 668          -- None of these will be needed if there are no non-default alts
 669          (mkTestLT, mkTestEQ, init_lo, init_hi)
 670             | null notd_ways
 671             = panic "mkMultiBranch: awesome foursome"
 672             | otherwise
 673             = case fst (head notd_ways) of {
 674               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
 675                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
 676                             DiscrI minBound,
 677                             DiscrI maxBound );
 678               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
 679                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
 680                             DiscrF minF,
 681                             DiscrF maxF );
 682               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
 683                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
 684                             DiscrD minD,
 685                             DiscrD maxD );
 686               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
 687                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
 688                             DiscrP algMinBound,
 689                             DiscrP algMaxBound )
 690               }
 691
 692          (algMinBound, algMaxBound)
 693             = case maybe_ncons of
 694                  Just n  -> (0, n - 1)
 695                  Nothing -> (minBound, maxBound)
 696
 697          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
 698          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
 699          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
 700          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
 701          NoDiscr     `eqAlt` NoDiscr     = True
 702          _           `eqAlt` _           = False
 703
 704          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
 705          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
 706          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
 707          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
 708          NoDiscr     `leAlt` NoDiscr     = True
 709          _           `leAlt` _           = False
 710
 711          isNoDiscr NoDiscr = True
 712          isNoDiscr _       = False
 713
 714          dec (DiscrI i) = DiscrI (i-1)
 715          dec (DiscrP i) = DiscrP (i-1)
 716          dec other      = other         -- not really right, but if you
 717                 -- do cases on floating values, you'll get what you deserve
 718
 719          -- same snotty comment applies to the following
 720          minF, maxF :: Float
 721          minD, maxD :: Double
 722          minF = -1.0e37
 723          maxF =  1.0e37
 724          minD = -1.0e308
 725          maxD =  1.0e308
 726      in
 727          mkTree notd_ways init_lo init_hi
 728
 729 \end{code}
 730
 731 %************************************************************************
 732 %*                                                                      *
 733 \subsection{Supporting junk for the compilation schemes}
 734 %*                                                                      *
 735 %************************************************************************
 736
 737 \begin{code}
 738
 739 -- Describes case alts
 740 data Discr
 741    = DiscrI Int
 742    | DiscrF Float
 743    | DiscrD Double
 744    | DiscrP Int
 745    | NoDiscr
 746
 747 instance Outputable Discr where
 748    ppr (DiscrI i) = int i
 749    ppr (DiscrF f) = text (show f)
 750    ppr (DiscrD d) = text (show d)
 751    ppr (DiscrP i) = int i
 752    ppr NoDiscr    = text "DEF"
 753
 754
 755 -- Find things in the BCEnv (the what's-on-the-stack-env)
 756 -- See comment preceding pushAtom for precise meaning of env contents
 757 --lookupBCEnv :: BCEnv -> Id -> Int
 758 --lookupBCEnv env nm
 759 --   = case lookupFM env nm of
 760 --        Nothing -> pprPanic "lookupBCEnv"
 761 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
 762 --        Just xx -> xx
 763
 764 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
 765 lookupBCEnv_maybe = lookupFM
 766
 767
 768 -- When I push one of these on the stack, how much does Sp move by?
 769 taggedSizeW :: PrimRep -> Int
 770 taggedSizeW pr
 771    | isFollowableRep pr = 1
 772    | otherwise          = 1{-the tag-} + getPrimRepSize pr
 773
 774
 775 -- The plain size of something, without tag.
 776 untaggedSizeW :: PrimRep -> Int
 777 untaggedSizeW pr
 778    | isFollowableRep pr = 1
 779    | otherwise          = getPrimRepSize pr
 780
 781
 782 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
 783 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
 784 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
 785
 786 \end{code}
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \subsection{The bytecode generator's monad}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794 \begin{code}
 795 data BcM_State
 796    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
 797                  nextlabel :: Int }             -- for generating local labels
 798
 799 type BcM result = BcM_State -> (result, BcM_State)
 800
 801 runBc :: BcM_State -> BcM () -> BcM_State
 802 runBc init_st m = case m init_st of { (r,st) -> st }
 803
 804 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 805 thenBc expr cont st
 806   = case expr st of { (result, st') -> cont result st' }
 807
 808 thenBc_ :: BcM a -> BcM b -> BcM b
 809 thenBc_ expr cont st
 810   = case expr st of { (result, st') -> cont st' }
 811
 812 returnBc :: a -> BcM a
 813 returnBc result st = (result, st)
 814
 815 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
 816 mapBc f []     = returnBc []
 817 mapBc f (x:xs)
 818   = f x          `thenBc` \ r  ->
 819     mapBc f xs   `thenBc` \ rs ->
 820     returnBc (r:rs)
 821
 822 emitBc :: ProtoBCO Name -> BcM ()
 823 emitBc bco st
 824    = ((), st{bcos = bco : bcos st})
 825
 826 getLabelBc :: BcM Int
 827 getLabelBc st
 828    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
 829
 830 \end{code}