Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 454 insertions, 0 deletions

diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
new file mode 100644
index 0000000000..33d72f1608
--- /dev/null
+++ b/compiler/codeGen/CgExpr.lhs
@@ -0,0 +1,454 @@
+%
+% (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}