Pointer Tagging

[ghc-hetmet.git] / compiler / codeGen / ClosureInfo.lhs

diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 831e4ec..d537a7b 100644 (file)
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -13,8 +13,9 @@ the STG paper.
 
 \begin{code}
 module ClosureInfo (
-       ClosureInfo, LambdaFormInfo, SMRep,     -- all abstract
-       StandardFormInfo, 
+       ClosureInfo(..), LambdaFormInfo(..),    -- would be abstract but
+       StandardFormInfo(..),                   -- mkCmmInfo looks inside
+        SMRep,
 
        ArgDescr(..), Liveness(..), 
        C_SRT(..), needsSRT,
@@ -22,7 +23,7 @@ module ClosureInfo (
        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
 
-       mkClosureInfo, mkConInfo,
+       mkClosureInfo, mkConInfo, maybeIsLFCon,
 
        closureSize, closureNonHdrSize,
        closureGoodStuffSize, closurePtrsSize,
@@ -34,6 +35,7 @@ module ClosureInfo (
        closureNeedsUpdSpace, closureIsThunk,
        closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
        closureFunInfo, isStandardFormThunk, isKnownFun,
+        funTag, funTagLFInfo, tagForArity,
 
        enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
 
@@ -57,6 +59,7 @@ module ClosureInfo (
 #include "../includes/MachDeps.h"
 #include "HsVersions.h"
 
+--import CgUtils
 import StgSyn
 import SMRep
 
@@ -123,10 +126,15 @@ data ClosureInfo
 
 data C_SRT = NoC_SRT
           | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
+           deriving (Eq)
 
 needsSRT :: C_SRT -> Bool
 needsSRT NoC_SRT       = False
 needsSRT (C_SRT _ _ _) = True
+
+instance Outputable C_SRT where
+  ppr (NoC_SRT) = ptext SLIT("_no_srt_")
+  ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
 \end{code}
 
 %************************************************************************
@@ -184,7 +192,7 @@ data LambdaFormInfo
 
 data ArgDescr
   = ArgSpec            -- Fits one of the standard patterns
-       !Int            -- RTS type identifier ARG_P, ARG_N, ...
+       !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
 
   | ArgGen             -- General case
        Liveness        -- Details about the arguments
@@ -257,12 +265,12 @@ mkLFThunk thunk_ty top fvs upd_flag
            (might_be_a_function thunk_ty)
 
 might_be_a_function :: Type -> Bool
+-- Return False only if we are *sure* it's a data type
+-- Look through newtypes etc as much as poss
 might_be_a_function ty
-  | Just (tc,_) <- splitTyConApp_maybe (repType ty), 
-    not (isFunTyCon tc)  && not (isAbstractTyCon tc) = False
-       -- don't forget to check for abstract types, which might
-       -- be functions too.
-  | otherwise = True
+  = case splitTyConApp_maybe (repType ty) of
+       Just (tc, _) -> not (isDataTyCon tc)
+       Nothing      -> True
 \end{code}
 
 @mkConLFInfo@ is similar, for constructors.
@@ -271,6 +279,10 @@ might_be_a_function ty
 mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con = LFCon con
 
+maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
+maybeIsLFCon (LFCon con) = Just con
+maybeIsLFCon _ = Nothing
+
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
        (might_be_a_function (idType id))
@@ -583,17 +595,24 @@ getCallMethod this_pkg name (LFCon con) n_args
     ReturnCon con
 
 getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args
-  | is_fun     -- Must always "call" a function-typed 
-  = SlowCall   -- thing, cannot just enter it [in eval/apply, the entry code
+  | is_fun     -- *Might* be a function, so we must "call" it (which is always safe)
+  = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
 
+  -- Since is_fun is False, we are *definitely* looking at a data value
   | updatable || opt_DoTickyProfiling  -- to catch double entry
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
         of jumping directly to the entry code is still valid.  --SDM
        -}
-  = ASSERT( n_args == 0 ) EnterIt
+  = EnterIt
+    -- We used to have ASSERT( n_args == 0 ), but actually it is
+    -- possible for the optimiser to generate
+    --   let bot :: Int = error Int "urk"
+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
+    -- This happens as a result of the case-of-error transformation
+    -- So the right thing to do is just to enter the thing
 
   | otherwise  -- Jump direct to code for single-entry thunks
   = ASSERT( n_args == 0 )
@@ -791,10 +810,32 @@ isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
 isConstrClosure_maybe _                                  = Nothing
 
 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
-closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc})
-  = Just (arity, arg_desc)
-closureFunInfo _
-  = Nothing
+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
+closureFunInfo _ = Nothing
+
+lfFunInfo :: LambdaFormInfo ->  Maybe (Int, ArgDescr)
+lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
+lfFunInfo _                                 = Nothing
+
+funTag :: ClosureInfo -> Int
+funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info
+funTag _ = 0
+
+-- maybe this should do constructor tags too?
+funTagLFInfo :: LambdaFormInfo -> Int
+funTagLFInfo lf
+    -- A function is tagged with its arity
+  | Just (arity,_) <- lfFunInfo lf,
+    Just tag <- tagForArity arity
+  = tag
+
+    -- other closures (and unknown ones) are not tagged
+  | otherwise
+  = 0
+
+tagForArity :: Int -> Maybe Int
+tagForArity i | i <= mAX_PTR_TAG = Just i
+              | otherwise        = Nothing
 \end{code}
 
 \begin{code}
@@ -946,5 +987,3 @@ getTyDescription ty
 getPredTyDescription (ClassP cl tys) = getOccString cl
 getPredTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
 \end{code}
-
-