[project @ 2000-01-24 17:24:23 by sewardj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / StixPrim.lhs

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 9f01488..ff5332d 100644 (file)
--- 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 )
@@ -140,7 +141,6 @@ primCode [lhs] SizeofMutableByteArrayOp [rhs]
 Most other array primitives translate to simple indexing.
 
 \begin{code}
-
 primCode lhs@[_] IndexArrayOp args
   = primCode lhs ReadArrayOp args
 
@@ -159,7 +159,7 @@ primCode [] WriteArrayOp [obj, ix, v]
        obj' = amodeToStix obj
        ix' = amodeToStix ix
        v' = amodeToStix v
-       base = StIndex IntRep obj' arrHS
+       base = StIndex IntRep obj' arrHS --(StInt (toInteger 3))
        assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
     in
     returnUs (\xs -> assign : xs)
@@ -235,6 +235,26 @@ primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
              _ -> base
 \end{code}
 
+DataToTagOp won't work for 64-bit archs, as it is.
+
+\begin{code}
+primCode [lhs] DataToTagOp [arg]
+  = let lhs'        = amodeToStix lhs
+        arg'        = amodeToStix arg
+        infoptr     = StInd PtrRep arg'
+        word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
+        masked_le32 = StPrim SrlOp [word_32, StInt 16]
+        masked_be32 = StPrim AndOp [word_32, StInt 65535]
+#ifdef WORDS_BIGENDIAN
+        masked      = masked_be32
+#else
+        masked      = masked_le32
+#endif
+        assign      = StAssign IntRep lhs' masked
+    in
+    returnUs (\xs -> assign : xs)
+\end{code}
+
 Now the more mundane operations.
 
 \begin{code}
@@ -332,7 +352,7 @@ amodeToStix (CCharLike (CLit (MachChar c)))
 amodeToStix (CCharLike x)
   = StIndex PtrRep 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))
@@ -348,13 +368,13 @@ 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
@@ -364,10 +384,21 @@ amodeToStix (CMacroExpr _ macro [arg])
                        [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
                                                         StInt 1]),
                         StInt 16]
-
+      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