ghc/compiler/ghci/ByteCodeGen.lhs

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