ghc/compiler/ghci/ByteCodeGen.lhs

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