windres to use the gcc given as --with-cc.

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

diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 8f62bc7..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))
@@ -594,7 +606,13 @@ getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args
         if we enter the same thunk multiple times, so the optimisation
         of jumping directly to the entry code is still valid.  --SDM
        -}
-  = ASSERT2( n_args == 0, ppr name ) 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 )
@@ -792,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}
@@ -947,5 +987,3 @@ getTyDescription ty
 getPredTyDescription (ClassP cl tys) = getOccString cl
 getPredTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
 \end{code}
-
-