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