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.
 957
 958          The marshalling code is generated specifically for this
 959          call site, and so knows exactly the (Haskell) stack
 960          offsets of the args, fn address and placeholder.  It
 961          copies the args to the C stack, calls the stacked addr,
 962          and parks the result back in the placeholder.  The interpreter
 963          calls it as a normal C call, assuming it has a signature
 964             void marshall_code ( StgWord* ptr_to_top_of_stack )
 965          -}
 966          -- resolve static address
 967          get_target_info
 968             = case target of
 969                  DynamicTarget
 970                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
 971                  StaticTarget target
 972                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
 973                        returnBc (True, res)
 974                  CasmTarget _
 975                     -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
 976      in
 977          get_target_info        `thenBc` \ (is_static, static_target_addr) ->
 978      let
 979
 980          -- Get the arg reps, zapping the leading Addr# in the dynamic case
 981          a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
 982                 | is_static = a_reps_pushed_RAW
 983                 | otherwise = if null a_reps_pushed_RAW
 984                               then panic "ByteCodeGen.generateCCall: dyn with no args"
 985                               else tail a_reps_pushed_RAW
 986
 987          -- push the Addr#
 988          (push_Addr, d_after_Addr)
 989             | is_static
 990             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
 991                d_after_args + addr_sizeW)
 992             | otherwise -- is already on the stack
 993             = (nilOL, d_after_args)
 994
 995          -- Push the return placeholder.  For a call returning nothing,
 996          -- this is a VoidRep (tag).
 997          r_sizeW   = getPrimRepSize r_rep
 998          d_after_r = d_after_Addr + r_sizeW
 999          r_lit     = mkDummyLiteral r_rep
1000          push_r    = (if   returns_void
1001                       then nilOL
1002                       else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
1003
1004          -- generate the marshalling code we're going to call
1005          r_offW       = 0
1006          addr_offW    = r_sizeW
1007          arg1_offW    = r_sizeW + addr_sizeW
1008          args_offW    = map (arg1_offW +)
1009                             (init (scanl (+) 0 (map getPrimRepSize a_reps)))
1010      in
1011          ioToBc (mkMarshalCode cconv
1012                     (r_offW, r_rep) addr_offW
1013                     (zip args_offW a_reps))     `thenBc` \ addr_of_marshaller ->
1014          recordMallocBc addr_of_marshaller      `thenBc_`
1015      let
1016          -- Offset of the next stack frame down the stack.  The CCALL
1017          -- instruction needs to describe the chunk of stack containing
1018          -- the ccall args to the GC, so it needs to know how large it
1019          -- is.  See comment in Interpreter.c with the CCALL instruction.
1020          stk_offset   = d_after_r - s
1021
1022          -- do the call
1023          do_call      = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
1024          -- slide and return
1025          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
1026                         `snocOL` RETURN_UBX r_rep
1027      in
1028          --trace (show (arg1_offW, args_offW  ,  (map getPrimRepSize a_reps) )) $
1029          returnBc (
1030          push_args `appOL`
1031          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
1032          )
1033
1034
1035 -- Make a dummy literal, to be used as a placeholder for FFI return
1036 -- values on the stack.
1037 mkDummyLiteral :: PrimRep -> Literal
1038 mkDummyLiteral pr
1039    = case pr of
1040         CharRep   -> MachChar 0
1041         IntRep    -> MachInt 0
1042         WordRep   -> MachWord 0
1043         DoubleRep -> MachDouble 0
1044         FloatRep  -> MachFloat 0
1045         AddrRep   | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0
1046         _         -> moan64 "mkDummyLiteral" (ppr pr)
1047
1048
1049 -- Convert (eg)
1050 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1051 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
1052 --
1053 -- to  Just IntRep
1054 -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
1055 --
1056 -- Alternatively, for call-targets returning nothing, convert
1057 --
1058 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1059 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
1060 --
1061 -- to  Nothing
1062
1063 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
1064 maybe_getCCallReturnRep fn_ty
1065    = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
1066          maybe_r_rep_to_go
1067             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
1068          (r_tycon, r_reps)
1069             = case splitTyConApp_maybe (repType r_ty) of
1070                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
1071                       Nothing -> blargh
1072          ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
1073                 || r_reps == [VoidRep] )
1074               && isUnboxedTupleTyCon r_tycon
1075               && case maybe_r_rep_to_go of
1076                     Nothing    -> True
1077                     Just r_rep -> r_rep /= PtrRep
1078                                   -- if it was, it would be impossible
1079                                   -- to create a valid return value
1080                                   -- placeholder on the stack
1081          blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1082                            (pprType fn_ty)
1083      in
1084      --trace (showSDoc (ppr (a_reps, r_reps))) $
1085      if ok then maybe_r_rep_to_go else blargh
1086
1087 -- Compile code which expects an unboxed Int on the top of stack,
1088 -- (call it i), and pushes the i'th closure in the supplied list
1089 -- as a consequence.
1090 implement_tagToId :: [Name] -> BcM BCInstrList
1091 implement_tagToId names
1092    = ASSERT( notNull names )
1093      getLabelsBc (length names)                 `thenBc` \ labels ->
1094      getLabelBc                                 `thenBc` \ label_fail ->
1095      getLabelBc                                 `thenBc` \ label_exit ->
1096      zip4 labels (tail labels ++ [label_fail])
1097                  [0 ..] names                   `bind`   \ infos ->
1098      map (mkStep label_exit) infos              `bind`   \ steps ->
1099      returnBc (concatOL steps
1100                `appOL`
1101                toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
1102      where
1103         mkStep l_exit (my_label, next_label, n, name_for_n)
1104            = toOL [LABEL my_label,
1105                    TESTEQ_I n next_label,
1106                    PUSH_G name_for_n,
1107                    JMP l_exit]
1108
1109
1110 -- -----------------------------------------------------------------------------
1111 -- pushAtom
1112
1113 -- Push an atom onto the stack, returning suitable code & number of
1114 -- stack words used.
1115 --
1116 -- The env p must map each variable to the highest- numbered stack
1117 -- slot for it.  For example, if the stack has depth 4 and we
1118 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1119 -- the tag in stack[5], the stack will have depth 6, and p must map v
1120 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
1121 -- depth 6 stack has valid words 0 .. 5.
1122
1123 pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
1124
1125 pushAtom d p (AnnApp f (_, AnnType _))
1126    = pushAtom d p (snd f)
1127
1128 pushAtom d p (AnnNote note e)
1129    = pushAtom d p (snd e)
1130
1131 pushAtom d p (AnnLam x e)
1132    | isTyVar x
1133    = pushAtom d p (snd e)
1134
1135 pushAtom d p (AnnVar v)
1136
1137    | idPrimRep v == VoidRep
1138    = returnBc (nilOL, 0)
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_PRIMOP primop), 1)
1145
1146    | otherwise
1147    = let
1148          -- d - d_v                 the number of words between the TOS
1149          --                         and the 1st slot of the object
1150          --
1151          -- d - d_v - 1             the offset from the TOS of the 1st slot
1152          --
1153          -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot
1154          --                         of the object.
1155          --
1156          -- Having found the last slot, we proceed to copy the right number of
1157          -- slots on to the top of the stack.
1158          --
1159          result
1160             = case lookupBCEnv_maybe p v of
1161                  Just d_v -> (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
1162                  Nothing  -> ASSERT(sz == 1) (unitOL (PUSH_G nm), sz)
1163
1164          nm = case isDataConId_maybe v of
1165                  Just c  -> getName c
1166                  Nothing -> getName v
1167
1168          sz   = idSizeW v
1169      in
1170          returnBc result
1171
1172
1173 pushAtom d p (AnnLit lit)
1174    = case lit of
1175         MachLabel fs -> code CodePtrRep
1176         MachWord w   -> code WordRep
1177         MachInt i    -> code IntRep
1178         MachFloat r  -> code FloatRep
1179         MachDouble r -> code DoubleRep
1180         MachChar c   -> code CharRep
1181         MachStr s    -> pushStr s
1182      where
1183         code rep
1184            = let size_host_words = getPrimRepSize rep
1185              in  returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
1186                            size_host_words)
1187
1188         pushStr s
1189            = let getMallocvilleAddr
1190                     = case s of
1191                          FastString _ l ba ->
1192                             -- sigh, a string in the heap is no good to us.
1193                             -- We need a static C pointer, since the type of
1194                             -- a string literal is Addr#.  So, copy the string
1195                             -- into C land and remember the pointer so we can
1196                             -- free it later.
1197                             let n = I# l
1198                             -- CAREFUL!  Chars are 32 bits in ghc 4.09+
1199                             in  ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
1200                                 recordMallocBc ptr         `thenBc_`
1201                                 ioToBc (
1202                                    do memcpy ptr ba (fromIntegral n)
1203                                       pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1204                                       return ptr
1205                                    )
1206                          other -> panic "ByteCodeGen.pushAtom.pushStr"
1207              in
1208                 getMallocvilleAddr `thenBc` \ addr ->
1209                 -- Get the addr on the stack, untaggedly
1210                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
1211
1212 pushAtom d p other
1213    = pprPanic "ByteCodeGen.pushAtom"
1214               (pprCoreExpr (deAnnotate (undefined, other)))
1215
1216 foreign import ccall unsafe "memcpy"
1217  memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1218
1219
1220 -- -----------------------------------------------------------------------------
1221 -- Given a bunch of alts code and their discrs, do the donkey work
1222 -- of making a multiway branch using a switch tree.
1223 -- What a load of hassle!
1224
1225 mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
1226                                 -- a hint; generates better code
1227                                 -- Nothing is always safe
1228               -> [(Discr, BCInstrList)]
1229               -> BcM BCInstrList
1230 mkMultiBranch maybe_ncons raw_ways
1231    = let d_way     = filter (isNoDiscr.fst) raw_ways
1232          notd_ways = naturalMergeSortLe
1233                         (\w1 w2 -> leAlt (fst w1) (fst w2))
1234                         (filter (not.isNoDiscr.fst) raw_ways)
1235
1236          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1237          mkTree [] range_lo range_hi = returnBc the_default
1238
1239          mkTree [val] range_lo range_hi
1240             | range_lo `eqAlt` range_hi
1241             = returnBc (snd val)
1242             | otherwise
1243             = getLabelBc                                `thenBc` \ label_neq ->
1244               returnBc (mkTestEQ (fst val) label_neq
1245                         `consOL` (snd val
1246                         `appOL`   unitOL (LABEL label_neq)
1247                         `appOL`   the_default))
1248
1249          mkTree vals range_lo range_hi
1250             = let n = length vals `div` 2
1251                   vals_lo = take n vals
1252                   vals_hi = drop n vals
1253                   v_mid = fst (head vals_hi)
1254               in
1255               getLabelBc                                `thenBc` \ label_geq ->
1256               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
1257               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
1258               returnBc (mkTestLT v_mid label_geq
1259                         `consOL` (code_lo
1260                         `appOL`   unitOL (LABEL label_geq)
1261                         `appOL`   code_hi))
1262
1263          the_default
1264             = case d_way of [] -> unitOL CASEFAIL
1265                             [(_, def)] -> def
1266
1267          -- None of these will be needed if there are no non-default alts
1268          (mkTestLT, mkTestEQ, init_lo, init_hi)
1269             | null notd_ways
1270             = panic "mkMultiBranch: awesome foursome"
1271             | otherwise
1272             = case fst (head notd_ways) of {
1273               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
1274                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
1275                             DiscrI minBound,
1276                             DiscrI maxBound );
1277               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
1278                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
1279                             DiscrF minF,
1280                             DiscrF maxF );
1281               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
1282                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
1283                             DiscrD minD,
1284                             DiscrD maxD );
1285               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
1286                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1287                             DiscrP algMinBound,
1288                             DiscrP algMaxBound )
1289               }
1290
1291          (algMinBound, algMaxBound)
1292             = case maybe_ncons of
1293                  Just n  -> (0, n - 1)
1294                  Nothing -> (minBound, maxBound)
1295
1296          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1297          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1298          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1299          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1300          NoDiscr     `eqAlt` NoDiscr     = True
1301          _           `eqAlt` _           = False
1302
1303          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1304          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1305          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1306          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1307          NoDiscr     `leAlt` NoDiscr     = True
1308          _           `leAlt` _           = False
1309
1310          isNoDiscr NoDiscr = True
1311          isNoDiscr _       = False
1312
1313          dec (DiscrI i) = DiscrI (i-1)
1314          dec (DiscrP i) = DiscrP (i-1)
1315          dec other      = other         -- not really right, but if you
1316                 -- do cases on floating values, you'll get what you deserve
1317
1318          -- same snotty comment applies to the following
1319          minF, maxF :: Float
1320          minD, maxD :: Double
1321          minF = -1.0e37
1322          maxF =  1.0e37
1323          minD = -1.0e308
1324          maxD =  1.0e308
1325      in
1326          mkTree notd_ways init_lo init_hi
1327
1328
1329 -- -----------------------------------------------------------------------------
1330 -- Supporting junk for the compilation schemes
1331
1332 -- Describes case alts
1333 data Discr
1334    = DiscrI Int
1335    | DiscrF Float
1336    | DiscrD Double
1337    | DiscrP Int
1338    | NoDiscr
1339
1340 instance Outputable Discr where
1341    ppr (DiscrI i) = int i
1342    ppr (DiscrF f) = text (show f)
1343    ppr (DiscrD d) = text (show d)
1344    ppr (DiscrP i) = int i
1345    ppr NoDiscr    = text "DEF"
1346
1347
1348 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
1349 lookupBCEnv_maybe = lookupFM
1350
1351 idSizeW :: Id -> Int
1352 idSizeW id = getPrimRepSize (typePrimRep (idType id))
1353
1354 unboxedTupleException :: a
1355 unboxedTupleException
1356    = throwDyn
1357         (Panic
1358            ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
1359             "\tto foreign import/export decls in source.  Workaround:\n" ++
1360             "\tcompile this module to a .o file, then restart session."))
1361
1362
1363 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1364 bind x f    = f x
1365
1366 isTypeAtom :: AnnExpr' id ann -> Bool
1367 isTypeAtom (AnnType _) = True
1368 isTypeAtom _           = False
1369
1370 isVoidRepAtom :: AnnExpr' id ann -> Bool
1371 isVoidRepAtom (AnnVar v)        = typePrimRep (idType v) == VoidRep
1372 isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
1373 isVoidRepAtom _                 = False
1374
1375 atomRep :: AnnExpr' Id ann -> PrimRep
1376 atomRep (AnnVar v)    = typePrimRep (idType v)
1377 atomRep (AnnLit l)    = literalPrimRep l
1378 atomRep (AnnNote n b) = atomRep (snd b)
1379 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
1380 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
1381 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
1382
1383 -- Let szsw be the sizes in words of some items pushed onto the stack,
1384 -- which has initial depth d'.  Return the values which the stack environment
1385 -- should map these items to.
1386 mkStackOffsets :: Int -> [Int] -> [Int]
1387 mkStackOffsets original_depth szsw
1388    = map (subtract 1) (tail (scanl (+) original_depth szsw))
1389
1390 -- -----------------------------------------------------------------------------
1391 -- The bytecode generator's monad
1392
1393 data BcM_State
1394    = BcM_State {
1395         nextlabel :: Int,               -- for generating local labels
1396         malloced  :: [Ptr ()] }         -- ptrs malloced for current BCO
1397                                         -- Should be free()d when it is GCd
1398
1399 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1400
1401 ioToBc :: IO a -> BcM a
1402 ioToBc io = BcM $ \st -> do
1403   x <- io
1404   return (st, x)
1405
1406 runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
1407 runBc st0 (BcM m) = do
1408   (st1, res) <- m st0
1409   return (st1, res)
1410
1411 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1412 thenBc (BcM expr) cont = BcM $ \st0 -> do
1413   (st1, q) <- expr st0
1414   let BcM k = cont q
1415   (st2, r) <- k st1
1416   return (st2, r)
1417
1418 thenBc_ :: BcM a -> BcM b -> BcM b
1419 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1420   (st1, q) <- expr st0
1421   (st2, r) <- cont st1
1422   return (st2, r)
1423
1424 returnBc :: a -> BcM a
1425 returnBc result = BcM $ \st -> (return (st, result))
1426
1427 instance Monad BcM where
1428   (>>=) = thenBc
1429   (>>)  = thenBc_
1430   return = returnBc
1431
1432 emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1433 emitBc bco
1434   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
1435
1436 recordMallocBc :: Ptr a -> BcM ()
1437 recordMallocBc a
1438   = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
1439
1440 getLabelBc :: BcM Int
1441 getLabelBc
1442   = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
1443
1444 getLabelsBc :: Int -> BcM [Int]
1445 getLabelsBc n
1446   = BcM $ \st -> let ctr = nextlabel st
1447                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1448 \end{code}