CgExpr.lhs 15.1 KB
Newer Older
1
%
2 3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
4
% $Id: CgExpr.lhs,v 1.37 2000/11/07 13:12:22 simonpj Exp $
5 6 7 8 9 10 11 12
%
%********************************************************
%*							*
\section[CgExpr]{Converting @StgExpr@s}
%*							*
%********************************************************

\begin{code}
13
module CgExpr ( cgExpr ) where
14

15
#include "HsVersions.h"
16

17
import Constants	( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
18 19 20
import StgSyn
import CgMonad
import AbsCSyn
sof's avatar
sof committed
21
import AbsCUtils	( mkAbstractCs )
22 23 24
import CLabel		( mkClosureTblLabel )

import SMRep		( fixedHdrSize )
25 26
import CgBindery	( getArgAmodes, getArgAmode, CgIdInfo, 
			  nukeDeadBindings, addBindC, addBindsC )
27
import CgCase		( cgCase, saveVolatileVarsAndRegs, 
28
			  restoreCurrentCostCentre )
29
import CgClosure	( cgRhsClosure, cgStdRhsClosure )
30 31
import CgCon		( buildDynCon, cgReturnDataCon )
import CgLetNoEscape	( cgLetNoEscapeClosure )
32 33 34 35
import CgRetConv	( dataReturnConvPrim )
import CgTailCall	( cgTailCall, performReturn, performPrimReturn,
			  mkDynamicAlgReturnCode, mkPrimReturnCode,
			  tailCallPrimOp, returnUnboxedTuple
36
			)
37 38
import ClosureInfo	( mkClosureLFInfo, mkSelectorLFInfo,
			  mkApLFInfo, layOutDynCon )
39
import CostCentre	( sccAbleCostCentre, isSccCountCostCentre )
40 41
import Id		( idPrimRep, idType, Id )
import VarSet
42 43 44
import DataCon		( dataConTyCon )
import PrimOp		( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
import PrimRep		( PrimRep(..), isFollowableRep )
45 46
import TyCon		( maybeTyConSingleCon,
			  isUnboxedTupleTyCon, isEnumerationTyCon )
47
import Type		( Type, typePrimRep, splitTyConApp_maybe, repType )
48 49
import Maybes		( maybeToBool )
import ListSetOps	( assocMaybe )
50 51
import Unique		( mkBuiltinUnique )
import BasicTypes	( TopLevelFlag(..), RecFlag(..) )
52
import Outputable
53 54 55 56 57 58 59
\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}
60
cgExpr	:: StgExpr		-- input
61 62 63 64 65 66 67 68 69 70 71
	-> Code			-- output
\end{code}

%********************************************************
%*							*
%*		Tail calls				*
%*							*
%********************************************************

``Applications'' mean {\em tail calls}, a service provided by module
@CgTailCall@.  This includes literals, which show up as
72
@(STGApp (StgLitArg 42) [])@.
73 74

\begin{code}
75
cgExpr (StgApp fun args) = cgTailCall fun args
76 77 78 79 80 81 82 83 84
\end{code}

%********************************************************
%*							*
%*		STG ConApps  (for inline versions)	*
%*							*
%********************************************************

\begin{code}
85
cgExpr (StgConApp con args)
86
  = getArgAmodes args `thenFC` \ amodes ->
87
    cgReturnDataCon con amodes
88 89
\end{code}

90 91 92 93 94
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}
95 96
cgExpr (StgLit lit)
  = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
97 98 99
\end{code}


100 101 102 103 104 105 106 107
%********************************************************
%*							*
%*		STG PrimApps  (unboxed primitive ops)	*
%*							*
%********************************************************

Here is where we insert real live machine instructions.

108 109
NOTE about _ccall_GC_:

110 111 112 113 114 115
A _ccall_GC_ is treated as an out-of-line primop (returns True
for primOpOutOfLine) so that when we see the call in case context
	case (ccall ...) of { ... }
we get a proper stack frame on the stack when we perform it.  When we
get in a tail-call position, however, we need to actually perform the
call, so we treat it as an inline primop.
116

117
\begin{code}
118
cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty)
119 120
  = primRetUnboxedTuple op args res_ty

121 122 123
-- tagToEnum# is special: we need to pull the constructor out of the table,
-- and perform an appropriate return.

124
cgExpr (StgPrimApp TagToEnumOp [arg] res_ty) 
125 126 127 128 129 130 131
  = ASSERT(isEnumerationTyCon tycon)
    getArgAmode arg `thenFC` \amode ->
	-- save the tag in a temporary in case amode overlaps
	-- with node.
    absC (CAssign dyn_tag amode)	`thenC`
    performReturn (
		CAssign (CReg node) 
132
			(CVal (CIndex
133
		          (CLbl (mkClosureTblLabel tycon) PtrRep)
134
		          dyn_tag PtrRep) PtrRep))
135
	    (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
136
   where
137
        dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
sof's avatar
sof committed
138 139 140 141 142 143 144 145
	  --
	  -- 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.
          --
146 147 148
	(Just (tycon,_)) = splitTyConApp_maybe res_ty


149
cgExpr x@(StgPrimApp op args res_ty)
150 151
  | primOpOutOfLine op = tailCallPrimOp op args
  | otherwise
152
  = ASSERT(op /= SeqOp) -- can't handle SeqOp
153 154

    getArgAmodes args	`thenFC` \ arg_amodes ->
155 156 157 158

    case (getPrimOpResultInfo op) of

	ReturnsPrim kind ->
159 160 161
	    let result_amode = CReg (dataReturnConvPrim kind) in
	    performReturn 
	      (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
162
	      (mkPrimReturnCode (text "primapp)" <+> ppr x))
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
			  
	-- otherwise, must be returning an enumerated type (eg. Bool).
	-- we've only got the tag in R2, so we have to load the constructor
	-- itself into R1.

	ReturnsAlg tycon
	    | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty

	    | isEnumerationTyCon  tycon ->
	     	performReturn
	      	     (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
			  (\ sequel -> 
			  absC (CAssign (CReg node) closure_lbl) `thenC`
			  mkDynamicAlgReturnCode tycon dyn_tag sequel)

            where
	       -- Pull a unique out of thin air to put the tag in.  
	       -- It shouldn't matter if this overlaps with anything - we're
	       -- about to return anyway.
	       dyn_tag = CTemp (mkBuiltinUnique 0) IntRep

184
	       closure_lbl = CVal (CIndex
185
			       (CLbl (mkClosureTblLabel tycon) PtrRep)
186
			       dyn_tag PtrRep) PtrRep
187

188 189 190 191 192 193 194 195 196 197 198
\end{code}

%********************************************************
%*							*
%*		Case expressions			*
%*							*
%********************************************************
Case-expression conversion is complicated enough to have its own
module, @CgCase@.
\begin{code}

199 200
cgExpr (StgCase expr live_vars save_vars bndr srt alts)
  = cgCase expr live_vars save_vars bndr srt alts
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
\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)
  =    	-- Figure out what volatile variables to save
    nukeDeadBindings live_in_whole_let	`thenC`
230
    saveVolatileVarsAndRegs live_in_rhss
231
    	    `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
232 233
    -- ToDo: cost centre???
    restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
234

235
	-- Save those variables right now!
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255
    absC save_assts				`thenC`

	-- Produce code for the rhss
	-- and add suitable bindings to the environment
    cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`

	-- 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}
256
cgExpr (StgSCC cc expr)
257 258
  = ASSERT(sccAbleCostCentre cc)
    costCentresC
259
	SLIT("SET_CCC")
260 261 262
	[mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
    `thenC`
    cgExpr expr
263 264
\end{code}

265
ToDo: counting of dict sccs ...
266 267 268 269 270 271 272 273 274 275 276 277

%********************************************************
%*							*
%*		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}
278
cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
279 280 281
	-- the Id is passed along so a binding can be set up

cgRhs name (StgRhsCon maybe_cc con args)
282 283
  = getArgAmodes args				`thenFC` \ amodes ->
    buildDynCon name maybe_cc con amodes	`thenFC` \ idinfo ->
284 285
    returnFC (name, idinfo)

286 287 288 289
cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
  = mkRhsClosure name cc bi srt fvs upd_flag args body
cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
  = mkRhsClosure name cc bi srt fvs upd_flag args body
290 291
\end{code}

292
mkRhsClosure looks for two special forms of the right-hand side:
293
	a) selector thunks.
294
	b) AP thunks
295 296

If neither happens, it just calls mkClosureLFInfo.  You might think
297 298
that mkClosureLFInfo should do all this, but it seems wrong for the
latter to look at the structure of an expression
299 300 301 302 303 304

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:
305

306 307 308
...  = [the_fv] \ u [] ->
	 case the_fv of
	   con a_1 ... a_n -> a_i
309

310 311

\begin{code}
312 313 314
mkRhsClosure	bndr cc	bi srt
		[the_fv]   		-- Just one free var
		upd_flag		-- Updatable thunk
315
		[]			-- A thunk
316 317
		body@(StgCase (StgApp scrutinee [{-no args-}])
		      _ _ _ _   -- ignore uniq, etc.
318 319
		      (StgAlgAlts case_ty
		  	 [(con, params, use_mask,
320
			    (StgApp selectee [{-no args-}]))]
321 322 323 324
		  	 StgNoDefault))
  |  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
325
  = ASSERT(is_single_constructor)
326
    cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
327
  where
328 329
    lf_info 		  = mkSelectorLFInfo (idType bndr) offset_into_int 
				(isUpdatable upd_flag)
330 331 332
    (_, params_w_offsets) = layOutDynCon con idPrimRep params
    maybe_offset	  = assocMaybe params_w_offsets selectee
    Just the_offset 	  = maybe_offset
333
    offset_into_int       = the_offset - fixedHdrSize
334 335
    is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
    tycon		  = dataConTyCon con
336 337
\end{code}

338

339 340
Ap thunks
~~~~~~~~~
341

342
A more generic AP thunk of the form
343

344 345 346 347 348 349 350 351 352 353
	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.
354 355

\begin{code}
356 357
mkRhsClosure 	bndr cc bi srt
		fvs
358 359
		upd_flag
		[]			-- No args; a thunk
360 361 362 363 364 365 366 367
		body@(StgApp fun_id args)

  | length args + 1 == arity
 	&& all isFollowableRep (map idPrimRep fvs) 
 	&& isUpdatable upd_flag
 	&& arity <= mAX_SPEC_AP_SIZE 

 		   -- Ha! an Ap thunk
368
	= cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
369 370 371 372 373 374 375

   where
	lf_info = mkApLFInfo (idType 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
376 377 378 379 380
\end{code}

The default case
~~~~~~~~~~~~~~~~
\begin{code}
381
mkRhsClosure bndr cc bi srt fvs upd_flag args body
382 383 384 385 386
  = getSRTLabel		`thenFC` \ srt_label ->
    let lf_info = 
	  mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
    in
    cgRhsClosure bndr cc bi fvs args body lf_info
387 388 389 390 391 392 393 394
\end{code}


%********************************************************
%*							*
%*		Let-no-escape bindings
%*							*
%********************************************************
395 396
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
397 398
  = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot 	
			NonRecursive binder rhs 
399 400 401 402 403 404
    	    	    	    	`thenFC` \ (binder, info) ->
    addBindC binder info

cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
  = fixC (\ new_bindings ->
		addBindsC new_bindings 	`thenC`
405 406 407
		listFCs [ cgLetNoEscapeRhs full_live_in_rhss 
				rhs_eob_info maybe_cc_slot Recursive b e 
			| (b,e) <- pairs ]
408 409 410 411 412 413
    ) `thenFC` \ new_bindings ->

    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!
414
    full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
415

416 417 418
cgLetNoEscapeRhs
    :: StgLiveVars	-- Live in rhss
    -> EndOfBlockInfo
419 420
    -> Maybe VirtualSpOffset
    -> RecFlag
421
    -> Id
422
    -> StgRhs
423 424
    -> FCode (Id, CgIdInfo)

425 426
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
		 (StgRhsClosure cc bi srt _ upd_flag args body)
427 428 429 430 431
  = -- 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
432
    cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
433

434
-- For a constructor RHS we want to generate a single chunk of code which
435 436
-- 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!
437
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
438
    	    	 (StgRhsCon cc con args)
439
  = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
440
	[] 	--No args; the binder is data structure, not a function
441
	(StgConApp con args)
442 443
\end{code}

444
Little helper for primitives that return unboxed tuples.
445 446 447


\begin{code}
448 449
primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
sof's avatar
sof committed
450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465
  = getArgAmodes args	    `thenFC` \ arg_amodes ->
    {-
      put all the arguments in temporaries so they don't get stomped when
      we push the return address.
    -}
    let
      n_args		  = length args
      arg_uniqs	          = map mkBuiltinUnique [0 .. n_args-1]
      arg_reps		  = map getArgPrimRep args
      arg_temps		  = zipWith CTemp arg_uniqs arg_reps
    in
    absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
    {-
      allocate some temporaries for the return values.
    -}
    let
466
      (tc,ty_args)      = case splitTyConApp_maybe (repType res_ty) of
sof's avatar
sof committed
467 468 469 470 471
			    Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
			    Just pr -> pr
      prim_reps          = map typePrimRep ty_args
      temp_uniqs         = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
      temp_amodes        = zipWith CTemp temp_uniqs prim_reps
472
    in
sof's avatar
sof committed
473
    returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
474
\end{code}