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