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