ghc/compiler/ghci/ByteCodeGen.lhs

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