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