diff options
Diffstat (limited to 'ghc/compiler/codeGen/CgExpr.lhs')
| -rw-r--r-- | ghc/compiler/codeGen/CgExpr.lhs | 454 |
1 files changed, 0 insertions, 454 deletions
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs deleted file mode 100644 index 33d72f1608..0000000000 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ /dev/null @@ -1,454 +0,0 @@ -% -% (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} |