X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=2d8643969244991f6828e5fc1245c8b446b3f8bd;hb=8252a068d95fa49040f6c55ed170f9155416e8ac;hp=588efa7571edc3cf47f9237732b3af469c8ae8a8;hpb=95585c35917515db927f0397b58eda4c8525b481;p=ghc-hetmet.git

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 588efa7..2d86439 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -14,6 +14,7 @@ import StixInteger
 
 import AbsCSyn 		hiding ( spRel )
 import AbsCUtils	( getAmodeRep, mixedTypeLocn )
+import Constants	( uF_UPDATEE )
 import SMRep		( fixedHdrSize )
 import Const		( Literal(..) )
 import CallConv		( cCallConv )
@@ -52,19 +53,20 @@ and modify our heap check accordingly.
 \begin{code}
 -- NB: ordering of clauses somewhere driven by
 -- the desire to getting sane patt-matching behavior
-primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
-  = gmpNegate (ar,sr,dr) (aa,sa,da)
-\end{code}
+primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
+  = gmpNegate (sr,dr) (sa,da)
 
-\begin{code}
-primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2]
-  = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
+primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
+  = gmpCompare res (sa1,da1, sa2,da2)
 
-primCode [res] Integer2IntOp arg@[aa,sa,da]
-  = gmpInteger2Int res (aa,sa,da)
+primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
+  = gmpCompareInt res (sa1,da1,ai)
 
-primCode [res] Integer2WordOp arg@[aa,sa,da]
-  = gmpInteger2Word res (aa,sa,da)
+primCode [res] Integer2IntOp arg@[sa,da]
+  = gmpInteger2Int res (sa,da)
+
+primCode [res] Integer2WordOp arg@[sa,da]
+  = gmpInteger2Word res (sa,da)
 
 primCode [res] Int2AddrOp [arg]
   = simpleCoercion AddrRep res arg
@@ -148,7 +150,7 @@ primCode [lhs] ReadArrayOp [obj, ix]
 	lhs' = amodeToStix lhs
     	obj' = amodeToStix obj
     	ix' = amodeToStix ix
-    	base = StIndex IntRep obj' arrHS
+    	base = StIndex IntRep obj' arrPtrsHS
     	assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
     in
     returnUs (\xs -> assign : xs)
@@ -158,7 +160,7 @@ primCode [] WriteArrayOp [obj, ix, v]
 	obj' = amodeToStix obj
     	ix' = amodeToStix ix
     	v' = amodeToStix v
-    	base = StIndex IntRep obj' arrHS
+    	base = StIndex IntRep obj' arrPtrsHS
     	assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
     in
     returnUs (\xs -> assign : xs)
@@ -173,7 +175,7 @@ primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 	lhs' = amodeToStix lhs
     	obj' = amodeToStix obj
     	ix' = amodeToStix ix
-    	base = StIndex IntRep obj' arrHS
+    	base = StIndex IntRep obj' arrWordsHS
     	assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
     in
     returnUs (\xs -> assign : xs)
@@ -202,7 +204,7 @@ primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 	obj' = amodeToStix obj
     	ix' = amodeToStix ix
     	v' = amodeToStix v
-    	base = StIndex IntRep obj' arrHS
+    	base = StIndex IntRep obj' arrWordsHS
     	assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
     in
     returnUs (\xs -> assign : xs)
@@ -228,8 +230,8 @@ primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 	let base = amodeToStix' x
 	in
 	    case getAmodeRep x of
-	      ArrayRep      -> StIndex PtrRep base arrHS
-	      ByteArrayRep  -> StIndex IntRep base arrHS
+	      ArrayRep      -> StIndex PtrRep base arrPtrsHS
+	      ByteArrayRep  -> StIndex IntRep base arrWordsHS
 	      ForeignObjRep -> StIndex PtrRep base fixedHS
 	      _ -> base
 \end{code}
@@ -349,9 +351,9 @@ amodeToStix (CCharLike (CLit (MachChar c)))
     off = charLikeSize * ord c
 
 amodeToStix (CCharLike x)
-  = StIndex PtrRep charLike off
+  = StIndex CharRep charLike off
   where
-    off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
+    off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 
 amodeToStix (CIntLike (CLit (MachInt i _)))
   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
@@ -367,26 +369,45 @@ amodeToStix (CLit core)
       MachStr s	     -> StString s
       MachAddr a     -> StInt a
       MachInt i _    -> StInt (toInteger i)
-      MachLitLit s _ -> StLitLit s
+      MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
       MachFloat d    -> StDouble d
       MachDouble d   -> StDouble d
       _ -> panic "amodeToStix:core literal"
 
- -- A CLitLit is just a (CLit . MachLitLit)
-amodeToStix (CLitLit s _) = StLitLit s
+amodeToStix (CLitLit s _)
+   = litLitToStix (_UNPK_ s)
 
 amodeToStix (CMacroExpr _ macro [arg])
   = case macro of
       ENTRY_CODE -> amodeToStix arg
       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
-      GET_TAG    -> StPrim SrlOp 
-			[StInd WordRep (StPrim IntSubOp [amodeToStix arg,
-							 StInt 1]),
+      GET_TAG    -> 
+#ifdef WORDS_BIGENDIAN
+                    StPrim AndOp 
+			[StInd WordRep (StIndex PtrRep (amodeToStix arg)
+                                                (StInt (toInteger (-1)))),
+			 StInt 65535]
+#else
+                    StPrim SrlOp 
+			[StInd WordRep (StIndex PtrRep (amodeToStix arg)
+                                                (StInt (toInteger (-1)))),
 			 StInt 16]
-
+#endif
+      UPD_FRAME_UPDATEE
+         -> StInd PtrRep (StIndex PtrRep (amodeToStix arg) 
+                                         (StInt (toInteger uF_UPDATEE)))
 -- XXX!!!
 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 -- which we've had to hand-code here.
+
+litLitToStix :: String -> StixTree
+litLitToStix nm
+   = case nm of
+        "stdout" -> stixFor_stdout
+        "stderr" -> stixFor_stderr
+        "stdin"  -> stixFor_stdin
+        other    -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" 
+                           ++ "suggested workaround: use flag -fvia-C\n")
 \end{code}
 
 Sizes of the CharLike and IntLike closures that are arranged as arrays