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