%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
performReturn,
mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
mkPrimReturnCode,
-
- tailCallBusiness,
- -- and to make the interface self-sufficient...
- StgAtom, Id, CgState, CAddrMode, TyCon,
- CgInfoDownwards, HeapOffset, Maybe
+ tailCallBusiness
) where
-IMPORT_Trace
-import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
-import Outputable
+import Ubiq{-uitous-}
-import StgSyn
import CgMonad
import AbsCSyn
-import AbsUniType ( isPrimType, UniType )
-import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgCompInfo ( oTHER_TAG, iND_TAG )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
+import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
+ ctrlReturnConvAlg, CtrlReturnConvention(..),
+ DataReturnConvention(..)
)
import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabelInfo ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
-import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getDataConTyCon, getDataConTag,
- getIdUniType, getIdKind, fIRST_TAG, Id,
- ConTag(..)
+import CgUsages ( getSpARelOffset )
+import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import ClosureInfo ( nodeMustPointToIt,
+ getEntryConvention, EntryConvention(..)
)
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimKind ( retKindSize )
-import Util
+import CmdLineOpts ( opt_DoSemiTagging )
+import HeapOffs ( zeroOff, VirtualSpAOffset(..) )
+import Id ( idType, dataConTyCon, dataConTag,
+ fIRST_TAG
+ )
+import Literal ( mkMachInt )
+import Maybes ( assocMaybe )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) )
+import Type ( isPrimType )
+import Util ( zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
+cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
\end{code}
Here's the code we generate for a tail call. (NB there may be no
top of the B stack.
\begin{code}
-cgTailCall (StgLitAtom lit) [] live_vars
+cgTailCall (StgLitArg lit) [] live_vars
= performPrimReturn (CLit lit) live_vars
\end{code}
Case for unboxed @Ids@ first:
\begin{code}
-cgTailCall atom@(StgVarAtom fun) [] live_vars
- | isPrimType (getIdUniType fun)
+cgTailCall atom@(StgVarArg fun) [] live_vars
+ | isPrimType (idType fun)
= getCAddrMode fun `thenFC` \ amode ->
performPrimReturn amode live_vars
\end{code}
The general case (@fun@ is boxed):
\begin{code}
-cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
+cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
\end{code}
%************************************************************************
\begin{code}
performPrimReturn :: CAddrMode -- The thing to return
- -> PlainStgLiveVars
+ -> StgLiveVars
-> Code
performPrimReturn amode live_vars
= let
- kind = getAmodeKind amode
+ kind = getAmodeRep amode
ret_reg = dataReturnConvPrim kind
assign_possibly = case kind of
- VoidKind -> AbsCNop
+ VoidRep -> AbsCNop
kind -> (CAssign (CReg ret_reg) amode)
in
performReturn assign_possibly mkPrimReturnCode live_vars
mkPrimReturnCode :: Sequel -> Code
---UNUSED:mkPrimReturnCode RestoreCostCentre = panic "mkPrimReturnCode: RCC"
-mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
-mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
- -- Direct, no vectoring
+mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
+mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
+ absC (CReturn dest_amode DirectReturn)
+ -- Direct, no vectoring
-- All constructor arguments in registers; Node and InfoPtr are set.
-- All that remains is
mkStaticAlgReturnCode con maybe_info_lbl sequel
= -- Generate profiling code if necessary
(case return_convention of
- VectoredReturn _ -> profCtrC SLIT("VEC_RETURN") []
- other -> nopC
+ VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
+ other -> nopC
) `thenC`
-- Set tag if necessary
-- Set the info pointer, and jump
set_info_ptr `thenC`
- absC (CJump (CLbl update_label CodePtrKind))
+ absC (CJump (CLbl update_label CodePtrRep))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
-- is going to handle.
case assocMaybe alts tag of
- Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind))
+ Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
Nothing -> panic "mkStaticAlgReturnCode: default"
-- The Nothing case should never happen; it's the subject
-- of a wad of special-case code in cgReturnCon
)
where
- tag = getDataConTag con
- tycon = getDataConTyCon con
+ tag = dataConTag con
+ tycon = dataConTyCon con
return_convention = ctrlReturnConvAlg tycon
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
- -- cf AbsCFuns.mkAlgAltsCSwitch
+ -- cf AbsCUtils.mkAlgAltsCSwitch
- update_label = case dataReturnConvAlg con of
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
+ update_label
+ = case (dataReturnConvAlg con) of
+ ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
+ ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
return_info = case return_convention of
UnvectoredReturn _ -> DirectReturn
set_info_ptr = case maybe_info_lbl of
Nothing -> nopC
- Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind))
+ Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
mkDynamicAlgReturnCode tycon dyn_tag sequel
= case ctrlReturnConvAlg tycon of
- VectoredReturn _ ->
+ VectoredReturn sz ->
- profCtrC SLIT("VEC_RETURN") [] `thenC`
- sequelToAmode sequel `thenFC` \ ret_addr ->
+ profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
+ sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
UnvectoredReturn no_of_constrs ->
-> (Sequel -> Code) -- The code to execute to actually do
-- the return, given an addressing mode
-- for the return address
- -> PlainStgLiveVars
+ -> StgLiveVars
-> Code
performReturn sim_assts finish_code live_vars
= getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts `thenC`
+ doSimAssts args_spa live_vars sim_assts `thenC`
-- Adjust stack pointers
adjustRealSps args_spa args_spb `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
-- depend on stk-ptr values
--- where
---UNUSED: live_regs = getDestinationRegs sim_assts
- -- ToDo: this is a *really* boring way to compute the
- -- live-reg set!
\end{code}
\begin{code}
performTailCall :: Id -- Function
- -> [PlainStgAtom] -- Args
- -> PlainStgLiveVars
+ -> [StgArg] -- Args
+ -> StgLiveVars
-> Code
performTailCall fun args live_vars
= -- Get all the info we have about the function and args and go on to
-- the business end
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
tailCallBusiness
fun fun_amode lf_info arg_amodes
tailCallBusiness :: Id -> CAddrMode -- Function and its amode
-> LambdaFormInfo -- Info about the function
-> [CAddrMode] -- Arguments
- -> PlainStgLiveVars -- Live in continuation
+ -> StgLiveVars -- Live in continuation
-> AbstractC -- Pending simultaneous assignments
-- *** GUARANTEED to contain only stack assignments.
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_TAILCALL") IntKind] `thenC`
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ = nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
- (map getAmodeKind arg_amodes) `thenFC` \ entry_conv ->
+ (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
CAssign (CReg infoptr)
- (CMacroExpr DataPtrKind INFO_PTR [CReg node]),
- CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
+ (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
])
- StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind))
- StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
+ StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
+ StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
`mkAbsCStmts`
- CJump (CLbl lbl CodePtrKind))
+ CJump (CLbl lbl CodePtrRep))
DirectEntry lbl arity regs ->
- (regs, (if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit arity]
- else AbsCNop)
- `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
+ (regs, CJump (CLbl lbl CodePtrRep))
no_of_args = length arg_amodes
-{- UNUSED: live_regs = if node_points then
- node : arg_regs
- else
- arg_regs
--}
- (reg_arg_assts, stk_arg_amodes)
- = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes),
- drop (length arg_regs) arg_amodes) -- No regs, or
- -- args beyond arity
+ (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
+ -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
+ reg_arg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
+ assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
in
case fun_amode of
CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
`thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
-- Do the simultaneous assignments,
- doSimAssts join_spa live_vars {-UNUSED: live_regs-}
+ doSimAssts join_spa live_vars
(mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
`thenC`
-- Make instruction to save return address
loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
-
+
mkStkAmodes args_spa args_spb stk_arg_amodes
`thenFC`
\ (final_spa, final_spb, stk_arg_assts) ->
-- on top, is recorded in final_spb.
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED: live_regs-}
+ doSimAssts args_spa live_vars
(mkAbstractCs [pending_assts, node_asst, ret_asst,
reg_arg_assts, stk_arg_assts])
`thenC`
adjustRealSps final_spa final_spb `thenC`
-- Now decide about semi-tagging
- isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
+ let
+ semi_tagging_on = opt_DoSemiTagging
+ in
case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
-- Here, lit.3 is built as a re-entrant thing, which you must enter.
-- (OK, the simplifier should have eliminated this, but it's
-- easy to deal with the case anyway.)
-
-
let
join_details_to_code (load_regs_and_profiling_code, join_lbl)
= load_regs_and_profiling_code `mkAbsCStmts`
- CJump (CLbl join_lbl CodePtrKind)
+ CJump (CLbl join_lbl CodePtrRep)
semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
join_details_to_code join_details)
| (tag, join_details) <- st_alts
]
- -- This alternative is for the unevaluated case; oTHER_TAG is -1
- un_evald_alt = (mkMachInt oTHER_TAG, enter_jump)
-
- enter_jump = CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
+ enter_jump
-- Enter Node (we know infoptr will have the info ptr in it)!
-
+ = mkAbstractCs [
+ CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
+ [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
in
-
-- Final switch
absC (mkAbstractCs [
CAssign (CReg infoptr)
- (CVal (NodeRel zeroOff) DataPtrKind),
+ (CVal (NodeRel zeroOff) DataPtrRep),
case maybe_deflt_join_details of
Nothing ->
- CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(enter_jump)
Just (_, details) ->
- CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
[(mkMachInt 0, enter_jump)]
(CSwitch
- (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(join_details_to_code details))
])
\begin{code}
doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
- -> PlainStgLiveVars -- Live in continuation
---UNUSED: -> [MagicId] -- Live regs (ptrs and non-ptrs)
+ -> StgLiveVars -- Live in continuation
-> AbstractC
-> Code
-doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
+doSimAssts tail_spa live_vars sim_assts
= -- Do the simultaneous assignments
absC (CSimultaneous sim_assts) `thenC`
where
stub_A_slot :: VirtualSpAOffset -> Code
stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
- absC (CAssign (CVal spa_rel PtrKind)
+ absC (CAssign (CVal spa_rel PtrRep)
(CReg StkStubReg))
\end{code}
projects / ghc-hetmet.git / blobdiff