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