projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2001-02-26 15:41:18 by simonpj]
[ghc-hetmet.git] / ghc / compiler / nativeGen / StixPrim.lhs
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index dc3bee7..c043f8d 100644 (file)
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -16,14 +16,15 @@ import AbsCUtils    ( getAmodeRep, mixedTypeLocn )
 import SMRep           ( fixedHdrSize )
 import Literal         ( Literal(..), word2IntLit )
 import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
-import PrimRep         ( PrimRep(..), isFloatingRep )
+import PrimRep         ( PrimRep(..) )
 import UniqSupply      ( returnUs, thenUs, getUniqueUs, UniqSM )
-import Constants       ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
+import Constants       ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
+                         rESERVED_STACK_WORDS )
 import CLabel          ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
                          mkMAP_FROZEN_infoLabel, mkForeignLabel )
+import CallConv                ( cCallConv )
 import Outputable
-
-import Char            ( ord, isAlpha, isDigit )
+import FastTypes
 
 #include "NCG.h"
 \end{code}
@@ -54,8 +55,6 @@ 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@[sr,dr] IntegerNegOp arg@[sa,da]
-  = gmpNegate (sr,dr) (sa,da)
 
 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
   = gmpCompare res (sa1,da1, sa2,da2)
@@ -80,6 +79,9 @@ primCode [res] Int2WordOp [arg]
 
 primCode [res] Word2IntOp [arg]
   = simpleCoercion IntRep res arg
+
+primCode [res] AddrToHValueOp [arg]
+  = simpleCoercion PtrRep res arg
 \end{code}
 
 \begin{code}
@@ -180,7 +182,7 @@ primCode [] WriteForeignObjOp [obj, v]
     returnUs (\xs -> assign : xs)
 
 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
-primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp CharRep      ls rs
+primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
@@ -190,7 +192,7 @@ primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRe
 primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 
-primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp CharRep      ls rs
+primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
@@ -200,7 +202,7 @@ primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep
 primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 
-primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp CharRep      ls rs
+primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
@@ -210,7 +212,7 @@ primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls
 primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 
-primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp CharRep      ls rs
+primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
@@ -220,7 +222,7 @@ primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep l
 primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 
-primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp CharRep      ls rs
+primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
 primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
 primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
@@ -230,7 +232,8 @@ primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp St
 primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
 primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
 
-primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp CharRep      ls rs
+primCode ls WriteOffAddrOp_Word8     rs = primCode_WriteOffAddrOp Word8Rep     ls rs
+primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
 primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
 primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
@@ -240,7 +243,7 @@ primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep l
 primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
 primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
 
-primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp CharRep      ls rs
+primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
 primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
 primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
@@ -254,6 +257,10 @@ primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep
 
 ToDo: saving/restoring of volatile regs around ccalls.
 
+JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
+rather than inheriting the calling convention of the thing which we're really
+calling.
+
 \begin{code}
 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
   | is_asm = error "ERROR: Native code generator can't handle casm"
@@ -266,8 +273,10 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
           id  = StReg (StixTemp uniq IntRep)
 
           suspend = StAssign IntRep id 
-                       (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
-          resume  = StCall SLIT("resumeThread") cconv VoidRep [id]
+                       (StCall SLIT("suspendThread") {-no:cconv-} cCallConv
+                                IntRep [stgBaseReg])
+          resume  = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
+                            VoidRep [id]
        in
        returnUs (\xs -> save (suspend : ccall : resume : load xs))
 
@@ -279,7 +288,7 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
            case getAmodeRep x of
              ArrayRep      -> StIndex PtrRep base arrPtrsHS
              ByteArrayRep  -> StIndex IntRep base arrWordsHS
-             ForeignObjRep -> StIndex PtrRep base fixedHS
+             ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
              _ -> base
 
     ccall = case lhs of
@@ -335,6 +344,19 @@ primCode [rr] ReadMutVarOp [aa]
      returnUs (\xs -> assign : xs)
 \end{code}
 
+ForeignObj# primops.
+
+\begin{code}
+primCode [rr] ForeignObjToAddrOp [fo]
+  = let code =  StAssign AddrRep (amodeToStix rr)
+                  (StInd AddrRep 
+                       (StIndex PtrRep (amodeToStix fo) fixedHS))
+    in
+    returnUs (\xs -> code : xs)
+
+primCode [] TouchOp [_] = returnUs id
+\end{code}
+
 Now the more mundane operations.
 
 \begin{code}
@@ -463,13 +485,13 @@ amodeToStix am@(CVal rr CharRep)
 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 
 amodeToStix (CAddr (SpRel off))
-  = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
+  = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
 
 amodeToStix (CAddr (HpRel off))
-  = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
+  = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
 
 amodeToStix (CAddr (NodeRel off))
-  = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
+  = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
 
 amodeToStix (CAddr (CIndex base off pk))
   = StIndex pk (amodeToStix base) (amodeToStix off)
@@ -482,17 +504,15 @@ amodeToStix (CLbl      lbl _) = StCLbl lbl
  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 
 amodeToStix (CCharLike (CLit (MachChar c)))
-  = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
+  = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
   where
-    off = charLikeSize * ord c
+    off = charLikeSize * (c - mIN_CHARLIKE)
 
 amodeToStix (CCharLike x)
-  = StIndex CharRep cHARLIKE_closure off
-  where
-    off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
+  = panic "CCharLike"
 
 amodeToStix (CIntLike (CLit (MachInt i)))
-  = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
+  = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
   where
     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 
@@ -501,7 +521,7 @@ amodeToStix (CIntLike x)
 
 amodeToStix (CLit core)
   = case core of
-      MachChar c     -> StInt (toInteger (ord c))
+      MachChar c     -> StInt (toInteger c)
       MachStr s             -> StString s
       MachAddr a     -> StInt a
       MachInt i      -> StInt i
@@ -572,10 +592,6 @@ save_thread_state
           (StInd PtrRep (StPrim IntAddOp 
                [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
           stgSu :
-       StAssign PtrRep 
-          (StInd PtrRep (StPrim IntAddOp 
-               [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
-          stgSpLim :
        StAssign PtrRep
           (StInd PtrRep (StPrim IntAddOp
                [stgCurrentNursery, 
@@ -596,8 +612,9 @@ load_thread_state
           (StInd PtrRep (StPrim IntAddOp 
                [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
        StAssign PtrRep stgSpLim
-          (StInd PtrRep (StPrim IntAddOp 
-               [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
+          (StPrim IntAddOp [tso, 
+                            StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
+                                              *BYTES_PER_WORD))]) :
        StAssign PtrRep stgHp
           (StPrim IntSubOp [
              StInd PtrRep (StPrim IntAddOp
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)