Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / ghci / ByteCodeGen.lhs

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 8a4b5e2..90931cc 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -250,7 +250,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -438,7 +438,7 @@ schemeE d s p (AnnLet binds (_,body))
 
         compile_bind d' fvs x rhs size arity off = do
                bco <- schemeR fvs (x,rhs)
-               build_thunk (fromIntegral d') fvs size bco off arity
+               build_thunk d' fvs size bco off arity
 
         compile_binds = 
            [ compile_bind d' fvs x rhs size arity n
@@ -834,7 +834,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
             rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
           where
-            real_bndrs = filter (not.isTyVar) bndrs
+            real_bndrs = filter (not.isTyCoVar) bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _) 
@@ -844,6 +844,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
            = case l of MachInt i     -> DiscrI (fromInteger i)
+                       MachWord w    -> DiscrW (fromInteger w)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
                        MachChar i    -> DiscrI (ord i)
@@ -1027,14 +1028,15 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
             = case target of
                  DynamicTarget
                     -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
-                 StaticTarget target
+
+                 StaticTarget target _
                     -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
                           return (True, res)
                    where
                       stdcall_adj_target
 #ifdef mingw32_TARGET_OS
                           | StdCallConv <- cconv
-                          = let size = a_reps_sizeW * wORD_SIZE in
+                          = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
                             mkFastString (unpackFS target ++ '@':show size)
 #endif
                           | otherwise
@@ -1144,6 +1146,8 @@ maybe_getCCallReturnRep fn_ty
                                   -- if it was, it would be impossible 
                                   -- to create a valid return value 
                                   -- placeholder on the stack
+
+         blargh :: a -- Used at more than one type
          blargh = pprPanic "maybe_getCCallReturn: can't handle:" 
                            (pprType fn_ty)
      in 
@@ -1203,7 +1207,7 @@ pushAtom d p (AnnVar v)
    = return (unitOL (PUSH_PRIMOP primop), 1)
 
    | Just d_v <- lookupBCEnv_maybe p v  -- v is a local variable
-   = let l = d - fromIntegral d_v + sz - 2
+   = let l = d - d_v + sz - 2
      in return (toOL (genericReplicate sz (PUSH_L l)), sz)
         -- d - d_v                 the number of words between the TOS 
         --                         and the 1st slot of the object
@@ -1334,6 +1338,10 @@ mkMultiBranch maybe_ncons raw_ways
                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
                             DiscrI minBound,
                             DiscrI maxBound );
+              DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label,
+                            \(DiscrW i) fail_label -> TESTEQ_W i fail_label,
+                            DiscrW minBound,
+                            DiscrW maxBound );
               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
                             DiscrF minF,
@@ -1356,6 +1364,7 @@ mkMultiBranch maybe_ncons raw_ways
                  Nothing -> (minBound, maxBound)
 
          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
+         (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2
          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
@@ -1363,6 +1372,7 @@ mkMultiBranch maybe_ncons raw_ways
          _           `eqAlt` _           = False
 
          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
+         (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2
          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
@@ -1373,6 +1383,7 @@ mkMultiBranch maybe_ncons raw_ways
          isNoDiscr _       = False
 
          dec (DiscrI i) = DiscrI (i-1)
+         dec (DiscrW w) = DiscrW (w-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
@@ -1394,6 +1405,7 @@ mkMultiBranch maybe_ncons raw_ways
 -- Describes case alts
 data Discr 
    = DiscrI Int
+   | DiscrW Word
    | DiscrF Float
    | DiscrD Double
    | DiscrP Word16
@@ -1401,6 +1413,7 @@ data Discr
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i
+   ppr (DiscrW w) = text (show w)
    ppr (DiscrF f) = text (show f)
    ppr (DiscrD d) = text (show d)
    ppr (DiscrP i) = ppr i
@@ -1444,7 +1457,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 -- whereas value lambdas cannot; that is why they are nuked here
 bcView (AnnNote _ (_,e))            = Just e
 bcView (AnnCast (_,e) _)            = Just e
-bcView (AnnLam v (_,e)) | isTyVar v  = Just e
+bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
 bcView _                             = Nothing
 
@@ -1534,7 +1547,10 @@ recordItblMallocBc a
 
 getLabelBc :: BcM Word16
 getLabelBc
-  = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
+  = BcM $ \st -> do let nl = nextlabel st
+                    when (nl == maxBound) $
+                        panic "getLabelBc: Ran out of labels"
+                    return (st{nextlabel = nl + 1}, nl)
 
 getLabelsBc :: Word16 -> BcM [Word16]
 getLabelsBc n