[project @ 2005-02-25 13:06:31 by simonpj]

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

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 485a285..5f9fe00 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -15,7 +15,7 @@ import ByteCodeAsm    ( CompiledByteCode(..), UnlinkedBCO,
 import ByteCodeLink    ( lookupStaticPtr )
 
 import Outputable
-import Name            ( Name, getName, mkSystemName )
+import Name            ( Name, getName, mkSystemVarName )
 import Id
 import FiniteMap
 import ForeignCall     ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
@@ -28,7 +28,7 @@ import PrimOp         ( PrimOp(..) )
 import CoreFVs         ( freeVars )
 import Type            ( isUnLiftedType, splitTyConApp_maybe )
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 
-                          isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+                          isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
                          dataConRepArity )
 import TyCon           ( tyConFamilySize, isDataTyCon, tyConDataCons,
                          isUnboxedTupleTyCon )
@@ -102,7 +102,7 @@ coreExprToBCOs dflags expr
 
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
-      let invented_name  = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
           invented_id    = mkLocalId invented_name (panic "invented_id's type")
          
       (BcM_State final_ctr mallocd, proto_bco) 
@@ -210,7 +210,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
 
 schemeTopBind (id, rhs)
   | Just data_con <- isDataConWorkId_maybe id,
-    isNullaryDataCon data_con
+    isNullaryRepDataCon data_con
   =    -- Special case for the worker of a nullary data con.
        -- It'll look like this:        Nil = /\a -> Nil a
        -- If we feed it into schemeR, we'll get 
@@ -391,7 +391,7 @@ schemeE d s p (AnnLet binds (_,body))
 
 
 
-schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
        -- Convert 
        --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
@@ -409,7 +409,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
-schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
        -- Similarly, convert
        --      case .... of x { (# a #) -> ... }
@@ -418,7 +418,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
    = --trace "automagic mashing of case alts (# a #)"  $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
-schemeE d s p (AnnCase scrut bndr alts)
+schemeE d s p (AnnCase scrut bndr _ alts)
    = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
 
 schemeE d s p (AnnNote note (_, body))
@@ -541,7 +541,7 @@ mkConAppCode :: Int -> Sequel -> BCEnv
             -> BcM BCInstrList
 
 mkConAppCode orig_d s p con [] -- Nullary constructor
-  = ASSERT( isNullaryDataCon con )
+  = ASSERT( isNullaryRepDataCon con )
     returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.
@@ -591,9 +591,9 @@ doTailCall init_d s p fn args
   = do_pushes init_d args (map atomRep args)
   where
   do_pushes d [] reps = do
-       ASSERTM( null reps )
+       ASSERT( null reps ) return ()
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
-       ASSERTM( sz == 1 )
+       ASSERT( sz == 1 ) return ()
        returnBc (push_fn `appOL` (
                  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
                  unitOL ENTER))
@@ -612,8 +612,6 @@ doTailCall init_d s p fn args
     return (final_d, push_code `appOL` more_push_code)
 
 -- v. similar to CgStackery.findMatch, ToDo: merge
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
-  = (PUSH_APPLY_PPPPPPP, 7, rest)
 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
   = (PUSH_APPLY_PPPPPP, 6, rest)
 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
@@ -1130,7 +1128,7 @@ mkMultiBranch :: Maybe Int        -- # datacons in tycon, if alg alt
               -> BcM BCInstrList
 mkMultiBranch maybe_ncons raw_ways
    = let d_way     = filter (isNoDiscr.fst) raw_ways
-         notd_ways = naturalMergeSortLe 
+         notd_ways = sortLe 
                         (\w1 w2 -> leAlt (fst w1) (fst w2))
                         (filter (not.isNoDiscr.fst) raw_ways)