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    | is_con_call,
 652      isUnboxedTupleCon con,                     -- (# ... #)
 653      [(_,arg1),(_,arg2)] <- args_r_to_l,        -- Exactly two args
 654      let
 655          isVoidRepAtom (AnnVar v)        = typePrimRep (idType v) == VoidRep
 656          isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
 657          isVoidRepAtom _                 = False
 658      in
 659      isVoidRepAtom arg2                 -- The first arg is void
 660    = --trace (if isSingleton args_r_to_l
 661      --       then "schemeT: unboxed singleton"
 662      --       else "schemeT: unboxed pair with Void first component") (
 663      pushAtom True d p arg1     `thenBc` \ (push, szw) ->
 664      returnBc (push                             -- value onto stack
 665                `appOL`  mkSLIDE szw (d-s)       -- clear to sequel
 666                `snocOL` RETURN (atomRep arg1))  -- go
 667         -- We used to use "schemeT d s p arg1", but that is wrong.
 668         -- We must use RETURN (because it's an unboxed tuple)
 669         -- I think that this still does not work: SLPJ Oct 02
 670
 671    -- Case 3
 672    | Just (CCall ccall_spec) <- isFCallId_maybe fn
 673    = generateCCall d s p ccall_spec fn args_r_to_l
 674
 675    -- Cases 4 and 5
 676    | otherwise
 677    = if   is_con_call && isUnboxedTupleCon con
 678      then unboxedTupleException
 679      else do_pushery d (map snd args_final_r_to_l)
 680
 681    where
 682       -- Detect and extract relevant info for the tagToEnum kludge.
 683       maybe_is_tagToEnum_call
 684          = let extract_constr_Names ty
 685                   = case splitTyConApp_maybe (repType ty) of
 686                        (Just (tyc, [])) |  isDataTyCon tyc
 687                                         -> map getName (tyConDataCons tyc)
 688                        other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
 689            in
 690            case app of
 691               (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
 692                  -> case isPrimOpId_maybe v of
 693                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
 694                        other            -> Nothing
 695               other -> Nothing
 696
 697       -- Extract the args (R->L) and fn
 698       (args_r_to_l, fn) = chomp app
 699       chomp expr
 700          = case snd expr of
 701               AnnVar v    -> ([], v)
 702               AnnApp f a
 703                  | isTypeAtom (snd a) -> chomp f
 704                  | otherwise          -> case chomp f of (az, f) -> (a:az, f)
 705               AnnNote n e -> chomp e
 706               other       -> pprPanic "schemeT"
 707                                (ppr (deAnnotate (panic "schemeT.chomp", other)))
 708
 709       n_args = length args_r_to_l
 710
 711       isTypeAtom (AnnType _) = True
 712       isTypeAtom _           = False
 713
 714       -- decide if this is a constructor application, because we need
 715       -- to rearrange the arguments on the stack if so.  For building
 716       -- a constructor, we put pointers before non-pointers and omit
 717       -- the tags.
 718       --
 719       -- Also if the constructor is not saturated, we just arrange to
 720       -- call the curried worker instead.
 721
 722       maybe_dcon  = case isDataConId_maybe fn of
 723                         Just con | dataConRepArity con == n_args -> Just con
 724                         _ -> Nothing
 725       is_con_call = isJust maybe_dcon
 726       (Just con)  = maybe_dcon
 727
 728       args_final_r_to_l
 729          | not is_con_call
 730          = args_r_to_l
 731          | otherwise
 732          = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
 733            where isPtr = isFollowableRep . atomRep
 734
 735       -- make code to push the args and then do the SLIDE-ENTER thing
 736       tag_when_push = not is_con_call
 737       narg_words    = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
 738       get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW
 739
 740       do_pushery d (arg:args)
 741          = pushAtom tag_when_push d p arg       `thenBc` \ (push, arg_words) ->
 742            do_pushery (d+arg_words) args        `thenBc` \ more_push_code ->
 743            returnBc (push `appOL` more_push_code)
 744       do_pushery d []
 745          | Just (CCall ccall_spec) <- isFCallId_maybe fn
 746          = panic "schemeT.do_pushery: unexpected ccall"
 747          | otherwise
 748          = case maybe_dcon of
 749               Just con -> returnBc (
 750                              (PACK con narg_words `consOL`
 751                               mkSLIDE 1 (d - narg_words - s)) `snocOL`
 752                               ENTER
 753                           )
 754               Nothing
 755                  -> pushAtom True d p (AnnVar fn)
 756                                                 `thenBc` \ (push, arg_words) ->
 757                     returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
 758                                                    (d - s - narg_words)
 759                               `snocOL` ENTER)
 760
 761
 762 {- Deal with a CCall.  Taggedly push the args onto the stack R->L,
 763    deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
 764    payloads in Ptr/Byte arrays).  Then, generate the marshalling
 765    (machine) code for the ccall, and create bytecodes to call that and
 766    then return in the right way.
 767 -}
 768 generateCCall :: Int -> Sequel          -- stack and sequel depths
 769               -> BCEnv
 770               -> CCallSpec              -- where to call
 771               -> Id                     -- of target, for type info
 772               -> [AnnExpr Id VarSet]    -- args (atoms)
 773               -> BcM BCInstrList
 774
 775 generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 776    = let
 777          -- useful constants
 778          addr_usizeW = untaggedSizeW AddrRep
 779          addr_tsizeW = taggedSizeW AddrRep
 780
 781          -- Get the args on the stack, with tags and suitably
 782          -- dereferenced for the CCall.  For each arg, return the
 783          -- depth to the first word of the bits for that arg, and the
 784          -- PrimRep of what was actually pushed.
 785
 786          pargs d [] = returnBc []
 787          pargs d ((_,a):az)
 788             = let arg_ty = repType (exprType (deAnnotate' a))
 789
 790               in case splitTyConApp_maybe arg_ty of
 791                     -- Don't push the FO; instead push the Addr# it
 792                     -- contains.
 793                     Just (t, _)
 794                      | t == foreignObjPrimTyCon
 795                        -> pushAtom False{-irrelevant-} d p a
 796                                                         `thenBc` \ (push_fo, _) ->
 797                           let foro_szW = taggedSizeW PtrRep
 798                               d_now    = d + addr_tsizeW
 799                               code     = push_fo `appOL` toOL [
 800                                             UPK_TAG addr_usizeW 0 0,
 801                                             SLIDE addr_tsizeW foro_szW
 802                                          ]
 803                           in  pargs d_now az            `thenBc` \ rest ->
 804                               returnBc ((code, AddrRep) : rest)
 805
 806                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
 807                        -> pargs (d + addr_tsizeW) az    `thenBc` \ rest ->
 808                           parg_ArrayishRep arrPtrsHdrSize d p a
 809                                                         `thenBc` \ code ->
 810                           returnBc ((code,AddrRep):rest)
 811
 812                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
 813                        -> pargs (d + addr_tsizeW) az    `thenBc` \ rest ->
 814                           parg_ArrayishRep arrWordsHdrSize d p a
 815                                                         `thenBc` \ code ->
 816                           returnBc ((code,AddrRep):rest)
 817
 818                     -- Default case: push taggedly, but otherwise intact.
 819                     other
 820                        -> pushAtom True d p a           `thenBc` \ (code_a, sz_a) ->
 821                           pargs (d+sz_a) az             `thenBc` \ rest ->
 822                           returnBc ((code_a, atomRep a) : rest)
 823
 824          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
 825          -- the stack but then advance it over the headers, so as to
 826          -- point to the payload.
 827          parg_ArrayishRep hdrSizeW d p a
 828             = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) ->
 829               -- The ptr points at the header.  Advance it over the
 830               -- header and then pretend this is an Addr# (push a tag).
 831               returnBc (push_fo `snocOL`
 832                         SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep
 833                                             * wORD_SIZE)
 834                         `snocOL`
 835                         PUSH_TAG addr_usizeW)
 836
 837      in
 838          pargs d0 args_r_to_l                           `thenBc` \ code_n_reps ->
 839      let
 840          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
 841
 842          push_args    = concatOL pushs_arg
 843          d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
 844          a_reps_pushed_RAW
 845             | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
 846             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
 847             | otherwise
 848             = reverse (tail a_reps_pushed_r_to_l)
 849
 850          -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
 851          -- push_args is the code to do that.
 852          -- d_after_args is the stack depth once the args are on.
 853
 854          -- Get the result rep.
 855          (returns_void, r_rep)
 856             = case maybe_getCCallReturnRep (idType fn) of
 857                  Nothing -> (True,  VoidRep)
 858                  Just rr -> (False, rr)
 859          {-
 860          Because the Haskell stack grows down, the a_reps refer to
 861          lowest to highest addresses in that order.  The args for the call
 862          are on the stack.  Now push an unboxed, tagged Addr# indicating
 863          the C function to call.  Then push a dummy placeholder for the
 864          result.  Finally, emit a CCALL insn with an offset pointing to the
 865          Addr# just pushed, and a literal field holding the mallocville
 866          address of the piece of marshalling code we generate.
 867          So, just prior to the CCALL insn, the stack looks like this
 868          (growing down, as usual):
 869
 870             <arg_n>
 871             ...
 872             <arg_1>
 873             Addr# address_of_C_fn
 874             <placeholder-for-result#> (must be an unboxed type)
 875
 876          The interpreter then calls the marshall code mentioned
 877          in the CCALL insn, passing it (& <placeholder-for-result#>),
 878          that is, the addr of the topmost word in the stack.
 879          When this returns, the placeholder will have been
 880          filled in.  The placeholder is slid down to the sequel
 881          depth, and we RETURN.
 882
 883          This arrangement makes it simple to do f-i-dynamic since the Addr#
 884          value is the first arg anyway.  It also has the virtue that the
 885          stack is GC-understandable at all times.
 886
 887          The marshalling code is generated specifically for this
 888          call site, and so knows exactly the (Haskell) stack
 889          offsets of the args, fn address and placeholder.  It
 890          copies the args to the C stack, calls the stacked addr,
 891          and parks the result back in the placeholder.  The interpreter
 892          calls it as a normal C call, assuming it has a signature
 893             void marshall_code ( StgWord* ptr_to_top_of_stack )
 894          -}
 895          -- resolve static address
 896          get_target_info
 897             = case target of
 898                  DynamicTarget
 899                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
 900                  StaticTarget target
 901                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
 902                        returnBc (True, res)
 903                  CasmTarget _
 904                     -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
 905      in
 906          get_target_info        `thenBc` \ (is_static, static_target_addr) ->
 907      let
 908
 909          -- Get the arg reps, zapping the leading Addr# in the dynamic case
 910          a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
 911                 | is_static = a_reps_pushed_RAW
 912                 | otherwise = if null a_reps_pushed_RAW
 913                               then panic "ByteCodeGen.generateCCall: dyn with no args"
 914                               else tail a_reps_pushed_RAW
 915
 916          -- push the Addr#
 917          (push_Addr, d_after_Addr)
 918             | is_static
 919             = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
 920                      PUSH_TAG addr_usizeW],
 921                d_after_args + addr_tsizeW)
 922             | otherwise -- is already on the stack
 923             = (nilOL, d_after_args)
 924
 925          -- Push the return placeholder.  For a call returning nothing,
 926          -- this is a VoidRep (tag).
 927          r_usizeW  = untaggedSizeW r_rep
 928          r_tsizeW  = taggedSizeW r_rep
 929          d_after_r = d_after_Addr + r_tsizeW
 930          r_lit     = mkDummyLiteral r_rep
 931          push_r    = (if   returns_void
 932                       then nilOL
 933                       else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
 934                       `appOL`
 935                       unitOL (PUSH_TAG r_usizeW)
 936
 937          -- generate the marshalling code we're going to call
 938          r_offW       = 0
 939          addr_offW    = r_tsizeW
 940          arg1_offW    = r_tsizeW + addr_tsizeW
 941          args_offW    = map (arg1_offW +)
 942                             (init (scanl (+) 0 (map taggedSizeW a_reps)))
 943      in
 944          ioToBc (mkMarshalCode cconv
 945                     (r_offW, r_rep) addr_offW
 946                     (zip args_offW a_reps))     `thenBc` \ addr_of_marshaller ->
 947          recordMallocBc addr_of_marshaller      `thenBc_`
 948      let
 949          -- do the call
 950          do_call      = unitOL (CCALL (castPtr addr_of_marshaller))
 951          -- slide and return
 952          wrapup       = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
 953                         `snocOL` RETURN r_rep
 954      in
 955          --trace (show (arg1_offW, args_offW  ,  (map taggedSizeW a_reps) )) (
 956          returnBc (
 957          push_args `appOL`
 958          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
 959          )
 960          --)
 961
 962
 963 -- Make a dummy literal, to be used as a placeholder for FFI return
 964 -- values on the stack.
 965 mkDummyLiteral :: PrimRep -> Literal
 966 mkDummyLiteral pr
 967    = case pr of
 968         CharRep   -> MachChar 0
 969         IntRep    -> MachInt 0
 970         WordRep   -> MachWord 0
 971         DoubleRep -> MachDouble 0
 972         FloatRep  -> MachFloat 0
 973         AddrRep   | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
 974         _         -> moan64 "mkDummyLiteral" (ppr pr)
 975
 976
 977 -- Convert (eg)
 978 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 979 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 980 --
 981 -- to  Just IntRep
 982 -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
 983 --
 984 -- Alternatively, for call-targets returning nothing, convert
 985 --
 986 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 987 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
 988 --
 989 -- to  Nothing
 990
 991 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 992 maybe_getCCallReturnRep fn_ty
 993    = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
 994          maybe_r_rep_to_go
 995             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
 996          (r_tycon, r_reps)
 997             = case splitTyConApp_maybe (repType r_ty) of
 998                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
 999                       Nothing -> blargh
1000          ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
1001                 || r_reps == [VoidRep] )
1002               && isUnboxedTupleTyCon r_tycon
1003               && case maybe_r_rep_to_go of
1004                     Nothing    -> True
1005                     Just r_rep -> r_rep /= PtrRep
1006                                   -- if it was, it would be impossible
1007                                   -- to create a valid return value
1008                                   -- placeholder on the stack
1009          blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1010                            (pprType fn_ty)
1011      in
1012      --trace (showSDoc (ppr (a_reps, r_reps))) (
1013      if ok then maybe_r_rep_to_go else blargh
1014      --)
1015
1016 atomRep (AnnVar v)    = typePrimRep (idType v)
1017 atomRep (AnnLit l)    = literalPrimRep l
1018 atomRep (AnnNote n b) = atomRep (snd b)
1019 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
1020 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
1021 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
1022
1023 -- Compile code which expects an unboxed Int on the top of stack,
1024 -- (call it i), and pushes the i'th closure in the supplied list
1025 -- as a consequence.
1026 implement_tagToId :: [Name] -> BcM BCInstrList
1027 implement_tagToId names
1028    = ASSERT( notNull names )
1029      getLabelsBc (length names)                 `thenBc` \ labels ->
1030      getLabelBc                                 `thenBc` \ label_fail ->
1031      getLabelBc                                 `thenBc` \ label_exit ->
1032      zip4 labels (tail labels ++ [label_fail])
1033                  [0 ..] names                   `bind`   \ infos ->
1034      map (mkStep label_exit) infos              `bind`   \ steps ->
1035      returnBc (concatOL steps
1036                `appOL`
1037                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
1038      where
1039         mkStep l_exit (my_label, next_label, n, name_for_n)
1040            = toOL [LABEL my_label,
1041                    TESTEQ_I n next_label,
1042                    PUSH_G (Left name_for_n),
1043                    JMP l_exit]
1044
1045
1046 -- Make code to unpack the top-of-stack constructor onto the stack,
1047 -- adding tags for the unboxed bits.  Takes the PrimReps of the
1048 -- constructor's arguments.  off_h and off_s are travelling offsets
1049 -- along the constructor and the stack.
1050 --
1051 -- Supposing a constructor in the heap has layout
1052 --
1053 --      Itbl p_1 ... p_i np_1 ... np_j
1054 --
1055 -- then we add to the stack, shown growing down, the following:
1056 --
1057 --    (previous stack)
1058 --         p_i
1059 --         ...
1060 --         p_1
1061 --         np_j
1062 --         tag_for(np_j)
1063 --         ..
1064 --         np_1
1065 --         tag_for(np_1)
1066 --
1067 -- so that in the common case (ptrs only) a single UNPACK instr can
1068 -- copy all the payload of the constr onto the stack with no further ado.
1069
1070 mkUnpackCode :: [Id]    -- constr args
1071              -> Int     -- depth before unpack
1072              -> BCEnv   -- env before unpack
1073              -> (BCInstrList, Int, BCEnv)
1074 mkUnpackCode vars d p
1075    = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
1076      --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
1077      --       ++ "\n") (
1078      (code_p `appOL` code_np, d', p')
1079      --)
1080      where
1081         -- vars with reps
1082         vreps = [(var, typePrimRep (idType var)) | var <- vars]
1083
1084         -- ptrs and nonptrs, forward
1085         vreps_p  = filter (isFollowableRep.snd) vreps
1086         vreps_np = filter (not.isFollowableRep.snd) vreps
1087
1088         -- the order in which we will augment the environment
1089         vreps_env = reverse vreps_p ++ reverse vreps_np
1090
1091         -- new env and depth
1092         vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
1093         p' = addListToFM p (zip (map fst vreps_env)
1094                                 (mkStackOffsets d vreps_env_tszsw))
1095         d' = d + sum vreps_env_tszsw
1096
1097         -- code to unpack the ptrs
1098         ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
1099         code_p | null vreps_p = nilOL
1100                | otherwise    = unitOL (UNPACK ptrs_szw)
1101
1102         -- code to unpack the nonptrs
1103         vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
1104         code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
1105         do_nptrs off_h off_s [] = nilOL
1106         do_nptrs off_h off_s (npr:nprs)
1107            | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep,
1108                          CharRep, AddrRep, StablePtrRep]
1109            = approved
1110            | otherwise
1111            = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr)
1112              where
1113                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
1114                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
1115                 usizeW   = untaggedSizeW npr
1116                 tsizeW   = taggedSizeW npr
1117
1118
1119 -- Push an atom onto the stack, returning suitable code & number of
1120 -- stack words used.  Pushes it either tagged or untagged, since
1121 -- pushAtom is used to set up the stack prior to copying into the
1122 -- heap for both APs (requiring tags) and constructors (which don't).
1123 --
1124 -- NB this means NO GC between pushing atoms for a constructor and
1125 -- copying them into the heap.  It probably also means that
1126 -- tail calls MUST be of the form atom{atom ... atom} since if the
1127 -- expression head was allowed to be arbitrary, there could be GC
1128 -- in between pushing the arg atoms and completing the head.
1129 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
1130 -- isn't a problem; but only if arbitrary graph construction for the
1131 -- head doesn't leave this BCO, since GC might happen at the start of
1132 -- each BCO (we consult doYouWantToGC there).
1133 --
1134 -- Blargh.  JRS 001206
1135 --
1136 -- NB (further) that the env p must map each variable to the highest-
1137 -- numbered stack slot for it.  For example, if the stack has depth 4
1138 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1139 -- the tag in stack[5], the stack will have depth 6, and p must map v to
1140 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
1141 -- 6 stack has valid words 0 .. 5.
1142
1143 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
1144 pushAtom tagged d p (AnnVar v)
1145
1146    | idPrimRep v == VoidRep
1147    = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
1148                else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
1149
1150    | isFCallId v
1151    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1152
1153    | Just primop <- isPrimOpId_maybe v
1154    = returnBc (unitOL (PUSH_G (Right primop)), 1)
1155
1156    | otherwise
1157    = let  {-
1158           str = "\npushAtom " ++ showSDocDebug (ppr v)
1159                ++ " :: " ++ showSDocDebug (pprType (idType v))
1160                ++ ", depth = " ++ show d
1161                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
1162                showSDocDebug (ppBCEnv p)
1163                ++ " --> words: " ++ show (snd result) ++ "\n" ++
1164                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
1165                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
1166          -}
1167
1168          result
1169             = case lookupBCEnv_maybe p v of
1170                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
1171                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
1172
1173          nm = case isDataConId_maybe v of
1174                  Just c  -> getName c
1175                  Nothing -> getName v
1176
1177          sz_t   = taggedIdSizeW v
1178          sz_u   = untaggedIdSizeW v
1179          nwords = if tagged then sz_t else sz_u
1180      in
1181          returnBc result
1182
1183 pushAtom True d p (AnnLit lit)
1184    = pushAtom False d p (AnnLit lit)            `thenBc` \ (ubx_code, ubx_size) ->
1185      returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
1186
1187 pushAtom False d p (AnnLit lit)
1188    = case lit of
1189         MachLabel fs -> code CodePtrRep
1190         MachWord w   -> code WordRep
1191         MachInt i    -> code IntRep
1192         MachFloat r  -> code FloatRep
1193         MachDouble r -> code DoubleRep
1194         MachChar c   -> code CharRep
1195         MachStr s    -> pushStr s
1196      where
1197         code rep
1198            = let size_host_words = untaggedSizeW rep
1199              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1200                            size_host_words)
1201
1202         pushStr s
1203            = let getMallocvilleAddr
1204                     = case s of
1205                          FastString _ l ba ->
1206                             -- sigh, a string in the heap is no good to us.
1207                             -- We need a static C pointer, since the type of
1208                             -- a string literal is Addr#.  So, copy the string
1209                             -- into C land and introduce a memory leak
1210                             -- at the same time.
1211                             let n = I# l
1212                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
1213                             in  ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
1214                                 recordMallocBc ptr         `thenBc_`
1215                                 ioToBc (
1216                                    do memcpy ptr ba (fromIntegral n)
1217                                       pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1218                                       return ptr
1219                                    )
1220                          other -> panic "ByteCodeGen.pushAtom.pushStr"
1221              in
1222                 getMallocvilleAddr `thenBc` \ addr ->
1223                 -- Get the addr on the stack, untaggedly
1224                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1225
1226
1227
1228
1229
1230 pushAtom tagged d p (AnnApp f (_, AnnType _))
1231    = pushAtom tagged d p (snd f)
1232
1233 pushAtom tagged d p (AnnNote note e)
1234    = pushAtom tagged d p (snd e)
1235
1236 pushAtom tagged d p (AnnLam x e)
1237    | isTyVar x
1238    = pushAtom tagged d p (snd e)
1239
1240 pushAtom tagged d p other
1241    = pprPanic "ByteCodeGen.pushAtom"
1242               (pprCoreExpr (deAnnotate (undefined, other)))
1243
1244 foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1245
1246
1247 -- Given a bunch of alts code and their discrs, do the donkey work
1248 -- of making a multiway branch using a switch tree.
1249 -- What a load of hassle!
1250 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
1251                                 -- a hint; generates better code
1252                                 -- Nothing is always safe
1253               -> [(Discr, BCInstrList)]
1254               -> BcM BCInstrList
1255 mkMultiBranch maybe_ncons raw_ways
1256    = let d_way     = filter (isNoDiscr.fst) raw_ways
1257          notd_ways = naturalMergeSortLe
1258                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1259                         (filter (not.isNoDiscr.fst) raw_ways)
1260
1261          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1262          mkTree [] range_lo range_hi = returnBc the_default
1263
1264          mkTree [val] range_lo range_hi
1265             | range_lo `eqAlt` range_hi
1266             = returnBc (snd val)
1267             | otherwise
1268             = getLabelBc                                `thenBc` \ label_neq ->
1269               returnBc (mkTestEQ (fst val) label_neq
1270                         `consOL` (snd val
1271                         `appOL`   unitOL (LABEL label_neq)
1272                         `appOL`   the_default))
1273
1274          mkTree vals range_lo range_hi
1275             = let n = length vals `div` 2
1276                   vals_lo = take n vals
1277                   vals_hi = drop n vals
1278                   v_mid = fst (head vals_hi)
1279               in
1280               getLabelBc                                `thenBc` \ label_geq ->
1281               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1282               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1283               returnBc (mkTestLT v_mid label_geq
1284                         `consOL` (code_lo
1285                         `appOL`   unitOL (LABEL label_geq)
1286                         `appOL`   code_hi))
1287
1288          the_default
1289             = case d_way of [] -> unitOL CASEFAIL
1290                             [(_, def)] -> def
1291
1292          -- None of these will be needed if there are no non-default alts
1293          (mkTestLT, mkTestEQ, init_lo, init_hi)
1294             | null notd_ways
1295             = panic "mkMultiBranch: awesome foursome"
1296             | otherwise
1297             = case fst (head notd_ways) of {
1298               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1299                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1300                             DiscrI minBound,
1301                             DiscrI maxBound );
1302               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1303                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1304                             DiscrF minF,
1305                             DiscrF maxF );
1306               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1307                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1308                             DiscrD minD,
1309                             DiscrD maxD );
1310               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1311                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1312                             DiscrP algMinBound,
1313                             DiscrP algMaxBound )
1314               }
1315
1316          (algMinBound, algMaxBound)
1317             = case maybe_ncons of
1318                  Just n  -> (0, n - 1)
1319                  Nothing -> (minBound, maxBound)
1320
1321          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1322          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1323          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1324          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1325          NoDiscr     `eqAlt` NoDiscr     = True
1326          _           `eqAlt` _           = False
1327
1328          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1329          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1330          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1331          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1332          NoDiscr     `leAlt` NoDiscr     = True
1333          _           `leAlt` _           = False
1334
1335          isNoDiscr NoDiscr = True
1336          isNoDiscr _       = False
1337
1338          dec (DiscrI i) = DiscrI (i-1)
1339          dec (DiscrP i) = DiscrP (i-1)
1340          dec other      = other         -- not really right, but if you
1341                 -- do cases on floating values, you'll get what you deserve
1342
1343          -- same snotty comment applies to the following
1344          minF, maxF :: Float
1345          minD, maxD :: Double
1346          minF = -1.0e37
1347          maxF =  1.0e37
1348          minD = -1.0e308
1349          maxD =  1.0e308
1350      in
1351          mkTree notd_ways init_lo init_hi
1352
1353 \end{code}
1354
1355 %************************************************************************
1356 %*                                                                      *
1357 \subsection{Supporting junk for the compilation schemes}
1358 %*                                                                      *
1359 %************************************************************************
1360
1361 \begin{code}
1362
1363 -- Describes case alts
1364 data Discr
1365    = DiscrI Int
1366    | DiscrF Float
1367    | DiscrD Double
1368    | DiscrP Int
1369    | NoDiscr
1370
1371 instance Outputable Discr where
1372    ppr (DiscrI i) = int i
1373    ppr (DiscrF f) = text (show f)
1374    ppr (DiscrD d) = text (show d)
1375    ppr (DiscrP i) = int i
1376    ppr NoDiscr    = text "DEF"
1377
1378
1379 -- Find things in the BCEnv (the what's-on-the-stack-env)
1380 -- See comment preceding pushAtom for precise meaning of env contents
1381 --lookupBCEnv :: BCEnv -> Id -> Int
1382 --lookupBCEnv env nm
1383 --   = case lookupFM env nm of
1384 --        Nothing -> pprPanic "lookupBCEnv"
1385 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
1386 --        Just xx -> xx
1387
1388 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1389 lookupBCEnv_maybe = lookupFM
1390
1391
1392 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
1393 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
1394 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
1395
1396 unboxedTupleException :: a
1397 unboxedTupleException
1398    = throwDyn
1399         (Panic
1400            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1401             "\tto foreign import/export decls in source.  Workaround:\n" ++
1402             "\tcompile this module to a .o file, then restart session."))
1403
1404
1405 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1406 bind x f    = f x
1407
1408 \end{code}
1409
1410 %************************************************************************
1411 %*                                                                      *
1412 \subsection{The bytecode generator's monad}
1413 %*                                                                      *
1414 %************************************************************************
1415
1416 \begin{code}
1417 data BcM_State
1418    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
1419                  nextlabel :: Int,              -- for generating local labels
1420                  malloced  :: [Ptr ()] }        -- ptrs malloced for current BCO
1421                                                 -- Should be free()d when it is GCd
1422 type BcM r = BcM_State -> IO (BcM_State, r)
1423
1424 ioToBc :: IO a -> BcM a
1425 ioToBc io st = do x <- io
1426                   return (st, x)
1427
1428 runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
1429 runBc st0 m = do (st1, res) <- m st0
1430                  return (st1, res)
1431
1432 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1433 thenBc expr cont st0
1434    = do (st1, q) <- expr st0
1435         (st2, r) <- cont q st1
1436         return (st2, r)
1437
1438 thenBc_ :: BcM a -> BcM b -> BcM b
1439 thenBc_ expr cont st0
1440    = do (st1, q) <- expr st0
1441         (st2, r) <- cont st1
1442         return (st2, r)
1443
1444 returnBc :: a -> BcM a
1445 returnBc result st = return (st, result)
1446
1447
1448 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
1449 mapBc f []     = returnBc []
1450 mapBc f (x:xs)
1451   = f x          `thenBc` \ r  ->
1452     mapBc f xs   `thenBc` \ rs ->
1453     returnBc (r:rs)
1454
1455 emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
1456 emitBc bco st
1457    = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
1458
1459 newbcoBc :: BcM ()
1460 newbcoBc st
1461    | notNull (malloced st)
1462    = panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
1463    | otherwise
1464    = return (st, ())
1465
1466 recordMallocBc :: Ptr a -> BcM ()
1467 recordMallocBc a st
1468    = return (st{malloced = castPtr a : malloced st}, ())
1469
1470 getLabelBc :: BcM Int
1471 getLabelBc st
1472    = return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1473
1474 getLabelsBc :: Int -> BcM [Int]
1475 getLabelsBc n st
1476    = let ctr = nextlabel st
1477      in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1478
1479 \end{code}