ghc/compiler/ghci/ByteCodeGen.lhs

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