%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.62 2005/06/21 10:44:41 simonmar Exp $
-%
-%********************************************************
-%* *
-\section[CgExpr]{Converting @StgExpr@s}
-%* *
-%********************************************************
\begin{code}
module CgExpr ( cgExpr ) where
#include "HsVersions.h"
-import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
+import Constants
import StgSyn
import CgMonad
-import SMRep ( fixedHdrSize, isFollowableArg, CgRep(..), argMachRep,
- nonVoidArg, idCgRep, typeCgRep, typeHint,
- primRepToCgRep )
-import CoreSyn ( AltCon(..) )
-import CgProf ( emitSetCCC )
-import CgHeapery ( layOutDynConstr )
-import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
- nukeDeadBindings, addBindC, addBindsC )
-import CgCase ( cgCase, saveVolatileVarsAndRegs )
-import CgClosure ( cgRhsClosure, cgStdRhsClosure )
-import CgCon ( buildDynCon, cgReturnDataCon )
-import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgCallConv ( dataReturnConvPrim )
+import CostCentre
+import SMRep
+import CoreSyn
+import CgProf
+import CgHeapery
+import CgBindery
+import CgCase
+import CgClosure
+import CgCon
+import CgLetNoEscape
import CgTailCall
-import CgInfoTbls ( emitDirectReturnInstr )
-import CgForeignCall ( emitForeignCall, shimForeignCallArg )
-import CgPrimOp ( cgPrimOp )
-import CgUtils ( addIdReps, newTemp, assignTemp, cgLit, tagToClosure )
-import ClosureInfo ( mkSelectorLFInfo, mkApLFInfo )
-import Cmm ( CmmExpr(..), CmmStmt(..), CmmReg, nodeReg )
-import MachOp ( wordRep, MachHint )
+import CgInfoTbls
+import CgForeignCall
+import CgPrimOp
+import CgHpc
+import CgUtils
+import ClosureInfo
+import Cmm
+import CmmUtils
import VarSet
-import Literal ( literalType )
-import PrimOp ( primOpOutOfLine, getPrimOpResultInfo,
- PrimOp(..), PrimOpResultInfo(..) )
-import Id ( Id )
-import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, tyConAppArgs, tyConAppTyCon, repType,
- PrimRep(VoidRep) )
-import Maybes ( maybeToBool )
-import ListSetOps ( assocMaybe )
-import BasicTypes ( RecFlag(..) )
-import Util ( lengthIs )
+import Literal
+import PrimOp
+import Id
+import TyCon
+import Type
+import Maybes
+import ListSetOps
+import BasicTypes
+import Util
import Outputable
\end{code}
= do { cmm_lit <- cgLit lit
; performPrimReturn rep (CmmLit cmm_lit) }
where
- rep = typeCgRep (literalType lit)
+ rep = (typeCgRep) (literalType lit)
\end{code}
reps_n_amodes <- getArgAmodes stg_args
let
-- Get the *non-void* args, and jiggle them with shimForeignCall
- arg_exprs = [ shimForeignCallArg stg_arg expr
+ arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg)
| (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
nonVoidArg rep]
- -- in
- arg_tmps <- mapM assignTemp arg_exprs
- let
- arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args)
- -- in
+ arg_tmps <- sequence [ assignTemp arg
+ | (arg, _) <- arg_exprs]
+ let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args)
{-
Now, allocate some result regs.
-}
(res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty
- ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $
- emitForeignCall (zip res_regs res_hints) fcall
+ ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
+ emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall
arg_hints emptyVarSet{-no live vars-}
-- tagToEnum# is special: we need to pull the constructor out of the table,
cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
= ASSERT(isEnumerationTyCon tycon)
- do { (_,amode) <- getArgAmode arg
+ do { (_rep,amode) <- getArgAmode arg
; amode' <- assignTemp amode -- We're going to use it twice,
-- so save in a temp if non-trivial
- ; this_pkg <- getThisPackage
- ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode'))
- ; performReturn (emitAlgReturnCode tycon amode') }
+ ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
+ ; performReturn emitReturnInstr }
where
-- If you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
tycon = tyConAppTyCon res_ty
-cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
+cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
| primOpOutOfLine primop
= tailCallPrimOp primop args
| ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args emptyVarSet
- performReturn emitDirectReturnInstr
+ performReturn emitReturnInstr
| ReturnsPrim rep <- result_info
- = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
- primop args emptyVarSet
- performReturn emitDirectReturnInstr
+ = do res <- newTemp (typeCmmType res_ty)
+ cgPrimOp [res] primop args emptyVarSet
+ performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
| ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
= do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
cgPrimOp regs primop args emptyVarSet{-no live vars-}
- returnUnboxedTuple (zip reps (map CmmReg regs))
+ returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
| ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...)
- = do tag_reg <- newTemp wordRep
- this_pkg <- getThisPackage
+ = do tag_reg <- newTemp bWord -- The tag is a word
cgPrimOp [tag_reg] primop args emptyVarSet
- stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg)))
- performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
+ stmtC (CmmAssign nodeReg
+ (tagToClosure tycon
+ (CmmReg (CmmLocal tag_reg))))
+ performReturn emitReturnInstr
where
result_info = getPrimOpResultInfo primop
+
+cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty)
+ = tailCallPrimCall primcall args
\end{code}
%********************************************************
\begin{code}
cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
- = cgCase expr live_vars save_vars bndr srt alt_type alts
+ = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts
\end{code}
\end{code}
%********************************************************
+%* *
+%* Hpc Tick Boxes *
+%* *
+%********************************************************
+
+\begin{code}
+cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
+\end{code}
+
+%********************************************************
+%* *
+%* Anything else *
+%* *
+%********************************************************
+
+\begin{code}
+cgExpr _ = panic "cgExpr"
+\end{code}
+
+%********************************************************
%* *
%* Non-top-level bindings *
%* *
; returnFC (name, idinfo) }
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = do this_pkg <- getThisPackage
- mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body
+ = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body
\end{code}
mkRhsClosure looks for two special forms of the right-hand side:
\begin{code}
-mkRhsClosure this_pkg bndr cc bi srt
+mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
+ -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id
+ -> FCode (Id, CgIdInfo)
+mkRhsClosure bndr cc bi
[the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
- _ _ _ _ -- ignore uniq, etc.
- (AlgAlt tycon)
- [(DataAlt con, params, use_mask,
+ _ _ _ srt -- ignore uniq, etc.
+ (AlgAlt _)
+ [(DataAlt con, params, _use_mask,
(StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
-- other constructors in the datatype. It's still ok to make a selector
-- thunk in this case, because we *know* which constructor the scrutinee
-- will evaluate to.
- cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
+ setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params)
+ (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
for semi-obvious reasons.
\begin{code}
-mkRhsClosure this_pkg bndr cc bi srt
+mkRhsClosure bndr cc bi
fvs
upd_flag
[] -- No args; a thunk
The default case
~~~~~~~~~~~~~~~~
\begin{code}
-mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body
- = cgRhsClosure bndr cc bi srt fvs upd_flag args body
+mkRhsClosure bndr cc bi fvs upd_flag args body
+ = cgRhsClosure bndr cc bi fvs upd_flag args body
\end{code}
%* *
%********************************************************
\begin{code}
+cgLetNoEscapeBindings :: StgLiveVars -> EndOfBlockInfo
+ -> Maybe VirtualSpOffset -> GenStgBinding Id Id
+ -> Code
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
(StgNonRec binder rhs)
= do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
where
-- We add the binders to the live-in-rhss set so that we don't
-- delete the bindings for the binder from the environment!
- full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,_) <- pairs])
cgLetNoEscapeRhs
:: StgLiveVars -- Live in rhss
-> FCode (Id, CgIdInfo)
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
- (StgRhsClosure cc bi _ upd_flag srt args body)
+ (StgRhsClosure cc bi _ _upd_flag srt args body)
= -- We could check the update flag, but currently we don't switch it off
-- for let-no-escaped things, so we omit the check too!
-- case upd_flag of
-- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
- cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
+ setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
maybe_cc_slot rec args body
-- For a constructor RHS we want to generate a single chunk of code which
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
+ = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
Little helper for primitives that return unboxed tuples.
\begin{code}
-newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
+newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty =
let
ty_args = tyConAppArgs (repType res_ty)
- (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
+ (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
let rep = typeCgRep ty,
nonVoidArg rep ]
+ make_new_temp rep = newTemp (argMachRep rep)
in do
- regs <- mapM (newTemp . argMachRep) reps
+ regs <- mapM make_new_temp reps
return (reps,regs,hints)
\end{code}
projects / ghc-hetmet.git / blobdiff