% % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \begin{code}

    module CgExpr ( cgExpr ) where

    #include "HsVersions.h"

    import Constants
    import StgSyn
    import CgMonad

    import CostCentre
    import SMRep
    import CoreSyn
    import CgProf
    import CgHeapery
    import CgBindery
    import CgCase
    import CgClosure
    import CgCon
    import CgLetNoEscape
    import CgTailCall
    import CgInfoTbls
    import CgForeignCall
    import CgPrimOp
    import CgHpc
    import CgUtils
    import ClosureInfo
    import Cmm
    import CmmUtils
    import VarSet
    import Literal
    import PrimOp
    import Id
    import TyCon
    import Type
    import Maybes
    import ListSetOps
    import BasicTypes
    import Util
    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)
    		    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
    		      nonVoidArg rep]

        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 . 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,
    -- and perform an appropriate return.

    cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
      = ASSERT(isEnumerationTyCon tycon)
        do	{ (_rep,amode) <- getArgAmode arg
    	; amode' <- assignTemp amode	-- We're going to use it twice,
    					-- so save in a temp if non-trivial
    	; 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
    	  -- 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 (StgOpApp (StgPrimOp primop) args res_ty)
      | primOpOutOfLine primop
    	= tailCallPrimOp primop args

      | ReturnsPrim VoidRep <- result_info
    	= do cgPrimOp [] primop args emptyVarSet
    	     performReturn emitReturnInstr

      | ReturnsPrim rep <- result_info
    	= 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 . CmmLocal) regs))

      | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
    	-- c.f. cgExpr (...TagToEnumOp...)
    	= do tag_reg <- newTemp bWord	-- The tag is a word
    	     cgPrimOp [tag_reg] primop args emptyVarSet
    	     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} %******************************************************** %* * %* 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)
      = setSRT srt $ cgCase expr live_vars save_vars bndr 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} %******************************************************** %* * %* 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 * %* * %******************************************************** \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)
      = setSRT srt $ mkRhsClosure name cc bi 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 :: 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-}])
    		      _ _ _ 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
      && 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.
        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 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    bndr cc bi
    		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 bndr cc bi fvs upd_flag args body
      = cgRhsClosure bndr cc bi fvs upd_flag args body

\end{code} %******************************************************** %* * %* Let-no-escape bindings %* * %******************************************************** \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
    					    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,_) <- 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
        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
    -- 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)
      = 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)

\end{code} Little helper for primitives that return unboxed tuples. \begin{code}

    newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
    newUnboxedTupleRegs res_ty =
       let
    	ty_args = tyConAppArgs (repType res_ty)
    	(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 make_new_temp reps
       return (reps,regs,hints)

\end{code}