ByteCodeGen.lhs 45.3 KB
Newer Older
1 2 3 4 5 6
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeGen]{Generate bytecode from Core}

\begin{code}
7 8
module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
		     filterNameMap,
9
                     byteCodeGen, coreExprToBCOs
10
		   ) where
11 12 13 14

#include "HsVersions.h"

import Outputable
15
import Name		( Name, getName )
16
import Id		( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
17 18
			  idPrimRep, mkSysLocal, idName, isFCallId_maybe )
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 28
import PrimOp		( PrimOp(..) )
import CStrings		( CLabelString )
29
import CoreFVs		( freeVars )
30
import Type		( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys )
31 32
import DataCon		( dataConTag, fIRST_TAG, dataConTyCon, 
                          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 42
import CmdLineOpts	( DynFlags, DynFlag(..) )
import ErrUtils		( showPass, dumpIfSet_dyn )
43
import Unique		( mkPseudoUnique3 )
44
import FastString	( FastString(..) )
45
import Panic		( GhcException(..) )
46
import PprType		( pprType )
47
import ByteCodeInstr	( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
48 49
import ByteCodeItbls	( ItblEnv, mkITbls )
import ByteCodeLink	( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
50
			  ClosureEnv, HValue, filterNameMap,
51
			  iNTERP_STACK_CHECK_THRESH )
52 53
import ByteCodeFFI	( taggedSizeW, untaggedSizeW, mkMarshalCode )
import Linker		( lookupSymbol )
54

55
import List		( intersperse, sortBy, zip4 )
56
import Foreign		( Ptr(..), mallocBytes )
57
import Addr		( Addr(..), nullAddr, addrToInt, writeCharOffAddr )
58
import CTypes		( CInt )
59
import Exception	( throwDyn )
60

61
import PrelBase		( Int(..) )
62 63
import PrelGHC		( ByteArray# )
import IOExts		( unsafePerformIO )
64
import PrelIOBase	( IO(..) )
65

66 67
\end{code}

68 69 70 71 72
%************************************************************************
%*									*
\subsection{Functions visible from outside this module.}
%*									*
%************************************************************************
73 74

\begin{code}
75

76 77 78 79 80 81 82 83 84 85 86 87 88
byteCodeGen :: DynFlags
            -> [CoreBind] 
            -> [TyCon] -> [Class]
            -> IO ([UnlinkedBCO], ItblEnv)
byteCodeGen dflags binds local_tycons local_classes
   = do showPass dflags "ByteCodeGen"
        let tycs = local_tycons ++ map classTyCon local_classes
        itblenv <- mkITbls tycs

        let flatBinds = concatMap getBind binds
            getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
            getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
            final_state = runBc (BcM_State [] 0) 
89 90
                                (mapBc (schemeR True) flatBinds
					`thenBc_` returnBc ())
91 92 93 94 95 96 97 98 99
            (BcM_State proto_bcos final_ctr) = final_state

        dumpIfSet_dyn dflags Opt_D_dump_BCOs
           "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))

        bcos <- mapM assembleBCO proto_bcos

        return (bcos, itblenv)
        
100

101 102 103 104 105 106 107
-- Returns: (the root BCO for this expression, 
--           a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
	       -> CoreExpr
               -> IO UnlinkedBCOExpr
coreExprToBCOs dflags expr
 = do showPass dflags "ByteCodeGen"
108 109 110

      -- create a totally bogus name for the top-level BCO; this
      -- should be harmless, since it's never used for anything
111 112 113
      let invented_id   = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) 
				     (panic "invented_id's type")
      let invented_name = idName invented_id
114 115

      let (BcM_State all_proto_bcos final_ctr) 
116
             = runBc (BcM_State [] 0) 
117
                     (schemeR True (invented_id, freeVars expr))
118
      dumpIfSet_dyn dflags Opt_D_dump_BCOs
119 120 121 122 123 124 125 126 127 128 129 130
         "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))

      let root_proto_bco 
             = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
                  [root_bco] -> root_bco
          auxiliary_proto_bcos
             = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos

      auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
      root_bco <- assembleBCO root_proto_bco

      return (root_bco, auxiliary_bcos)
131
\end{code}
132

133 134 135 136 137
%************************************************************************
%*									*
\subsection{Compilation schema for the bytecode generator.}
%*									*
%************************************************************************
138

139 140 141 142
\begin{code}

type BCInstrList = OrdList BCInstr

143 144 145 146 147 148
type Sequel = Int	-- back off to this depth before ENTER

-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
type BCEnv = FiniteMap Id Int	-- To find vars on the stack

149 150 151 152 153 154 155 156
ppBCEnv :: BCEnv -> SDoc
ppBCEnv p
   = text "begin-env"
     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
     $$ text "end-env"
     where
        pp_one (var, offset) = int offset <> colon <+> ppr var
        cmp_snd x y = compare (snd x) (snd y)
157

158 159 160
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO nm instrs_ordlist origin
161
   = ProtoBCO nm maybe_with_stack_check origin
162
     where
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
        -- Overestimate the stack usage (in words) of this BCO,
        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
        -- stack check.  (The interpreter always does a stack check
        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
        -- BCO anyway, so we only need to add an explicit on in the
        -- (hopefully rare) cases when the (overestimated) stack use
        -- exceeds iNTERP_STACK_CHECK_THRESH.
        maybe_with_stack_check
           | stack_overest >= 65535
           = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
                      (int stack_overest)
           | stack_overest >= iNTERP_STACK_CHECK_THRESH
           = (STKCHECK stack_overest) : peep_d
           | otherwise
           = peep_d	-- the supposedly common case
             
        stack_overest = sum (map bciStackUse peep_d)
                        + 10 {- just to be really really sure -}


        -- Merge local pushes
        peep_d = peep (fromOL instrs_ordlist)

186 187 188
        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
        peep (PUSH_L off1 : PUSH_L off2 : rest)
189
           = PUSH_LL off1 (off2-1) : peep rest
190 191 192 193 194
        peep (i:rest)
           = i : peep rest
        peep []
           = []

195 196 197 198

-- Compile code for the right hand side of a let binding.
-- Park the resulting BCO in the monad.  Also requires the
-- variable to which this value was bound, so as to give the
199 200 201 202
-- resulting BCO a name.  Bool indicates top-levelness.

schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM ()
schemeR is_top (nm, rhs) 
203
{-
204 205 206 207 208 209 210
   | trace (showSDoc (
              (char ' '
               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
211
-}
212
   | otherwise
213
   = schemeR_wrk is_top rhs nm (collect [] rhs)
214

215

216 217
collect xs (_, AnnNote note e)
   = collect xs e
218 219 220 221
collect xs (_, AnnLam x e) 
   = collect (if isTyVar x then xs else (x:xs)) e
collect xs not_lambda
   = (reverse xs, not_lambda)
222

223 224
schemeR_wrk is_top original_body nm (args, body)
   | Just dcon <- maybe_toplevel_null_con_rhs
225
   = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
226 227
     emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
                                     (Right original_body))
228
     --)
229 230

   | otherwise
231
   = let fvs       = filter (not.isTyVar) (varSetElems (fst original_body))
232
         all_args  = reverse args ++ fvs
233
         szsw_args = map taggedIdSizeW all_args
234
         szw_args  = sum szsw_args
235
         p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
236
         argcheck  = unitOL (ARGCHECK szw_args)
237 238
     in
     schemeE szw_args 0 p_init body 		`thenBc` \ body_code ->
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255
     emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) 
                                     (Right original_body))

     where
        maybe_toplevel_null_con_rhs
           | is_top && null args
           = case snd body of
                AnnVar v_wrk 
                   -> case isDataConId_maybe v_wrk of
                         Nothing -> Nothing
                         Just dc_wrk |  nm == dataConWrapId dc_wrk
                                     -> Just dc_wrk
                                     |  otherwise 
                                     -> Nothing
                other -> Nothing
           | otherwise
           = Nothing
256

257 258 259 260 261 262
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'.  Return the values which the stack environment
-- should map these items to.
mkStackOffsets :: Int -> [Int] -> [Int]
mkStackOffsets original_depth szsw
   = map (subtract 1) (tail (scanl (+) original_depth szsw))
263 264 265 266 267 268

-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList

-- Delegate tail-calls to schemeT.
269
schemeE d s p e@(fvs, AnnApp f a) 
270
   = schemeT d s p (fvs, AnnApp f a)
271

272
schemeE d s p e@(fvs, AnnVar v)
273
   | isFollowableRep v_rep
274 275
   =  -- Ptr-ish thing; push it in the normal way
     schemeT d s p (fvs, AnnVar v)
276

277 278 279 280
   | otherwise
   = -- returning an unboxed value.  Heave it on the stack, SLIDE, and RETURN.
     let (push, szw) = pushAtom True d p (AnnVar v)
     in  returnBc (push 			-- value onto stack
281
                   `appOL`  mkSLIDE szw (d-s) 	-- clear to sequel
282 283 284
                   `snocOL` RETURN v_rep)	-- go
   where
      v_rep = typePrimRep (idType v)
285 286 287

schemeE d s p (fvs, AnnLit literal)
   = let (push, szw) = pushAtom True d p (AnnLit literal)
288
         l_rep = literalPrimRep literal
289
     in  returnBc (push 			-- value onto stack
290 291
                   `appOL`  mkSLIDE szw (d-s) 	-- clear to sequel
                   `snocOL` RETURN l_rep)	-- go
292 293 294 295

schemeE d s p (fvs, AnnLet binds b)
   = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
296 297
         n     = length xs
         fvss  = map (filter (not.isTyVar).varSetElems.fst) rhss
298 299

         -- Sizes of tagged free vars, + 1 for the fn
300
         sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
301 302 303 304 305 306

         -- This p', d' defn is safe because all the items being pushed
         -- are ptrs, so all have size 1.  d' and p' reflect the stack
         -- after the closures have been allocated in the heap (but not
         -- filled in), and pointers to them parked on the stack.
         p'    = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
307
         d'    = d + n
308

309 310 311 312 313
         infos = zipE4 fvss sizes xs [n, n-1 .. 1]
         zipE  = zipEqual "schemeE"
         zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))

         -- ToDo: don't build thunks for things with no free variables
314
         buildThunk dd ([], size, id, off)
315
            = PUSH_G (Left (getName id))
316 317 318 319 320 321 322 323
              `consOL` unitOL (MKAP (off+size-1) size)
         buildThunk dd ((fv:fvs), size, id, off)
            = case pushAtom True dd p' (AnnVar fv) of
                 (push_code, pushed_szw)
                    -> push_code `appOL`
                       buildThunk (dd+pushed_szw) (fvs, size, id, off)

         thunkCode = concatOL (map (buildThunk d') infos)
324 325
         allocCode = toOL (map ALLOC sizes)
     in
326
     schemeE d' s p' b   				`thenBc`  \ bodyCode ->
327
     mapBc (schemeR False) (zip xs rhss)		`thenBc_`
328 329 330
     returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)


331 332 333 334 335 336 337



schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr 
                                 [(DEFAULT, [], (fvs_rhs, rhs))])

   | let isFunType var_type 
338 339 340 341
            = case splitTyConApp_maybe var_type of
                 Just (tycon,_) | isFunTyCon tycon -> True
                 _ -> False
         ty_bndr = repType (idType bndr)
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363
     in isFunType ty_bndr || isTyVarTy ty_bndr

   -- Nasty hack; treat
   --     case scrut::suspect of bndr { DEFAULT -> rhs }
   --     as 
   --     let bndr = scrut in rhs
   --     when suspect is polymorphic or arrowtyped
   -- So the required strictness properties are not observed.
   -- At some point, must fix this properly.
   = let new_expr
            = (fvs_case, 
               AnnLet 
                  (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
              )

     in  trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
                "   Possibly due to strict polymorphic/functional constructor args.\n" ++
                "   Your program may leak space unexpectedly.\n")
                -- ++ showSDoc (char ' ' $$ pprCoreExpr (deAnnotate new_expr) $$ char ' '))
         (schemeE d s p new_expr)


364

365 366 367 368
{- Convert case .... of (# VoidRep'd-thing, a #) -> ...
      as
   case .... of a -> ...
   Use  a  as the name of the binder too.
369 370 371 372

   Also    case .... of (# a #) -> ...
      to
   case .... of a -> ...
373 374 375
-}
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
   | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
376
   = --trace "automagic mashing of case alts (# VoidRep, a #)" (
377
     schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
378 379 380 381 382 383 384
     --)

schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
   | isUnboxedTupleCon dc
   = --trace "automagic mashing of case alts (# a #)" (
     schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)])
     --)
385 386 387

schemeE d s p (fvs, AnnCase scrut bndr alts)
   = let
388 389 390 391 392 393 394 395
        -- Top of stack is the return itbl, as usual.
        -- underneath it is the pointer to the alt_code BCO.
        -- When an alt is entered, it assumes the returned value is
        -- on top of the itbl.
        ret_frame_sizeW = 2

        -- Env and depth in which to compile the alts, not including
        -- any vars bound by the alts themselves
396
        d' = d + ret_frame_sizeW + taggedIdSizeW bndr
397
        p' = addToFM p bndr (d' - 1)
398

399
        scrut_primrep = typePrimRep (idType bndr)
400
        isAlgCase
401 402 403 404 405 406 407 408 409
           | scrut_primrep == PtrRep
           = True
           | scrut_primrep `elem`
             [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep,
              VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep,
              Word8Rep, Word16Rep, Word32Rep, Word64Rep]
           = False
           | otherwise
           =  pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep)
410 411

        -- given an alt, return a discr and code for it.
412
        codeAlt alt@(discr, binds_f, rhs)
413
           | isAlgCase 
414
           = let (unpack_code, d_after_unpack, p_after_unpack)
415
                    = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
416 417 418
             in  schemeE d_after_unpack s p_after_unpack rhs
					`thenBc` \ rhs_code -> 
                 returnBc (my_discr alt, unpack_code `appOL` rhs_code)
419
           | otherwise 
420
           = ASSERT(null binds_f) 
421 422
             schemeE d' s p' rhs	`thenBc` \ rhs_code ->
             returnBc (my_discr alt, rhs_code)
423

424 425 426 427 428 429
        my_discr (DEFAULT, binds, rhs) = NoDiscr
        my_discr (DataAlt dc, binds, rhs) 
           | isUnboxedTupleCon dc
           = unboxedTupleException
           | otherwise
           = DiscrP (dataConTag dc - fIRST_TAG)
430
        my_discr (LitAlt l, binds, rhs)
431
           = case l of MachInt i     -> DiscrI (fromInteger i)
432 433
                       MachFloat r   -> DiscrF (fromRational r)
                       MachDouble r  -> DiscrD (fromRational r)
434 435
                       MachChar i    -> DiscrI i
                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
436

437 438 439 440 441 442 443
        maybe_ncons 
           | not isAlgCase = Nothing
           | otherwise 
           = case [dc | (DataAlt dc, _, _) <- alts] of
                []     -> Nothing
                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))

444
     in 
445
     mapBc codeAlt alts 				`thenBc` \ alt_stuff ->
446
     mkMultiBranch maybe_ncons alt_stuff		`thenBc` \ alt_final ->
447
     let 
448
         alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
449
         alt_bco_name = getName bndr
450
         alt_bco      = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
451 452 453 454 455
     in
     schemeE (d + ret_frame_sizeW) 
             (d + ret_frame_sizeW) p scrut		`thenBc` \ scrut_code ->

     emitBc alt_bco 					`thenBc_`
456
     returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
457 458 459 460 461 462 463 464


schemeE d s p (fvs, AnnNote note body)
   = schemeE d s p body

schemeE d s p other
   = pprPanic "ByteCodeGen.schemeE: unhandled case" 
               (pprCoreExpr (deAnnotate other))
465 466


467 468 469 470 471 472 473 474
-- Compile code to do a tail call.  Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-- and enter.  Four cases:
--
-- 0.  (Nasty hack).
--     An application "PrelGHC.tagToEnum# <type> unboxed-int".
--     The int will be on the stack.  Generate a code sequence
--     to convert it to the relevant constructor, SLIDE and ENTER.
475 476 477
--
-- 1.  A nullary constructor.  Push its closure on the stack 
--     and SLIDE and RETURN.
478
--
479 480
-- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
--     it simply as  b  -- since the representations are identical
481 482
--     (the VoidRep takes up zero stack space).  Also, spot
--     (# b #) and treat it as  b.
483 484
--
-- 3.  Application of a non-nullary constructor, by defn saturated.
485 486 487
--     Split the args into ptrs and non-ptrs, and push the nonptrs, 
--     then the ptrs, and then do PACK and RETURN.
--
488
-- 4.  Otherwise, it must be a function call.  Push the args
489
--     right to left, SLIDE and ENTER.
490 491

schemeT :: Int 		-- Stack depth
492 493
        -> Sequel 	-- Sequel depth
        -> BCEnv 	-- stack env
494
        -> AnnExpr Id VarSet 
495
        -> BcM BCInstrList
496

497
schemeT d s p app
498 499 500
--   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
--   = panic "schemeT ?!?!"

501 502 503
--   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
--   = error "?!?!" 

504 505 506 507 508 509 510 511
   -- Handle case 0
   | Just (arg, constr_names) <- maybe_is_tagToEnum_call
   = pushAtom True d p arg 		`bind` \ (push, arg_words) ->
     implement_tagToId constr_names	`thenBc` \ tagToId_sequence ->
     returnBc (push `appOL`  tagToId_sequence            
                    `appOL`  mkSLIDE 1 (d+arg_words-s)
                    `snocOL` ENTER)

512 513
   -- Handle case 1
   | is_con_call && null args_r_to_l
514 515 516 517
   = returnBc (
        (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
        `snocOL` ENTER
     )
518

519 520 521 522
   -- Handle case 2
   | let isVoidRepAtom (_, AnnVar v)    = VoidRep == typePrimRep (idType v)
         isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
     in  is_con_call && isUnboxedTupleCon con 
523 524 525 526 527 528
         && ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l)))
              || (length args_r_to_l == 1)
            )
   = --trace (if length args_r_to_l == 1
     --       then "schemeT: unboxed singleton"
     --       else "schemeT: unboxed pair with Void first component") (
529
     schemeT d s p (head args_r_to_l)
530
     --)
531 532

   -- Cases 3 and 4
533
   | otherwise
534
   = if   is_con_call && isUnboxedTupleCon con
535
     then returnBc unboxedTupleException
536
     else code `seq` returnBc code
537

538 539 540 541
   where
      -- Detect and extract relevant info for the tagToEnum kludge.
      maybe_is_tagToEnum_call
         = let extract_constr_Names ty
542
                  = case splitTyConApp_maybe (repType ty) of
543 544
                       (Just (tyc, [])) |  isDataTyCon tyc
                                        -> map getName (tyConDataCons tyc)
545
                       other            -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
546 547 548 549
           in 
           case app of
              (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
                 -> case isPrimOpId_maybe v of
550 551
                       Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
		       other		-> Nothing
552 553 554 555 556 557 558
              other -> Nothing

      -- Extract the args (R->L) and fn
      (args_r_to_l_raw, fn) = chomp app
      chomp expr
         = case snd expr of
              AnnVar v    -> ([], v)
559
              AnnApp f a  -> case chomp f of (az, f) -> (a:az, f)
560 561 562
              AnnNote n e -> chomp e
              other       -> pprPanic "schemeT" 
                                (ppr (deAnnotate (panic "schemeT.chomp", other)))
563
         
564
      args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
565 566 567 568 569 570 571 572 573 574 575 576 577
      isTypeAtom (AnnType _) = True
      isTypeAtom _           = False

      -- decide if this is a constructor call, and rearrange
      -- args appropriately.
      maybe_dcon  = isDataConId_maybe fn
      is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
      (Just con)  = maybe_dcon

      args_final_r_to_l
         | not is_con_call
         = args_r_to_l
         | otherwise
578
         = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
579 580 581
           where isPtr = isFollowableRep . atomRep

      -- make code to push the args and then do the SLIDE-ENTER thing
582
      code          = do_pushery d (map snd args_final_r_to_l)
583
      tag_when_push = not is_con_call
584
      narg_words    = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
585 586 587 588 589 590
      get_arg_szw   = if tag_when_push then taggedSizeW else untaggedSizeW

      do_pushery d (arg:args)
         = let (push, arg_words) = pushAtom tag_when_push d p arg
           in  push `appOL` do_pushery (d+arg_words) args
      do_pushery d []
591 592

         -- CCALL !
593 594
         | Just (CCall ccall_spec) <- isFCallId_maybe fn
         = generateCCall d s fn ccall_spec
595 596

         | otherwise
597 598 599 600 601 602 603 604 605
         = case maybe_dcon of
              Just con -> PACK con narg_words `consOL` (
                          mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
              Nothing
                 -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
                    in  push 
                        `appOL` mkSLIDE (narg_words+arg_words) 
                                        (d - s - narg_words)
                        `snocOL` ENTER
606

607

608

609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730
{- Given that the args for a CCall have been pushed onto the Haskell
   stack, generate the marshalling (machine) code for the ccall, and
   create bytecodes to call that and then return in the right way.  
-}
generateCCall :: Int -> Sequel 		-- stack and sequel depths
              -> Id 			-- of target, for type info
              -> CCallSpec		-- where to call
              -> BCInstrList

generateCCall d s fn ccall_spec@(CCallSpec target cconv safety)
   = let -- Get the arg and result reps.
         (a_reps_RAW, maybe_r_rep) = getCCallPrimReps (idType fn)               
         (returns_void, r_rep)
            = case maybe_r_rep of
                 Nothing -> (True,  VoidRep)
                 Just rr -> (False, rr) 
         {-
         Because the Haskell stack grows down, the a_reps refer to 
         lowest to highest addresses in that order.  The args for the call
         are on the stack.  Now push an unboxed, tagged Addr# indicating
         the C function to call.  Then push a dummy placeholder for the 
         result.  Finally, emit a CCALL insn with an offset pointing to the 
         Addr# just pushed, and a literal field holding the mallocville
         address of the piece of marshalling code we generate.
         So, just prior to the CCALL insn, the stack looks like this 
         (growing down, as usual):
                 
            <arg_n>
            ...
            <arg_1>
            Addr# address_of_C_fn
            <placeholder-for-result#> (must be an unboxed type)

         The interpreter then calls the marshall code mentioned
         in the CCALL insn, passing it (& <placeholder-for-result#>), 
         that is, the addr of the topmost word in the stack.
         When this returns, the placeholder will have been
         filled in.  The placeholder is slid down to the sequel
         depth, and we RETURN.

         This arrangement makes it simple to do f-i-dynamic since the Addr#
         value is the first arg anyway.  It also has the virtue that the
         stack is GC-understandable at all times.

         The marshalling code is generated specifically for this
         call site, and so knows exactly the (Haskell) stack
         offsets of the args, fn address and placeholder.  It
         copies the args to the C stack, calls the stacked addr,
         and parks the result back in the placeholder.  The interpreter
         calls it as a normal C call, assuming it has a signature
            void marshall_code ( StgWord* ptr_to_top_of_stack )
         -}
         -- resolve static address
         (is_static, static_target_addr)
            = case target of
                 DynamicTarget
                    -> (False, panic "ByteCodeGen.generateCCall(dyn)")
                 StaticTarget target
                    -> let unpacked = _UNPK_ target
                       in  case unsafePerformIO (lookupSymbol unpacked) of
                              Just aa -> case aa of Ptr a# -> (True, A# a#)
                              Nothing -> invalid
                 CasmTarget _
                    -> invalid
                 where
                    invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable " 
                                        ++ "symbol or otherwise invalid target")
                                       (ppr ccall_spec)

         -- Get the arg reps, zapping the leading Addr# in the dynamic case
         a_reps | is_static = a_reps_RAW
                | otherwise = if null a_reps_RAW 
                              then panic "ByteCodeGen.generateCCall: dyn with no args"
                              else tail a_reps_RAW

         -- push the Addr#
         addr_usizeW = untaggedSizeW AddrRep
         addr_tsizeW = taggedSizeW AddrRep
         (push_Addr, d_after_Addr)
            | is_static
            = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
                     PUSH_TAG addr_usizeW],
               d + addr_tsizeW)
            | otherwise	-- is already on the stack
            = (nilOL, d)

         -- Push the return placeholder.  For a call returning nothing,
         -- this is a VoidRep (tag).
         r_usizeW  = untaggedSizeW r_rep
         r_tsizeW  = taggedSizeW r_rep
         d_after_r = d_after_Addr + r_tsizeW
         r_lit     = mkDummyLiteral r_rep
         push_r    = (if   returns_void 
                      then nilOL 
                      else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
                      `appOL` 
                      unitOL (PUSH_TAG r_usizeW)

         -- do the call
         do_call      = unitOL (CCALL addr_of_marshaller)
         -- slide and return
         wrapup       = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
                        `snocOL` RETURN r_rep

         -- generate the marshalling code we're going to call
         r_offW       = 0 
         addr_offW    = r_tsizeW
         arg1_offW    = r_tsizeW + addr_tsizeW
         args_offW    = map (arg1_offW +) 
                            (init (scanl (+) 0 (map taggedSizeW a_reps)))
         addr_of_marshaller
                      = mkMarshalCode cconv
                                      (r_offW, r_rep) addr_offW
                                      (zip args_offW a_reps)
     in
         --trace (show (arg1_offW, args_offW  ,  (map taggedSizeW a_reps) )) (
         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
         --)


-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
731 732 733
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
   = case pr of
734 735 736 737 738
        IntRep    -> MachInt 0
        DoubleRep -> MachDouble 0
        FloatRep  -> MachFloat 0
        AddrRep   | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
        _         -> pprPanic "mkDummyLiteral" (ppr pr)
739 740 741 742 743 744


-- Convert (eg) 
--       PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
--                    -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
--
745
-- to [IntRep] -> Just IntRep
746 747
-- and check that the last arg is VoidRep'd and that an unboxed pair is
-- returned wherein the first arg is VoidRep'd.
748 749 750 751 752 753 754
--
-- Alternatively, for call-targets returning nothing, convert
--
--       PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
--                    -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
--
-- to [IntRep] -> Nothing
755

756
getCCallPrimReps :: Type -> ([PrimRep], Maybe PrimRep)
757 758 759
getCCallPrimReps fn_ty
   = let (a_tys, r_ty) = splitRepFunTys fn_ty
         a_reps        = map typePrimRep a_tys
760 761 762
         a_reps_to_go  = init a_reps
         maybe_r_rep_to_go  
            = if length r_reps == 1 then Nothing else Just (r_reps !! 1)
763 764 765 766
         (r_tycon, r_reps) 
            = case splitTyConApp_maybe (repType r_ty) of
                      (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
                      Nothing -> blargh
767

768
         ok = length a_reps >= 1 && VoidRep == last a_reps
769 770
               && ( (length r_reps == 2 && VoidRep == head r_reps)
                    || r_reps == [VoidRep] )
771
               && isUnboxedTupleTyCon r_tycon
772 773 774 775 776 777
               && case maybe_r_rep_to_go of
                     Nothing    -> True
                     Just r_rep -> r_rep /= PtrRep
                                   -- if it was, it would be impossible 
                                   -- to create a valid return value 
                                   -- placeholder on the stack
778 779 780 781
         blargh       = pprPanic "getCCallPrimReps: can't handle:" 
                                 (pprType fn_ty)
     in 
     --trace (showSDoc (ppr (a_reps, r_reps))) (
782
     if ok then (a_reps_to_go, maybe_r_rep_to_go) else blargh
783 784
     --)

785 786 787 788
atomRep (AnnVar v)    = typePrimRep (idType v)
atomRep (AnnLit l)    = literalPrimRep l
atomRep (AnnNote n b) = atomRep (snd b)
atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
789
atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
790
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
791

792

793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815
-- Compile code which expects an unboxed Int on the top of stack,
-- (call it i), and pushes the i'th closure in the supplied list 
-- as a consequence.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
   = ASSERT(not (null names))
     getLabelsBc (length names)			`thenBc` \ labels ->
     getLabelBc					`thenBc` \ label_fail ->
     getLabelBc 				`thenBc` \ label_exit ->
     zip4 labels (tail labels ++ [label_fail])
                 [0 ..] names			`bind`   \ infos ->
     map (mkStep label_exit) infos		`bind`   \ steps ->
     returnBc (concatOL steps
               `appOL` 
               toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
     where
        mkStep l_exit (my_label, next_label, n, name_for_n)
           = toOL [LABEL my_label, 
                   TESTEQ_I n next_label, 
                   PUSH_G (Left name_for_n), 
                   JMP l_exit]


816 817 818 819
-- Make code to unpack the top-of-stack constructor onto the stack, 
-- adding tags for the unboxed bits.  Takes the PrimReps of the 
-- constructor's arguments.  off_h and off_s are travelling offsets
-- along the constructor and the stack.
820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849
--
-- Supposing a constructor in the heap has layout
--
--      Itbl p_1 ... p_i np_1 ... np_j
--
-- then we add to the stack, shown growing down, the following:
--
--    (previous stack)
--         p_i
--         ...
--         p_1
--         np_j
--         tag_for(np_j)
--         ..
--         np_1
--         tag_for(np_1)
--
-- so that in the common case (ptrs only) a single UNPACK instr can
-- copy all the payload of the constr onto the stack with no further ado.

mkUnpackCode :: [Id] 	-- constr args
             -> Int 	-- depth before unpack
             -> BCEnv 	-- env before unpack
             -> (BCInstrList, Int, BCEnv)
mkUnpackCode vars d p
   = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
     --       ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
     --       ++ "\n") (
     (code_p `appOL` code_np, d', p')
     --)
850
     where
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874
        -- vars with reps
        vreps = [(var, typePrimRep (idType var)) | var <- vars]

        -- ptrs and nonptrs, forward
        vreps_p  = filter (isFollowableRep.snd) vreps
        vreps_np = filter (not.isFollowableRep.snd) vreps

        -- the order in which we will augment the environment
        vreps_env = reverse vreps_p ++ reverse vreps_np

        -- new env and depth
        vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
        p' = addListToFM p (zip (map fst vreps_env) 
                                (mkStackOffsets d vreps_env_tszsw))
        d' = d + sum vreps_env_tszsw

        -- code to unpack the ptrs
        ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
        code_p | null vreps_p = nilOL
               | otherwise    = unitOL (UNPACK ptrs_szw)

        -- code to unpack the nonptrs
        vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
        code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
875 876
        do_nptrs off_h off_s [] = nilOL
        do_nptrs off_h off_s (npr:nprs)
877 878 879 880
           | npr `elem` [IntRep, FloatRep, DoubleRep, CharRep, AddrRep]
           = approved
           | otherwise
           = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
881
             where
882 883
                approved = UPK_TAG usizeW (off_h-usizeW) off_s   `consOL` theRest
                theRest  = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
884 885 886
                usizeW   = untaggedSizeW npr
                tsizeW   = taggedSizeW npr

887

888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904
-- Push an atom onto the stack, returning suitable code & number of
-- stack words used.  Pushes it either tagged or untagged, since 
-- pushAtom is used to set up the stack prior to copying into the
-- heap for both APs (requiring tags) and constructors (which don't).
--
-- NB this means NO GC between pushing atoms for a constructor and
-- copying them into the heap.  It probably also means that 
-- tail calls MUST be of the form atom{atom ... atom} since if the
-- expression head was allowed to be arbitrary, there could be GC
-- in between pushing the arg atoms and completing the head.
-- (not sure; perhaps the allocate/doYouWantToGC interface means this
-- isn't a problem; but only if arbitrary graph construction for the
-- head doesn't leave this BCO, since GC might happen at the start of
-- each BCO (we consult doYouWantToGC there).
--
-- Blargh.  JRS 001206
--
905 906 907 908
-- NB (further) that the env p must map each variable to the highest-
-- numbered stack slot for it.  For example, if the stack has depth 4 
-- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
-- the tag in stack[5], the stack will have depth 6, and p must map v to
909 910
-- 5 and not to 4.  Stack locations are numbered from zero, so a depth
-- 6 stack has valid words 0 .. 5.
911

912
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
913
pushAtom tagged d p (AnnVar v)
914 915 916 917 918

   | idPrimRep v == VoidRep
   = ASSERT(tagged)
     (unitOL (PUSH_TAG 0), 1)

919
   | isFCallId v
920
   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
921

922
   | Just primop <- isPrimOpId_maybe v
923
   = (unitOL (PUSH_G (Right primop)), 1)
924 925

   | otherwise
926 927
   = let  {-
	  str = "\npushAtom " ++ showSDocDebug (ppr v) 
928 929 930
               ++ " :: " ++ showSDocDebug (pprType (idType v))
               ++ ", depth = " ++ show d
               ++ ", tagged = " ++ show tagged ++ ", env =\n" ++ 
931
               showSDocDebug (ppBCEnv p)
932
               ++ " --> words: " ++ show (snd result) ++ "\n" ++
933 934
               showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
               ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
935
	 -}
936 937 938

         result
            = case lookupBCEnv_maybe p v of
939
                 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
940
                 Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
941

942 943 944 945
         nm = case isDataConId_maybe v of
                 Just c  -> getName c
                 Nothing -> getName v

946 947 948 949 950
         sz_t   = taggedIdSizeW v
         sz_u   = untaggedIdSizeW v
         nwords = if tagged then sz_t else sz_u
     in
         result
951 952

pushAtom True d p (AnnLit lit)
953 954
   = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
     in  (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
955 956 957

pushAtom False d p (AnnLit lit)
   = case lit of
958
        MachWord w   -> code WordRep
959 960 961
        MachInt i    -> code IntRep
        MachFloat r  -> code FloatRep
        MachDouble r -> code DoubleRep
962
        MachChar c   -> code CharRep
963
        MachStr s    -> pushStr s
964
     where
965 966
        code rep
           = let size_host_words = untaggedSizeW rep
967
             in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words)
968

969 970 971 972 973 974 975 976 977 978 979 980 981 982
        pushStr s 
           = let mallocvilleAddr
                    = case s of
                         CharStr s i -> A# s

                         FastString _ l ba -> 
                            -- sigh, a string in the heap is no good to us.
                            -- We need a static C pointer, since the type of 
                            -- a string literal is Addr#.  So, copy the string 
                            -- into C land and introduce a memory leak 
                            -- at the same time.
                            let n = I# l
                            -- CAREFUL!  Chars are 32 bits in ghc 4.09+
                            in  unsafePerformIO (
983 984 985 986
                                   do (Ptr a#) <- mallocBytes (n+1)
                                      strncpy (Ptr a#) ba (fromIntegral n)
                                      writeCharOffAddr (A# a#) n '\0'
                                      return (A# a#)
987 988 989 990
                                   )
                         _ -> panic "StgInterp.lit2expr: unhandled string constant type"
             in
                -- Get the addr on the stack, untaggedly
991
                (unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1)
992 993 994 995 996





997 998 999
pushAtom tagged d p (AnnApp f (_, AnnType _))
   = pushAtom tagged d p (snd f)

1000 1001 1002
pushAtom tagged d p (AnnNote note e)
   = pushAtom tagged d p (snd e)

1003 1004 1005 1006
pushAtom tagged d p (AnnLam x e) 
   | isTyVar x 
   = pushAtom tagged d p (snd e)

1007 1008 1009 1010
pushAtom tagged d p other
   = pprPanic "ByteCodeGen.pushAtom" 
              (pprCoreExpr (deAnnotate (undefined, other)))

1011 1012
foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()

1013

1014 1015 1016
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
1017 1018 1019 1020 1021 1022
mkMultiBranch :: Maybe Int	-- # datacons in tycon, if alg alt
				-- a hint; generates better code
				-- Nothing is always safe
              -> [(Discr, BCInstrList)] 
              -> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways
1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078
   = let d_way     = filter (isNoDiscr.fst) raw_ways
         notd_ways = naturalMergeSortLe 
                        (\w1 w2 -> leAlt (fst w1) (fst w2))
                        (filter (not.isNoDiscr.fst) raw_ways)

         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
         mkTree [] range_lo range_hi = returnBc the_default

         mkTree [val] range_lo range_hi
            | range_lo `eqAlt` range_hi 
            = returnBc (snd val)
            | otherwise
            = getLabelBc 				`thenBc` \ label_neq ->
              returnBc (mkTestEQ (fst val) label_neq 
			`consOL` (snd val
			`appOL`   unitOL (LABEL label_neq)
			`appOL`   the_default))

         mkTree vals range_lo range_hi
            = let n = length vals `div` 2
                  vals_lo = take n vals
                  vals_hi = drop n vals
                  v_mid = fst (head vals_hi)
              in
              getLabelBc 				`thenBc` \ label_geq ->
              mkTree vals_lo range_lo (dec v_mid) 	`thenBc` \ code_lo ->
              mkTree vals_hi v_mid range_hi 		`thenBc` \ code_hi ->
              returnBc (mkTestLT v_mid label_geq
                        `consOL` (code_lo
			`appOL`   unitOL (LABEL label_geq)
			`appOL`   code_hi))
 
         the_default 
            = case d_way of [] -> unitOL CASEFAIL
                            [(_, def)] -> def

         -- None of these will be needed if there are no non-default alts
         (mkTestLT, mkTestEQ, init_lo, init_hi)
            | null notd_ways
            = panic "mkMultiBranch: awesome foursome"
            | otherwise
            = case fst (head notd_ways) of {
              DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
                            \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
                            DiscrI minBound,
                            DiscrI maxBound );
              DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
                            \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
                            DiscrF minF,
                            DiscrF maxF );
              DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
                            \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
                            DiscrD minD,
                            DiscrD maxD );
              DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
                            \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
1079 1080
                            DiscrP algMinBound,
                            DiscrP algMaxBound )
1081 1082
              }

1083 1084
         (algMinBound, algMaxBound)
            = case maybe_ncons of
1085
                 Just n  -> (0, n - 1)
1086 1087
                 Nothing -> (minBound, maxBound)

1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118
         (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
         (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
         (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
         (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
         NoDiscr     `eqAlt` NoDiscr     = True
         _           `eqAlt` _           = False

         (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
         (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
         (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
         (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
         NoDiscr     `leAlt` NoDiscr     = True
         _           `leAlt` _           = False

         isNoDiscr NoDiscr = True
         isNoDiscr _       = False

         dec (DiscrI i) = DiscrI (i-1)
         dec (DiscrP i) = DiscrP (i-1)
         dec other      = other		-- not really right, but if you
		-- do cases on floating values, you'll get what you deserve

         -- same snotty comment applies to the following
         minF, maxF :: Float
         minD, maxD :: Double
         minF = -1.0e37
         maxF =  1.0e37
         minD = -1.0e308
         maxD =  1.0e308
     in
         mkTree notd_ways init_lo init_hi
1119

1120 1121
\end{code}

1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146
%************************************************************************
%*									*
\subsection{Supporting junk for the compilation schemes}
%*									*
%************************************************************************

\begin{code}

-- Describes case alts
data Discr 
   = DiscrI Int
   | DiscrF Float
   | DiscrD Double
   | DiscrP Int
   | NoDiscr

instance Outputable Discr where
   ppr (DiscrI i) = int i
   ppr (DiscrF f) = text (show f)
   ppr (DiscrD d) = text (show d)
   ppr (DiscrP i) = int i
   ppr NoDiscr    = text "DEF"


-- Find things in the BCEnv (the what's-on-the-stack-env)
1147
-- See comment preceding pushAtom for precise meaning of env contents
1148 1149 1150 1151 1152 1153
--lookupBCEnv :: BCEnv -> Id -> Int
--lookupBCEnv env nm
--   = case lookupFM env nm of
--        Nothing -> pprPanic "lookupBCEnv" 
--                            (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
--        Just xx -> xx
1154 1155 1156 1157 1158 1159 1160 1161 1162

lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
lookupBCEnv_maybe = lookupFM


taggedIdSizeW, untaggedIdSizeW :: Id -> Int
taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType

1163 1164
unboxedTupleException :: a
unboxedTupleException 
1165 1166 1167 1168 1169
   = throwDyn 
        (Panic 
           ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
            "\tto foreign import/export decls in source.  Workaround:\n" ++
            "\tcompile this module to a .o file, then restart session."))
1170

1171 1172 1173 1174

mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f    = f x

1175 1176 1177 1178 1179 1180 1181
\end{code}

%************************************************************************
%*									*
\subsection{The bytecode generator's monad}
%*									*
%************************************************************************
1182 1183

\begin{code}
1184
data BcM_State 
1185
   = BcM_State { bcos      :: [ProtoBCO Name],	-- accumulates completed BCOs
1186
                 nextlabel :: Int }		-- for generating local labels
1187 1188 1189

type BcM result = BcM_State -> (result, BcM_State)

1190 1191
runBc :: BcM_State -> BcM () -> BcM_State
runBc init_st m = case m init_st of { (r,st) -> st }
1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210

thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc expr cont st
  = case expr st of { (result, st') -> cont result st' }

thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ expr cont st
  = case expr st of { (result, st') -> cont st' }

returnBc :: a -> BcM a
returnBc result st = (result, st)

mapBc :: (a -> BcM b) -> [a] -> BcM [b]
mapBc f []     = returnBc []
mapBc f (x:xs)
  = f x          `thenBc` \ r  ->
    mapBc f xs   `thenBc` \ rs ->
    returnBc (r:rs)

1211
emitBc :: ProtoBCO Name -> BcM ()
1212 1213 1214 1215 1216 1217
emitBc bco st
   = ((), st{bcos = bco : bcos st})

getLabelBc :: BcM Int
getLabelBc st
   = (nextlabel st, st{nextlabel = 1 + nextlabel st})
1218

1219 1220 1221 1222 1223
getLabelsBc :: Int -> BcM [Int]
getLabelsBc n st
   = let ctr = nextlabel st 
     in  ([ctr .. ctr+n-1], st{nextlabel = ctr+n})

1224
\end{code}