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