+%
+% (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 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 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 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 Outputable
+\end{code}
+
+This module provides the support code for @StgToAbstractC@ to deal
+with STG {\em expressions}. See also @CgClosure@, which deals
+with closures, and @CgCon@, which deals with constructors.
+
+\begin{code}
+cgExpr :: StgExpr -- input
+ -> Code -- output
+\end{code}
+
+%********************************************************
+%* *
+%* Tail calls *
+%* *
+%********************************************************
+
+``Applications'' mean {\em tail calls}, a service provided by module
+@CgTailCall@. This includes literals, which show up as
+@(STGApp (StgLitArg 42) [])@.
+
+\begin{code}
+cgExpr (StgApp fun args) = cgTailCall fun args
+\end{code}
+
+%********************************************************
+%* *
+%* STG ConApps (for inline versions) *
+%* *
+%********************************************************
+
+\begin{code}
+cgExpr (StgConApp con args)
+ = do { amodes <- getArgAmodes args
+ ; cgReturnDataCon con amodes }
+\end{code}
+
+Literals are similar to constructors; they return by putting
+themselves in an appropriate register and returning to the address on
+top of the stack.
+
+\begin{code}
+cgExpr (StgLit lit)
+ = do { cmm_lit <- cgLit lit
+ ; performPrimReturn rep (CmmLit cmm_lit) }
+ where
+ rep = typeCgRep (literalType lit)
+\end{code}
+
+
+%********************************************************
+%* *
+%* PrimOps and foreign calls.
+%* *
+%********************************************************
+
+NOTE about "safe" foreign calls: a safe foreign call is never compiled
+inline in a case expression. When we see
+
+ case (ccall ...) of { ... }
+
+We generate a proper return address for the alternatives and push the
+stack frame before doing the call, so that in the event that the call
+re-enters the RTS the stack is in a sane state.
+
+\begin{code}
+cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
+ {-
+ First, copy the args into temporaries. We're going to push
+ a return address right before doing the call, so the args
+ must be out of the way.
+ -}
+ reps_n_amodes <- getArgAmodes stg_args
+ let
+ -- Get the *non-void* args, and jiggle them with shimForeignCall
+ arg_exprs = [ shimForeignCallArg stg_arg expr
+ | (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
+ {-
+ 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
+ arg_hints emptyVarSet{-no live vars-}
+
+-- tagToEnum# is special: we need to pull the constructor out of the table,
+-- and perform an appropriate return.
+
+cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
+ = ASSERT(isEnumerationTyCon tycon)
+ do { (_,amode) <- getArgAmode arg
+ ; amode' <- assignTemp amode -- We're going to use it twice,
+ -- so save in a temp if non-trivial
+ ; hmods <- getHomeModules
+ ; stmtC (CmmAssign nodeReg (tagToClosure hmods tycon amode'))
+ ; performReturn (emitAlgReturnCode tycon amode') }
+ where
+ -- If you're reading this code in the attempt to figure
+ -- out why the compiler panic'ed here, it is probably because
+ -- you used tagToEnum# in a non-monomorphic setting, e.g.,
+ -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
+ -- That won't work.
+ tycon = tyConAppTyCon res_ty
+
+
+cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
+ | primOpOutOfLine primop
+ = tailCallPrimOp primop args
+
+ | ReturnsPrim VoidRep <- result_info
+ = do cgPrimOp [] primop args emptyVarSet
+ performReturn emitDirectReturnInstr
+
+ | ReturnsPrim rep <- result_info
+ = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
+ primop args emptyVarSet
+ performReturn emitDirectReturnInstr
+
+ | 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))
+
+ | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
+ -- c.f. cgExpr (...TagToEnumOp...)
+ = do tag_reg <- newTemp wordRep
+ hmods <- getHomeModules
+ cgPrimOp [tag_reg] primop args emptyVarSet
+ stmtC (CmmAssign nodeReg (tagToClosure hmods tycon (CmmReg tag_reg)))
+ performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
+ where
+ result_info = getPrimOpResultInfo primop
+\end{code}
+
+%********************************************************
+%* *
+%* Case expressions *
+%* *
+%********************************************************
+Case-expression conversion is complicated enough to have its own
+module, @CgCase@.
+\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
+\end{code}
+
+
+%********************************************************
+%* *
+%* Let and letrec *
+%* *
+%********************************************************
+\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
+
+\begin{code}
+cgExpr (StgLet (StgNonRec name rhs) expr)
+ = cgRhs name rhs `thenFC` \ (name, info) ->
+ addBindC name info `thenC`
+ cgExpr expr
+
+cgExpr (StgLet (StgRec pairs) expr)
+ = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
+ listFCs [ cgRhs b e | (b,e) <- pairs ]
+ ) `thenFC` \ new_bindings ->
+
+ addBindsC new_bindings `thenC`
+ cgExpr expr
+\end{code}
+
+\begin{code}
+cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
+ = do { -- Figure out what volatile variables to save
+ ; nukeDeadBindings live_in_whole_let
+ ; (save_assts, rhs_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_rhss
+
+ -- Save those variables right now!
+ ; emitStmts save_assts
+
+ -- Produce code for the rhss
+ -- and add suitable bindings to the environment
+ ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info
+ maybe_cc_slot bindings
+
+ -- Do the body
+ ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
+\end{code}
+
+
+%********************************************************
+%* *
+%* SCC Expressions *
+%* *
+%********************************************************
+
+SCC expressions are treated specially. They set the current cost
+centre.
+
+\begin{code}
+cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
+\end{code}
+
+%********************************************************
+%* *
+%* Non-top-level bindings *
+%* *
+%********************************************************
+\subsection[non-top-level-bindings]{Converting non-top-level bindings}
+
+We rely on the support code in @CgCon@ (to do constructors) and
+in @CgClosure@ (to do closures).
+
+\begin{code}
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+ -- the Id is passed along so a binding can be set up
+
+cgRhs name (StgRhsCon maybe_cc con args)
+ = do { amodes <- getArgAmodes args
+ ; idinfo <- buildDynCon name maybe_cc con amodes
+ ; returnFC (name, idinfo) }
+
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
+ = do hmods <- getHomeModules
+ mkRhsClosure hmods name cc bi srt fvs upd_flag args body
+\end{code}
+
+mkRhsClosure looks for two special forms of the right-hand side:
+ a) selector thunks.
+ b) AP thunks
+
+If neither happens, it just calls mkClosureLFInfo. You might think
+that mkClosureLFInfo should do all this, but it seems wrong for the
+latter to look at the structure of an expression
+
+Selectors
+~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep. We are looking for a closure of {\em exactly} the
+form:
+
+... = [the_fv] \ u [] ->
+ case the_fv of
+ con a_1 ... a_n -> a_i
+
+
+\begin{code}
+mkRhsClosure hmods bndr cc bi srt
+ [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,
+ (StgApp selectee [{-no args-}]))])
+ | the_fv == scrutinee -- Scrutinee is the only free variable
+ && maybeToBool maybe_offset -- Selectee is a component of the tuple
+ && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
+ = -- NOT TRUE: ASSERT(is_single_constructor)
+ -- The simplifier may have statically determined that the single alternative
+ -- is the only possible case and eliminated the others, even if there are
+ -- 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]
+ where
+ lf_info = mkSelectorLFInfo bndr offset_into_int
+ (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr hmods con (addIdReps params)
+ -- Just want the layout
+ maybe_offset = assocMaybe params_w_offsets selectee
+ Just the_offset = maybe_offset
+ offset_into_int = the_offset - fixedHdrSize
+\end{code}
+
+Ap thunks
+~~~~~~~~~
+
+A more generic AP thunk of the form
+
+ x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
+
+A set of these is compiled statically into the RTS, so we just use
+those. We could extend the idea to thunks where some of the x_i are
+global ids (and hence not free variables), but this would entail
+generating a larger thunk. It might be an option for non-optimising
+compilation, though.
+
+We only generate an Ap thunk if all the free variables are pointers,
+for semi-obvious reasons.
+
+\begin{code}
+mkRhsClosure hmods bndr cc bi srt
+ fvs
+ upd_flag
+ [] -- No args; a thunk
+ body@(StgApp fun_id args)
+
+ | args `lengthIs` (arity-1)
+ && all isFollowableArg (map idCgRep fvs)
+ && isUpdatable upd_flag
+ && arity <= mAX_SPEC_AP_SIZE
+
+ -- Ha! an Ap thunk
+ = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
+
+ where
+ lf_info = mkApLFInfo bndr upd_flag arity
+ -- the payload has to be in the correct order, hence we can't
+ -- just use the fvs.
+ payload = StgVarArg fun_id : args
+ arity = length fvs
+\end{code}
+
+The default case
+~~~~~~~~~~~~~~~~
+\begin{code}
+mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body
+ = cgRhsClosure bndr cc bi srt fvs upd_flag args body
+\end{code}
+
+
+%********************************************************
+%* *
+%* Let-no-escape bindings
+%* *
+%********************************************************
+\begin{code}
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
+ (StgNonRec binder rhs)
+ = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
+ maybe_cc_slot
+ NonRecursive binder rhs
+ ; addBindC binder info }
+
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
+ = do { new_bindings <- fixC (\ new_bindings -> do
+ { addBindsC new_bindings
+ ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss
+ rhs_eob_info maybe_cc_slot Recursive b e
+ | (b,e) <- pairs ] })
+
+ ; addBindsC new_bindings }
+ 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])
+
+cgLetNoEscapeRhs
+ :: StgLiveVars -- Live in rhss
+ -> EndOfBlockInfo
+ -> Maybe VirtualSpOffset
+ -> RecFlag
+ -> Id
+ -> StgRhs
+ -> FCode (Id, CgIdInfo)
+
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+ (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
+ maybe_cc_slot rec args body
+
+-- For a constructor RHS we want to generate a single chunk of code which
+-- can be jumped to from many places, which will return the constructor.
+-- 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
+ full_live_in_rhss rhs_eob_info maybe_cc_slot rec
+ [] --No args; the binder is data structure, not a function
+ (StgConApp con args)
+\end{code}
+
+Little helper for primitives that return unboxed tuples.
+
+\begin{code}
+newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
+newUnboxedTupleRegs res_ty =
+ let
+ ty_args = tyConAppArgs (repType res_ty)
+ (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
+ let rep = typeCgRep ty,
+ nonVoidArg rep ]
+ in do
+ regs <- mapM (newTemp . argMachRep) reps
+ return (reps,regs,hints)
+\end{code}
projects / ghc-hetmet.git / blobdiff