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, CharRep, AddrRep]
1096            = approved
1097            | otherwise
1098            = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr)
1099              where
1100                 approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
1101                 theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
1102                 usizeW   = untaggedSizeW npr
1103                 tsizeW   = taggedSizeW npr
1104
1105
1106 -- Push an atom onto the stack, returning suitable code & number of
1107 -- stack words used.  Pushes it either tagged or untagged, since
1108 -- pushAtom is used to set up the stack prior to copying into the
1109 -- heap for both APs (requiring tags) and constructors (which don't).
1110 --
1111 -- NB this means NO GC between pushing atoms for a constructor and
1112 -- copying them into the heap.  It probably also means that
1113 -- tail calls MUST be of the form atom{atom ... atom} since if the
1114 -- expression head was allowed to be arbitrary, there could be GC
1115 -- in between pushing the arg atoms and completing the head.
1116 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
1117 -- isn't a problem; but only if arbitrary graph construction for the
1118 -- head doesn't leave this BCO, since GC might happen at the start of
1119 -- each BCO (we consult doYouWantToGC there).
1120 --
1121 -- Blargh.  JRS 001206
1122 --
1123 -- NB (further) that the env p must map each variable to the highest-
1124 -- numbered stack slot for it.  For example, if the stack has depth 4
1125 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1126 -- the tag in stack[5], the stack will have depth 6, and p must map v to
1127 -- 5 and not to 4.  Stack locations are numbered from zero, so a depth
1128 -- 6 stack has valid words 0 .. 5.
1129
1130 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
1131 pushAtom tagged d p (AnnVar v)
1132
1133    | idPrimRep v == VoidRep
1134    = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
1135                else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
1136
1137    | isFCallId v
1138    = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1139
1140    | Just primop <- isPrimOpId_maybe v
1141    = returnBc (unitOL (PUSH_G (Right primop)), 1)
1142
1143    | otherwise
1144    = let  {-
1145           str = "\npushAtom " ++ showSDocDebug (ppr v)
1146                ++ " :: " ++ showSDocDebug (pprType (idType v))
1147                ++ ", depth = " ++ show d
1148                ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
1149                showSDocDebug (ppBCEnv p)
1150                ++ " --> words: " ++ show (snd result) ++ "\n" ++
1151                showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
1152                ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
1153          -}
1154
1155          result
1156             = case lookupBCEnv_maybe p v of
1157                  Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
1158                  Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
1159
1160          nm = case isDataConId_maybe v of
1161                  Just c  -> getName c
1162                  Nothing -> getName v
1163
1164          sz_t   = taggedIdSizeW v
1165          sz_u   = untaggedIdSizeW v
1166          nwords = if tagged then sz_t else sz_u
1167      in
1168          returnBc result
1169
1170 pushAtom True d p (AnnLit lit)
1171    = pushAtom False d p (AnnLit lit)            `thenBc` \ (ubx_code, ubx_size) ->
1172      returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
1173
1174 pushAtom False d p (AnnLit lit)
1175    = case lit of
1176         MachWord w   -> code WordRep
1177         MachInt i    -> code IntRep
1178         MachFloat r  -> code FloatRep
1179         MachDouble r -> code DoubleRep
1180         MachChar c   -> code CharRep
1181         MachStr s    -> pushStr s
1182      where
1183         code rep
1184            = let size_host_words = untaggedSizeW rep
1185              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1186                            size_host_words)
1187
1188         pushStr s
1189            = let getMallocvilleAddr
1190                     = case s of
1191                          CharStr s i -> returnBc (Ptr s)
1192
1193                          FastString _ l ba ->
1194                             -- sigh, a string in the heap is no good to us.
1195                             -- We need a static C pointer, since the type of
1196                             -- a string literal is Addr#.  So, copy the string
1197                             -- into C land and introduce a memory leak
1198                             -- at the same time.
1199                             let n = I# l
1200                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
1201                             in  ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
1202                                 recordMallocBc ptr         `thenBc_`
1203                                 ioToBc (
1204                                    do memcpy ptr ba (fromIntegral n)
1205                                       pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1206                                       return ptr
1207                                    )
1208                          other -> panic "ByteCodeGen.pushAtom.pushStr"
1209              in
1210                 getMallocvilleAddr `thenBc` \ addr ->
1211                 -- Get the addr on the stack, untaggedly
1212                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1213
1214
1215
1216
1217
1218 pushAtom tagged d p (AnnApp f (_, AnnType _))
1219    = pushAtom tagged d p (snd f)
1220
1221 pushAtom tagged d p (AnnNote note e)
1222    = pushAtom tagged d p (snd e)
1223
1224 pushAtom tagged d p (AnnLam x e)
1225    | isTyVar x
1226    = pushAtom tagged d p (snd e)
1227
1228 pushAtom tagged d p other
1229    = pprPanic "ByteCodeGen.pushAtom"
1230               (pprCoreExpr (deAnnotate (undefined, other)))
1231
1232 foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1233
1234
1235 -- Given a bunch of alts code and their discrs, do the donkey work
1236 -- of making a multiway branch using a switch tree.
1237 -- What a load of hassle!
1238 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
1239                                 -- a hint; generates better code
1240                                 -- Nothing is always safe
1241               -> [(Discr, BCInstrList)]
1242               -> BcM BCInstrList
1243 mkMultiBranch maybe_ncons raw_ways
1244    = let d_way     = filter (isNoDiscr.fst) raw_ways
1245          notd_ways = naturalMergeSortLe
1246                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1247                         (filter (not.isNoDiscr.fst) raw_ways)
1248
1249          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1250          mkTree [] range_lo range_hi = returnBc the_default
1251
1252          mkTree [val] range_lo range_hi
1253             | range_lo `eqAlt` range_hi
1254             = returnBc (snd val)
1255             | otherwise
1256             = getLabelBc                                `thenBc` \ label_neq ->
1257               returnBc (mkTestEQ (fst val) label_neq
1258                         `consOL` (snd val
1259                         `appOL`   unitOL (LABEL label_neq)
1260                         `appOL`   the_default))
1261
1262          mkTree vals range_lo range_hi
1263             = let n = length vals `div` 2
1264                   vals_lo = take n vals
1265                   vals_hi = drop n vals
1266                   v_mid = fst (head vals_hi)
1267               in
1268               getLabelBc                                `thenBc` \ label_geq ->
1269               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1270               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1271               returnBc (mkTestLT v_mid label_geq
1272                         `consOL` (code_lo
1273                         `appOL`   unitOL (LABEL label_geq)
1274                         `appOL`   code_hi))
1275
1276          the_default
1277             = case d_way of [] -> unitOL CASEFAIL
1278                             [(_, def)] -> def
1279
1280          -- None of these will be needed if there are no non-default alts
1281          (mkTestLT, mkTestEQ, init_lo, init_hi)
1282             | null notd_ways
1283             = panic "mkMultiBranch: awesome foursome"
1284             | otherwise
1285             = case fst (head notd_ways) of {
1286               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1287                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1288                             DiscrI minBound,
1289                             DiscrI maxBound );
1290               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1291                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1292                             DiscrF minF,
1293                             DiscrF maxF );
1294               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1295                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1296                             DiscrD minD,
1297                             DiscrD maxD );
1298               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1299                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1300                             DiscrP algMinBound,
1301                             DiscrP algMaxBound )
1302               }
1303
1304          (algMinBound, algMaxBound)
1305             = case maybe_ncons of
1306                  Just n  -> (0, n - 1)
1307                  Nothing -> (minBound, maxBound)
1308
1309          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1310          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1311          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1312          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1313          NoDiscr     `eqAlt` NoDiscr     = True
1314          _           `eqAlt` _           = False
1315
1316          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1317          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1318          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1319          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1320          NoDiscr     `leAlt` NoDiscr     = True
1321          _           `leAlt` _           = False
1322
1323          isNoDiscr NoDiscr = True
1324          isNoDiscr _       = False
1325
1326          dec (DiscrI i) = DiscrI (i-1)
1327          dec (DiscrP i) = DiscrP (i-1)
1328          dec other      = other         -- not really right, but if you
1329                 -- do cases on floating values, you'll get what you deserve
1330
1331          -- same snotty comment applies to the following
1332          minF, maxF :: Float
1333          minD, maxD :: Double
1334          minF = -1.0e37
1335          maxF =  1.0e37
1336          minD = -1.0e308
1337          maxD =  1.0e308
1338      in
1339          mkTree notd_ways init_lo init_hi
1340
1341 \end{code}
1342
1343 %************************************************************************
1344 %*                                                                      *
1345 \subsection{Supporting junk for the compilation schemes}
1346 %*                                                                      *
1347 %************************************************************************
1348
1349 \begin{code}
1350
1351 -- Describes case alts
1352 data Discr
1353    = DiscrI Int
1354    | DiscrF Float
1355    | DiscrD Double
1356    | DiscrP Int
1357    | NoDiscr
1358
1359 instance Outputable Discr where
1360    ppr (DiscrI i) = int i
1361    ppr (DiscrF f) = text (show f)
1362    ppr (DiscrD d) = text (show d)
1363    ppr (DiscrP i) = int i
1364    ppr NoDiscr    = text "DEF"
1365
1366
1367 -- Find things in the BCEnv (the what's-on-the-stack-env)
1368 -- See comment preceding pushAtom for precise meaning of env contents
1369 --lookupBCEnv :: BCEnv -> Id -> Int
1370 --lookupBCEnv env nm
1371 --   = case lookupFM env nm of
1372 --        Nothing -> pprPanic "lookupBCEnv"
1373 --                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
1374 --        Just xx -> xx
1375
1376 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1377 lookupBCEnv_maybe = lookupFM
1378
1379
1380 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
1381 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
1382 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
1383
1384 unboxedTupleException :: a
1385 unboxedTupleException
1386    = throwDyn
1387         (Panic
1388            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1389             "\tto foreign import/export decls in source.  Workaround:\n" ++
1390             "\tcompile this module to a .o file, then restart session."))
1391
1392
1393 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1394 bind x f    = f x
1395
1396 \end{code}
1397
1398 %************************************************************************
1399 %*                                                                      *
1400 \subsection{The bytecode generator's monad}
1401 %*                                                                      *
1402 %************************************************************************
1403
1404 \begin{code}
1405 data BcM_State
1406    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
1407                  nextlabel :: Int,              -- for generating local labels
1408                  malloced  :: [Ptr ()] }        -- ptrs malloced for current BCO
1409                                                 -- Should be free()d when it is GCd
1410 type BcM r = BcM_State -> IO (BcM_State, r)
1411
1412 ioToBc :: IO a -> BcM a
1413 ioToBc io st = do x <- io
1414                   return (st, x)
1415
1416 runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
1417 runBc st0 m = do (st1, res) <- m st0
1418                  return (st1, res)
1419
1420 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1421 thenBc expr cont st0
1422    = do (st1, q) <- expr st0
1423         (st2, r) <- cont q st1
1424         return (st2, r)
1425
1426 thenBc_ :: BcM a -> BcM b -> BcM b
1427 thenBc_ expr cont st0
1428    = do (st1, q) <- expr st0
1429         (st2, r) <- cont st1
1430         return (st2, r)
1431
1432 returnBc :: a -> BcM a
1433 returnBc result st = return (st, result)
1434
1435
1436 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
1437 mapBc f []     = returnBc []
1438 mapBc f (x:xs)
1439   = f x          `thenBc` \ r  ->
1440     mapBc f xs   `thenBc` \ rs ->
1441     returnBc (r:rs)
1442
1443 emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
1444 emitBc bco st
1445    = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
1446
1447 newbcoBc :: BcM ()
1448 newbcoBc st
1449    | not (null (malloced st))
1450    = panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
1451    | otherwise
1452    = return (st, ())
1453
1454 recordMallocBc :: Ptr a -> BcM ()
1455 recordMallocBc a st
1456    = return (st{malloced = castPtr a : malloced st}, ())
1457
1458 getLabelBc :: BcM Int
1459 getLabelBc st
1460    = return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1461
1462 getLabelsBc :: Int -> BcM [Int]
1463 getLabelsBc n st
1464    = let ctr = nextlabel st
1465      in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1466
1467 \end{code}