%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgClosure.lhs,v 1.33 1999/06/24 13:04:17 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
@CgCon@, which deals with constructors.
\begin{code}
-#include "HsVersions.h"
-
-module CgClosure (
- cgTopRhsClosure, cgRhsClosure,
+module CgClosure ( cgTopRhsClosure,
+ cgStdRhsClosure,
+ cgRhsClosure,
+ closureCodeBody ) where
- -- and to make the interface self-sufficient...
- StgExpr, Id, CgState, Maybe, HeapOffset,
- CgInfoDownwards, CgIdInfo, CompilationInfo,
- UpdateFlag
- ) where
+#include "HsVersions.h"
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty -- NB: see below
+import {-# SOURCE #-} CgExpr ( cgExpr )
-import StgSyn
import CgMonad
import AbsCSyn
+import StgSyn
-import AbsPrel ( PrimOp(..), primOpNameInfo, Name
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( isPrimType, isPrimTyCon,
- getTauType, showTypeCategory, getTyConDataCons
- IF_ATTACK_PRAGMAS(COMMA splitType)
- IF_ATTACK_PRAGMAS(COMMA splitTyArgs)
- )
-import CgBindery ( getCAddrMode, getAtomAmodes,
- getCAddrModeAndInfo,
- bindNewToNode, bindNewToAStack, bindNewToBStack,
- bindNewToReg, bindArgsToRegs
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getCAddrMode, getArgAmodes,
+ getCAddrModeAndInfo, bindNewToNode,
+ bindNewToStack,
+ bindNewToReg, bindArgsToRegs,
+ stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import CgCompInfo ( spARelToInt, spBRelToInt )
-import CgExpr ( cgExpr, cgSccExpr )
import CgUpdate ( pushUpdateFrame )
-import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , heapCheckOnly, fetchAndReschedule -- HWL
-#endif {- GRAN -}
- )
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import CgHeapery ( allocDynClosure,
+ fetchAndReschedule, yield, -- HWL
+ fastEntryChecks, thunkChecks
)
-import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
- adjustRealSps
+import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
+import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
+ getSpRelOffset, getHpRelOffset
)
-import CgUsages ( getVirtSps, setRealAndVirtualSps,
- getSpARelOffset, getSpBRelOffset,
- getHpRelOffset
+import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
+ mkRednCountsLabel, mkInfoTableLabel
)
-import CLabelInfo
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( GlobalSwitch(..) )
-import CostCentre
-import Id ( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe,
- showId, getIdInfo, getIdStrictness,
- getDataConTag
- )
-import IdInfo
+import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
+import CostCentre
+import Id ( Id, idName, idType, idPrimRep )
+import Name ( Name )
+import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import Maybes ( Maybe(..), maybeToBool )
-import PrimKind ( isFollowableKind )
-import UniqSet
-import Unpretty
-import Util
+import PrimRep ( PrimRep(..) )
+import PprType ( showTypeCategory )
+import Util ( isIn )
+import CmdLineOpts ( opt_SccProfilingOn )
+import Outputable
+
+import Name ( nameOccName )
+import OccName ( occNameFS )
+
+getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
%********************************************************
\begin{code}
cgTopRhsClosure :: Id
- -> CostCentre -- Optional cost centre annotation
+ -> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> [Id] -- Args
- -> PlainStgExpr
+ -> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-\end{code}
-\begin{code}
-{- NOT USED:
-cgTopRhsClosure name cc binder_info args body lf_info
- | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
- let
- (closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info
- in
-
- -- BUILD THE OBJECT
- chooseStaticCostCentre cc lf_info `thenFC` \ cost_centre ->
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- cost_centre
- (map fst amodes_w_offsets)) -- They are in the correct order
- ) `thenC`
-
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
- where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
-
- closure_label = mkClosureLabel name
--}
-\end{code}
-
-The general case:
-\begin{code}
-cgTopRhsClosure name cc binder_info args body lf_info
+cgTopRhsClosure id ccs binder_info args body lf_info
= -- LAY OUT THE OBJECT
let
closure_info = layOutStaticNoFVClosure name lf_info
in
-
- -- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (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
- 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
+ ({- if staticClosureRequired name binder_info lf_info
+ then -}
+ (if opt_SccProfilingOn
+ then
+ absC (CStaticClosure
closure_label -- Labelled with the name on lhs of defn
closure_info
- cost_centre
+ (mkCCostCentreStack ccs)
[]) -- No fields
- else
- nopC
+ else
+ absC (CStaticClosure
+ closure_label -- Labelled with the name on lhs of defn
+ closure_info
+ (panic "absent cc")
+ []) -- No fields
+ )
+
+ {- else
+ nopC -}
+ `thenC`
+
+ -- GENERATE THE INFO TABLE (IF NECESSARY)
+ forkClosureBody (closureCodeBody binder_info closure_info
+ ccs args body)
+
) `thenC`
- returnFC (name, cg_id_info)
+ returnFC (id, cg_id_info)
where
+ name = idName id
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info
+ cg_id_info = stableAmodeIdInfo id (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
- -> PlainStgExpr
- -> 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
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeKind amodes lf_info
+ = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
-- BUILD THE OBJECT
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- )
+ )
`thenFC` \ heap_offset ->
-- RETURN
returnFC (binder, heapIdInfo binder heap_offset lf_info)
where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
+ is_std_thunk = isStandardFormThunk lf_info
\end{code}
Here's the general case.
+
\begin{code}
+cgRhsClosure :: Id
+ -> CostCentreStack -- 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
= (
-- LAY OUT THE OBJECT
let
is_elem = isIn "cgRhsClosure"
- binder_is_a_fv = binder `is_elem` fvs
- reduced_fvs = if binder_is_a_fv
- then fvs `minusList` [binder]
- else fvs
+ binder_is_a_fv = binder `is_elem` fvs
+ reduced_fvs = if binder_is_a_fv
+ then fvs `minusList` [binder]
+ else fvs
in
mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
let
bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
(closure_info, bind_details)
- = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
+ = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
- get_kind (id, amode_and_info) = getIdKind id
+ get_kind (id, amode_and_info) = idPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
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 (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet
- -- 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) = getIdKind 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]
- -> PlainStgExpr
+ -> StgExpr
-> Code
\end{code}
\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 ->
-#ifndef DPH
- moduleName `thenFC` \ mod_name ->
- absC (CClosureInfoAndCode closure_info body_absC Nothing stdUpd (cl_descr mod_name))
-#else
- -- Applying a similar scheme to Simon's placing info tables before code...
- -- ToDo:DPH: update
- absC (CNativeInfoTableAndCode closure_info
- closure_description
- (CCodeBlock entry_label body_absC))
-#endif {- Data Parallel Haskell -}
- where
- cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
-
- body_addr = CLbl (entryLabelFromCI closure_info) CodePtrKind
- body_code = profCtrC SLIT("ENT_THK") [] `thenC`
- enterCostCentreCode closure_info cc IsThunk `thenC`
- thunkWrapper closure_info (cgSccExpr body)
+ getAbsC body_code `thenFC` \ body_absC ->
+ moduleName `thenFC` \ mod_name ->
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
+ absC (CClosureInfoAndCode closure_info body_absC Nothing
+ (cl_descr mod_name))
+ where
+ cl_descr mod_name = closureDescription mod_name (closureName closure_info)
+
+ body_label = entryLabelFromCI closure_info
+ is_box = case body of { StgApp fun [] -> True; _ -> False }
+
+ body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
+ thunkWrapper closure_info body_label (
+ -- 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)
\end{code}
If there is {\em at least one argument}, then this closure is in
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention id lf_info
- (map getIdKind all_args) `thenFC` \ entry_conv ->
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
-
- isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
+ = getEntryConvention name lf_info
+ (map idPrimRep all_args) `thenFC` \ entry_conv ->
+ -- get the current virtual Sp (it might not be zero, eg. if we're
+ -- compiling a let-no-escape).
+ getVirtSp `thenFC` \vSp ->
let
- stg_arity = length all_args
+ -- Figure out what is needed and what isn't
+
+ -- SDM: need everything for now in case the heap/stack check refers
+ -- to it. (ToDo)
+ slow_code_needed = True
+ --slowFunEntryCodeRequired name binder_info entry_conv
+ info_table_needed = True
+ --funInfoTableRequired name binder_info lf_info
- -- 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
- getIdKind
- all_args
+ -- Arg mapping for standard (slow) entry point; all args on stack,
+ -- with tagging.
+ (sp_all_args, arg_offsets, arg_tags)
+ = mkTaggedVirtStkOffsets vSp idPrimRep all_args
- -- Arg mapping for the fast entry point; as many args as poss in
+ -- Arg mapping for the fast 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 tagged, but the tags may not
+ -- actually be present (just gaps) if the function is called
+ -- by jumping directly to the fast entry point.
+ --
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- ViaNode | is_concurrent -> []
- other -> panic "closureCodeBody:arg_regs"
+ other -> panic "closureCodeBody:arg_regs"
+
+ num_arg_regs = length arg_regs
+
+ (reg_args, stk_args) = splitAt num_arg_regs all_args
- stk_args = drop (length 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
- getIdKind
- stk_args
+ (sp_stk_args, stk_offsets, stk_tags)
+ = mkTaggedVirtStkOffsets vSp 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 PtrKind 1
+ -- where node = UnusedReg 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`
-
- -- set the arity checker, if asked
- absC (
- if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
-
-#ifndef DPH
- absC (CFallThrough (CLbl fast_label CodePtrKind))
-#else
- -- Fall through to the fast entry point
- absC (AbsCNop)
-#endif {- Data Parallel Haskell -}
+ = profCtrC SLIT("TICK_ENT_FUN_STD") [] `thenC`
+
+ -- Bind args, and record expected position of stk ptrs
+ mapCs bindNewToStack arg_offsets `thenC`
+ setRealAndVirtualSp sp_all_args `thenC`
+
+ argSatisfactionCheck closure_info `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 (no need to adjust Hp,
+ -- but call this function for convenience).
+ adjustSpAndHp sp_stk_args `thenC`
+
+ absC (CFallThrough (CLbl fast_label CodePtrRep))
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-- see argSatisfactionCheck for new version
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
- fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrKind,
- CString (_PK_ (showId PprDebug id)),
+ fast_entry_code
+ = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+ CLbl (mkRednCountsLabel name) PtrRep,
+ mkCString (_PK_ (showSDoc (ppr name))),
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 . getIdUniType) all_args)),
- CString (_PK_ (show_wrapper_name wrapper_maybe)),
- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+ mkIntCLit sp_stk_args, -- # passed on stk
+ mkCString (_PK_ (map (showTypeCategory . idType) all_args))
] `thenC`
- absC (
- if do_arity_chks
- then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
+
+-- Nuked for now; see comment at end of file
+-- CString (_PK_ (show_wrapper_name wrapper_maybe)),
+-- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+
-- Bind args to regs/stack as appropriate, and
- -- record expected position of sps
- bindArgsToRegs all_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 `thenC`
+ mapCs bindNewToStack stk_offsets `thenC`
+ setRealAndVirtualSp sp_stk_args `thenC`
+
+ -- free up the stack slots containing tags
+ freeStackSlots (map fst stk_tags) `thenC`
-- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction `thenC`
+ enterCostCentreCode closure_info cc IsFunction False `thenC`
-- Do the business
- funWrapper closure_info arg_regs (cgExpr body)
+ funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
in
-#ifndef DPH
-- 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 ->
+ 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)
+ -- XXX probably need the info table and slow entry code in case of
+ -- a heap check failure.
absC (
- if info_table_needed
- then
- CClosureInfoAndCode closure_info slow_abs_c
- (Just fast_abs_c) stdUpd (cl_descr mod_name)
- else
+ if info_table_needed then
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+ (cl_descr mod_name)
+ else
CCodeBlock fast_label fast_abs_c
)
-
- where
-#else
- -- The info table goes before the slow entry point.
- forkAbsC slow_entry_code `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
- absC (CNativeInfoTableAndCode
- closure_info
- (closureDescription mod_name id all_args body)
- (CCodeBlock slow_label
- (AbsCStmts slow_abs_c
- (CCodeBlock fast_label
- fast_abs_c))))
where
- slow_label = if slow_code_needed then
- mkStdEntryLabel id
- else
- mkErrorStdEntryLabel
- -- We may need a pointer to stuff in the info table,
- -- but if the slow entry code isn't needed, this code
- -- will never be entered, so we can use a standard
- -- panic routine.
-
-#endif {- Data Parallel Haskell -}
-
+ stg_arity = length all_args
lf_info = closureLFInfo closure_info
- cl_descr mod_name = closureDescription mod_name id all_args body
-
- -- 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
+ cl_descr mod_name = closureDescription mod_name name
-- Manufacture labels
- id = closureId closure_info
-
- fast_label = fastLabelFromCI closure_info
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
-
- 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
-
- show_wrapper_name Nothing = ""
- show_wrapper_name (Just xx) = showId PprDebug xx
-
- show_wrapper_arg_kinds Nothing = ""
- show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
- Nothing -> ""
- Just str -> str
+ name = closureName closure_info
+ fast_label = mkFastEntryLabel name stg_arity
+ info_label = mkInfoTableLabel name
\end{code}
For lexically scoped profiling we have to load the cost centre from
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
-
-enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
-
-enterCostCentreCode closure_info cc is_thunk
- = costCentresFlag `thenFC` \ profiling_on ->
- if not profiling_on then
+-- #ifdef DEBUG
+ deriving Eq
+-- #endif
+
+enterCostCentreCode
+ :: ClosureInfo -> CostCentreStack
+ -> IsThunk
+ -> Bool -- is_box: this closure is a special box introduced by SCCfinal
+ -> Code
+
+enterCostCentreCode closure_info ccs is_thunk is_box
+ = if not opt_SccProfilingOn then
nopC
- else -- down to business
- ASSERT(not (noCostCentreAttached cc))
-
- if costsAreSubsumed cc then
- nopC
-
- else if is_current_CC cc then -- fish the CC out of the closure,
- -- where we put it when we alloc'd;
- -- NB: chk defn of "is_current_CC"
- -- if you go to change this! (WDP 94/12)
- costCentresC
- (case is_thunk of
- IsThunk -> SLIT("ENTER_CC_TCL")
- IsFunction -> SLIT("ENTER_CC_FCL"))
- [CReg node]
-
- else if isCafCC cc then
- costCentresC
- SLIT("ENTER_CC_CAF")
- [mkCCostCentre cc]
-
- else -- we've got a "real" cost centre right here in our hands...
- costCentresC
- (case is_thunk of
- IsThunk -> SLIT("ENTER_CC_T")
- IsFunction -> SLIT("ENTER_CC_F"))
- [mkCCostCentre cc]
- where
- is_current_CC cc
- = currentOrSubsumedCosts cc
- -- but we've already ruled out "subsumed", so it must be "current"!
+ else
+ ASSERT(not (noCCSAttached ccs))
+
+ if isSubsumedCCS ccs then
+ ASSERT(isToplevClosure closure_info)
+ ASSERT(is_thunk == IsFunction)
+ costCentresC SLIT("ENTER_CCS_FSUB") []
+
+ else if isCurrentCCS ccs then
+ if re_entrant && not is_box
+ then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
+ else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
+
+ else if isCafCCS ccs then
+ ASSERT(isToplevClosure closure_info)
+ ASSERT(is_thunk == IsThunk)
+ -- might be a PAP, in which case we want to subsume costs
+ if re_entrant
+ then costCentresC SLIT("ENTER_CCS_FSUB") []
+ else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
+
+ else panic "enterCostCentreCode"
+
+ where
+ c_ccs = [mkCCostCentreStack ccs]
+ re_entrant = closureReEntrant closure_info
\end{code}
%************************************************************************
are expected.
\begin{code}
-argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
+argSatisfactionCheck :: ClosureInfo -> Code
-argSatisfactionCheck closure_info [] = nopC
+argSatisfactionCheck closure_info
-argSatisfactionCheck closure_info args
- = -- safest way to determine which stack last arg will be on:
- -- look up CAddrMode that last arg is bound to;
- -- getAmodeKind;
- -- check isFollowableKind.
+ = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+ let
+ emit_gran_macros = opt_GranMacros
+ in
-#ifdef GRAN
- -- HWL:
+ -- HWL ngo' ngoq:
-- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
-
- getCAddrMode (last args) `thenFC` \ last_amode ->
-
- if (isFollowableKind (getAmodeKind last_amode)) then
- getSpARelOffset 0 `thenFC` \ a_rel_offset ->
- if node_points then
- absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)])
- else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
- [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
- else
- getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
+ -- 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`
+
+ getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
+ let
+ off = I# sp
+ rel_arg = mkIntCLit off
+ in
+ ASSERT(off /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
+ absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
- [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_LOAD_NODE [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) PtrKind
+ set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-thunkWrapper:: ClosureInfo -> Code -> Code
-thunkWrapper closure_info thunk_code
+thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
+thunkWrapper closure_info label thunk_code
= -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
-#ifdef GRAN
- -- HWL insert macros for GrAnSim if node is live here
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
+ nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
-
- -- Must be after stackCheck: if stchk fails new stack
- -- space has to be allocated from the heap
+ let
+ emit_gran_macros = opt_GranMacros
+ 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`
- heapCheck [] node_points (
- -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ -- stack and/or heap checks
+ thunkChecks label node_points (
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info node_points `thenC`
- -- Push update frame if necessary
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-
- -- Evaluation scoping -- load current cost centre from closure
- -- Must be done after the update frame is pushed
- -- Node is guaranteed to point to it, if profiling
--- OLD:
--- (if isStaticClosure closure_info
--- then evalCostCentreC "SET_CAFCC_CL" [CReg node]
--- else evalCostCentreC "ENTER_CC_TCL" [CReg node]) `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)
+ -> [(VirtualSpOffset,Int)] -- tagged stack slots
+ -> CLabel -- info table for heap check ret.
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs fun_body
+funWrapper closure_info arg_regs stk_tags info_label fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
- stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ -- HWL chu' ngoq:
+ (if emit_gran_macros
+ then yield arg_regs node_points
+ else absC AbsCNop) `thenC`
- -- Heap overflow check
- heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
+ -- heap and/or stack checks
+ fastEntryChecks arg_regs stk_tags info_label node_points (
-- 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
-
-stackCheck closure_info regs node_reqd code
- = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
-
- getVirtSps `thenFC` \ (vSpA, vSpB) ->
-
- let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
- b_headroom_reqd = bHw - vSpB
- 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 = mkLiveRegsBitMask all_regs
-
- returns_prim_type = closureReturnsUnboxedType closure_info
\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
absC (if closureSingleEntry(closure_info) then
CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
else
CMacroStmt UPD_BH_UPDATABLE [CReg node])
- -- Node always points to it; see stg-details
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
- -- Non-updatable thunks still need a resume-cost-centre "update"
- -- frame to be pushed if we are doing evaluation profiling.
-
---OLD: evalPushRCCFrame False {-never primitive-} (
- profCtrC SLIT("UPDF_OMITTED") []
- `thenC`
- code
--- )
+ case (closureUpdReqd closure_info, isStaticClosure closure_info) of
+ (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (False,True ) -> (if opt_DoTickyProfiling
+ then
+ -- blackhole the SE CAF
+ link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
+ else
+ nopC) `thenC`
+ profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
+ profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (True ,False) -> pushUpdateFrame (CReg node) code
+ (True ,True ) -> -- blackhole the (updatable) CAF:
+ link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
+ profCtrC SLIT("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)") PtrKind
- 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
-
- closure_label = mkClosureLabel (closureId closure_info)
-
- 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 = getDataConTag 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) DataPtrKind
+ cl_name :: FAST_STRING
+ 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
+ -- Hack Warning: Using a CLitLit to get CAddrMode !
+ let
+ use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
+ 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
- -> PlainStgExpr -- 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 (StgVarAtom 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}
+
+
+
+========================================================================
+OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
+
+It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
+
+\begin{pseudocode}
+getWrapperArgTypeCategories
+ :: Type -- wrapper's type
+ -> StrictnessInfo bdee -- strictness info about its args
+ -> Maybe String
+
+getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
+getWrapperArgTypeCategories _ BottomGuaranteed
+ = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
+getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
+
+getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
+ = Just (mkWrapperArgTypeCategories ty arg_info)
+
+mkWrapperArgTypeCategories
+ :: Type -- wrapper's type
+ -> [Demand] -- info about its arguments
+ -> String -- a string saying lots about the args
+
+mkWrapperArgTypeCategories wrapper_ty wrap_info
+ = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
+ map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
+ where
+ -- ToDo: this needs FIXING UP (it was a hack anyway...)
+ do_one (WwPrim, _) = 'P'
+ do_one (WwEnum, _) = 'E'
+ do_one (WwStrict, arg_ty_char) = arg_ty_char
+ do_one (WwUnpack _ _ _, arg_ty_char)
+ = if arg_ty_char `elem` "CIJFDTS"
+ then toLower arg_ty_char
+ else if arg_ty_char == '+' then 't'
+ else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
+ do_one (other_wrap_info, _) = '-'
+\end{pseudocode}
+
projects / ghc-hetmet.git / blobdiff