ghci: Ensure that system libffi include path is searched
[ghc.git] / compiler / codeGen / StgCmmClosure.hs
index bc5e473..fff2078 100644 (file)
@@ -27,7 +27,7 @@ module StgCmmClosure (
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
         mkLFStringLit,
         lfDynTag,
-        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
+        isLFThunk, isLFReEntrant, lfUpdatable,
 
         -- * Used by other modules
         CgLoc(..), SelfLoopInfo, CallMethod(..),
@@ -66,11 +66,14 @@ module StgCmmClosure (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 import SMRep
 import Cmm
 import PprCmmExpr()
 
+import CostCentre
 import BlockId
 import CLabel
 import Id
@@ -88,6 +91,7 @@ import DynFlags
 import Util
 
 import Data.Coerce (coerce)
+import qualified Data.ByteString.Char8 as BS8
 
 -----------------------------------------------------------------------------
 --                Data types and synonyms
@@ -384,11 +388,6 @@ lfDynTag _      _other                      = 0
 --                Observing LambdaFormInfo
 -----------------------------------------------------------------------------
 
--------------
-maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
-maybeIsLFCon (LFCon con) = Just con
-maybeIsLFCon _ = Nothing
-
 ------------
 isLFThunk :: LambdaFormInfo -> Bool
 isLFThunk (LFThunk {})  = True
@@ -405,7 +404,7 @@ isLFReEntrant _                = False
 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
 lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
 lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
-                                                    (dataConIdentity con)
+                                                      (dataConIdentity con)
 lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
 lfClosureType _                              = panic "lfClosureType"
 
@@ -553,7 +552,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc
               (Just (self_loop_id, block_id, args))
   | gopt Opt_Loopification dflags
   , id == self_loop_id
-  , n_args - v_args == length args
+  , args `lengthIs` (n_args - v_args)
   -- If these patterns match then we know that:
   --   * loopification optimisation is turned on
   --   * function is performing a self-recursive call in a tail position
@@ -625,92 +624,6 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
 getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
 
 -----------------------------------------------------------------------------
---                staticClosureRequired
------------------------------------------------------------------------------
-
-{-  staticClosureRequired is never called (hence commented out)
-
-    SimonMar writes (Sept 07) It's an optimisation we used to apply at
-    one time, I believe, but it got lost probably in the rewrite of
-    the RTS/code generator.  I left that code there to remind me to
-    look into whether it was worth doing sometime
-
-{- Avoiding generating entries and info tables
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At present, for every function we generate all of the following,
-just in case.  But they aren't always all needed, as noted below:
-
-[NB1: all of this applies only to *functions*.  Thunks always
-have closure, info table, and entry code.]
-
-[NB2: All are needed if the function is *exported*, just to play safe.]
-
-* Fast-entry code  ALWAYS NEEDED
-
-* Slow-entry code
-        Needed iff (a) we have any un-saturated calls to the function
-        OR         (b) the function is passed as an arg
-        OR         (c) we're in the parallel world and the function has free vars
-                       [Reason: in parallel world, we always enter functions
-                       with free vars via the closure.]
-
-* The function closure
-        Needed iff (a) we have any un-saturated calls to the function
-        OR         (b) the function is passed as an arg
-        OR         (c) if the function has free vars (ie not top level)
-
-  Why case (a) here?  Because if the arg-satis check fails,
-  UpdatePAP stuffs a pointer to the function closure in the PAP.
-  [Could be changed; UpdatePAP could stuff in a code ptr instead,
-   but doesn't seem worth it.]
-
-  [NB: these conditions imply that we might need the closure
-  without the slow-entry code.  Here's how.
-
-        f x y = let g w = ...x..y..w...
-                in
-                ...(g t)...
-
-  Here we need a closure for g which contains x and y,
-  but since the calls are all saturated we just jump to the
-  fast entry point for g, with R1 pointing to the closure for g.]
-
-
-* Standard info table
-        Needed iff (a) we have any un-saturated calls to the function
-        OR         (b) the function is passed as an arg
-        OR         (c) the function has free vars (ie not top level)
-
-        NB.  In the sequential world, (c) is only required so that the function closure has
-        an info table to point to, to keep the storage manager happy.
-        If (c) alone is true we could fake up an info table by choosing
-        one of a standard family of info tables, whose entry code just
-        bombs out.
-
-        [NB In the parallel world (c) is needed regardless because
-        we enter functions with free vars via the closure.]
-
-        If (c) is retained, then we'll sometimes generate an info table
-        (for storage mgr purposes) without slow-entry code.  Then we need
-        to use an error label in the info table to substitute for the absent
-        slow entry code.
--}
-
-staticClosureRequired
-        :: Name
-        -> StgBinderInfo
-        -> LambdaFormInfo
-        -> Bool
-staticClosureRequired binder bndr_info
-                      (LFReEntrant top_level _ _ _ _)        -- It's a function
-  = ASSERT( isTopLevel top_level )
-        -- Assumption: it's a top-level, no-free-var binding
-        not (satCallsOnly bndr_info)
-
-staticClosureRequired binder other_binder_info other_lf_info = True
--}
-
------------------------------------------------------------------------------
 --              Data types for closure information
 -----------------------------------------------------------------------------
 
@@ -748,12 +661,15 @@ data ClosureInfo
     }
 
 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
-mkCmmInfo :: ClosureInfo -> CmmInfoTable
-mkCmmInfo ClosureInfo {..}
+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
+mkCmmInfo ClosureInfo {..} id ccs
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = if isStaticRep closureSMRep
+                                then Just (id,ccs)
+                                else Nothing }
 
 --------------------------------------
 --        Building ClosureInfos
@@ -816,7 +732,7 @@ blackHoleOnEntry cl_info
 {- Note [Black-holing non-updatable thunks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must not black-hole non-updatable (single-entry) thunks otherwise
-we run into issues like Trac #10414. Specifically:
+we run into issues like #10414. Specifically:
 
   * There is no reason to black-hole a non-updatable thunk: it should
     not be competed for by multiple threads
@@ -829,7 +745,7 @@ we run into issues like Trac #10414. Specifically:
      - is not updated (of course)
      - hence, if it is black-holed and another thread tries to evaluate
        it, that thread will block forever
-    This actually happened in Trac #10414.  So we do not black-hole
+    This actually happened in #10414.  So we do not black-hole
     non-updatable thunks.
 
   * How could two threads evaluate the same non-updatable (single-entry)
@@ -839,7 +755,7 @@ we run into issues like Trac #10414. Specifically:
     thunk, because lazy black-holing only affects thunks with an
     update frame on the stack.
 
-Here is and example due to Reid Barton (Trac #10414):
+Here is and example due to Reid Barton (#10414):
     x = \u []  concat [[1], []]
 with the following definitions,
 
@@ -1001,10 +917,9 @@ enterIdLabel dflags id c
 mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
 mkProfilingInfo dflags id val_descr
   | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
-  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
   where
-    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))
-    val_descr_w8 = stringToWord8s val_descr
+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))
 
 getTyDescription :: Type -> String
 getTyDescription ty
@@ -1013,15 +928,15 @@ getTyDescription ty
       TyVarTy _              -> "*"
       AppTy fun _            -> getTyDescription fun
       TyConApp tycon _       -> getOccString tycon
-      FunTy _ res            -> '-' : '>' : fun_result res
+      FunTy {}              -> '-' : fun_result tau_ty
       ForAllTy _  ty         -> getTyDescription ty
       LitTy n                -> getTyLitDescription n
       CastTy ty _            -> getTyDescription ty
       CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
     }
   where
-    fun_result (FunTy _ res) = '>' : fun_result res
-    fun_result other         = getTyDescription other
+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res
+    fun_result other                    = getTyDescription other
 
 getTyLitDescription :: TyLit -> String
 getTyLitDescription l =
@@ -1038,7 +953,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
-                , cit_srt  = NoC_SRT }
+                , cit_srt  = Nothing
+                , cit_clo  = Nothing }
  where
    name = dataConName data_con
    info_lbl = mkConInfoTableLabel name NoCafRefs
@@ -1050,8 +966,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
    prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
         | otherwise                            = ProfilingInfo ty_descr val_descr
 
-   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
-   val_descr = stringToWord8s $ occNameString $ getOccName data_con
+   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
+   val_descr = BS8.pack $ occNameString $ getOccName data_con
 
 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
 -- want to allocate the black hole on entry to a CAF.
@@ -1061,14 +977,16 @@ cafBlackHoleInfoTable
   = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
                  , cit_rep  = blackHoleRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 indStaticInfoTable :: CmmInfoTable
 indStaticInfoTable
   = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
                  , cit_rep  = indStaticRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
@@ -1079,4 +997,4 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- of the SRT.
 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+  | otherwise              = has_srt