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