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