X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgUtils.hs;h=0a8ac41628e1e08a408e2c55a68fa6b4a9964d28;hp=c66fc9ebdd263e66390b48828a58745b6b681db2;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=c23fe488fc0c4b019a2dc3186106e4654b5f5107

diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index c66fc9e..0a8ac41 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -6,6 +6,13 @@
 --
 -----------------------------------------------------------------------------
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CgUtils (
 	addIdReps,
 	cgLit,
@@ -22,12 +29,17 @@ module CgUtils (
         callerSaveVolatileRegs, get_GlobalReg_addr,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+        cmmUGtWord,
 	cmmOffsetExprW, cmmOffsetExprB,
 	cmmRegOffW, cmmRegOffB,
 	cmmLabelOffW, cmmLabelOffB,
 	cmmOffsetW, cmmOffsetB,
 	cmmOffsetLitW, cmmOffsetLitB,
 	cmmLoadIndexW,
+        cmmConstrTag, cmmConstrTag1,
+
+        tagForCon, tagCons, isSmallFamily,
+        cmmUntag, cmmIsTagged, cmmGetTag,
 
 	addToMem, addToMemE,
 	mkWordCLit,
@@ -43,6 +55,7 @@ module CgUtils (
 
 import CgMonad
 import TyCon
+import DataCon
 import Id
 import Constants
 import SMRep
@@ -61,7 +74,9 @@ import Util
 import DynFlags
 import FastString
 import PackageConfig
+#ifdef DEBUG
 import Outputable
+#endif
 
 import Data.Char
 import Data.Bits
@@ -164,6 +179,9 @@ cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
+--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
+--cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
@@ -172,6 +190,57 @@ cmmNegate e			  = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
 blankWord :: CmmStatic
 blankWord = CmmUninitialised wORD_SIZE
 
+-- Tagging --
+-- Tag bits mask
+--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
+cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
+cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
+
+-- Used to untag a possibly tagged pointer
+-- A static label need not be untagged
+cmmUntag e@(CmmLit (CmmLabel _)) = e
+-- Default case
+cmmUntag e = (e `cmmAndWord` cmmPointerMask)
+
+cmmGetTag e = (e `cmmAndWord` cmmTagMask)
+
+-- Test if a closure pointer is untagged
+cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
+                 `cmmNeWord` CmmLit zeroCLit
+
+cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
+-- Get constructor tag, but one based.
+cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
+
+{-
+   The family size of a data type (the number of constructors)
+   can be either:
+    * small, if the family size < 2**tag_bits
+    * big, otherwise.
+
+   Small families can have the constructor tag in the tag
+   bits.
+   Big families only use the tag value 1 to represent
+   evaluatedness.
+-}
+isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
+
+tagForCon con = tag
+    where
+    con_tag           = dataConTagZ con
+    fam_size   = tyConFamilySize (dataConTyCon con)
+    tag | isSmallFamily fam_size = con_tag + 1
+        | otherwise              = 1
+
+--Tag an expression, to do: refactor, this appears in some other module.
+tagCons con expr = cmmOffsetB expr (tagForCon con)
+
+-- Copied from CgInfoTbls.hs
+-- We keep the *zero-indexed* tag in the srt_len field of the info
+-- table of a data constructor.
+dataConTagZ :: DataCon -> ConTagZ
+dataConTagZ con = dataConTag con - fIRST_TAG
+
 -----------------------
 --	Making literals
 
@@ -219,11 +288,11 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
-tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure this_pkg tycon tag
+tagToClosure :: TyCon -> CmmExpr -> CmmExpr
+tagToClosure tycon tag
   = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
   where closure_tbl = CmmLit (CmmLabel lbl)
-	lbl = mkClosureTableLabel this_pkg (tyConName tycon)
+	lbl = mkClosureTableLabel (tyConName tycon)
 
 -------------------------------------------------------------------------
 --
@@ -292,11 +361,11 @@ emitRtsCall' res fun args vols safe = do
             then getSRTInfo >>= (return . CmmSafe)
             else return CmmUnsafe
   stmtsC caller_save
-  stmtC (CmmCall target res args safety)
+  stmtC (CmmCall target res args safety CmmMayReturn)
   stmtsC caller_load
   where
     (caller_save, caller_load) = callerSaveVolatileRegs vols
-    target   = CmmForeignCall fun_expr CCallConv
+    target   = CmmCallee fun_expr CCallConv
     fun_expr = mkLblExpr (mkRtsCodeLabel fun)
 
 -----------------------------------------------------------------------------