import AbsCSyn
import CgMonad
-import AbsUniType ( getTyConDataCons, kindFromType,
+import Type ( getTyConDataCons, primRepFromType,
maybeIntLikeTyCon, mkSpecTyCon,
TyVarTemplate, TyCon, Class,
- TauType(..), UniType, ThetaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+ TauType(..), Type, ThetaType(..)
)
import CgHeapery ( heapCheck, allocDynClosure )
import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel,
- --UNUSED: mkInfoTableLabel,
- mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel,
- mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
+import CLabel ( mkConEntryLabel, mkStaticConEntryLabel,
+ mkClosureLabel,
+ mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
mkStdUpdVecTblLabel, CLabel
)
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
infoTableLabelFromCI, dataConLiveness
)
-import CmdLineOpts ( GlobalSwitch(..) )
import FiniteMap
import Id ( getDataConTag, getDataConSig, getDataConTyCon,
mkSameSpecCon,
)
import CgCompInfo ( uF_UPDATEE )
import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( getKindSize, retKindSize )
+import PrimRep ( getPrimRepSize, retPrimRepSize )
import CostCentre
import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import TCE ( rngTCE, TCE(..), UniqFM )
import Util
\end{code}
For every constructor we generate the following info tables:
- A static info table, for static instances of the constructor,
+ A static info table, for static instances of the constructor,
- For constructors which return in registers (and only them),
+ For constructors which return in registers (and only them),
an "inregs" info table. This info table is rather emaciated;
it only contains update code and tag.
the closure tries to get rid of itself.
\item[@con_inregs_info@:]
-Used when returning a new constructor in registers.
+Used when returning a new constructor in registers.
Only for return-in-regs constructors.
Macro: @INREGS_INFO_TABLE@.
\begin{code}
genStaticConBits :: CompilationInfo -- global info about the compilation
-> [TyCon] -- tycons to generate
- -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+ -> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
-> AbstractC -- output
mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
`mkAbsCStmts`
- mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
- | (imported_spec, spec) <- specs,
- -- no code generated if spec is imported
- not imported_spec
- ]
- | (tc, specs) <- fmToList tycon_specs ]
+ mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
+ | (imported_spec, spec) <- specs,
+ -- no code generated if spec is imported
+ not imported_spec
+ ]
+ | (tc, specs) <- fmToList tycon_specs ]
where
gen_for_tycon :: TyCon -> AbstractC
gen_for_tycon tycon
VectoredReturn _ -> CFlatRetVector tycon_upd_label
(map (mk_upd_label tycon) data_cons)
------------------
- gen_for_spec_tycon :: TyCon -> [Maybe UniType] -> AbstractC
+ gen_for_spec_tycon :: TyCon -> [Maybe Type] -> AbstractC
gen_for_spec_tycon tycon ty_maybes
= mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons)
`mkAbsCStmts`
- maybe_spec_tycon_vtbl
+ maybe_spec_tycon_vtbl
where
data_cons = getTyConDataCons tycon
------------------
mk_upd_label tycon con
= CLbl
- (case (dataReturnConvAlg isw_chkr con) of
+ (case (dataReturnConvAlg isw_chkr con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
- CodePtrKind
+ CodePtrRep
where
tag = getDataConTag con
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticClosure data_con kindFromType arg_tys (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
body = (initC comp_info (
profCtrC SLIT("ENT_CON") [CReg node] `thenC`
body_code))
- entry_addr = CLbl entry_label CodePtrKind
+ entry_addr = CLbl entry_label CodePtrRep
con_descr = _UNPK_ (getOccurrenceName data_con)
closure_code = CClosureInfoAndCode closure_info body Nothing
inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
- stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
+ stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
tag = getDataConTag data_con
cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
-- For zero-arity data constructors, or, more accurately,
- -- those which only have VoidKind args (or none):
+ -- those which only have VoidRep args (or none):
-- We make the closure too (not just info tbl), so that we can share
-- one copy throughout.
- closure_maybe = -- OLD: if con_arity /= 0 then
- if not (all zero_size arg_tys) then
+ closure_maybe = if not (all zero_size arg_tys) then
AbsCNop
- else
+ else
CStaticClosure closure_label -- Label for closure
static_ci -- Info table
cost_centre
- [{-No args! A slight lie for constrs with VoidKind args-}]
+ [{-No args! A slight lie for constrs with VoidRep args-}]
- zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0
+ zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
(_,_,arg_tys,_) = getDataConSig data_con
con_arity = getDataConArity data_con
performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyUniqSet{-no live vars-}
in
(closure_info, body_code)
-
+
ReturnInHeap ->
let
(_, _, arg_tys, _) = getDataConSig con
(closure_info, arg_things)
- = layOutDynCon con kindFromType arg_tys
+ = layOutDynCon con primRepFromType arg_tys
body_code
- = -- OLD: We don't set CC when entering data any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC`
+ = -- NB: We don't set CC when entering data (WDP 94/06)
profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
performReturn AbsCNop -- Ptr to thing already in Node
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
+ emptyUniqSet{-no live vars-}
in
(closure_info, body_code)
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
= CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
-\end{code}
+\end{code}
%************************************************************************
%* *
genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
+genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
= case (dataReturnConvAlg isw_chkr data_con) of
- ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
- AbsCNop -- No need for a phantom update
+ ReturnInHeap -> AbsCNop -- No need for a phantom update
- ReturnInRegs regs ->
- --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
- let
- phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
+ ReturnInRegs regs ->
+ let
+ phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
upd_code con_descr
(dataConLiveness isw_chkr phantom_ci)
- phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
-
- con_descr = _UNPK_ (getOccurrenceName data_con)
+ phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
+
+ con_descr = _UNPK_ (getOccurrenceName data_con)
- con_arity = getDataConArity data_con
+ con_arity = getDataConArity data_con
- upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
+ upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = getDataConTag data_con
+ tag = getDataConTag data_con
- updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind
+ updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
- perform_return = mkAbstractCs
- [
- CMacroStmt POP_STD_UPD_FRAME [],
- CReturn (CReg RetReg) return_info
- ]
+ perform_return = mkAbstractCs
+ [
+ CMacroStmt POP_STD_UPD_FRAME [],
+ CReturn (CReg RetReg) return_info
+ ]
- return_info =
- -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) (
+ return_info =
case (ctrlReturnConvAlg tycon) of
UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
- -- )
+ VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
-- Determine cost centre for the updated closures CC (and allocation)
-- CCC for lexical (now your only choice)
use_cc = CReg CurCostCentre -- what to put in the closure
blame_cc = use_cc -- who to blame for allocation
- do_move (reg, virt_offset) =
+ do_move (reg, virt_offset) =
CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
overwrite_code
= profCtrC SLIT("UPD_CON_IN_PLACE")
[mkIntCLit (length regs_w_offsets)] `thenC`
- absC (mkAbstractCs
- [
+ absC (mkAbstractCs
+ [
CAssign (CReg node) updatee,
-- Tell the storage mgr that we intend to update in place
CInitHdr closure_info (NodeRel zeroOff) use_cc True,
mkAbstractCs (map do_move regs_w_offsets),
if con_arity /= 0 then
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
- else
+ CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
+ else
AbsCNop
])
- upd_inplace_macro = if closurePtrsSize closure_info == 0
+ upd_inplace_macro = if closurePtrsSize closure_info == 0
then UPD_INPLACE_NOPTRS
else UPD_INPLACE_PTRS
-- Allocate and build closure specifying upd_new_w_regs
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
`thenFC` \ hp_offset ->
- getHpRelOffset hp_offset `thenFC` \ hp_rel ->
+ getHpRelOffset hp_offset `thenFC` \ hp_rel ->
let
amode = CAddr hp_rel
in
profCtrC SLIT("UPD_CON_IN_NEW")
[mkIntCLit (length amodes_w_offsets)] `thenC`
- absC (mkAbstractCs
+ absC (mkAbstractCs
[ CMacroStmt UPD_IND [updatee, amode],
CAssign (CReg node) amode,
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
+ CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
])
- (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
- info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
+ (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
+ info_label = infoTableLabelFromCI closure_info
+ liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
- build_closure =
+ build_closure =
if fitsMinUpdSize closure_info then
- initC comp_info overwrite_code
+ initC comp_info overwrite_code
else
- initC comp_info (heapCheck regs False alloc_code)
+ initC comp_info (heapCheck regs False alloc_code)
- in CClosureUpdInfo phantom_itbl
+ in CClosureUpdInfo phantom_itbl
\end{code}
projects / ghc-hetmet.git / blobdiff