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, 457 insertions, 0 deletions

diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
new file mode 100644
index 0000000000..bfb55bf46e
--- /dev/null
+++ b/compiler/codeGen/CgCon.lhs
@@ -0,0 +1,457 @@
+%
+% (c) The GRASP Project, Glasgow University, 1992-1998
+%
+\section[CgCon]{Code generation for constructors}
+
+This module provides the support code for @StgToAbstractC@ to deal
+with {\em constructors} on the RHSs of let(rec)s.  See also
+@CgClosure@, which deals with closures.
+
+\begin{code}
+module CgCon (
+	cgTopRhsCon, buildDynCon,
+	bindConArgs, bindUnboxedTupleComponents,
+	cgReturnDataCon,
+	cgTyCon
+    ) where
+
+#include "HsVersions.h"
+
+import CgMonad
+import StgSyn
+
+import CgBindery	( getArgAmodes, bindNewToNode,
+			  bindArgsToRegs, idInfoToAmode, stableIdInfo,
+			  heapIdInfo, CgIdInfo, bindArgsToStack
+			)
+import CgStackery	( mkVirtStkOffsets, freeStackSlots,
+			  getRealSp, getVirtSp, setRealAndVirtualSp )
+import CgUtils		( addIdReps, cmmLabelOffW, emitRODataLits, emitDataLits )
+import CgCallConv	( assignReturnRegs )
+import Constants	( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE )
+import CgHeapery	( allocDynClosure, layOutDynConstr, 
+			  layOutStaticConstr, mkStaticClosureFields )
+import CgTailCall	( performReturn, emitKnownConReturnCode, returnUnboxedTuple )
+import CgProf		( mkCCostCentreStack, ldvEnter, curCCS )
+import CgTicky
+import CgInfoTbls	( emitClosureCodeAndInfoTable, dataConTagZ )
+import CLabel
+import ClosureInfo	( mkConLFInfo, mkLFArgument )
+import CmmUtils		( mkLblExpr )
+import Cmm
+import SMRep		( WordOff, CgRep, separateByPtrFollowness,
+			  fixedHdrSize, typeCgRep )
+import CostCentre	( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
+			  currentCCS )
+import Constants	( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE )
+import TyCon		( TyCon, tyConDataCons, isEnumerationTyCon, tyConName )
+import DataCon		( DataCon, dataConRepArgTys, isNullaryRepDataCon,
+			  isUnboxedTupleCon, dataConWorkId, 
+			  dataConName, dataConRepArity
+			)
+import Id		( Id, idName, isDeadBinder )
+import Type		( Type )
+import PrelInfo		( maybeCharLikeCon, maybeIntLikeCon )
+import Outputable
+import Util		( lengthIs )
+import ListSetOps	( assocMaybe )
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[toplevel-constructors]{Top-level constructors}
+%*									*
+%************************************************************************
+
+\begin{code}
+cgTopRhsCon :: Id		-- Name of thing bound to this RHS
+	    -> DataCon		-- Id
+	    -> [StgArg]		-- Args
+	    -> FCode (Id, CgIdInfo)
+cgTopRhsCon id con args
+  = do { 
+	; hmods <- getHomeModules
+#if mingw32_TARGET_OS
+        -- Windows DLLs have a problem with static cross-DLL refs.
+        ; ASSERT( not (isDllConApp hmods con args) ) return ()
+#endif
+	; ASSERT( args `lengthIs` dataConRepArity con ) return ()
+
+	-- LAY IT OUT
+	; amodes <- getArgAmodes args
+
+	; let
+	    name          = idName id
+	    lf_info	  = mkConLFInfo con
+    	    closure_label = mkClosureLabel hmods name
+	    caffy         = any stgArgHasCafRefs args
+	    (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes
+	    closure_rep = mkStaticClosureFields
+	    		     closure_info
+	    		     dontCareCCS		-- Because it's static data
+	    		     caffy			-- Has CAF refs
+			     payload
+
+	    payload = map get_lit amodes_w_offsets	
+	    get_lit (CmmLit lit, _offset) = lit
+	    get_lit other = pprPanic "CgCon.get_lit" (ppr other)
+		-- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
+		-- NB2: all the amodes should be Lits!
+
+		-- BUILD THE OBJECT
+	; emitDataLits closure_label closure_rep
+
+		-- RETURN
+	; returnFC (id, stableIdInfo id (mkLblExpr closure_label) lf_info) }
+\end{code}
+
+%************************************************************************
+%*									*
+%* non-top-level constructors						*
+%*									*
+%************************************************************************
+\subsection[code-for-constructors]{The code for constructors}
+
+\begin{code}
+buildDynCon :: Id		  -- Name of the thing to which this constr will
+				  -- be bound
+	    -> CostCentreStack	  -- Where to grab cost centre from;
+				  -- current CCS if currentOrSubsumedCCS
+	    -> DataCon		  -- The data constructor
+	    -> [(CgRep,CmmExpr)] -- Its args
+	    -> FCode CgIdInfo	  -- Return details about how to find it
+
+-- We used to pass a boolean indicating whether all the
+-- args were of size zero, so we could use a static
+-- construtor; but I concluded that it just isn't worth it.
+-- Now I/O uses unboxed tuples there just aren't any constructors
+-- with all size-zero args.
+--
+-- The reason for having a separate argument, rather than looking at
+-- the addr modes of the args is that we may be in a "knot", and
+-- premature looking at the args will cause the compiler to black-hole!
+\end{code}
+
+First we deal with the case of zero-arity constructors.  Now, they
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
+
+In the case of zero-arity constructors, or, more accurately, those
+which have exclusively size-zero (VoidRep) args, we generate no code
+at all.
+
+\begin{code}
+buildDynCon binder cc con []
+  = do hmods <- getHomeModules
+       returnFC (stableIdInfo binder
+			   (mkLblExpr (mkClosureLabel hmods (dataConName con)))
+    			   (mkConLFInfo con))
+\end{code}
+
+The following three paragraphs about @Char@-like and @Int@-like
+closures are obsolete, but I don't understand the details well enough
+to properly word them, sorry. I've changed the treatment of @Char@s to
+be analogous to @Int@s: only a subset is preallocated, because @Char@
+has now 31 bits. Only literals are handled here. -- Qrczak
+
+Now for @Char@-like closures.  We generate an assignment of the
+address of the closure to a temporary.  It would be possible simply to
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
+
+Last special case: @Int@-like closures.  We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal.  Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
+
+Because of this, we use can safely return an addressing mode.
+
+\begin{code}
+buildDynCon binder cc con [arg_amode]
+  | maybeIntLikeCon con 
+  , (_, CmmLit (CmmInt val _)) <- arg_amode
+  , let val_int = (fromIntegral val) :: Int
+  , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
+  = do 	{ let intlike_lbl   = mkRtsDataLabel SLIT("stg_INTLIKE_closure")
+	      offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
+		-- INTLIKE closures consist of a header and one word payload
+	      intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
+	; returnFC (stableIdInfo binder intlike_amode (mkConLFInfo con)) }
+
+buildDynCon binder cc con [arg_amode]
+  | maybeCharLikeCon con 
+  , (_, CmmLit (CmmInt val _)) <- arg_amode
+  , let val_int = (fromIntegral val) :: Int
+  , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
+  = do 	{ let charlike_lbl   = mkRtsDataLabel SLIT("stg_CHARLIKE_closure")
+	      offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
+		-- CHARLIKE closures consist of a header and one word payload
+	      charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
+	; returnFC (stableIdInfo binder charlike_amode (mkConLFInfo con)) }
+\end{code}
+
+Now the general case.
+
+\begin{code}
+buildDynCon binder ccs con args
+  = do	{ 
+	; hmods <- getHomeModules
+	; let
+	    (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args
+
+	; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
+ 	; returnFC (heapIdInfo binder hp_off lf_info) }
+  where
+    lf_info = mkConLFInfo con
+
+    use_cc	-- cost-centre to stick in the object
+      | currentOrSubsumedCCS ccs = curCCS
+      | otherwise		 = CmmLit (mkCCostCentreStack ccs)
+
+    blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
+\end{code}
+
+
+%************************************************************************
+%*									*
+%* constructor-related utility function:				*
+%*		bindConArgs is called from cgAlt of a case		*
+%*									*
+%************************************************************************
+\subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
+
+@bindConArgs@ $con args$ augments the environment with bindings for the
+binders $args$, assuming that we have just returned from a @case@ which
+found a $con$.
+
+\begin{code}
+bindConArgs :: DataCon -> [Id] -> Code
+bindConArgs con args
+  = do hmods <- getHomeModules
+       let
+	  bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+	  (_, args_w_offsets)    = layOutDynConstr hmods con (addIdReps args)
+	--
+       ASSERT(not (isUnboxedTupleCon con)) return ()
+       mapCs bind_arg args_w_offsets
+\end{code}
+
+Unboxed tuples are handled slightly differently - the object is
+returned in registers and on the stack instead of the heap.
+
+\begin{code}
+bindUnboxedTupleComponents
+	:: [Id]				-- Args
+	-> FCode ([(Id,GlobalReg)],	-- Regs assigned
+		  WordOff,		-- Number of pointer stack slots
+		  WordOff,		-- Number of non-pointer stack slots
+		  VirtualSpOffset)	-- Offset of return address slot
+					-- (= realSP on entry)
+
+bindUnboxedTupleComponents args
+ =  do	{   
+	  vsp <- getVirtSp
+	; rsp <- getRealSp
+
+	   -- Assign as many components as possible to registers
+	; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
+
+		-- Separate the rest of the args into pointers and non-pointers
+	      (ptr_args, nptr_args) = separateByPtrFollowness stk_args
+  
+		-- Allocate the rest on the stack
+		-- The real SP points to the return address, above which any 
+	 	-- leftover unboxed-tuple components will be allocated
+	      (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets rsp    ptr_args
+	      (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args
+              ptrs  = ptr_sp  - rsp
+	      nptrs = nptr_sp - ptr_sp
+
+	    -- The stack pointer points to the last stack-allocated component
+    	; setRealAndVirtualSp nptr_sp
+
+	    -- We have just allocated slots starting at real SP + 1, and set the new
+	    -- virtual SP to the topmost allocated slot.  
+	    -- If the virtual SP started *below* the real SP, we've just jumped over
+	    -- some slots that won't be in the free-list, so put them there
+	    -- This commonly happens because we've freed the return-address slot
+	    -- (trimming back the virtual SP), but the real SP still points to that slot
+	; freeStackSlots [vsp+1,vsp+2 .. rsp]
+
+	; bindArgsToRegs reg_args
+	; bindArgsToStack ptr_offsets
+	; bindArgsToStack nptr_offsets
+
+	; returnFC (reg_args, ptrs, nptrs, rsp) }
+\end{code}
+
+%************************************************************************
+%*									*
+	Actually generate code for a constructor return
+%*									*
+%************************************************************************
+
+
+Note: it's the responsibility of the @cgReturnDataCon@ caller to be
+sure the @amodes@ passed don't conflict with each other.
+\begin{code}
+cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
+
+cgReturnDataCon con amodes
+  = ASSERT( amodes `lengthIs` dataConRepArity con )
+    do	{ EndOfBlockInfo _ sequel <- getEndOfBlockInfo
+	; case sequel of
+	    CaseAlts _ (Just (alts, deflt_lbl)) bndr _ 
+	      ->    -- Ho! We know the constructor so we can
+		    -- go straight to the right alternative
+		 case assocMaybe alts (dataConTagZ con) of {
+		    Just join_lbl -> build_it_then (jump_to join_lbl);
+		    Nothing
+			-- Special case!  We're returning a constructor to the default case
+			-- of an enclosing case.  For example:
+			--
+			--	case (case e of (a,b) -> C a b) of
+			--	  D x -> ...
+			--	  y   -> ...<returning here!>...
+			--
+			-- In this case,
+			--	if the default is a non-bind-default (ie does not use y),
+			--  	then we should simply jump to the default join point;
+    
+			| isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
+			| otherwise	    -> build_it_then (jump_to deflt_lbl) }
+    
+	    other_sequel	-- The usual case
+	      | isUnboxedTupleCon con -> returnUnboxedTuple amodes
+              | otherwise -> build_it_then (emitKnownConReturnCode con)
+	}
+  where
+    jump_to lbl = stmtC (CmmJump (CmmLit lbl) [])
+    build_it_then return_code
+      = do { 	-- BUILD THE OBJECT IN THE HEAP
+	   	-- The first "con" says that the name bound to this
+		-- closure is "con", which is a bit of a fudge, but it only
+		-- affects profiling
+
+		-- This Id is also used to get a unique for a
+		-- temporary variable, if the closure is a CHARLIKE.
+		-- funnily enough, this makes the unique always come
+		-- out as '54' :-)
+	     tickyReturnNewCon (length amodes)
+	   ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes
+	   ; amode <- idInfoToAmode idinfo
+	   ; checkedAbsC (CmmAssign nodeReg amode)
+	   ; performReturn return_code }
+\end{code}
+
+
+%************************************************************************
+%*									*
+	Generating static stuff for algebraic data types
+%*									*
+%************************************************************************
+
+	[These comments are rather out of date]
+
+\begin{tabular}{lll}
+Info tbls &	 Macro  &     	     Kind of constructor \\
+\hline
+info & @CONST_INFO_TABLE@&    Zero arity (no info -- compiler uses static closure)\\
+info & @CHARLIKE_INFO_TABLE@& Charlike   (no info -- compiler indexes fixed array)\\
+info & @INTLIKE_INFO_TABLE@&  Intlike; the one macro generates both info tbls\\
+info & @SPEC_INFO_TABLE@&     SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
+info & @GEN_INFO_TABLE@&      GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
+\end{tabular}
+
+Possible info tables for constructor con:
+
+\begin{description}
+\item[@_con_info@:]
+Used for dynamically let(rec)-bound occurrences of
+the constructor, and for updates.  For constructors
+which are int-like, char-like or nullary, when GC occurs,
+the closure tries to get rid of itself.
+
+\item[@_static_info@:]
+Static occurrences of the constructor
+macro: @STATIC_INFO_TABLE@.
+\end{description}
+
+For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
+it's place is taken by the top level defn of the constructor.
+
+For charlike and intlike closures there is a fixed array of static
+closures predeclared.
+
+\begin{code}
+cgTyCon :: TyCon -> FCode [Cmm]  -- each constructor gets a separate Cmm
+cgTyCon tycon
+  = do	{ constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
+
+	    -- Generate a table of static closures for an enumeration type
+	    -- Put the table after the data constructor decls, because the
+	    -- datatype closure table (for enumeration types)
+	    -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
+	; extra <- 
+	   if isEnumerationTyCon tycon then do
+	        tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel 
+						(tyConName tycon))
+			   [ CmmLabel (mkLocalClosureLabel (dataConName con))
+    			   | con <- tyConDataCons tycon])
+		return [tbl]
+	   else
+		return []
+
+	; return (extra ++ constrs)
+    }
+\end{code}
+
+Generate the entry code, info tables, and (for niladic constructor) the
+static closure, for a constructor.
+
+\begin{code}
+cgDataCon :: DataCon -> Code
+cgDataCon data_con
+  = do	{     -- Don't need any dynamic closure code for zero-arity constructors
+	  hmods <- getHomeModules
+
+	; let
+	    -- To allow the debuggers, interpreters, etc to cope with
+	    -- static data structures (ie those built at compile
+	    -- time), we take care that info-table contains the
+	    -- information we need.
+	    (static_cl_info, _) = 
+		layOutStaticConstr hmods data_con arg_reps
+
+	    (dyn_cl_info, arg_things) = 
+		layOutDynConstr    hmods data_con arg_reps
+
+	    emit_info cl_info ticky_code
+		= do { code_blks <- getCgStmts the_code
+		     ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+		where
+		  the_code = do	{ ticky_code
+				; ldvEnter (CmmReg nodeReg)
+				; body_code }
+
+	    arg_reps :: [(CgRep, Type)]
+	    arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
+
+	    body_code = do { 	
+			-- NB: We don't set CC when entering data (WDP 94/06)
+			     tickyReturnOldCon (length arg_things)
+			   ; performReturn (emitKnownConReturnCode data_con) }
+				-- noStmts: Ptr to thing already in Node
+
+	; whenC (not (isNullaryRepDataCon data_con))
+	 	(emit_info dyn_cl_info tickyEnterDynCon)
+
+		-- Dynamic-Closure first, to reduce forward references
+	; emit_info static_cl_info tickyEnterStaticCon }
+
+  where
+\end{code}