X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=0df09d63d3bcfedd52a466e81ecfe503c1d2708e;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hp=bd292810ad3af1105d99e15e3c0f856e7ae008ca;hpb=b515d109750e00630dfaf6055a1ded8dfd61b415;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index bd29281..0df09d6 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -17,6 +17,7 @@ import LibFFI
 
 import Outputable
 import Name
+import MkId
 import Id
 import FiniteMap
 import ForeignCall
@@ -30,9 +31,9 @@ import CoreFVs
 import Type
 import DataCon
 import TyCon
-import Type
+-- import Type
 import Util
-import DataCon
+-- import DataCon
 import Var
 import VarSet
 import TysPrim
@@ -49,9 +50,8 @@ import Constants
 import Data.List
 import Foreign
 import Foreign.C
-import Control.Exception	( throwDyn )
 
-import GHC.Exts		( Int(..), ByteArray# )
+-- import GHC.Exts		( Int(..) )
 
 import Control.Monad	( when )
 import Data.Char
@@ -167,7 +167,7 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
         -- 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
+        -- BCO anyway, so we only need to add an explicit one in the
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check
@@ -257,13 +257,14 @@ schemeR fvs (nm, rhs)
    = undefined
    | otherwise
 -}
-   = schemeR_wrk fvs nm rhs (collect [] rhs)
+   = schemeR_wrk fvs nm rhs (collect rhs)
 
-collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
-collect xs (_, AnnNote _ e) = collect xs e
-collect xs (_, AnnCast e _) = collect xs e
-collect xs (_, AnnLam x e)  = collect (if isTyVar x then xs else (x:xs)) e
-collect xs (_, not_lambda)  = (reverse xs, not_lambda)
+collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
+collect (_, e) = go [] e
+  where
+    go xs e | Just e' <- bcView e = go xs e'
+    go xs (AnnLam x (_,e))        = go (x:xs) e
+    go xs not_lambda              = (reverse xs, not_lambda)
 
 schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) 
 schemeR_wrk fvs nm original_body (args, body)
@@ -347,6 +348,10 @@ instance Outputable TickInfo where
 -- on the stack, returning a HNF.
 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 
+schemeE d s p e
+   | Just e' <- bcView e
+   = schemeE d s p e'
+
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(AnnApp _ _) 
    = schemeT d s p e
@@ -398,7 +403,7 @@ schemeE d s p (AnnLet binds (_,body))
          sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
 
 	 -- the arity of each rhs
-	 arities = map (length . fst . collect []) rhss
+	 arities = map (length . fst . collect) rhss
 
          -- 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
@@ -450,9 +455,21 @@ schemeE d s p (AnnLet binds (_,body))
 -- best way to calculate the free vars but it seemed like the least
 -- intrusive thing to do
 schemeE d s p exp@(AnnCase {})
-   | Just (_tickInfo, rhs) <- isTickedExp' exp
+   | Just (_tickInfo, _rhs) <- isTickedExp' exp
    = if isUnLiftedType ty
-        then schemeE d s p (snd rhs)
+        then do
+          -- If the result type is unlifted, then we must generate
+          --   let f = \s . case tick# of _ -> e 
+          --   in  f realWorld#
+          -- When we stop at the breakpoint, _result will have an unlifted
+          -- type and hence won't be bound in the environment, but the
+          -- breakpoint will otherwise work fine.
+          id <- newId (mkFunTy realWorldStatePrimTy ty)
+          st <- newId realWorldStatePrimTy
+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
+                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) 
+                                                    (emptyVarSet, AnnVar realWorldPrimId)))
+          schemeE d s p letExp
         else do
           id <- newId ty
           -- Todo: is emptyVarSet correct on the next line?
@@ -492,12 +509,6 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
 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 _ (_, body))
-   = schemeE d s p body
-
-schemeE d s p (AnnCast (_, body) _)
-   = schemeE d s p body
-
 schemeE _ _ _ expr
    = pprPanic "ByteCodeGen.schemeE: unhandled case" 
                (pprCoreExpr (deAnnotate' expr))
@@ -1016,11 +1027,11 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
                       stdcall_adj_target
 #ifdef mingw32_TARGET_OS
                           | StdCallConv <- cconv
-                          = mkFastString (unpackFS target ++ '@':show size)
+                          = let size = a_reps_sizeW * wORD_SIZE in
+                            mkFastString (unpackFS target ++ '@':show size)
 #endif
                           | otherwise
                           = target
-                      size = a_reps_sizeW * wORD_SIZE
 
      -- in
      (is_static, static_target_addr) <- get_target_info
@@ -1170,18 +1181,11 @@ implement_tagToId names
 
 pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
 
-pushAtom d p (AnnApp f (_, AnnType _))
-   = pushAtom d p (snd f)
-
-pushAtom d p (AnnNote _ e)
-   = pushAtom d p (snd e)
-
-pushAtom d p (AnnLam x e) 
-   | isTyVar x 
-   = pushAtom d p (snd e)
+pushAtom d p e 
+   | Just e' <- bcView e 
+   = pushAtom d p e'
 
 pushAtom d p (AnnVar v)
-
    | idCgRep v == VoidArg
    = return (nilOL, 0)
 
@@ -1214,12 +1218,13 @@ pushAtom d p (AnnVar v)
 
 pushAtom _ _ (AnnLit lit)
    = case lit of
-        MachLabel _ _ -> code NonPtrArg
+        MachLabel _ _ _ -> code NonPtrArg
         MachWord _    -> code NonPtrArg
         MachInt _     -> code PtrArg
         MachFloat _   -> code FloatArg
         MachDouble _  -> code DoubleArg
         MachChar _    -> code NonPtrArg
+	MachNullAddr  -> code NonPtrArg
         MachStr s     -> pushStr s
         l             -> pprPanic "pushAtom" (ppr l)
      where
@@ -1401,7 +1406,7 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id))
 -- See bug #1257
 unboxedTupleException :: a
 unboxedTupleException 
-   = throwDyn 
+   = ghcError 
         (ProgramError 
            ("Error: bytecode compiler can't handle unboxed tuples.\n"++
             "  Possibly due to foreign import/export decls in source.\n"++
@@ -1411,34 +1416,37 @@ unboxedTupleException
 mkSLIDE :: Int -> Int -> OrdList BCInstr
 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
 
-splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
+splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
 	-- The arguments are returned in *right-to-left* order
-splitApp (AnnApp (_,f) (_,a))
-	       | isTypeAtom a = splitApp f
-	       | otherwise    = case splitApp f of 
-				     (f', as) -> (f', a:as)
-splitApp (AnnNote _ (_,e))    = splitApp e
-splitApp (AnnCast (_,e) _)    = splitApp e
-splitApp e		      = (e, [])
-
-
-isTypeAtom :: AnnExpr' id ann -> Bool
-isTypeAtom (AnnType _) = True
-isTypeAtom _           = False
-
-isVoidArgAtom :: AnnExpr' id ann -> Bool
-isVoidArgAtom (AnnVar v)        = typePrimRep (idType v) == VoidRep
-isVoidArgAtom (AnnNote _ (_,e)) = isVoidArgAtom e
-isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e
-isVoidArgAtom _ 	        = False
+splitApp e | Just e' <- bcView e = splitApp e'
+splitApp (AnnApp (_,f) (_,a)) 	 = case splitApp f of 
+			      	      (f', as) -> (f', a:as)
+splitApp e		      	 = (e, [])
+
+
+bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
+-- The "bytecode view" of a term discards
+--  a) type abstractions
+--  b) type applications
+--  c) casts
+--  d) notes
+-- Type lambdas *can* occur in random expressions, 
+-- 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 (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView _                             = Nothing
+
+isVoidArgAtom :: AnnExpr' Var ann -> Bool
+isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
+isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
+isVoidArgAtom _ 	              = False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
-atomPrimRep (AnnVar v)    = typePrimRep (idType v)
-atomPrimRep (AnnLit l)    = typePrimRep (literalType l)
-atomPrimRep (AnnNote _ b) = atomPrimRep (snd b)
-atomPrimRep (AnnApp f (_, AnnType _)) = atomPrimRep (snd f)
-atomPrimRep (AnnLam x e) | isTyVar x = atomPrimRep (snd e)
-atomPrimRep (AnnCast b _) = atomPrimRep (snd b)
+atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
+atomPrimRep (AnnVar v)    	    = typePrimRep (idType v)
+atomPrimRep (AnnLit l)    	    = typePrimRep (literalType l)
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
 atomRep :: AnnExpr' Id ann -> CgRep