From: simonmar <unknown>
Date: Tue, 6 Aug 2002 13:43:35 +0000 (+0000)
Subject: [project @ 2002-08-06 13:43:35 by simonmar]
X-Git-Tag: Approx_11550_changesets_converted~1773
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ab3866ba287adb59fb4fbdfa7b623b647f6859a9;p=ghc-hetmet.git

[project @ 2002-08-06 13:43:35 by simonmar]
Make this compile, and maybe even work
---

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 345a81b..251b7c5 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -20,6 +20,7 @@ import OrdList		( OrdList, consOL, snocOL, appOL, unitOL,
 			  nilOL, toOL, concatOL, fromOL )
 import FiniteMap	( FiniteMap, addListToFM, listToFM, elemFM,
 			  addToFM, lookupFM, fmToList )
+import CoreUtils	( exprType )
 import CoreSyn
 import PprCore		( pprCoreExpr )
 import Literal		( Literal(..), literalPrimRep )
@@ -38,6 +39,10 @@ import Util		( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
 import DataCon		( dataConRepArity )
 import Var		( isTyVar )
 import VarSet		( VarSet, varSetElems )
+import TysPrim		( foreignObjPrimTyCon, 
+			  arrayPrimTyCon, mutableArrayPrimTyCon,
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon
+			)
 import PrimRep		( isFollowableRep )
 import CmdLineOpts	( DynFlags, DynFlag(..) )
 import ErrUtils		( showPass, dumpIfSet_dyn )
@@ -779,14 +784,16 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 
          pargs d [] = returnBc []
          pargs d ((_,a):az) 
-            = let rep_arg = atomRep a
-              in case rep_arg of
+            = let arg_ty = repType (exprType (deAnnotate' a))
+
+              in case splitTyConApp_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
                     -- contains.
-                    ForeignObjRep
+		    Just (t, _)
+		     | t == foreignObjPrimTyCon
                        -> pushAtom False{-irrelevant-} d p a
 							`thenBc` \ (push_fo, _) ->
-                          let foro_szW = taggedSizeW ForeignObjRep
+                          let foro_szW = taggedSizeW PtrRep
                               d_now    = d + addr_tsizeW
                               code     = push_fo `appOL` toOL [
                                             UPK_TAG addr_usizeW 0 0,
@@ -795,13 +802,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
                           in  pargs d_now az 		`thenBc` \ rest ->
                               returnBc ((code, AddrRep) : rest)
 
-                    ArrayRep
+		     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
                        -> pargs (d + addr_tsizeW) az	`thenBc` \ rest ->
                           parg_ArrayishRep arrPtrsHdrSize d p a
 							`thenBc` \ code ->
                           returnBc ((code,AddrRep):rest)
 
-                    ByteArrayRep
+		     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
                        -> pargs (d + addr_tsizeW) az	`thenBc` \ rest ->
                           parg_ArrayishRep arrWordsHdrSize d p a
 							`thenBc` \ code ->
@@ -811,7 +818,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
                     other
                        -> pushAtom True d p a		`thenBc` \ (code_a, sz_a) ->
                           pargs (d+sz_a) az		`thenBc` \ rest ->
-                          returnBc ((code_a, rep_arg) : rest)
+                          returnBc ((code_a, atomRep a) : rest)
 
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
@@ -1016,7 +1023,6 @@ atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 
-
 -- 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.