[project @ 2002-04-29 14:03:38 by simonmar]

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

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 6d587bb..56f64fc 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -32,9 +32,9 @@ import DataCon                ( dataConTag, fIRST_TAG, dataConTyCon,
 import TyCon           ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
                          isFunTyCon, isUnboxedTupleTyCon )
 import Class           ( Class, classTyCon )
-import Type            ( Type, repType, splitRepFunTys )
+import Type            ( Type, repType, splitFunTys, dropForAlls )
 import Util            ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
-                         isSingleton, lengthIs )
+                         isSingleton, lengthIs, notNull )
 import DataCon         ( dataConRepArity )
 import Var             ( isTyVar )
 import VarSet          ( VarSet, varSetElems )
@@ -94,7 +94,7 @@ byteCodeGen dflags binds local_tycons local_classes
                        --               ^^
                        -- better be no free vars in these top-level bindings
 
-        when (not (null mallocd))
+        when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
 
         dumpIfSet_dyn dflags Opt_D_dump_BCOs
@@ -115,8 +115,9 @@ 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_id   = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) 
-                                    (panic "invented_id's type")
+      let invented_id   = mkSysLocal FSLIT("Expr-Top-Level") 
+                               (mkPseudoUnique3 0) 
+                               (panic "invented_id's type")
       let invented_name = idName invented_id
 
          annexpr = freeVars expr
@@ -126,7 +127,7 @@ coreExprToBCOs dflags expr
          <- runBc (BcM_State [] 0 []) 
                   (schemeR True fvs (invented_id, annexpr))
 
-      when (not (null mallocd))
+      when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
 
       dumpIfSet_dyn dflags Opt_D_dump_BCOs
@@ -590,7 +591,7 @@ schemeE d s p other
 -- and enter.  Four cases:
 --
 -- 0.  (Nasty hack).
---     An application "PrelGHC.tagToEnum# <type> unboxed-int".
+--     An application "GHC.Prim.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.
 --
@@ -641,16 +642,17 @@ schemeT d s p app
      )
 
    -- Case 2
-   | let isVoidRepAtom (_, AnnVar v)    = VoidRep == typePrimRep (idType v)
+   | [arg1,arg2] <- args_r_to_l,
+     let 
+        isVoidRepAtom (_, AnnVar v)    = typePrimRep (idType v) == VoidRep
          isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
-     in  is_con_call && isUnboxedTupleCon con 
-         && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l)))
-              || (isSingleton args_r_to_l)
-            )
+        isVoidRepAtom _ = False
+     in  
+        isVoidRepAtom arg2
    = --trace (if isSingleton args_r_to_l
      --       then "schemeT: unboxed singleton"
      --       else "schemeT: unboxed pair with Void first component") (
-     schemeT d s p (head args_r_to_l)
+     schemeT d s p arg1
      --)
 
    -- Case 3
@@ -881,7 +883,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
                  DynamicTarget
                     -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
                  StaticTarget target
-                    -> let sym_to_find = _UNPK_ target in
+                    -> let sym_to_find = unpackFS target in
                        ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
                        case res of
                            Just aa -> returnBc (True, aa)
@@ -962,22 +964,22 @@ mkDummyLiteral pr
 
 
 -- Convert (eg) 
---     PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
---                   -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 --
 -- to  Just IntRep
 -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
 --
 -- Alternatively, for call-targets returning nothing, convert
 --
---     PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
---                   -> (# PrelGHC.State# PrelGHC.RealWorld #)
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
 --
 -- to  Nothing
 
 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 maybe_getCCallReturnRep fn_ty
-   = let (a_tys, r_ty) = splitRepFunTys fn_ty
+   = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
          maybe_r_rep_to_go  
             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
          (r_tycon, r_reps) 
@@ -1013,7 +1015,7 @@ atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 -- as a consequence.
 implement_tagToId :: [Name] -> BcM BCInstrList
 implement_tagToId names
-   = ASSERT(not (null names))
+   = ASSERT( notNull names )
      getLabelsBc (length names)                        `thenBc` \ labels ->
      getLabelBc                                        `thenBc` \ label_fail ->
      getLabelBc                                `thenBc` \ label_exit ->
@@ -1448,7 +1450,7 @@ emitBc bco st
 
 newbcoBc :: BcM ()
 newbcoBc st
-   | not (null (malloced st)) 
+   | notNull (malloced st)
    = panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
    | otherwise
    = return (st, ())