%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
@CgCon@, which deals with constructors.
\begin{code}
-#include "HsVersions.h"
+module CgClosure ( cgTopRhsClosure,
+ cgStdRhsClosure,
+ cgRhsClosure,
+ ) where
-module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
+#include "HsVersions.h"
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop2) ( cgExpr )
+import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
-import AbsCSyn
-import StgSyn
-
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgBindery ( getCAddrMode, getArgAmodes,
- getCAddrModeAndInfo, bindNewToNode,
- bindNewToAStack, bindNewToBStack,
- bindNewToReg, bindArgsToRegs,
- stableAmodeIdInfo, heapIdInfo, CgIdInfo
- )
-import CgCompInfo ( spARelToInt, spBRelToInt )
+import CgBindery
import CgUpdate ( pushUpdateFrame )
-import CgHeapery ( allocDynClosure, heapCheck
- , heapCheckOnly, fetchAndReschedule, yield -- HWL
- )
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
- CtrlReturnConvention(..), DataReturnConvention(..)
- )
-import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
- adjustRealSps
- )
-import CgUsages ( getVirtSps, setRealAndVirtualSps,
- getSpARelOffset, getSpBRelOffset,
- getHpRelOffset
- )
-import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
- mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
- mkErrorStdEntryLabel, mkRednCountsLabel
- )
+import CgHeapery
+import CgStackery
+import CgUsages
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
-import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
- noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre, showCostCentre
- )
-import HeapOffs ( SYN_IE(VirtualHeapOffset) )
-import Id ( idType, idPrimRep,
- showId, getIdStrictness, dataConTag,
- emptyIdSet,
- GenId{-instance Outputable-}
- )
+
+import AbsCUtils ( getAmodeRep, mkAbstractCs )
+import AbsCSyn
+import CLabel
+
+import StgSyn
+import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
+import CostCentre
+import Id ( Id, idName, idType, idPrimRep )
+import Name ( Name, isInternalName )
+import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import Maybes ( maybeToBool )
-import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
-import PrimRep ( isFollowableRep, PrimRep(..) )
-import TyCon ( isPrimTyCon, tyConDataCons )
-import Unpretty ( uppShow )
-import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
-
-myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
-showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
-getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
+import PrimRep ( PrimRep(..), getPrimRepSize )
+import Util ( isIn, splitAtList )
+import CmdLineOpts ( opt_SccProfilingOn )
+import Outputable
+import FastString
+
+import Name ( nameOccName )
+import OccName ( occNameFS )
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
+import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
+import Maybe
\end{code}
%********************************************************
\begin{code}
cgTopRhsClosure :: Id
- -> CostCentre -- Optional cost centre annotation
+ -> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure name cc binder_info args body lf_info
- = -- LAY OUT THE OBJECT
+cgTopRhsClosure id ccs binder_info srt args body lf_info
+ =
+ let
+ name = idName id
+ in
+ -- LAY OUT THE OBJECT
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
let
- closure_info = layOutStaticNoFVClosure name lf_info
+ name = idName id
+ descr = closureDescription mod_name name
+ closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
+ closure_label = mkClosureLabel name
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
in
+ -- BUILD THE OBJECT (IF NECESSARY)
+ (
+ ({- if staticClosureRequired name binder_info lf_info
+ then -}
+ absC (mkStaticClosure closure_label closure_info ccs [] True)
+ {- else
+ nopC -}
+ )
+ `thenC`
+
-- GENERATE THE INFO TABLE (IF NECESSARY)
forkClosureBody (closureCodeBody binder_info closure_info
- cc args body)
- `thenC`
+ ccs args body)
- -- BUILD VAP INFO TABLES IF NECESSARY
- -- Don't build Vap info tables etc for
- -- a function whose result is an unboxed type,
- -- because we can never have thunks with such a type.
- (if closureReturnsUnboxedType closure_info then
- nopC
- else
- let
- bind_the_fun = addBindC name cg_id_info -- It's global!
- in
- cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
) `thenC`
- -- BUILD THE OBJECT (IF NECESSARY)
- (if staticClosureRequired name binder_info lf_info
- then
- let
- cost_centre = mkCCostCentre cc
- in
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- cost_centre
- []) -- No fields
- else
- nopC
- ) `thenC`
+ returnFC (id, cg_id_info)
- returnFC (name, cg_id_info)
- where
- closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
\end{code}
%********************************************************
For closures with free vars, allocate in heap.
-===================== OLD PROBABLY OUT OF DATE COMMENTS =============
-
--- Closures which (a) have no fvs and (b) have some args (i.e.
--- combinator functions), are allocated statically, just as if they
--- were top-level closures. We can't get a space leak that way
--- (because they are HNFs) and it saves allocation.
-
--- Lexical Scoping: Problem
--- These top level function closures will be inherited, possibly
--- to a different cost centre scope set before entering.
-
--- Evaluation Scoping: ok as already in HNF
-
--- Should rely on floating mechanism to achieve this floating to top level.
--- As let floating will avoid floating which breaks cost centre attribution
--- everything will be OK.
-
--- Disabled: because it breaks lexical-scoped cost centre semantics.
--- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
--- = cgTopRhsClosure binder cc bi upd_flag args body
-
-===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
-
\begin{code}
-cgRhsClosure :: Id
- -> CostCentre -- Optional cost centre annotation
- -> StgBinderInfo
- -> [Id] -- Free vars
- -> [Id] -- Args
- -> StgExpr
- -> LambdaFormInfo
- -> FCode (Id, CgIdInfo)
-
-cgRhsClosure binder cc binder_info fvs args body lf_info
- | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
- -- ToDo: check non-primitiveness (ASSERT)
+cgStdRhsClosure
+ :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> StgExpr
+ -> LambdaFormInfo
+ -> [StgArg] -- payload
+ -> FCode (Id, CgIdInfo)
+
+cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
+ -- AHA! A STANDARD-FORM THUNK
= (
-- LAY OUT THE OBJECT
- getArgAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes payload `thenFC` \ amodes ->
+ moduleName `thenFC` \ mod_name ->
let
+ descr = closureDescription mod_name (idName binder)
+
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep amodes lf_info
+ = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
+ -- No SRT for a standard-form closure
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
+
-- BUILD THE OBJECT
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
)
-- RETURN
returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
- where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
\end{code}
Here's the general case.
+
\begin{code}
-cgRhsClosure binder cc binder_info fvs args body lf_info
+cgRhsClosure :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo
+ -> SRT
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> StgExpr
+ -> LambdaFormInfo
+ -> FCode (Id, CgIdInfo)
+
+cgRhsClosure binder cc binder_info srt fvs args body lf_info
= (
-- LAY OUT THE OBJECT
--
reduced_fvs = if binder_is_a_fv
then fvs `minusList` [binder]
else fvs
+
+ name = idName binder
in
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
+
+ mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
let
- fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
+ descr = closureDescription mod_name (idName binder)
closure_info :: ClosureInfo
- bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
+ bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, bind_details)
- = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
+ = layOutDynClosure binder get_kind
+ fvs_w_amodes_and_info lf_info srt_info descr
- bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
+ bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
- amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
+ amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
- get_kind (id, amode_and_info) = idPrimRep id
+ get_kind (id, _, _) = idPrimRep id
in
+
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
-- Bind the fvs
closureCodeBody binder_info closure_info cc args body
) `thenC`
- -- BUILD VAP INFO TABLES IF NECESSARY
- -- Don't build Vap info tables etc for
- -- a function whose result is an unboxed type,
- -- because we can never have thunks with such a type.
- (if closureReturnsUnboxedType closure_info then
- nopC
- else
- cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
- ) `thenC`
-
-- BUILD THE OBJECT
let
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
returnFC (binder, heapIdInfo binder heap_offset lf_info)
\end{code}
-@cgVapInfoTables@ generates both Vap info tables, if they are required
-at all. It calls @cgVapInfoTable@ to generate each Vap info table,
-along with its entry code.
-
-\begin{code}
--- Don't generate Vap info tables for thunks; only for functions
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
- = nopC
-
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
- = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
- (if stdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
- else
- nopC
- ) `thenC`
-
- -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
- (if noUpdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
- else
- nopC
- )
-
- where
- fun_in_payload = not top_level
-
-cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
- = let
- -- The vap_entry_rhs is a manufactured STG expression which
- -- looks like the RHS of any binding which is going to use the vap-entry
- -- point of the function. Each of these bindings will look like:
- --
- -- x = [a,b,c] \upd [] -> f a b c
- --
- -- If f is not top-level, then f is one of the free variables too,
- -- hence "payload_ids" isn't the same as "arg_ids".
- --
- vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
- -- Empty live vars
-
- arg_ids_w_info = [(name,mkLFArgument) | name <- args]
- payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
- | otherwise = arg_ids_w_info
-
- payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
- | otherwise = args
-
- vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
- upd_flag [] vap_entry_rhs
- -- It's not top level, even if we're currently compiling a top-level
- -- function, because any VAP *use* of this function will be for a
- -- local thunk, thus
- -- let x = f p q -- x isn't top level!
- -- in ...
-
- get_kind (id, info) = idPrimRep id
-
- payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
- (closure_info, payload_bind_details) = layOutDynClosure
- fun
- get_kind payload_ids_w_info
- vap_lf_info
- -- The dodgy thing is that we use the "fun" as the
- -- Id to give to layOutDynClosure. This Id gets embedded in
- -- the closure_info it returns. But of course, the function doesn't
- -- have the right type to match the Vap closure. Never mind,
- -- a hack in closureType spots the special case. Otherwise that
- -- Id is just used for label construction, which is OK.
-
- bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
- in
-
- -- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
-
- -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
- -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
- perhaps_bind_the_fun `thenC`
- mapCs bind_fv payload_bind_details `thenC`
-
- -- Generate the info table and code
- closureCodeBody NoStgBinderInfo
- closure_info
- useCurrentCostCentre
- [] -- No args; it's a thunk
- vap_entry_rhs
- )
-\end{code}
%************************************************************************
%* *
\subsection[code-for-closures]{The code for closures}
\begin{code}
closureCodeBody :: StgBinderInfo
- -> ClosureInfo -- Lots of information about this closure
- -> CostCentre -- Optional cost centre attached to closure
+ -> ClosureInfo -- Lots of information about this closure
+ -> CostCentreStack -- Optional cost centre attached to closure
-> [Id]
-> StgExpr
-> Code
There are two main cases for the code for closures. If there are {\em
no arguments}, then the closure is a thunk, and not in normal form.
-So it should set up an update frame (if it is shared). Also, it has
-no argument satisfaction check, so fast and slow entry-point labels
-are the same.
+So it should set up an update frame (if it is shared).
\begin{code}
closureCodeBody binder_info closure_info cc [] body
= -- thunks cannot have a primitive type!
-#ifdef DEBUG
- let
- (has_tycon, tycon)
- = case (closureType closure_info) of
- Nothing -> (False, panic "debug")
- Just (tc,_,_) -> (True, tc)
- in
- if has_tycon && isPrimTyCon tycon then
- pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
- else
-#endif
getAbsC body_code `thenFC` \ body_absC ->
- moduleName `thenFC` \ mod_name ->
- absC (CClosureInfoAndCode closure_info body_absC Nothing
- stdUpd (cl_descr mod_name)
- (dataConLiveness closure_info))
+ absC (CClosureInfoAndCode closure_info body_absC)
where
- cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
+ is_box = case body of { StgApp fun [] -> True; _ -> False }
- body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
- body_code = profCtrC SLIT("ENT_THK") [] `thenC`
+ ticky_ent_lit = if (isStaticClosure closure_info)
+ then FSLIT("TICK_ENT_STATIC_THK")
+ else FSLIT("TICK_ENT_DYN_THK")
+
+ body_code = profCtrC ticky_ent_lit [] `thenC`
+ -- node always points when profiling, so this is ok:
+ ldvEnter `thenC`
thunkWrapper closure_info (
- -- We only enter cc after setting up update so that cc
- -- of enclosing scope will be recorded in update frame
- -- CAF/DICT functions will be subsumed by this enclosing cc
- enterCostCentreCode closure_info cc IsThunk `thenC`
- cgExpr body)
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
+ enterCostCentreCode closure_info cc IsThunk is_box `thenC`
+ cgExpr body
+ )
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
-If there is {\em at least one argument}, then this closure is in
-normal form, so there is no need to set up an update frame. On the
-other hand, we do have to check that there are enough args, and
-perform an update if not!
+If there is /at least one argument/, then this closure is in
+normal form, so there is no need to set up an update frame.
The Macros for GrAnSim are produced at the beginning of the
argSatisfactionCheck (by calling fetchAndReschedule). There info if
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention id lf_info
- (map idPrimRep all_args) `thenFC` \ entry_conv ->
- let
- is_concurrent = opt_ForConcurrent
+ = let arg_reps = map idPrimRep all_args in
- stg_arity = length all_args
+ getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
- -- Arg mapping for standard (slow) entry point; all args on stack
- (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- all_args
-
- -- Arg mapping for the fast entry point; as many args as poss in
+ let
+ -- Arg mapping for the entry point; as many args as poss in
-- registers; the rest on the stack
-- arg_regs are the registers used for arg passing
-- stk_args are the args which are passed on the stack
--
+ -- Args passed on the stack are not tagged.
+ --
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- ViaNode | is_concurrent -> []
- other -> panic "closureCodeBody:arg_regs"
-
- num_arg_regs = length arg_regs
-
- (reg_args, stk_args) = splitAt num_arg_regs all_args
-
- (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- stk_args
-
- -- HWL; Note: empty list of live regs in slow entry code
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
- -- where node = VanillaReg PtrRep 1
- --slow_entry_code = forceHeapCheck [] True slow_entry_code'
-
- slow_entry_code
- = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
-
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToAStack all_bxd_w_offsets `thenC`
- mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_all_args spB_all_args `thenC`
-
- argSatisfactionCheck closure_info all_args `thenC`
-
- -- OK, so there are enough args. Now we need to stuff as
- -- many of them in registers as the fast-entry code
- -- expects Note that the zipWith will give up when it hits
- -- the end of arg_regs.
-
- mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
- absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
-
- -- Now adjust real stack pointers
- adjustRealSps spA_stk_args spB_stk_args `thenC`
-
- absC (CFallThrough (CLbl fast_label CodePtrRep))
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
- -- HWL
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
-
- fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrRep,
- CString (_PK_ (showId PprDebug id)),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit spA_stk_args, -- # passed on A stk
- mkIntCLit spB_stk_args, -- B stk (rest in regs)
- CString (_PK_ (map (showTypeCategory . idType) all_args)),
- CString (_PK_ (show_wrapper_name wrapper_maybe)),
- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
- ] `thenC`
+ _ -> panic "closureCodeBody"
+ in
+
+ -- If this function doesn't have a specialised ArgDescr, we need
+ -- to generate the function's arg bitmap, slow-entry code, and
+ -- register-save code for the heap-check failure
+ --
+ (case closureFunInfo closure_info of
+ Just (_, ArgGen slow_lbl liveness) ->
+ absC (maybeLargeBitmap liveness) `thenC`
+ absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
+ returnFC (mkRegSaveCode arg_regs arg_reps)
+
+ other -> returnFC AbsCNop
+ )
+ `thenFC` \ reg_save_code ->
+
+ -- get the current virtual Sp (it might not be zero, eg. if we're
+ -- compiling a let-no-escape).
+ getVirtSp `thenFC` \vSp ->
+
+ let
+ (reg_args, stk_args) = splitAtList arg_regs all_args
+
+ (sp_stk_args, stk_offsets)
+ = mkVirtStkOffsets vSp idPrimRep stk_args
+
+ entry_code = do
+ mod_name <- moduleName
+ profCtrC FSLIT("TICK_CTR") [
+ CLbl ticky_ctr_label DataPtrRep,
+ mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
+ mkIntCLit stg_arity, -- total # of args
+ mkIntCLit sp_stk_args, -- # passed on stk
+ mkCString (mkFastString (map (showTypeCategory . idType) all_args))
+ ]
+ let prof =
+ profCtrC ticky_ent_lit [
+ CLbl ticky_ctr_label DataPtrRep
+ ]
-- Bind args to regs/stack as appropriate, and
- -- record expected position of sps
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
- mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
+ -- record expected position of sps.
+ bindArgsToRegs reg_args arg_regs
+ mapCs bindNewToStack stk_offsets
+ setRealAndVirtualSp sp_stk_args
-- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction `thenC`
+ enterCostCentreCode closure_info cc IsFunction False
-- Do the business
- funWrapper closure_info arg_regs (cgExpr body)
+ funWrapper closure_info arg_regs reg_save_code
+ (prof >> cgExpr body)
in
- -- Make a labelled code-block for the slow and fast entry code
- forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
- `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
- -- Now either construct the info table, or put the fast code in alone
- -- (We never have slow code without an info table)
- absC (
- if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
- stdUpd (cl_descr mod_name)
- (dataConLiveness closure_info)
- else
- CCodeBlock fast_label fast_abs_c
+ setTickyCtrLabel ticky_ctr_label (
+
+ forkAbsC entry_code `thenFC` \ entry_abs_c ->
+ moduleName `thenFC` \ mod_name ->
+
+ -- Now construct the info table
+ absC (CClosureInfoAndCode closure_info entry_abs_c)
)
where
+ ticky_ctr_label = mkRednCountsLabel name
+
+ ticky_ent_lit =
+ if (isStaticClosure closure_info)
+ then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
+ else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
+
+ stg_arity = length all_args
lf_info = closureLFInfo closure_info
- cl_descr mod_name = closureDescription mod_name id all_args body
+ -- Manufacture labels
+ name = closureName closure_info
- -- Figure out what is needed and what isn't
- slow_code_needed = slowFunEntryCodeRequired id binder_info
- info_table_needed = funInfoTableRequired id binder_info lf_info
- -- Manufacture labels
- id = closureId closure_info
+-- When printing the name of a thing in a ticky file, we want to
+-- give the module name even for *local* things. We print
+-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
+ppr_for_ticky_name mod_name name
+ | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
+ | otherwise = showSDocDebug (ppr name)
+\end{code}
- fast_label = fastLabelFromCI closure_info
+The "slow entry" code for a function. This entry point takes its
+arguments on the stack. It loads the arguments into registers
+according to the calling convention, and jumps to the function's
+normal entry point. The function's closure is assumed to be in
+R1/node.
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
+The slow entry point is used in two places:
- wrapper_maybe = get_ultimate_wrapper Nothing id
- where
- get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
- = case (myWrapperMaybe x) of
- Nothing -> deflt
- Just xx -> get_ultimate_wrapper (Just xx) xx
+ (a) unknown calls: eg. stg_PAP_entry
+ (b) returning from a heap-check failure
- show_wrapper_name Nothing = ""
- show_wrapper_name (Just xx) = showId PprDebug xx
+\begin{code}
+mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
+mkSlowEntryCode name lbl regs reps
+ = CCodeBlock lbl (
+ mkAbstractCs [assts, stk_adj, jump]
+ )
+ where
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
+
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
+ stk_final_offset = head (drop (length regs) stk_offsets)
+
+ jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
+
+mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
+mkRegSaveCode regs reps
+ = mkAbstractCs [stk_adj, assts]
+ where
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
- show_wrapper_arg_kinds Nothing = ""
- show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
- Nothing -> ""
- Just str -> str
+ stk_final_offset = head (drop (length regs) stk_offsets)
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
\end{code}
For lexically scoped profiling we have to load the cost centre from
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
---#ifdef DEBUG
+-- #ifdef DEBUG
deriving Eq
---#endif
+-- #endif
-enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
+enterCostCentreCode
+ :: ClosureInfo -> CostCentreStack
+ -> IsThunk
+ -> Bool -- is_box: this closure is a special box introduced by SCCfinal
+ -> Code
-enterCostCentreCode closure_info cc is_thunk
- = costCentresFlag `thenFC` \ profiling_on ->
- if not profiling_on then
+enterCostCentreCode closure_info ccs is_thunk is_box
+ = if not opt_SccProfilingOn then
nopC
else
- ASSERT(not (noCostCentreAttached cc))
-
- if costsAreSubsumed cc then
- --ASSERT(isToplevClosure closure_info)
- --ASSERT(is_thunk == IsFunction)
- (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
- costCentresC SLIT("ENTER_CC_FSUB") []
-
- else if currentOrSubsumedCosts cc then
- -- i.e. current; subsumed dealt with above
- -- get CCC out of the closure, where we put it when we alloc'd
- case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
- IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
-
- else if isCafCC cc && isToplevClosure closure_info then
+ ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
+
+ if isSubsumedCCS ccs then
+ ASSERT(isToplevClosure closure_info)
+ ASSERT(is_thunk == IsFunction)
+ costCentresC FSLIT("ENTER_CCS_FSUB") []
+
+ else if isDerivedFromCurrentCCS ccs then
+ if re_entrant && not is_box
+ then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
+ else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
+
+ else if isCafCCS ccs then
+ ASSERT(isToplevClosure closure_info)
ASSERT(is_thunk == IsThunk)
- costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
-
- else -- we've got a "real" cost centre right here in our hands...
- case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
- IsFunction -> if isCafCC cc || isDictCC cc
- then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
- else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
-%* *
-%************************************************************************
-
-The argument-satisfaction check code is placed after binding
-the arguments to their stack locations. Hence, the virtual stack
-pointer is pointing after all the args, and virtual offset 1 means
-the base of frame and hence most distant arg. Hence
-virtual offset 0 is just beyond the most distant argument; the
-relative offset of this word tells how many words of arguments
-are expected.
-
-\begin{code}
-argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
-
-argSatisfactionCheck closure_info [] = nopC
+ -- might be a PAP, in which case we want to subsume costs
+ if re_entrant
+ then costCentresC FSLIT("ENTER_CCS_FSUB") []
+ else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
-argSatisfactionCheck closure_info args
- = -- safest way to determine which stack last arg will be on:
- -- look up CAddrMode that last arg is bound to;
- -- getAmodeRep;
- -- check isFollowableRep.
+ else panic "enterCostCentreCode"
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- let
- emit_gran_macros = opt_GranMacros
- in
-
- -- HWL ngo' ngoq:
- -- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if emit_gran_macros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- getCAddrMode (last args) `thenFC` \ last_amode ->
-
- if (isFollowableRep (getAmodeRep last_amode)) then
- getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
- let
- a_rel_int = spARelToInt spA off
- a_rel_arg = mkIntCLit a_rel_int
- in
- ASSERT(a_rel_int /= 0)
- if node_points then
- absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
- else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
- else
- getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
- let
- b_rel_int = spBRelToInt spB off
- b_rel_arg = mkIntCLit b_rel_int
- in
- ASSERT(b_rel_int /= 0)
- if node_points then
- absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
- else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
- where
- -- We must tell the arg-satis macro whether Node is pointing to
- -- the closure or not. If it isn't so pointing, then we give to
- -- the macro the (static) address of the closure.
-
- set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
+ where
+ c_ccs = [mkCCostCentreStack ccs]
+ re_entrant = closureReEntrant closure_info
\end{code}
%************************************************************************
thunkWrapper:: ClosureInfo -> Code -> Code
thunkWrapper closure_info thunk_code
= -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- let
- emit_gran_macros = opt_GranMacros
+ nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ (if opt_GranMacros
+ then if node_points
+ then fetchAndReschedule [] node_points
+ else yield [] node_points
+ else absC AbsCNop) `thenC`
+
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
in
- -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
- -- (we prefer fetchAndReschedule-style context switches to yield ones)
- (if emit_gran_macros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
- -- heapCheck must be after stackCheck: if stchk fails
- -- new stack space is allocated from the heap which
- -- would violate any previous heapCheck
-
- heapCheck [] node_points ( -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ -- stack and/or heap checks
+ thunkChecks closure_lbl (
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info node_points `thenC`
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-- Finally, do the business
thunk_code
- )))
+ ))
funWrapper :: ClosureInfo -- Closure whose code body this is
-> [MagicId] -- List of argument registers (if any)
+ -> AbstractC -- reg saves for the heap check failure
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs fun_body
+funWrapper closure_info arg_regs reg_save_code fun_body
= -- Stack overflow check
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- let
- emit_gran_macros = opt_GranMacros
- in
- -- HWL chu' ngoq:
- (if emit_gran_macros
- then yield arg_regs node_points
- else absC AbsCNop) `thenC`
-
- stackCheck closure_info arg_regs node_points (
- -- stackCheck *encloses* the rest
-
- heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
-
- -- Finally, do the business
- fun_body
- ))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
-%* *
-%************************************************************************
-
-Assumption: virtual and real stack pointers are currently exactly aligned.
-
-\begin{code}
-stackCheck :: ClosureInfo
- -> [MagicId] -- Live registers
- -> Bool -- Node required to point after check?
- -> Code
- -> Code
+ nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-stackCheck closure_info regs node_reqd code
- = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
+ -- enter for Ldv profiling
+ (if node_points then ldvEnter else nopC) `thenC`
- getVirtSps `thenFC` \ (vSpA, vSpB) ->
+ (if opt_GranMacros
+ then yield arg_regs node_points
+ else absC AbsCNop) `thenC`
- let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
- b_headroom_reqd = bHw - vSpB
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
in
- absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
- AbsCNop
- else
- CMacroStmt STK_CHK [mkIntCLit liveness_mask,
- mkIntCLit a_headroom_reqd,
- mkIntCLit b_headroom_reqd,
- mkIntCLit vSpA,
- mkIntCLit vSpB,
- mkIntCLit (if returns_prim_type then 1 else 0),
- mkIntCLit (if node_reqd then 1 else 0)]
- )
- -- The test is *inside* the absC, to avoid black holes!
-
- `thenC` code
- )
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
+ -- heap and/or stack checks
+ funEntryChecks closure_lbl reg_save_code (
- returns_prim_type = closureReturnsUnboxedType closure_info
+ -- Finally, do the business
+ fun_body
+ )
\end{code}
+
%************************************************************************
%* *
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
\begin{code}
-blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
-blackHoleIt closure_info
- = noBlackHolingFlag `thenFC` \ no_black_holing ->
+blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
- if (blackHoleOnEntry no_black_holing closure_info)
+blackHoleIt closure_info node_points
+ = if blackHoleOnEntry closure_info && node_points
then
+ let
+ info_label = infoTableLabelFromCI closure_info
+ args = [ CLbl info_label DataPtrRep ]
+ in
absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
+ CMacroStmt UPD_BH_SINGLE_ENTRY args
else
- CMacroStmt UPD_BH_UPDATABLE [CReg node])
- -- Node always points to it; see stg-details
+ CMacroStmt UPD_BH_UPDATABLE args)
else
nopC
\end{code}
\begin{code}
-setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
+setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent ENTER_CC_TCL
+-- I've tidied up the code for this function, but it should still do the same as
+-- it did before (modulo ticky stuff). KSW 1999-04.
setupUpdate closure_info code
- = if (closureUpdReqd closure_info) then
- link_caf_if_needed `thenFC` \ update_closure ->
- pushUpdateFrame update_closure vector code
+ = if closureReEntrant closure_info
+ then
+ code
else
- profCtrC SLIT("UPDF_OMITTED") [] `thenC`
- code
+ case (closureUpdReqd closure_info, isStaticClosure closure_info) of
+ (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (False,True ) -> (if opt_DoTickyProfiling
+ then
+ -- blackhole the SE CAF
+ link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
+ else
+ nopC) `thenC`
+ profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
+ profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (True ,False) -> pushUpdateFrame (CReg node) code
+ (True ,True ) -> -- blackhole the (updatable) CAF:
+ link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
+ profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
+ pushUpdateFrame update_closure code
where
- link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
- link_caf_if_needed
- = if not (isStaticClosure closure_info) then
- returnFC (CReg node)
- else
-
- -- First we must allocate a black hole, and link the
- -- CAF onto the CAF list
-
- -- Alloc black hole specifying CC_HDR(Node) as the cost centre
- -- Hack Warning: Using a CLitLit to get CAddrMode !
- let
- use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
- blame_cc = use_cc
- in
- allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
- `thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
- let amode = CAddr hp_rel
- in
- absC (CMacroStmt UPD_CAF [CReg node, amode])
- `thenC`
- returnFC amode
-
- vector
- = case (closureType closure_info) of
- Nothing -> CReg StdUpdRetVecReg
- Just (spec_tycon, _, spec_datacons) ->
- case (ctrlReturnConvAlg spec_tycon) of
- UnvectoredReturn 1 ->
- let
- spec_data_con = head spec_datacons
- only_tag = dataConTag spec_data_con
-
- direct = case (dataReturnConvAlg spec_data_con) of
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
- ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
-
- vectored = mkStdUpdVecTblLabel spec_tycon
- in
- CUnVecLbl direct vectored
-
- UnvectoredReturn _ -> CReg StdUpdRetVecReg
- VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
+ cl_name :: FastString
+ cl_name = (occNameFS . nameOccName . closureName) closure_info
+
+ link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
+ -> FCode CAddrMode -- Returns amode for closure to be updated
+ link_caf bhCI
+ = -- To update a CAF we must allocate a black hole, link the CAF onto the
+ -- CAF list, then update the CAF to point to the fresh black hole.
+ -- This function returns the address of the black hole, so it can be
+ -- updated with the new value when available.
+
+ -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+ let
+ use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
+ blame_cc = use_cc
+ in
+ allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
+ getHpRelOffset heap_offset `thenFC` \ hp_rel ->
+ let amode = CAddr hp_rel
+ in
+ absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
+ returnFC amode
\end{code}
%************************************************************************
binding information.
\begin{code}
-closureDescription :: FAST_STRING -- Module
- -> Id -- Id of closure binding
- -> [Id] -- Args
- -> StgExpr -- Body
+closureDescription :: Module -- Module
+ -> Name -- Id of closure binding
-> String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-closureDescription mod_name name args body
- = uppShow 0 (prettyToUn (
- ppBesides [ppChar '<',
- ppPStr mod_name,
- ppChar '.',
- ppr PprDebug name,
- ppChar '>']))
+closureDescription mod_name name
+ = showSDoc (
+ hcat [char '<',
+ pprModule mod_name,
+ char '.',
+ ppr name,
+ char '>'])
\end{code}
-
+
\begin{code}
-chooseDynCostCentres cc args fvs body
+chooseDynCostCentres ccs args fvs body
= let
use_cc -- cost-centre we record in the object
- = if currentOrSubsumedCosts cc
+ = if currentOrSubsumedCCS ccs
then CReg CurCostCentre
- else mkCCostCentre cc
+ else mkCCostCentreStack ccs
blame_cc -- cost-centre on whom we blame the allocation
= case (args, fvs, body) of
- ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
- | just1 == fun
- -> mkCCostCentre overheadCostCentre
+ ([], _, StgApp fun [{-no args-}])
+ -> mkCCostCentreStack overheadCCS
_ -> use_cc
-- if it's an utterly trivial RHS, then it must be
-- one introduced by boxHigherOrderArgs for profiling,
-- so we charge it to "OVERHEAD".
+
+ -- This looks like a HACK to me --SDM
in
(use_cc, blame_cc)
\end{code}
+
+
+\begin{code}
+showTypeCategory :: Type -> Char
+ {-
+ {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case tcSplitTyConApp_maybe ty of
+ Nothing -> if isJust (tcSplitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if isJust (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
+\end{code}
projects / ghc-hetmet.git / blobdiff